[Midnightbsd-cvs] src [6438] U trunk/contrib/perl: perl 5.18.1 merge
laffer1 at midnightbsd.org
laffer1 at midnightbsd.org
Mon Dec 2 16:18:19 EST 2013
Revision: 6438
http://svnweb.midnightbsd.org/src/?rev=6438
Author: laffer1
Date: 2013-12-02 16:18:17 -0500 (Mon, 02 Dec 2013)
Log Message:
-----------
perl 5.18.1 merge
Modified Paths:
--------------
trunk/contrib/perl/EXTERN.h
trunk/contrib/perl/Makefile.SH
trunk/contrib/perl/Policy_sh.SH
trunk/contrib/perl/XSUB.h
trunk/contrib/perl/autodoc.pl
trunk/contrib/perl/av.c
trunk/contrib/perl/av.h
trunk/contrib/perl/cflags.SH
trunk/contrib/perl/config_h.SH
trunk/contrib/perl/cop.h
trunk/contrib/perl/cv.h
trunk/contrib/perl/deb.c
trunk/contrib/perl/doio.c
trunk/contrib/perl/doop.c
trunk/contrib/perl/dosish.h
trunk/contrib/perl/dquote_static.c
trunk/contrib/perl/dump.c
trunk/contrib/perl/embed.h
trunk/contrib/perl/embedvar.h
trunk/contrib/perl/fakesdio.h
trunk/contrib/perl/fakethr.h
trunk/contrib/perl/form.h
trunk/contrib/perl/generate_uudmap.c
trunk/contrib/perl/globals.c
trunk/contrib/perl/gv.c
trunk/contrib/perl/gv.h
trunk/contrib/perl/handy.h
trunk/contrib/perl/hv.c
trunk/contrib/perl/hv.h
trunk/contrib/perl/install_lib.pl
trunk/contrib/perl/intrpvar.h
trunk/contrib/perl/iperlsys.h
trunk/contrib/perl/keywords.c
trunk/contrib/perl/keywords.h
trunk/contrib/perl/l1_char_class_tab.h
trunk/contrib/perl/locale.c
trunk/contrib/perl/madly.c
trunk/contrib/perl/make_ext.pl
trunk/contrib/perl/make_patchnum.pl
trunk/contrib/perl/makedef.pl
trunk/contrib/perl/makedepend.SH
trunk/contrib/perl/malloc.c
trunk/contrib/perl/mathoms.c
trunk/contrib/perl/metaconfig.h
trunk/contrib/perl/mg.c
trunk/contrib/perl/mg.h
trunk/contrib/perl/minimod.pl
trunk/contrib/perl/miniperlmain.c
trunk/contrib/perl/mro.c
trunk/contrib/perl/myconfig.SH
trunk/contrib/perl/mydtrace.h
trunk/contrib/perl/nostdio.h
trunk/contrib/perl/numeric.c
trunk/contrib/perl/op.c
trunk/contrib/perl/op.h
trunk/contrib/perl/op_reg_common.h
trunk/contrib/perl/opcode.h
trunk/contrib/perl/opnames.h
trunk/contrib/perl/overload.c
trunk/contrib/perl/overload.h
trunk/contrib/perl/pad.c
trunk/contrib/perl/pad.h
trunk/contrib/perl/parser.h
trunk/contrib/perl/patchlevel.h
trunk/contrib/perl/perl.c
trunk/contrib/perl/perl.h
trunk/contrib/perl/perlapi.c
trunk/contrib/perl/perlapi.h
trunk/contrib/perl/perlio.c
trunk/contrib/perl/perlio.h
trunk/contrib/perl/perliol.h
trunk/contrib/perl/perlsdio.h
trunk/contrib/perl/perlsfio.h
trunk/contrib/perl/perlvars.h
trunk/contrib/perl/perly.c
trunk/contrib/perl/perly.h
trunk/contrib/perl/pp.c
trunk/contrib/perl/pp.h
trunk/contrib/perl/pp_ctl.c
trunk/contrib/perl/pp_hot.c
trunk/contrib/perl/pp_pack.c
trunk/contrib/perl/pp_proto.h
trunk/contrib/perl/pp_sort.c
trunk/contrib/perl/pp_sys.c
trunk/contrib/perl/proto.h
trunk/contrib/perl/reentr.c
trunk/contrib/perl/regcharclass.h
trunk/contrib/perl/regcomp.c
trunk/contrib/perl/regcomp.h
trunk/contrib/perl/regen.pl
trunk/contrib/perl/regen_perly.pl
trunk/contrib/perl/regexec.c
trunk/contrib/perl/regexp.h
trunk/contrib/perl/regnodes.h
trunk/contrib/perl/run.c
trunk/contrib/perl/runtests.SH
trunk/contrib/perl/scope.c
trunk/contrib/perl/scope.h
trunk/contrib/perl/sv.c
trunk/contrib/perl/sv.h
trunk/contrib/perl/taint.c
trunk/contrib/perl/thread.h
trunk/contrib/perl/time64.c
trunk/contrib/perl/toke.c
trunk/contrib/perl/uconfig.h
trunk/contrib/perl/universal.c
trunk/contrib/perl/unixish.h
trunk/contrib/perl/utf8.c
trunk/contrib/perl/utf8.h
trunk/contrib/perl/utfebcdic.h
trunk/contrib/perl/util.c
trunk/contrib/perl/util.h
trunk/contrib/perl/warnings.h
trunk/contrib/perl/write_buildcustomize.pl
Added Paths:
-----------
trunk/contrib/perl/charclass_invlists.h
trunk/contrib/perl/feature.h
trunk/contrib/perl/hv_func.h
trunk/contrib/perl/inline.h
trunk/contrib/perl/inline_invlist.c
trunk/contrib/perl/mg_names.c
trunk/contrib/perl/mg_raw.h
trunk/contrib/perl/mg_vtable.h
trunk/contrib/perl/unicode_constants.h
Property Changed:
----------------
trunk/contrib/perl/EXTERN.h
trunk/contrib/perl/INTERN.h
trunk/contrib/perl/Makefile.SH
trunk/contrib/perl/Policy_sh.SH
trunk/contrib/perl/XSUB.h
trunk/contrib/perl/autodoc.pl
trunk/contrib/perl/av.c
trunk/contrib/perl/av.h
trunk/contrib/perl/cflags.SH
trunk/contrib/perl/config_h.SH
trunk/contrib/perl/cop.h
trunk/contrib/perl/cv.h
trunk/contrib/perl/deb.c
trunk/contrib/perl/doio.c
trunk/contrib/perl/doop.c
trunk/contrib/perl/dosish.h
trunk/contrib/perl/dquote_static.c
trunk/contrib/perl/dump.c
trunk/contrib/perl/embed.h
trunk/contrib/perl/embedvar.h
trunk/contrib/perl/fakesdio.h
trunk/contrib/perl/fakethr.h
trunk/contrib/perl/form.h
trunk/contrib/perl/generate_uudmap.c
trunk/contrib/perl/genpacksizetables.pl
trunk/contrib/perl/globals.c
trunk/contrib/perl/gv.c
trunk/contrib/perl/gv.h
trunk/contrib/perl/handy.h
trunk/contrib/perl/hv.c
trunk/contrib/perl/hv.h
trunk/contrib/perl/install_lib.pl
trunk/contrib/perl/intrpvar.h
trunk/contrib/perl/iperlsys.h
trunk/contrib/perl/keywords.c
trunk/contrib/perl/keywords.h
trunk/contrib/perl/l1_char_class_tab.h
trunk/contrib/perl/locale.c
trunk/contrib/perl/madly.c
trunk/contrib/perl/make_ext.pl
trunk/contrib/perl/make_patchnum.pl
trunk/contrib/perl/makedef.pl
trunk/contrib/perl/makedepend.SH
trunk/contrib/perl/malloc.c
trunk/contrib/perl/malloc_ctl.h
trunk/contrib/perl/mathoms.c
trunk/contrib/perl/metaconfig.SH
trunk/contrib/perl/metaconfig.h
trunk/contrib/perl/mg.c
trunk/contrib/perl/mg.h
trunk/contrib/perl/minimod.pl
trunk/contrib/perl/miniperlmain.c
trunk/contrib/perl/mro.c
trunk/contrib/perl/myconfig.SH
trunk/contrib/perl/mydtrace.h
trunk/contrib/perl/nostdio.h
trunk/contrib/perl/numeric.c
trunk/contrib/perl/op.c
trunk/contrib/perl/op.h
trunk/contrib/perl/op_reg_common.h
trunk/contrib/perl/opcode.h
trunk/contrib/perl/opnames.h
trunk/contrib/perl/overload.c
trunk/contrib/perl/overload.h
trunk/contrib/perl/pad.c
trunk/contrib/perl/pad.h
trunk/contrib/perl/parser.h
trunk/contrib/perl/patchlevel.h
trunk/contrib/perl/perl.c
trunk/contrib/perl/perl.h
trunk/contrib/perl/perlapi.c
trunk/contrib/perl/perlapi.h
trunk/contrib/perl/perlio.c
trunk/contrib/perl/perlio.h
trunk/contrib/perl/perliol.h
trunk/contrib/perl/perlsdio.h
trunk/contrib/perl/perlsfio.h
trunk/contrib/perl/perlvars.h
trunk/contrib/perl/perly.c
trunk/contrib/perl/perly.h
trunk/contrib/perl/pp.c
trunk/contrib/perl/pp.h
trunk/contrib/perl/pp_ctl.c
trunk/contrib/perl/pp_hot.c
trunk/contrib/perl/pp_pack.c
trunk/contrib/perl/pp_proto.h
trunk/contrib/perl/pp_sort.c
trunk/contrib/perl/pp_sys.c
trunk/contrib/perl/proto.h
trunk/contrib/perl/reentr.c
trunk/contrib/perl/reentr.h
trunk/contrib/perl/regcharclass.h
trunk/contrib/perl/regcomp.c
trunk/contrib/perl/regcomp.h
trunk/contrib/perl/regen.pl
trunk/contrib/perl/regen_perly.pl
trunk/contrib/perl/regexec.c
trunk/contrib/perl/regexp.h
trunk/contrib/perl/regnodes.h
trunk/contrib/perl/run.c
trunk/contrib/perl/runtests.SH
trunk/contrib/perl/scope.c
trunk/contrib/perl/scope.h
trunk/contrib/perl/sv.c
trunk/contrib/perl/sv.h
trunk/contrib/perl/taint.c
trunk/contrib/perl/thread.h
trunk/contrib/perl/time64.c
trunk/contrib/perl/time64.h
trunk/contrib/perl/time64_config.h
trunk/contrib/perl/toke.c
trunk/contrib/perl/uconfig.h
trunk/contrib/perl/universal.c
trunk/contrib/perl/unixish.h
trunk/contrib/perl/utf8.c
trunk/contrib/perl/utf8.h
trunk/contrib/perl/utfebcdic.h
trunk/contrib/perl/util.c
trunk/contrib/perl/util.h
trunk/contrib/perl/warnings.h
trunk/contrib/perl/write_buildcustomize.pl
Modified: trunk/contrib/perl/EXTERN.h
===================================================================
--- trunk/contrib/perl/EXTERN.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/EXTERN.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -29,16 +29,24 @@
# define dEXTCONST globaldef {"$GLOBAL_RO_VARS"} readonly
#else
# if (defined(WIN32) || defined(__SYMBIAN32__)) && !defined(PERL_STATIC_SYMS)
-# if defined(PERLDLL) || defined(__SYMBIAN32__)
-# define EXT extern __declspec(dllexport)
+ /* miniperl should not export anything */
+# if defined(PERL_IS_MINIPERL) && !defined(UNDER_CE) && defined(_MSC_VER)
+# define EXT extern
# define dEXT
-# define EXTCONST extern __declspec(dllexport) const
+# define EXTCONST extern const
# define dEXTCONST const
# else
-# define EXT extern __declspec(dllimport)
-# define dEXT
-# define EXTCONST extern __declspec(dllimport) const
-# define dEXTCONST const
+# if defined(PERLDLL) || defined(__SYMBIAN32__)
+# define EXT extern __declspec(dllexport)
+# define dEXT
+# define EXTCONST extern __declspec(dllexport) const
+# define dEXTCONST const
+# else
+# define EXT extern __declspec(dllimport)
+# define dEXT
+# define EXTCONST extern __declspec(dllimport) const
+# define dEXTCONST const
+# endif
# endif
# else
# if defined(__CYGWIN__) && defined(USEIMPORTLIB)
Property changes on: trunk/contrib/perl/EXTERN.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/INTERN.h
===================================================================
--- trunk/contrib/perl/INTERN.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/INTERN.h 2013-12-02 21:18:17 UTC (rev 6438)
Property changes on: trunk/contrib/perl/INTERN.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/Makefile.SH
===================================================================
--- trunk/contrib/perl/Makefile.SH 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/Makefile.SH 2013-12-02 21:18:17 UTC (rev 6438)
@@ -1,3 +1,14 @@
+#!/bin/sh
+
+# quote() - Creates a shell literal
+# Usage: echo "...` quote "..." `..."
+quote() {
+ case "$1" in
+ '') echo "''" ;;
+ *) echo "$1" | sed 's/\([^a-zA-Z0-9.:_\-\/]\)/\\\1/g' ;;
+ esac
+}
+
case $PERL_CONFIG_SH in
'')
if test -f config.sh
@@ -26,6 +37,7 @@
*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
esac
+pwd="`pwd`"
linklibperl='$(LIBPERL)'
linklibperl_nonshr=''
shrpldflags='$(LDDLFLAGS)'
@@ -37,10 +49,8 @@
# Prefix all runs of 'miniperl' and 'perl' with
# $ldlibpth so that ./perl finds *this* shared libperl.
case "$LD_LIBRARY_PATH" in
- '')
- ldlibpth="LD_LIBRARY_PATH=`pwd`";;
- *)
- ldlibpth="LD_LIBRARY_PATH=`pwd`:${LD_LIBRARY_PATH}";;
+ '') ldlibpth="LD_LIBRARY_PATH=` quote "$pwd" `" ;;
+ *) ldlibpth="LD_LIBRARY_PATH=` quote "$pwd" `:` quote "$LD_LIBRARY_PATH" `" ;;
esac
pldlflags="$cccdlflags"
@@ -52,7 +62,7 @@
-compatibility_version 1 -current_version $patchlevel \
-prebind -seg1addr 0x27000000 -install_name \$(shrpdir)/\$@"
;;
- rhapsody*|darwin*)
+ darwin*)
shrpldflags="${ldflags} -dynamiclib \
-compatibility_version \
${api_revision}.${api_version}.${api_subversion} \
@@ -119,19 +129,19 @@
ldlibpth=''
;;
*)
- eval "ldlibpth=\"$ldlibpthname=`pwd`:\$$ldlibpthname\""
+ eval "ldlibpthval=\"\$$ldlibpthname\""
+
+ case "$ldlibpthval" in
+ '') ldlibpth="$ldlibpthname=` quote "$pwd" `" ;;
+ *) ldlibpth="$ldlibpthname=` quote "$pwd" `:` quote "$ldlibpthval" `" ;;
+ esac
+
;;
esac
- # Strip off any trailing :'s
- ldlibpth=`echo $ldlibpth | sed 's/:*$//'`
+
;;
esac
- case "$ldlibpth" in
- # Protect any spaces
- *" "*) ldlibpth=`echo $ldlibpth|sed 's/ /\\\\ /g'` ;;
- esac
-
case "$osname" in
linux)
# If there is a pre-existing $libperl from a previous
@@ -164,10 +174,22 @@
;;
esac
+: is Cwd static or dynamic
+static_cwd='define'
+list_util_dep='$(PERL_EXE)'
+for f in $dynamic_ext; do
+ case $f in
+ Cwd) static_cwd='undef' ;;
+ List/Util) list_util_dep=lib/auto/List/Util/Util.$dlext
+ esac
+done
+
: Prepare dependency lists for Makefile.
dynamic_list=' '
dynamic_ext_re="lib/auto/re/re.$dlext"
-extra_dep=''
+extra_dep='
+ext/Pod-Functions/pm_to_blib: cpan/Pod-Simple/pm_to_blib cpan/Pod-Escapes/pm_to_blib pod/perlfunc.pod
+'
for f in $dynamic_ext; do
: the dependency named here will never exist
base=`echo "$f" | sed 's/.*\///'`
@@ -176,16 +198,10 @@
: Parallel makes reveal that we have some interdependencies
case $f in
- Encode) extra_dep="$extra_dep
-$this_target: lib/auto/Cwd/Cwd.$dlext" ;;
Math/BigInt/FastCalc|Devel/NYTProf) extra_dep="$extra_dep
-$this_target: lib/auto/List/Util/Util.$dlext" ;;
+$this_target: $list_util_dep" ;;
Unicode/Normalize) extra_dep="$extra_dep
$this_target: uni.data" ;;
- Text/ParseWords) extra_dep="$extra_dep
-$this_target: lib/auto/Scalar/Util.$dlext" ;;
- SDBM_File) extra_dep="$extra_dep
-$this_target: lib/auto/Cwd/Cwd.$dlext" ;;
esac
done
@@ -290,7 +306,7 @@
# These variables may need to be manually set for non-Unix systems.
AR = $full_ar
-HOST_EXE_EXT =
+HOST_EXE_EXT = $_exe
EXE_EXT = $_exe
LIB_EXT = $_a
OBJ_EXT = $_o
@@ -327,10 +343,21 @@
# Mention $gmake here so it gets probed for by Configure.
+!GROK!THIS!
+
+case "${osname}" in
+linux*|darwin)
+$spitshell >>$Makefile <<!GROK!THIS!
# If you're going to use valgrind and it can't be invoked as plain valgrind
# then you'll need to change this, or override it on the make command line.
-VALGRIND=valgrind
+VALGRIND ?= valgrind
+VG_TEST ?= ./perl -e 1 2>/dev/null
+!GROK!THIS!
+ ;;
+esac
+
+$spitshell >>$Makefile <<!GROK!THIS!
DTRACE = $dtrace
DTRACE_H = $dtrace_h
DTRACE_O = $dtrace_o
@@ -432,6 +459,7 @@
# Unicode data files generated by mktables
unidatafiles = lib/unicore/Decomposition.pl lib/unicore/TestProp.pl \
lib/unicore/CombiningClass.pl lib/unicore/Name.pl \
+ lib/unicore/UCD.pl lib/unicore/Name.pm \
lib/unicore/Heavy.pl lib/unicore/mktables.lst
# Directories of Unicode data files generated by mktables
@@ -438,11 +466,12 @@
unidatadirs = lib/unicore/To lib/unicore/lib
h1 = EXTERN.h INTERN.h XSUB.h av.h $(CONFIGH) cop.h cv.h dosish.h
-h2 = embed.h form.h gv.h handy.h hv.h keywords.h mg.h op.h opcode.h
+h2 = embed.h form.h gv.h handy.h hv.h hv_func.h keywords.h mg.h op.h opcode.h
h3 = pad.h patchlevel.h perl.h perlapi.h perly.h pp.h proto.h regcomp.h
h4 = regexp.h scope.h sv.h unixish.h util.h iperlsys.h thread.h
h5 = utf8.h warnings.h mydtrace.h op_reg_common.h l1_char_class_tab.h
-h = $(h1) $(h2) $(h3) $(h4) $(h5)
+h6 = charclass_invlists.h
+h = $(h1) $(h2) $(h3) $(h4) $(h5) $(h6)
c1 = av.c scope.c op.c doop.c doio.c dump.c gv.c hv.c mg.c reentr.c mro.c perl.c
c2 = perly.c pp.c pp_hot.c pp_ctl.c pp_sys.c regcomp.c regexec.c utf8.c sv.c
@@ -453,19 +482,21 @@
c = $(c1) $(c2) $(c3) $(c4) $(c5) miniperlmain.c opmini.c perlmini.c
obj0 = op$(OBJ_EXT) perl$(OBJ_EXT)
+obj0mini = perlmini$(OBJ_EXT) opmini$(OBJ_EXT) miniperlmain$(OBJ_EXT)
obj1 = $(madlyobj) $(mallocobj) gv$(OBJ_EXT) toke$(OBJ_EXT) perly$(OBJ_EXT) pad$(OBJ_EXT) regcomp$(OBJ_EXT) dump$(OBJ_EXT) util$(OBJ_EXT) mg$(OBJ_EXT) reentr$(OBJ_EXT) mro$(OBJ_EXT) keywords$(OBJ_EXT)
obj2 = hv$(OBJ_EXT) av$(OBJ_EXT) run$(OBJ_EXT) pp_hot$(OBJ_EXT) sv$(OBJ_EXT) pp$(OBJ_EXT) scope$(OBJ_EXT) pp_ctl$(OBJ_EXT) pp_sys$(OBJ_EXT)
obj3 = doop$(OBJ_EXT) doio$(OBJ_EXT) regexec$(OBJ_EXT) utf8$(OBJ_EXT) taint$(OBJ_EXT) deb$(OBJ_EXT) universal$(OBJ_EXT) globals$(OBJ_EXT) perlio$(OBJ_EXT) perlapi$(OBJ_EXT) numeric$(OBJ_EXT) mathoms$(OBJ_EXT) locale$(OBJ_EXT) pp_pack$(OBJ_EXT) pp_sort$(OBJ_EXT)
-minindt_obj = $(obj1) $(obj2) $(obj3) $(ARCHOBJS)
+minindt_obj = $(obj0mini) $(obj1) $(obj2) $(obj3) $(ARCHOBJS)
mini_obj = $(minindt_obj) $(MINIDTRACE_O)
ndt_obj = $(obj0) $(obj1) $(obj2) $(obj3) $(ARCHOBJS)
obj = $(ndt_obj) $(DTRACE_O)
-perltoc_pod_prereqs = extra.pods pod/perl5142delta.pod pod/perlapi.pod pod/perlintern.pod pod/perlmodlib.pod pod/perluniprops.pod
+perltoc_pod_prereqs = extra.pods pod/perl5181delta.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
-Icwd = -Idist/Cwd -Idist/Cwd/lib
+Icwd = -Idist/Cwd -Idist/Cwd/lib -Idist/Carp/lib
lintflags = \
-b \
@@ -555,11 +586,15 @@
# Making utilities and translators require Cwd. If we have dynamic
# loading, we only need miniperl and Cwd.$dlext. If we have static
# loading, we need to build perl first.
-case "$usedl" in
-define)
+case "$usedl$static_cwd" in
+defineundef)
util_deps='$(MINIPERL_EXE) $(CONFIGPM) lib/auto/Cwd/Cwd$(DLSUFFIX) FORCE'
x2p_deps='$(MINIPERL_EXE) $(CONFIGPM) $(dynamic_ext) FORCE'
;;
+definedefine)
+ util_deps='$(PERL_EXE) $(CONFIGPM) FORCE'
+ x2p_deps='$(PERL_EXE) $(CONFIGPM) $(dynamic_ext) FORCE'
+ ;;
*) util_deps='$(PERL_EXE) $(CONFIGPM) FORCE'
x2p_deps='$(PERL_EXE) $(CONFIGPM) FORCE'
;;
@@ -572,6 +607,9 @@
x2p/s2p: $x2p_deps
cd x2p; \$(LDLIBPTH) \$(MAKE) s2p
+x2p/find2perl: $x2p_deps
+ cd x2p; \$(LDLIBPTH) \$(MAKE) find2perl
+
utilities: $util_deps
@echo " "; echo " Making utilities"; cd utils; \$(LDLIBPTH) \$(MAKE) all
@@ -619,13 +657,15 @@
$spitshell >>$Makefile <<'!NO!SUBS!'
-globals$(OBJ_EXT): uudmap.h bitcount.h
+globals$(OBJ_EXT): $(generated_headers)
-uudmap.h: bitcount.h
+uudmap.h mg_data.h: bitcount.h
bitcount.h: generate_uudmap$(HOST_EXE_EXT)
- $(RUN) ./generate_uudmap$(HOST_EXE_EXT) uudmap.h bitcount.h
+ $(RUN) ./generate_uudmap$(HOST_EXE_EXT) $(generated_headers)
+generate_uudmap$(OBJ_EXT): mg_raw.h
+
generate_uudmap$(HOST_EXE_EXT): generate_uudmap$(OBJ_EXT)
$(CC) -o generate_uudmap$(EXE_EXT) $(LDFLAGS) generate_uudmap$(OBJ_EXT) $(libs)
@@ -696,8 +736,8 @@
;;
esac
$spitshell >>$Makefile <<'!NO!SUBS!'
-perl.exp: $(MINIPERLEXP) makedef.pl config.sh $(SYM) $(SYMH)
- ./$(MINIPERLEXP) makedef.pl PLATFORM=aix CC_FLAGS="$(OPTIMIZE)" | sort -u | sort -f > perl.exp
+perl.exp: $(MINIPERLEXP) makedef.pl $(CONFIGPM) $(SYM) $(SYMH)
+ ./$(MINIPERLEXP) makedef.pl --sort-fold PLATFORM=aix CC_FLAGS="$(OPTIMIZE)" > perl.exp
!NO!SUBS!
;;
@@ -705,7 +745,7 @@
$spitshell >>$Makefile <<'!NO!SUBS!'
MINIPERLEXP = miniperl
-perl5.def: $(MINIPERLEXP) makedef.pl config.sh $(SYM) $(SYMH) miniperl.map
+perl5.def: $(MINIPERLEXP) makedef.pl $(CONFIGPM) $(SYM) $(SYMH) miniperl.map
./$(MINIPERLEXP) makedef.pl PLATFORM=os2 -DPERL_DLL=$(PERL_DLL) CC_FLAGS="$(OPTIMIZE)" > perl5.def
!NO!SUBS!
@@ -735,8 +775,11 @@
case "$dtrace_h" in
?*)
$spitshell >>$Makefile <<'!NO!SUBS!'
+# dtrace dicards const qualifiers from arguments, put them back
$(DTRACE_H): perldtrace.d
- $(DTRACE) -h -s perldtrace.d -o $(DTRACE_H)
+ $(DTRACE) -h -s perldtrace.d -o $(DTRACE_H).in
+ sed -e '/const/!s/char \*/const char */g' $(DTRACE_H).in >$(DTRACE_H)
+ $(RMS) $(DTRACE_H).in
mydtrace.h: $(DTRACE_H)
@@ -749,8 +792,8 @@
$(DTRACE_O): perldtrace.d $(ndt_obj)
$(DTRACE) -G -s perldtrace.d -o $(DTRACE_O) $(ndt_obj)
-$(MINIDTRACE_O): perldtrace.d $(minindt_obj)
- $(DTRACE) -G -s perldtrace.d -o $(MINIDTRACE_O) $(minindt_obj)
+$(MINIDTRACE_O): perldtrace.d $(minindt_obj) perlmini$(OBJ_EXT)
+ $(DTRACE) -G -s perldtrace.d -o $(MINIDTRACE_O) $(minindt_obj) perlmini$(OBJ_EXT)
!NO!SUBS!
;;
@@ -797,20 +840,17 @@
!NO!SUBS!
case "${osname}${osvers}" in
- aix*|beos*)
+ aix*)
$spitshell >>$Makefile <<'!NO!SUBS!'
-$(MINIPERL_EXE): $& miniperlmain$(OBJ_EXT) $(mini_obj) opmini$(OBJ_EXT) perlmini$(OBJ_EXT)
- $(CC) -o $(MINIPERL_EXE) $(CLDFLAGS) \
- $(mini_obj) \
- miniperlmain$(OBJ_EXT) opmini$(OBJ_EXT) perlmini$(OBJ_EXT) $(libs)
+$(MINIPERL_EXE): $& $(mini_obj)
+ $(CC) -o $(MINIPERL_EXE) $(CLDFLAGS) $(mini_obj) $(libs)
$(LDLIBPTH) $(RUN) ./miniperl$(HOST_EXE_EXT) -w -Ilib -MExporter -e '<?>' || $(MAKE) minitest
!NO!SUBS!
;;
next4*)
$spitshell >>$Makefile <<'!NO!SUBS!'
-$(MINIPERL_EXE): $& miniperlmain$(OBJ_EXT) $(mini_obj) perlmini$(OBJ_EXT) opmini$(OBJ_EXT)
- $(CC) -o $(MINIPERL_EXE) $(mini_obj) \
- miniperlmain$(OBJ_EXT) opmini$(OBJ_EXT) perlmini$(OBJ_EXT) $(libs)
+$(MINIPERL_EXE): $& $(mini_obj)
+ $(CC) -o $(MINIPERL_EXE) $(mini_obj) $(libs)
$(LDLIBPTH) $(RUN) ./miniperl$(HOST_EXE_EXT) -w -Ilib -MExporter -e '<?>' || $(MAKE) minitest
!NO!SUBS!
;;
@@ -828,21 +868,19 @@
;;
esac
$spitshell >>$Makefile <<'!NO!SUBS!'
-$(MINIPERL_EXE): $& miniperlmain$(OBJ_EXT) $(mini_obj) opmini$(OBJ_EXT) perlmini$(OBJ_EXT)
+$(MINIPERL_EXE): $& $(mini_obj)
- at rm -f miniperl.xok
$(CC) $(CLDFLAGS) $(NAMESPACEFLAGS) -o $(MINIPERL_EXE) \
- $(mini_obj) \
- miniperlmain$(OBJ_EXT) opmini$(OBJ_EXT) perlmini$(OBJ_EXT) $(libs)
+ $(mini_obj) $(libs)
$(LDLIBPTH) $(RUN) ./miniperl$(HOST_EXE_EXT) -w -Ilib -MExporter -e '<?>' || $(MAKE) minitest
!NO!SUBS!
;;
*)
$spitshell >>$Makefile <<'!NO!SUBS!'
-$(MINIPERL_EXE): $& miniperlmain$(OBJ_EXT) $(mini_obj) opmini$(OBJ_EXT) perlmini$(OBJ_EXT)
+$(MINIPERL_EXE): $& $(mini_obj)
- at rm -f miniperl.xok
$(LDLIBPTH) $(CC) $(CLDFLAGS) -o $(MINIPERL_EXE) \
- $(mini_obj) \
- miniperlmain$(OBJ_EXT) opmini$(OBJ_EXT) perlmini$(OBJ_EXT) $(libs)
+ $(mini_obj) $(libs)
$(LDLIBPTH) $(RUN) ./miniperl$(HOST_EXE_EXT) -w -Ilib -MExporter -e '<?>' || $(MAKE) minitest
!NO!SUBS!
;;
@@ -865,8 +903,13 @@
quant$(PERL_EXE): $& perlmain$(OBJ_EXT) $(LIBPERL) $(static_ext) ext.libs $(PERLEXPORT)
$(SHRPENV) $(LDLIBPTH) quantify $(CC) -o quantperl $(CLDFLAGS) $(CCDLFLAGS) perlmain$(OBJ_EXT) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
-# Valgrind perl (currently Linux only)
+!NO!SUBS!
+case "${osname}${osvers}" in
+linux*|darwin*)
+ $spitshell >>$Makefile <<'!NO!SUBS!'
+# Valgrind perl (currently Linux, Darwin only)
+
perl.valgrind.config: config.sh
@echo "To build perl.valgrind you must Configure -Doptimize=-g -Uusemymalloc, checking..."
@$(MAKE) perl.config.dashg
@@ -874,8 +917,13 @@
@grep "^usemymalloc=" config.sh
@grep "^usemymalloc='n'" config.sh >/dev/null || exit 1
@echo "And of course you have to have valgrind..."
- $(VALGRIND) ./perl -e 1 2>/dev/null || exit 1
+ $(VALGRIND) $(VG_TEST) || exit 1
+!NO!SUBS!
+ ;;
+esac
+$spitshell >>$Makefile <<'!NO!SUBS!'
+
# Third Degree Perl (Tru64 only)
perl.config.dashg:
@@ -1010,7 +1058,7 @@
# But also this ensures that all extensions are built before we try to scan
# them, which picks up Devel::PPPort's documentation.
pod/perltoc.pod: $(perltoc_pod_prereqs) $(PERL_EXE) $(ext) pod/buildtoc
- $(RUN_PERL) -f -Ilib pod/buildtoc --build-toc -q
+ $(RUN_PERL) -f -Ilib pod/buildtoc -q
pod/perlapi.pod: pod/perlintern.pod
@@ -1020,8 +1068,9 @@
pod/perlmodlib.pod: $(MINIPERL_EXE) pod/perlmodlib.PL MANIFEST
$(MINIPERL) $(Icwd) pod/perlmodlib.PL -q
-pod/perl5142delta.pod: pod/perldelta.pod
- $(LNS) perldelta.pod pod/perl5142delta.pod
+pod/perl5181delta.pod: pod/perldelta.pod
+ $(RMS) pod/perl5181delta.pod
+ $(LNS) perldelta.pod pod/perl5181delta.pod
extra.pods: $(MINIPERL_EXE)
- at test ! -f extra.pods || rm -f `cat extra.pods`
@@ -1044,19 +1093,19 @@
.PHONY: install install-strip install-all install-verbose install-silent \
no-install install.perl install.man install.html
-install-strip:
+install_strip install-strip:
$(MAKE) STRIPFLAGS=-s install DESTDIR="$(DESTDIR)"
-install install-all:
+install install_all install-all:
$(MAKE) install.perl install.man STRIPFLAGS=$(STRIPFLAGS) DESTDIR="$(DESTDIR)"
-install-verbose:
+install_verbose install-verbose:
$(MAKE) install.perl install.man STRIPFLAGS=$(STRIPFLAGS) INSTALLFLAGS=-V DESTDIR="$(DESTDIR)"
-install-silent:
+install_silent install-silent:
$(MAKE) install.perl install.man STRIPFLAGS=$(STRIPFLAGS) INSTALLFLAGS=-S DESTDIR="$(DESTDIR)"
-no-install:
+no_install no-install:
$(MAKE) install.perl install.man STRIPFLAGS=$(STRIPFLAGS) INSTALLFLAGS=-n DESTDIR="$(DESTDIR)"
# Set this to an empty string to avoid an attempt of rebuild before install
@@ -1079,7 +1128,6 @@
--htmlroot=$(privlib)/html \
--splithead=pod/perlipc \
--splititem=pod/perlfunc \
- --libpods=perlfunc:perlguts:perlvar:perlrun:perlop \
--ignore=Porting/Maintainers.pm,Porting/pumpkin.pod,Porting/repository.pod \
--verbose
@@ -1091,11 +1139,11 @@
.PHONY: regen_perly
-run_byacc:
+run_byacc run-byacc:
@echo "run_byacc is obsolete; try 'make regen_perly' instead"
# this outputs perly.h, perly.act and perly.tab
-regen_perly:
+regen_perly regen-perly:
perl regen_perly.pl
# We don't want to regenerate perly.c and perly.h, but they might
@@ -1107,7 +1155,7 @@
perly.h: perly.y
- at sh -c true
-SYM = global.sym globvar.sym perlio.sym
+SYM = globvar.sym perlio.sym
SYMH = perlvars.h intrpvar.h
@@ -1114,11 +1162,11 @@
CHMOD_W = chmod +w
# The following files are generated automatically
-# embed.pl: proto.h embed.h embedvar.h global.sym
-# perlapi.h perlapi.c
+# embed.pl: proto.h embed.h embedvar.h perlapi.h perlapi.c
# opcode.pl: opcode.h opnames.h pp_proto.h
# regcomp.pl: regnodes.h
# warnings.pl: warnings.h lib/warnings.pm
+# feature.pl: feature.h lib/feature.pm
# The correct versions should be already supplied with the perl kit,
# in case you don't have perl available.
# To force them to be regenerated, run
@@ -1126,27 +1174,31 @@
# with your existing copy of perl
# (make regen_headers is kept for backwards compatibility)
-AUTOGEN_FILES = opcode.h opnames.h pp_proto.h proto.h \
- embed.h embedvar.h global.sym \
- perlapi.h perlapi.c regnodes.h \
- warnings.h lib/warnings.pm
+AUTOGEN_FILES = opcode.h opnames.h pp_proto.h proto.h embed.h embedvar.h \
+ perlapi.h perlapi.c regnodes.h warnings.h lib/warnings.pm \
+ lib/feature.pm feature.h
.PHONY: regen_headers regen_all
regen: FORCE
-perl regen.pl
+ -perl regen/uconfig_h.pl
-regen_headers: FORCE
+regen_headers regen-headers: FORCE
-perl regen.pl -v
+ -perl regen/uconfig_h.pl -v
-regen_meta: META.yml
+regen_meta regen-meta: META.yml META.json
META.yml: FORCE
- PATH="`pwd`:${PATH}" PERL5LIB="`pwd`/lib" $(RUN_PERL) -Ilib Porting/makemeta
+ PATH="`pwd`:${PATH}" PERL5LIB="`pwd`/lib" $(RUN_PERL) -Ilib Porting/makemeta -y
+META.json: FORCE
+ PATH="`pwd`:${PATH}" PERL5LIB="`pwd`/lib" $(RUN_PERL) -Ilib Porting/makemeta -j
-regen_all: regen regen_meta
+regen_all regen-all: regen regen_meta
+
.PHONY: manisort manicheck
manisort: FORCE
@@ -1169,7 +1221,7 @@
$(DYNALOADER): $(MINIPERL_EXE) lib/buildcustomize.pl preplibrary FORCE $(nonxs_ext)
$(MINIPERL) make_ext.pl $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) LINKTYPE=static $(STATIC_LDFLAGS)
-d_dummy $(dynamic_ext): $(MINIPERL_EXE) lib/buildcustomize.pl preplibrary makeppport $(DYNALOADER) FORCE $(PERLEXPORT)
+d_dummy $(dynamic_ext): $(MINIPERL_EXE) lib/buildcustomize.pl preplibrary makeppport $(DYNALOADER) FORCE $(PERLEXPORT) $(LIBPERL)
$(MINIPERL) make_ext.pl $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) LINKTYPE=dynamic
s_dummy $(static_ext): $(MINIPERL_EXE) lib/buildcustomize.pl preplibrary makeppport $(DYNALOADER) FORCE
@@ -1213,11 +1265,11 @@
# Do not 'make _mopup' directly.
_mopup:
- rm -f *$(OBJ_EXT) *$(LIB_EXT) all perlmain.c opmini.c perlmini.c uudmap.h generate_uudmap$(EXE_EXT) bitcount.h
+ rm -f *$(OBJ_EXT) *$(LIB_EXT) all perlmain.c opmini.c perlmini.c generate_uudmap$(EXE_EXT) $(generated_headers)
-rmdir .depending
- at test -f extra.pods && rm -f `cat extra.pods`
- at test -f vms/README_vms.pod && rm -f vms/README_vms.pod
- -rm -f perl.exp ext.libs $(generated_pods) uni.data opmini.o perlmini.o
+ -rm -f perl.exp ext.libs $(generated_pods) uni.data opmini.o perlmini.o pod/roffitall
-rm -f perl.export perl.dll perl.libexp perl.map perl.def
-rm -f perl.loadmap miniperl.loadmap perl.prelmap miniperl.prelmap
-rm -f perl.third lib*.so.perl.third perl.3log t/perl.third t/perl.3log
@@ -1259,7 +1311,8 @@
_cleaner2:
-rm -f core.*perl.*.? t/core.perl.*.? .?*.c
rm -f core *perl.core t/core t/*perl.core core.* t/core.*
- rm -f t/misctmp* t/forktmp* t/tmp* t/c t/$(PERL_EXE) t/rantests
+ rm -f t/$(PERL_EXE) t/rantests
+ rm -rf t/tmp*
rm -f so_locations $(LIBPERL_NONSHR) $(MINIPERL_NONSHR)
rm -rf $(addedbyconf)
rm -f $(FIRSTMAKEFILE) $(FIRSTMAKEFILE).old makefile.old
@@ -1280,10 +1333,12 @@
rm -fr lib/B
rm -fr lib/CPAN lib/CPANPLUS
rm -fr lib/ExtUtils/CBuilder
+ rm -f pod2htmd.tmp
+ rm -rf pod/perlfunc pod/perlipc
-rmdir cpan/CPANPLUS-Dist-Build/t/dummy-cpanplus cpan/CPANPLUS/t/dummy-cpanplus cpan/CPANPLUS/t/dummy-localmirror
-rmdir ext/B/lib
-rmdir lib/Archive/Tar lib/Archive lib/Attribute
- -rmdir lib/CGI
+ -rmdir lib/CGI lib/Carp
-rmdir lib/Data lib/Devel lib/Digest
-rmdir lib/ExtUtils/Command lib/ExtUtils/Constant lib/ExtUtils/Liblist lib/ExtUtils/MakeMaker
-rmdir lib/File/Spec lib/Filter/Util lib/Filter
@@ -1370,7 +1425,9 @@
test_prep_pre: preplibrary utilities $(nonxs_ext)
-test_prep: test_prep_pre $(MINIPERL_EXE) $(unidatafiles) $(PERL_EXE) $(dynamic_ext) $(TEST_PERL_DLL) runtests x2p/s2p $(generated_pods)
+test_prep test-prep: test_prep_pre $(MINIPERL_EXE) $(unidatafiles) $(PERL_EXE) \
+ $(dynamic_ext) $(TEST_PERL_DLL) runtests x2p/s2p x2p/find2perl \
+ $(generated_pods)
cd t && (rm -f $(PERL_EXE); $(LNS) ../$(PERL_EXE) $(PERL_EXE))
test_prep_reonly: $(MINIPERL_EXE) $(PERL_EXE) $(dynamic_ext_re) $(TEST_PERL_DLL)
@@ -1380,10 +1437,10 @@
test check: test_prep
$(RUN_TESTS) choose
-test_tty: test_prep
+test_tty test-tty: test_prep
$(RUN_TESTS) tty
-test_notty: test_prep
+test_notty test-notty: test_prep
$(RUN_TESTS) no-tty
utest ucheck test.utf8 check.utf8: test_prep
@@ -1392,12 +1449,6 @@
coretest: test_prep
TEST_ARGS=-core $(RUN_TESTS) choose
-test-prep: test_prep
-
-test-tty: test_tty
-
-test-notty: test_notty
-
# Torture testing
test.torture torturetest: test_prep
@@ -1407,7 +1458,7 @@
minitest.utf16: minitest.prep
- cd t && (rm -f $(PERL_EXE); $(LNS) ../$(MINIPERL_EXE) $(PERL_EXE)) \
- && $(RUN_PERL) TEST -utf16 base/*.t comp/*.t cmd/*.t run/*.t io/*.t op/*.t uni/*.t </dev/tty
+ && $(RUN_PERL) TEST -utf16 base/*.t comp/*.t cmd/*.t run/*.t io/*.t opbasic/*.t op/*.t uni/*.t </dev/tty
test.utf16 check.utf16: test_prep
TEST_ARGS=-utf16 $(RUN_TESTS) choose
@@ -1415,6 +1466,11 @@
utest.utf16 ucheck.utf16: test_prep
TEST_ARGS="-utf8 -utf16" $(RUN_TESTS) choose
+!NO!SUBS!
+
+case "${osname}${osvers}" in
+linux*|darwin*)
+ $spitshell >>$Makefile <<'!NO!SUBS!'
# Targets for valgrind testing:
test_prep.valgrind: test_prep perl.valgrind
@@ -1427,7 +1483,12 @@
test_notty.valgrind: test_prep.valgrind perl.valgrind.config
PERL_VALGRIND=1 $(RUN_TESTS) no-tty
+!NO!SUBS!
+ ;;
+esac
+$spitshell >>$Makefile <<'!NO!SUBS!'
+
# Targets for Third Degree testing.
test_prep.third: test_prep perl.third
@@ -1466,23 +1527,23 @@
# is crashing.
minitest: $(MINIPERL_EXE) minitest.prep
- 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 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 </dev/tty
# Test via harness
-test_harness: test_prep
+test_harness test-harness: test_prep
TESTFILE=harness $(RUN_TESTS) choose
test_harness_notty: test_prep
HARNESS_NOTTY=1 TESTFILE=harness $(RUN_TESTS) choose
-test-reonly: test_prep_reonly
+test_reonly test-reonly: test_prep_reonly
TEST_ARGS='-re \bre\/' TESTFILE=harness $(RUN_TESTS) choose
# Porting tests (well-formedness of pod, manifest, etc)
-test_porting: test_prep
+test_porting test-porting: test_prep
cd t && $(RUN_PERL) harness porting/*.t ../lib/diagnostics.t
# Handy way to run perlbug -ok without having to install and run the
@@ -1599,9 +1660,6 @@
cd ..
fi
;;
-vmesa)
- # Do nothing in VM/ESA.
- ;;
*)
echo "'$osname' is an EBCDIC system I don't know that well." >&4
;;
Property changes on: trunk/contrib/perl/Makefile.SH
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.4
\ No newline at end of property
Modified: trunk/contrib/perl/Policy_sh.SH
===================================================================
--- trunk/contrib/perl/Policy_sh.SH 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/Policy_sh.SH 2013-12-02 21:18:17 UTC (rev 6438)
@@ -1,3 +1,5 @@
+#!/bin/sh
+
case $PERL_CONFIG_SH in
'') . ./config.sh ;;
esac
Property changes on: trunk/contrib/perl/Policy_sh.SH
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/XSUB.h
===================================================================
--- trunk/contrib/perl/XSUB.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/XSUB.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -48,8 +48,16 @@
=for apidoc AmU||XS
Macro to declare an XSUB and its C parameter list. This is handled by
-C<xsubpp>.
+C<xsubpp>. It is the same as using the more explicit XS_EXTERNAL macro.
+=for apidoc AmU||XS_INTERNAL
+Macro to declare an XSUB and its C parameter list without exporting the symbols.
+This is handled by C<xsubpp> and generally preferable over exporting the XSUB
+symbols unnecessarily.
+
+=for apidoc AmU||XS_EXTERNAL
+Macro to declare an XSUB and its C parameter list explicitly exporting the symbols.
+
=for apidoc Ams||dAX
Sets up the C<ax> variable.
This is usually handled automatically by C<xsubpp> by calling C<dXSARGS>.
@@ -107,32 +115,51 @@
* Don't forget to change the __attribute__unused__ version of XS()
* below too if you change XSPROTO() here.
*/
+
+/* XS_INTERNAL is the explicit static-linkage variant of the default
+ * XS macro.
+ *
+ * XS_EXTERNAL is the same as XS_INTERNAL except it does not include
+ * "STATIC", ie. it exports XSUB symbols. You probably don't want that.
+ */
+
#define XSPROTO(name) void name(pTHX_ CV* cv)
#undef XS
+#undef XS_EXTERNAL
+#undef XS_INTERNAL
#if defined(__CYGWIN__) && defined(USE_DYNAMIC_LOADING)
-# define XS(name) __declspec(dllexport) XSPROTO(name)
+# define XS_EXTERNAL(name) __declspec(dllexport) XSPROTO(name)
+# define XS_INTERNAL(name) STATIC XSPROTO(name)
#endif
#if defined(__SYMBIAN32__)
-# define XS(name) EXPORT_C XSPROTO(name)
+# define XS_EXTERNAL(name) EXPORT_C XSPROTO(name)
+# define XS_INTERNAL(name) EXPORT_C STATIC XSPROTO(name)
#endif
-#ifndef XS
+#ifndef XS_EXTERNAL
# if defined(HASATTRIBUTE_UNUSED) && !defined(__cplusplus)
-# define XS(name) void name(pTHX_ CV* cv __attribute__unused__)
+# define XS_EXTERNAL(name) void name(pTHX_ CV* cv __attribute__unused__)
+# define XS_INTERNAL(name) STATIC void name(pTHX_ CV* cv __attribute__unused__)
# else
# ifdef __cplusplus
-# define XS(name) extern "C" XSPROTO(name)
+# define XS_EXTERNAL(name) extern "C" XSPROTO(name)
+# define XS_INTERNAL(name) static XSPROTO(name)
# else
-# define XS(name) XSPROTO(name)
+# define XS_EXTERNAL(name) XSPROTO(name)
+# define XS_INTERNAL(name) STATIC XSPROTO(name)
# endif
# endif
#endif
+/* We do export xsub symbols by default for the public XS macro.
+ * Try explicitly using XS_INTERNAL/XS_EXTERNAL instead, please. */
+#define XS(name) XS_EXTERNAL(name)
+
#define dAX const I32 ax = (I32)(MARK - PL_stack_base + 1)
#define dAXMARK \
I32 ax = POPMARK; \
- register SV **mark = PL_stack_base + ax++
+ SV **mark = PL_stack_base + ax++
#define dITEMS I32 items = (I32)(SP - MARK)
@@ -367,7 +394,6 @@
# define VTBL_sv &PL_vtbl_sv
# define VTBL_env &PL_vtbl_env
# define VTBL_envelem &PL_vtbl_envelem
-# define VTBL_sig &PL_vtbl_sig
# define VTBL_sigelem &PL_vtbl_sigelem
# define VTBL_pack &PL_vtbl_pack
# define VTBL_packelem &PL_vtbl_packelem
@@ -609,18 +635,16 @@
# define socketpair PerlSock_socketpair
# endif /* NETWARE && USE_STDIO */
-# ifdef USE_SOCKETS_AS_HANDLES
-# undef fd_set
-# undef FD_SET
-# undef FD_CLR
-# undef FD_ISSET
-# undef FD_ZERO
-# define fd_set Perl_fd_set
-# define FD_SET(n,p) PERL_FD_SET(n,p)
-# define FD_CLR(n,p) PERL_FD_CLR(n,p)
-# define FD_ISSET(n,p) PERL_FD_ISSET(n,p)
-# define FD_ZERO(p) PERL_FD_ZERO(p)
-# endif /* USE_SOCKETS_AS_HANDLES */
+# undef fd_set
+# undef FD_SET
+# undef FD_CLR
+# undef FD_ISSET
+# undef FD_ZERO
+# define fd_set Perl_fd_set
+# define FD_SET(n,p) PERL_FD_SET(n,p)
+# define FD_CLR(n,p) PERL_FD_CLR(n,p)
+# define FD_ISSET(n,p) PERL_FD_ISSET(n,p)
+# define FD_ZERO(p) PERL_FD_ZERO(p)
# endif /* NO_XSLOCKS */
#endif /* PERL_IMPLICIT_SYS && !PERL_CORE */
@@ -631,8 +655,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/XSUB.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/autodoc.pl
===================================================================
--- trunk/contrib/perl/autodoc.pl 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/autodoc.pl 2013-12-02 21:18:17 UTC (rev 6438)
@@ -186,14 +186,50 @@
print $fh "\t\t$name;\n\n";
} elsif ($flags =~ /n/) { # no args
print $fh "\t$ret\t$name\n\n";
- } elsif ($flags =~ /o/) { # no #define foo Perl_foo
- print $fh "\t$ret\tPerl_$name";
- print $fh "(" . (@args ? "pTHX_ " : "pTHX");
- print $fh join(", ", @args) . ")\n\n";
} else { # full usage
- print $fh "\t$ret\t$name";
- print $fh "(" . join(", ", @args) . ")";
- print $fh "\n\n";
+ my $p = $flags =~ /o/; # no #define foo Perl_foo
+ my $n = "Perl_"x$p . $name;
+ my $large_ret = length $ret > 7;
+ my $indent_size = 7+8 # nroff: 7 under =head + 8 under =item
+ +8+($large_ret ? 1 + length $ret : 8)
+ +length($n) + 1;
+ my $indent;
+ print $fh "\t$ret" . ($large_ret ? ' ' : "\t") . "$n(";
+ my $long_args;
+ for (@args) {
+ if ($indent_size + 2 + length > 79) {
+ $long_args=1;
+ $indent_size -= length($n) - 3;
+ last;
+ }
+ }
+ my $args = '';
+ if ($p) {
+ $args = @args ? "pTHX_ " : "pTHX";
+ if ($long_args) { print $fh $args; $args = '' }
+ }
+ $long_args and print $fh "\n";
+ my $first = !$long_args;
+ while () {
+ if (!@args or
+ length $args
+ && $indent_size + 3 + length($args[0]) + length $args > 79
+ ) {
+ print $fh
+ $first ? '' : (
+ $indent //=
+ "\t".($large_ret ? " " x (1+length $ret) : "\t")
+ ." "x($long_args ? 4 : 1 + length $n)
+ ),
+ $args, (","x($args ne 'pTHX_ ') . "\n")x!!@args;
+ $args = $first = '';
+ }
+ @args or last;
+ $args .= ", "x!!(length $args && $args ne 'pTHX_ ')
+ . shift @args;
+ }
+ if ($long_args) { print $fh "\n", substr $indent, 0, -4 }
+ print $fh ")\n\n";
}
print $fh "=for hackers\nFound in file $file\n\n";
}
@@ -235,18 +271,28 @@
if (@$missing) {
print $fh "\n=head1 Undocumented functions\n\n";
- print $fh <<'_EOB_';
+ print $fh $podname eq 'perlapi' ? <<'_EOB_' : <<'_EOB_';
The following functions have been flagged as part of the public API,
but are currently undocumented. Use them at your own risk, as the
-interfaces are subject to change.
+interfaces are subject to change. Functions that are not listed in this
+document are not intended for public use, and should NOT be used under any
+circumstances.
-If you use one of them, you may wish to consider creating and submitting
-documentation for it. If your patch is accepted, this will indicate that
-the interface is stable (unless it is explicitly marked otherwise).
+If you use one of the undocumented functions below, you may wish to consider
+creating and submitting documentation for it. If your patch is accepted, this
+will indicate that the interface is stable (unless it is explicitly marked
+otherwise).
=over
_EOB_
+The following functions are currently undocumented. If you use one of
+them, you may wish to consider creating and submitting documentation for
+it.
+
+=over
+
+_EOB_
for my $missing (sort @$missing) {
print $fh "=item $missing\nX<$missing>\n\n";
}
@@ -328,7 +374,8 @@
# walk table providing an array of components in each line to
# subroutine, printing the result
-my @missing_api = grep $funcflags{$_}{flags} =~ /A/ && !$docs{api}{$_}, keys %funcflags;
+# List of funcs in the public API that aren't also marked as experimental.
+my @missing_api = grep $funcflags{$_}{flags} =~ /A/ && $funcflags{$_}{flags} !~ /M/ && !$docs{api}{$_}, keys %funcflags;
output('perlapi', <<'_EOB_', $docs{api}, \@missing_api, <<'_EOE_');
=head1 NAME
@@ -338,7 +385,7 @@
X<Perl API> X<API> X<api>
This file contains the documentation of the perl public API generated by
-embed.pl, specifically a listing of functions, macros, flags, and variables
+F<embed.pl>, specifically a listing of functions, macros, flags, and variables
that may be used by extension writers. L<At the end|/Undocumented functions>
is a list of functions which have yet to be documented. The interfaces of
those are subject to change without notice. Any functions not listed here are
@@ -368,11 +415,6 @@
the UTF- encodings, and a string encoded in UTF-EBCDIC may occupy more bytes
than in UTF-8.
-Also, on some EBCDIC machines, functions that are documented as operating on
-US-ASCII (or Basic Latin in Unicode terminology) may in fact operate on all
-256 characters in the EBCDIC range, not just the subset corresponding to
-US-ASCII.
-
The listing below is alphabetical, case insensitive.
_EOB_
@@ -397,7 +439,9 @@
_EOE_
-my @missing_guts = grep $funcflags{$_}{flags} !~ /A/ && !$docs{guts}{$_}, keys %funcflags;
+# List of non-static internal functions
+my @missing_guts =
+ grep $funcflags{$_}{flags} !~ /[As]/ && !$docs{guts}{$_}, keys %funcflags;
output('perlintern', <<'END', $docs{guts}, \@missing_guts, <<'END');
=head1 NAME
Property changes on: trunk/contrib/perl/autodoc.pl
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/av.c
===================================================================
--- trunk/contrib/perl/av.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/av.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -80,23 +80,35 @@
arg1);
return;
}
- if (key > AvMAX(av)) {
+ av_extend_guts(av,key,&AvMAX(av),&AvALLOC(av),&AvARRAY(av));
+}
+
+/* The guts of av_extend. *Not* for general use! */
+void
+Perl_av_extend_guts(pTHX_ AV *av, I32 key, SSize_t *maxp, SV ***allocp,
+ SV ***arrayp)
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT_AV_EXTEND_GUTS;
+
+ if (key > *maxp) {
SV** ary;
I32 tmp;
I32 newmax;
- if (AvALLOC(av) != AvARRAY(av)) {
- ary = AvALLOC(av) + AvFILLp(av) + 1;
- tmp = AvARRAY(av) - AvALLOC(av);
- Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*);
- AvMAX(av) += tmp;
- AvARRAY(av) = AvALLOC(av);
+ if (av && *allocp != *arrayp) {
+ ary = *allocp + AvFILLp(av) + 1;
+ tmp = *arrayp - *allocp;
+ Move(*arrayp, *allocp, AvFILLp(av)+1, SV*);
+ *maxp += tmp;
+ *arrayp = *allocp;
if (AvREAL(av)) {
while (tmp)
ary[--tmp] = &PL_sv_undef;
}
- if (key > AvMAX(av) - 10) {
- newmax = key + AvMAX(av);
+ if (key > *maxp - 10) {
+ newmax = key + *maxp;
goto resize;
}
}
@@ -106,11 +118,7 @@
"Out of memory during array extend"; /* Duplicated in pp_hot.c */
#endif
- if (AvALLOC(av)) {
-#if !defined(STRANGE_MALLOC) && !defined(MYMALLOC)
- MEM_SIZE bytes;
- IV itmp;
-#endif
+ if (*allocp) {
#ifdef Perl_safesysmalloc_size
/* Whilst it would be quite possible to move this logic around
@@ -126,41 +134,24 @@
memory that might never be read. So, I feel, better to keep
the current lazy system of only writing to it if our caller
has a need for more space. NWC */
- newmax = Perl_safesysmalloc_size((void*)AvALLOC(av)) /
+ newmax = Perl_safesysmalloc_size((void*)*allocp) /
sizeof(const SV *) - 1;
if (key <= newmax)
goto resized;
#endif
- newmax = key + AvMAX(av) / 5;
+ newmax = key + *maxp / 5;
resize:
MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
-#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
- Renew(AvALLOC(av),newmax+1, SV*);
-#else
- bytes = (newmax + 1) * sizeof(const SV *);
-#define MALLOC_OVERHEAD 16
- itmp = MALLOC_OVERHEAD;
- while ((MEM_SIZE)(itmp - MALLOC_OVERHEAD) < bytes)
- itmp += itmp;
- itmp -= MALLOC_OVERHEAD;
- itmp /= sizeof(const SV *);
- assert(itmp > newmax);
- newmax = itmp - 1;
- assert(newmax >= AvMAX(av));
- Newx(ary, newmax+1, SV*);
- Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
- Safefree(AvALLOC(av));
- AvALLOC(av) = ary;
-#endif
+ Renew(*allocp,newmax+1, SV*);
#ifdef Perl_safesysmalloc_size
resized:
#endif
- ary = AvALLOC(av) + AvMAX(av) + 1;
- tmp = newmax - AvMAX(av);
+ ary = *allocp + *maxp + 1;
+ tmp = newmax - *maxp;
if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
- PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base);
- PL_stack_base = AvALLOC(av);
+ PL_stack_sp = *allocp + (PL_stack_sp - PL_stack_base);
+ PL_stack_base = *allocp;
PL_stack_max = PL_stack_base + newmax;
}
}
@@ -167,18 +158,18 @@
else {
newmax = key < 3 ? 3 : key;
MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
- Newx(AvALLOC(av), newmax+1, SV*);
- ary = AvALLOC(av) + 1;
+ Newx(*allocp, newmax+1, SV*);
+ ary = *allocp + 1;
tmp = newmax;
- AvALLOC(av)[0] = &PL_sv_undef; /* For the stacks */
+ *allocp[0] = &PL_sv_undef; /* For the stacks */
}
- if (AvREAL(av)) {
+ if (av && AvREAL(av)) {
while (tmp)
ary[--tmp] = &PL_sv_undef;
}
- AvARRAY(av) = AvALLOC(av);
- AvMAX(av) = newmax;
+ *arrayp = *allocp;
+ *maxp = newmax;
}
}
}
@@ -195,11 +186,37 @@
more information on how to use this function on tied arrays.
The rough perl equivalent is C<$myarray[$idx]>.
+
=cut
*/
+static bool
+S_adjust_index(pTHX_ AV *av, const MAGIC *mg, I32 *keyp)
+{
+ bool adjust_index = 1;
+ if (mg) {
+ /* Handle negative array indices 20020222 MJD */
+ SV * const ref = SvTIED_obj(MUTABLE_SV(av), mg);
+ SvGETMAGIC(ref);
+ if (SvROK(ref) && SvOBJECT(SvRV(ref))) {
+ SV * const * const negative_indices_glob =
+ hv_fetchs(SvSTASH(SvRV(ref)), NEGATIVE_INDICES_VAR, 0);
+
+ if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob)))
+ adjust_index = 0;
+ }
+ }
+
+ if (adjust_index) {
+ *keyp += AvFILL(av) + 1;
+ if (*keyp < 0)
+ return FALSE;
+ }
+ return TRUE;
+}
+
SV**
-Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
+Perl_av_fetch(pTHX_ AV *av, I32 key, I32 lval)
{
dVAR;
@@ -212,23 +229,8 @@
if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
SV *sv;
if (key < 0) {
- I32 adjust_index = 1;
- if (tied_magic) {
- /* Handle negative array indices 20020222 MJD */
- SV * const * const negative_indices_glob =
- hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
- tied_magic))),
- NEGATIVE_INDICES_VAR, 16, 0);
-
- if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob)))
- adjust_index = 0;
- }
-
- if (adjust_index) {
- key += AvFILL(av) + 1;
- if (key < 0)
+ if (!S_adjust_index(aTHX_ av, tied_magic, &key))
return NULL;
- }
}
sv = sv_newmortal();
@@ -248,18 +250,12 @@
return NULL;
}
- if (key > AvFILLp(av)) {
- if (!lval)
- return NULL;
- return av_store(av,key,newSV(0));
+ if (key > AvFILLp(av) || AvARRAY(av)[key] == &PL_sv_undef) {
+ emptyness:
+ return lval ? av_store(av,key,newSV(0)) : NULL;
}
- if (AvARRAY(av)[key] == &PL_sv_undef) {
- emptyness:
- if (lval)
- return av_store(av,key,newSV(0));
- return NULL;
- }
- else if (AvREIFY(av)
+
+ if (AvREIFY(av)
&& (!AvARRAY(av)[key] /* eg. @_ could have freed elts */
|| SvIS_FREED(AvARRAY(av)[key]))) {
AvARRAY(av)[key] = &PL_sv_undef; /* 1/2 reify */
@@ -274,11 +270,16 @@
Stores an SV in an array. The array index is specified as C<key>. The
return value will be NULL if the operation failed or if the value did not
need to be actually stored within the array (as in the case of tied
-arrays). Otherwise it can be dereferenced to get the original C<SV*>. Note
-that the caller is responsible for suitably incrementing the reference
+arrays). Otherwise, it can be dereferenced
+to get the C<SV*> that was stored
+there (= C<val>)).
+
+Note that the caller is responsible for suitably incrementing the reference
count of C<val> before the call, and decrementing it if the function
returned NULL.
+Approximate Perl equivalent: C<$myarray[$key] = $val;>.
+
See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
more information on how to use this function on tied arrays.
@@ -286,7 +287,7 @@
*/
SV**
-Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
+Perl_av_store(pTHX_ AV *av, I32 key, SV *val)
{
dVAR;
SV** ary;
@@ -304,21 +305,9 @@
if (SvRMAGICAL(av)) {
const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied);
if (tied_magic) {
- /* Handle negative array indices 20020222 MJD */
if (key < 0) {
- bool adjust_index = 1;
- SV * const * const negative_indices_glob =
- hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
- tied_magic))),
- NEGATIVE_INDICES_VAR, 16, 0);
- if (negative_indices_glob
- && SvTRUE(GvSV(*negative_indices_glob)))
- adjust_index = 0;
- if (adjust_index) {
- key += AvFILL(av) + 1;
- if (key < 0)
+ if (!S_adjust_index(aTHX_ av, tied_magic, &key))
return 0;
- }
}
if (val != &PL_sv_undef) {
mg_copy(MUTABLE_SV(av), val, 0, key);
@@ -335,7 +324,7 @@
}
if (SvREADONLY(av) && key >= AvFILL(av))
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
if (!AvREAL(av) && AvREIFY(av))
av_reify(av);
@@ -356,13 +345,19 @@
SvREFCNT_dec(ary[key]);
ary[key] = val;
if (SvSMAGICAL(av)) {
- const MAGIC* const mg = SvMAGIC(av);
- if (val != &PL_sv_undef) {
+ const MAGIC *mg = SvMAGIC(av);
+ bool set = TRUE;
+ for (; mg; mg = mg->mg_moremagic) {
+ if (!isUPPER(mg->mg_type)) continue;
+ if (val != &PL_sv_undef) {
sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key);
+ }
+ if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa) {
+ PL_delaymagic |= DM_ARRAY_ISA;
+ set = FALSE;
+ }
}
- if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa)
- PL_delaymagic |= DM_ARRAY_ISA;
- else
+ if (set)
mg_set(MUTABLE_SV(av));
}
return &ary[key];
@@ -381,20 +376,23 @@
*/
AV *
-Perl_av_make(pTHX_ register I32 size, register SV **strp)
+Perl_av_make(pTHX_ I32 size, SV **strp)
{
- register AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV));
+ AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV));
/* sv_upgrade does AvREAL_only() */
PERL_ARGS_ASSERT_AV_MAKE;
assert(SvTYPE(av) == SVt_PVAV);
if (size) { /* "defined" was returning undef for size==0 anyway. */
- register SV** ary;
- register I32 i;
+ SV** ary;
+ I32 i;
Newx(ary,size,SV*);
AvALLOC(av) = ary;
AvARRAY(av) = ary;
- AvFILLp(av) = AvMAX(av) = size - 1;
+ AvMAX(av) = size - 1;
+ AvFILLp(av) = -1;
+ ENTER;
+ SAVEFREESV(av);
for (i = 0; i < size; i++) {
assert (*strp);
@@ -402,11 +400,15 @@
have multiple references to the same temp scalar (e.g.
from a list slice) */
+ SvGETMAGIC(*strp); /* before newSV, in case it dies */
+ AvFILLp(av)++;
ary[i] = newSV(0);
sv_setsv_flags(ary[i], *strp,
- SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
+ SV_DO_COW_SVSETSV|SV_NOSTEAL);
strp++;
}
+ SvREFCNT_inc_simple_void_NN(av);
+ LEAVE;
}
return av;
}
@@ -414,17 +416,21 @@
/*
=for apidoc av_clear
-Clears an array, making it empty. Does not free the memory used by the
-array itself. Perl equivalent: C<@myarray = ();>.
+Clears an array, making it empty. Does not free the memory the av uses to
+store its list of scalars. If any destructors are triggered as a result,
+the av itself may be freed when this function returns.
+Perl equivalent: C<@myarray = ();>.
+
=cut
*/
void
-Perl_av_clear(pTHX_ register AV *av)
+Perl_av_clear(pTHX_ AV *av)
{
dVAR;
I32 extra;
+ bool real;
PERL_ARGS_ASSERT_AV_CLEAR;
assert(SvTYPE(av) == SVt_PVAV);
@@ -436,7 +442,7 @@
#endif
if (SvREADONLY(av))
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
/* Give any tie a chance to cleanup first */
if (SvRMAGICAL(av)) {
@@ -450,9 +456,11 @@
if (AvMAX(av) < 0)
return;
- if (AvREAL(av)) {
+ if ((real = !!AvREAL(av))) {
SV** const ary = AvARRAY(av);
I32 index = AvFILLp(av) + 1;
+ ENTER;
+ SAVEFREESV(SvREFCNT_inc_simple_NN(av));
while (index) {
SV * const sv = ary[--index];
/* undef the slot before freeing the value, because a
@@ -467,20 +475,24 @@
AvARRAY(av) = AvALLOC(av);
}
AvFILLp(av) = -1;
-
+ if (real) LEAVE;
}
/*
=for apidoc av_undef
-Undefines the array. Frees the memory used by the array itself.
+Undefines the array. Frees the memory used by the av to store its list of
+scalars. If any destructors are triggered as a result, the av itself may
+be freed.
=cut
*/
void
-Perl_av_undef(pTHX_ register AV *av)
+Perl_av_undef(pTHX_ AV *av)
{
+ bool real;
+
PERL_ARGS_ASSERT_AV_UNDEF;
assert(SvTYPE(av) == SVt_PVAV);
@@ -488,8 +500,10 @@
if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
av_fill(av, -1);
- if (AvREAL(av)) {
- register I32 key = AvFILLp(av) + 1;
+ if ((real = !!AvREAL(av))) {
+ I32 key = AvFILLp(av) + 1;
+ ENTER;
+ SAVEFREESV(SvREFCNT_inc_simple_NN(av));
while (key)
SvREFCNT_dec(AvARRAY(av)[--key]);
}
@@ -500,6 +514,7 @@
AvMAX(av) = AvFILLp(av) = -1;
if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
+ if(real) LEAVE;
}
/*
@@ -526,13 +541,15 @@
=for apidoc av_push
Pushes an SV onto the end of the array. The array will grow automatically
-to accommodate the addition. This takes ownership of one reference count.
+to accommodate the addition. This takes ownership of one reference count.
+Perl equivalent: C<push @myarray, $elem;>.
+
=cut
*/
void
-Perl_av_push(pTHX_ register AV *av, SV *val)
+Perl_av_push(pTHX_ AV *av, SV *val)
{
dVAR;
MAGIC *mg;
@@ -541,7 +558,7 @@
assert(SvTYPE(av) == SVt_PVAV);
if (SvREADONLY(av))
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "PUSH", G_DISCARD, 1,
@@ -554,14 +571,17 @@
/*
=for apidoc av_pop
-Pops an SV off the end of the array. Returns C<&PL_sv_undef> if the array
-is empty.
+Removes one SV from the end of the array, reducing its size by one and
+returning the SV (transferring control of one reference count) to the
+caller. Returns C<&PL_sv_undef> if the array is empty.
+Perl equivalent: C<pop(@myarray);>
+
=cut
*/
SV *
-Perl_av_pop(pTHX_ register AV *av)
+Perl_av_pop(pTHX_ AV *av)
{
dVAR;
SV *retval;
@@ -571,7 +591,7 @@
assert(SvTYPE(av) == SVt_PVAV);
if (SvREADONLY(av))
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "POP", 0, 0);
if (retval)
@@ -616,14 +636,16 @@
array. The array will grow automatically to accommodate the addition. You
must then use C<av_store> to assign values to these new elements.
+Perl equivalent: C<unshift @myarray, ( (undef) x $n );>
+
=cut
*/
void
-Perl_av_unshift(pTHX_ register AV *av, register I32 num)
+Perl_av_unshift(pTHX_ AV *av, I32 num)
{
dVAR;
- register I32 i;
+ I32 i;
MAGIC* mg;
PERL_ARGS_ASSERT_AV_UNSHIFT;
@@ -630,7 +652,7 @@
assert(SvTYPE(av) == SVt_PVAV);
if (SvREADONLY(av))
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "UNSHIFT",
@@ -653,7 +675,7 @@
AvARRAY(av) = AvARRAY(av) - i;
}
if (num) {
- register SV **ary;
+ SV **ary;
const I32 i = AvFILLp(av);
/* Create extra elements */
const I32 slide = i > 0 ? i : 0;
@@ -675,14 +697,17 @@
/*
=for apidoc av_shift
-Shifts an SV off the beginning of the array. Returns C<&PL_sv_undef> if the
+Shifts an SV off the beginning of the
+array. Returns C<&PL_sv_undef> if the
array is empty.
+Perl equivalent: C<shift(@myarray);>
+
=cut
*/
SV *
-Perl_av_shift(pTHX_ register AV *av)
+Perl_av_shift(pTHX_ AV *av)
{
dVAR;
SV *retval;
@@ -692,7 +717,7 @@
assert(SvTYPE(av) == SVt_PVAV);
if (SvREADONLY(av))
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "SHIFT", 0, 0);
if (retval)
@@ -713,13 +738,21 @@
}
/*
-=for apidoc av_len
+=for apidoc av_top_index
Returns the highest index in the array. The number of elements in the
-array is C<av_len(av) + 1>. Returns -1 if the array is empty.
+array is C<av_top_index(av) + 1>. Returns -1 if the array is empty.
The Perl equivalent for this is C<$#myarray>.
+(A slightly shorter form is C<av_tindex>.)
+
+=for apidoc av_len
+
+Same as L</av_top_index>. Returns the highest index in the array. Note that the
+return value is +1 what its name implies it returns; and hence differs in
+meaning from what the similarly named L</sv_len> returns.
+
=cut
*/
@@ -727,9 +760,8 @@
Perl_av_len(pTHX_ AV *av)
{
PERL_ARGS_ASSERT_AV_LEN;
- assert(SvTYPE(av) == SVt_PVAV);
- return AvFILL(av);
+ return av_top_index(av);
}
/*
@@ -747,7 +779,7 @@
=cut
*/
void
-Perl_av_fill(pTHX_ register AV *av, I32 fill)
+Perl_av_fill(pTHX_ AV *av, I32 fill)
{
dVAR;
MAGIC *mg;
@@ -808,30 +840,16 @@
assert(SvTYPE(av) == SVt_PVAV);
if (SvREADONLY(av))
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
if (SvRMAGICAL(av)) {
const MAGIC * const tied_magic
= mg_find((const SV *)av, PERL_MAGIC_tied);
if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
- /* Handle negative array indices 20020222 MJD */
SV **svp;
if (key < 0) {
- unsigned adjust_index = 1;
- if (tied_magic) {
- SV * const * const negative_indices_glob =
- hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
- tied_magic))),
- NEGATIVE_INDICES_VAR, 16, 0);
- if (negative_indices_glob
- && SvTRUE(GvSV(*negative_indices_glob)))
- adjust_index = 0;
- }
- if (adjust_index) {
- key += AvFILL(av) + 1;
- if (key < 0)
+ if (!S_adjust_index(aTHX_ av, tied_magic, &key))
return NULL;
- }
}
svp = av_fetch(av, key, TRUE);
if (svp) {
@@ -903,27 +921,11 @@
const MAGIC * const regdata_magic
= mg_find((const SV *)av, PERL_MAGIC_regdata);
if (tied_magic || regdata_magic) {
- SV * const sv = sv_newmortal();
MAGIC *mg;
/* Handle negative array indices 20020222 MJD */
if (key < 0) {
- unsigned adjust_index = 1;
- if (tied_magic) {
- SV * const * const negative_indices_glob =
- hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
- tied_magic))),
- NEGATIVE_INDICES_VAR, 16, 0);
- if (negative_indices_glob
- && SvTRUE(GvSV(*negative_indices_glob)))
- adjust_index = 0;
- }
- if (adjust_index) {
- key += AvFILL(av) + 1;
- if (key < 0)
+ if (!S_adjust_index(aTHX_ av, tied_magic, &key))
return FALSE;
- else
- return TRUE;
- }
}
if(key >= 0 && regdata_magic) {
@@ -932,14 +934,18 @@
else
return FALSE;
}
-
- mg_copy(MUTABLE_SV(av), sv, 0, key);
- mg = mg_find(sv, PERL_MAGIC_tiedelem);
- if (mg) {
- magic_existspack(sv, mg);
- return cBOOL(SvTRUE(sv));
- }
-
+ {
+ SV * const sv = sv_newmortal();
+ mg_copy(MUTABLE_SV(av), sv, 0, key);
+ mg = mg_find(sv, PERL_MAGIC_tiedelem);
+ if (mg) {
+ magic_existspack(sv, mg);
+ {
+ I32 retbool = SvTRUE_nomg_NN(sv);
+ return cBOOL(retbool);
+ }
+ }
+ }
}
}
@@ -1012,8 +1018,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/av.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/av.h
===================================================================
--- trunk/contrib/perl/av.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/av.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -47,8 +47,11 @@
=head1 Array Manipulation Functions
=for apidoc Am|int|AvFILL|AV* av
-Same as C<av_len()>. Deprecated, use C<av_len()> instead.
+Same as C<av_top_index()>. Deprecated, use C<av_top_index()> instead.
+=for apidoc Am|int|av_tindex|AV* av
+Same as C<av_top_index()>.
+
=cut
*/
@@ -75,6 +78,7 @@
#define AvFILL(av) ((SvRMAGICAL((const SV *) (av))) \
? mg_size(MUTABLE_SV(av)) : AvFILLp(av))
+#define av_tindex(av) av_top_index(av)
#define NEGATIVE_INDICES_VAR "NEGATIVE_INDICES"
@@ -83,6 +87,8 @@
Creates a new AV. The reference count is set to 1.
+Perl equivalent: C<my @array;>.
+
=cut
*/
@@ -92,8 +98,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/av.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.4
\ No newline at end of property
Modified: trunk/contrib/perl/cflags.SH
===================================================================
--- trunk/contrib/perl/cflags.SH 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/cflags.SH 2013-12-02 21:18:17 UTC (rev 6438)
@@ -1,3 +1,5 @@
+#!/bin/sh
+
case $PERL_CONFIG_SH in
'')
if test -f config.sh; then TOP=.;
@@ -140,7 +142,7 @@
case " $ccflags " in
*" $opt "*) ;; # Skip if already there.
*) rm -f _cflags$_exe
- case "`$cc $cflags $warn $stdflags $opt _cflags.c -o _cflags$_exe 2>&1`" in
+ case "`$cc -DPERL_NO_INLINE_FUNCTIONS $cflags $warn $stdflags $opt _cflags.c -o _cflags$_exe 2>&1`" in
*"unrecognized"*) ;;
*"implicit declaration"*) ;; # Was something useful hidden?
*"Invalid"*) ;;
@@ -273,56 +275,23 @@
: or customize here
case "$file" in
- DB_File) ;;
- GDBM_File) ;;
- NDBM_File) ;;
- ODBM_File) ;;
- POSIX) ;;
- SDBM_File) ;;
- av) ;;
- byterun) ;;
- deb) ;;
- dl) ;;
- doio) ;;
- doop) ;;
- dump) ;;
- globals) ;;
- gv) ;;
- hv) ;;
- locale) ;;
- madly) ;;
- main) ;;
- malloc) ;;
- mg) ;;
- miniperlmain) ;;
- numeric) ;;
- op) ;;
- opmini) ;;
- pad) ;;
- perl) ;;
- perlapi) ;;
- perlmain) ;;
- perly) ;;
- pp) ;;
- pp_ctl) ;;
- pp_hot) ;;
- pp_pack) ;;
- pp_sort) ;;
- pp_sys) ;;
- regcomp) ;;
- regexec) ;;
- run) ;;
- scope) ;;
- sv) ;;
- taint) ;;
- toke) ;;
- universal) ;;
- usersub) ;;
- utf8) ;;
- util) ;;
*) ;;
+
+ *) : Customization examples follow: ;;
+ av) ccflags=`echo $ccflags | sed -e s/-pipe//` ;;
+ deb) ccflags="$ccflags -fno-jump-tables" ;;
+ hv) warn=`echo $warn | sed -e s/-Wextra//` ;;
+ toke) optimize=-O0 ;;
esac
+ : The examples are intentionally unreachable as the '*)' case always
+ : matches. To use them, move before the '*)' and edit as appropriate.
+ : It is not a good idea to set ccflags to an absolute value here, as it
+ : often contains general -D defines which are needed for correct
+ : compilation. It is better to edit ccflags as shown, using interpolation
+ : to add flags, or sed to remove flags.
+
+
case "$cc" in
*g++*)
# Extra paranoia in case people have bad canned ccflags:
@@ -337,6 +306,10 @@
cppflags=`echo $cppflags|sed 's/-Wdeclaration-after-statement/ /'`
case "$cc" in
+ *clang)
+ # clang complains a lot about -Wunused-value which are not fixable
+ warn="$warn -Wno-unused-value"
+ ;;
*g++*)
# Without -Wno-unused-variable g++ 4.x compiles are rather unwatchable
# because of all the warnings about Perl___notused, and g++ doesn't do
Property changes on: trunk/contrib/perl/cflags.SH
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/charclass_invlists.h (from rev 6437, vendor/perl/5.18.1/charclass_invlists.h)
===================================================================
--- trunk/contrib/perl/charclass_invlists.h (rev 0)
+++ trunk/contrib/perl/charclass_invlists.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -0,0 +1,813 @@
+/* -*- buffer-read-only: t -*-
+ * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ * This file is built by regen/mk_invlists.pl from Unicode::UCD.
+ * Any changes made here will be lost!
+ */
+
+/* See the generating file for comments */
+
+
+#ifndef PERL_IN_XSUB_RE
+
+static UV Latin1_invlist[] = {
+ 2, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 0, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 256,
+ 0
+};
+
+#endif
+
+#ifndef PERL_IN_XSUB_RE
+
+static UV AboveLatin1_invlist[] = {
+ 1, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 1, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 256
+};
+
+#endif
+
+#ifndef PERL_IN_XSUB_RE
+
+static UV ASCII_invlist[] = {
+ 2, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 0, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 128,
+ 0
+};
+
+#endif
+
+#ifndef PERL_IN_XSUB_RE
+
+static UV L1Cased_invlist[] = {
+ 16, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 1, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 65,
+ 91,
+ 97,
+ 123,
+ 170,
+ 171,
+ 181,
+ 182,
+ 186,
+ 187,
+ 192,
+ 215,
+ 216,
+ 247,
+ 248,
+ 443
+};
+
+#endif
+
+#ifndef PERL_IN_XSUB_RE
+
+static UV VertSpace_invlist[] = {
+ 6, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 1, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 10,
+ 14,
+ 133,
+ 134,
+ 8232,
+ 8234
+};
+
+#endif
+
+#ifndef PERL_IN_XSUB_RE
+
+static UV PerlSpace_invlist[] = {
+ 4, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 1, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 9,
+ 14,
+ 32,
+ 33
+};
+
+#endif
+
+#ifndef PERL_IN_XSUB_RE
+
+static UV XPerlSpace_invlist[] = {
+ 22, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 1, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 9,
+ 14,
+ 32,
+ 33,
+ 133,
+ 134,
+ 160,
+ 161,
+ 5760,
+ 5761,
+ 6158,
+ 6159,
+ 8192,
+ 8203,
+ 8232,
+ 8234,
+ 8239,
+ 8240,
+ 8287,
+ 8288,
+ 12288,
+ 12289
+};
+
+#endif
+
+#ifndef PERL_IN_XSUB_RE
+
+static UV PosixAlnum_invlist[] = {
+ 6, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 1, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 48,
+ 58,
+ 65,
+ 91,
+ 97,
+ 123
+};
+
+#endif
+
+#ifndef PERL_IN_XSUB_RE
+
+static UV L1PosixAlnum_invlist[] = {
+ 18, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 1, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 48,
+ 58,
+ 65,
+ 91,
+ 97,
+ 123,
+ 170,
+ 171,
+ 181,
+ 182,
+ 186,
+ 187,
+ 192,
+ 215,
+ 216,
+ 247,
+ 248,
+ 706
+};
+
+#endif
+
+#ifndef PERL_IN_XSUB_RE
+
+static UV PosixAlpha_invlist[] = {
+ 4, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 1, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 65,
+ 91,
+ 97,
+ 123
+};
+
+#endif
+
+#ifndef PERL_IN_XSUB_RE
+
+static UV L1PosixAlpha_invlist[] = {
+ 16, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 1, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 65,
+ 91,
+ 97,
+ 123,
+ 170,
+ 171,
+ 181,
+ 182,
+ 186,
+ 187,
+ 192,
+ 215,
+ 216,
+ 247,
+ 248,
+ 706
+};
+
+#endif
+
+#ifndef PERL_IN_XSUB_RE
+
+static UV PosixBlank_invlist[] = {
+ 4, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 1, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 9,
+ 10,
+ 32,
+ 33
+};
+
+#endif
+
+#ifndef PERL_IN_XSUB_RE
+
+static UV XPosixBlank_invlist[] = {
+ 18, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 1, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 9,
+ 10,
+ 32,
+ 33,
+ 160,
+ 161,
+ 5760,
+ 5761,
+ 6158,
+ 6159,
+ 8192,
+ 8203,
+ 8239,
+ 8240,
+ 8287,
+ 8288,
+ 12288,
+ 12289
+};
+
+#endif
+
+#ifndef PERL_IN_XSUB_RE
+
+static UV PosixCntrl_invlist[] = {
+ 4, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 0, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 32,
+ 127,
+ 128,
+ 0
+};
+
+#endif
+
+#ifndef PERL_IN_XSUB_RE
+
+static UV XPosixCntrl_invlist[] = {
+ 4, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 0, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 32,
+ 127,
+ 160,
+ 0
+};
+
+#endif
+
+#ifndef PERL_IN_XSUB_RE
+
+static UV PosixDigit_invlist[] = {
+ 2, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 1, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 48,
+ 58
+};
+
+#endif
+
+#ifndef PERL_IN_XSUB_RE
+
+static UV PosixGraph_invlist[] = {
+ 2, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 1, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 33,
+ 127
+};
+
+#endif
+
+#ifndef PERL_IN_XSUB_RE
+
+static UV L1PosixGraph_invlist[] = {
+ 4, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 1, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 33,
+ 127,
+ 161,
+ 888
+};
+
+#endif
+
+#ifndef PERL_IN_XSUB_RE
+
+static UV PosixLower_invlist[] = {
+ 2, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 1, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 97,
+ 123
+};
+
+#endif
+
+#ifndef PERL_IN_XSUB_RE
+
+static UV L1PosixLower_invlist[] = {
+ 12, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 1, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 97,
+ 123,
+ 170,
+ 171,
+ 181,
+ 182,
+ 186,
+ 187,
+ 223,
+ 247,
+ 248,
+ 256
+};
+
+#endif
+
+#ifndef PERL_IN_XSUB_RE
+
+static UV PosixPrint_invlist[] = {
+ 2, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 1, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 32,
+ 127
+};
+
+#endif
+
+#ifndef PERL_IN_XSUB_RE
+
+static UV L1PosixPrint_invlist[] = {
+ 4, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 1, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 32,
+ 127,
+ 160,
+ 888
+};
+
+#endif
+
+#ifndef PERL_IN_XSUB_RE
+
+static UV PosixPunct_invlist[] = {
+ 8, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 1, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 33,
+ 48,
+ 58,
+ 65,
+ 91,
+ 97,
+ 123,
+ 127
+};
+
+#endif
+
+#ifndef PERL_IN_XSUB_RE
+
+static UV L1PosixPunct_invlist[] = {
+ 20, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 1, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 33,
+ 48,
+ 58,
+ 65,
+ 91,
+ 97,
+ 123,
+ 127,
+ 161,
+ 162,
+ 167,
+ 168,
+ 171,
+ 172,
+ 182,
+ 184,
+ 187,
+ 188,
+ 191,
+ 192
+};
+
+#endif
+
+#ifndef PERL_IN_XSUB_RE
+
+static UV PosixSpace_invlist[] = {
+ 4, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 1, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 9,
+ 14,
+ 32,
+ 33
+};
+
+#endif
+
+#ifndef PERL_IN_XSUB_RE
+
+static UV XPosixSpace_invlist[] = {
+ 22, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 1, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 9,
+ 14,
+ 32,
+ 33,
+ 133,
+ 134,
+ 160,
+ 161,
+ 5760,
+ 5761,
+ 6158,
+ 6159,
+ 8192,
+ 8203,
+ 8232,
+ 8234,
+ 8239,
+ 8240,
+ 8287,
+ 8288,
+ 12288,
+ 12289
+};
+
+#endif
+
+#ifndef PERL_IN_XSUB_RE
+
+static UV PosixUpper_invlist[] = {
+ 2, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 1, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 65,
+ 91
+};
+
+#endif
+
+#ifndef PERL_IN_XSUB_RE
+
+static UV L1PosixUpper_invlist[] = {
+ 6, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 1, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 65,
+ 91,
+ 192,
+ 215,
+ 216,
+ 223
+};
+
+#endif
+
+#ifndef PERL_IN_XSUB_RE
+
+static UV PosixWord_invlist[] = {
+ 8, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 1, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 48,
+ 58,
+ 65,
+ 91,
+ 95,
+ 96,
+ 97,
+ 123
+};
+
+#endif
+
+#ifndef PERL_IN_XSUB_RE
+
+static UV L1PosixWord_invlist[] = {
+ 20, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 1, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 48,
+ 58,
+ 65,
+ 91,
+ 95,
+ 96,
+ 97,
+ 123,
+ 170,
+ 171,
+ 181,
+ 182,
+ 186,
+ 187,
+ 192,
+ 215,
+ 216,
+ 247,
+ 248,
+ 706
+};
+
+#endif
+
+#ifndef PERL_IN_XSUB_RE
+
+static UV PosixXDigit_invlist[] = {
+ 6, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 1, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 48,
+ 58,
+ 65,
+ 71,
+ 97,
+ 103
+};
+
+#endif
+
+#ifndef PERL_IN_XSUB_RE
+
+static UV XPosixXDigit_invlist[] = {
+ 12, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 1, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 48,
+ 58,
+ 65,
+ 71,
+ 97,
+ 103,
+ 65296,
+ 65306,
+ 65313,
+ 65319,
+ 65345,
+ 65351
+};
+
+#endif
+
+static UV NonL1_Perl_Non_Final_Folds_invlist[] = {
+ 44, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 1, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 700,
+ 701,
+ 776,
+ 777,
+ 787,
+ 788,
+ 834,
+ 835,
+ 940,
+ 941,
+ 942,
+ 943,
+ 945,
+ 946,
+ 951,
+ 952,
+ 953,
+ 954,
+ 961,
+ 962,
+ 965,
+ 966,
+ 969,
+ 970,
+ 974,
+ 975,
+ 1381,
+ 1382,
+ 1396,
+ 1397,
+ 1406,
+ 1407,
+ 7936,
+ 7944,
+ 7968,
+ 7976,
+ 8032,
+ 8040,
+ 8048,
+ 8049,
+ 8052,
+ 8053,
+ 8060,
+ 8061
+};
+
+#ifndef PERL_IN_XSUB_RE
+
+static UV _Perl_Multi_Char_Folds_invlist[] = {
+ 58, /* Number of elements */
+ 0, /* Current iteration position */
+ 0, /* Cache of previous search index result */
+ 290655244, /* Version and data structure type */
+ 1, /* 0 if this is the first element of the list proper;
+ 1 if the next element is the first */
+ 223,
+ 224,
+ 304,
+ 305,
+ 329,
+ 330,
+ 496,
+ 497,
+ 912,
+ 913,
+ 944,
+ 945,
+ 1415,
+ 1416,
+ 7830,
+ 7835,
+ 7838,
+ 7839,
+ 8016,
+ 8017,
+ 8018,
+ 8019,
+ 8020,
+ 8021,
+ 8022,
+ 8023,
+ 8064,
+ 8112,
+ 8114,
+ 8117,
+ 8118,
+ 8120,
+ 8124,
+ 8125,
+ 8130,
+ 8133,
+ 8134,
+ 8136,
+ 8140,
+ 8141,
+ 8146,
+ 8148,
+ 8150,
+ 8152,
+ 8162,
+ 8165,
+ 8166,
+ 8168,
+ 8178,
+ 8181,
+ 8182,
+ 8184,
+ 8188,
+ 8189,
+ 64256,
+ 64263,
+ 64275,
+ 64280
+};
+
+#endif
+
+/* ex: set ro: */
Modified: trunk/contrib/perl/config_h.SH
===================================================================
--- trunk/contrib/perl/config_h.SH 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/config_h.SH 2013-12-02 21:18:17 UTC (rev 6438)
@@ -1,3 +1,5 @@
+#!/bin/sh
+#
# THIS IS A GENERATED FILE
# DO NOT HAND-EDIT
#
@@ -121,7 +123,7 @@
* of significant digits in a double precision number. If this
* symbol is not defined, a guess of 15 is usually pretty good.
*/
-#$d_dbl_dig HAS_DBL_DIG /* */
+#$d_dbl_dig HAS_DBL_DIG /**/
/* HAS_DIFFTIME:
* This symbol, if defined, indicates that the difftime routine is
@@ -912,47 +914,19 @@
#define _V(args) ()
#endif
-/* INTSIZE:
- * This symbol contains the value of sizeof(int) so that the C
- * preprocessor can make decisions based on it.
+/* OSNAME:
+ * This symbol contains the name of the operating system, as determined
+ * by Configure. You shouldn't rely on it too much; the specific
+ * feature tests from Configure are generally more reliable.
*/
-/* LONGSIZE:
- * This symbol contains the value of sizeof(long) so that the C
- * preprocessor can make decisions based on it.
+/* OSVERS:
+ * This symbol contains the version of the operating system, as determined
+ * by Configure. You shouldn't rely on it too much; the specific
+ * feature tests from Configure are generally more reliable.
*/
-/* SHORTSIZE:
- * This symbol contains the value of sizeof(short) so that the C
- * preprocessor can make decisions based on it.
- */
-#define INTSIZE $intsize /**/
-#define LONGSIZE $longsize /**/
-#define SHORTSIZE $shortsize /**/
+#define OSNAME "$osname" /**/
+#define OSVERS "$osvers" /**/
-/* MULTIARCH:
- * This symbol, if defined, signifies that the build
- * process will produce some binary files that are going to be
- * used in a cross-platform environment. This is the case for
- * example with the NeXT "fat" binaries that contain executables
- * for several CPUs.
- */
-#$multiarch MULTIARCH /**/
-
-/* HAS_QUAD:
- * This symbol, if defined, tells that there's a 64-bit integer type,
- * Quad_t, and its unsigned counterpart, Uquad_t. QUADKIND will be one
- * of QUAD_IS_INT, QUAD_IS_LONG, QUAD_IS_LONG_LONG, or QUAD_IS_INT64_T.
- */
-#$d_quad HAS_QUAD /**/
-#ifdef HAS_QUAD
-# define Quad_t $quadtype /**/
-# define Uquad_t $uquadtype /**/
-# define QUADKIND $quadkind /**/
-# define QUAD_IS_INT 1
-# define QUAD_IS_LONG 2
-# define QUAD_IS_LONG_LONG 3
-# define QUAD_IS_INT64_T 4
-#endif
-
/* USE_CROSS_COMPILE:
* This symbol, if defined, indicates that Perl is being cross-compiled.
*/
@@ -965,16 +939,22 @@
#define PERL_TARGETARCH "$targetarch" /**/
#endif
+/* MULTIARCH:
+ * This symbol, if defined, signifies that the build
+ * process will produce some binary files that are going to be
+ * used in a cross-platform environment. This is the case for
+ * example with the NeXT "fat" binaries that contain executables
+ * for several CPUs.
+ */
+#$multiarch MULTIARCH /**/
+
/* MEM_ALIGNBYTES:
* This symbol contains the number of bytes required to align a
* double, or a long double when applicable. Usual values are 2,
- * 4 and 8. The default is eight, for safety.
+ * 4 and 8. The default is eight, for safety. For cross-compiling
+ * or multiarch support, Configure will set a minimum of 8.
*/
-#if defined(USE_CROSS_COMPILE) || defined(MULTIARCH)
-# define MEM_ALIGNBYTES 8
-#else
#define MEM_ALIGNBYTES $alignbytes
-#endif
/* ARCHLIB:
* This variable, if defined, holds the name of the directory in
@@ -1016,11 +996,27 @@
#define BIN_EXP "$binexp" /**/
#define PERL_RELOCATABLE_INC "$userelocatableinc" /**/
+/* INTSIZE:
+ * This symbol contains the value of sizeof(int) so that the C
+ * preprocessor can make decisions based on it.
+ */
+/* LONGSIZE:
+ * This symbol contains the value of sizeof(long) so that the C
+ * preprocessor can make decisions based on it.
+ */
+/* SHORTSIZE:
+ * This symbol contains the value of sizeof(short) so that the C
+ * preprocessor can make decisions based on it.
+ */
+#define INTSIZE $intsize /**/
+#define LONGSIZE $longsize /**/
+#define SHORTSIZE $shortsize /**/
+
/* BYTEORDER:
* This symbol holds the hexadecimal constant defined in byteorder,
* in a UV, i.e. 0x1234 or 0x4321 or 0x12345678, etc...
* If the compiler supports cross-compiling or multiple-architecture
- * binaries (eg. on NeXT systems), use compiler-defined macros to
+ * binaries (e.g. on NeXT systems), use compiler-defined macros to
* determine the byte order.
* On NeXT 3.2 (and greater), you can build "Fat" Multiple Architecture
* Binaries (MAB) on either big endian or little endian machines.
@@ -1065,6 +1061,64 @@
*/
#define CHARBITS $charbits /**/
+/* CAT2:
+ * This macro concatenates 2 tokens together.
+ */
+/* STRINGIFY:
+ * This macro surrounds its token with double quotes.
+ */
+#if $cpp_stuff == 1
+#define CAT2(a,b) a/**/b
+#define STRINGIFY(a) "a"
+#endif
+#if $cpp_stuff == 42
+#define PeRl_CaTiFy(a, b) a ## b
+#define PeRl_StGiFy(a) #a
+#define CAT2(a,b) PeRl_CaTiFy(a,b)
+#define StGiFy(a) PeRl_StGiFy(a)
+#define STRINGIFY(a) PeRl_StGiFy(a)
+#endif
+#if $cpp_stuff != 1 && $cpp_stuff != 42
+#include "Bletch: How does this C preprocessor concatenate tokens?"
+#endif
+
+/* CPPSTDIN:
+ * This symbol contains the first part of the string which will invoke
+ * the C preprocessor on the standard input and produce to standard
+ * output. Typical value of "cc -E" or "/lib/cpp", but it can also
+ * call a wrapper. See CPPRUN.
+ */
+/* CPPMINUS:
+ * This symbol contains the second part of the string which will invoke
+ * the C preprocessor on the standard input and produce to standard
+ * output. This symbol will have the value "-" if CPPSTDIN needs a minus
+ * to specify standard input, otherwise the value is "".
+ */
+/* CPPRUN:
+ * This symbol contains the string which will invoke a C preprocessor on
+ * the standard input and produce to standard output. It needs to end
+ * with CPPLAST, after all other preprocessor flags have been specified.
+ * The main difference with CPPSTDIN is that this program will never be a
+ * pointer to a shell wrapper, i.e. it will be empty if no preprocessor is
+ * available directly to the user. Note that it may well be different from
+ * the preprocessor used to compile the C program.
+ */
+/* CPPLAST:
+ * This symbol is intended to be used along with CPPRUN in the same manner
+ * symbol CPPMINUS is used with CPPSTDIN. It contains either "-" or "".
+ */
+#define CPPSTDIN "$cppstdin"
+#define CPPMINUS "$cppminus"
+#define CPPRUN "$cpprun"
+#define CPPLAST "$cpplast"
+
+/* HAS_ACCESS:
+ * This manifest constant lets the C program know that the access()
+ * system call is available to check for accessibility using real UID/GID.
+ * (always present on UNIX.)
+ */
+#$d_access HAS_ACCESS /**/
+
/* HAS_ACCESSX:
* This symbol, if defined, indicates that the accessx routine is
* available to do extended access checks.
@@ -1084,6 +1138,43 @@
#$d_asctime_r HAS_ASCTIME_R /**/
#define ASCTIME_R_PROTO $asctime_r_proto /**/
+/* HASATTRIBUTE_FORMAT:
+ * Can we handle GCC attribute for checking printf-style formats
+ */
+/* PRINTF_FORMAT_NULL_OK:
+ * Allows __printf__ format to be null when checking printf-style
+ */
+/* HASATTRIBUTE_MALLOC:
+ * Can we handle GCC attribute for malloc-style functions.
+ */
+/* HASATTRIBUTE_NONNULL:
+ * Can we handle GCC attribute for nonnull function parms.
+ */
+/* HASATTRIBUTE_NORETURN:
+ * Can we handle GCC attribute for functions that do not return
+ */
+/* HASATTRIBUTE_PURE:
+ * Can we handle GCC attribute for pure functions
+ */
+/* HASATTRIBUTE_UNUSED:
+ * Can we handle GCC attribute for unused variables and arguments
+ */
+/* HASATTRIBUTE_DEPRECATED:
+ * Can we handle GCC attribute for marking deprecated APIs
+ */
+/* HASATTRIBUTE_WARN_UNUSED_RESULT:
+ * Can we handle GCC attribute for warning on unused results
+ */
+#$d_attribute_deprecated HASATTRIBUTE_DEPRECATED /**/
+#$d_attribute_format HASATTRIBUTE_FORMAT /**/
+#$d_printf_format_null PRINTF_FORMAT_NULL_OK /**/
+#$d_attribute_noreturn HASATTRIBUTE_NORETURN /**/
+#$d_attribute_malloc HASATTRIBUTE_MALLOC /**/
+#$d_attribute_nonnull HASATTRIBUTE_NONNULL /**/
+#$d_attribute_pure HASATTRIBUTE_PURE /**/
+#$d_attribute_unused HASATTRIBUTE_UNUSED /**/
+#$d_attribute_warn_unused_result HASATTRIBUTE_WARN_UNUSED_RESULT /**/
+
/* CASTI32:
* This symbol is defined if the C compiler can cast negative
* or large floating point numbers to 32-bit ints.
@@ -1111,6 +1202,17 @@
*/
#$d_void_closedir VOID_CLOSEDIR /**/
+/* HASCONST:
+ * This symbol, if defined, indicates that this C compiler knows about
+ * the const type. There is no need to actually test for that symbol
+ * within your programs. The mere use of the "const" keyword will
+ * trigger the necessary tests.
+ */
+#$d_const HASCONST /**/
+#ifndef HASCONST
+#define const
+#endif
+
/* HAS_CRYPT_R:
* This symbol, if defined, indicates that the crypt_r routine
* is available to crypt re-entrantly.
@@ -1124,6 +1226,17 @@
#$d_crypt_r HAS_CRYPT_R /**/
#define CRYPT_R_PROTO $crypt_r_proto /**/
+/* HAS_CSH:
+ * This symbol, if defined, indicates that the C-shell exists.
+ */
+/* CSH:
+ * This symbol, if defined, contains the full pathname of csh.
+ */
+#$d_csh HAS_CSH /**/
+#ifdef HAS_CSH
+#define CSH "$full_csh" /**/
+#endif
+
/* HAS_CTERMID_R:
* This symbol, if defined, indicates that the ctermid_r routine
* is available to ctermid re-entrantly.
@@ -1150,6 +1263,26 @@
#$d_ctime_r HAS_CTIME_R /**/
#define CTIME_R_PROTO $ctime_r_proto /**/
+/* SETUID_SCRIPTS_ARE_SECURE_NOW:
+ * This symbol, if defined, indicates that the bug that prevents
+ * setuid scripts from being secure is not present in this kernel.
+ */
+/* DOSUID:
+ * This symbol, if defined, indicates that the C program should
+ * check the script that it is executing for setuid/setgid bits, and
+ * attempt to emulate setuid/setgid on systems that have disabled
+ * setuid #! scripts because the kernel can't do it securely.
+ * It is up to the package designer to make sure that this emulation
+ * is done securely. Among other things, it should do an fstat on
+ * the script it just opened to make sure it really is a setuid/setgid
+ * script, it should make sure the arguments passed correspond exactly
+ * to the argument on the #! line, and it should not trust any
+ * subprocesses to which it must pass the filename rather than the
+ * file descriptor of the script to be executed.
+ */
+#$d_suidsafe SETUID_SCRIPTS_ARE_SECURE_NOW /**/
+#$d_dosuid DOSUID /**/
+
/* HAS_DRAND48_R:
* This symbol, if defined, indicates that the drand48_r routine
* is available to drand48 re-entrantly.
@@ -1163,6 +1296,14 @@
#$d_drand48_r HAS_DRAND48_R /**/
#define DRAND48_R_PROTO $drand48_r_proto /**/
+/* HAS_DRAND48_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the drand48() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern double drand48(void);
+ */
+#$d_drand48proto HAS_DRAND48_PROTO /**/
+
/* HAS_EACCESS:
* This symbol, if defined, indicates that the eaccess routine is
* available to do extended access checks.
@@ -1169,6 +1310,12 @@
*/
#$d_eaccess HAS_EACCESS /**/
+/* HAS_ENDGRENT:
+ * This symbol, if defined, indicates that the getgrent routine is
+ * available for finalizing sequential access of the group database.
+ */
+#$d_endgrent HAS_ENDGRENT /**/
+
/* HAS_ENDGRENT_R:
* This symbol, if defined, indicates that the endgrent_r routine
* is available to endgrent re-entrantly.
@@ -1182,6 +1329,12 @@
#$d_endgrent_r HAS_ENDGRENT_R /**/
#define ENDGRENT_R_PROTO $endgrent_r_proto /**/
+/* HAS_ENDHOSTENT:
+ * This symbol, if defined, indicates that the endhostent() routine is
+ * available to close whatever was being used for host queries.
+ */
+#$d_endhent HAS_ENDHOSTENT /**/
+
/* HAS_ENDHOSTENT_R:
* This symbol, if defined, indicates that the endhostent_r routine
* is available to endhostent re-entrantly.
@@ -1195,6 +1348,12 @@
#$d_endhostent_r HAS_ENDHOSTENT_R /**/
#define ENDHOSTENT_R_PROTO $endhostent_r_proto /**/
+/* HAS_ENDNETENT:
+ * This symbol, if defined, indicates that the endnetent() routine is
+ * available to close whatever was being used for network queries.
+ */
+#$d_endnent HAS_ENDNETENT /**/
+
/* HAS_ENDNETENT_R:
* This symbol, if defined, indicates that the endnetent_r routine
* is available to endnetent re-entrantly.
@@ -1208,6 +1367,12 @@
#$d_endnetent_r HAS_ENDNETENT_R /**/
#define ENDNETENT_R_PROTO $endnetent_r_proto /**/
+/* HAS_ENDPROTOENT:
+ * This symbol, if defined, indicates that the endprotoent() routine is
+ * available to close whatever was being used for protocol queries.
+ */
+#$d_endpent HAS_ENDPROTOENT /**/
+
/* HAS_ENDPROTOENT_R:
* This symbol, if defined, indicates that the endprotoent_r routine
* is available to endprotoent re-entrantly.
@@ -1221,6 +1386,12 @@
#$d_endprotoent_r HAS_ENDPROTOENT_R /**/
#define ENDPROTOENT_R_PROTO $endprotoent_r_proto /**/
+/* HAS_ENDPWENT:
+ * This symbol, if defined, indicates that the getgrent routine is
+ * available for finalizing sequential access of the passwd database.
+ */
+#$d_endpwent HAS_ENDPWENT /**/
+
/* HAS_ENDPWENT_R:
* This symbol, if defined, indicates that the endpwent_r routine
* is available to endpwent re-entrantly.
@@ -1234,6 +1405,12 @@
#$d_endpwent_r HAS_ENDPWENT_R /**/
#define ENDPWENT_R_PROTO $endpwent_r_proto /**/
+/* HAS_ENDSERVENT:
+ * This symbol, if defined, indicates that the endservent() routine is
+ * available to close whatever was being used for service queries.
+ */
+#$d_endsent HAS_ENDSERVENT /**/
+
/* HAS_ENDSERVENT_R:
* This symbol, if defined, indicates that the endservent_r routine
* is available to endservent re-entrantly.
@@ -1253,6 +1430,12 @@
*/
#$d_fd_set HAS_FD_SET /**/
+/* FLEXFILENAMES:
+ * This symbol, if defined, indicates that the system supports filenames
+ * longer than 14 characters.
+ */
+#$d_flexfnam FLEXFILENAMES /**/
+
/* Gconvert:
* This preprocessor macro is defined to convert a floating point
* number to a string without a trailing decimal point. This
@@ -1270,6 +1453,12 @@
*/
#define Gconvert(x,n,t,b) $d_Gconvert
+/* HAS_GETGRENT:
+ * This symbol, if defined, indicates that the getgrent routine is
+ * available for sequential access of the group database.
+ */
+#$d_getgrent HAS_GETGRENT /**/
+
/* HAS_GETGRENT_R:
* This symbol, if defined, indicates that the getgrent_r routine
* is available to getgrent re-entrantly.
@@ -1309,6 +1498,53 @@
#$d_getgrnam_r HAS_GETGRNAM_R /**/
#define GETGRNAM_R_PROTO $getgrnam_r_proto /**/
+/* HAS_GETHOSTBYADDR:
+ * This symbol, if defined, indicates that the gethostbyaddr() routine is
+ * available to look up hosts by their IP addresses.
+ */
+#$d_gethbyaddr HAS_GETHOSTBYADDR /**/
+
+/* HAS_GETHOSTBYNAME:
+ * This symbol, if defined, indicates that the gethostbyname() routine is
+ * available to look up host names in some data base or other.
+ */
+#$d_gethbyname HAS_GETHOSTBYNAME /**/
+
+/* HAS_GETHOSTENT:
+ * This symbol, if defined, indicates that the gethostent() routine is
+ * available to look up host names in some data base or another.
+ */
+#$d_gethent HAS_GETHOSTENT /**/
+
+/* HAS_GETHOSTNAME:
+ * This symbol, if defined, indicates that the C program may use the
+ * gethostname() routine to derive the host name. See also HAS_UNAME
+ * and PHOSTNAME.
+ */
+/* HAS_UNAME:
+ * This symbol, if defined, indicates that the C program may use the
+ * uname() routine to derive the host name. See also HAS_GETHOSTNAME
+ * and PHOSTNAME.
+ */
+/* PHOSTNAME:
+ * This symbol, if defined, indicates the command to feed to the
+ * popen() routine to derive the host name. See also HAS_GETHOSTNAME
+ * and HAS_UNAME. Note that the command uses a fully qualified path,
+ * so that it is safe even if used by a process with super-user
+ * privileges.
+ */
+/* HAS_PHOSTNAME:
+ * This symbol, if defined, indicates that the C program may use the
+ * contents of PHOSTNAME as a command to feed to the popen() routine
+ * to derive the host name.
+ */
+#$d_gethname HAS_GETHOSTNAME /**/
+#$d_uname HAS_UNAME /**/
+#$d_phostname HAS_PHOSTNAME /**/
+#ifdef HAS_PHOSTNAME
+#define PHOSTNAME "$aphostname" /* How to get the host name */
+#endif
+
/* HAS_GETHOSTBYADDR_R:
* This symbol, if defined, indicates that the gethostbyaddr_r routine
* is available to gethostbyaddr re-entrantly.
@@ -1348,6 +1584,14 @@
#$d_gethostent_r HAS_GETHOSTENT_R /**/
#define GETHOSTENT_R_PROTO $gethostent_r_proto /**/
+/* HAS_GETHOST_PROTOS:
+ * This symbol, if defined, indicates that <netdb.h> includes
+ * prototypes for gethostent(), gethostbyname(), and
+ * gethostbyaddr(). Otherwise, it is up to the program to guess
+ * them. See netdbtype.U for probing for various Netdb_xxx_t types.
+ */
+#$d_gethostprotos HAS_GETHOST_PROTOS /**/
+
/* HAS_GETLOGIN_R:
* This symbol, if defined, indicates that the getlogin_r routine
* is available to getlogin re-entrantly.
@@ -1361,6 +1605,24 @@
#$d_getlogin_r HAS_GETLOGIN_R /**/
#define GETLOGIN_R_PROTO $getlogin_r_proto /**/
+/* HAS_GETNETBYADDR:
+ * This symbol, if defined, indicates that the getnetbyaddr() routine is
+ * available to look up networks by their IP addresses.
+ */
+#$d_getnbyaddr HAS_GETNETBYADDR /**/
+
+/* HAS_GETNETBYNAME:
+ * This symbol, if defined, indicates that the getnetbyname() routine is
+ * available to look up networks by their names.
+ */
+#$d_getnbyname HAS_GETNETBYNAME /**/
+
+/* HAS_GETNETENT:
+ * This symbol, if defined, indicates that the getnetent() routine is
+ * available to look up network names in some data base or another.
+ */
+#$d_getnent HAS_GETNETENT /**/
+
/* HAS_GETNETBYADDR_R:
* This symbol, if defined, indicates that the getnetbyaddr_r routine
* is available to getnetbyaddr re-entrantly.
@@ -1400,6 +1662,14 @@
#$d_getnetent_r HAS_GETNETENT_R /**/
#define GETNETENT_R_PROTO $getnetent_r_proto /**/
+/* HAS_GETNET_PROTOS:
+ * This symbol, if defined, indicates that <netdb.h> includes
+ * prototypes for getnetent(), getnetbyname(), and
+ * getnetbyaddr(). Otherwise, it is up to the program to guess
+ * them. See netdbtype.U for probing for various Netdb_xxx_t types.
+ */
+#$d_getnetprotos HAS_GETNET_PROTOS /**/
+
/* HAS_GETPAGESIZE:
* This symbol, if defined, indicates that the getpagesize system call
* is available to get system page size, which is the granularity of
@@ -1407,6 +1677,34 @@
*/
#$d_getpagsz HAS_GETPAGESIZE /**/
+/* HAS_GETPROTOENT:
+ * This symbol, if defined, indicates that the getprotoent() routine is
+ * available to look up protocols in some data base or another.
+ */
+#$d_getpent HAS_GETPROTOENT /**/
+
+/* HAS_GETPGRP:
+ * This symbol, if defined, indicates that the getpgrp routine is
+ * available to get the current process group.
+ */
+/* USE_BSD_GETPGRP:
+ * This symbol, if defined, indicates that getpgrp needs one
+ * arguments whereas USG one needs none.
+ */
+#$d_getpgrp HAS_GETPGRP /**/
+#$d_bsdgetpgrp USE_BSD_GETPGRP /**/
+
+/* HAS_GETPROTOBYNAME:
+ * This symbol, if defined, indicates that the getprotobyname()
+ * routine is available to look up protocols by their name.
+ */
+/* HAS_GETPROTOBYNUMBER:
+ * This symbol, if defined, indicates that the getprotobynumber()
+ * routine is available to look up protocols by their number.
+ */
+#$d_getpbyname HAS_GETPROTOBYNAME /**/
+#$d_getpbynumber HAS_GETPROTOBYNUMBER /**/
+
/* HAS_GETPROTOBYNAME_R:
* This symbol, if defined, indicates that the getprotobyname_r routine
* is available to getprotobyname re-entrantly.
@@ -1446,6 +1744,21 @@
#$d_getprotoent_r HAS_GETPROTOENT_R /**/
#define GETPROTOENT_R_PROTO $getprotoent_r_proto /**/
+/* HAS_GETPROTO_PROTOS:
+ * This symbol, if defined, indicates that <netdb.h> includes
+ * prototypes for getprotoent(), getprotobyname(), and
+ * getprotobyaddr(). Otherwise, it is up to the program to guess
+ * them. See netdbtype.U for probing for various Netdb_xxx_t types.
+ */
+#$d_getprotoprotos HAS_GETPROTO_PROTOS /**/
+
+/* HAS_GETPWENT:
+ * This symbol, if defined, indicates that the getpwent routine is
+ * available for sequential access of the passwd database.
+ * If this is not available, the older getpw() function may be available.
+ */
+#$d_getpwent HAS_GETPWENT /**/
+
/* HAS_GETPWENT_R:
* This symbol, if defined, indicates that the getpwent_r routine
* is available to getpwent re-entrantly.
@@ -1485,6 +1798,12 @@
#$d_getpwuid_r HAS_GETPWUID_R /**/
#define GETPWUID_R_PROTO $getpwuid_r_proto /**/
+/* HAS_GETSERVENT:
+ * This symbol, if defined, indicates that the getservent() routine is
+ * available to look up network services in some data base or another.
+ */
+#$d_getsent HAS_GETSERVENT /**/
+
/* HAS_GETSERVBYNAME_R:
* This symbol, if defined, indicates that the getservbyname_r routine
* is available to getservbyname re-entrantly.
@@ -1524,6 +1843,14 @@
#$d_getservent_r HAS_GETSERVENT_R /**/
#define GETSERVENT_R_PROTO $getservent_r_proto /**/
+/* HAS_GETSERV_PROTOS:
+ * This symbol, if defined, indicates that <netdb.h> includes
+ * prototypes for getservent(), getservbyname(), and
+ * getservbyaddr(). Otherwise, it is up to the program to guess
+ * them. See netdbtype.U for probing for various Netdb_xxx_t types.
+ */
+#$d_getservprotos HAS_GETSERV_PROTOS /**/
+
/* HAS_GETSPNAM_R:
* This symbol, if defined, indicates that the getspnam_r routine
* is available to getspnam re-entrantly.
@@ -1537,6 +1864,17 @@
#$d_getspnam_r HAS_GETSPNAM_R /**/
#define GETSPNAM_R_PROTO $getspnam_r_proto /**/
+/* HAS_GETSERVBYNAME:
+ * This symbol, if defined, indicates that the getservbyname()
+ * routine is available to look up services by their name.
+ */
+/* HAS_GETSERVBYPORT:
+ * This symbol, if defined, indicates that the getservbyport()
+ * routine is available to look up services by their port.
+ */
+#$d_getsbyname HAS_GETSERVBYNAME /**/
+#$d_getsbyport HAS_GETSERVBYPORT /**/
+
/* HAS_GMTIME_R:
* This symbol, if defined, indicates that the gmtime_r routine
* is available to gmtime re-entrantly.
@@ -1560,6 +1898,31 @@
# define _GNU_SOURCE
#endif
+/* HAS_HTONL:
+ * This symbol, if defined, indicates that the htonl() routine (and
+ * friends htons() ntohl() ntohs()) are available to do network
+ * order byte swapping.
+ */
+/* HAS_HTONS:
+ * This symbol, if defined, indicates that the htons() routine (and
+ * friends htonl() ntohl() ntohs()) are available to do network
+ * order byte swapping.
+ */
+/* HAS_NTOHL:
+ * This symbol, if defined, indicates that the ntohl() routine (and
+ * friends htonl() htons() ntohs()) are available to do network
+ * order byte swapping.
+ */
+/* HAS_NTOHS:
+ * This symbol, if defined, indicates that the ntohs() routine (and
+ * friends htonl() htons() ntohl()) are available to do network
+ * order byte swapping.
+ */
+#$d_htonl HAS_HTONL /**/
+#$d_htonl HAS_HTONS /**/
+#$d_htonl HAS_NTOHL /**/
+#$d_htonl HAS_NTOHS /**/
+
/* HAS_ISASCII:
* This manifest constant lets the C program know that isascii
* is available.
@@ -1599,6 +1962,72 @@
#$d_localtime_r HAS_LOCALTIME_R /**/
#define LOCALTIME_R_PROTO $localtime_r_proto /**/
+/* HAS_LONG_DOUBLE:
+ * This symbol will be defined if the C compiler supports long
+ * doubles.
+ */
+/* LONG_DOUBLESIZE:
+ * This symbol contains the size of a long double, so that the
+ * C preprocessor can make decisions based on it. It is only
+ * defined if the system supports long doubles.
+ */
+#$d_longdbl HAS_LONG_DOUBLE /**/
+#ifdef HAS_LONG_DOUBLE
+#define LONG_DOUBLESIZE $longdblsize /**/
+#endif
+
+/* HAS_LONG_LONG:
+ * This symbol will be defined if the C compiler supports long long.
+ */
+/* LONGLONGSIZE:
+ * This symbol contains the size of a long long, so that the
+ * C preprocessor can make decisions based on it. It is only
+ * defined if the system supports long long.
+ */
+#$d_longlong HAS_LONG_LONG /**/
+#ifdef HAS_LONG_LONG
+#define LONGLONGSIZE $longlongsize /**/
+#endif
+
+/* HAS_LSEEK_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the lseek() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern off_t lseek(int, off_t, int);
+ */
+#$d_lseekproto HAS_LSEEK_PROTO /**/
+
+/* HAS_MEMCHR:
+ * This symbol, if defined, indicates that the memchr routine is available
+ * to locate characters within a C string.
+ */
+#$d_memchr HAS_MEMCHR /**/
+
+/* HAS_MKSTEMP:
+ * This symbol, if defined, indicates that the mkstemp routine is
+ * available to exclusively create and open a uniquely named
+ * temporary file.
+ */
+#$d_mkstemp HAS_MKSTEMP /**/
+
+/* HAS_MMAP:
+ * This symbol, if defined, indicates that the mmap system call is
+ * available to map a file into memory.
+ */
+/* Mmap_t:
+ * This symbol holds the return type of the mmap() system call
+ * (and simultaneously the type of the first argument).
+ * Usually set to 'void *' or 'caddr_t'.
+ */
+#$d_mmap HAS_MMAP /**/
+#define Mmap_t $mmaptype /**/
+
+/* HAS_MSG:
+ * This symbol, if defined, indicates that the entire msg*(2) library is
+ * supported (IPC mechanism based on message queues).
+ */
+#$d_msg HAS_MSG /**/
+
/* HAS_OPEN3:
* This manifest constant lets the C program know that the three
* argument form of open(2) is available.
@@ -1702,6 +2131,18 @@
*/
#$d_sanemcmp HAS_SANE_MEMCMP /**/
+/* HAS_SEM:
+ * This symbol, if defined, indicates that the entire sem*(2) library is
+ * supported.
+ */
+#$d_sem HAS_SEM /**/
+
+/* HAS_SETGRENT:
+ * This symbol, if defined, indicates that the setgrent routine is
+ * available for initializing sequential access of the group database.
+ */
+#$d_setgrent HAS_SETGRENT /**/
+
/* HAS_SETGRENT_R:
* This symbol, if defined, indicates that the setgrent_r routine
* is available to setgrent re-entrantly.
@@ -1715,6 +2156,12 @@
#$d_setgrent_r HAS_SETGRENT_R /**/
#define SETGRENT_R_PROTO $setgrent_r_proto /**/
+/* HAS_SETHOSTENT:
+ * This symbol, if defined, indicates that the sethostent() routine is
+ * available.
+ */
+#$d_sethent HAS_SETHOSTENT /**/
+
/* HAS_SETHOSTENT_R:
* This symbol, if defined, indicates that the sethostent_r routine
* is available to sethostent re-entrantly.
@@ -1741,6 +2188,12 @@
#$d_setlocale_r HAS_SETLOCALE_R /**/
#define SETLOCALE_R_PROTO $setlocale_r_proto /**/
+/* HAS_SETNETENT:
+ * This symbol, if defined, indicates that the setnetent() routine is
+ * available.
+ */
+#$d_setnent HAS_SETNETENT /**/
+
/* HAS_SETNETENT_R:
* This symbol, if defined, indicates that the setnetent_r routine
* is available to setnetent re-entrantly.
@@ -1754,6 +2207,24 @@
#$d_setnetent_r HAS_SETNETENT_R /**/
#define SETNETENT_R_PROTO $setnetent_r_proto /**/
+/* HAS_SETPROTOENT:
+ * This symbol, if defined, indicates that the setprotoent() routine is
+ * available.
+ */
+#$d_setpent HAS_SETPROTOENT /**/
+
+/* HAS_SETPGRP:
+ * This symbol, if defined, indicates that the setpgrp routine is
+ * available to set the current process group.
+ */
+/* USE_BSD_SETPGRP:
+ * This symbol, if defined, indicates that setpgrp needs two
+ * arguments whereas USG one needs none. See also HAS_SETPGID
+ * for a POSIX interface.
+ */
+#$d_setpgrp HAS_SETPGRP /**/
+#$d_bsdsetpgrp USE_BSD_SETPGRP /**/
+
/* HAS_SETPROTOENT_R:
* This symbol, if defined, indicates that the setprotoent_r routine
* is available to setprotoent re-entrantly.
@@ -1767,6 +2238,12 @@
#$d_setprotoent_r HAS_SETPROTOENT_R /**/
#define SETPROTOENT_R_PROTO $setprotoent_r_proto /**/
+/* HAS_SETPWENT:
+ * This symbol, if defined, indicates that the setpwent routine is
+ * available for initializing sequential access of the passwd database.
+ */
+#$d_setpwent HAS_SETPWENT /**/
+
/* HAS_SETPWENT_R:
* This symbol, if defined, indicates that the setpwent_r routine
* is available to setpwent re-entrantly.
@@ -1780,6 +2257,12 @@
#$d_setpwent_r HAS_SETPWENT_R /**/
#define SETPWENT_R_PROTO $setpwent_r_proto /**/
+/* HAS_SETSERVENT:
+ * This symbol, if defined, indicates that the setservent() routine is
+ * available.
+ */
+#$d_setsent HAS_SETSERVENT /**/
+
/* HAS_SETSERVENT_R:
* This symbol, if defined, indicates that the setservent_r routine
* is available to setservent re-entrantly.
@@ -1793,6 +2276,33 @@
#$d_setservent_r HAS_SETSERVENT_R /**/
#define SETSERVENT_R_PROTO $setservent_r_proto /**/
+/* HAS_SETVBUF:
+ * This symbol, if defined, indicates that the setvbuf routine is
+ * available to change buffering on an open stdio stream.
+ * to a line-buffered mode.
+ */
+#$d_setvbuf HAS_SETVBUF /**/
+
+/* HAS_SHM:
+ * This symbol, if defined, indicates that the entire shm*(2) library is
+ * supported.
+ */
+#$d_shm HAS_SHM /**/
+
+/* Shmat_t:
+ * This symbol holds the return type of the shmat() system call.
+ * Usually set to 'void *' or 'char *'.
+ */
+/* HAS_SHMAT_PROTOTYPE:
+ * This symbol, if defined, indicates that the sys/shm.h includes
+ * a prototype for shmat(). Otherwise, it is up to the program to
+ * guess one. Shmat_t shmat(int, Shmat_t, int) is a good guess,
+ * but not always right so it should be emitted by the program only
+ * when HAS_SHMAT_PROTOTYPE is not defined to avoid conflicting defs.
+ */
+#define Shmat_t $shmattype /**/
+#$d_shmatprototype HAS_SHMAT_PROTOTYPE /**/
+
/* HAS_SIGACTION:
* This symbol, if defined, indicates that Vr4's sigaction() routine
* is available.
@@ -1830,6 +2340,89 @@
#define Siglongjmp(buf,retval) longjmp((buf),(retval))
#endif
+/* HAS_SOCKET:
+ * This symbol, if defined, indicates that the BSD socket interface is
+ * supported.
+ */
+/* HAS_SOCKETPAIR:
+ * This symbol, if defined, indicates that the BSD socketpair() call is
+ * supported.
+ */
+/* HAS_MSG_CTRUNC:
+ * This symbol, if defined, indicates that the MSG_CTRUNC is supported.
+ * Checking just with #ifdef might not be enough because this symbol
+ * has been known to be an enum.
+ */
+/* HAS_MSG_DONTROUTE:
+ * This symbol, if defined, indicates that the MSG_DONTROUTE is supported.
+ * Checking just with #ifdef might not be enough because this symbol
+ * has been known to be an enum.
+ */
+/* HAS_MSG_OOB:
+ * This symbol, if defined, indicates that the MSG_OOB is supported.
+ * Checking just with #ifdef might not be enough because this symbol
+ * has been known to be an enum.
+ */
+/* HAS_MSG_PEEK:
+ * This symbol, if defined, indicates that the MSG_PEEK is supported.
+ * Checking just with #ifdef might not be enough because this symbol
+ * has been known to be an enum.
+ */
+/* HAS_MSG_PROXY:
+ * This symbol, if defined, indicates that the MSG_PROXY is supported.
+ * Checking just with #ifdef might not be enough because this symbol
+ * has been known to be an enum.
+ */
+/* HAS_SCM_RIGHTS:
+ * This symbol, if defined, indicates that the SCM_RIGHTS is supported.
+ * Checking just with #ifdef might not be enough because this symbol
+ * has been known to be an enum.
+ */
+/* HAS_SOCKADDR_SA_LEN:
+ * This symbol, if defined, indicates that the struct sockaddr
+ * structure has a member called sa_len, indicating the length of
+ * the structure.
+ */
+/* HAS_SOCKADDR_IN6:
+ * This symbol, if defined, indicates the availability of
+ * struct sockaddr_in6;
+ */
+/* HAS_SIN6_SCOPE_ID:
+ * This symbol, if defined, indicates that the struct sockaddr_in6
+ * structure has a member called sin6_scope_id.
+ */
+/* HAS_IP_MREQ:
+ * This symbol, if defined, indicates the availability of
+ * struct ip_mreq;
+ */
+/* HAS_IP_MREQ_SOURCE:
+ * This symbol, if defined, indicates the availability of
+ * struct ip_mreq_source;
+ */
+/* HAS_IPV6_MREQ:
+ * This symbol, if defined, indicates the availability of
+ * struct ipv6_mreq;
+ */
+/* HAS_IPV6_MREQ_SOURCE:
+ * This symbol, if defined, indicates the availability of
+ * struct ipv6_mreq_source;
+ */
+#$d_socket HAS_SOCKET /**/
+#$d_sockpair HAS_SOCKETPAIR /**/
+#$d_sockaddr_sa_len HAS_SOCKADDR_SA_LEN /**/
+#$d_msg_ctrunc HAS_MSG_CTRUNC /**/
+#$d_msg_dontroute HAS_MSG_DONTROUTE /**/
+#$d_msg_oob HAS_MSG_OOB /**/
+#$d_msg_peek HAS_MSG_PEEK /**/
+#$d_msg_proxy HAS_MSG_PROXY /**/
+#$d_scm_rights HAS_SCM_RIGHTS /**/
+#$d_sockaddr_in6 HAS_SOCKADDR_IN6 /**/
+#$d_sin6_scope_id HAS_SIN6_SCOPE_ID /**/
+#$d_ip_mreq HAS_IP_MREQ /**/
+#$d_ip_mreq_source HAS_IP_MREQ_SOURCE /**/
+#$d_ipv6_mreq HAS_IPV6_MREQ /**/
+#$d_ipv6_mreq_source HAS_IPV6_MREQ_SOURCE /**/
+
/* HAS_SRAND48_R:
* This symbol, if defined, indicates that the srand48_r routine
* is available to srand48 re-entrantly.
@@ -1856,6 +2449,35 @@
#$d_srandom_r HAS_SRANDOM_R /**/
#define SRANDOM_R_PROTO $srandom_r_proto /**/
+/* USE_STAT_BLOCKS:
+ * This symbol is defined if this system has a stat structure declaring
+ * st_blksize and st_blocks.
+ */
+#ifndef USE_STAT_BLOCKS
+#$d_statblks USE_STAT_BLOCKS /**/
+#endif
+
+/* HAS_STATIC_INLINE:
+ * This symbol, if defined, indicates that the C compiler supports
+ * C99-style static inline. That is, the function can't be called
+ * from another translation unit.
+ */
+/* PERL_STATIC_INLINE:
+ * This symbol gives the best-guess incantation to use for static
+ * inline functions. If HAS_STATIC_INLINE is defined, this will
+ * give C99-style inline. If HAS_STATIC_INLINE is not defined,
+ * this will give a plain 'static'. It will always be defined
+ * to something that gives static linkage.
+ * Possibilities include
+ * static inline (c99)
+ * static __inline__ (gcc -ansi)
+ * static __inline (MSVC)
+ * static _inline (older MSVC)
+ * static (c89 compilers)
+ */
+#$d_static_inline HAS_STATIC_INLINE /**/
+#define PERL_STATIC_INLINE $perl_static_inline /**/
+
/* USE_STDIO_PTR:
* This symbol is defined if the _ptr and _cnt fields (or similar)
* of the stdio FILE structure can be used to access the stdio buffer
@@ -1926,6 +2548,32 @@
#define FILE_bufsiz(fp) $stdio_bufsiz
#endif
+/* USE_STRUCT_COPY:
+ * This symbol, if defined, indicates that this C compiler knows how
+ * to copy structures. If undefined, you'll need to use a block copy
+ * routine of some sort instead.
+ */
+#$d_strctcpy USE_STRUCT_COPY /**/
+
+/* HAS_STRERROR:
+ * This symbol, if defined, indicates that the strerror routine is
+ * available to translate error numbers to strings. See the writeup
+ * of Strerror() in this file before you try to define your own.
+ */
+/* HAS_SYS_ERRLIST:
+ * This symbol, if defined, indicates that the sys_errlist array is
+ * available to translate error numbers to strings. The extern int
+ * sys_nerr gives the size of that table.
+ */
+/* Strerror:
+ * This preprocessor symbol is defined as a macro if strerror() is
+ * not available to translate error numbers to strings but sys_errlist[]
+ * array is there.
+ */
+#$d_strerror HAS_STRERROR /**/
+#$d_syserrlst HAS_SYS_ERRLIST /**/
+#define Strerror(e) $d_strerrm
+
/* HAS_STRERROR_R:
* This symbol, if defined, indicates that the strerror_r routine
* is available to strerror re-entrantly.
@@ -1939,6 +2587,30 @@
#$d_strerror_r HAS_STRERROR_R /**/
#define STRERROR_R_PROTO $strerror_r_proto /**/
+/* HAS_STRTOUL:
+ * This symbol, if defined, indicates that the strtoul routine is
+ * available to provide conversion of strings to unsigned long.
+ */
+#$d_strtoul HAS_STRTOUL /**/
+
+/* HAS_TIME:
+ * This symbol, if defined, indicates that the time() routine exists.
+ */
+/* Time_t:
+ * This symbol holds the type returned by time(). It can be long,
+ * or time_t on BSD sites (in which case <sys/types.h> should be
+ * included).
+ */
+#$d_time HAS_TIME /**/
+#define Time_t $timetype /* Time type */
+
+/* HAS_TIMES:
+ * This symbol, if defined, indicates that the times() routine exists.
+ * Note that this became obsolete on some systems (SUNOS), which now
+ * use getrusage(). It may be necessary to include <sys/times.h>.
+ */
+#$d_times HAS_TIMES /**/
+
/* HAS_TMPNAM_R:
* This symbol, if defined, indicates that the tmpnam_r routine
* is available to tmpnam re-entrantly.
@@ -1965,886 +2637,6 @@
#$d_ttyname_r HAS_TTYNAME_R /**/
#define TTYNAME_R_PROTO $ttyname_r_proto /**/
-/* HAS_VPRINTF:
- * This symbol, if defined, indicates that the vprintf routine is available
- * to printf with a pointer to an argument list. If unavailable, you
- * may need to write your own, probably in terms of _doprnt().
- */
-/* USE_CHAR_VSPRINTF:
- * This symbol is defined if this system has vsprintf() returning type
- * (char*). The trend seems to be to declare it as "int vsprintf()". It
- * is up to the package author to declare vsprintf correctly based on the
- * symbol.
- */
-#$d_vprintf HAS_VPRINTF /**/
-#$d_charvspr USE_CHAR_VSPRINTF /**/
-
-/* DOUBLESIZE:
- * This symbol contains the size of a double, so that the C preprocessor
- * can make decisions based on it.
- */
-#define DOUBLESIZE $doublesize /**/
-
-/* I_MACH_CTHREADS:
- * This symbol, if defined, indicates to the C program that it should
- * include <mach/cthreads.h>.
- */
-#$i_machcthr I_MACH_CTHREADS /**/
-
-/* I_PTHREAD:
- * This symbol, if defined, indicates to the C program that it should
- * include <pthread.h>.
- */
-#$i_pthread I_PTHREAD /**/
-
-/* I_SYS_ACCESS:
- * This symbol, if defined, indicates to the C program that it should
- * include <sys/access.h>.
- */
-#$i_sysaccess I_SYS_ACCESS /**/
-
-/* I_SYS_SECURITY:
- * This symbol, if defined, indicates to the C program that it should
- * include <sys/security.h>.
- */
-#$i_syssecrt I_SYS_SECURITY /**/
-
-/* I_TIME:
- * This symbol, if defined, indicates to the C program that it should
- * include <time.h>.
- */
-/* I_SYS_TIME:
- * This symbol, if defined, indicates to the C program that it should
- * include <sys/time.h>.
- */
-/* I_SYS_TIME_KERNEL:
- * This symbol, if defined, indicates to the C program that it should
- * include <sys/time.h> with KERNEL defined.
- */
-/* HAS_TM_TM_ZONE:
- * This symbol, if defined, indicates to the C program that
- * the struct tm has a tm_zone field.
- */
-/* HAS_TM_TM_GMTOFF:
- * This symbol, if defined, indicates to the C program that
- * the struct tm has a tm_gmtoff field.
- */
-#$i_time I_TIME /**/
-#$i_systime I_SYS_TIME /**/
-#$i_systimek I_SYS_TIME_KERNEL /**/
-#$d_tm_tm_zone HAS_TM_TM_ZONE /**/
-#$d_tm_tm_gmtoff HAS_TM_TM_GMTOFF /**/
-
-/* PERL_INC_VERSION_LIST:
- * This variable specifies the list of subdirectories in over
- * which perl.c:incpush() and lib/lib.pm will automatically
- * search when adding directories to @INC, in a format suitable
- * for a C initialization string. See the inc_version_list entry
- * in Porting/Glossary for more details.
- */
-#$d_inc_version_list PERL_INC_VERSION_LIST $inc_version_list_init /**/
-
-/* INSTALL_USR_BIN_PERL:
- * This symbol, if defined, indicates that Perl is to be installed
- * also as /usr/bin/perl.
- */
-#$installusrbinperl INSTALL_USR_BIN_PERL /**/
-
-/* VAL_O_NONBLOCK:
- * This symbol is to be used during open() or fcntl(F_SETFL) to turn on
- * non-blocking I/O for the file descriptor. Note that there is no way
- * back, i.e. you cannot turn it blocking again this way. If you wish to
- * alternatively switch between blocking and non-blocking, use the
- * ioctl(FIOSNBIO) call instead, but that is not supported by all devices.
- */
-/* VAL_EAGAIN:
- * This symbol holds the errno error code set by read() when no data was
- * present on the non-blocking file descriptor.
- */
-/* RD_NODATA:
- * This symbol holds the return code from read() when no data is present
- * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is
- * not defined, then you can't distinguish between no data and EOF by
- * issuing a read(). You'll have to find another way to tell for sure!
- */
-/* EOF_NONBLOCK:
- * This symbol, if defined, indicates to the C program that a read() on
- * a non-blocking file descriptor will return 0 on EOF, and not the value
- * held in RD_NODATA (-1 usually, in that case!).
- */
-#define VAL_O_NONBLOCK $o_nonblock
-#define VAL_EAGAIN $eagain
-#define RD_NODATA $rd_nodata
-#$d_eofnblk EOF_NONBLOCK
-
-/* PERL_OTHERLIBDIRS:
- * This variable contains a colon-separated set of paths for the perl
- * binary to search for additional library files or modules.
- * These directories will be tacked to the end of @INC.
- * Perl will automatically search below each path for version-
- * and architecture-specific directories. See PERL_INC_VERSION_LIST
- * for more details.
- */
-#$d_perl_otherlibdirs PERL_OTHERLIBDIRS "$otherlibdirs" /**/
-
-/* PRIVLIB:
- * This symbol contains the name of the private library for this package.
- * The library is private in the sense that it needn't be in anyone's
- * execution path, but it should be accessible by the world. The program
- * should be prepared to do ~ expansion.
- */
-/* PRIVLIB_EXP:
- * 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 "$privlib" /**/
-#define PRIVLIB_EXP "$privlibexp" /**/
-
-/* PTRSIZE:
- * This symbol contains the size of a pointer, so that the C preprocessor
- * can make decisions based on it. It will be sizeof(void *) if
- * the compiler supports (void *); otherwise it will be
- * sizeof(char *).
- */
-#define PTRSIZE $ptrsize /**/
-
-/* Drand01:
- * This macro is to be used to generate uniformly distributed
- * random numbers over the range [0., 1.[. You may have to supply
- * an 'extern double drand48();' in your program since SunOS 4.1.3
- * doesn't provide you with anything relevant in its headers.
- * See HAS_DRAND48_PROTO.
- */
-/* Rand_seed_t:
- * This symbol defines the type of the argument of the
- * random seed function.
- */
-/* seedDrand01:
- * This symbol defines the macro to be used in seeding the
- * random number generator (see Drand01).
- */
-/* RANDBITS:
- * This symbol indicates how many bits are produced by the
- * function used to generate normalized random numbers.
- * Values include 15, 16, 31, and 48.
- */
-#define Drand01() $drand01 /**/
-#define Rand_seed_t $randseedtype /**/
-#define seedDrand01(x) $seedfunc((Rand_seed_t)x) /**/
-#define RANDBITS $randbits /**/
-
-/* SITEARCH:
- * This symbol contains the name of the private library for this package.
- * The library is private in the sense that it needn't be in anyone's
- * execution path, but it should be accessible by the world. The program
- * should be prepared to do ~ expansion.
- * The standard distribution will put nothing in this directory.
- * After perl has been installed, users may install their own local
- * architecture-dependent modules in this directory with
- * MakeMaker Makefile.PL
- * or equivalent. See INSTALL for details.
- */
-/* SITEARCH_EXP:
- * 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.
- */
-#$d_sitearch SITEARCH "$sitearch" /**/
-#$d_sitearch SITEARCH_EXP "$sitearchexp" /**/
-
-/* SITELIB:
- * This symbol contains the name of the private library for this package.
- * The library is private in the sense that it needn't be in anyone's
- * execution path, but it should be accessible by the world. The program
- * should be prepared to do ~ expansion.
- * The standard distribution will put nothing in this directory.
- * After perl has been installed, users may install their own local
- * architecture-independent modules in this directory with
- * MakeMaker Makefile.PL
- * or equivalent. See INSTALL for details.
- */
-/* SITELIB_EXP:
- * This symbol contains the ~name expanded version of SITELIB, to be used
- * in programs that are not prepared to deal with ~ expansion at run-time.
- */
-/* SITELIB_STEM:
- * This define is SITELIB_EXP with any trailing version-specific component
- * 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 "$sitelib" /**/
-#define SITELIB_EXP "$sitelibexp" /**/
-#define SITELIB_STEM "$sitelib_stem" /**/
-
-/* SSize_t:
- * This symbol holds the type used by functions that return
- * a count of bytes or an error condition. It must be a signed type.
- * It is usually ssize_t, but may be long or int, etc.
- * It may be necessary to include <sys/types.h> or <unistd.h>
- * to get any typedef'ed information.
- * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t).
- */
-#define SSize_t $ssizetype /* signed count of bytes */
-
-/* USE_ITHREADS:
- * This symbol, if defined, indicates that Perl should be built to
- * use the interpreter-based threading implementation.
- */
-/* USE_5005THREADS:
- * This symbol, if defined, indicates that Perl should be built to
- * use the 5.005-based threading implementation.
- * Only valid up to 5.8.x.
- */
-/* OLD_PTHREADS_API:
- * This symbol, if defined, indicates that Perl should
- * be built to use the old draft POSIX threads API.
- */
-/* USE_REENTRANT_API:
- * This symbol, if defined, indicates that Perl should
- * try to use the various _r versions of library functions.
- * This is extremely experimental.
- */
-#$use5005threads USE_5005THREADS /**/
-#$useithreads USE_ITHREADS /**/
-#if defined(USE_5005THREADS) && !defined(USE_ITHREADS)
-#define USE_THREADS /* until src is revised*/
-#endif
-#$d_oldpthreads OLD_PTHREADS_API /**/
-#$usereentrant USE_REENTRANT_API /**/
-
-/* PERL_VENDORARCH:
- * If defined, this symbol contains the name of a private library.
- * The library is private in the sense that it needn't be in anyone's
- * execution path, but it should be accessible by the world.
- * It may have a ~ on the front.
- * The standard distribution will put nothing in this directory.
- * Vendors who distribute perl may wish to place their own
- * architecture-dependent modules and extensions in this directory with
- * MakeMaker Makefile.PL INSTALLDIRS=vendor
- * or equivalent. See INSTALL for details.
- */
-/* PERL_VENDORARCH_EXP:
- * This symbol contains the ~name expanded version of PERL_VENDORARCH, to be used
- * in programs that are not prepared to deal with ~ expansion at run-time.
- */
-#$d_vendorarch PERL_VENDORARCH "$vendorarch" /**/
-#$d_vendorarch PERL_VENDORARCH_EXP "$vendorarchexp" /**/
-
-/* PERL_VENDORLIB_EXP:
- * This symbol contains the ~name expanded version of VENDORLIB, to be used
- * in programs that are not prepared to deal with ~ expansion at run-time.
- */
-/* PERL_VENDORLIB_STEM:
- * This define is PERL_VENDORLIB_EXP with any trailing version-specific component
- * 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.
- */
-#$d_vendorlib PERL_VENDORLIB_EXP "$vendorlibexp" /**/
-#$d_vendorlib PERL_VENDORLIB_STEM "$vendorlib_stem" /**/
-
-/* HAS_STATIC_INLINE:
- * This symbol, if defined, indicates that the C compiler supports
- * C99-style static inline. That is, the function can't be called
- * from another translation unit.
- */
-/* PERL_STATIC_INLINE:
- * This symbol gives the best-guess incantation to use for static
- * inline functions. If HAS_STATIC_INLINE is defined, this will
- * give C99-style inline. If HAS_STATIC_INLINE is not defined,
- * this will give a plain 'static'. It will always be defined
- * to something that gives static linkage.
- * Possibilities include
- * static inline (c99)
- * static __inline__ (gcc -ansi)
- * static __inline (MSVC)
- * static _inline (older MSVC)
- * static (c89 compilers)
- */
-#$d_static_inline HAS_STATIC_INLINE /**/
-#define PERL_STATIC_INLINE $perl_static_inline /**/
-
-/* EBCDIC:
- * This symbol, if defined, indicates that this system uses
- * EBCDIC encoding.
- */
-#$ebcdic EBCDIC /**/
-
-/* OSNAME:
- * This symbol contains the name of the operating system, as determined
- * by Configure. You shouldn't rely on it too much; the specific
- * feature tests from Configure are generally more reliable.
- */
-/* OSVERS:
- * This symbol contains the version of the operating system, as determined
- * by Configure. You shouldn't rely on it too much; the specific
- * feature tests from Configure are generally more reliable.
- */
-#define OSNAME "$osname" /**/
-#define OSVERS "$osvers" /**/
-
-/* CAT2:
- * This macro concatenates 2 tokens together.
- */
-/* STRINGIFY:
- * This macro surrounds its token with double quotes.
- */
-#if $cpp_stuff == 1
-#define CAT2(a,b) a/**/b
-#define STRINGIFY(a) "a"
-#endif
-#if $cpp_stuff == 42
-#define PeRl_CaTiFy(a, b) a ## b
-#define PeRl_StGiFy(a) #a
-#define CAT2(a,b) PeRl_CaTiFy(a,b)
-#define StGiFy(a) PeRl_StGiFy(a)
-#define STRINGIFY(a) PeRl_StGiFy(a)
-#endif
-#if $cpp_stuff != 1 && $cpp_stuff != 42
-#include "Bletch: How does this C preprocessor concatenate tokens?"
-#endif
-
-/* CPPSTDIN:
- * This symbol contains the first part of the string which will invoke
- * the C preprocessor on the standard input and produce to standard
- * output. Typical value of "cc -E" or "/lib/cpp", but it can also
- * call a wrapper. See CPPRUN.
- */
-/* CPPMINUS:
- * This symbol contains the second part of the string which will invoke
- * the C preprocessor on the standard input and produce to standard
- * output. This symbol will have the value "-" if CPPSTDIN needs a minus
- * to specify standard input, otherwise the value is "".
- */
-/* CPPRUN:
- * This symbol contains the string which will invoke a C preprocessor on
- * the standard input and produce to standard output. It needs to end
- * with CPPLAST, after all other preprocessor flags have been specified.
- * The main difference with CPPSTDIN is that this program will never be a
- * pointer to a shell wrapper, i.e. it will be empty if no preprocessor is
- * available directly to the user. Note that it may well be different from
- * the preprocessor used to compile the C program.
- */
-/* CPPLAST:
- * This symbol is intended to be used along with CPPRUN in the same manner
- * symbol CPPMINUS is used with CPPSTDIN. It contains either "-" or "".
- */
-#define CPPSTDIN "$cppstdin"
-#define CPPMINUS "$cppminus"
-#define CPPRUN "$cpprun"
-#define CPPLAST "$cpplast"
-
-/* HAS_ACCESS:
- * This manifest constant lets the C program know that the access()
- * system call is available to check for accessibility using real UID/GID.
- * (always present on UNIX.)
- */
-#$d_access HAS_ACCESS /**/
-
-/* HASATTRIBUTE_FORMAT:
- * Can we handle GCC attribute for checking printf-style formats
- */
-/* PRINTF_FORMAT_NULL_OK:
- * Allows __printf__ format to be null when checking printf-style
- */
-/* HASATTRIBUTE_MALLOC:
- * Can we handle GCC attribute for malloc-style functions.
- */
-/* HASATTRIBUTE_NONNULL:
- * Can we handle GCC attribute for nonnull function parms.
- */
-/* HASATTRIBUTE_NORETURN:
- * Can we handle GCC attribute for functions that do not return
- */
-/* HASATTRIBUTE_PURE:
- * Can we handle GCC attribute for pure functions
- */
-/* HASATTRIBUTE_UNUSED:
- * Can we handle GCC attribute for unused variables and arguments
- */
-/* HASATTRIBUTE_DEPRECATED:
- * Can we handle GCC attribute for marking deprecated APIs
- */
-/* HASATTRIBUTE_WARN_UNUSED_RESULT:
- * Can we handle GCC attribute for warning on unused results
- */
-#$d_attribute_deprecated HASATTRIBUTE_DEPRECATED /**/
-#$d_attribute_format HASATTRIBUTE_FORMAT /**/
-#$d_printf_format_null PRINTF_FORMAT_NULL_OK /**/
-#$d_attribute_noreturn HASATTRIBUTE_NORETURN /**/
-#$d_attribute_malloc HASATTRIBUTE_MALLOC /**/
-#$d_attribute_nonnull HASATTRIBUTE_NONNULL /**/
-#$d_attribute_pure HASATTRIBUTE_PURE /**/
-#$d_attribute_unused HASATTRIBUTE_UNUSED /**/
-#$d_attribute_warn_unused_result HASATTRIBUTE_WARN_UNUSED_RESULT /**/
-
-/* HASCONST:
- * This symbol, if defined, indicates that this C compiler knows about
- * the const type. There is no need to actually test for that symbol
- * within your programs. The mere use of the "const" keyword will
- * trigger the necessary tests.
- */
-#$d_const HASCONST /**/
-#ifndef HASCONST
-#define const
-#endif
-
-/* HAS_CSH:
- * This symbol, if defined, indicates that the C-shell exists.
- */
-/* CSH:
- * This symbol, if defined, contains the full pathname of csh.
- */
-#$d_csh HAS_CSH /**/
-#ifdef HAS_CSH
-#define CSH "$full_csh" /**/
-#endif
-
-/* SETUID_SCRIPTS_ARE_SECURE_NOW:
- * This symbol, if defined, indicates that the bug that prevents
- * setuid scripts from being secure is not present in this kernel.
- */
-/* DOSUID:
- * This symbol, if defined, indicates that the C program should
- * check the script that it is executing for setuid/setgid bits, and
- * attempt to emulate setuid/setgid on systems that have disabled
- * setuid #! scripts because the kernel can't do it securely.
- * It is up to the package designer to make sure that this emulation
- * is done securely. Among other things, it should do an fstat on
- * the script it just opened to make sure it really is a setuid/setgid
- * script, it should make sure the arguments passed correspond exactly
- * to the argument on the #! line, and it should not trust any
- * subprocesses to which it must pass the filename rather than the
- * file descriptor of the script to be executed.
- */
-#$d_suidsafe SETUID_SCRIPTS_ARE_SECURE_NOW /**/
-#$d_dosuid DOSUID /**/
-
-/* HAS_ENDGRENT:
- * This symbol, if defined, indicates that the getgrent routine is
- * available for finalizing sequential access of the group database.
- */
-#$d_endgrent HAS_ENDGRENT /**/
-
-/* HAS_ENDHOSTENT:
- * This symbol, if defined, indicates that the endhostent() routine is
- * available to close whatever was being used for host queries.
- */
-#$d_endhent HAS_ENDHOSTENT /**/
-
-/* HAS_ENDNETENT:
- * This symbol, if defined, indicates that the endnetent() routine is
- * available to close whatever was being used for network queries.
- */
-#$d_endnent HAS_ENDNETENT /**/
-
-/* HAS_ENDPROTOENT:
- * This symbol, if defined, indicates that the endprotoent() routine is
- * available to close whatever was being used for protocol queries.
- */
-#$d_endpent HAS_ENDPROTOENT /**/
-
-/* HAS_ENDPWENT:
- * This symbol, if defined, indicates that the getgrent routine is
- * available for finalizing sequential access of the passwd database.
- */
-#$d_endpwent HAS_ENDPWENT /**/
-
-/* HAS_ENDSERVENT:
- * This symbol, if defined, indicates that the endservent() routine is
- * available to close whatever was being used for service queries.
- */
-#$d_endsent HAS_ENDSERVENT /**/
-
-/* FLEXFILENAMES:
- * This symbol, if defined, indicates that the system supports filenames
- * longer than 14 characters.
- */
-#$d_flexfnam FLEXFILENAMES /**/
-
-/* HAS_GETGRENT:
- * This symbol, if defined, indicates that the getgrent routine is
- * available for sequential access of the group database.
- */
-#$d_getgrent HAS_GETGRENT /**/
-
-/* HAS_GETHOSTBYADDR:
- * This symbol, if defined, indicates that the gethostbyaddr() routine is
- * available to look up hosts by their IP addresses.
- */
-#$d_gethbyaddr HAS_GETHOSTBYADDR /**/
-
-/* HAS_GETHOSTBYNAME:
- * This symbol, if defined, indicates that the gethostbyname() routine is
- * available to look up host names in some data base or other.
- */
-#$d_gethbyname HAS_GETHOSTBYNAME /**/
-
-/* HAS_GETHOSTENT:
- * This symbol, if defined, indicates that the gethostent() routine is
- * available to look up host names in some data base or another.
- */
-#$d_gethent HAS_GETHOSTENT /**/
-
-/* HAS_GETHOSTNAME:
- * This symbol, if defined, indicates that the C program may use the
- * gethostname() routine to derive the host name. See also HAS_UNAME
- * and PHOSTNAME.
- */
-/* HAS_UNAME:
- * This symbol, if defined, indicates that the C program may use the
- * uname() routine to derive the host name. See also HAS_GETHOSTNAME
- * and PHOSTNAME.
- */
-/* PHOSTNAME:
- * This symbol, if defined, indicates the command to feed to the
- * popen() routine to derive the host name. See also HAS_GETHOSTNAME
- * and HAS_UNAME. Note that the command uses a fully qualified path,
- * so that it is safe even if used by a process with super-user
- * privileges.
- */
-/* HAS_PHOSTNAME:
- * This symbol, if defined, indicates that the C program may use the
- * contents of PHOSTNAME as a command to feed to the popen() routine
- * to derive the host name.
- */
-#$d_gethname HAS_GETHOSTNAME /**/
-#$d_uname HAS_UNAME /**/
-#$d_phostname HAS_PHOSTNAME /**/
-#ifdef HAS_PHOSTNAME
-#define PHOSTNAME "$aphostname" /* How to get the host name */
-#endif
-
-/* HAS_GETNETBYADDR:
- * This symbol, if defined, indicates that the getnetbyaddr() routine is
- * available to look up networks by their IP addresses.
- */
-#$d_getnbyaddr HAS_GETNETBYADDR /**/
-
-/* HAS_GETNETBYNAME:
- * This symbol, if defined, indicates that the getnetbyname() routine is
- * available to look up networks by their names.
- */
-#$d_getnbyname HAS_GETNETBYNAME /**/
-
-/* HAS_GETNETENT:
- * This symbol, if defined, indicates that the getnetent() routine is
- * available to look up network names in some data base or another.
- */
-#$d_getnent HAS_GETNETENT /**/
-
-/* HAS_GETPROTOENT:
- * This symbol, if defined, indicates that the getprotoent() routine is
- * available to look up protocols in some data base or another.
- */
-#$d_getpent HAS_GETPROTOENT /**/
-
-/* HAS_GETPGRP:
- * This symbol, if defined, indicates that the getpgrp routine is
- * available to get the current process group.
- */
-/* USE_BSD_GETPGRP:
- * This symbol, if defined, indicates that getpgrp needs one
- * arguments whereas USG one needs none.
- */
-#$d_getpgrp HAS_GETPGRP /**/
-#$d_bsdgetpgrp USE_BSD_GETPGRP /**/
-
-/* HAS_GETPROTOBYNAME:
- * This symbol, if defined, indicates that the getprotobyname()
- * routine is available to look up protocols by their name.
- */
-/* HAS_GETPROTOBYNUMBER:
- * This symbol, if defined, indicates that the getprotobynumber()
- * routine is available to look up protocols by their number.
- */
-#$d_getpbyname HAS_GETPROTOBYNAME /**/
-#$d_getpbynumber HAS_GETPROTOBYNUMBER /**/
-
-/* HAS_GETPWENT:
- * This symbol, if defined, indicates that the getpwent routine is
- * available for sequential access of the passwd database.
- * If this is not available, the older getpw() function may be available.
- */
-#$d_getpwent HAS_GETPWENT /**/
-
-/* HAS_GETSERVENT:
- * This symbol, if defined, indicates that the getservent() routine is
- * available to look up network services in some data base or another.
- */
-#$d_getsent HAS_GETSERVENT /**/
-
-/* HAS_GETSERVBYNAME:
- * This symbol, if defined, indicates that the getservbyname()
- * routine is available to look up services by their name.
- */
-/* HAS_GETSERVBYPORT:
- * This symbol, if defined, indicates that the getservbyport()
- * routine is available to look up services by their port.
- */
-#$d_getsbyname HAS_GETSERVBYNAME /**/
-#$d_getsbyport HAS_GETSERVBYPORT /**/
-
-/* HAS_HTONL:
- * This symbol, if defined, indicates that the htonl() routine (and
- * friends htons() ntohl() ntohs()) are available to do network
- * order byte swapping.
- */
-/* HAS_HTONS:
- * This symbol, if defined, indicates that the htons() routine (and
- * friends htonl() ntohl() ntohs()) are available to do network
- * order byte swapping.
- */
-/* HAS_NTOHL:
- * This symbol, if defined, indicates that the ntohl() routine (and
- * friends htonl() htons() ntohs()) are available to do network
- * order byte swapping.
- */
-/* HAS_NTOHS:
- * This symbol, if defined, indicates that the ntohs() routine (and
- * friends htonl() htons() ntohl()) are available to do network
- * order byte swapping.
- */
-#$d_htonl HAS_HTONL /**/
-#$d_htonl HAS_HTONS /**/
-#$d_htonl HAS_NTOHL /**/
-#$d_htonl HAS_NTOHS /**/
-
-/* HAS_LONG_DOUBLE:
- * This symbol will be defined if the C compiler supports long
- * doubles.
- */
-/* LONG_DOUBLESIZE:
- * This symbol contains the size of a long double, so that the
- * C preprocessor can make decisions based on it. It is only
- * defined if the system supports long doubles.
- */
-#$d_longdbl HAS_LONG_DOUBLE /**/
-#ifdef HAS_LONG_DOUBLE
-#define LONG_DOUBLESIZE $longdblsize /**/
-#endif
-
-/* HAS_LONG_LONG:
- * This symbol will be defined if the C compiler supports long long.
- */
-/* LONGLONGSIZE:
- * This symbol contains the size of a long long, so that the
- * C preprocessor can make decisions based on it. It is only
- * defined if the system supports long long.
- */
-#$d_longlong HAS_LONG_LONG /**/
-#ifdef HAS_LONG_LONG
-#define LONGLONGSIZE $longlongsize /**/
-#endif
-
-/* HAS_MEMCHR:
- * This symbol, if defined, indicates that the memchr routine is available
- * to locate characters within a C string.
- */
-#$d_memchr HAS_MEMCHR /**/
-
-/* HAS_MKSTEMP:
- * This symbol, if defined, indicates that the mkstemp routine is
- * available to exclusively create and open a uniquely named
- * temporary file.
- */
-#$d_mkstemp HAS_MKSTEMP /**/
-
-/* HAS_MMAP:
- * This symbol, if defined, indicates that the mmap system call is
- * available to map a file into memory.
- */
-/* Mmap_t:
- * This symbol holds the return type of the mmap() system call
- * (and simultaneously the type of the first argument).
- * Usually set to 'void *' or 'caddr_t'.
- */
-#$d_mmap HAS_MMAP /**/
-#define Mmap_t $mmaptype /**/
-
-/* HAS_MSG:
- * This symbol, if defined, indicates that the entire msg*(2) library is
- * supported (IPC mechanism based on message queues).
- */
-#$d_msg HAS_MSG /**/
-
-/* HAS_SEM:
- * This symbol, if defined, indicates that the entire sem*(2) library is
- * supported.
- */
-#$d_sem HAS_SEM /**/
-
-/* HAS_SETGRENT:
- * This symbol, if defined, indicates that the setgrent routine is
- * available for initializing sequential access of the group database.
- */
-#$d_setgrent HAS_SETGRENT /**/
-
-/* HAS_SETHOSTENT:
- * This symbol, if defined, indicates that the sethostent() routine is
- * available.
- */
-#$d_sethent HAS_SETHOSTENT /**/
-
-/* HAS_SETNETENT:
- * This symbol, if defined, indicates that the setnetent() routine is
- * available.
- */
-#$d_setnent HAS_SETNETENT /**/
-
-/* HAS_SETPROTOENT:
- * This symbol, if defined, indicates that the setprotoent() routine is
- * available.
- */
-#$d_setpent HAS_SETPROTOENT /**/
-
-/* HAS_SETPGRP:
- * This symbol, if defined, indicates that the setpgrp routine is
- * available to set the current process group.
- */
-/* USE_BSD_SETPGRP:
- * This symbol, if defined, indicates that setpgrp needs two
- * arguments whereas USG one needs none. See also HAS_SETPGID
- * for a POSIX interface.
- */
-#$d_setpgrp HAS_SETPGRP /**/
-#$d_bsdsetpgrp USE_BSD_SETPGRP /**/
-
-/* HAS_SETPWENT:
- * This symbol, if defined, indicates that the setpwent routine is
- * available for initializing sequential access of the passwd database.
- */
-#$d_setpwent HAS_SETPWENT /**/
-
-/* HAS_SETSERVENT:
- * This symbol, if defined, indicates that the setservent() routine is
- * available.
- */
-#$d_setsent HAS_SETSERVENT /**/
-
-/* HAS_SETVBUF:
- * This symbol, if defined, indicates that the setvbuf routine is
- * available to change buffering on an open stdio stream.
- * to a line-buffered mode.
- */
-#$d_setvbuf HAS_SETVBUF /**/
-
-/* HAS_SHM:
- * This symbol, if defined, indicates that the entire shm*(2) library is
- * supported.
- */
-#$d_shm HAS_SHM /**/
-
-/* Shmat_t:
- * This symbol holds the return type of the shmat() system call.
- * Usually set to 'void *' or 'char *'.
- */
-/* HAS_SHMAT_PROTOTYPE:
- * This symbol, if defined, indicates that the sys/shm.h includes
- * a prototype for shmat(). Otherwise, it is up to the program to
- * guess one. Shmat_t shmat(int, Shmat_t, int) is a good guess,
- * but not always right so it should be emitted by the program only
- * when HAS_SHMAT_PROTOTYPE is not defined to avoid conflicting defs.
- */
-#define Shmat_t $shmattype /**/
-#$d_shmatprototype HAS_SHMAT_PROTOTYPE /**/
-
-/* HAS_SOCKET:
- * This symbol, if defined, indicates that the BSD socket interface is
- * supported.
- */
-/* HAS_SOCKETPAIR:
- * This symbol, if defined, indicates that the BSD socketpair() call is
- * supported.
- */
-/* HAS_MSG_CTRUNC:
- * This symbol, if defined, indicates that the MSG_CTRUNC is supported.
- * Checking just with #ifdef might not be enough because this symbol
- * has been known to be an enum.
- */
-/* HAS_MSG_DONTROUTE:
- * This symbol, if defined, indicates that the MSG_DONTROUTE is supported.
- * Checking just with #ifdef might not be enough because this symbol
- * has been known to be an enum.
- */
-/* HAS_MSG_OOB:
- * This symbol, if defined, indicates that the MSG_OOB is supported.
- * Checking just with #ifdef might not be enough because this symbol
- * has been known to be an enum.
- */
-/* HAS_MSG_PEEK:
- * This symbol, if defined, indicates that the MSG_PEEK is supported.
- * Checking just with #ifdef might not be enough because this symbol
- * has been known to be an enum.
- */
-/* HAS_MSG_PROXY:
- * This symbol, if defined, indicates that the MSG_PROXY is supported.
- * Checking just with #ifdef might not be enough because this symbol
- * has been known to be an enum.
- */
-/* HAS_SCM_RIGHTS:
- * This symbol, if defined, indicates that the SCM_RIGHTS is supported.
- * Checking just with #ifdef might not be enough because this symbol
- * has been known to be an enum.
- */
-/* HAS_SOCKADDR_SA_LEN:
- * This symbol, if defined, indicates that the struct sockaddr
- * structure has a member called sa_len, indicating the length of
- * the structure.
- */
-/* HAS_SIN6_SCOPE_ID:
- * This symbol, if defined, indicates that the struct sockaddr_in6
- * structure has a member called sin6_scope_id.
- */
-#$d_socket HAS_SOCKET /**/
-#$d_sockpair HAS_SOCKETPAIR /**/
-#$d_sockaddr_sa_len HAS_SOCKADDR_SA_LEN /**/
-#$d_msg_ctrunc HAS_MSG_CTRUNC /**/
-#$d_msg_dontroute HAS_MSG_DONTROUTE /**/
-#$d_msg_oob HAS_MSG_OOB /**/
-#$d_msg_peek HAS_MSG_PEEK /**/
-#$d_msg_proxy HAS_MSG_PROXY /**/
-#$d_scm_rights HAS_SCM_RIGHTS /**/
-#$d_sin6_scope_id HAS_SIN6_SCOPE_ID /**/
-
-/* USE_STAT_BLOCKS:
- * This symbol is defined if this system has a stat structure declaring
- * st_blksize and st_blocks.
- */
-#ifndef USE_STAT_BLOCKS
-#$d_statblks USE_STAT_BLOCKS /**/
-#endif
-
-/* USE_STRUCT_COPY:
- * This symbol, if defined, indicates that this C compiler knows how
- * to copy structures. If undefined, you'll need to use a block copy
- * routine of some sort instead.
- */
-#$d_strctcpy USE_STRUCT_COPY /**/
-
-/* HAS_STRERROR:
- * This symbol, if defined, indicates that the strerror routine is
- * available to translate error numbers to strings. See the writeup
- * of Strerror() in this file before you try to define your own.
- */
-/* HAS_SYS_ERRLIST:
- * This symbol, if defined, indicates that the sys_errlist array is
- * available to translate error numbers to strings. The extern int
- * sys_nerr gives the size of that table.
- */
-/* Strerror:
- * This preprocessor symbol is defined as a macro if strerror() is
- * not available to translate error numbers to strings but sys_errlist[]
- * array is there.
- */
-#$d_strerror HAS_STRERROR /**/
-#$d_syserrlst HAS_SYS_ERRLIST /**/
-#define Strerror(e) $d_strerrm
-
-/* HAS_STRTOUL:
- * This symbol, if defined, indicates that the strtoul routine is
- * available to provide conversion of strings to unsigned long.
- */
-#$d_strtoul HAS_STRTOUL /**/
-
/* HAS_UNION_SEMUN:
* This symbol, if defined, indicates that the union semun is
* defined by including <sys/sem.h>. If not, the user code
@@ -2895,6 +2687,71 @@
#define volatile
#endif
+/* HAS_VPRINTF:
+ * This symbol, if defined, indicates that the vprintf routine is available
+ * to printf with a pointer to an argument list. If unavailable, you
+ * may need to write your own, probably in terms of _doprnt().
+ */
+/* USE_CHAR_VSPRINTF:
+ * This symbol is defined if this system has vsprintf() returning type
+ * (char*). The trend seems to be to declare it as "int vsprintf()". It
+ * is up to the package author to declare vsprintf correctly based on the
+ * symbol.
+ */
+#$d_vprintf HAS_VPRINTF /**/
+#$d_charvspr USE_CHAR_VSPRINTF /**/
+
+/* DOUBLESIZE:
+ * This symbol contains the size of a double, so that the C preprocessor
+ * can make decisions based on it.
+ */
+#define DOUBLESIZE $doublesize /**/
+
+/* EBCDIC:
+ * This symbol, if defined, indicates that this system uses
+ * EBCDIC encoding.
+ */
+/* BOOTSTRAP_CHARSET:
+ * This symbol, if defined, indicates that this system needs
+ * converting various files to the native character set before
+ * bringing up perl on a system that has a non-ASCII character
+ * set and no working perl.
+ */
+#$ebcdic EBCDIC /**/
+#$bootstrap_charset BOOTSTRAP_CHARSET /**/
+
+/* Fpos_t:
+ * This symbol holds the type used to declare file positions in libc.
+ * It can be fpos_t, long, uint, etc... It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+#define Fpos_t $fpostype /* File position type */
+
+/* Gid_t_f:
+ * This symbol defines the format string used for printing a Gid_t.
+ */
+#define Gid_t_f $gidformat /**/
+
+/* Gid_t_sign:
+ * This symbol holds the signedness of a Gid_t.
+ * 1 for unsigned, -1 for signed.
+ */
+#define Gid_t_sign $gidsign /* GID sign */
+
+/* Gid_t_size:
+ * This symbol holds the size of a Gid_t in bytes.
+ */
+#define Gid_t_size $gidsize /* GID size */
+
+/* Gid_t:
+ * This symbol holds the return type of getgid() and the type of
+ * argument to setrgid() and related functions. Typically,
+ * it is the type of group ids in the kernel. It can be int, ushort,
+ * gid_t, etc... It may be necessary to include <sys/types.h> to get
+ * any typedef'ed information.
+ */
+#define Gid_t $gidtype /* Type for getgid(), etc... */
+
/* I_DIRENT:
* This symbol, if defined, indicates to the C program that it should
* include <dirent.h>. Using this symbol also triggers the definition
@@ -2926,6 +2783,12 @@
#$i_grp I_GRP /**/
#$d_grpasswd GRPASSWD /**/
+/* I_MACH_CTHREADS:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <mach/cthreads.h>.
+ */
+#$i_machcthr I_MACH_CTHREADS /**/
+
/* I_NDBM:
* This symbol, if defined, indicates that <ndbm.h> exists and should
* be included.
@@ -2977,6 +2840,12 @@
*/
#$i_neterrno I_NET_ERRNO /**/
+/* I_PTHREAD:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <pthread.h>.
+ */
+#$i_pthread I_PTHREAD /**/
+
/* I_PWD:
* This symbol, if defined, indicates to the C program that it should
* include <pwd.h>.
@@ -3023,6 +2892,18 @@
#$d_pwgecos PWGECOS /**/
#$d_pwpasswd PWPASSWD /**/
+/* I_SYS_ACCESS:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/access.h>.
+ */
+#$i_sysaccess I_SYS_ACCESS /**/
+
+/* I_SYS_SECURITY:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/security.h>.
+ */
+#$i_syssecrt I_SYS_SECURITY /**/
+
/* I_SYSUIO:
* This symbol, if defined, indicates that <sys/uio.h> exists and
* should be included.
@@ -3029,6 +2910,32 @@
*/
#$i_sysuio I_SYSUIO /**/
+/* I_TIME:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <time.h>.
+ */
+/* I_SYS_TIME:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/time.h>.
+ */
+/* I_SYS_TIME_KERNEL:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/time.h> with KERNEL defined.
+ */
+/* HAS_TM_TM_ZONE:
+ * This symbol, if defined, indicates to the C program that
+ * the struct tm has a tm_zone field.
+ */
+/* HAS_TM_TM_GMTOFF:
+ * This symbol, if defined, indicates to the C program that
+ * the struct tm has a tm_gmtoff field.
+ */
+#$i_time I_TIME /**/
+#$i_systime I_SYS_TIME /**/
+#$i_systimek I_SYS_TIME_KERNEL /**/
+#$d_tm_tm_zone HAS_TM_TM_ZONE /**/
+#$d_tm_tm_gmtoff HAS_TM_TM_GMTOFF /**/
+
/* I_STDARG:
* This symbol, if defined, indicates that <stdarg.h> exists and should
* be included.
@@ -3040,6 +2947,36 @@
#$i_stdarg I_STDARG /**/
#$i_varargs I_VARARGS /**/
+/* PERL_INC_VERSION_LIST:
+ * This variable specifies the list of subdirectories in over
+ * which perl.c:incpush() and lib/lib.pm will automatically
+ * search when adding directories to @INC, in a format suitable
+ * for a C initialization string. See the inc_version_list entry
+ * in Porting/Glossary for more details.
+ */
+#$d_inc_version_list PERL_INC_VERSION_LIST $inc_version_list_init /**/
+
+/* INSTALL_USR_BIN_PERL:
+ * This symbol, if defined, indicates that Perl is to be installed
+ * also as /usr/bin/perl.
+ */
+#$installusrbinperl INSTALL_USR_BIN_PERL /**/
+
+/* Off_t:
+ * This symbol holds the type used to declare offsets in the kernel.
+ * It can be int, long, off_t, etc... It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+/* LSEEKSIZE:
+ * This symbol holds the number of bytes used by the Off_t.
+ */
+/* Off_t_size:
+ * This symbol holds the number of bytes used by the Off_t.
+ */
+#define Off_t $lseektype /* <offset> type */
+#define LSEEKSIZE $lseeksize /* <offset> size */
+#define Off_t_size $lseeksize /* <offset> size */
+
/* Free_t:
* This variable contains the return type of free(). It is usually
* void, but occasionally int.
@@ -3060,6 +2997,92 @@
*/
#$d_mymalloc MYMALLOC /**/
+/* Mode_t:
+ * This symbol holds the type used to declare file modes
+ * for systems calls. It is usually mode_t, but may be
+ * int or unsigned short. It may be necessary to include <sys/types.h>
+ * to get any typedef'ed information.
+ */
+#define Mode_t $modetype /* file mode parameter for system calls */
+
+/* VAL_O_NONBLOCK:
+ * This symbol is to be used during open() or fcntl(F_SETFL) to turn on
+ * non-blocking I/O for the file descriptor. Note that there is no way
+ * back, i.e. you cannot turn it blocking again this way. If you wish to
+ * alternatively switch between blocking and non-blocking, use the
+ * ioctl(FIOSNBIO) call instead, but that is not supported by all devices.
+ */
+/* VAL_EAGAIN:
+ * This symbol holds the errno error code set by read() when no data was
+ * present on the non-blocking file descriptor.
+ */
+/* RD_NODATA:
+ * This symbol holds the return code from read() when no data is present
+ * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is
+ * not defined, then you can't distinguish between no data and EOF by
+ * issuing a read(). You'll have to find another way to tell for sure!
+ */
+/* EOF_NONBLOCK:
+ * This symbol, if defined, indicates to the C program that a read() on
+ * a non-blocking file descriptor will return 0 on EOF, and not the value
+ * held in RD_NODATA (-1 usually, in that case!).
+ */
+#define VAL_O_NONBLOCK $o_nonblock
+#define VAL_EAGAIN $eagain
+#define RD_NODATA $rd_nodata
+#$d_eofnblk EOF_NONBLOCK
+
+/* Netdb_host_t:
+ * This symbol holds the type used for the 1st argument
+ * to gethostbyaddr().
+ */
+/* Netdb_hlen_t:
+ * This symbol holds the type used for the 2nd argument
+ * to gethostbyaddr().
+ */
+/* Netdb_name_t:
+ * This symbol holds the type used for the argument to
+ * gethostbyname().
+ */
+/* Netdb_net_t:
+ * This symbol holds the type used for the 1st argument to
+ * getnetbyaddr().
+ */
+#define Netdb_host_t $netdb_host_type /**/
+#define Netdb_hlen_t $netdb_hlen_type /**/
+#define Netdb_name_t $netdb_name_type /**/
+#define Netdb_net_t $netdb_net_type /**/
+
+/* PERL_OTHERLIBDIRS:
+ * This variable contains a colon-separated set of paths for the perl
+ * binary to search for additional library files or modules.
+ * These directories will be tacked to the end of @INC.
+ * Perl will automatically search below each path for version-
+ * and architecture-specific directories. See PERL_INC_VERSION_LIST
+ * for more details.
+ */
+#$d_perl_otherlibdirs PERL_OTHERLIBDIRS "$otherlibdirs" /**/
+
+/* Pid_t:
+ * This symbol holds the type used to declare process ids in the kernel.
+ * It can be int, uint, pid_t, etc... It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+#define Pid_t $pidtype /* PID type */
+
+/* PRIVLIB:
+ * This symbol contains the name of the private library for this package.
+ * The library is private in the sense that it needn't be in anyone's
+ * execution path, but it should be accessible by the world. The program
+ * should be prepared to do ~ expansion.
+ */
+/* PRIVLIB_EXP:
+ * 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 "$privlib" /**/
+#define PRIVLIB_EXP "$privlibexp" /**/
+
/* CAN_PROTOTYPE:
* If defined, this macro indicates that the C compiler can handle
* function prototypes.
@@ -3078,6 +3101,65 @@
#define _(args) ()
#endif
+/* PTRSIZE:
+ * This symbol contains the size of a pointer, so that the C preprocessor
+ * can make decisions based on it. It will be sizeof(void *) if
+ * the compiler supports (void *); otherwise it will be
+ * sizeof(char *).
+ */
+#define PTRSIZE $ptrsize /**/
+
+/* HAS_QUAD:
+ * This symbol, if defined, tells that there's a 64-bit integer type,
+ * Quad_t, and its unsigned counterpart, Uquad_t. QUADKIND will be one
+ * of QUAD_IS_INT, QUAD_IS_LONG, QUAD_IS_LONG_LONG, QUAD_IS_INT64_T,
+ * or QUAD_IS___INT64.
+ */
+#$d_quad HAS_QUAD /**/
+#ifdef HAS_QUAD
+# define Quad_t $quadtype /**/
+# define Uquad_t $uquadtype /**/
+# define QUADKIND $quadkind /**/
+# define QUAD_IS_INT 1
+# define QUAD_IS_LONG 2
+# define QUAD_IS_LONG_LONG 3
+# define QUAD_IS_INT64_T 4
+# define QUAD_IS___INT64 5
+#endif
+
+/* Drand01:
+ * This macro is to be used to generate uniformly distributed
+ * random numbers over the range [0., 1.[. You may have to supply
+ * an 'extern double drand48();' in your program since SunOS 4.1.3
+ * doesn't provide you with anything relevant in its headers.
+ * See HAS_DRAND48_PROTO.
+ */
+/* Rand_seed_t:
+ * This symbol defines the type of the argument of the
+ * random seed function.
+ */
+/* seedDrand01:
+ * This symbol defines the macro to be used in seeding the
+ * random number generator (see Drand01).
+ */
+/* RANDBITS:
+ * This symbol indicates how many bits are produced by the
+ * function used to generate normalized random numbers.
+ * Values include 15, 16, 31, and 48.
+ */
+#define Drand01() $drand01 /**/
+#define Rand_seed_t $randseedtype /**/
+#define seedDrand01(x) $seedfunc((Rand_seed_t)x) /**/
+#define RANDBITS $randbits /**/
+
+/* Select_fd_set_t:
+ * This symbol holds the type used for the 2nd, 3rd, and 4th
+ * arguments to select. Usually, this is 'fd_set *', if HAS_FD_SET
+ * is defined, and 'int *' otherwise. This is only useful if you
+ * have select(), of course.
+ */
+#define Select_fd_set_t $selecttype /**/
+
/* SH_PATH:
* This symbol contains the full pathname to the shell used on this
* on this system to execute Bourne shell scripts. Usually, this will be
@@ -3127,6 +3209,77 @@
#define SIG_NUM $sig_num_init /**/
#define SIG_SIZE $sig_size /**/
+/* SITEARCH:
+ * This symbol contains the name of the private library for this package.
+ * The library is private in the sense that it needn't be in anyone's
+ * execution path, but it should be accessible by the world. The program
+ * should be prepared to do ~ expansion.
+ * The standard distribution will put nothing in this directory.
+ * After perl has been installed, users may install their own local
+ * architecture-dependent modules in this directory with
+ * MakeMaker Makefile.PL
+ * or equivalent. See INSTALL for details.
+ */
+/* SITEARCH_EXP:
+ * 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.
+ */
+#$d_sitearch SITEARCH "$sitearch" /**/
+#$d_sitearch SITEARCH_EXP "$sitearchexp" /**/
+
+/* SITELIB:
+ * This symbol contains the name of the private library for this package.
+ * The library is private in the sense that it needn't be in anyone's
+ * execution path, but it should be accessible by the world. The program
+ * should be prepared to do ~ expansion.
+ * The standard distribution will put nothing in this directory.
+ * After perl has been installed, users may install their own local
+ * architecture-independent modules in this directory with
+ * MakeMaker Makefile.PL
+ * or equivalent. See INSTALL for details.
+ */
+/* SITELIB_EXP:
+ * This symbol contains the ~name expanded version of SITELIB, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+/* SITELIB_STEM:
+ * This define is SITELIB_EXP with any trailing version-specific component
+ * 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 "$sitelib" /**/
+#define SITELIB_EXP "$sitelibexp" /**/
+#define SITELIB_STEM "$sitelib_stem" /**/
+
+/* Size_t_size:
+ * This symbol holds the size of a Size_t in bytes.
+ */
+#define Size_t_size $sizesize /**/
+
+/* Size_t:
+ * This symbol holds the type used to declare length parameters
+ * for string functions. It is usually size_t, but may be
+ * unsigned long, int, etc. It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+#define Size_t $sizetype /* length parameter for string functions */
+
+/* Sock_size_t:
+ * This symbol holds the type used for the size argument of
+ * various socket calls (just the base type, not the pointer-to).
+ */
+#define Sock_size_t $socksizetype /**/
+
+/* SSize_t:
+ * This symbol holds the type used by functions that return
+ * a count of bytes or an error condition. It must be a signed type.
+ * It is usually ssize_t, but may be long or int, etc.
+ * It may be necessary to include <sys/types.h> or <unistd.h>
+ * to get any typedef'ed information.
+ * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t).
+ */
+#define SSize_t $ssizetype /* signed count of bytes */
+
/* STDCHAR:
* This symbol is defined to be the type of char used in stdio.h.
* It has the values "unsigned char" or "char".
@@ -3133,6 +3286,85 @@
*/
#define STDCHAR $stdchar /**/
+/* Uid_t_f:
+ * This symbol defines the format string used for printing a Uid_t.
+ */
+#define Uid_t_f $uidformat /**/
+
+/* Uid_t_sign:
+ * This symbol holds the signedness of a Uid_t.
+ * 1 for unsigned, -1 for signed.
+ */
+#define Uid_t_sign $uidsign /* UID sign */
+
+/* Uid_t_size:
+ * This symbol holds the size of a Uid_t in bytes.
+ */
+#define Uid_t_size $uidsize /* UID size */
+
+/* Uid_t:
+ * This symbol holds the type used to declare user ids in the kernel.
+ * It can be int, ushort, uid_t, etc... It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+#define Uid_t $uidtype /* UID type */
+
+/* USE_ITHREADS:
+ * This symbol, if defined, indicates that Perl should be built to
+ * use the interpreter-based threading implementation.
+ */
+/* USE_5005THREADS:
+ * This symbol, if defined, indicates that Perl should be built to
+ * use the 5.005-based threading implementation.
+ * Only valid up to 5.8.x.
+ */
+/* OLD_PTHREADS_API:
+ * This symbol, if defined, indicates that Perl should
+ * be built to use the old draft POSIX threads API.
+ */
+/* USE_REENTRANT_API:
+ * This symbol, if defined, indicates that Perl should
+ * try to use the various _r versions of library functions.
+ * This is extremely experimental.
+ */
+#$use5005threads USE_5005THREADS /**/
+#$useithreads USE_ITHREADS /**/
+#if defined(USE_5005THREADS) && !defined(USE_ITHREADS)
+#define USE_THREADS /* until src is revised*/
+#endif
+#$d_oldpthreads OLD_PTHREADS_API /**/
+#$usereentrant USE_REENTRANT_API /**/
+
+/* PERL_VENDORARCH:
+ * If defined, this symbol contains the name of a private library.
+ * The library is private in the sense that it needn't be in anyone's
+ * execution path, but it should be accessible by the world.
+ * It may have a ~ on the front.
+ * The standard distribution will put nothing in this directory.
+ * Vendors who distribute perl may wish to place their own
+ * architecture-dependent modules and extensions in this directory with
+ * MakeMaker Makefile.PL INSTALLDIRS=vendor
+ * or equivalent. See INSTALL for details.
+ */
+/* PERL_VENDORARCH_EXP:
+ * This symbol contains the ~name expanded version of PERL_VENDORARCH, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+#$d_vendorarch PERL_VENDORARCH "$vendorarch" /**/
+#$d_vendorarch PERL_VENDORARCH_EXP "$vendorarchexp" /**/
+
+/* PERL_VENDORLIB_EXP:
+ * This symbol contains the ~name expanded version of VENDORLIB, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+/* PERL_VENDORLIB_STEM:
+ * This define is PERL_VENDORLIB_EXP with any trailing version-specific component
+ * 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.
+ */
+#$d_vendorlib PERL_VENDORLIB_EXP "$vendorlibexp" /**/
+#$d_vendorlib PERL_VENDORLIB_STEM "$vendorlib_stem" /**/
+
/* VOIDFLAGS:
* This symbol indicates how much support of the void type is given by this
* compiler. What various bits mean:
@@ -3522,6 +3754,12 @@
*/
#$d_int64_t HAS_INT64_T /**/
+/* HAS_ISBLANK:
+ * This manifest constant lets the C program know that isblank
+ * is available.
+ */
+#$d_isblank HAS_ISBLANK /**/
+
/* HAS_ISFINITE:
* This symbol, if defined, indicates that the isfinite routine is
* available to check whether a double is finite (non-infinity non-NaN).
@@ -4118,6 +4356,12 @@
*/
#$i_socks I_SOCKS /**/
+/* I_STDBOOL:
+ * This symbol, if defined, indicates that <stdbool.h> exists and
+ * can be included.
+ */
+#$i_stdbool I_STDBOOL /**/
+
/* I_SUNMATH:
* This symbol, if defined, indicates that <sunmath.h> exists and
* should be included.
@@ -4387,6 +4631,16 @@
*/
#define SELECT_MIN_BITS $selectminbits /**/
+/* ST_INO_SIZE:
+ * This variable contains the size of struct stat's st_ino in bytes.
+ */
+/* ST_INO_SIGN:
+ * This symbol holds the signedness of struct stat's st_ino.
+ * 1 for unsigned, -1 for signed.
+ */
+#define ST_INO_SIGN $st_ino_sign /* st_ino sign */
+#define ST_INO_SIZE $st_ino_size /* st_ino size */
+
/* STARTPERL:
* This variable contains the string to put in front of a perl
* script to make sure (one hopes) that it runs with perl and not
@@ -4468,6 +4722,13 @@
#$usefaststdio USE_FAST_STDIO /**/
#endif
+/* USE_KERN_PROC_PATHNAME:
+ * This symbol, if defined, indicates that we can use sysctl with
+ * KERN_PROC_PATHNAME to get a full path for the executable, and hence
+ * convert $^X to an absolute path.
+ */
+#$usekernprocpathname USE_KERN_PROC_PATHNAME /**/
+
/* USE_LARGE_FILES:
* This symbol, if defined, indicates that large file support
* should be used when available.
@@ -4500,6 +4761,13 @@
#$usemultiplicity MULTIPLICITY /**/
#endif
+/* USE_NSGETEXECUTABLEPATH:
+ * This symbol, if defined, indicates that we can use _NSGetExecutablePath
+ * and realpath to get a full path for the executable, and hence convert
+ * $^X to an absolute path.
+ */
+#$usensgetexecutablepath USE_NSGETEXECUTABLEPATH /**/
+
/* USE_PERLIO:
* This symbol, if defined, indicates that the PerlIO abstraction should
* be used throughout. If not defined, stdio should be
@@ -4517,205 +4785,6 @@
#$usesocks USE_SOCKS /**/
#endif
-/* HAS_DRAND48_PROTO:
- * This symbol, if defined, indicates that the system provides
- * a prototype for the drand48() function. Otherwise, it is up
- * to the program to supply one. A good guess is
- * extern double drand48(void);
- */
-#$d_drand48proto HAS_DRAND48_PROTO /**/
-
-/* HAS_GETHOST_PROTOS:
- * This symbol, if defined, indicates that <netdb.h> includes
- * prototypes for gethostent(), gethostbyname(), and
- * gethostbyaddr(). Otherwise, it is up to the program to guess
- * them. See netdbtype.U for probing for various Netdb_xxx_t types.
- */
-#$d_gethostprotos HAS_GETHOST_PROTOS /**/
-
-/* HAS_GETNET_PROTOS:
- * This symbol, if defined, indicates that <netdb.h> includes
- * prototypes for getnetent(), getnetbyname(), and
- * getnetbyaddr(). Otherwise, it is up to the program to guess
- * them. See netdbtype.U for probing for various Netdb_xxx_t types.
- */
-#$d_getnetprotos HAS_GETNET_PROTOS /**/
-
-/* HAS_GETPROTO_PROTOS:
- * This symbol, if defined, indicates that <netdb.h> includes
- * prototypes for getprotoent(), getprotobyname(), and
- * getprotobyaddr(). Otherwise, it is up to the program to guess
- * them. See netdbtype.U for probing for various Netdb_xxx_t types.
- */
-#$d_getprotoprotos HAS_GETPROTO_PROTOS /**/
-
-/* HAS_GETSERV_PROTOS:
- * This symbol, if defined, indicates that <netdb.h> includes
- * prototypes for getservent(), getservbyname(), and
- * getservbyaddr(). Otherwise, it is up to the program to guess
- * them. See netdbtype.U for probing for various Netdb_xxx_t types.
- */
-#$d_getservprotos HAS_GETSERV_PROTOS /**/
-
-/* HAS_LSEEK_PROTO:
- * This symbol, if defined, indicates that the system provides
- * a prototype for the lseek() function. Otherwise, it is up
- * to the program to supply one. A good guess is
- * extern off_t lseek(int, off_t, int);
- */
-#$d_lseekproto HAS_LSEEK_PROTO /**/
-
-/* Netdb_host_t:
- * This symbol holds the type used for the 1st argument
- * to gethostbyaddr().
- */
-/* Netdb_hlen_t:
- * This symbol holds the type used for the 2nd argument
- * to gethostbyaddr().
- */
-/* Netdb_name_t:
- * This symbol holds the type used for the argument to
- * gethostbyname().
- */
-/* Netdb_net_t:
- * This symbol holds the type used for the 1st argument to
- * getnetbyaddr().
- */
-#define Netdb_host_t $netdb_host_type /**/
-#define Netdb_hlen_t $netdb_hlen_type /**/
-#define Netdb_name_t $netdb_name_type /**/
-#define Netdb_net_t $netdb_net_type /**/
-
-/* Select_fd_set_t:
- * This symbol holds the type used for the 2nd, 3rd, and 4th
- * arguments to select. Usually, this is 'fd_set *', if HAS_FD_SET
- * is defined, and 'int *' otherwise. This is only useful if you
- * have select(), of course.
- */
-#define Select_fd_set_t $selecttype /**/
-
-/* Sock_size_t:
- * This symbol holds the type used for the size argument of
- * various socket calls (just the base type, not the pointer-to).
- */
-#define Sock_size_t $socksizetype /**/
-
-/* HAS_TIME:
- * This symbol, if defined, indicates that the time() routine exists.
- */
-/* Time_t:
- * This symbol holds the type returned by time(). It can be long,
- * or time_t on BSD sites (in which case <sys/types.h> should be
- * included).
- */
-#$d_time HAS_TIME /**/
-#define Time_t $timetype /* Time type */
-
-/* HAS_TIMES:
- * This symbol, if defined, indicates that the times() routine exists.
- * Note that this became obsolete on some systems (SUNOS), which now
- * use getrusage(). It may be necessary to include <sys/times.h>.
- */
-#$d_times HAS_TIMES /**/
-
-/* Fpos_t:
- * This symbol holds the type used to declare file positions in libc.
- * It can be fpos_t, long, uint, etc... It may be necessary to include
- * <sys/types.h> to get any typedef'ed information.
- */
-#define Fpos_t $fpostype /* File position type */
-
-/* Gid_t_f:
- * This symbol defines the format string used for printing a Gid_t.
- */
-#define Gid_t_f $gidformat /**/
-
-/* Gid_t_sign:
- * This symbol holds the signedess of a Gid_t.
- * 1 for unsigned, -1 for signed.
- */
-#define Gid_t_sign $gidsign /* GID sign */
-
-/* Gid_t_size:
- * This symbol holds the size of a Gid_t in bytes.
- */
-#define Gid_t_size $gidsize /* GID size */
-
-/* Gid_t:
- * This symbol holds the return type of getgid() and the type of
- * argument to setrgid() and related functions. Typically,
- * it is the type of group ids in the kernel. It can be int, ushort,
- * gid_t, etc... It may be necessary to include <sys/types.h> to get
- * any typedef'ed information.
- */
-#define Gid_t $gidtype /* Type for getgid(), etc... */
-
-/* Off_t:
- * This symbol holds the type used to declare offsets in the kernel.
- * It can be int, long, off_t, etc... It may be necessary to include
- * <sys/types.h> to get any typedef'ed information.
- */
-/* LSEEKSIZE:
- * This symbol holds the number of bytes used by the Off_t.
- */
-/* Off_t_size:
- * This symbol holds the number of bytes used by the Off_t.
- */
-#define Off_t $lseektype /* <offset> type */
-#define LSEEKSIZE $lseeksize /* <offset> size */
-#define Off_t_size $lseeksize /* <offset> size */
-
-/* Mode_t:
- * This symbol holds the type used to declare file modes
- * for systems calls. It is usually mode_t, but may be
- * int or unsigned short. It may be necessary to include <sys/types.h>
- * to get any typedef'ed information.
- */
-#define Mode_t $modetype /* file mode parameter for system calls */
-
-/* Pid_t:
- * This symbol holds the type used to declare process ids in the kernel.
- * It can be int, uint, pid_t, etc... It may be necessary to include
- * <sys/types.h> to get any typedef'ed information.
- */
-#define Pid_t $pidtype /* PID type */
-
-/* Size_t_size:
- * This symbol holds the size of a Size_t in bytes.
- */
-#define Size_t_size $sizesize /* */
-
-/* Size_t:
- * This symbol holds the type used to declare length parameters
- * for string functions. It is usually size_t, but may be
- * unsigned long, int, etc. It may be necessary to include
- * <sys/types.h> to get any typedef'ed information.
- */
-#define Size_t $sizetype /* length parameter for string functions */
-
-/* Uid_t_f:
- * This symbol defines the format string used for printing a Uid_t.
- */
-#define Uid_t_f $uidformat /**/
-
-/* Uid_t_sign:
- * This symbol holds the signedess of a Uid_t.
- * 1 for unsigned, -1 for signed.
- */
-#define Uid_t_sign $uidsign /* UID sign */
-
-/* Uid_t_size:
- * This symbol holds the size of a Uid_t in bytes.
- */
-#define Uid_t_size $uidsize /* UID size */
-
-/* Uid_t:
- * This symbol holds the type used to declare user ids in the kernel.
- * It can be int, ushort, uid_t, etc... It may be necessary to include
- * <sys/types.h> to get any typedef'ed information.
- */
-#define Uid_t $uidtype /* UID type */
-
#endif
!GROK!THIS!
;;
Property changes on: trunk/contrib/perl/config_h.SH
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/cop.h
===================================================================
--- trunk/contrib/perl/cop.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/cop.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -138,7 +138,7 @@
PerlProc_longjmp(PL_top_env->je_buf, (v)); \
if ((v) == 2) \
PerlProc_exit(STATUS_EXIT); \
- PerlIO_printf(PerlIO_stderr(), "panic: top_env\n"); \
+ PerlIO_printf(PerlIO_stderr(), "panic: top_env, v=%d\n", (int)v); \
PerlProc_exit(1); \
} STMT_END
@@ -387,7 +387,8 @@
line_t cop_line; /* line # of this command */
/* label for this construct is now stored in cop_hints_hash */
#ifdef USE_ITHREADS
- char * cop_stashpv; /* package line was compiled in */
+ PADOFFSET cop_stashoff; /* offset into PL_stashpad, for the
+ package the line was compiled in */
char * cop_file; /* file name the following line # is from */
#else
HV * cop_stash; /* package line was compiled in */
@@ -419,29 +420,16 @@
? GvSV(gv_fetchfile(CopFILE(c))) : NULL)
# define CopFILEAV(c) (CopFILE(c) \
? GvAV(gv_fetchfile(CopFILE(c))) : NULL)
-# ifdef DEBUGGING
-# define CopFILEAVx(c) (assert(CopFILE(c)), \
+# define CopFILEAVx(c) (assert_(CopFILE(c)) \
GvAV(gv_fetchfile(CopFILE(c))))
-# else
-# define CopFILEAVx(c) (GvAV(gv_fetchfile(CopFILE(c))))
-# endif
-# define CopSTASHPV(c) ((c)->cop_stashpv)
+# define CopSTASH(c) PL_stashpad[(c)->cop_stashoff]
+# define CopSTASH_set(c,hv) ((c)->cop_stashoff = (hv) \
+ ? alloccopstash(hv) \
+ : 0)
# ifdef NETWARE
-# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : NULL))
-# else
-# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = savesharedpv(pv))
-# endif
-
-# define CopSTASH(c) (CopSTASHPV(c) \
- ? gv_stashpv(CopSTASHPV(c),GV_ADD) : NULL)
-# define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME_get(hv) : NULL)
-# define CopSTASH_eq(c,hv) ((hv) && stashpv_hvname_match(c,hv))
-# ifdef NETWARE
-# define CopSTASH_free(c) SAVECOPSTASH_FREE(c)
# define CopFILE_free(c) SAVECOPFILE_FREE(c)
# else
-# define CopSTASH_free(c) PerlMemShared_free(CopSTASHPV(c))
# define CopFILE_free(c) (PerlMemShared_free(CopFILE(c)),(CopFILE(c) = NULL))
# endif
#else
@@ -460,15 +448,15 @@
? SvPVX(GvSV(CopFILEGV(c))) : NULL)
# define CopSTASH(c) ((c)->cop_stash)
# define CopSTASH_set(c,hv) ((c)->cop_stash = (hv))
-# define CopSTASHPV(c) (CopSTASH(c) ? HvNAME_get(CopSTASH(c)) : NULL)
- /* cop_stash is not refcounted */
-# define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD))
-# define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv))
-# define CopSTASH_free(c)
# define CopFILE_free(c) (SvREFCNT_dec(CopFILEGV(c)),(CopFILEGV(c) = NULL))
#endif /* USE_ITHREADS */
+#define CopSTASHPV(c) (CopSTASH(c) ? HvNAME_get(CopSTASH(c)) : NULL)
+ /* cop_stash is not refcounted */
+#define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD))
+#define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv))
+
#define CopHINTHASH_get(c) ((COPHH*)((c)->cop_hints_hash))
#define CopHINTHASH_set(c,h) ((c)->cop_hints_hash = (h))
@@ -542,7 +530,9 @@
#define cop_hints_2hv(cop, flags) \
cophh_2hv(CopHINTHASH_get(cop), flags)
-#define CopLABEL(c) Perl_fetch_cop_label(aTHX_ (c), NULL, NULL)
+#define CopLABEL(c) Perl_cop_fetch_label(aTHX_ (c), NULL, NULL)
+#define CopLABEL_len(c,len) Perl_cop_fetch_label(aTHX_ (c), len, NULL)
+#define CopLABEL_len_flags(c,len,flags) Perl_cop_fetch_label(aTHX_ (c), len, flags)
#define CopLABEL_alloc(pv) ((pv)?savepv(pv):NULL)
#define CopSTASH_ne(c,hv) (!CopSTASH_eq(c,hv))
@@ -554,31 +544,6 @@
/* OutCopFILE() is CopFILE for output (caller, die, warn, etc.) */
#define OutCopFILE(c) CopFILE(c)
-/* If $[ is non-zero, it's stored in cop_hints under the key "$[", and
- HINT_ARYBASE is set to indicate this.
- Setting it is inefficient due to the need to create 2 mortal SVs, but as
- using $[ is highly discouraged, no sane Perl code will be using it. */
-#define CopARYBASE_get(c) \
- ((CopHINTS_get(c) & HINT_ARYBASE) \
- ? SvIV(cop_hints_fetch_pvs((c), "$[", 0)) \
- : 0)
-#define CopARYBASE_set(c, b) STMT_START { \
- if (b || ((c)->cop_hints & HINT_ARYBASE)) { \
- (c)->cop_hints |= HINT_ARYBASE; \
- if ((c) == &PL_compiling) { \
- SV *val = newSViv(b); \
- (void)hv_stores(GvHV(PL_hintgv), "$[", val); \
- mg_set(val); \
- PL_hints |= HINT_ARYBASE; \
- } else { \
- CopHINTHASH_set((c), \
- cophh_store_pvs(CopHINTHASH_get((c)), "$[", \
- sv_2mortal(newSViv(b)), 0)); \
- } \
- } \
- } STMT_END
-
-/* FIXME NATIVE_HINTS if this is changed from op_private (see perl.h) */
#define CopHINTS_get(c) ((c)->cop_hints + 0)
#define CopHINTS_set(c, h) STMT_START { \
(c)->cop_hints = (h); \
@@ -616,7 +581,9 @@
* decremented by LEAVESUB, the other by LEAVE. */
#define PUSHSUB_BASE(cx) \
- ENTRY_PROBE(GvENAME(CvGV(cv)), \
+ ENTRY_PROBE(CvNAMED(cv) \
+ ? HEK_KEY(CvNAME_HEK(cv)) \
+ : GvENAME(CvGV(cv)), \
CopFILE((const COP *)CvSTART(cv)), \
CopLINE((const COP *)CvSTART(cv)), \
CopSTASHPV((const COP *)CvSTART(cv))); \
@@ -631,11 +598,23 @@
SAVEFREESV(cv); \
}
+#define PUSHSUB_GET_LVALUE_MASK(func) \
+ /* If the context is indeterminate, then only the lvalue */ \
+ /* flags that the caller also has are applicable. */ \
+ ( \
+ (PL_op->op_flags & OPf_WANT) \
+ ? OPpENTERSUB_LVAL_MASK \
+ : !(PL_op->op_private & OPpENTERSUB_LVAL_MASK) \
+ ? 0 : (U8)func(aTHX) \
+ )
#define PUSHSUB(cx) \
+ { \
+ U8 phlags = PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub); \
PUSHSUB_BASE(cx) \
cx->blk_u16 = PL_op->op_private & \
- (OPpLVAL_INTRO|OPpENTERSUB_INARGS);
+ (phlags|OPpDEREF); \
+ }
/* variant for use by OP_DBSTATE, where op_private holds hint bits */
#define PUSHSUB_DB(cx) \
@@ -648,6 +627,8 @@
cx->blk_format.gv = gv; \
cx->blk_format.retop = (retop); \
cx->blk_format.dfoutgv = PL_defoutgv; \
+ if (!CvDEPTH(cv)) SvREFCNT_inc_simple_void_NN(cv); \
+ CvDEPTH(cv)++; \
SvREFCNT_inc_void(cx->blk_format.dfoutgv)
#define POP_SAVEARRAY() \
@@ -667,7 +648,9 @@
#define POPSUB(cx,sv) \
STMT_START { \
- RETURN_PROBE(GvENAME(CvGV((const CV*)cx->blk_sub.cv)), \
+ RETURN_PROBE(CvNAMED(cx->blk_sub.cv) \
+ ? HEK_KEY(CvNAME_HEK(cx->blk_sub.cv)) \
+ : GvENAME(CvGV(cx->blk_sub.cv)), \
CopFILE((COP*)CvSTART((const CV*)cx->blk_sub.cv)), \
CopLINE((COP*)CvSTART((const CV*)cx->blk_sub.cv)), \
CopSTASHPV((COP*)CvSTART((const CV*)cx->blk_sub.cv))); \
@@ -677,7 +660,7 @@
/* abandon @_ if it got reified */ \
if (AvREAL(cx->blk_sub.argarray)) { \
const SSize_t fill = AvFILLp(cx->blk_sub.argarray); \
- SvREFCNT_dec(cx->blk_sub.argarray); \
+ SvREFCNT_dec_NN(cx->blk_sub.argarray); \
cx->blk_sub.argarray = newAV(); \
av_extend(cx->blk_sub.argarray, fill); \
AvREIFY_only(cx->blk_sub.argarray); \
@@ -694,13 +677,15 @@
#define LEAVESUB(sv) \
STMT_START { \
- if (sv) \
- SvREFCNT_dec(sv); \
+ SvREFCNT_dec(sv); \
} STMT_END
#define POPFORMAT(cx) \
setdefout(cx->blk_format.dfoutgv); \
- SvREFCNT_dec(cx->blk_format.dfoutgv);
+ CvDEPTH(cx->blk_format.cv)--; \
+ if (!CvDEPTH(cx->blk_format.cv)) \
+ SvREFCNT_dec_NN(cx->blk_format.cv); \
+ SvREFCNT_dec_NN(cx->blk_format.dfoutgv);
/* eval context */
struct block_eval {
@@ -738,6 +723,8 @@
PL_in_eval = CxOLD_IN_EVAL(cx); \
optype = CxOLD_OP_TYPE(cx); \
PL_eval_root = cx->blk_eval.old_eval_root; \
+ if (cx->blk_eval.cur_text && SvSCREAM(cx->blk_eval.cur_text)) \
+ SvREFCNT_dec_NN(cx->blk_eval.cur_text); \
if (cx->blk_eval.old_namesv) \
sv_2mortal(cx->blk_eval.old_namesv); \
} STMT_END
@@ -782,6 +769,8 @@
: (SV**)NULL)
#define CxLABEL(c) (0 + CopLABEL((c)->blk_oldcop))
+#define CxLABEL_len(c,len) (0 + CopLABEL_len((c)->blk_oldcop, len))
+#define CxLABEL_len_flags(c,len,flags) (0 + CopLABEL_len_flags((c)->blk_oldcop, len, flags))
#define CxHASARGS(c) (((c)->cx_type & CXp_HASARGS) == CXp_HASARGS)
#define CxLVAL(c) (0 + (c)->blk_u16)
@@ -801,8 +790,8 @@
#define POPLOOP(cx) \
if (CxTYPE(cx) == CXt_LOOP_LAZYSV) { \
- SvREFCNT_dec(cx->blk_loop.state_u.lazysv.cur); \
- SvREFCNT_dec(cx->blk_loop.state_u.lazysv.end); \
+ SvREFCNT_dec_NN(cx->blk_loop.state_u.lazysv.cur); \
+ SvREFCNT_dec_NN(cx->blk_loop.state_u.lazysv.end); \
} \
if (CxTYPE(cx) == CXt_LOOP_FOR) \
SvREFCNT_dec(cx->blk_loop.state_u.ary.ary);
@@ -986,6 +975,8 @@
/* private flags for CXt_SUB and CXt_FORMAT */
#define CXp_HASARGS 0x20
+#define CXp_SUB_RE 0x40 /* code called within regex, i.e. (?{}) */
+#define CXp_SUB_RE_FAKE 0x80 /* fake sub CX for (?{}) in current scope */
/* private flags for CXt_EVAL */
#define CXp_REAL 0x20 /* truly eval'', not a lookalike */
@@ -1066,6 +1057,7 @@
Perl_magic_methcall(). */
#define G_WRITING_TO_STDERR 1024 /* Perl_write_to_stderr() is calling
Perl_magic_methcall(). */
+#define G_RE_REPARSING 0x800 /* compiling a run-time /(?{..})/ */
/* flag bits for PL_in_eval */
#define EVAL_NULL 0 /* not in an eval */
@@ -1073,6 +1065,7 @@
#define EVAL_WARNONLY 2 /* used by yywarn() when calling yyerror() */
#define EVAL_KEEPERR 4 /* set by Perl_call_sv if G_KEEPERR */
#define EVAL_INREQUIRE 8 /* The code is being required. */
+#define EVAL_RE_REPARSING 0x10 /* eval_sv() called with G_RE_REPARSING */
/* Support for switching (stack and block) contexts.
* This ensures magic doesn't invalidate local stack and cx pointers.
@@ -1151,8 +1144,7 @@
Perl_deb(aTHX_ "pop STACKINFO %d at %s:%d\n", \
i, __FILE__, __LINE__);}) \
if (!prev) { \
- PerlIO_printf(Perl_error_log, "panic: POPSTACK\n"); \
- my_exit(1); \
+ Perl_croak_popstack(); \
} \
SWITCHSTACK(PL_curstack,prev->si_stack); \
/* don't free prev here, free them all at the END{} */ \
@@ -1174,18 +1166,18 @@
=head1 Multicall Functions
=for apidoc Ams||dMULTICALL
-Declare local variables for a multicall. See L<perlcall/Lightweight Callbacks>.
+Declare local variables for a multicall. See L<perlcall/LIGHTWEIGHT CALLBACKS>.
=for apidoc Ams||PUSH_MULTICALL
Opening bracket for a lightweight callback.
-See L<perlcall/Lightweight Callbacks>.
+See L<perlcall/LIGHTWEIGHT CALLBACKS>.
=for apidoc Ams||MULTICALL
-Make a lightweight callback. See L<perlcall/Lightweight Callbacks>.
+Make a lightweight callback. See L<perlcall/LIGHTWEIGHT CALLBACKS>.
=for apidoc Ams||POP_MULTICALL
Closing bracket for a lightweight callback.
-See L<perlcall/Lightweight Callbacks>.
+See L<perlcall/LIGHTWEIGHT CALLBACKS>.
=cut
*/
@@ -1199,18 +1191,26 @@
U8 hasargs = 0 /* used by PUSHSUB */
#define PUSH_MULTICALL(the_cv) \
+ PUSH_MULTICALL_FLAGS(the_cv, 0)
+
+/* Like PUSH_MULTICALL, but allows you to specify extra flags
+ * for the CX stack entry (this isn't part of the public API) */
+
+#define PUSH_MULTICALL_FLAGS(the_cv, flags) \
STMT_START { \
CV * const _nOnclAshIngNamE_ = the_cv; \
CV * const cv = _nOnclAshIngNamE_; \
- AV * const padlist = CvPADLIST(cv); \
+ PADLIST * const padlist = CvPADLIST(cv); \
ENTER; \
multicall_oldcatch = CATCH_GET; \
SAVETMPS; SAVEVPTR(PL_op); \
CATCH_SET(TRUE); \
PUSHSTACKi(PERLSI_SORT); \
- PUSHBLOCK(cx, CXt_SUB|CXp_MULTICALL, PL_stack_sp); \
+ PUSHBLOCK(cx, (CXt_SUB|CXp_MULTICALL|flags), PL_stack_sp); \
PUSHSUB(cx); \
- if (++CvDEPTH(cv) >= 2) { \
+ if (!(flags & CXp_SUB_RE_FAKE)) \
+ CvDEPTH(cv)++; \
+ if (CvDEPTH(cv) >= 2) { \
PERL_STACK_OVERFLOW_CHECK(); \
Perl_pad_push(aTHX_ padlist, CvDEPTH(cv)); \
} \
@@ -1228,8 +1228,10 @@
#define POP_MULTICALL \
STMT_START { \
- if (! --CvDEPTH(multicall_cv)) \
- LEAVESUB(multicall_cv); \
+ cx = &cxstack[cxstack_ix]; \
+ if (! ((CvDEPTH(multicall_cv) = cx->blk_sub.olddepth)) ) { \
+ LEAVESUB(multicall_cv); \
+ } \
POPBLOCK(cx,PL_curpm); \
POPSTACK; \
CATCH_SET(multicall_oldcatch); \
@@ -1237,12 +1239,38 @@
SPAGAIN; \
} STMT_END
+/* Change the CV of an already-pushed MULTICALL CxSUB block.
+ * (this isn't part of the public API) */
+
+#define CHANGE_MULTICALL_FLAGS(the_cv, flags) \
+ STMT_START { \
+ CV * const _nOnclAshIngNamE_ = the_cv; \
+ CV * const cv = _nOnclAshIngNamE_; \
+ PADLIST * const padlist = CvPADLIST(cv); \
+ cx = &cxstack[cxstack_ix]; \
+ assert(cx->cx_type & CXp_MULTICALL); \
+ if (! ((CvDEPTH(multicall_cv) = cx->blk_sub.olddepth)) ) { \
+ LEAVESUB(multicall_cv); \
+ } \
+ cx->cx_type = (CXt_SUB|CXp_MULTICALL|flags); \
+ PUSHSUB(cx); \
+ if (!(flags & CXp_SUB_RE_FAKE)) \
+ CvDEPTH(cv)++; \
+ if (CvDEPTH(cv) >= 2) { \
+ PERL_STACK_OVERFLOW_CHECK(); \
+ Perl_pad_push(aTHX_ padlist, CvDEPTH(cv)); \
+ } \
+ SAVECOMPPAD(); \
+ PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); \
+ multicall_cv = cv; \
+ multicall_cop = CvSTART(cv); \
+ } STMT_END
/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/cop.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/cv.h
===================================================================
--- trunk/contrib/perl/cv.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/cv.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -8,12 +8,11 @@
*
*/
-/* This structure must the beginning of XPVFM in sv.h */
+/* This structure must match the beginning of XPVFM in sv.h */
struct xpvcv {
_XPV_HEAD;
_XPVCV_COMMON;
- I32 xcv_depth; /* >= 2 indicates recursive call */
};
/*
@@ -26,9 +25,17 @@
=head1 CV Manipulation Functions
+This section documents functions to manipulate CVs which are code-values,
+or subroutines. For more information, see L<perlguts>.
+
=for apidoc Am|HV*|CvSTASH|CV* cv
-Returns the stash of the CV.
+Returns the stash of the CV. A stash is the symbol table hash, containing
+the package-scoped variables in the package where the subroutine was defined.
+For more information, see L<perlguts>.
+This also has a special use with XS AUTOLOAD subs.
+See L<perlguts/Autoloading with XSUBs>.
+
=cut
*/
@@ -42,28 +49,40 @@
#define CvROOT(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_root_u.xcv_root
#define CvXSUB(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_root_u.xcv_xsub
#define CvXSUBANY(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_start_u.xcv_xsubany
-#define CvGV(sv) (0+((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv)
+#define CvGV(sv) S_CvGV((CV *)(sv))
#define CvGV_set(cv,gv) Perl_cvgv_set(aTHX_ cv, gv)
#define CvFILE(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_file
#ifdef USE_ITHREADS
-# define CvFILE_set_from_cop(sv, cop) (CvFILE(sv) = savepv(CopFILE(cop)))
+# define CvFILE_set_from_cop(sv, cop) \
+ (CvFILE(sv) = savepv(CopFILE(cop)), CvDYNFILE_on(sv))
#else
-# define CvFILE_set_from_cop(sv, cop) (CvFILE(sv) = CopFILE(cop))
+# define CvFILE_set_from_cop(sv, cop) \
+ (CvFILE(sv) = CopFILE(cop), CvDYNFILE_off(sv))
#endif
#define CvFILEGV(sv) (gv_fetchfile(CvFILE(sv)))
-#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
-# define CvDEPTH(sv) (*({const CV *const _cvdepth = (const CV *)sv; \
- assert(SvTYPE(_cvdepth) == SVt_PVCV); \
- &((XPVCV*)SvANY(_cvdepth))->xcv_depth; \
- }))
-#else
-# define CvDEPTH(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_depth
-#endif
+#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
#define CvOUTSIDE_SEQ(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_outside_seq
+/* These two are sometimes called on non-CVs */
+#define CvPROTO(sv) \
+ ( \
+ SvPOK(sv) \
+ ? SvTYPE(sv) == SVt_PVCV && CvAUTOLOAD(sv) \
+ ? SvEND(sv)+1 : SvPVX_const(sv) \
+ : NULL \
+ )
+#define CvPROTOLEN(sv) \
+ ( \
+ SvPOK(sv) \
+ ? SvTYPE(sv) == SVt_PVCV && CvAUTOLOAD(sv) \
+ ? SvLEN(sv)-SvCUR(sv)-2 \
+ : SvCUR(sv) \
+ : 0 \
+ )
+
#define CVf_METHOD 0x0001 /* CV is explicitly marked as a method */
#define CVf_LVALUE 0x0002 /* CV return value can be used as lvalue */
#define CVf_CONST 0x0004 /* inlinable sub */
@@ -78,6 +97,13 @@
#define CVf_NODEBUG 0x0200 /* no DB::sub indirection for this CV
(esp. useful for special XSUBs) */
#define CVf_CVGV_RC 0x0400 /* CvGV is reference counted */
+#ifdef PERL_CORE
+# define CVf_SLABBED 0x0800 /* Holds refcount on op slab */
+#endif
+#define CVf_DYNFILE 0x1000 /* The filename isn't static */
+#define CVf_AUTOLOAD 0x2000 /* SvPVX contains AUTOLOADed sub name */
+#define CVf_HASEVAL 0x4000 /* contains string eval */
+#define CVf_NAMED 0x8000 /* Has a name HEK */
/* This symbol for optimised communication between toke.c and op.c: */
#define CVf_BUILTIN_ATTRS (CVf_METHOD|CVf_LVALUE)
@@ -94,6 +120,7 @@
#define CvANON_on(cv) (CvFLAGS(cv) |= CVf_ANON)
#define CvANON_off(cv) (CvFLAGS(cv) &= ~CVf_ANON)
+/* CvEVAL or CvSPECIAL */
#define CvUNIQUE(cv) (CvFLAGS(cv) & CVf_UNIQUE)
#define CvUNIQUE_on(cv) (CvFLAGS(cv) |= CVf_UNIQUE)
#define CvUNIQUE_off(cv) (CvFLAGS(cv) &= ~CVf_UNIQUE)
@@ -110,6 +137,7 @@
#define CvLVALUE_on(cv) (CvFLAGS(cv) |= CVf_LVALUE)
#define CvLVALUE_off(cv) (CvFLAGS(cv) &= ~CVf_LVALUE)
+/* eval or PL_main_cv */
#define CvEVAL(cv) (CvUNIQUE(cv) && !SvFAKE(cv))
#define CvEVAL_on(cv) (CvUNIQUE_on(cv),SvFAKE_off(cv))
#define CvEVAL_off(cv) CvUNIQUE_off(cv)
@@ -135,9 +163,55 @@
#define CvCVGV_RC_on(cv) (CvFLAGS(cv) |= CVf_CVGV_RC)
#define CvCVGV_RC_off(cv) (CvFLAGS(cv) &= ~CVf_CVGV_RC)
+#ifdef PERL_CORE
+# define CvSLABBED(cv) (CvFLAGS(cv) & CVf_SLABBED)
+# define CvSLABBED_on(cv) (CvFLAGS(cv) |= CVf_SLABBED)
+# define CvSLABBED_off(cv) (CvFLAGS(cv) &= ~CVf_SLABBED)
+#endif
+
+#define CvDYNFILE(cv) (CvFLAGS(cv) & CVf_DYNFILE)
+#define CvDYNFILE_on(cv) (CvFLAGS(cv) |= CVf_DYNFILE)
+#define CvDYNFILE_off(cv) (CvFLAGS(cv) &= ~CVf_DYNFILE)
+
+#define CvAUTOLOAD(cv) (CvFLAGS(cv) & CVf_AUTOLOAD)
+#define CvAUTOLOAD_on(cv) (CvFLAGS(cv) |= CVf_AUTOLOAD)
+#define CvAUTOLOAD_off(cv) (CvFLAGS(cv) &= ~CVf_AUTOLOAD)
+
+#define CvHASEVAL(cv) (CvFLAGS(cv) & CVf_HASEVAL)
+#define CvHASEVAL_on(cv) (CvFLAGS(cv) |= CVf_HASEVAL)
+#define CvHASEVAL_off(cv) (CvFLAGS(cv) &= ~CVf_HASEVAL)
+
+#define CvNAMED(cv) (CvFLAGS(cv) & CVf_NAMED)
+#define CvNAMED_on(cv) (CvFLAGS(cv) |= CVf_NAMED)
+#define CvNAMED_off(cv) (CvFLAGS(cv) &= ~CVf_NAMED)
+
/* Flags for newXS_flags */
#define XS_DYNAMIC_FILENAME 0x01 /* The filename isn't static */
+PERL_STATIC_INLINE GV *
+S_CvGV(CV *sv)
+{
+ return CvNAMED(sv)
+ ? 0
+ : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv;
+}
+PERL_STATIC_INLINE HEK *
+CvNAME_HEK(CV *sv)
+{
+ return CvNAMED(sv)
+ ? ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_hek
+ : 0;
+}
+/* This lowers the refernce count of the previous value, but does *not*
+ increment the reference count of the new value. */
+#define CvNAME_HEK_set(cv, hek) ( \
+ CvNAME_HEK((CV *)(cv)) \
+ ? unshare_hek(SvANY((CV *)(cv))->xcv_gv_u.xcv_hek) \
+ : (void)0, \
+ ((XPVCV*)MUTABLE_PTR(SvANY(cv)))->xcv_gv_u.xcv_hek = (hek), \
+ CvNAMED_on(cv) \
+ )
+
/*
=head1 CV reference counts and CvOUTSIDE
@@ -199,8 +273,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/cv.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/deb.c
===================================================================
--- trunk/contrib/perl/deb.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/deb.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -114,7 +114,7 @@
{
#ifdef DEBUGGING
dVAR;
- register I32 i = stack_max - 30;
+ I32 i = stack_max - 30;
const I32 *markscan = PL_markstack + mark_min;
PERL_ARGS_ASSERT_DEB_STACK_N;
@@ -330,8 +330,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/deb.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/doio.c
===================================================================
--- trunk/contrib/perl/doio.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/doio.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -61,12 +61,12 @@
#include <signal.h>
bool
-Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw,
+Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw,
int rawmode, int rawperm, PerlIO *supplied_fp, SV **svp,
I32 num_svs)
{
dVAR;
- register IO * const io = GvIOn(gv);
+ IO * const io = GvIOn(gv);
PerlIO *saveifp = NULL;
PerlIO *saveofp = NULL;
int savefd = -1;
@@ -126,8 +126,9 @@
if (result == EOF && fd > PL_maxsysfd) {
/* Why is this not Perl_warn*() call ? */
PerlIO_printf(Perl_error_log,
- "Warning: unable to close filehandle %s properly.\n",
- GvENAME(gv));
+ "Warning: unable to close filehandle %"HEKf" properly.\n",
+ HEKfARG(GvENAME_HEK(gv))
+ );
}
IoOFP(io) = IoIFP(io) = NULL;
}
@@ -148,7 +149,8 @@
int ismodifying;
if (num_svs != 0) {
- Perl_croak(aTHX_ "panic: sysopen with multiple args");
+ Perl_croak(aTHX_ "panic: sysopen with multiple args, num_svs=%ld",
+ (long) num_svs);
}
/* It's not always
@@ -318,7 +320,10 @@
}
while (isSPACE(*type))
type++;
- if (num_svs && (SvIOK(*svp) || (SvPOK(*svp) && looks_like_number(*svp)))) {
+ if (num_svs && (
+ SvIOK(*svp)
+ || (SvPOKp(*svp) && looks_like_number(*svp))
+ )) {
fd = SvUV(*svp);
num_svs = 0;
}
@@ -541,14 +546,16 @@
if ((IoTYPE(io) == IoTYPE_RDONLY) &&
(fp == PerlIO_stdout() || fp == PerlIO_stderr())) {
Perl_warner(aTHX_ packWARN(WARN_IO),
- "Filehandle STD%s reopened as %s only for input",
+ "Filehandle STD%s reopened as %"HEKf
+ " only for input",
((fp == PerlIO_stdout()) ? "OUT" : "ERR"),
- GvENAME(gv));
+ HEKfARG(GvENAME_HEK(gv)));
}
else if ((IoTYPE(io) == IoTYPE_WRONLY) && fp == PerlIO_stdin()) {
Perl_warner(aTHX_ packWARN(WARN_IO),
- "Filehandle STDIN reopened as %s only for output",
- GvENAME(gv));
+ "Filehandle STDIN reopened as %"HEKf" only for output",
+ HEKfARG(GvENAME_HEK(gv))
+ );
}
}
@@ -616,9 +623,9 @@
char newname[FILENAME_MAX+1];
if (PerlIO_getname(fp, newname)) {
if (fd == PerlIO_fileno(PerlIO_stdout()))
- Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT", newname);
+ vmssetuserlnm("SYS$OUTPUT", newname);
if (fd == PerlIO_fileno(PerlIO_stderr()))
- Perl_vmssetuserlnm(aTHX_ "SYS$ERROR", newname);
+ vmssetuserlnm("SYS$ERROR", newname);
}
}
#endif
@@ -699,10 +706,10 @@
}
PerlIO *
-Perl_nextargv(pTHX_ register GV *gv)
+Perl_nextargv(pTHX_ GV *gv)
{
dVAR;
- register SV *sv;
+ SV *sv;
#ifndef FLEXFILENAMES
int filedev;
int fileino;
@@ -740,6 +747,7 @@
STRLEN oldlen;
sv = av_shift(GvAV(gv));
SAVEFREESV(sv);
+ SvTAINTED_off(GvSVn(gv)); /* previous tainting irrelevant */
sv_setsv(GvSVn(gv),sv);
SvSETMAGIC(GvSV(gv));
PL_oldname = SvPVx(GvSV(gv), oldlen);
@@ -798,7 +806,7 @@
}
#endif
#ifdef HAS_RENAME
-#if !defined(DOSISH) && !defined(__CYGWIN__) && !defined(EPOC)
+#if !defined(DOSISH) && !defined(__CYGWIN__)
if (PerlLIO_rename(PL_oldname,SvPVX_const(sv)) < 0) {
Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
"Can't rename %s to %"SVf": %s, skipping file",
@@ -861,10 +869,7 @@
#ifdef HAS_FCHMOD
(void)fchmod(PL_lastfd,PL_filemode);
#else
-# if !(defined(WIN32) && defined(__BORLANDC__))
- /* Borland runtime creates a readonly file! */
(void)PerlLIO_chmod(PL_oldname,PL_filemode);
-# endif
#endif
if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
#ifdef HAS_FCHOWN
@@ -903,7 +908,7 @@
{
GV * const oldout = MUTABLE_GV(av_pop(PL_argvout_stack));
setdefout(oldout);
- SvREFCNT_dec(oldout);
+ SvREFCNT_dec_NN(oldout);
return NULL;
}
setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO));
@@ -989,7 +994,7 @@
Perl_do_eof(pTHX_ GV *gv)
{
dVAR;
- register IO * const io = GvIO(gv);
+ IO * const io = GvIO(gv);
PERL_ARGS_ASSERT_DO_EOF;
@@ -1035,7 +1040,7 @@
{
dVAR;
IO *const io = GvIO(gv);
- register PerlIO *fp;
+ PerlIO *fp;
PERL_ARGS_ASSERT_DO_TELL;
@@ -1056,7 +1061,7 @@
{
dVAR;
IO *const io = GvIO(gv);
- register PerlIO *fp;
+ PerlIO *fp;
if (io && (fp = IoIFP(io))) {
#ifdef ULTRIX_STDIO_BOTCH
@@ -1075,7 +1080,7 @@
{
dVAR;
IO *const io = GvIO(gv);
- register PerlIO *fp;
+ PerlIO *fp;
PERL_ARGS_ASSERT_DO_SYSSEEK;
@@ -1194,7 +1199,7 @@
#endif /* !HAS_TRUNCATE && !HAS_CHSIZE */
bool
-Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
+Perl_do_print(pTHX_ SV *sv, PerlIO *fp)
{
dVAR;
@@ -1218,26 +1223,31 @@
U8 *tmpbuf = NULL;
bool happy = TRUE;
- if (PerlIO_isutf8(fp)) {
- if (!SvUTF8(sv)) {
+ if (PerlIO_isutf8(fp)) { /* If the stream is utf8 ... */
+ if (!SvUTF8(sv)) { /* Convert to utf8 if necessary */
/* We don't modify the original scalar. */
tmpbuf = bytes_to_utf8((const U8*) tmps, &len);
tmps = (char *) tmpbuf;
}
- else if (ckWARN_d(WARN_UTF8)) {
+ else if (ckWARN4_d(WARN_UTF8, WARN_SURROGATE, WARN_NON_UNICODE, WARN_NONCHAR)) {
(void) check_utf8_print((const U8*) tmps, len);
}
- }
- else if (DO_UTF8(sv)) {
+ } /* else stream isn't utf8 */
+ else if (DO_UTF8(sv)) { /* But if is utf8 internally, attempt to
+ convert to bytes */
STRLEN tmplen = len;
bool utf8 = TRUE;
U8 * const result = bytes_from_utf8((const U8*) tmps, &tmplen, &utf8);
if (!utf8) {
+
+ /* Here, succeeded in downgrading from utf8. Set up to below
+ * output the converted value */
tmpbuf = result;
tmps = (char *) tmpbuf;
len = tmplen;
}
- else {
+ else { /* Non-utf8 output stream, but string only representable in
+ utf8 */
assert((char *)result == tmps);
Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
"Wide character in %s",
@@ -1270,7 +1280,6 @@
GV* gv;
if (PL_op->op_flags & OPf_REF) {
- EXTEND(SP,1);
gv = cGVOP_gv;
do_fstat:
if (gv == PL_defgv)
@@ -1278,7 +1287,7 @@
io = GvIO(gv);
do_fstat_have_io:
PL_laststype = OP_STAT;
- PL_statgv = gv;
+ PL_statgv = gv ? gv : (GV *)io;
sv_setpvs(PL_statname, "");
if(io) {
if (IoIFP(io)) {
@@ -1285,31 +1294,22 @@
return (PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache));
} else if (IoDIRP(io)) {
return (PL_laststatval = PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache));
- } else {
- report_evil_fh(gv);
- return (PL_laststatval = -1);
}
- } else {
- report_evil_fh(gv);
- return (PL_laststatval = -1);
}
+ PL_laststatval = -1;
+ report_evil_fh(gv);
+ return -1;
}
- else if (PL_op->op_private & OPpFT_STACKED) {
+ else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
+ == OPpFT_STACKED)
return PL_laststatval;
- }
else {
- SV* const sv = POPs;
+ SV* const sv = TOPs;
const char *s;
STRLEN len;
- PUTBACK;
- if (isGV_with_GP(sv)) {
- gv = MUTABLE_GV(sv);
+ if ((gv = MAYBE_DEREF_GV_flags(sv,flags))) {
goto do_fstat;
}
- else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
- gv = MUTABLE_GV(SvRV(sv));
- goto do_fstat;
- }
else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
io = MUTABLE_IO(SvRV(sv));
gv = NULL;
@@ -1333,35 +1333,36 @@
Perl_my_lstat_flags(pTHX_ const U32 flags)
{
dVAR;
- static const char no_prev_lstat[] = "The stat preceding -l _ wasn't an lstat";
+ static const char* const no_prev_lstat = "The stat preceding -l _ wasn't an lstat";
dSP;
- SV *sv;
const char *file;
+ SV* const sv = TOPs;
if (PL_op->op_flags & OPf_REF) {
- EXTEND(SP,1);
if (cGVOP_gv == PL_defgv) {
if (PL_laststype != OP_LSTAT)
- Perl_croak(aTHX_ no_prev_lstat);
+ Perl_croak(aTHX_ "%s", no_prev_lstat);
return PL_laststatval;
}
+ PL_laststatval = -1;
if (ckWARN(WARN_IO)) {
- Perl_warner(aTHX_ packWARN(WARN_IO), "Use of -l on filehandle %s",
- GvENAME(cGVOP_gv));
- return (PL_laststatval = -1);
+ Perl_warner(aTHX_ packWARN(WARN_IO),
+ "Use of -l on filehandle %"HEKf,
+ HEKfARG(GvENAME_HEK(cGVOP_gv)));
}
+ return -1;
}
- else if (PL_laststype != OP_LSTAT
- && (PL_op->op_private & OPpFT_STACKED) && ckWARN(WARN_IO))
- Perl_croak(aTHX_ no_prev_lstat);
+ if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
+ == OPpFT_STACKED) {
+ if (PL_laststype != OP_LSTAT)
+ Perl_croak(aTHX_ "%s", no_prev_lstat);
+ return PL_laststatval;
+ }
PL_laststype = OP_LSTAT;
PL_statgv = NULL;
- sv = POPs;
- PUTBACK;
if (SvROK(sv) && isGV_with_GP(SvRV(sv)) && ckWARN(WARN_IO)) {
- Perl_warner(aTHX_ packWARN(WARN_IO), "Use of -l on filehandle %s",
- GvENAME((const GV *)SvRV(sv)));
- return (PL_laststatval = -1);
+ Perl_warner(aTHX_ packWARN(WARN_IO), "Use of -l on filehandle %s",
+ GvENAME((const GV *)SvRV(sv)));
}
file = SvPV_flags_const_nolen(sv, flags);
sv_setpv(PL_statname,file);
@@ -1386,7 +1387,7 @@
}
bool
-Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp,
+Perl_do_aexec5(pTHX_ SV *really, SV **mark, SV **sp,
int fd, int do_report)
{
dVAR;
@@ -1441,8 +1442,8 @@
Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report)
{
dVAR;
- register const char **a;
- register char *s;
+ const char **a;
+ char *s;
char *buf;
char *cmd;
/* Make a copy so we can change it */
@@ -1503,7 +1504,7 @@
goto doshell;
s = cmd;
- while (isALNUM(*s))
+ while (isWORDCHAR(*s))
s++; /* catch VAR=val gizmo */
if (*s == '=')
goto doshell;
@@ -1570,18 +1571,26 @@
#endif /* OS2 || WIN32 */
+#ifdef VMS
+#include <starlet.h> /* for sys$delprc */
+#endif
+
I32
-Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp)
+Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
{
dVAR;
- register I32 val;
- register I32 tot = 0;
+ I32 val;
+ I32 tot = 0;
const char *const what = PL_op_name[type];
const char *s;
+ STRLEN len;
SV ** const oldmark = mark;
+ bool killgp = FALSE;
PERL_ARGS_ASSERT_APPLY;
+ PERL_UNUSED_VAR(what); /* may not be used depending on compile options */
+
/* Doing this ahead of the switch statement preserves the old behaviour,
where attempting to use kill as a taint test test would fail on
platforms where kill was not defined. */
@@ -1597,11 +1606,11 @@
#define APPLY_TAINT_PROPER() \
STMT_START { \
- if (PL_tainted) { TAINT_PROPER(what); } \
+ if (TAINT_get) { TAINT_PROPER(what); } \
} STMT_END
/* This is a first heuristic; it doesn't catch tainting magic. */
- if (PL_tainting) {
+ if (TAINTING_get) {
while (++mark <= sp) {
if (SvTAINTED(*mark)) {
TAINT;
@@ -1619,9 +1628,7 @@
tot = sp - mark;
while (++mark <= sp) {
GV* gv;
- if (isGV_with_GP(*mark)) {
- gv = MUTABLE_GV(*mark);
- do_fchmod:
+ if ((gv = MAYBE_DEREF_GV(*mark))) {
if (GvIO(gv) && IoIFP(GvIOp(gv))) {
#ifdef HAS_FCHMOD
APPLY_TAINT_PROPER();
@@ -1635,12 +1642,8 @@
tot--;
}
}
- else if (SvROK(*mark) && isGV_with_GP(SvRV(*mark))) {
- gv = MUTABLE_GV(SvRV(*mark));
- goto do_fchmod;
- }
else {
- const char *name = SvPV_nolen_const(*mark);
+ const char *name = SvPV_nomg_const_nolen(*mark);
APPLY_TAINT_PROPER();
if (PerlLIO_chmod(name, val))
tot--;
@@ -1652,7 +1655,7 @@
case OP_CHOWN:
APPLY_TAINT_PROPER();
if (sp - mark > 2) {
- register I32 val2;
+ I32 val2;
val = SvIVx(*++mark);
val2 = SvIVx(*++mark);
APPLY_TAINT_PROPER();
@@ -1659,9 +1662,7 @@
tot = sp - mark;
while (++mark <= sp) {
GV* gv;
- if (isGV_with_GP(*mark)) {
- gv = MUTABLE_GV(*mark);
- do_fchown:
+ if ((gv = MAYBE_DEREF_GV(*mark))) {
if (GvIO(gv) && IoIFP(GvIOp(gv))) {
#ifdef HAS_FCHOWN
APPLY_TAINT_PROPER();
@@ -1675,12 +1676,8 @@
tot--;
}
}
- else if (SvROK(*mark) && isGV_with_GP(SvRV(*mark))) {
- gv = MUTABLE_GV(SvRV(*mark));
- goto do_fchown;
- }
else {
- const char *name = SvPV_nolen_const(*mark);
+ const char *name = SvPV_nomg_const_nolen(*mark);
APPLY_TAINT_PROPER();
if (PerlLIO_chown(name, val, val2))
tot--;
@@ -1700,22 +1697,35 @@
APPLY_TAINT_PROPER();
if (mark == sp)
break;
- s = SvPVx_nolen_const(*++mark);
+ s = SvPVx_const(*++mark, len);
+ if (*s == '-' && isALPHA(s[1]))
+ {
+ s++;
+ len--;
+ killgp = TRUE;
+ }
if (isALPHA(*s)) {
- if (*s == 'S' && s[1] == 'I' && s[2] == 'G')
+ if (*s == 'S' && s[1] == 'I' && s[2] == 'G') {
s += 3;
- if ((val = whichsig(s)) < 0)
- Perl_croak(aTHX_ "Unrecognized signal name \"%s\"",s);
+ len -= 3;
+ }
+ if ((val = whichsig_pvn(s, len)) < 0)
+ Perl_croak(aTHX_ "Unrecognized signal name \"%"SVf"\"", SVfARG(*mark));
}
else
+ {
val = SvIV(*mark);
+ if (val < 0)
+ {
+ killgp = TRUE;
+ val = -val;
+ }
+ }
APPLY_TAINT_PROPER();
tot = sp - mark;
#ifdef VMS
/* kill() doesn't do process groups (job trees?) under VMS */
- if (val < 0) val = -val;
if (val == SIGKILL) {
-# include <starlet.h>
/* Use native sys$delprc() to insure that target process is
* deleted; supervisor-mode images don't pay attention to
* CRTL's emulation of Unix-style signals and kill()
@@ -1722,7 +1732,7 @@
*/
while (++mark <= sp) {
I32 proc;
- register unsigned long int __vmssts;
+ unsigned long int __vmssts;
SvGETMAGIC(*mark);
if (!(SvIOK(*mark) || SvNOK(*mark) || looks_like_number(*mark)))
Perl_croak(aTHX_ "Can't kill a non-numeric process ID");
@@ -1747,35 +1757,20 @@
break;
}
#endif
- if (val < 0) {
- val = -val;
- while (++mark <= sp) {
- I32 proc;
- SvGETMAGIC(*mark);
- if (!(SvIOK(*mark) || SvNOK(*mark) || looks_like_number(*mark)))
- Perl_croak(aTHX_ "Can't kill a non-numeric process ID");
- proc = SvIV_nomg(*mark);
- APPLY_TAINT_PROPER();
-#ifdef HAS_KILLPG
- if (PerlProc_killpg(proc,val)) /* BSD */
-#else
- if (PerlProc_kill(-proc,val)) /* SYSV */
-#endif
- tot--;
+ while (++mark <= sp) {
+ Pid_t proc;
+ SvGETMAGIC(*mark);
+ if (!(SvNIOK(*mark) || looks_like_number(*mark)))
+ Perl_croak(aTHX_ "Can't kill a non-numeric process ID");
+ proc = SvIV_nomg(*mark);
+ if (killgp)
+ {
+ proc = -proc;
}
+ APPLY_TAINT_PROPER();
+ if (PerlProc_kill(proc, val))
+ tot--;
}
- else {
- while (++mark <= sp) {
- I32 proc;
- SvGETMAGIC(*mark);
- if (!(SvIOK(*mark) || SvNOK(*mark) || looks_like_number(*mark)))
- Perl_croak(aTHX_ "Can't kill a non-numeric process ID");
- proc = SvIV_nomg(*mark);
- APPLY_TAINT_PROPER();
- if (PerlProc_kill(proc, val))
- tot--;
- }
- }
PERL_ASYNC_CHECK();
break;
#endif
@@ -1785,7 +1780,7 @@
while (++mark <= sp) {
s = SvPV_nolen_const(*mark);
APPLY_TAINT_PROPER();
- if (PL_euid || PL_unsafe) {
+ if (PerlProc_geteuid() || PL_unsafe) {
if (UNLINK(s))
tot--;
}
@@ -1845,9 +1840,7 @@
tot = sp - mark;
while (++mark <= sp) {
GV* gv;
- if (isGV_with_GP(*mark)) {
- gv = MUTABLE_GV(*mark);
- do_futimes:
+ if ((gv = MAYBE_DEREF_GV(*mark))) {
if (GvIO(gv) && IoIFP(GvIOp(gv))) {
#ifdef HAS_FUTIMES
APPLY_TAINT_PROPER();
@@ -1862,12 +1855,8 @@
tot--;
}
}
- else if (SvROK(*mark) && isGV_with_GP(SvRV(*mark))) {
- gv = MUTABLE_GV(SvRV(*mark));
- goto do_futimes;
- }
else {
- const char * const name = SvPV_nolen_const(*mark);
+ const char * const name = SvPV_nomg_const_nolen(*mark);
APPLY_TAINT_PROPER();
#ifdef HAS_FUTIMES
if (utimes(name, (struct timeval *)utbufp))
@@ -1892,7 +1881,7 @@
/* Do the permissions allow some operation? Assumes statcache already set. */
#ifndef VMS /* VMS' cando is in vms.c */
bool
-Perl_cando(pTHX_ Mode_t mode, bool effective, register const Stat_t *statbufp)
+Perl_cando(pTHX_ Mode_t mode, bool effective, const Stat_t *statbufp)
/* effective is a flag, true for EUID, or for checking if the effective gid
* is in the list of groups returned from getgroups().
*/
@@ -1929,7 +1918,7 @@
# ifdef __CYGWIN__
if (ingroup(544,effective)) { /* member of Administrators */
# else
- if ((effective ? PL_euid : PL_uid) == 0) { /* root is special */
+ if ((effective ? PerlProc_geteuid() : PerlProc_getuid()) == 0) { /* root is special */
# endif
if (mode == S_IXUSR) {
if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
@@ -1939,7 +1928,7 @@
return TRUE; /* root reads and writes anything */
return FALSE;
}
- if (statbufp->st_uid == (effective ? PL_euid : PL_uid) ) {
+ if (statbufp->st_uid == (effective ? PerlProc_geteuid() : PerlProc_getuid()) ) {
if (statbufp->st_mode & mode)
return TRUE; /* ok as "user" */
}
@@ -1958,7 +1947,7 @@
S_ingroup(pTHX_ Gid_t testgid, bool effective)
{
dVAR;
- if (testgid == (effective ? PL_egid : PL_gid))
+ if (testgid == (effective ? PerlProc_getegid() : PerlProc_getgid()))
return TRUE;
#ifdef HAS_GETGROUPS
{
@@ -2173,6 +2162,7 @@
PERL_UNUSED_ARG(mark);
/* diag_listed_as: msg%s not implemented */
Perl_croak(aTHX_ "msgsnd not implemented");
+ return -1;
#endif
}
@@ -2215,6 +2205,7 @@
PERL_UNUSED_ARG(mark);
/* diag_listed_as: msg%s not implemented */
Perl_croak(aTHX_ "msgrcv not implemented");
+ return -1;
#endif
}
@@ -2302,9 +2293,11 @@
if (optype == OP_SHMREAD) {
char *mbuf;
/* suppress warning when reading into undef var (tchrist 3/Mar/00) */
+ SvGETMAGIC(mstr);
+ SvUPGRADE(mstr, SVt_PV);
if (! SvOK(mstr))
sv_setpvs(mstr, "");
- SvPV_force_nolen(mstr);
+ SvPOK_only(mstr);
mbuf = SvGROW(mstr, (STRLEN)msize+1);
Copy(shm + mpos, mbuf, msize, char);
@@ -2329,6 +2322,7 @@
#else
/* diag_listed_as: shm%s not implemented */
Perl_croak(aTHX_ "shm I/O not implemented");
+ return -1;
#endif
}
@@ -2400,6 +2394,16 @@
#endif
#endif /* !CSH */
#endif /* !DOSISH */
+ {
+ GV * const envgv = gv_fetchpvs("ENV", 0, SVt_PVHV);
+ SV ** const home = hv_fetchs(GvHV(envgv), "HOME", 0);
+ SV ** const path = hv_fetchs(GvHV(envgv), "PATH", 0);
+ if (home && *home) SvGETMAGIC(*home);
+ if (path && *path) SvGETMAGIC(*path);
+ save_hash(gv_fetchpvs("ENV", 0, SVt_PVHV));
+ if (home && *home) SvSETMAGIC(*home);
+ if (path && *path) SvSETMAGIC(*path);
+ }
(void)do_open(PL_last_in_gv, (char*)SvPVX_const(tmpcmd), SvCUR(tmpcmd),
FALSE, O_RDONLY, 0, NULL);
fp = IoIFP(io);
@@ -2412,8 +2416,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/doio.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/doop.c
===================================================================
--- trunk/contrib/perl/doop.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/doop.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -632,17 +632,15 @@
PERL_ARGS_ASSERT_DO_TRANS;
if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_IDENTICAL)) {
- if (SvIsCOW(sv))
- sv_force_normal_flags(sv, 0);
- if (SvREADONLY(sv))
- Perl_croak_no_modify(aTHX);
+ if (!SvIsCOW(sv))
+ Perl_croak_no_modify();
}
(void)SvPV_const(sv, len);
if (!len)
return 0;
if (!(PL_op->op_private & OPpTRANS_IDENTICAL)) {
- if (!SvPOKp(sv))
- (void)SvPV_force(sv, len);
+ if (!SvPOKp(sv) || SvTHINKFIRST(sv))
+ (void)SvPV_force_nomg(sv, len);
(void)SvPOK_only_UTF8(sv);
}
@@ -673,12 +671,12 @@
}
void
-Perl_do_join(pTHX_ register SV *sv, SV *delim, register SV **mark, register SV **sp)
+Perl_do_join(pTHX_ SV *sv, SV *delim, SV **mark, SV **sp)
{
dVAR;
SV ** const oldmark = mark;
- register I32 items = sp - mark;
- register STRLEN len;
+ I32 items = sp - mark;
+ STRLEN len;
STRLEN delimlen;
PERL_ARGS_ASSERT_DO_JOIN;
@@ -709,7 +707,7 @@
/* sv_setpv retains old UTF8ness [perl #24846] */
SvUTF8_off(sv);
- if (PL_tainting && SvMAGICAL(sv))
+ if (TAINTING_get && SvMAGICAL(sv))
SvTAINTED_off(sv);
if (items-- > 0) {
@@ -720,7 +718,7 @@
if (delimlen) {
for (; items > 0; items--,mark++) {
- sv_catsv(sv,delim);
+ sv_catsv_nomg(sv,delim);
sv_catsv(sv,*mark);
}
}
@@ -760,13 +758,19 @@
/* currently converts input to bytes if possible, but doesn't sweat failure */
UV
-Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size)
+Perl_do_vecget(pTHX_ SV *sv, SSize_t offset, int size)
{
dVAR;
STRLEN srclen, len, uoffset, bitoffs = 0;
- const unsigned char *s = (const unsigned char *) SvPV_const(sv, srclen);
+ const unsigned char *s = (const unsigned char *) SvPV_flags_const(sv, srclen,
+ SV_GMAGIC | ((PL_op->op_flags & OPf_MOD || LVRET)
+ ? SV_UNDEF_RETURNS_NULL : 0));
UV retnum = 0;
+ if (!s) {
+ s = (const unsigned char *)"";
+ }
+
PERL_ARGS_ASSERT_DO_VECGET;
if (offset < 0)
@@ -908,10 +912,10 @@
Perl_do_vecset(pTHX_ SV *sv)
{
dVAR;
- register I32 offset, bitoffs = 0;
- register I32 size;
- register unsigned char *s;
- register UV lval;
+ SSize_t offset, bitoffs = 0;
+ int size;
+ unsigned char *s;
+ UV lval;
I32 mask;
STRLEN targlen;
STRLEN len;
@@ -921,7 +925,8 @@
if (!targ)
return;
- s = (unsigned char*)SvPV_force(targ, targlen);
+ s = (unsigned char*)SvPV_force_flags(targ, targlen,
+ SV_GMAGIC | SV_UNDEF_RETURNS_NULL);
if (SvUTF8(targ)) {
/* This is handled by the SvPOK_only below...
if (!Perl_sv_utf8_downgrade(aTHX_ targ, TRUE))
@@ -995,16 +1000,16 @@
{
dVAR;
#ifdef LIBERAL
- register long *dl;
- register long *ll;
- register long *rl;
+ long *dl;
+ long *ll;
+ long *rl;
#endif
- register char *dc;
+ char *dc;
STRLEN leftlen;
STRLEN rightlen;
- register const char *lc;
- register const char *rc;
- register STRLEN len;
+ const char *lc;
+ const char *rc;
+ STRLEN len;
STRLEN lensave;
const char *lsave;
const char *rsave;
@@ -1014,7 +1019,7 @@
PERL_ARGS_ASSERT_DO_VOP;
- if (sv != left || (optype != OP_BIT_AND && !SvOK(sv) && !SvGMAGICAL(sv)))
+ if (sv != left || (optype != OP_BIT_AND && !SvOK(sv)))
sv_setpvs(sv, ""); /* avoid undef warning on |= and ^= */
if (sv == left) {
lsave = lc = SvPV_force_nomg(left, leftlen);
@@ -1124,12 +1129,12 @@
else if (lulen)
dcsave = savepvn(lc, lulen);
if (sv == left || sv == right)
- (void)sv_usepvn(sv, dcorig, needlen); /* Uses Renew(). */
+ (void)sv_usepvn(sv, dcorig, needlen); /* uses Renew(); defaults to nomg */
SvCUR_set(sv, dc - dcorig);
if (rulen)
- sv_catpvn(sv, dcsave, rulen);
+ sv_catpvn_nomg(sv, dcsave, rulen);
else if (lulen)
- sv_catpvn(sv, dcsave, lulen);
+ sv_catpvn_nomg(sv, dcsave, lulen);
else
*SvEND(sv) = '\0';
Safefree(dcsave);
@@ -1207,9 +1212,9 @@
mop_up:
len = lensave;
if (rightlen > len)
- sv_catpvn(sv, rsave + len, rightlen - len);
+ sv_catpvn_nomg(sv, rsave + len, rightlen - len);
else if (leftlen > (STRLEN)len)
- sv_catpvn(sv, lsave + len, leftlen - len);
+ sv_catpvn_nomg(sv, lsave + len, leftlen - len);
else
*SvEND(sv) = '\0';
break;
@@ -1224,9 +1229,8 @@
{
dVAR;
dSP;
- HV * const hv = MUTABLE_HV(POPs);
- HV *keys;
- register HE *entry;
+ HV * const keys = MUTABLE_HV(POPs);
+ HE *entry;
const I32 gimme = GIMME_V;
const I32 dokv = (PL_op->op_type == OP_RV2HV || PL_op->op_type == OP_PADHV);
/* op_type is OP_RKEYS/OP_RVALUES if pp_rkeys delegated to here */
@@ -1233,17 +1237,6 @@
const I32 dokeys = dokv || (PL_op->op_type == OP_KEYS || PL_op->op_type == OP_RKEYS);
const I32 dovalues = dokv || (PL_op->op_type == OP_VALUES || PL_op->op_type == OP_RVALUES);
- if (!hv) {
- if (PL_op->op_flags & OPf_MOD || LVRET) { /* lvalue */
- dTARGET; /* make sure to clear its target here */
- if (SvTYPE(TARG) == SVt_PVLV)
- LvTARG(TARG) = NULL;
- PUSHs(TARG);
- }
- RETURN;
- }
-
- keys = hv;
(void)hv_iterinit(keys); /* always reset iterator regardless */
if (gimme == G_VOID)
@@ -1262,7 +1255,7 @@
dTARGET;
if (! SvTIED_mg((const SV *)keys, PERL_MAGIC_tied) ) {
- i = HvKEYS(keys);
+ i = HvUSEDKEYS(keys);
}
else {
i = 0;
@@ -1273,7 +1266,7 @@
RETURN;
}
- EXTEND(SP, HvKEYS(keys) * (dokeys + dovalues));
+ EXTEND(SP, HvUSEDKEYS(keys) * (dokeys + dovalues));
PUTBACK; /* hv_iternext and hv_iterval might clobber stack_sp */
while ((entry = hv_iternext(keys))) {
@@ -1285,7 +1278,7 @@
if (dovalues) {
SV *tmpstr;
PUTBACK;
- tmpstr = hv_iterval(hv,entry);
+ tmpstr = hv_iterval(keys,entry);
DEBUG_H(Perl_sv_setpvf(aTHX_ tmpstr, "%lu%%%d=%lu",
(unsigned long)HeHASH(entry),
(int)HvMAX(keys)+1,
@@ -1302,8 +1295,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/doop.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/dosish.h
===================================================================
--- trunk/contrib/perl/dosish.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/dosish.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -52,7 +52,9 @@
#endif /* DJGPP */
#ifndef PERL_SYS_TERM_BODY
-# define PERL_SYS_TERM_BODY() HINTS_REFCNT_TERM; OP_REFCNT_TERM; PERLIO_TERM; MALLOC_TERM
+# define PERL_SYS_TERM_BODY() \
+ HINTS_REFCNT_TERM; OP_CHECK_MUTEX_TERM; \
+ OP_REFCNT_TERM; PERLIO_TERM; MALLOC_TERM
#endif
#define dXSUB_SYS
@@ -88,12 +90,7 @@
* information.
*/
#if defined(WIN64) || defined(USE_LARGE_FILES)
-# if defined(__BORLANDC__) /* buk */
-# include <sys\stat.h>
-# define Stat_t struct stati64
-# else
#define Stat_t struct _stati64
-# endif
#else
#if defined(UNDER_CE)
#define Stat_t struct xcestat
@@ -207,8 +204,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/dosish.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/dquote_static.c
===================================================================
--- trunk/contrib/perl/dquote_static.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/dquote_static.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -8,7 +8,6 @@
*/
#define PERL_IN_DQUOTE_STATIC_C
-#include "proto.h"
#include "embed.h"
/*
@@ -16,7 +15,11 @@
Pulled from regcomp.c.
*/
PERL_STATIC_INLINE I32
-S_regcurly(pTHX_ register const char *s)
+S_regcurly(pTHX_ const char *s,
+ const bool rbrace_must_be_escaped /* Should the terminating '} be
+ preceded by a backslash? This
+ is an abnormal case */
+ )
{
PERL_ARGS_ASSERT_REGCURLY;
@@ -31,9 +34,10 @@
while (isDIGIT(*s))
s++;
}
- if (*s != '}')
- return FALSE;
- return TRUE;
+
+ return (rbrace_must_be_escaped)
+ ? *s == '\\' && *(s+1) == '}'
+ : *s == '}';
}
/* XXX Add documentation after final interface and behavior is decided */
@@ -69,7 +73,7 @@
else {
U8 clearer[3];
U8 i = 0;
- if (! isALNUM(result)) {
+ if (! isWORDCHAR(result)) {
clearer[i++] = '\\';
}
clearer[i++] = result;
@@ -86,11 +90,10 @@
}
STATIC bool
-S_grok_bslash_o(pTHX_ const char *s,
- UV *uv,
- STRLEN *len,
- const char** error_msg,
- const bool output_warning)
+S_grok_bslash_o(pTHX_ char **s, UV *uv, const char** error_msg,
+ const bool output_warning, const bool strict,
+ const bool silence_non_portable,
+ const bool UTF)
{
/* Documentation to be supplied when interface nailed down finally
@@ -97,20 +100,27 @@
* This returns FALSE if there is an error which the caller need not recover
* from; , otherwise TRUE. In either case the caller should look at *len
* On input:
- * s points to a string that begins with 'o', and the previous character
- * was a backslash.
+ * s is the address of a pointer to a NULL terminated string that begins
+ * with 'o', and the previous character was a backslash. At exit, *s
+ * will be advanced to the byte just after those absorbed by this
+ * function. Hence the caller can continue parsing from there. In
+ * the case of an error, this routine has generally positioned *s to
+ * point just to the right of the first bad spot, so that a message
+ * that has a "<--" to mark the spot will be correctly positioned.
* uv points to a UV that will hold the output value, valid only if the
* return from the function is TRUE
- * len on success will point to the next character in the string past the
- * end of this construct.
- * on failure, it will point to the failure
* error_msg is a pointer that will be set to an internal buffer giving an
* error message upon failure (the return is FALSE). Untouched if
* function succeeds
* output_warning says whether to output any warning messages, or suppress
* them
+ * strict is true if this should fail instead of warn if there are
+ * non-octal digits within the braces
+ * silence_non_portable is true if to suppress warnings about the code
+ * point returned being too large to fit on all platforms.
+ * UTF is true iff the string *s is encoded in UTF-8.
*/
- const char* e;
+ char* e;
STRLEN numbers_len;
I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
| PERL_SCAN_DISALLOW_PREFIX
@@ -121,55 +131,212 @@
PERL_ARGS_ASSERT_GROK_BSLASH_O;
- assert(*s == 'o');
- s++;
+ assert(**s == 'o');
+ (*s)++;
- if (*s != '{') {
- *len = 1; /* Move past the o */
+ if (**s != '{') {
*error_msg = "Missing braces on \\o{}";
return FALSE;
}
- e = strchr(s, '}');
+ e = strchr(*s, '}');
if (!e) {
- *len = 2; /* Move past the o{ */
- *error_msg = "Missing right brace on \\o{";
+ (*s)++; /* Move past the '{' */
+ while (isOCTAL(**s)) { /* Position beyond the legal digits */
+ (*s)++;
+ }
+ *error_msg = "Missing right brace on \\o{";
return FALSE;
}
- /* Return past the '}' no matter what is inside the braces */
- *len = e - s + 2; /* 2 = 1 for the o + 1 for the '}' */
-
- s++; /* Point to first digit */
-
- numbers_len = e - s;
+ (*s)++; /* Point to expected first digit (could be first byte of utf8
+ sequence if not a digit) */
+ numbers_len = e - *s;
if (numbers_len == 0) {
+ (*s)++; /* Move past the } */
*error_msg = "Number with no digits";
return FALSE;
}
- *uv = NATIVE_TO_UNI(grok_oct(s, &numbers_len, &flags, NULL));
+ if (silence_non_portable) {
+ flags |= PERL_SCAN_SILENT_NON_PORTABLE;
+ }
+
+ *uv = grok_oct(*s, &numbers_len, &flags, NULL);
/* Note that if has non-octal, will ignore everything starting with that up
* to the '}' */
- if (output_warning && numbers_len != (STRLEN) (e - s)) {
- Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
- /* diag_listed_as: Non-octal character '%c'. Resolved as "%s" */
- "Non-octal character '%c'. Resolved as \"\\o{%.*s}\"",
- *(s + numbers_len),
- (int) numbers_len,
- s);
+ if (numbers_len != (STRLEN) (e - *s)) {
+ if (strict) {
+ *s += numbers_len;
+ *s += (UTF) ? UTF8SKIP(*s) : (STRLEN) 1;
+ *error_msg = "Non-octal character";
+ return FALSE;
+ }
+ else if (output_warning) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
+ /* diag_listed_as: Non-octal character '%c'. Resolved as "%s" */
+ "Non-octal character '%c'. Resolved as \"\\o{%.*s}\"",
+ *(*s + numbers_len),
+ (int) numbers_len,
+ *s);
+ }
}
+ /* Return past the '}' */
+ *s = e + 1;
+
return TRUE;
}
+PERL_STATIC_INLINE bool
+S_grok_bslash_x(pTHX_ char **s, UV *uv, const char** error_msg,
+ const bool output_warning, const bool strict,
+ const bool silence_non_portable,
+ const bool UTF)
+{
+
+/* Documentation to be supplied when interface nailed down finally
+ * This returns FALSE if there is an error which the caller need not recover
+ * from; , otherwise TRUE. In either case the caller should look at *len
+ * On input:
+ * s is the address of a pointer to a NULL terminated string that begins
+ * with 'x', and the previous character was a backslash. At exit, *s
+ * will be advanced to the byte just after those absorbed by this
+ * function. Hence the caller can continue parsing from there. In
+ * the case of an error, this routine has generally positioned *s to
+ * point just to the right of the first bad spot, so that a message
+ * that has a "<--" to mark the spot will be correctly positioned.
+ * uv points to a UV that will hold the output value, valid only if the
+ * return from the function is TRUE
+ * error_msg is a pointer that will be set to an internal buffer giving an
+ * error message upon failure (the return is FALSE). Untouched if
+ * function succeeds
+ * output_warning says whether to output any warning messages, or suppress
+ * them
+ * strict is true if anything out of the ordinary should cause this to
+ * fail instead of warn or be silent. For example, it requires
+ * exactly 2 digits following the \x (when there are no braces).
+ * 3 digits could be a mistake, so is forbidden in this mode.
+ * silence_non_portable is true if to suppress warnings about the code
+ * point returned being too large to fit on all platforms.
+ * UTF is true iff the string *s is encoded in UTF-8.
+ */
+ char* e;
+ STRLEN numbers_len;
+ I32 flags = PERL_SCAN_DISALLOW_PREFIX;
+
+ PERL_ARGS_ASSERT_GROK_BSLASH_X;
+
+ PERL_UNUSED_ARG(output_warning);
+
+ assert(**s == 'x');
+ (*s)++;
+
+ if (strict) {
+ flags |= PERL_SCAN_SILENT_ILLDIGIT;
+ }
+
+ if (**s != '{') {
+ STRLEN len = (strict) ? 3 : 2;
+
+ *uv = grok_hex(*s, &len, &flags, NULL);
+ *s += len;
+ if (strict && len != 2) {
+ if (len < 2) {
+ *s += (UTF) ? UTF8SKIP(*s) : 1;
+ *error_msg = "Non-hex character";
+ }
+ else {
+ *error_msg = "Use \\x{...} for more than two hex characters";
+ }
+ return FALSE;
+ }
+ return TRUE;
+ }
+
+ e = strchr(*s, '}');
+ if (!e) {
+ (*s)++; /* Move past the '{' */
+ while (isXDIGIT(**s)) { /* Position beyond the legal digits */
+ (*s)++;
+ }
+ /* XXX The corresponding message above for \o is just '\\o{'; other
+ * messages for other constructs include the '}', so are inconsistent.
+ */
+ *error_msg = "Missing right brace on \\x{}";
+ return FALSE;
+ }
+
+ (*s)++; /* Point to expected first digit (could be first byte of utf8
+ sequence if not a digit) */
+ numbers_len = e - *s;
+ if (numbers_len == 0) {
+ if (strict) {
+ (*s)++; /* Move past the } */
+ *error_msg = "Number with no digits";
+ return FALSE;
+ }
+ return TRUE;
+ }
+
+ flags |= PERL_SCAN_ALLOW_UNDERSCORES;
+ if (silence_non_portable) {
+ flags |= PERL_SCAN_SILENT_NON_PORTABLE;
+ }
+
+ *uv = grok_hex(*s, &numbers_len, &flags, NULL);
+ /* Note that if has non-hex, will ignore everything starting with that up
+ * to the '}' */
+
+ if (strict && numbers_len != (STRLEN) (e - *s)) {
+ *s += numbers_len;
+ *s += (UTF) ? UTF8SKIP(*s) : 1;
+ *error_msg = "Non-hex character";
+ return FALSE;
+ }
+
+ /* Return past the '}' */
+ *s = e + 1;
+
+ return TRUE;
+}
+
+STATIC char*
+S_form_short_octal_warning(pTHX_
+ const char * const s, /* Points to first non-octal */
+ const STRLEN len /* Length of octals string, so
+ (s-len) points to first
+ octal */
+) {
+ /* Return a character string consisting of a warning message for when a
+ * string constant in octal is weird, like "\078". */
+
+ const char * sans_leading_zeros = s - len;
+
+ PERL_ARGS_ASSERT_FORM_SHORT_OCTAL_WARNING;
+
+ assert(*s == '8' || *s == '9');
+
+ /* Remove the leading zeros, retaining one zero so won't be zero length */
+ while (*sans_leading_zeros == '0') sans_leading_zeros++;
+ if (sans_leading_zeros == s) {
+ sans_leading_zeros--;
+ }
+
+ return Perl_form(aTHX_
+ "'%.*s' resolved to '\\o{%.*s}%c'",
+ (int) (len + 2), s - len - 1,
+ (int) (s - sans_leading_zeros), sans_leading_zeros,
+ *s);
+}
+
/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/dquote_static.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/dump.c
===================================================================
--- trunk/contrib/perl/dump.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/dump.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -26,7 +26,6 @@
#define PERL_IN_DUMP_C
#include "perl.h"
#include "regcomp.h"
-#include "proto.h"
static const char* const svtypenames[SVt_LAST] = {
@@ -87,7 +86,6 @@
S_append_flags(aTHX_ (sv), (f), (flags), C_ARRAY_END(flags))
-#define Sequence PL_op_sequence
void
Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
@@ -282,7 +280,7 @@
isuni = 1;
for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
- const UV u= (isuni) ? utf8_to_uvchr((U8*)pv, &readsize) : (U8)*pv;
+ const UV u= (isuni) ? utf8_to_uvchr_buf((U8*)pv, (U8*) end, &readsize) : (U8)*pv;
const U8 c = (U8)u & 0xFF;
if ( ( u > 255 )
@@ -321,7 +319,7 @@
chsize = 1;
break;
default:
- if ( (pv < end) && isDIGIT((U8)*(pv+readsize)) )
+ if ( (pv+readsize < end) && isDIGIT((U8)*(pv+readsize)) )
chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
"%c%03o", esc, c);
else
@@ -458,7 +456,8 @@
sv_catpv(t, "VOID");
goto finish;
}
- else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
+ else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
+ /* detect data corruption under memory poisoning */
sv_catpv(t, "WILD");
goto finish;
}
@@ -562,7 +561,7 @@
Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
sv_uni_display(tmp, sv, 6 * SvCUR(sv),
UNI_DISPLAY_QQ));
- SvREFCNT_dec(tmp);
+ SvREFCNT_dec_NN(tmp);
}
}
else if (SvNOKp(sv)) {
@@ -582,7 +581,7 @@
finish:
while (unref--)
sv_catpv(t, ")");
- if (PL_tainting && SvTAINTED(sv))
+ if (TAINTING_get && SvTAINTED(sv))
sv_catpv(t, " [tainted]");
return SvPV_nolen(t);
}
@@ -614,10 +613,19 @@
Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
op_dump(pm->op_pmreplrootu.op_pmreplroot);
}
+ if (pm->op_code_list) {
+ if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
+ Perl_dump_indent(aTHX_ level, file, "CODE_LIST =\n");
+ do_op_dump(level, file, pm->op_code_list);
+ }
+ else
+ Perl_dump_indent(aTHX_ level, file, "CODE_LIST = 0x%"UVxf"\n",
+ PTR2UV(pm->op_code_list));
+ }
if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
SV * const tmpsv = pm_description(pm);
Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
- SvREFCNT_dec(tmpsv);
+ SvREFCNT_dec_NN(tmpsv);
}
Perl_dump_indent(aTHX_ level-1, file, "}\n");
@@ -631,6 +639,9 @@
{PMf_RETAINT, ",RETAINT"},
{PMf_EVAL, ",EVAL"},
{PMf_NONDESTRUCT, ",NONDESTRUCT"},
+ {PMf_HAS_CV, ",HAS_CV"},
+ {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"},
+ {PMf_IS_QR, ",IS_QR"}
};
static SV *
@@ -653,7 +664,7 @@
#endif
if (regex) {
- if (RX_EXTFLAGS(regex) & RXf_TAINTED)
+ if (RX_ISTAINTED(regex))
sv_catpv(desc, ",TAINTED");
if (RX_CHECK_SUBSTR(regex)) {
if (!(RX_EXTFLAGS(regex) & RXf_NOSCAN))
@@ -675,105 +686,11 @@
do_pmop_dump(0, Perl_debug_log, pm);
}
-/* An op sequencer. We visit the ops in the order they're to execute. */
+/* Return a unique integer to represent the address of op o.
+ * If it already exists in PL_op_sequence, just return it;
+ * otherwise add it.
+ * *** Note that this isn't thread-safe */
-STATIC void
-S_sequence(pTHX_ register const OP *o)
-{
- dVAR;
- const OP *oldop = NULL;
-
- if (!o)
- return;
-
-#ifdef PERL_MAD
- if (o->op_next == 0)
- return;
-#endif
-
- if (!Sequence)
- Sequence = newHV();
-
- for (; o; o = o->op_next) {
- STRLEN len;
- SV * const op = newSVuv(PTR2UV(o));
- const char * const key = SvPV_const(op, len);
-
- if (hv_exists(Sequence, key, len))
- break;
-
- switch (o->op_type) {
- case OP_STUB:
- if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
- (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
- break;
- }
- goto nothin;
- case OP_NULL:
-#ifdef PERL_MAD
- if (o == o->op_next)
- return;
-#endif
- if (oldop && o->op_next)
- continue;
- break;
- case OP_SCALAR:
- case OP_LINESEQ:
- case OP_SCOPE:
- nothin:
- if (oldop && o->op_next)
- continue;
- (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
- break;
-
- case OP_MAPWHILE:
- case OP_GREPWHILE:
- case OP_AND:
- case OP_OR:
- case OP_DOR:
- case OP_ANDASSIGN:
- case OP_ORASSIGN:
- case OP_DORASSIGN:
- case OP_COND_EXPR:
- case OP_RANGE:
- (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
- sequence_tail(cLOGOPo->op_other);
- break;
-
- case OP_ENTERLOOP:
- case OP_ENTERITER:
- (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
- sequence_tail(cLOOPo->op_redoop);
- sequence_tail(cLOOPo->op_nextop);
- sequence_tail(cLOOPo->op_lastop);
- break;
-
- case OP_SUBST:
- (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
- sequence_tail(cPMOPo->op_pmstashstartu.op_pmreplstart);
- break;
-
- case OP_QR:
- case OP_MATCH:
- case OP_HELEM:
- break;
-
- default:
- (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
- break;
- }
- oldop = o;
- }
-}
-
-static void
-S_sequence_tail(pTHX_ const OP *o)
-{
- while (o && (o->op_type == OP_NULL))
- o = o->op_next;
- sequence(o);
-}
-
STATIC UV
S_sequence_num(pTHX_ const OP *o)
{
@@ -782,11 +699,18 @@
**seq;
const char *key;
STRLEN len;
- if (!o) return 0;
+ if (!o)
+ return 0;
op = newSVuv(PTR2UV(o));
+ sv_2mortal(op);
key = SvPV_const(op, len);
- seq = hv_fetch(Sequence, key, len, 0);
- return seq ? SvUV(*seq): 0;
+ if (!PL_op_sequence)
+ PL_op_sequence = newHV();
+ seq = hv_fetch(PL_op_sequence, key, len, 0);
+ if (seq)
+ return SvUV(*seq);
+ (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
+ return PL_op_seq;
}
const struct flag_to_name op_flags_names[] = {
@@ -811,7 +735,6 @@
const struct flag_to_name op_entersub_names[] = {
{OPpENTERSUB_DB, ",DB"},
{OPpENTERSUB_HASTARG, ",HASTARG"},
- {OPpENTERSUB_NOMOD, ",NOMOD"},
{OPpENTERSUB_AMPER, ",AMPER"},
{OPpENTERSUB_NOPAREN, ",NOPAREN"},
{OPpENTERSUB_INARGS, ",INARGS"}
@@ -822,9 +745,8 @@
{OPpCONST_SHORTCIRCUIT, ",SHORTCIRCUIT"},
{OPpCONST_STRICT, ",STRICT"},
{OPpCONST_ENTERED, ",ENTERED"},
- {OPpCONST_ARYBASE, ",ARYBASE"},
- {OPpCONST_BARE, ",BARE"},
- {OPpCONST_WARNING, ",WARNING"}
+ {OPpCONST_FOLDED, ",FOLDED"},
+ {OPpCONST_BARE, ",BARE"}
};
const struct flag_to_name op_sort_names[] = {
@@ -849,14 +771,17 @@
{OPpHUSH_VMSISH, ",HUSH_VMSISH"}
};
+const struct flag_to_name op_sassign_names[] = {
+ {OPpASSIGN_BACKWARDS, ",BACKWARDS"},
+ {OPpASSIGN_CV_TO_GV, ",CV2GV"}
+};
+
#define OP_PRIVATE_ONCE(op, flag, name) \
const struct flag_to_name CAT2(op, _names)[] = { \
{(flag), (name)} \
}
-OP_PRIVATE_ONCE(op_aassign, OPpASSIGN_COMMON, ",COMMON");
OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED");
-OP_PRIVATE_ONCE(op_sassign, OPpASSIGN_BACKWARDS, ",BACKWARDS");
OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST");
OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE");
OP_PRIVATE_ONCE(op_rv2cv, OPpLVAL_INTRO, ",INTRO");
@@ -878,7 +803,6 @@
{OP_LEAVE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
{OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
{OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
- {OP_AASSIGN, C_ARRAY_LENGTH(op_aassign_names), op_aassign_names },
{OP_DIE, C_ARRAY_LENGTH(op_die_names), op_die_names },
{OP_DELETE, C_ARRAY_LENGTH(op_delete_names), op_delete_names },
{OP_EXISTS, C_ARRAY_LENGTH(op_exists_names), op_exists_names },
@@ -915,6 +839,131 @@
return FALSE;
}
+#define DUMP_OP_FLAGS(o,xml,level,file) \
+ if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) { \
+ SV * const tmpsv = newSVpvs(""); \
+ switch (o->op_flags & OPf_WANT) { \
+ case OPf_WANT_VOID: \
+ sv_catpv(tmpsv, ",VOID"); \
+ break; \
+ case OPf_WANT_SCALAR: \
+ sv_catpv(tmpsv, ",SCALAR"); \
+ break; \
+ case OPf_WANT_LIST: \
+ sv_catpv(tmpsv, ",LIST"); \
+ break; \
+ default: \
+ sv_catpv(tmpsv, ",UNKNOWN"); \
+ break; \
+ } \
+ append_flags(tmpsv, o->op_flags, op_flags_names); \
+ if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED"); \
+ if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE"); \
+ if (o->op_static) sv_catpvs(tmpsv, ",STATIC"); \
+ if (!xml) \
+ Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", \
+ SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");\
+ else \
+ PerlIO_printf(file, " flags=\"%s\"", \
+ SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); \
+ SvREFCNT_dec_NN(tmpsv); \
+ }
+
+#if !defined(PERL_MAD)
+# define xmldump_attr1(level, file, pat, arg)
+#else
+# define xmldump_attr1(level, file, pat, arg) \
+ S_xmldump_attr(aTHX_ level, file, pat, arg)
+#endif
+
+#define DUMP_OP_PRIVATE(o,xml,level,file) \
+ if (o->op_private) { \
+ U32 optype = o->op_type; \
+ U32 oppriv = o->op_private; \
+ SV * const tmpsv = newSVpvs(""); \
+ if (PL_opargs[optype] & OA_TARGLEX) { \
+ if (oppriv & OPpTARGET_MY) \
+ sv_catpv(tmpsv, ",TARGET_MY"); \
+ } \
+ else if (optype == OP_ENTERSUB || \
+ optype == OP_RV2SV || \
+ optype == OP_GVSV || \
+ optype == OP_RV2AV || \
+ optype == OP_RV2HV || \
+ optype == OP_RV2GV || \
+ optype == OP_AELEM || \
+ optype == OP_HELEM ) \
+ { \
+ if (optype == OP_ENTERSUB) { \
+ append_flags(tmpsv, oppriv, op_entersub_names); \
+ } \
+ else { \
+ switch (oppriv & OPpDEREF) { \
+ case OPpDEREF_SV: \
+ sv_catpv(tmpsv, ",SV"); \
+ break; \
+ case OPpDEREF_AV: \
+ sv_catpv(tmpsv, ",AV"); \
+ break; \
+ case OPpDEREF_HV: \
+ sv_catpv(tmpsv, ",HV"); \
+ break; \
+ } \
+ if (oppriv & OPpMAYBE_LVSUB) \
+ sv_catpv(tmpsv, ",MAYBE_LVSUB"); \
+ } \
+ if (optype == OP_AELEM || optype == OP_HELEM) { \
+ if (oppriv & OPpLVAL_DEFER) \
+ sv_catpv(tmpsv, ",LVAL_DEFER"); \
+ } \
+ else if (optype == OP_RV2HV || optype == OP_PADHV) { \
+ if (oppriv & OPpMAYBE_TRUEBOOL) \
+ sv_catpvs(tmpsv, ",OPpMAYBE_TRUEBOOL"); \
+ if (oppriv & OPpTRUEBOOL) \
+ sv_catpvs(tmpsv, ",OPpTRUEBOOL"); \
+ } \
+ else { \
+ if (oppriv & HINT_STRICT_REFS) \
+ sv_catpv(tmpsv, ",STRICT_REFS"); \
+ if (oppriv & OPpOUR_INTRO) \
+ sv_catpv(tmpsv, ",OUR_INTRO"); \
+ } \
+ } \
+ else if (S_op_private_to_names(aTHX_ tmpsv, optype, oppriv)) { \
+ } \
+ else if (OP_IS_FILETEST(o->op_type)) { \
+ if (oppriv & OPpFT_ACCESS) \
+ sv_catpv(tmpsv, ",FT_ACCESS"); \
+ if (oppriv & OPpFT_STACKED) \
+ sv_catpv(tmpsv, ",FT_STACKED"); \
+ if (oppriv & OPpFT_STACKING) \
+ sv_catpv(tmpsv, ",FT_STACKING"); \
+ if (oppriv & OPpFT_AFTER_t) \
+ sv_catpv(tmpsv, ",AFTER_t"); \
+ } \
+ else if (o->op_type == OP_AASSIGN) { \
+ if (oppriv & OPpASSIGN_COMMON) \
+ sv_catpvs(tmpsv, ",COMMON"); \
+ if (oppriv & OPpMAYBE_LVSUB) \
+ sv_catpvs(tmpsv, ",MAYBE_LVSUB"); \
+ } \
+ if (o->op_flags & OPf_MOD && oppriv & OPpLVAL_INTRO) \
+ sv_catpv(tmpsv, ",INTRO"); \
+ if (o->op_type == OP_PADRANGE) \
+ Perl_sv_catpvf(aTHX_ tmpsv, ",COUNT=%"UVuf, \
+ (UV)(oppriv & OPpPADRANGE_COUNTMASK)); \
+ if (SvCUR(tmpsv)) { \
+ if (xml) \
+ xmldump_attr1(level+1, file, "private=\"%s\"", SvPVX(tmpsv)+1); \
+ else \
+ Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1); \
+ } else if (!xml) \
+ Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n", \
+ (UV)oppriv); \
+ SvREFCNT_dec_NN(tmpsv); \
+ }
+
+
void
Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
{
@@ -924,7 +973,6 @@
PERL_ARGS_ASSERT_DO_OP_DUMP;
- sequence(o);
Perl_dump_indent(aTHX_ level, file, "{\n");
level++;
seq = sequence_num(o);
@@ -931,15 +979,16 @@
if (seq)
PerlIO_printf(file, "%-4"UVuf, seq);
else
- PerlIO_printf(file, " ");
+ PerlIO_printf(file, "????");
PerlIO_printf(file,
"%*sTYPE = %s ===> ",
(int)(PL_dumpindent*level-4), "", OP_NAME(o));
if (o->op_next)
- PerlIO_printf(file, seq ? "%"UVuf"\n" : "(%"UVuf")\n",
+ PerlIO_printf(file,
+ o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
sequence_num(o->op_next));
else
- PerlIO_printf(file, "DONE\n");
+ PerlIO_printf(file, "NULL\n");
if (o->op_targ) {
if (optype == OP_NULL) {
Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
@@ -961,96 +1010,10 @@
#ifdef DUMPADDR
Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
#endif
- if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
- SV * const tmpsv = newSVpvs("");
- switch (o->op_flags & OPf_WANT) {
- case OPf_WANT_VOID:
- sv_catpv(tmpsv, ",VOID");
- break;
- case OPf_WANT_SCALAR:
- sv_catpv(tmpsv, ",SCALAR");
- break;
- case OPf_WANT_LIST:
- sv_catpv(tmpsv, ",LIST");
- break;
- default:
- sv_catpv(tmpsv, ",UNKNOWN");
- break;
- }
- append_flags(tmpsv, o->op_flags, op_flags_names);
- if (o->op_latefree)
- sv_catpv(tmpsv, ",LATEFREE");
- if (o->op_latefreed)
- sv_catpv(tmpsv, ",LATEFREED");
- if (o->op_attached)
- sv_catpv(tmpsv, ",ATTACHED");
- Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
- SvREFCNT_dec(tmpsv);
- }
- if (o->op_private) {
- SV * const tmpsv = newSVpvs("");
- if (PL_opargs[optype] & OA_TARGLEX) {
- if (o->op_private & OPpTARGET_MY)
- sv_catpv(tmpsv, ",TARGET_MY");
- }
- else if (optype == OP_ENTERSUB ||
- optype == OP_RV2SV ||
- optype == OP_GVSV ||
- optype == OP_RV2AV ||
- optype == OP_RV2HV ||
- optype == OP_RV2GV ||
- optype == OP_AELEM ||
- optype == OP_HELEM )
- {
- if (optype == OP_ENTERSUB) {
- append_flags(tmpsv, o->op_private, op_entersub_names);
- }
- else {
- switch (o->op_private & OPpDEREF) {
- case OPpDEREF_SV:
- sv_catpv(tmpsv, ",SV");
- break;
- case OPpDEREF_AV:
- sv_catpv(tmpsv, ",AV");
- break;
- case OPpDEREF_HV:
- sv_catpv(tmpsv, ",HV");
- break;
- }
- if (o->op_private & OPpMAYBE_LVSUB)
- sv_catpv(tmpsv, ",MAYBE_LVSUB");
- }
- if ((optype==OP_RV2SV || optype==OP_RV2AV || optype==OP_RV2HV)
- && (o->op_private & OPpDEREFed))
- sv_catpv(tmpsv, ",DEREFed");
+ DUMP_OP_FLAGS(o,0,level,file);
+ DUMP_OP_PRIVATE(o,0,level,file);
- if (optype == OP_AELEM || optype == OP_HELEM) {
- if (o->op_private & OPpLVAL_DEFER)
- sv_catpv(tmpsv, ",LVAL_DEFER");
- }
- else {
- if (o->op_private & HINT_STRICT_REFS)
- sv_catpv(tmpsv, ",STRICT_REFS");
- if (o->op_private & OPpOUR_INTRO)
- sv_catpv(tmpsv, ",OUR_INTRO");
- }
- }
- else if (S_op_private_to_names(aTHX_ tmpsv, optype, o->op_private)) {
- }
- else if (PL_check[optype] != Perl_ck_ftst) {
- if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
- sv_catpv(tmpsv, ",FT_ACCESS");
- if (o->op_private & OPpFT_STACKED)
- sv_catpv(tmpsv, ",FT_STACKED");
- }
- if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
- sv_catpv(tmpsv, ",INTRO");
- if (SvCUR(tmpsv))
- Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
- SvREFCNT_dec(tmpsv);
- }
-
#ifdef PERL_MAD
if (PL_madskills && o->op_madprop) {
SV * const tmpsv = newSVpvs("");
@@ -1090,7 +1053,7 @@
level--;
Perl_dump_indent(aTHX_ level, file, "}\n");
- SvREFCNT_dec(tmpsv);
+ SvREFCNT_dec_NN(tmpsv);
}
#endif
@@ -1233,49 +1196,7 @@
*/
static const struct { const char type; const char *name; } magic_names[] = {
- { PERL_MAGIC_sv, "sv(\\0)" },
- { PERL_MAGIC_arylen, "arylen(#)" },
- { PERL_MAGIC_rhash, "rhash(%)" },
- { PERL_MAGIC_pos, "pos(.)" },
- { PERL_MAGIC_symtab, "symtab(:)" },
- { PERL_MAGIC_backref, "backref(<)" },
- { PERL_MAGIC_arylen_p, "arylen_p(@)" },
- { PERL_MAGIC_overload, "overload(A)" },
- { PERL_MAGIC_bm, "bm(B)" },
- { PERL_MAGIC_regdata, "regdata(D)" },
- { PERL_MAGIC_env, "env(E)" },
- { PERL_MAGIC_hints, "hints(H)" },
- { PERL_MAGIC_isa, "isa(I)" },
- { PERL_MAGIC_dbfile, "dbfile(L)" },
- { PERL_MAGIC_shared, "shared(N)" },
- { PERL_MAGIC_tied, "tied(P)" },
- { PERL_MAGIC_sig, "sig(S)" },
- { PERL_MAGIC_uvar, "uvar(U)" },
- { PERL_MAGIC_checkcall, "checkcall(])" },
- { PERL_MAGIC_overload_elem, "overload_elem(a)" },
- { PERL_MAGIC_overload_table, "overload_table(c)" },
- { PERL_MAGIC_regdatum, "regdatum(d)" },
- { PERL_MAGIC_envelem, "envelem(e)" },
- { PERL_MAGIC_fm, "fm(f)" },
- { PERL_MAGIC_regex_global, "regex_global(g)" },
- { PERL_MAGIC_hintselem, "hintselem(h)" },
- { PERL_MAGIC_isaelem, "isaelem(i)" },
- { PERL_MAGIC_nkeys, "nkeys(k)" },
- { PERL_MAGIC_dbline, "dbline(l)" },
- { PERL_MAGIC_shared_scalar, "shared_scalar(n)" },
- { PERL_MAGIC_collxfrm, "collxfrm(o)" },
- { PERL_MAGIC_tiedelem, "tiedelem(p)" },
- { PERL_MAGIC_tiedscalar, "tiedscalar(q)" },
- { PERL_MAGIC_qr, "qr(r)" },
- { PERL_MAGIC_sigelem, "sigelem(s)" },
- { PERL_MAGIC_taint, "taint(t)" },
- { PERL_MAGIC_uvar_elem, "uvar_elem(u)" },
- { PERL_MAGIC_vec, "vec(v)" },
- { PERL_MAGIC_vstring, "vstring(V)" },
- { PERL_MAGIC_utf8, "utf8(w)" },
- { PERL_MAGIC_substr, "substr(x)" },
- { PERL_MAGIC_defelem, "defelem(y)" },
- { PERL_MAGIC_ext, "ext(~)" },
+#include "mg_names.c"
/* this null string terminates the list */
{ 0, NULL },
};
@@ -1290,40 +1211,11 @@
" MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
if (mg->mg_virtual) {
const MGVTBL * const v = mg->mg_virtual;
- const char *s;
- if (v == &PL_vtbl_sv) s = "sv";
- else if (v == &PL_vtbl_env) s = "env";
- else if (v == &PL_vtbl_envelem) s = "envelem";
- else if (v == &PL_vtbl_sig) s = "sig";
- else if (v == &PL_vtbl_sigelem) s = "sigelem";
- else if (v == &PL_vtbl_pack) s = "pack";
- else if (v == &PL_vtbl_packelem) s = "packelem";
- else if (v == &PL_vtbl_dbline) s = "dbline";
- else if (v == &PL_vtbl_isa) s = "isa";
- else if (v == &PL_vtbl_arylen) s = "arylen";
- else if (v == &PL_vtbl_mglob) s = "mglob";
- else if (v == &PL_vtbl_nkeys) s = "nkeys";
- else if (v == &PL_vtbl_taint) s = "taint";
- else if (v == &PL_vtbl_substr) s = "substr";
- else if (v == &PL_vtbl_vec) s = "vec";
- else if (v == &PL_vtbl_pos) s = "pos";
- else if (v == &PL_vtbl_bm) s = "bm";
- else if (v == &PL_vtbl_fm) s = "fm";
- else if (v == &PL_vtbl_uvar) s = "uvar";
- else if (v == &PL_vtbl_defelem) s = "defelem";
-#ifdef USE_LOCALE_COLLATE
- else if (v == &PL_vtbl_collxfrm) s = "collxfrm";
-#endif
- else if (v == &PL_vtbl_amagic) s = "amagic";
- else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
- else if (v == &PL_vtbl_backref) s = "backref";
- else if (v == &PL_vtbl_utf8) s = "utf8";
- else if (v == &PL_vtbl_arylen_p) s = "arylen_p";
- else if (v == &PL_vtbl_hintselem) s = "hintselem";
- else if (v == &PL_vtbl_hints) s = "hints";
- else s = NULL;
- if (s)
- Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s);
+ if (v >= PL_magic_vtables
+ && v < PL_magic_vtables + magic_vtable_max) {
+ const U32 i = v - PL_magic_vtables;
+ Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
+ }
else
Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
}
@@ -1396,7 +1288,7 @@
if (mg->mg_type != PERL_MAGIC_utf8) {
SV * const sv = newSVpvs("");
PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
- SvREFCNT_dec(sv);
+ SvREFCNT_dec_NN(sv);
}
}
else if (mg->mg_len == HEf_SVKEY) {
@@ -1500,6 +1392,7 @@
{SVf_OOK, "OOK,"},
{SVf_FAKE, "FAKE,"},
{SVf_READONLY, "READONLY,"},
+ {SVf_IsCOW, "IsCOW,"},
{SVf_BREAK, "BREAK,"},
{SVf_AMAGIC, "OVERLOAD,"},
{SVp_IOK, "pIOK,"},
@@ -1518,6 +1411,10 @@
{CVf_METHOD, "METHOD,"},
{CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
{CVf_CVGV_RC, "CVGV_RC,"},
+ {CVf_DYNFILE, "DYNFILE,"},
+ {CVf_AUTOLOAD, "AUTOLOAD,"},
+ {CVf_HASEVAL, "HASEVAL"},
+ {CVf_SLABBED, "SLABBED,"},
{CVf_ISXSUB, "ISXSUB,"}
};
@@ -1525,7 +1422,6 @@
{SVphv_SHAREKEYS, "SHAREKEYS,"},
{SVphv_LAZYDEL, "LAZYDEL,"},
{SVphv_HASKFLAGS, "HASKFLAGS,"},
- {SVphv_REHASH, "REHASH,"},
{SVphv_CLONEABLE, "CLONEABLE,"}
};
@@ -1555,7 +1451,7 @@
{RXf_ANCH_GPOS, "ANCH_GPOS,"},
{RXf_GPOS_SEEN, "GPOS_SEEN,"},
{RXf_GPOS_FLOAT, "GPOS_FLOAT,"},
- {RXf_LOOKBEHIND_SEEN, "LOOKBEHIND_SEEN,"},
+ {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
{RXf_EVAL_SEEN, "EVAL_SEEN,"},
{RXf_CANY_SEEN, "CANY_SEEN,"},
{RXf_NOSCAN, "NOSCAN,"},
@@ -1601,11 +1497,14 @@
(int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
(int)(PL_dumpindent*level), "");
- if (!(flags & SVpad_NAME && (type == SVt_PVMG || type == SVt_PVNV))) {
- if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
+ if (!((flags & SVpad_NAME) == SVpad_NAME
+ && (type == SVt_PVMG || type == SVt_PVNV))) {
+ if ((flags & SVs_PADMY) && (flags & SVs_PADSTALE))
+ sv_catpv(d, "PADSTALE,");
}
- if (!(flags & SVpad_NAME && type == SVt_PVMG)) {
- if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
+ if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
+ if (!(flags & SVs_PADMY) && (flags & SVs_PADTMP))
+ sv_catpv(d, "PADTMP,");
if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
}
append_flags(d, flags, first_sv_flags_names);
@@ -1646,8 +1545,6 @@
sv_catpv(d, " ),");
}
}
- if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
- if (SvVALID(sv)) sv_catpv(d, "VALID,");
/* FALL THROUGH */
default:
evaled_or_uv:
@@ -1655,6 +1552,8 @@
if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
break;
case SVt_PVMG:
+ if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
+ if (SvVALID(sv)) sv_catpv(d, "VALID,");
if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
/* FALL THROUGH */
@@ -1696,12 +1595,12 @@
PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
if (type == SVt_NULL) {
- SvREFCNT_dec(d);
+ SvREFCNT_dec_NN(d);
return;
}
} else {
PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
- SvREFCNT_dec(d);
+ SvREFCNT_dec_NN(d);
return;
}
@@ -1708,8 +1607,8 @@
/* Dump general SV fields */
if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
- && type != SVt_PVCV && !isGV_with_GP(sv) && type != SVt_PVFM
- && type != SVt_PVIO && type != SVt_REGEXP)
+ && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
+ && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
|| (type == SVt_IV && !SvROK(sv))) {
if (SvIsUV(sv)
#ifdef PERL_OLD_COPY_ON_WRITE
@@ -1728,7 +1627,8 @@
PerlIO_putc(file, '\n');
}
- if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) {
+ if ((type == SVt_PVNV || type == SVt_PVMG)
+ && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
(UV) COP_SEQ_RANGE_LOW(sv));
Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
@@ -1754,12 +1654,15 @@
}
if (type < SVt_PV) {
- SvREFCNT_dec(d);
+ SvREFCNT_dec_NN(d);
return;
}
- if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
- if (SvPVX_const(sv)) {
+ if (type <= SVt_PVLV && !isGV_with_GP(sv)) {
+ const bool re = isREGEXP(sv);
+ const char * const ptr =
+ re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
+ if (ptr) {
STRLEN delta;
if (SvOOK(sv)) {
SvOOK_offset(sv, delta);
@@ -1768,18 +1671,27 @@
} else {
delta = 0;
}
- Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
+ Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(ptr));
if (SvOOK(sv)) {
PerlIO_printf(file, "( %s . ) ",
- pv_display(d, SvPVX_const(sv) - delta, delta, 0,
+ pv_display(d, ptr - delta, delta, 0,
pvlim));
}
- PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
+ PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
+ re ? 0 : SvLEN(sv),
+ pvlim));
if (SvUTF8(sv)) /* the 6? \x{....} */
PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
PerlIO_printf(file, "\n");
Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
- Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
+ if (!re)
+ Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n",
+ (IV)SvLEN(sv));
+#ifdef PERL_NEW_COPY_ON_WRITE
+ if (SvIsCOW(sv) && SvLEN(sv))
+ Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
+ CowREFCNT(sv));
+#endif
}
else
Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
@@ -1796,6 +1708,12 @@
}
if (SvSTASH(sv))
do_hv_dump(level, file, " STASH", SvSTASH(sv));
+
+ if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
+ Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
+ Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
+ Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
+ }
}
/* Dump type-specific SV fields */
@@ -1830,13 +1748,13 @@
break;
case SVt_PVHV:
Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
- if (HvARRAY(sv) && HvKEYS(sv)) {
+ if (HvARRAY(sv) && HvUSEDKEYS(sv)) {
/* Show distribution of HEs in the ARRAY */
int freq[200];
#define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
int i;
int max = 0;
- U32 pow2 = 2, keys = HvKEYS(sv);
+ U32 pow2 = 2, keys = HvUSEDKEYS(sv);
NV theoret, sum = 0;
PerlIO_printf(file, " (");
@@ -1878,17 +1796,26 @@
}
while ((keys = keys >> 1))
pow2 = pow2 << 1;
- theoret = HvKEYS(sv);
+ theoret = HvUSEDKEYS(sv);
theoret += theoret * (theoret-1)/pow2;
PerlIO_putc(file, '\n');
Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
}
PerlIO_putc(file, '\n');
- Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
+ Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvUSEDKEYS(sv));
Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
- Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
- Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
+ if (SvOOK(sv)) {
+ Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
+ Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+ Perl_dump_indent(aTHX_ level, file, " RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
+ if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
+ PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
+ }
+#endif
+ PerlIO_putc(file, '\n');
+ }
{
MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
if (mg && mg->mg_obj) {
@@ -1982,42 +1909,51 @@
}
}
if (nest < maxnest) {
- if (HvEITER_get(sv)) /* preserve iterator */
- Perl_dump_indent(aTHX_ level, file,
- " (*** Active iterator; skipping element dump ***)\n");
- else {
- HE *he;
- HV * const hv = MUTABLE_HV(sv);
+ HV * const hv = MUTABLE_HV(sv);
+ STRLEN i;
+ HE *he;
+
+ if (HvARRAY(hv)) {
int count = maxnest - nest;
+ for (i=0; i <= HvMAX(hv); i++) {
+ for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
+ U32 hash;
+ SV * keysv;
+ const char * keypv;
+ SV * elt;
+ STRLEN len;
- hv_iterinit(hv);
- while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
- && count--) {
- STRLEN len;
- const U32 hash = HeHASH(he);
- SV * const keysv = hv_iterkeysv(he);
- const char * const keypv = SvPV_const(keysv, len);
- SV * const elt = hv_iterval(hv, he);
+ if (count-- <= 0) goto DONEHV;
- Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
- if (SvUTF8(keysv))
- PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
- if (HeKREHASH(he))
- PerlIO_printf(file, "[REHASH] ");
- PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
- do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
+ hash = HeHASH(he);
+ keysv = hv_iterkeysv(he);
+ keypv = SvPV_const(keysv, len);
+ elt = HeVAL(he);
+
+ Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
+ if (SvUTF8(keysv))
+ PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
+ if (HvEITER_get(hv) == he)
+ PerlIO_printf(file, "[CURRENT] ");
+ PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
+ do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
+ }
}
- hv_iterinit(hv); /* Return to status quo */
+ DONEHV:;
}
}
break;
case SVt_PVCV:
+ if (CvAUTOLOAD(sv)) {
+ STRLEN len;
+ const char *const name = SvPV_const(sv, len);
+ Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%.*s\"\n",
+ (int) len, name);
+ }
if (SvPOK(sv)) {
- STRLEN len;
- const char *const proto = SvPV_const(sv, len);
Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
- (int) len, proto);
+ (int) CvPROTOLEN(sv), CvPROTO(sv));
}
/* FALL THROUGH */
case SVt_PVFM:
@@ -2050,14 +1986,14 @@
(IV)CvXSUBANY(sv).any_i32);
}
}
- do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
+ if (CvNAMED(sv))
+ Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
+ HEK_KEY(CvNAME_HEK((CV *)sv)));
+ else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
- if (type == SVt_PVCV)
- Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
+ 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));
- if (type == SVt_PVFM)
- Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(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);
@@ -2083,16 +2019,12 @@
Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
+ Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
dumpops, pvlim);
}
- if (SvVALID(sv)) {
- Perl_dump_indent(aTHX_ level, file, " FLAGS = %u\n", (U8)BmFLAGS(sv));
- Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
- Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
- Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
- }
+ if (isREGEXP(sv)) goto dumpregexp;
if (!isGV_with_GP(sv))
break;
Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
@@ -2161,17 +2093,26 @@
Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
break;
case SVt_REGEXP:
+ dumpregexp:
{
- struct regexp * const r = (struct regexp *)SvANY(sv);
- flags = RX_EXTFLAGS((REGEXP*)sv);
- sv_setpv(d,"");
- append_flags(d, flags, regexp_flags_names);
- if (*(SvEND(d) - 1) == ',') {
- SvCUR_set(d, SvCUR(d) - 1);
- SvPVX(d)[SvCUR(d)] = '\0';
- }
+ struct regexp * const r = ReANY((REGEXP*)sv);
+#define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags) STMT_START { \
+ sv_setpv(d,""); \
+ append_flags(d, flags, regexp_flags_names); \
+ if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
+ SvCUR_set(d, SvCUR(d) - 1); \
+ SvPVX(d)[SvCUR(d)] = '\0'; \
+ } \
+} STMT_END
+ SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags);
+ Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%"UVxf" (%s)\n",
+ (UV)(r->compflags), SvPVX_const(d));
+
+ SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags);
Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
- (UV)flags, SvPVX_const(d));
+ (UV)(r->extflags), SvPVX_const(d));
+#undef SV_SET_STRINGIFY_REGEXP_FLAGS
+
Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
(UV)(r->intflags));
Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
@@ -2188,10 +2129,12 @@
(UV)(r->gofs));
Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
(UV)(r->pre_prefix));
- Perl_dump_indent(aTHX_ level, file, " SEEN_EVALS = %"UVuf"\n",
- (UV)(r->seen_evals));
Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
(IV)(r->sublen));
+ Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %"IVdf"\n",
+ (IV)(r->suboffset));
+ Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %"IVdf"\n",
+ (IV)(r->subcoffset));
if (r->subbeg)
Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
PTR2UV(r->subbeg),
@@ -2210,7 +2153,9 @@
PTR2UV(r->pprivate));
Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
PTR2UV(r->offs));
-#ifdef PERL_OLD_COPY_ON_WRITE
+ Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n",
+ PTR2UV(r->qr_anoncv));
+#ifdef PERL_ANY_COW
Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
PTR2UV(r->saved_copy));
#endif
@@ -2217,7 +2162,7 @@
}
break;
}
- SvREFCNT_dec(d);
+ SvREFCNT_dec_NN(d);
}
void
@@ -2263,8 +2208,11 @@
if (DEBUG_t_TEST_) debop(PL_op);
if (DEBUG_P_TEST_) debprof(PL_op);
}
+
+ OP_ENTRY_PROBE(OP_NAME(PL_op));
} while ((PL_op = PL_op->op_ppaddr(aTHX)));
DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
+ PERL_ASYNC_CHECK();
TAINT_NOT;
return 0;
@@ -2304,30 +2252,50 @@
#endif
gv_fullname3(sv, cGVOPo_gv, NULL);
PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
- SvREFCNT_dec(sv);
+ SvREFCNT_dec_NN(sv);
}
else
PerlIO_printf(Perl_debug_log, "(NULL)");
break;
+
+ {
+ int count;
+
case OP_PADSV:
case OP_PADAV:
case OP_PADHV:
- {
+ count = 1;
+ goto dump_padop;
+ case OP_PADRANGE:
+ count = o->op_private & OPpPADRANGE_COUNTMASK;
+ dump_padop:
/* print the lexical's name */
- CV * const cv = deb_curcv(cxstack_ix);
- SV *sv;
- if (cv) {
- AV * const padlist = CvPADLIST(cv);
- AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
- sv = *av_fetch(comppad, o->op_targ, FALSE);
- } else
- sv = NULL;
- if (sv)
- PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
- else
- PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
- }
+ {
+ CV * const cv = deb_curcv(cxstack_ix);
+ SV *sv;
+ PAD * comppad = NULL;
+ int i;
+
+ if (cv) {
+ PADLIST * const padlist = CvPADLIST(cv);
+ comppad = *PadlistARRAY(padlist);
+ }
+ PerlIO_printf(Perl_debug_log, "(");
+ for (i = 0; i < count; i++) {
+ if (comppad &&
+ (sv = *av_fetch(comppad, o->op_targ + i, FALSE)))
+ PerlIO_printf(Perl_debug_log, "%s", SvPV_nolen_const(sv));
+ else
+ PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
+ (UV)o->op_targ+i);
+ if (i < count-1)
+ PerlIO_printf(Perl_debug_log, ",");
+ }
+ PerlIO_printf(Perl_debug_log, ")");
+ }
break;
+ }
+
default:
break;
}
@@ -2343,7 +2311,7 @@
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
return cx->blk_sub.cv;
else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
- return PL_compcv;
+ return cx->blk_eval.cv;
else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
return PL_main_cv;
else if (ix <= 0)
@@ -2567,7 +2535,7 @@
retry:
while (pv < e) {
if (utf8) {
- c = utf8_to_uvchr((U8*)pv, &cl);
+ c = utf8_to_uvchr_buf((U8*)pv, (U8*)e, &cl);
if (cl == 0) {
SvCUR(dsv) = dsvcur;
pv = start;
@@ -2693,7 +2661,7 @@
sv_catpv(t, "VOID=\"\"");
goto finish;
}
- else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
+ else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
sv_catpv(t, "WILD=\"\"");
goto finish;
}
@@ -2860,7 +2828,7 @@
sv_catxmlsv(tmpsv, MUTABLE_SV(r));
Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
SvPVX(tmpsv));
- SvREFCNT_dec(tmpsv);
+ SvREFCNT_dec_NN(tmpsv);
Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
(pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
}
@@ -2869,7 +2837,7 @@
if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
SV * const tmpsv = pm_description(pm);
Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
- SvREFCNT_dec(tmpsv);
+ SvREFCNT_dec_NN(tmpsv);
}
level--;
@@ -2895,12 +2863,12 @@
{
UV seq;
int contents = 0;
+ const OPCODE optype = o->op_type;
PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
if (!o)
return;
- sequence(o);
seq = sequence_num(o);
Perl_xmldump_indent(aTHX_ level, file,
"<op_%s seq=\"%"UVuf" -> ",
@@ -2914,7 +2882,7 @@
PerlIO_printf(file, "DONE\"");
if (o->op_targ) {
- if (o->op_type == OP_NULL)
+ if (optype == OP_NULL)
{
PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
if (o->op_targ == OP_NEXTSTATE)
@@ -2936,205 +2904,11 @@
#ifdef DUMPADDR
PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
#endif
- if (o->op_flags) {
- SV * const tmpsv = newSVpvs("");
- switch (o->op_flags & OPf_WANT) {
- case OPf_WANT_VOID:
- sv_catpv(tmpsv, ",VOID");
- break;
- case OPf_WANT_SCALAR:
- sv_catpv(tmpsv, ",SCALAR");
- break;
- case OPf_WANT_LIST:
- sv_catpv(tmpsv, ",LIST");
- break;
- default:
- sv_catpv(tmpsv, ",UNKNOWN");
- break;
- }
- if (o->op_flags & OPf_KIDS)
- sv_catpv(tmpsv, ",KIDS");
- if (o->op_flags & OPf_PARENS)
- sv_catpv(tmpsv, ",PARENS");
- if (o->op_flags & OPf_STACKED)
- sv_catpv(tmpsv, ",STACKED");
- if (o->op_flags & OPf_REF)
- sv_catpv(tmpsv, ",REF");
- if (o->op_flags & OPf_MOD)
- sv_catpv(tmpsv, ",MOD");
- if (o->op_flags & OPf_SPECIAL)
- sv_catpv(tmpsv, ",SPECIAL");
- PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
- SvREFCNT_dec(tmpsv);
- }
- if (o->op_private) {
- SV * const tmpsv = newSVpvs("");
- if (PL_opargs[o->op_type] & OA_TARGLEX) {
- if (o->op_private & OPpTARGET_MY)
- sv_catpv(tmpsv, ",TARGET_MY");
- }
- else if (o->op_type == OP_LEAVESUB ||
- o->op_type == OP_LEAVE ||
- o->op_type == OP_LEAVESUBLV ||
- o->op_type == OP_LEAVEWRITE) {
- if (o->op_private & OPpREFCOUNTED)
- sv_catpv(tmpsv, ",REFCOUNTED");
- }
- else if (o->op_type == OP_AASSIGN) {
- if (o->op_private & OPpASSIGN_COMMON)
- sv_catpv(tmpsv, ",COMMON");
- }
- else if (o->op_type == OP_SASSIGN) {
- if (o->op_private & OPpASSIGN_BACKWARDS)
- sv_catpv(tmpsv, ",BACKWARDS");
- }
- else if (o->op_type == OP_TRANS) {
- if (o->op_private & OPpTRANS_SQUASH)
- sv_catpv(tmpsv, ",SQUASH");
- if (o->op_private & OPpTRANS_DELETE)
- sv_catpv(tmpsv, ",DELETE");
- if (o->op_private & OPpTRANS_COMPLEMENT)
- sv_catpv(tmpsv, ",COMPLEMENT");
- if (o->op_private & OPpTRANS_IDENTICAL)
- sv_catpv(tmpsv, ",IDENTICAL");
- if (o->op_private & OPpTRANS_GROWS)
- sv_catpv(tmpsv, ",GROWS");
- }
- else if (o->op_type == OP_REPEAT) {
- if (o->op_private & OPpREPEAT_DOLIST)
- sv_catpv(tmpsv, ",DOLIST");
- }
- else if (o->op_type == OP_ENTERSUB ||
- o->op_type == OP_RV2SV ||
- o->op_type == OP_GVSV ||
- o->op_type == OP_RV2AV ||
- o->op_type == OP_RV2HV ||
- o->op_type == OP_RV2GV ||
- o->op_type == OP_AELEM ||
- o->op_type == OP_HELEM )
- {
- if (o->op_type == OP_ENTERSUB) {
- if (o->op_private & OPpENTERSUB_AMPER)
- sv_catpv(tmpsv, ",AMPER");
- if (o->op_private & OPpENTERSUB_DB)
- sv_catpv(tmpsv, ",DB");
- if (o->op_private & OPpENTERSUB_HASTARG)
- sv_catpv(tmpsv, ",HASTARG");
- if (o->op_private & OPpENTERSUB_NOPAREN)
- sv_catpv(tmpsv, ",NOPAREN");
- if (o->op_private & OPpENTERSUB_INARGS)
- sv_catpv(tmpsv, ",INARGS");
- if (o->op_private & OPpENTERSUB_NOMOD)
- sv_catpv(tmpsv, ",NOMOD");
- }
- else {
- switch (o->op_private & OPpDEREF) {
- case OPpDEREF_SV:
- sv_catpv(tmpsv, ",SV");
- break;
- case OPpDEREF_AV:
- sv_catpv(tmpsv, ",AV");
- break;
- case OPpDEREF_HV:
- sv_catpv(tmpsv, ",HV");
- break;
- }
- if (o->op_private & OPpMAYBE_LVSUB)
- sv_catpv(tmpsv, ",MAYBE_LVSUB");
- }
- if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
- if (o->op_private & OPpLVAL_DEFER)
- sv_catpv(tmpsv, ",LVAL_DEFER");
- }
- else {
- if (o->op_private & HINT_STRICT_REFS)
- sv_catpv(tmpsv, ",STRICT_REFS");
- if (o->op_private & OPpOUR_INTRO)
- sv_catpv(tmpsv, ",OUR_INTRO");
- }
- }
- else if (o->op_type == OP_CONST) {
- if (o->op_private & OPpCONST_BARE)
- sv_catpv(tmpsv, ",BARE");
- if (o->op_private & OPpCONST_STRICT)
- sv_catpv(tmpsv, ",STRICT");
- if (o->op_private & OPpCONST_ARYBASE)
- sv_catpv(tmpsv, ",ARYBASE");
- if (o->op_private & OPpCONST_WARNING)
- sv_catpv(tmpsv, ",WARNING");
- if (o->op_private & OPpCONST_ENTERED)
- sv_catpv(tmpsv, ",ENTERED");
- }
- else if (o->op_type == OP_FLIP) {
- if (o->op_private & OPpFLIP_LINENUM)
- sv_catpv(tmpsv, ",LINENUM");
- }
- else if (o->op_type == OP_FLOP) {
- if (o->op_private & OPpFLIP_LINENUM)
- sv_catpv(tmpsv, ",LINENUM");
- }
- else if (o->op_type == OP_RV2CV) {
- if (o->op_private & OPpLVAL_INTRO)
- sv_catpv(tmpsv, ",INTRO");
- }
- else if (o->op_type == OP_GV) {
- if (o->op_private & OPpEARLY_CV)
- sv_catpv(tmpsv, ",EARLY_CV");
- }
- else if (o->op_type == OP_LIST) {
- if (o->op_private & OPpLIST_GUESSED)
- sv_catpv(tmpsv, ",GUESSED");
- }
- else if (o->op_type == OP_DELETE) {
- if (o->op_private & OPpSLICE)
- sv_catpv(tmpsv, ",SLICE");
- }
- else if (o->op_type == OP_EXISTS) {
- if (o->op_private & OPpEXISTS_SUB)
- sv_catpv(tmpsv, ",EXISTS_SUB");
- }
- else if (o->op_type == OP_SORT) {
- if (o->op_private & OPpSORT_NUMERIC)
- sv_catpv(tmpsv, ",NUMERIC");
- if (o->op_private & OPpSORT_INTEGER)
- sv_catpv(tmpsv, ",INTEGER");
- if (o->op_private & OPpSORT_REVERSE)
- sv_catpv(tmpsv, ",REVERSE");
- }
- else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
- if (o->op_private & OPpOPEN_IN_RAW)
- sv_catpv(tmpsv, ",IN_RAW");
- if (o->op_private & OPpOPEN_IN_CRLF)
- sv_catpv(tmpsv, ",IN_CRLF");
- if (o->op_private & OPpOPEN_OUT_RAW)
- sv_catpv(tmpsv, ",OUT_RAW");
- if (o->op_private & OPpOPEN_OUT_CRLF)
- sv_catpv(tmpsv, ",OUT_CRLF");
- }
- else if (o->op_type == OP_EXIT) {
- if (o->op_private & OPpEXIT_VMSISH)
- sv_catpv(tmpsv, ",EXIT_VMSISH");
- if (o->op_private & OPpHUSH_VMSISH)
- sv_catpv(tmpsv, ",HUSH_VMSISH");
- }
- else if (o->op_type == OP_DIE) {
- if (o->op_private & OPpHUSH_VMSISH)
- sv_catpv(tmpsv, ",HUSH_VMSISH");
- }
- else if (PL_check[o->op_type] != Perl_ck_ftst) {
- if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
- sv_catpv(tmpsv, ",FT_ACCESS");
- if (o->op_private & OPpFT_STACKED)
- sv_catpv(tmpsv, ",FT_STACKED");
- }
- if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
- sv_catpv(tmpsv, ",INTRO");
- if (SvCUR(tmpsv))
- S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
- SvREFCNT_dec(tmpsv);
- }
- switch (o->op_type) {
+ DUMP_OP_FLAGS(o,1,0,file);
+ DUMP_OP_PRIVATE(o,1,0,file);
+
+ switch (optype) {
case OP_AELEMFAST:
if (o->op_flags & OPf_SPECIAL) {
break;
@@ -3286,10 +3060,10 @@
level--;
Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
- SvREFCNT_dec(tmpsv);
+ SvREFCNT_dec_NN(tmpsv);
}
- switch (o->op_type) {
+ switch (optype) {
case OP_PUSHRE:
case OP_MATCH:
case OP_QR:
@@ -3333,8 +3107,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/dump.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.4
\ No newline at end of property
Modified: trunk/contrib/perl/embed.h
===================================================================
--- trunk/contrib/perl/embed.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/embed.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -27,8 +27,18 @@
/* Hide global symbols */
#define Gv_AMupdate(a,b) Perl_Gv_AMupdate(aTHX_ a,b)
+#define _is_uni_FOO(a,b) Perl__is_uni_FOO(aTHX_ a,b)
+#define _is_uni_perl_idcont(a) Perl__is_uni_perl_idcont(aTHX_ a)
+#define _is_uni_perl_idstart(a) Perl__is_uni_perl_idstart(aTHX_ a)
+#define _is_utf8_FOO(a,b) Perl__is_utf8_FOO(aTHX_ a,b)
+#define _is_utf8_mark(a) Perl__is_utf8_mark(aTHX_ a)
+#define _is_utf8_perl_idcont(a) Perl__is_utf8_perl_idcont(aTHX_ a)
+#define _is_utf8_perl_idstart(a) Perl__is_utf8_perl_idstart(aTHX_ a)
#define _to_uni_fold_flags(a,b,c,d) Perl__to_uni_fold_flags(aTHX_ a,b,c,d)
-#define _to_utf8_fold_flags(a,b,c,d) Perl__to_utf8_fold_flags(aTHX_ a,b,c,d)
+#define _to_utf8_fold_flags(a,b,c,d,e) Perl__to_utf8_fold_flags(aTHX_ a,b,c,d,e)
+#define _to_utf8_lower_flags(a,b,c,d,e) Perl__to_utf8_lower_flags(aTHX_ a,b,c,d,e)
+#define _to_utf8_title_flags(a,b,c,d,e) Perl__to_utf8_title_flags(aTHX_ a,b,c,d,e)
+#define _to_utf8_upper_flags(a,b,c,d,e) Perl__to_utf8_upper_flags(aTHX_ a,b,c,d,e)
#define amagic_call(a,b,c,d) Perl_amagic_call(aTHX_ a,b,c,d)
#define amagic_deref_call(a,b) Perl_amagic_deref_call(aTHX_ a,b)
#define apply_attrs_string(a,b,c,d) Perl_apply_attrs_string(aTHX_ a,b,c,d)
@@ -46,6 +56,7 @@
#define av_push(a,b) Perl_av_push(aTHX_ a,b)
#define av_shift(a) Perl_av_shift(aTHX_ a)
#define av_store(a,b,c) Perl_av_store(aTHX_ a,b,c)
+#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_gimme() Perl_block_gimme(aTHX)
@@ -73,11 +84,12 @@
#ifndef PERL_IMPLICIT_CONTEXT
#define croak Perl_croak
#endif
-#define croak_no_modify() Perl_croak_no_modify(aTHX)
+#define croak_no_modify Perl_croak_no_modify
#define croak_sv(a) Perl_croak_sv(aTHX_ a)
-#define croak_xs_usage(a,b) Perl_croak_xs_usage(aTHX_ a,b)
+#define croak_xs_usage Perl_croak_xs_usage
#define custom_op_desc(a) Perl_custom_op_desc(aTHX_ a)
#define custom_op_name(a) Perl_custom_op_name(aTHX_ a)
+#define cv_clone(a) Perl_cv_clone(aTHX_ a)
#define cv_const_sv(a) Perl_cv_const_sv(aTHX_ a)
#define cv_get_call_checker(a,b,c) Perl_cv_get_call_checker(aTHX_ a,b,c)
#define cv_set_call_checker(a,b,c) Perl_cv_set_call_checker(aTHX_ a,b,c)
@@ -160,7 +172,9 @@
#define grok_numeric_radix(a,b) Perl_grok_numeric_radix(aTHX_ a,b)
#define grok_oct(a,b,c,d) Perl_grok_oct(aTHX_ a,b,c,d)
#define gv_add_by_type(a,b) Perl_gv_add_by_type(aTHX_ a,b)
-#define gv_autoload4(a,b,c,d) Perl_gv_autoload4(aTHX_ a,b,c,d)
+#define gv_autoload_pv(a,b,c) Perl_gv_autoload_pv(aTHX_ a,b,c)
+#define gv_autoload_pvn(a,b,c,d) Perl_gv_autoload_pvn(aTHX_ a,b,c,d)
+#define gv_autoload_sv(a,b,c) Perl_gv_autoload_sv(aTHX_ a,b,c)
#define gv_check(a) Perl_gv_check(aTHX_ a)
#define gv_const_sv(a) Perl_gv_const_sv(aTHX_ a)
#define gv_dump(a) Perl_gv_dump(aTHX_ a)
@@ -168,10 +182,16 @@
#define gv_efullname4(a,b,c,d) Perl_gv_efullname4(aTHX_ a,b,c,d)
#define gv_fetchfile(a) Perl_gv_fetchfile(aTHX_ a)
#define gv_fetchfile_flags(a,b,c) Perl_gv_fetchfile_flags(aTHX_ a,b,c)
-#define gv_fetchmeth(a,b,c,d) Perl_gv_fetchmeth(aTHX_ a,b,c,d)
-#define gv_fetchmeth_autoload(a,b,c,d) Perl_gv_fetchmeth_autoload(aTHX_ a,b,c,d)
+#define gv_fetchmeth_pv(a,b,c,d) Perl_gv_fetchmeth_pv(aTHX_ a,b,c,d)
+#define gv_fetchmeth_pv_autoload(a,b,c,d) Perl_gv_fetchmeth_pv_autoload(aTHX_ a,b,c,d)
+#define gv_fetchmeth_pvn(a,b,c,d,e) Perl_gv_fetchmeth_pvn(aTHX_ a,b,c,d,e)
+#define gv_fetchmeth_pvn_autoload(a,b,c,d,e) Perl_gv_fetchmeth_pvn_autoload(aTHX_ a,b,c,d,e)
+#define gv_fetchmeth_sv(a,b,c,d) Perl_gv_fetchmeth_sv(aTHX_ a,b,c,d)
+#define gv_fetchmeth_sv_autoload(a,b,c,d) Perl_gv_fetchmeth_sv_autoload(aTHX_ a,b,c,d)
#define gv_fetchmethod_autoload(a,b,c) Perl_gv_fetchmethod_autoload(aTHX_ a,b,c)
-#define gv_fetchmethod_flags(a,b,c) Perl_gv_fetchmethod_flags(aTHX_ a,b,c)
+#define gv_fetchmethod_pv_flags(a,b,c) Perl_gv_fetchmethod_pv_flags(aTHX_ a,b,c)
+#define gv_fetchmethod_pvn_flags(a,b,c,d) Perl_gv_fetchmethod_pvn_flags(aTHX_ a,b,c,d)
+#define gv_fetchmethod_sv_flags(a,b,c) Perl_gv_fetchmethod_sv_flags(aTHX_ a,b,c)
#define gv_fetchpv(a,b,c) Perl_gv_fetchpv(aTHX_ a,b,c)
#define gv_fetchpvn_flags(a,b,c,d) Perl_gv_fetchpvn_flags(aTHX_ a,b,c,d)
#define gv_fetchsv(a,b,c) Perl_gv_fetchsv(aTHX_ a,b,c)
@@ -178,7 +198,9 @@
#define gv_fullname(a,b) Perl_gv_fullname(aTHX_ a,b)
#define gv_fullname4(a,b,c,d) Perl_gv_fullname4(aTHX_ a,b,c,d)
#define gv_handler(a,b) Perl_gv_handler(aTHX_ a,b)
-#define gv_init(a,b,c,d,e) Perl_gv_init(aTHX_ a,b,c,d,e)
+#define gv_init_pv(a,b,c,d) Perl_gv_init_pv(aTHX_ a,b,c,d)
+#define gv_init_pvn(a,b,c,d,e) Perl_gv_init_pvn(aTHX_ a,b,c,d,e)
+#define gv_init_sv(a,b,c,d) Perl_gv_init_sv(aTHX_ a,b,c,d)
#define gv_name_set(a,b,c,d) Perl_gv_name_set(aTHX_ a,b,c,d)
#define gv_stashpv(a,b) Perl_gv_stashpv(aTHX_ a,b)
#define gv_stashpvn(a,b,c) Perl_gv_stashpvn(aTHX_ a,b,c)
@@ -198,6 +220,7 @@
#define hv_iterval(a,b) Perl_hv_iterval(aTHX_ a,b)
#define hv_ksplit(a,b) Perl_hv_ksplit(aTHX_ a,b)
#define hv_name_set(a,b,c,d) Perl_hv_name_set(aTHX_ a,b,c,d)
+#define hv_rand_set(a,b) Perl_hv_rand_set(aTHX_ a,b)
#define hv_scalar(a) Perl_hv_scalar(aTHX_ a)
#define init_i18nl10n(a) Perl_init_i18nl10n(aTHX_ a)
#define init_i18nl14n(a) Perl_init_i18nl14n(aTHX_ a)
@@ -208,10 +231,14 @@
#define is_lvalue_sub() Perl_is_lvalue_sub(aTHX)
#define is_uni_alnum(a) Perl_is_uni_alnum(aTHX_ a)
#define is_uni_alnum_lc(a) Perl_is_uni_alnum_lc(aTHX_ a)
+#define is_uni_alnumc(a) Perl_is_uni_alnumc(aTHX_ a)
+#define is_uni_alnumc_lc(a) Perl_is_uni_alnumc_lc(aTHX_ a)
#define is_uni_alpha(a) Perl_is_uni_alpha(aTHX_ a)
#define is_uni_alpha_lc(a) Perl_is_uni_alpha_lc(aTHX_ a)
#define is_uni_ascii(a) Perl_is_uni_ascii(aTHX_ a)
#define is_uni_ascii_lc(a) Perl_is_uni_ascii_lc(aTHX_ a)
+#define is_uni_blank(a) Perl_is_uni_blank(aTHX_ a)
+#define is_uni_blank_lc(a) Perl_is_uni_blank_lc(aTHX_ a)
#define is_uni_cntrl(a) Perl_is_uni_cntrl(aTHX_ a)
#define is_uni_cntrl_lc(a) Perl_is_uni_cntrl_lc(aTHX_ a)
#define is_uni_digit(a) Perl_is_uni_digit(aTHX_ a)
@@ -233,9 +260,12 @@
#define is_uni_xdigit(a) Perl_is_uni_xdigit(aTHX_ a)
#define is_uni_xdigit_lc(a) Perl_is_uni_xdigit_lc(aTHX_ a)
#define is_utf8_alnum(a) Perl_is_utf8_alnum(aTHX_ a)
+#define is_utf8_alnumc(a) Perl_is_utf8_alnumc(aTHX_ a)
#define is_utf8_alpha(a) Perl_is_utf8_alpha(aTHX_ a)
#define is_utf8_ascii(a) Perl_is_utf8_ascii(aTHX_ a)
+#define is_utf8_blank(a) Perl_is_utf8_blank(aTHX_ a)
#define is_utf8_char Perl_is_utf8_char
+#define is_utf8_char_buf Perl_is_utf8_char_buf
#define is_utf8_cntrl(a) Perl_is_utf8_cntrl(aTHX_ a)
#define is_utf8_digit(a) Perl_is_utf8_digit(aTHX_ a)
#define is_utf8_graph(a) Perl_is_utf8_graph(aTHX_ a)
@@ -301,8 +331,6 @@
#define my_failure_exit() Perl_my_failure_exit(aTHX)
#define my_fflush_all() Perl_my_fflush_all(aTHX)
#define my_fork Perl_my_fork
-#define my_pclose(a) Perl_my_pclose(aTHX_ a)
-#define my_popen(a,b) Perl_my_popen(aTHX_ a,b)
#define my_popen_list(a,b,c) Perl_my_popen_list(aTHX_ a,b,c)
#define my_setenv(a,b) Perl_my_setenv(aTHX_ a,b)
#define my_socketpair Perl_my_socketpair
@@ -317,12 +345,13 @@
#define newBINOP(a,b,c,d) Perl_newBINOP(aTHX_ a,b,c,d)
#define newCONDOP(a,b,c,d) Perl_newCONDOP(aTHX_ a,b,c,d)
#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 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 newGVOP(a,b,c) Perl_newGVOP(aTHX_ a,b,c)
#define newGVREF(a,b) Perl_newGVREF(aTHX_ a,b)
-#define newGVgen(a) Perl_newGVgen(aTHX_ a)
+#define newGVgen_flags(a,b) Perl_newGVgen_flags(aTHX_ a,b)
#define newHVREF(a) Perl_newHVREF(aTHX_ a)
#define newHVhv(a) Perl_newHVhv(aTHX_ a)
#define newLISTOP(a,b,c,d) Perl_newLISTOP(aTHX_ a,b,c,d)
@@ -329,6 +358,7 @@
#define newLOGOP(a,b,c,d) Perl_newLOGOP(aTHX_ a,b,c,d)
#define newLOOPEX(a,b) Perl_newLOOPEX(aTHX_ a,b)
#define newLOOPOP(a,b,c,d) Perl_newLOOPOP(aTHX_ a,b,c,d)
+#define newMYSUB(a,b,c,d,e) Perl_newMYSUB(aTHX_ a,b,c,d,e)
#define newNULLLIST() Perl_newNULLLIST(aTHX)
#define newOP(a,b) Perl_newOP(aTHX_ a,b)
#define newPMOP(a,b) Perl_newPMOP(aTHX_ a,b)
@@ -375,7 +405,6 @@
#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)
-#define op_lvalue(a,b) Perl_op_lvalue(aTHX_ a,b)
#define op_null(a) Perl_op_null(aTHX_ a)
#define op_prepend_elem(a,b,c) Perl_op_prepend_elem(aTHX_ a,b,c)
#define op_refcnt_lock() Perl_op_refcnt_lock(aTHX)
@@ -383,7 +412,17 @@
#define op_scope(a) Perl_op_scope(aTHX_ a)
#define pack_cat(a,b,c,d,e,f,g) Perl_pack_cat(aTHX_ a,b,c,d,e,f,g)
#define packlist(a,b,c,d,e) Perl_packlist(aTHX_ a,b,c,d,e)
-#define pad_findmy(a,b,c) Perl_pad_findmy(aTHX_ a,b,c)
+#define pad_add_anon(a,b) Perl_pad_add_anon(aTHX_ a,b)
+#define pad_add_name_pv(a,b,c,d) Perl_pad_add_name_pv(aTHX_ a,b,c,d)
+#define pad_add_name_pvn(a,b,c,d,e) Perl_pad_add_name_pvn(aTHX_ a,b,c,d,e)
+#define pad_add_name_sv(a,b,c,d) Perl_pad_add_name_sv(aTHX_ a,b,c,d)
+#define pad_alloc(a,b) Perl_pad_alloc(aTHX_ a,b)
+#define pad_compname_type(a) Perl_pad_compname_type(aTHX_ a)
+#define pad_findmy_pv(a,b) Perl_pad_findmy_pv(aTHX_ a,b)
+#define pad_findmy_pvn(a,b,c) Perl_pad_findmy_pvn(aTHX_ a,b,c)
+#define pad_findmy_sv(a,b) Perl_pad_findmy_sv(aTHX_ a,b)
+#define pad_new(a) Perl_pad_new(aTHX_ a)
+#define pad_tidy(a) Perl_pad_tidy(aTHX_ a)
#define parse_arithexpr(a) Perl_parse_arithexpr(aTHX_ a)
#define parse_barestmt(a) Perl_parse_barestmt(aTHX_ a)
#define parse_block(a) Perl_parse_block(aTHX_ a)
@@ -414,6 +453,10 @@
#define re_compile(a,b) Perl_re_compile(aTHX_ a,b)
#define re_intuit_start(a,b,c,d,e,f) Perl_re_intuit_start(aTHX_ a,b,c,d,e,f)
#define re_intuit_string(a) Perl_re_intuit_string(aTHX_ a)
+#define reentrant_free() Perl_reentrant_free(aTHX)
+#define reentrant_init() Perl_reentrant_init(aTHX)
+#define reentrant_retry Perl_reentrant_retry
+#define reentrant_size() Perl_reentrant_size(aTHX)
#define reg_named_buff_all(a,b) Perl_reg_named_buff_all(aTHX_ a,b)
#define reg_named_buff_exists(a,b,c) Perl_reg_named_buff_exists(aTHX_ a,b,c)
#define reg_named_buff_fetch(a,b,c) Perl_reg_named_buff_fetch(aTHX_ a,b,c)
@@ -422,7 +465,6 @@
#define reg_named_buff_scalar(a,b) Perl_reg_named_buff_scalar(aTHX_ a,b)
#define regclass_swash(a,b,c,d,e) Perl_regclass_swash(aTHX_ a,b,c,d,e)
#define regdump(a) Perl_regdump(aTHX_ a)
-#define regdump(a) Perl_regdump(aTHX_ a)
#define regexec_flags(a,b,c,d,e,f,g,h) Perl_regexec_flags(aTHX_ a,b,c,d,e,f,g,h)
#define regfree_internal(a) Perl_regfree_internal(aTHX_ a)
#define reginitcolors() Perl_reginitcolors(aTHX)
@@ -504,7 +546,6 @@
#define sortsv_flags(a,b,c,d) Perl_sortsv_flags(aTHX_ a,b,c,d)
#define stack_grow(a,b,c) Perl_stack_grow(aTHX_ a,b,c)
#define start_subparse(a,b) Perl_start_subparse(aTHX_ a,b)
-#define stashpv_hvname_match(a,b) Perl_stashpv_hvname_match(aTHX_ a,b)
#define str_to_version(a) Perl_str_to_version(aTHX_ a)
#define sv_2bool_flags(a,b) Perl_sv_2bool_flags(aTHX_ a,b)
#define sv_2cv(a,b,c,d) Perl_sv_2cv(aTHX_ a,b,c,d)
@@ -532,13 +573,18 @@
#define sv_clear(a) Perl_sv_clear(aTHX_ a)
#define sv_cmp_flags(a,b,c) Perl_sv_cmp_flags(aTHX_ a,b,c)
#define sv_cmp_locale_flags(a,b,c) Perl_sv_cmp_locale_flags(aTHX_ a,b,c)
-#define sv_compile_2op(a,b,c,d) Perl_sv_compile_2op(aTHX_ a,b,c,d)
-#define sv_copypv(a,b) Perl_sv_copypv(aTHX_ a,b)
+#define sv_copypv_flags(a,b,c) Perl_sv_copypv_flags(aTHX_ a,b,c)
#define sv_dec(a) Perl_sv_dec(aTHX_ a)
#define sv_dec_nomg(a) Perl_sv_dec_nomg(aTHX_ a)
#define sv_derived_from(a,b) Perl_sv_derived_from(aTHX_ a,b)
+#define sv_derived_from_pv(a,b,c) Perl_sv_derived_from_pv(aTHX_ a,b,c)
+#define sv_derived_from_pvn(a,b,c,d) Perl_sv_derived_from_pvn(aTHX_ a,b,c,d)
+#define sv_derived_from_sv(a,b,c) Perl_sv_derived_from_sv(aTHX_ a,b,c)
#define sv_destroyable(a) Perl_sv_destroyable(aTHX_ a)
#define sv_does(a,b) Perl_sv_does(aTHX_ a,b)
+#define sv_does_pv(a,b,c) Perl_sv_does_pv(aTHX_ a,b,c)
+#define sv_does_pvn(a,b,c,d) Perl_sv_does_pvn(aTHX_ a,b,c,d)
+#define sv_does_sv(a,b,c) Perl_sv_does_sv(aTHX_ a,b,c)
#define sv_dump(a) Perl_sv_dump(aTHX_ a)
#define sv_eq_flags(a,b,c) Perl_sv_eq_flags(aTHX_ a,b,c)
#define sv_force_normal_flags(a,b) Perl_sv_force_normal_flags(aTHX_ a,b)
@@ -555,7 +601,6 @@
#define sv_len_utf8(a) Perl_sv_len_utf8(aTHX_ a)
#define sv_magic(a,b,c,d,e) Perl_sv_magic(aTHX_ a,b,c,d,e)
#define sv_magicext(a,b,c,d,e,f) Perl_sv_magicext(aTHX_ a,b,c,d,e,f)
-#define sv_mortalcopy(a) Perl_sv_mortalcopy(aTHX_ a)
#define sv_newmortal() Perl_sv_newmortal(aTHX)
#define sv_newref(a) Perl_sv_newref(aTHX_ a)
#define sv_nosharing(a) Perl_sv_nosharing(aTHX_ a)
@@ -617,6 +662,7 @@
#define sv_vcatpvf(a,b,c) Perl_sv_vcatpvf(aTHX_ a,b,c)
#define sv_vcatpvf_mg(a,b,c) Perl_sv_vcatpvf_mg(aTHX_ a,b,c)
#define sv_vcatpvfn(a,b,c,d,e,f,g) Perl_sv_vcatpvfn(aTHX_ a,b,c,d,e,f,g)
+#define sv_vcatpvfn_flags(a,b,c,d,e,f,g,h) Perl_sv_vcatpvfn_flags(aTHX_ a,b,c,d,e,f,g,h)
#define sv_vsetpvf(a,b,c) Perl_sv_vsetpvf(aTHX_ a,b,c)
#define sv_vsetpvf_mg(a,b,c) Perl_sv_vsetpvf_mg(aTHX_ a,b,c)
#define sv_vsetpvfn(a,b,c,d,e,f,g) Perl_sv_vsetpvfn(aTHX_ a,b,c,d,e,f,g)
@@ -632,9 +678,6 @@
#define to_uni_upper(a,b,c) Perl_to_uni_upper(aTHX_ a,b,c)
#define to_uni_upper_lc(a) Perl_to_uni_upper_lc(aTHX_ a)
#define to_utf8_case(a,b,c,d,e,f) Perl_to_utf8_case(aTHX_ a,b,c,d,e,f)
-#define to_utf8_lower(a,b,c) Perl_to_utf8_lower(aTHX_ a,b,c)
-#define to_utf8_title(a,b,c) Perl_to_utf8_title(aTHX_ a,b,c)
-#define to_utf8_upper(a,b,c) Perl_to_utf8_upper(aTHX_ a,b,c)
#define unpack_str(a,b,c,d,e,f,g,h) Perl_unpack_str(aTHX_ a,b,c,d,e,f,g,h)
#define unpackstring(a,b,c,d,e) Perl_unpackstring(aTHX_ a,b,c,d,e)
#define unsharepvn(a,b,c) Perl_unsharepvn(aTHX_ a,b,c)
@@ -646,10 +689,13 @@
#define utf8_length(a,b) Perl_utf8_length(aTHX_ a,b)
#define utf8_to_bytes(a,b) Perl_utf8_to_bytes(aTHX_ a,b)
#define utf8_to_uvchr(a,b) Perl_utf8_to_uvchr(aTHX_ a,b)
+#define utf8_to_uvchr_buf(a,b,c) Perl_utf8_to_uvchr_buf(aTHX_ a,b,c)
#define utf8_to_uvuni(a,b) Perl_utf8_to_uvuni(aTHX_ a,b)
+#define utf8_to_uvuni_buf(a,b,c) Perl_utf8_to_uvuni_buf(aTHX_ a,b,c)
#define utf8n_to_uvuni(a,b,c,d) Perl_utf8n_to_uvuni(aTHX_ a,b,c,d)
#define uvchr_to_utf8_flags(a,b,c) Perl_uvchr_to_utf8_flags(aTHX_ a,b,c)
#define uvuni_to_utf8_flags(a,b,c) Perl_uvuni_to_utf8_flags(aTHX_ a,b,c)
+#define valid_utf8_to_uvuni(a,b) Perl_valid_utf8_to_uvuni(aTHX_ a,b)
#define vcmp(a,b) Perl_vcmp(aTHX_ a,b)
#define vcroak(a,b) Perl_vcroak(aTHX_ a,b)
#define vdeb(a,b) Perl_vdeb(aTHX_ a,b)
@@ -670,7 +716,10 @@
#ifndef PERL_IMPLICIT_CONTEXT
#define warner Perl_warner
#endif
-#define whichsig(a) Perl_whichsig(aTHX_ a)
+#define whichsig_pv(a) Perl_whichsig_pv(aTHX_ a)
+#define whichsig_pvn(a,b) Perl_whichsig_pvn(aTHX_ a,b)
+#define whichsig_sv(a) Perl_whichsig_sv(aTHX_ a)
+#define wrap_op_checker(a,b,c) Perl_wrap_op_checker(aTHX_ a,b,c)
#if !(defined(HAS_SIGACTION) && defined(SA_SIGINFO))
#define csighandler Perl_csighandler
#endif
@@ -679,7 +728,6 @@
#endif
#if !(defined(PERL_MAD))
#define newFORM(a,b,c) Perl_newFORM(aTHX_ a,b,c)
-#define newMYSUB(a,b,c,d,e) Perl_newMYSUB(aTHX_ a,b,c,d,e)
#endif
#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
#define my_bzero Perl_my_bzero
@@ -693,10 +741,15 @@
#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
#define my_chsize(a,b) Perl_my_chsize(aTHX_ a,b)
#endif
+#if !defined(PERL_IMPLICIT_SYS)
+#define my_pclose(a) Perl_my_pclose(aTHX_ a)
+#define my_popen(a,b) Perl_my_popen(aTHX_ a,b)
+#endif
#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
#define my_bcopy Perl_my_bcopy
#endif
#if defined(DEBUGGING)
+#define pad_setsv(a,b) Perl_pad_setsv(aTHX_ a,b)
#define pad_sv(a) Perl_pad_sv(aTHX_ a)
#endif
#if defined(DUMP_FDS)
@@ -705,6 +758,7 @@
#if defined(EBCDIC)
#define utf8n_to_uvchr(a,b,c,d) Perl_utf8n_to_uvchr(aTHX_ a,b,c,d)
#define uvchr_to_utf8(a,b) Perl_uvchr_to_utf8(aTHX_ a,b)
+#define valid_utf8_to_uvchr(a,b) Perl_valid_utf8_to_uvchr(aTHX_ a,b)
#endif
#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
#define csighandler Perl_csighandler
@@ -749,16 +803,12 @@
#endif
#if defined(PERL_MAD)
#define newFORM(a,b,c) Perl_newFORM(aTHX_ a,b,c)
-#define newMYSUB(a,b,c,d,e) Perl_newMYSUB(aTHX_ a,b,c,d,e)
#endif
-#if defined(PL_OP_SLAB_ALLOC)
-#define Slab_Alloc(a) Perl_Slab_Alloc(aTHX_ a)
-#define Slab_Free(a) Perl_Slab_Free(aTHX_ a)
-#endif
#if defined(UNLINK_ALL_VERSIONS)
#define unlnk(a) Perl_unlnk(aTHX_ a)
#endif
#if defined(USE_ITHREADS)
+#define alloccopstash(a) Perl_alloccopstash(aTHX_ a)
#define any_dup(a,b) Perl_any_dup(aTHX_ a,b)
#define cx_dup(a,b,c,d) Perl_cx_dup(aTHX_ a,b,c,d)
#define dirp_dup(a,b) Perl_dirp_dup(aTHX_ a,b)
@@ -804,12 +854,6 @@
#define PerlIO_unread(a,b,c) Perl_PerlIO_unread(aTHX_ a,b,c)
#define PerlIO_write(a,b,c) Perl_PerlIO_write(aTHX_ a,b,c)
#endif
-#if defined(USE_REENTRANT_API)
-#define reentrant_free() Perl_reentrant_free(aTHX)
-#define reentrant_init() Perl_reentrant_init(aTHX)
-#define reentrant_retry Perl_reentrant_retry
-#define reentrant_size() Perl_reentrant_size(aTHX)
-#endif
#if defined(WIN32) || defined(__SYMBIAN32__) || defined(VMS)
#define do_aspawn(a,b,c) Perl_do_aspawn(aTHX_ a,b,c)
#define do_spawn(a) Perl_do_spawn(aTHX_ a)
@@ -816,22 +860,8 @@
#define do_spawn_nowait(a) Perl_do_spawn_nowait(aTHX_ a)
#endif
#if defined(PERL_CORE) || defined(PERL_EXT)
-#define _append_range_to_invlist(a,b,c) Perl__append_range_to_invlist(aTHX_ a,b,c)
-#define _new_invlist(a) Perl__new_invlist(aTHX_ a)
-#define _swash_inversion_hash(a) Perl__swash_inversion_hash(aTHX_ a)
-#define _swash_to_invlist(a) Perl__swash_to_invlist(aTHX_ a)
#define av_reify(a) Perl_av_reify(aTHX_ a)
-#define is_utf8_X_L(a) Perl_is_utf8_X_L(aTHX_ a)
-#define is_utf8_X_LV(a) Perl_is_utf8_X_LV(aTHX_ a)
-#define is_utf8_X_LVT(a) Perl_is_utf8_X_LVT(aTHX_ a)
-#define is_utf8_X_LV_LVT_V(a) Perl_is_utf8_X_LV_LVT_V(aTHX_ a)
-#define is_utf8_X_T(a) Perl_is_utf8_X_T(aTHX_ a)
-#define is_utf8_X_V(a) Perl_is_utf8_X_V(aTHX_ a)
-#define is_utf8_X_begin(a) Perl_is_utf8_X_begin(aTHX_ a)
-#define is_utf8_X_extend(a) Perl_is_utf8_X_extend(aTHX_ a)
-#define is_utf8_X_non_hangul(a) Perl_is_utf8_X_non_hangul(aTHX_ a)
-#define is_utf8_X_prepend(a) Perl_is_utf8_X_prepend(aTHX_ a)
-#define mod(a,b) Perl_mod(aTHX_ a,b)
+#define current_re_engine() Perl_current_re_engine(aTHX)
#define op_clear(a) Perl_op_clear(aTHX_ a)
#define qerror(a) Perl_qerror(aTHX_ a)
#define reg_named_buff(a,b,c,d) Perl_reg_named_buff(aTHX_ a,b,c,d)
@@ -860,38 +890,48 @@
#define dump_exec_pos(a,b,c,d,e,f) S_dump_exec_pos(aTHX_ a,b,c,d,e,f)
# endif
# endif
-# if defined(PERL_IN_DQUOTE_STATIC_C)
-#define grok_bslash_c(a,b,c) S_grok_bslash_c(aTHX_ a,b,c)
-#define grok_bslash_o(a,b,c,d,e) S_grok_bslash_o(aTHX_ a,b,c,d,e)
-#define regcurly(a) S_regcurly(aTHX_ a)
+# if defined(PERL_ANY_COW)
+#define sv_setsv_cow(a,b) Perl_sv_setsv_cow(aTHX_ a,b)
# endif
# if defined(PERL_IN_REGCOMP_C)
-#define add_alternate(a,b,c) S_add_alternate(aTHX_ a,b,c)
+#define _append_range_to_invlist(a,b,c) S__append_range_to_invlist(aTHX_ a,b,c)
+#define _invlist_array_init(a,b) S__invlist_array_init(aTHX_ a,b)
+#define _new_invlist_C_array(a) S__new_invlist_C_array(aTHX_ a)
#define add_cp_to_invlist(a,b) S_add_cp_to_invlist(aTHX_ a,b)
#define add_data S_add_data
-#define add_range_to_invlist(a,b,c) S_add_range_to_invlist(aTHX_ a,b,c)
-#define checkposixcc(a) S_checkposixcc(aTHX_ a)
+#define alloc_maybe_populate_EXACT(a,b,c,d,e) S_alloc_maybe_populate_EXACT(aTHX_ a,b,c,d,e)
#define cl_and S_cl_and
#define cl_anything S_cl_anything
#define cl_init S_cl_init
#define cl_is_anything S_cl_is_anything
#define cl_or S_cl_or
+#define compute_EXACTish(a) S_compute_EXACTish(aTHX_ a)
+#define could_it_be_a_POSIX_class(a) S_could_it_be_a_POSIX_class(aTHX_ a)
+#define get_invlist_iter_addr(a) S_get_invlist_iter_addr(aTHX_ a)
+#define get_invlist_previous_index_addr(a) S_get_invlist_previous_index_addr(aTHX_ a)
+#define get_invlist_version_id_addr(a) S_get_invlist_version_id_addr(aTHX_ a)
+#define get_invlist_zero_addr(a) S_get_invlist_zero_addr(aTHX_ a)
+#define grok_bslash_N(a,b,c,d,e,f,g) S_grok_bslash_N(aTHX_ a,b,c,d,e,f,g)
+#define handle_regex_sets(a,b,c,d,e) S_handle_regex_sets(aTHX_ a,b,c,d,e)
#define invlist_array(a) S_invlist_array(aTHX_ a)
-#define invlist_destroy(a) S_invlist_destroy(aTHX_ a)
+#define invlist_clone(a) S_invlist_clone(aTHX_ a)
#define invlist_extend(a,b) S_invlist_extend(aTHX_ a,b)
-#define invlist_intersection(a,b) S_invlist_intersection(aTHX_ a,b)
-#define invlist_len(a) S_invlist_len(aTHX_ a)
+#define invlist_highest(a) S_invlist_highest(aTHX_ a)
+#define invlist_is_iterating(a) S_invlist_is_iterating(aTHX_ a)
+#define invlist_iterfinish(a) S_invlist_iterfinish(aTHX_ a)
+#define invlist_iterinit(a) S_invlist_iterinit(aTHX_ a)
+#define invlist_iternext(a,b,c) S_invlist_iternext(aTHX_ a,b,c)
#define invlist_max(a) S_invlist_max(aTHX_ a)
+#define invlist_previous_index(a) S_invlist_previous_index(aTHX_ a)
#define invlist_set_len(a,b) S_invlist_set_len(aTHX_ a,b)
-#define invlist_set_max(a,b) S_invlist_set_max(aTHX_ a,b)
+#define invlist_set_previous_index(a,b) S_invlist_set_previous_index(aTHX_ a,b)
#define invlist_trim(a) S_invlist_trim(aTHX_ a)
-#define invlist_union(a,b) S_invlist_union(aTHX_ a,b)
-#define join_exact(a,b,c,d,e,f) S_join_exact(aTHX_ a,b,c,d,e,f)
+#define join_exact(a,b,c,d,e,f,g) S_join_exact(aTHX_ a,b,c,d,e,f,g)
#define make_trie(a,b,c,d,e,f,g,h) S_make_trie(aTHX_ a,b,c,d,e,f,g,h)
#define make_trie_failtable(a,b,c,d) S_make_trie_failtable(aTHX_ a,b,c,d)
#define nextchar(a) S_nextchar(aTHX_ a)
+#define parse_lparen_question_flags(a) S_parse_lparen_question_flags(aTHX_ a)
#define reg(a,b,c,d) S_reg(aTHX_ a,b,c,d)
-#define reg_namedseq(a,b,c,d) S_reg_namedseq(aTHX_ a,b,c,d)
#define reg_node(a,b) S_reg_node(aTHX_ a,b)
#define reg_recode(a,b) S_reg_recode(aTHX_ a,b)
#define reg_scan_name(a,b) S_reg_scan_name(aTHX_ a,b)
@@ -899,28 +939,59 @@
#define reganode(a,b,c) S_reganode(aTHX_ a,b,c)
#define regatom(a,b,c) S_regatom(aTHX_ a,b,c)
#define regbranch(a,b,c,d) S_regbranch(aTHX_ a,b,c,d)
-#define regclass(a,b) S_regclass(aTHX_ a,b)
+#define regclass(a,b,c,d,e,f,g) S_regclass(aTHX_ a,b,c,d,e,f,g)
#define reginsert(a,b,c,d) S_reginsert(aTHX_ a,b,c,d)
+#define regpatws S_regpatws
#define regpiece(a,b,c) S_regpiece(aTHX_ a,b,c)
-#define regpposixcc(a,b) S_regpposixcc(aTHX_ a,b)
+#define regpposixcc(a,b,c) S_regpposixcc(aTHX_ a,b,c)
#define regtail(a,b,c,d) S_regtail(aTHX_ a,b,c,d)
#define reguni(a,b,c) S_reguni(aTHX_ a,b,c)
#define regwhite S_regwhite
#define scan_commit(a,b,c,d) S_scan_commit(aTHX_ a,b,c,d)
-#define set_regclass_bit(a,b,c,d,e) S_set_regclass_bit(aTHX_ a,b,c,d,e)
-#define set_regclass_bit_fold(a,b,c,d,e) S_set_regclass_bit_fold(aTHX_ a,b,c,d,e)
#define study_chunk(a,b,c,d,e,f,g,h,i,j,k) S_study_chunk(aTHX_ a,b,c,d,e,f,g,h,i,j,k)
# endif
+# if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_REGEXEC_C) || defined(PERL_IN_UTF8_C)
+#define _get_invlist_len_addr(a) S__get_invlist_len_addr(aTHX_ a)
+#define _get_swash_invlist(a) Perl__get_swash_invlist(aTHX_ a)
+#define _invlist_contains_cp(a,b) S__invlist_contains_cp(aTHX_ a,b)
+#define _invlist_contents(a) Perl__invlist_contents(aTHX_ a)
+#define _invlist_len(a) S__invlist_len(aTHX_ a)
+#define _invlist_search(a,b) Perl__invlist_search(aTHX_ a,b)
+#define _swash_inversion_hash(a) Perl__swash_inversion_hash(aTHX_ a)
+# endif
+# if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_REGEXEC_C) || defined(PERL_IN_UTF8_C) || defined(PERL_IN_TOKE_C)
+#define _core_swash_init(a,b,c,d,e,f,g) Perl__core_swash_init(aTHX_ a,b,c,d,e,f,g)
+# endif
+# if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_TOKE_C)
+#define form_short_octal_warning(a,b) S_form_short_octal_warning(aTHX_ a,b)
+#define grok_bslash_c(a,b,c) S_grok_bslash_c(aTHX_ a,b,c)
+#define grok_bslash_o(a,b,c,d,e,f,g) S_grok_bslash_o(aTHX_ a,b,c,d,e,f,g)
+#define grok_bslash_x(a,b,c,d,e,f,g) S_grok_bslash_x(aTHX_ a,b,c,d,e,f,g)
+#define regcurly(a,b) S_regcurly(aTHX_ a,b)
+# endif
+# if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_UTF8_C)
+#define _add_range_to_invlist(a,b,c) Perl__add_range_to_invlist(aTHX_ a,b,c)
+#define _invlist_intersection_maybe_complement_2nd(a,b,c,d) Perl__invlist_intersection_maybe_complement_2nd(aTHX_ a,b,c,d)
+#define _invlist_invert(a) Perl__invlist_invert(aTHX_ a)
+#define _invlist_invert_prop(a) Perl__invlist_invert_prop(aTHX_ a)
+#define _invlist_populate_swatch(a,b,c,d) Perl__invlist_populate_swatch(aTHX_ a,b,c,d)
+#define _invlist_union_maybe_complement_2nd(a,b,c,d) Perl__invlist_union_maybe_complement_2nd(aTHX_ a,b,c,d)
+#define _new_invlist(a) Perl__new_invlist(aTHX_ a)
+#define _swash_to_invlist(a) Perl__swash_to_invlist(aTHX_ a)
+# endif
# if defined(PERL_IN_REGEXEC_C)
-#define find_byclass(a,b,c,d,e) S_find_byclass(aTHX_ a,b,c,d,e)
+#define core_regclass_swash(a,b,c,d) S_core_regclass_swash(aTHX_ a,b,c,d)
+#define find_byclass(a,b,c,d,e,f) S_find_byclass(aTHX_ a,b,c,d,e,f)
+#define isFOO_lc(a,b) S_isFOO_lc(aTHX_ a,b)
+#define isFOO_utf8_lc(a,b) S_isFOO_utf8_lc(aTHX_ a,b)
#define reg_check_named_buff_matched(a,b) S_reg_check_named_buff_matched(aTHX_ a,b)
-#define regcppop(a) S_regcppop(aTHX_ a)
-#define regcppush(a) S_regcppush(aTHX_ a)
+#define regcppop(a,b) S_regcppop(aTHX_ a,b)
+#define regcppush(a,b,c) S_regcppush(aTHX_ a,b,c)
#define reghop3 S_reghop3
#define reghopmaybe3 S_reghopmaybe3
-#define reginclass(a,b,c,d,e) S_reginclass(aTHX_ a,b,c,d,e)
-#define regmatch(a,b) S_regmatch(aTHX_ a,b)
-#define regrepeat(a,b,c,d) S_regrepeat(aTHX_ a,b,c,d)
+#define reginclass(a,b,c,d) S_reginclass(aTHX_ a,b,c,d)
+#define regmatch(a,b,c) S_regmatch(aTHX_ a,b,c)
+#define regrepeat(a,b,c,d,e,f) S_regrepeat(aTHX_ a,b,c,d,e,f)
#define regtry(a,b) S_regtry(aTHX_ a,b)
#define to_byte_substr(a) S_to_byte_substr(aTHX_ a)
#define to_utf8_substr(a) S_to_utf8_substr(aTHX_ a)
@@ -928,13 +999,17 @@
#define reghop4 S_reghop4
# endif
# endif
-# if defined(PERL_OLD_COPY_ON_WRITE)
-#define sv_setsv_cow(a,b) Perl_sv_setsv_cow(aTHX_ a,b)
+# if defined(PERL_IN_UTF8_C) || defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_REGEXEC_C)
+#define _to_fold_latin1(a,b,c,d) Perl__to_fold_latin1(aTHX_ a,b,c,d)
# endif
#endif
#ifdef PERL_CORE
+#define Slab_Alloc(a) Perl_Slab_Alloc(aTHX_ a)
+#define Slab_Free(a) Perl_Slab_Free(aTHX_ a)
#define allocmy(a,b,c) Perl_allocmy(aTHX_ a,b,c)
+#define amagic_is_enabled(a) Perl_amagic_is_enabled(aTHX_ a)
#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)
@@ -945,7 +1020,7 @@
#define check_utf8_print(a,b) Perl_check_utf8_print(aTHX_ a,b)
#define ck_anoncode(a) Perl_ck_anoncode(aTHX_ a)
#define ck_bitop(a) Perl_ck_bitop(aTHX_ a)
-#define ck_chdir(a) Perl_ck_chdir(aTHX_ a)
+#define ck_cmp(a) Perl_ck_cmp(aTHX_ a)
#define ck_concat(a) Perl_ck_concat(aTHX_ a)
#define ck_defined(a) Perl_ck_defined(aTHX_ a)
#define ck_delete(a) Perl_ck_delete(aTHX_ a)
@@ -962,6 +1037,7 @@
#define ck_grep(a) Perl_ck_grep(aTHX_ a)
#define ck_index(a) Perl_ck_index(aTHX_ a)
#define ck_join(a) Perl_ck_join(aTHX_ a)
+#define ck_length(a) Perl_ck_length(aTHX_ a)
#define ck_lfun(a) Perl_ck_lfun(aTHX_ a)
#define ck_listiob(a) Perl_ck_listiob(aTHX_ a)
#define ck_match(a) Perl_ck_match(aTHX_ a)
@@ -984,12 +1060,17 @@
#define ck_subr(a) Perl_ck_subr(aTHX_ a)
#define ck_substr(a) Perl_ck_substr(aTHX_ a)
#define ck_svconst(a) Perl_ck_svconst(aTHX_ a)
+#define ck_tell(a) Perl_ck_tell(aTHX_ a)
#define ck_trunc(a) Perl_ck_trunc(aTHX_ a)
-#define ck_unpack(a) Perl_ck_unpack(aTHX_ a)
#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 cv_ckproto_len(a,b,c,d) Perl_cv_ckproto_len(aTHX_ a,b,c,d)
-#define cv_clone(a) Perl_cv_clone(aTHX_ a)
+#define croak_no_mem Perl_croak_no_mem
+#define croak_popstack Perl_croak_popstack
+#define cv_ckproto_len_flags(a,b,c,d,e) Perl_cv_ckproto_len_flags(aTHX_ a,b,c,d,e)
+#define cv_clone_into(a,b) Perl_cv_clone_into(aTHX_ a,b)
+#define cv_forget_slab(a) Perl_cv_forget_slab(aTHX_ a)
#define cvgv_set(a,b) Perl_cvgv_set(aTHX_ a,b)
#define cvstash_set(a,b) Perl_cvstash_set(aTHX_ a,b)
#define deb_stack_all() Perl_deb_stack_all(aTHX)
@@ -999,6 +1080,7 @@
#define do_dump_pad(a,b,c,d) Perl_do_dump_pad(aTHX_ a,b,c,d)
#define do_eof(a) Perl_do_eof(aTHX_ a)
#define do_execfree() Perl_do_execfree(aTHX)
+#define do_ncmp(a,b) Perl_do_ncmp(aTHX_ a,b)
#define do_print(a,b) Perl_do_print(aTHX_ a,b)
#define do_readline() Perl_do_readline(aTHX)
#define do_seek(a,b,c) Perl_do_seek(aTHX_ a,b,c)
@@ -1012,9 +1094,13 @@
#define dump_all_perl(a) Perl_dump_all_perl(aTHX_ a)
#define dump_packsubs_perl(a,b) Perl_dump_packsubs_perl(aTHX_ a,b)
#define dump_sub_perl(a,b) Perl_dump_sub_perl(aTHX_ a,b)
+#define finalize_optree(a) Perl_finalize_optree(aTHX_ a)
+#define find_lexical_cv(a) Perl_find_lexical_cv(aTHX_ a)
+#define find_runcv_where(a,b,c) Perl_find_runcv_where(aTHX_ a,b,c)
+#define find_rundefsv2(a,b) Perl_find_rundefsv2(aTHX_ a,b)
#define find_script(a,b,c,d) Perl_find_script(aTHX_ a,b,c,d)
#define free_tied_hv_pool() Perl_free_tied_hv_pool(aTHX)
-#define get_hash_seed() Perl_get_hash_seed(aTHX)
+#define get_hash_seed(a) Perl_get_hash_seed(aTHX_ a)
#define get_no_modify() Perl_get_no_modify(aTHX)
#define get_opargs() Perl_get_opargs(aTHX)
#define gv_try_downgrade(a) Perl_gv_try_downgrade(aTHX_ a)
@@ -1021,16 +1107,19 @@
#define hv_ename_add(a,b,c,d) Perl_hv_ename_add(aTHX_ a,b,c,d)
#define hv_ename_delete(a,b,c,d) Perl_hv_ename_delete(aTHX_ a,b,c,d)
#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 is_gv_magical_sv(a,b) Perl_is_gv_magical_sv(aTHX_ a,b)
+#define isALNUM_lazy(a) S_isALNUM_lazy(aTHX_ a)
+#define isIDFIRST_lazy(a) S_isIDFIRST_lazy(aTHX_ a)
#define jmaybe(a) Perl_jmaybe(aTHX_ a)
#define keyword(a,b,c) Perl_keyword(aTHX_ a,b,c)
#define list(a) Perl_list(aTHX_ a)
#define localize(a,b) Perl_localize(aTHX_ a,b)
#define magic_clear_all_env(a,b) Perl_magic_clear_all_env(aTHX_ a,b)
+#define magic_cleararylen_p(a,b) Perl_magic_cleararylen_p(aTHX_ a,b)
#define magic_clearenv(a,b) Perl_magic_clearenv(aTHX_ a,b)
#define magic_clearhint(a,b) Perl_magic_clearhint(aTHX_ a,b)
#define magic_clearhints(a,b) Perl_magic_clearhints(aTHX_ a,b)
@@ -1037,6 +1126,7 @@
#define magic_clearisa(a,b) Perl_magic_clearisa(aTHX_ a,b)
#define magic_clearpack(a,b) Perl_magic_clearpack(aTHX_ a,b)
#define magic_clearsig(a,b) Perl_magic_clearsig(aTHX_ a,b)
+#define magic_copycallchecker(a,b,c,d,e) Perl_magic_copycallchecker(aTHX_ a,b,c,d,e)
#define magic_existspack(a,b) Perl_magic_existspack(aTHX_ a,b)
#define magic_freearylen_p(a,b) Perl_magic_freearylen_p(aTHX_ a,b)
#define magic_freeovrld(a,b) Perl_magic_freeovrld(aTHX_ a,b)
@@ -1052,15 +1142,12 @@
#define magic_getuvar(a,b) Perl_magic_getuvar(aTHX_ a,b)
#define magic_getvec(a,b) Perl_magic_getvec(aTHX_ a,b)
#define magic_killbackrefs(a,b) Perl_magic_killbackrefs(aTHX_ a,b)
-#define magic_len(a,b) Perl_magic_len(aTHX_ a,b)
#define magic_nextpack(a,b,c) Perl_magic_nextpack(aTHX_ a,b,c)
#define magic_regdata_cnt(a,b) Perl_magic_regdata_cnt(aTHX_ a,b)
#define magic_regdatum_get(a,b) Perl_magic_regdatum_get(aTHX_ a,b)
-#define magic_regdatum_set(a,b) Perl_magic_regdatum_set(aTHX_ a,b)
#define magic_scalarpack(a,b) Perl_magic_scalarpack(aTHX_ a,b)
#define magic_set(a,b) Perl_magic_set(aTHX_ a,b)
#define magic_set_all_env(a,b) Perl_magic_set_all_env(aTHX_ a,b)
-#define magic_setamagic(a,b) Perl_magic_setamagic(aTHX_ a,b)
#define magic_setarylen(a,b) Perl_magic_setarylen(aTHX_ a,b)
#define magic_setdbline(a,b) Perl_magic_setdbline(aTHX_ a,b)
#define magic_setdefelem(a,b) Perl_magic_setdefelem(aTHX_ a,b)
@@ -1084,7 +1171,6 @@
#define mode_from_discipline(a,b) Perl_mode_from_discipline(aTHX_ a,b)
#define mro_isa_changed_in(a) Perl_mro_isa_changed_in(aTHX_ a)
#define mro_package_moved(a,b,c,d) Perl_mro_package_moved(aTHX_ a,b,c,d)
-#define munge_qwlist_to_paren_list(a) Perl_munge_qwlist_to_paren_list(aTHX_ a)
#define my_attrs(a,b) Perl_my_attrs(aTHX_ a,b)
#define my_clearenv() Perl_my_clearenv(aTHX)
#define my_lstat_flags(a) Perl_my_lstat_flags(aTHX_ a)
@@ -1091,27 +1177,27 @@
#define my_stat_flags(a) Perl_my_stat_flags(aTHX_ a)
#define my_swabn Perl_my_swabn
#define my_unexec() Perl_my_unexec(aTHX)
+#define newATTRSUB_flags(a,b,c,d,e,f) Perl_newATTRSUB_flags(aTHX_ a,b,c,d,e,f)
+#define newSTUB(a,b) Perl_newSTUB(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) Perl_nextargv(aTHX_ a)
#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_version(a) Perl_package_version(aTHX_ a)
-#define pad_add_anon(a,b) Perl_pad_add_anon(aTHX_ a,b)
-#define pad_add_name(a,b,c,d,e) Perl_pad_add_name(aTHX_ a,b,c,d,e)
-#define pad_alloc(a,b) Perl_pad_alloc(aTHX_ a,b)
#define pad_block_start(a) Perl_pad_block_start(aTHX_ a)
-#define pad_compname_type(a) Perl_pad_compname_type(aTHX_ a)
#define pad_fixup_inner_anons(a,b,c) Perl_pad_fixup_inner_anons(aTHX_ a,b,c)
#define pad_free(a) Perl_pad_free(aTHX_ a)
#define pad_leavemy() Perl_pad_leavemy(aTHX)
-#define pad_new(a) Perl_pad_new(aTHX_ a)
#define pad_push(a,b) Perl_pad_push(aTHX_ a,b)
#define pad_swipe(a,b) Perl_pad_swipe(aTHX_ a,b)
-#define pad_tidy(a) Perl_pad_tidy(aTHX_ a)
+#define padlist_store(a,b,c) Perl_padlist_store(aTHX_ a,b,c)
#define parse_unicode_opts(a) Perl_parse_unicode_opts(aTHX_ a)
#define parser_free(a) Perl_parser_free(aTHX_ a)
#define peep(a) Perl_peep(aTHX_ a)
-#define pmruntime(a,b,c) Perl_pmruntime(aTHX_ a,b,c)
+#define pmruntime(a,b,c,d) Perl_pmruntime(aTHX_ a,b,c,d)
+#define re_op_compile(a,b,c,d,e,f,g,h) Perl_re_op_compile(aTHX_ a,b,c,d,e,f,g,h)
#define refcounted_he_chain_2hv(a,b) Perl_refcounted_he_chain_2hv(aTHX_ a,b)
#define refcounted_he_fetch_pv(a,b,c,d) Perl_refcounted_he_fetch_pv(aTHX_ a,b,c,d)
#define refcounted_he_fetch_pvn(a,b,c,d,e) Perl_refcounted_he_fetch_pvn(aTHX_ a,b,c,d,e)
@@ -1136,6 +1222,11 @@
#define sv_clean_objs() Perl_sv_clean_objs(aTHX)
#define sv_del_backref(a,b) Perl_sv_del_backref(aTHX_ a,b)
#define sv_free_arenas() Perl_sv_free_arenas(aTHX)
+#define sv_len_utf8_nomg(a) Perl_sv_len_utf8_nomg(aTHX_ a)
+#define sv_mortalcopy_flags(a,b) Perl_sv_mortalcopy_flags(aTHX_ a,b)
+#define sv_ref(a,b,c) Perl_sv_ref(aTHX_ a,b,c)
+#define sv_resetpvn(a,b,c) Perl_sv_resetpvn(aTHX_ a,b,c)
+#define sv_sethek(a,b) Perl_sv_sethek(aTHX_ a,b)
#ifndef PERL_IMPLICIT_CONTEXT
#define tied_method Perl_tied_method
#endif
@@ -1145,6 +1236,8 @@
#define watch(a) Perl_watch(aTHX_ a)
#define write_to_stderr(a) Perl_write_to_stderr(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)
#define yyparse(a) Perl_yyparse(aTHX_ a)
#define yyunlex() Perl_yyunlex(aTHX)
# if !(defined(DEBUGGING))
@@ -1164,6 +1257,9 @@
#define package(a) Perl_package(aTHX_ a)
#define utilize(a,b,c,d,e) Perl_utilize(aTHX_ a,b,c,d,e)
# endif
+# if !(defined(_MSC_VER))
+#define magic_regdatum_set(a,b) Perl_magic_regdatum_set(aTHX_ a,b)
+# endif
# if !defined(HAS_GETENV_LEN)
#define getenv_len(a,b) Perl_getenv_len(aTHX_ a,b)
# endif
@@ -1203,7 +1299,6 @@
# endif
# if defined(DEBUGGING)
#define get_debug_opts(a,b) Perl_get_debug_opts(aTHX_ a,b)
-#define pad_setsv(a,b) Perl_pad_setsv(aTHX_ a,b)
# if defined(PERL_IN_PAD_C)
#define cv_dump(a,b) S_cv_dump(aTHX_ a,b)
# endif
@@ -1233,6 +1328,16 @@
#define malloc_good_size Perl_malloc_good_size
#define malloced_size Perl_malloced_size
# endif
+# if defined(PERL_CORE)
+#define opslab_force_free(a) Perl_opslab_force_free(aTHX_ a)
+#define opslab_free(a) Perl_opslab_free(aTHX_ a)
+#define opslab_free_nopad(a) Perl_opslab_free_nopad(aTHX_ a)
+#define parser_free_nexttoke_ops(a,b) Perl_parser_free_nexttoke_ops(aTHX_ a,b)
+# if defined(PERL_DEBUG_READONLY_OPS)
+#define Slab_to_ro(a) Perl_Slab_to_ro(aTHX_ a)
+#define Slab_to_rw(a) Perl_Slab_to_rw(aTHX_ a)
+# endif
+# endif
# if defined(PERL_CR_FILTER)
# if defined(PERL_IN_TOKE_C)
#define cr_textfilter(a,b,c) S_cr_textfilter(aTHX_ a,b,c)
@@ -1239,13 +1344,6 @@
#define strip_return(a) S_strip_return(aTHX_ a)
# endif
# endif
-# if defined(PERL_DEBUG_READONLY_OPS)
-# if defined(PERL_IN_OP_C)
-# if defined(PL_OP_SLAB_ALLOC)
-#define Slab_to_rw(a) S_Slab_to_rw(aTHX_ a)
-# endif
-# endif
-# endif
# if defined(PERL_IN_AV_C)
#define get_aux_mg(a) S_get_aux_mg(aTHX_ a)
# endif
@@ -1268,26 +1366,24 @@
#define deb_curcv(a) S_deb_curcv(aTHX_ a)
#define debprof(a) S_debprof(aTHX_ a)
#define pm_description(a) S_pm_description(aTHX_ a)
-#define sequence(a) S_sequence(aTHX_ a)
#define sequence_num(a) S_sequence_num(aTHX_ a)
-#define sequence_tail(a) S_sequence_tail(aTHX_ a)
# endif
# if defined(PERL_IN_GV_C)
-#define gv_get_super_pkg(a,b) S_gv_get_super_pkg(aTHX_ a,b)
-#define gv_init_sv(a,b) S_gv_init_sv(aTHX_ a,b)
+#define gv_init_svtype(a,b) S_gv_init_svtype(aTHX_ a,b)
#define gv_magicalize_isa(a) S_gv_magicalize_isa(aTHX_ a)
-#define gv_magicalize_overload(a) S_gv_magicalize_overload(aTHX_ a)
#define require_tie_mod(a,b,c,d,e) S_require_tie_mod(aTHX_ a,b,c,d,e)
# endif
# if defined(PERL_IN_HV_C)
#define clear_placeholders(a,b) S_clear_placeholders(aTHX_ a,b)
#define hfreeentries(a) S_hfreeentries(aTHX_ a)
-#define hsplit(a) S_hsplit(aTHX_ a)
-#define hv_auxinit S_hv_auxinit
+#define hsplit(a,b,c) S_hsplit(aTHX_ a,b,c)
+#define hv_auxinit(a) S_hv_auxinit(aTHX_ a)
#define hv_delete_common(a,b,c,d,e,f,g) S_hv_delete_common(aTHX_ a,b,c,d,e,f,g)
+#define hv_free_ent_ret(a,b) S_hv_free_ent_ret(aTHX_ a,b)
#define hv_magic_check S_hv_magic_check
#define hv_notallowed(a,b,c,d) S_hv_notallowed(aTHX_ a,b,c,d)
#define new_he() S_new_he(aTHX)
+#define ptr_hash S_ptr_hash
#define refcounted_he_value(a) S_refcounted_he_value(aTHX_ a)
#define save_hek_flags S_save_hek_flags
#define share_hek_flags(a,b,c,d) S_share_hek_flags(aTHX_ a,b,c,d)
@@ -1305,8 +1401,11 @@
#define save_magic(a,b) S_save_magic(aTHX_ a,b)
#define unwind_handler_stack(a) S_unwind_handler_stack(aTHX_ a)
# endif
+# if defined(PERL_IN_MG_C) || defined(PERL_IN_PP_C)
+#define translate_substr_offsets(a,b,c,d,e,f,g) Perl_translate_substr_offsets(aTHX_ a,b,c,d,e,f,g)
+# endif
# if defined(PERL_IN_MRO_C)
-#define mro_clean_isarev(a,b,c,d) S_mro_clean_isarev(aTHX_ a,b,c,d)
+#define mro_clean_isarev(a,b,c,d,e) S_mro_clean_isarev(aTHX_ a,b,c,d,e)
#define mro_gather_and_rename(a,b,c,d,e) S_mro_gather_and_rename(aTHX_ a,b,c,d,e)
#define mro_get_linear_isa_dfs(a,b) S_mro_get_linear_isa_dfs(aTHX_ a,b)
# endif
@@ -1314,18 +1413,22 @@
#define mulexp10 S_mulexp10
# endif
# if defined(PERL_IN_OP_C)
-#define apply_attrs(a,b,c,d) S_apply_attrs(aTHX_ a,b,c,d)
+#define aassign_common_vars(a) S_aassign_common_vars(aTHX_ a)
+#define apply_attrs(a,b,c) S_apply_attrs(aTHX_ a,b,c)
#define apply_attrs_my(a,b,c,d) S_apply_attrs_my(aTHX_ a,b,c,d)
-#define bad_type(a,b,c,d) S_bad_type(aTHX_ a,b,c,d)
+#define bad_type_pv(a,b,c,d,e) S_bad_type_pv(aTHX_ a,b,c,d,e)
+#define bad_type_sv(a,b,c,d,e) S_bad_type_sv(aTHX_ a,b,c,d,e)
#define cop_free(a) S_cop_free(aTHX_ a)
#define dup_attrlist(a) S_dup_attrlist(aTHX_ a)
+#define finalize_op(a) S_finalize_op(aTHX_ a)
#define find_and_forget_pmops(a) S_find_and_forget_pmops(aTHX_ a)
#define fold_constants(a) S_fold_constants(aTHX_ a)
#define force_list(a) S_force_list(aTHX_ a)
+#define forget_pmop(a) S_forget_pmop(aTHX_ a)
#define gen_constant_list(a) S_gen_constant_list(aTHX_ a)
#define gv_ename(a) S_gv_ename(aTHX_ a)
+#define inplace_aassign(a) S_inplace_aassign(aTHX_ a)
#define is_handle_constructor S_is_handle_constructor
-#define is_inplace_av(a,b) S_is_inplace_av(aTHX_ a,b)
#define is_list_assignment(a) S_is_list_assignment(aTHX_ a)
#define listkids(a) S_listkids(aTHX_ a)
#define looks_like_bool(a) S_looks_like_bool(aTHX_ a)
@@ -1336,9 +1439,10 @@
#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 opt_scalarhv(a) S_opt_scalarhv(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 process_special_blocks(a,b,c) S_process_special_blocks(aTHX_ a,b,c)
+#define process_special_blocks(a,b,c,d) S_process_special_blocks(aTHX_ a,b,c,d)
#define ref_array_or_hash(a) S_ref_array_or_hash(aTHX_ a)
#define refkids(a,b) S_refkids(aTHX_ a,b)
#define scalar_mod_type S_scalar_mod_type
@@ -1347,13 +1451,18 @@
#define scalarseq(a) S_scalarseq(aTHX_ a)
#define search_const(a) S_search_const(aTHX_ a)
#define simplify_sort(a) S_simplify_sort(aTHX_ a)
-#define too_few_arguments(a,b) S_too_few_arguments(aTHX_ a,b)
-#define too_many_arguments(a,b) S_too_many_arguments(aTHX_ a,b)
+#define too_few_arguments_pv(a,b,c) S_too_few_arguments_pv(aTHX_ a,b,c)
+#define too_few_arguments_sv(a,b,c) S_too_few_arguments_sv(aTHX_ a,b,c)
+#define too_many_arguments_pv(a,b,c) S_too_many_arguments_pv(aTHX_ a,b,c)
+#define too_many_arguments_sv(a,b,c) S_too_many_arguments_sv(aTHX_ a,b,c)
# endif
+# if defined(PERL_IN_OP_C) || defined(PERL_IN_SV_C)
+#define report_redefined_cv(a,b,c) Perl_report_redefined_cv(aTHX_ a,b,c)
+# endif
# if defined(PERL_IN_PAD_C)
-#define pad_add_name_sv(a,b,c,d) S_pad_add_name_sv(aTHX_ a,b,c,d)
+#define pad_alloc_name(a,b,c,d) S_pad_alloc_name(aTHX_ a,b,c,d)
#define pad_check_dup(a,b,c) S_pad_check_dup(aTHX_ a,b,c)
-#define pad_findlex(a,b,c,d,e,f,g) S_pad_findlex(aTHX_ a,b,c,d,e,f,g)
+#define pad_findlex(a,b,c,d,e,f,g,h,i) S_pad_findlex(aTHX_ a,b,c,d,e,f,g,h,i)
#define pad_reset() S_pad_reset(aTHX)
# endif
# if defined(PERL_IN_PERL_C)
@@ -1367,12 +1476,14 @@
#define init_perllib() S_init_perllib(aTHX)
#define init_postdump_symbols(a,b,c) S_init_postdump_symbols(aTHX_ a,b,c)
#define init_predump_symbols() S_init_predump_symbols(aTHX)
+#define mayberelocate(a,b,c) S_mayberelocate(aTHX_ a,b,c)
+#define minus_v() S_minus_v(aTHX)
#define my_exit_jump() S_my_exit_jump(aTHX)
#define nuke_stacks() S_nuke_stacks(aTHX)
-#define open_script(a,b,c,d) S_open_script(aTHX_ a,b,c,d)
+#define open_script(a,b,c) S_open_script(aTHX_ a,b,c)
#define parse_body(a,b) S_parse_body(aTHX_ a,b)
#define run_body(a) S_run_body(aTHX_ a)
-#define usage(a) S_usage(aTHX_ a)
+#define usage() S_usage(aTHX)
# endif
# if defined(PERL_IN_PP_C)
#define do_chomp(a,b,c) S_do_chomp(aTHX_ a,b,c)
@@ -1380,16 +1491,17 @@
#define refto(a) S_refto(aTHX_ a)
# endif
# if defined(PERL_IN_PP_CTL_C)
+#define adjust_stack_on_leave(a,b,c,d,e) S_adjust_stack_on_leave(aTHX_ a,b,c,d,e)
#define check_type_and_open(a) S_check_type_and_open(aTHX_ a)
#define destroy_matcher(a) S_destroy_matcher(aTHX_ a)
-#define do_smartmatch(a,b) S_do_smartmatch(aTHX_ a,b)
+#define do_smartmatch(a,b,c) S_do_smartmatch(aTHX_ a,b,c)
#define docatch(a) S_docatch(aTHX_ a)
#define doeval(a,b,c,d) S_doeval(aTHX_ a,b,c,d)
-#define dofindlabel(a,b,c,d) S_dofindlabel(aTHX_ a,b,c,d)
+#define dofindlabel(a,b,c,d,e,f) S_dofindlabel(aTHX_ a,b,c,d,e,f)
#define doparseform(a) S_doparseform(aTHX_ a)
#define dopoptoeval(a) S_dopoptoeval(aTHX_ a)
#define dopoptogiven(a) S_dopoptogiven(aTHX_ a)
-#define dopoptolabel(a) S_dopoptolabel(aTHX_ a)
+#define dopoptolabel(a,b,c) S_dopoptolabel(aTHX_ a,b,c)
#define dopoptoloop(a) S_dopoptoloop(aTHX_ a)
#define dopoptosub_at(a,b) S_dopoptosub_at(aTHX_ a,b)
#define dopoptowhen(a) S_dopoptowhen(aTHX_ a)
@@ -1403,7 +1515,7 @@
#define save_lines(a,b) S_save_lines(aTHX_ a,b)
# endif
# if defined(PERL_IN_PP_HOT_C)
-#define do_oddball(a,b,c) S_do_oddball(aTHX_ a,b,c)
+#define do_oddball(a,b) S_do_oddball(aTHX_ a,b)
#define method_common(a,b) S_method_common(aTHX_ a,b)
# endif
# if defined(PERL_IN_PP_PACK_C)
@@ -1462,11 +1574,10 @@
#define sv_pos_u2b_cached(a,b,c,d,e,f,g) S_sv_pos_u2b_cached(aTHX_ a,b,c,d,e,f,g)
#define sv_pos_u2b_forwards S_sv_pos_u2b_forwards
#define sv_pos_u2b_midway S_sv_pos_u2b_midway
-#define sv_unglob(a) S_sv_unglob(aTHX_ a)
+#define sv_unglob(a,b) S_sv_unglob(aTHX_ a,b)
#define uiv_2buf S_uiv_2buf
#define utf8_mg_len_cache_update(a,b,c) S_utf8_mg_len_cache_update(aTHX_ a,b,c)
#define utf8_mg_pos_cache_update(a,b,c,d,e) S_utf8_mg_pos_cache_update(aTHX_ a,b,c,d,e)
-#define varname(a,b,c,d,e,f) S_varname(aTHX_ a,b,c,d,e,f)
#define visit(a,b,c) S_visit(aTHX_ a,b,c)
# if defined(PERL_OLD_COPY_ON_WRITE)
#define sv_release_COW(a,b,c) S_sv_release_COW(aTHX_ a,b,c)
@@ -1477,6 +1588,9 @@
#define unreferenced_to_tmp_stack(a) S_unreferenced_to_tmp_stack(aTHX_ a)
# endif
# endif
+# if defined(PERL_IN_SV_C) || defined (PERL_IN_OP_C)
+#define varname(a,b,c,d,e,f) Perl_varname(aTHX_ a,b,c,d,e,f)
+# endif
# if defined(PERL_IN_TOKE_C)
#define ao(a) S_ao(aTHX_ a)
#define check_uni() S_check_uni(aTHX)
@@ -1485,10 +1599,12 @@
#define filter_gets(a,b) S_filter_gets(aTHX_ a,b)
#define find_in_my_stash(a,b) S_find_in_my_stash(aTHX_ a,b)
#define force_ident(a,b) S_force_ident(aTHX_ a,b)
+#define force_ident_maybe_lex(a) S_force_ident_maybe_lex(aTHX_ a)
#define force_next(a) S_force_next(aTHX_ a)
#define force_strict_version(a) S_force_strict_version(aTHX_ a)
#define force_version(a,b) S_force_version(aTHX_ a,b)
#define force_word(a,b,c,d,e) S_force_word(aTHX_ a,b,c,d,e)
+#define get_and_check_backslash_N_name(a,b) S_get_and_check_backslash_N_name(aTHX_ a,b)
#define incline(a) S_incline(aTHX_ a)
#define intuit_method(a,b,c) S_intuit_method(aTHX_ a,b,c)
#define intuit_more(a) S_intuit_more(aTHX_ a)
@@ -1495,6 +1611,8 @@
#define lop(a,b,c) S_lop(aTHX_ a,b,c)
#define missingterm(a) S_missingterm(aTHX_ a)
#define no_op(a,b) S_no_op(aTHX_ a,b)
+#define parse_ident(a,b,c,d,e) S_parse_ident(aTHX_ a,b,c,d,e)
+#define pending_ident() S_pending_ident(aTHX)
#define readpipe_override() S_readpipe_override(aTHX)
#define scan_const(a) S_scan_const(aTHX_ a)
#define scan_formline(a) S_scan_formline(aTHX_ a)
@@ -1502,7 +1620,7 @@
#define scan_ident(a,b,c,d,e) S_scan_ident(aTHX_ a,b,c,d,e)
#define scan_inputsymbol(a) S_scan_inputsymbol(aTHX_ a)
#define scan_pat(a,b) S_scan_pat(aTHX_ a,b)
-#define scan_str(a,b,c) S_scan_str(aTHX_ a,b,c)
+#define scan_str(a,b,c,d,e) S_scan_str(aTHX_ a,b,c,d,e)
#define scan_subst(a) S_scan_subst(aTHX_ a)
#define scan_trans(a) S_scan_trans(aTHX_ a)
#define scan_word(a,b,c,d,e) S_scan_word(aTHX_ a,b,c,d,e)
@@ -1514,7 +1632,7 @@
#define tokenize_use(a,b) S_tokenize_use(aTHX_ a,b)
#define tokeq(a) S_tokeq(aTHX_ a)
#define update_debugger_info(a,b,c) S_update_debugger_info(aTHX_ a,b,c)
-#define yywarn(a) S_yywarn(aTHX_ a)
+#define yywarn(a,b) S_yywarn(aTHX_ a,b)
# if defined(PERL_MAD)
#define curmad(a,b) S_curmad(aTHX_ a,b)
#define skipspace0(a) S_skipspace0(aTHX_ a)
@@ -1524,13 +1642,18 @@
# endif
# endif
# if defined(PERL_IN_UNIVERSAL_C)
-#define isa_lookup(a,b) S_isa_lookup(aTHX_ a,b)
+#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 is_utf8_char_slow S_is_utf8_char_slow
#define is_utf8_common(a,b,c) S_is_utf8_common(aTHX_ a,b,c)
-#define swash_get(a,b,c) S_swash_get(aTHX_ a,b,c)
+#define swatch_get(a,b,c) S_swatch_get(aTHX_ a,b,c)
+#define to_lower_latin1(a,b,c) S_to_lower_latin1(aTHX_ a,b,c)
# endif
+# if defined(PERL_IN_UTF8_C) || defined(PERL_IN_PP_C)
+#define _to_upper_title_latin1(a,b,c,d) Perl__to_upper_title_latin1(aTHX_ a,b,c,d)
+# endif
# if defined(PERL_IN_UTIL_C)
#define ckwarn_common(a) S_ckwarn_common(aTHX_ a)
#define closest_cop(a,b) S_closest_cop(aTHX_ a,b)
@@ -1537,7 +1660,6 @@
#define invoke_exception_hook(a,b) S_invoke_exception_hook(aTHX_ a,b)
#define mess_alloc() S_mess_alloc(aTHX)
#define with_queued_errors(a) S_with_queued_errors(aTHX_ a)
-#define write_no_mem() S_write_no_mem(aTHX)
# if defined(PERL_MEM_LOG) && !defined(PERL_MEM_LOG_NOIMPL)
#define mem_log_common S_mem_log_common
# endif
@@ -1663,6 +1785,9 @@
#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(_MSC_VER)
+#define magic_regdatum_set(a,b) Perl_magic_regdatum_set(aTHX_ a,b)
+# endif
#endif
#endif /* #ifndef PERL_NO_SHORT_NAMES */
Property changes on: trunk/contrib/perl/embed.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.4
\ No newline at end of property
Modified: trunk/contrib/perl/embedvar.h
===================================================================
--- trunk/contrib/perl/embedvar.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/embedvar.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -40,6 +40,8 @@
# define vTHX PERL_GET_INTERP
# endif
+#define PL_ASCII (vTHX->IASCII)
+#define PL_AboveLatin1 (vTHX->IAboveLatin1)
#define PL_Argv (vTHX->IArgv)
#define PL_Cmd (vTHX->ICmd)
#define PL_DBcv (vTHX->IDBcv)
@@ -51,19 +53,21 @@
#define PL_DBtrace (vTHX->IDBtrace)
#define PL_Dir (vTHX->IDir)
#define PL_Env (vTHX->IEnv)
+#define PL_HasMultiCharFold (vTHX->IHasMultiCharFold)
+#define PL_L1Posix_ptrs (vTHX->IL1Posix_ptrs)
#define PL_LIO (vTHX->ILIO)
+#define PL_Latin1 (vTHX->ILatin1)
#define PL_Mem (vTHX->IMem)
#define PL_MemParse (vTHX->IMemParse)
#define PL_MemShared (vTHX->IMemShared)
-#define PL_OpPtr (vTHX->IOpPtr)
-#define PL_OpSlab (vTHX->IOpSlab)
-#define PL_OpSpace (vTHX->IOpSpace)
+#define PL_NonL1NonFinalFold (vTHX->INonL1NonFinalFold)
+#define PL_Posix_ptrs (vTHX->IPosix_ptrs)
#define PL_Proc (vTHX->IProc)
#define PL_Sock (vTHX->ISock)
#define PL_StdIO (vTHX->IStdIO)
#define PL_Sv (vTHX->ISv)
+#define PL_XPosix_ptrs (vTHX->IXPosix_ptrs)
#define PL_Xpv (vTHX->IXpv)
-#define PL_amagic_generation (vTHX->Iamagic_generation)
#define PL_an (vTHX->Ian)
#define PL_apiversion (vTHX->Iapiversion)
#define PL_argvgv (vTHX->Iargvgv)
@@ -117,6 +121,10 @@
#define PL_defoutgv (vTHX->Idefoutgv)
#define PL_defstash (vTHX->Idefstash)
#define PL_delaymagic (vTHX->Idelaymagic)
+#define PL_delaymagic_egid (vTHX->Idelaymagic_egid)
+#define PL_delaymagic_euid (vTHX->Idelaymagic_euid)
+#define PL_delaymagic_gid (vTHX->Idelaymagic_gid)
+#define PL_delaymagic_uid (vTHX->Idelaymagic_uid)
#define PL_destroyhook (vTHX->Idestroyhook)
#define PL_diehook (vTHX->Idiehook)
#define PL_doswitches (vTHX->Idoswitches)
@@ -126,13 +134,11 @@
#define PL_e_script (vTHX->Ie_script)
#define PL_efloatbuf (vTHX->Iefloatbuf)
#define PL_efloatsize (vTHX->Iefloatsize)
-#define PL_egid (vTHX->Iegid)
#define PL_encoding (vTHX->Iencoding)
#define PL_endav (vTHX->Iendav)
#define PL_envgv (vTHX->Ienvgv)
#define PL_errgv (vTHX->Ierrgv)
#define PL_errors (vTHX->Ierrors)
-#define PL_euid (vTHX->Ieuid)
#define PL_eval_root (vTHX->Ieval_root)
#define PL_eval_start (vTHX->Ieval_start)
#define PL_evalseq (vTHX->Ievalseq)
@@ -143,14 +149,13 @@
#define PL_filemode (vTHX->Ifilemode)
#define PL_firstgv (vTHX->Ifirstgv)
#define PL_forkprocess (vTHX->Iforkprocess)
-#define PL_formfeed (vTHX->Iformfeed)
#define PL_formtarget (vTHX->Iformtarget)
#define PL_generation (vTHX->Igeneration)
#define PL_gensym (vTHX->Igensym)
-#define PL_gid (vTHX->Igid)
-#define PL_glob_index (vTHX->Iglob_index)
#define PL_globalstash (vTHX->Iglobalstash)
-#define PL_hash_seed (vTHX->Ihash_seed)
+#define PL_globhook (vTHX->Iglobhook)
+#define PL_hash_rand_bits (vTHX->Ihash_rand_bits)
+#define PL_hash_rand_bits_enabled (vTHX->Ihash_rand_bits_enabled)
#define PL_hintgv (vTHX->Ihintgv)
#define PL_hints (vTHX->Ihints)
#define PL_hv_fetch_ent_mh (vTHX->Ihv_fetch_ent_mh)
@@ -171,7 +176,6 @@
#define PL_last_swash_tmps (vTHX->Ilast_swash_tmps)
#define PL_lastfd (vTHX->Ilastfd)
#define PL_lastgotoprobe (vTHX->Ilastgotoprobe)
-#define PL_lastscream (vTHX->Ilastscream)
#define PL_laststatval (vTHX->Ilaststatval)
#define PL_laststype (vTHX->Ilaststype)
#define PL_localizing (vTHX->Ilocalizing)
@@ -187,7 +191,6 @@
#define PL_markstack_ptr (vTHX->Imarkstack_ptr)
#define PL_max_intro_pending (vTHX->Imax_intro_pending)
#define PL_maxo (vTHX->Imaxo)
-#define PL_maxscream (vTHX->Imaxscream)
#define PL_maxsysfd (vTHX->Imaxsysfd)
#define PL_memory_debug_header (vTHX->Imemory_debug_header)
#define PL_mess_sv (vTHX->Imess_sv)
@@ -234,7 +237,6 @@
#define PL_perlio (vTHX->Iperlio)
#define PL_phase (vTHX->Iphase)
#define PL_pidstatus (vTHX->Ipidstatus)
-#define PL_ppid (vTHX->Ippid)
#define PL_preambleav (vTHX->Ipreambleav)
#define PL_profiledata (vTHX->Iprofiledata)
#define PL_psig_name (vTHX->Ipsig_name)
@@ -247,12 +249,9 @@
#define PL_regdummy (vTHX->Iregdummy)
#define PL_regex_pad (vTHX->Iregex_pad)
#define PL_regex_padav (vTHX->Iregex_padav)
-#define PL_reginterp_cnt (vTHX->Ireginterp_cnt)
#define PL_registered_mros (vTHX->Iregistered_mros)
#define PL_regmatch_slab (vTHX->Iregmatch_slab)
#define PL_regmatch_state (vTHX->Iregmatch_state)
-#define PL_rehash_seed (vTHX->Irehash_seed)
-#define PL_rehash_seed_set (vTHX->Irehash_seed_set)
#define PL_replgv (vTHX->Ireplgv)
#define PL_restartjmpenv (vTHX->Irestartjmpenv)
#define PL_restartop (vTHX->Irestartop)
@@ -263,13 +262,13 @@
#define PL_savestack (vTHX->Isavestack)
#define PL_savestack_ix (vTHX->Isavestack_ix)
#define PL_savestack_max (vTHX->Isavestack_max)
+#ifndef PL_sawampersand
#define PL_sawampersand (vTHX->Isawampersand)
+#endif
#define PL_scopestack (vTHX->Iscopestack)
#define PL_scopestack_ix (vTHX->Iscopestack_ix)
#define PL_scopestack_max (vTHX->Iscopestack_max)
#define PL_scopestack_name (vTHX->Iscopestack_name)
-#define PL_screamfirst (vTHX->Iscreamfirst)
-#define PL_screamnext (vTHX->Iscreamnext)
#define PL_secondgv (vTHX->Isecondgv)
#define PL_sharehook (vTHX->Isharehook)
#define PL_sig_pending (vTHX->Isig_pending)
@@ -276,8 +275,6 @@
#define PL_sighandlerp (vTHX->Isighandlerp)
#define PL_signalhook (vTHX->Isignalhook)
#define PL_signals (vTHX->Isignals)
-#define PL_slab_count (vTHX->Islab_count)
-#define PL_slabs (vTHX->Islabs)
#define PL_sort_RealCmp (vTHX->Isort_RealCmp)
#define PL_sortcop (vTHX->Isortcop)
#define PL_sortstash (vTHX->Isortstash)
@@ -288,6 +285,9 @@
#define PL_stack_sp (vTHX->Istack_sp)
#define PL_start_env (vTHX->Istart_env)
#define PL_stashcache (vTHX->Istashcache)
+#define PL_stashpad (vTHX->Istashpad)
+#define PL_stashpadix (vTHX->Istashpadix)
+#define PL_stashpadmax (vTHX->Istashpadmax)
#define PL_statbuf (vTHX->Istatbuf)
#define PL_statcache (vTHX->Istatcache)
#define PL_statgv (vTHX->Istatgv)
@@ -321,46 +321,27 @@
#define PL_tmps_stack (vTHX->Itmps_stack)
#define PL_top_env (vTHX->Itop_env)
#define PL_toptarget (vTHX->Itoptarget)
-#define PL_uid (vTHX->Iuid)
#define PL_unicode (vTHX->Iunicode)
#define PL_unitcheckav (vTHX->Iunitcheckav)
#define PL_unitcheckav_save (vTHX->Iunitcheckav_save)
#define PL_unlockhook (vTHX->Iunlockhook)
#define PL_unsafe (vTHX->Iunsafe)
-#define PL_utf8_X_L (vTHX->Iutf8_X_L)
-#define PL_utf8_X_LV (vTHX->Iutf8_X_LV)
-#define PL_utf8_X_LVT (vTHX->Iutf8_X_LVT)
-#define PL_utf8_X_LV_LVT_V (vTHX->Iutf8_X_LV_LVT_V)
-#define PL_utf8_X_T (vTHX->Iutf8_X_T)
-#define PL_utf8_X_V (vTHX->Iutf8_X_V)
-#define PL_utf8_X_begin (vTHX->Iutf8_X_begin)
#define PL_utf8_X_extend (vTHX->Iutf8_X_extend)
-#define PL_utf8_X_non_hangul (vTHX->Iutf8_X_non_hangul)
-#define PL_utf8_X_prepend (vTHX->Iutf8_X_prepend)
-#define PL_utf8_alnum (vTHX->Iutf8_alnum)
-#define PL_utf8_alpha (vTHX->Iutf8_alpha)
-#define PL_utf8_ascii (vTHX->Iutf8_ascii)
-#define PL_utf8_cntrl (vTHX->Iutf8_cntrl)
-#define PL_utf8_digit (vTHX->Iutf8_digit)
+#define PL_utf8_X_regular_begin (vTHX->Iutf8_X_regular_begin)
+#define PL_utf8_charname_begin (vTHX->Iutf8_charname_begin)
+#define PL_utf8_charname_continue (vTHX->Iutf8_charname_continue)
#define PL_utf8_foldable (vTHX->Iutf8_foldable)
#define PL_utf8_foldclosures (vTHX->Iutf8_foldclosures)
-#define PL_utf8_graph (vTHX->Iutf8_graph)
#define PL_utf8_idcont (vTHX->Iutf8_idcont)
#define PL_utf8_idstart (vTHX->Iutf8_idstart)
-#define PL_utf8_lower (vTHX->Iutf8_lower)
#define PL_utf8_mark (vTHX->Iutf8_mark)
-#define PL_utf8_perl_space (vTHX->Iutf8_perl_space)
-#define PL_utf8_perl_word (vTHX->Iutf8_perl_word)
-#define PL_utf8_posix_digit (vTHX->Iutf8_posix_digit)
-#define PL_utf8_print (vTHX->Iutf8_print)
-#define PL_utf8_punct (vTHX->Iutf8_punct)
-#define PL_utf8_space (vTHX->Iutf8_space)
+#define PL_utf8_perl_idcont (vTHX->Iutf8_perl_idcont)
+#define PL_utf8_perl_idstart (vTHX->Iutf8_perl_idstart)
+#define PL_utf8_swash_ptrs (vTHX->Iutf8_swash_ptrs)
#define PL_utf8_tofold (vTHX->Iutf8_tofold)
#define PL_utf8_tolower (vTHX->Iutf8_tolower)
#define PL_utf8_totitle (vTHX->Iutf8_totitle)
#define PL_utf8_toupper (vTHX->Iutf8_toupper)
-#define PL_utf8_upper (vTHX->Iutf8_upper)
-#define PL_utf8_xdigit (vTHX->Iutf8_xdigit)
#define PL_utf8_xidcont (vTHX->Iutf8_xidcont)
#define PL_utf8_xidstart (vTHX->Iutf8_xidstart)
#define PL_utf8cache (vTHX->Iutf8cache)
@@ -370,355 +351,16 @@
#define PL_watchok (vTHX->Iwatchok)
#define PL_xmlfp (vTHX->Ixmlfp)
-#else /* !MULTIPLICITY */
-
-/* case 1 above */
-
-#define PL_IArgv PL_Argv
-#define PL_ICmd PL_Cmd
-#define PL_IDBcv PL_DBcv
-#define PL_IDBgv PL_DBgv
-#define PL_IDBline PL_DBline
-#define PL_IDBsignal PL_DBsignal
-#define PL_IDBsingle PL_DBsingle
-#define PL_IDBsub PL_DBsub
-#define PL_IDBtrace PL_DBtrace
-#define PL_IDir PL_Dir
-#define PL_IEnv PL_Env
-#define PL_ILIO PL_LIO
-#define PL_IMem PL_Mem
-#define PL_IMemParse PL_MemParse
-#define PL_IMemShared PL_MemShared
-#define PL_IOpPtr PL_OpPtr
-#define PL_IOpSlab PL_OpSlab
-#define PL_IOpSpace PL_OpSpace
-#define PL_IProc PL_Proc
-#define PL_ISock PL_Sock
-#define PL_IStdIO PL_StdIO
-#define PL_ISv PL_Sv
-#define PL_IXpv PL_Xpv
-#define PL_Iamagic_generation PL_amagic_generation
-#define PL_Ian PL_an
-#define PL_Iapiversion PL_apiversion
-#define PL_Iargvgv PL_argvgv
-#define PL_Iargvout_stack PL_argvout_stack
-#define PL_Iargvoutgv PL_argvoutgv
-#define PL_Ibasetime PL_basetime
-#define PL_Ibeginav PL_beginav
-#define PL_Ibeginav_save PL_beginav_save
-#define PL_Iblockhooks PL_blockhooks
-#define PL_Ibody_arenas PL_body_arenas
-#define PL_Ibody_roots PL_body_roots
-#define PL_Ibodytarget PL_bodytarget
-#define PL_Ibreakable_sub_gen PL_breakable_sub_gen
-#define PL_Icheckav PL_checkav
-#define PL_Icheckav_save PL_checkav_save
-#define PL_Ichopset PL_chopset
-#define PL_Iclocktick PL_clocktick
-#define PL_Icollation_ix PL_collation_ix
-#define PL_Icollation_name PL_collation_name
-#define PL_Icollation_standard PL_collation_standard
-#define PL_Icollxfrm_base PL_collxfrm_base
-#define PL_Icollxfrm_mult PL_collxfrm_mult
-#define PL_Icolors PL_colors
-#define PL_Icolorset PL_colorset
-#define PL_Icompcv PL_compcv
-#define PL_Icompiling PL_compiling
-#define PL_Icomppad PL_comppad
-#define PL_Icomppad_name PL_comppad_name
-#define PL_Icomppad_name_fill PL_comppad_name_fill
-#define PL_Icomppad_name_floor PL_comppad_name_floor
-#define PL_Icop_seqmax PL_cop_seqmax
-#define PL_Icryptseen PL_cryptseen
-#define PL_Icurcop PL_curcop
-#define PL_Icurcopdb PL_curcopdb
-#define PL_Icurpad PL_curpad
-#define PL_Icurpm PL_curpm
-#define PL_Icurstack PL_curstack
-#define PL_Icurstackinfo PL_curstackinfo
-#define PL_Icurstash PL_curstash
-#define PL_Icurstname PL_curstname
-#define PL_Icustom_op_descs PL_custom_op_descs
-#define PL_Icustom_op_names PL_custom_op_names
-#define PL_Icustom_ops PL_custom_ops
-#define PL_Icv_has_eval PL_cv_has_eval
-#define PL_Idbargs PL_dbargs
-#define PL_Idebstash PL_debstash
-#define PL_Idebug PL_debug
-#define PL_Idebug_pad PL_debug_pad
-#define PL_Idef_layerlist PL_def_layerlist
-#define PL_Idefgv PL_defgv
-#define PL_Idefoutgv PL_defoutgv
-#define PL_Idefstash PL_defstash
-#define PL_Idelaymagic PL_delaymagic
-#define PL_Idestroyhook PL_destroyhook
-#define PL_Idiehook PL_diehook
-#define PL_Idoswitches PL_doswitches
-#define PL_Idowarn PL_dowarn
-#define PL_Idumper_fd PL_dumper_fd
-#define PL_Idumpindent PL_dumpindent
-#define PL_Ie_script PL_e_script
-#define PL_Iefloatbuf PL_efloatbuf
-#define PL_Iefloatsize PL_efloatsize
-#define PL_Iegid PL_egid
-#define PL_Iencoding PL_encoding
-#define PL_Iendav PL_endav
-#define PL_Ienvgv PL_envgv
-#define PL_Ierrgv PL_errgv
-#define PL_Ierrors PL_errors
-#define PL_Ieuid PL_euid
-#define PL_Ieval_root PL_eval_root
-#define PL_Ieval_start PL_eval_start
-#define PL_Ievalseq PL_evalseq
-#define PL_Iexit_flags PL_exit_flags
-#define PL_Iexitlist PL_exitlist
-#define PL_Iexitlistlen PL_exitlistlen
-#define PL_Ifdpid PL_fdpid
-#define PL_Ifilemode PL_filemode
-#define PL_Ifirstgv PL_firstgv
-#define PL_Iforkprocess PL_forkprocess
-#define PL_Iformfeed PL_formfeed
-#define PL_Iformtarget PL_formtarget
-#define PL_Igeneration PL_generation
-#define PL_Igensym PL_gensym
-#define PL_Igid PL_gid
-#define PL_Iglob_index PL_glob_index
-#define PL_Iglobalstash PL_globalstash
-#define PL_Ihash_seed PL_hash_seed
-#define PL_Ihintgv PL_hintgv
-#define PL_Ihints PL_hints
-#define PL_Ihv_fetch_ent_mh PL_hv_fetch_ent_mh
-#define PL_Iin_clean_all PL_in_clean_all
-#define PL_Iin_clean_objs PL_in_clean_objs
-#define PL_Iin_eval PL_in_eval
-#define PL_Iin_load_module PL_in_load_module
-#define PL_Iincgv PL_incgv
-#define PL_Iinitav PL_initav
-#define PL_Iinplace PL_inplace
-#define PL_Iisarev PL_isarev
-#define PL_Iknown_layers PL_known_layers
-#define PL_Ilast_in_gv PL_last_in_gv
-#define PL_Ilast_swash_hv PL_last_swash_hv
-#define PL_Ilast_swash_key PL_last_swash_key
-#define PL_Ilast_swash_klen PL_last_swash_klen
-#define PL_Ilast_swash_slen PL_last_swash_slen
-#define PL_Ilast_swash_tmps PL_last_swash_tmps
-#define PL_Ilastfd PL_lastfd
-#define PL_Ilastgotoprobe PL_lastgotoprobe
-#define PL_Ilastscream PL_lastscream
-#define PL_Ilaststatval PL_laststatval
-#define PL_Ilaststype PL_laststype
-#define PL_Ilocalizing PL_localizing
-#define PL_Ilocalpatches PL_localpatches
-#define PL_Ilockhook PL_lockhook
-#define PL_Imadskills PL_madskills
-#define PL_Imain_cv PL_main_cv
-#define PL_Imain_root PL_main_root
-#define PL_Imain_start PL_main_start
-#define PL_Imainstack PL_mainstack
-#define PL_Imarkstack PL_markstack
-#define PL_Imarkstack_max PL_markstack_max
-#define PL_Imarkstack_ptr PL_markstack_ptr
-#define PL_Imax_intro_pending PL_max_intro_pending
-#define PL_Imaxo PL_maxo
-#define PL_Imaxscream PL_maxscream
-#define PL_Imaxsysfd PL_maxsysfd
-#define PL_Imemory_debug_header PL_memory_debug_header
-#define PL_Imess_sv PL_mess_sv
-#define PL_Imin_intro_pending PL_min_intro_pending
-#define PL_Iminus_E PL_minus_E
-#define PL_Iminus_F PL_minus_F
-#define PL_Iminus_a PL_minus_a
-#define PL_Iminus_c PL_minus_c
-#define PL_Iminus_l PL_minus_l
-#define PL_Iminus_n PL_minus_n
-#define PL_Iminus_p PL_minus_p
-#define PL_Imodcount PL_modcount
-#define PL_Imodglobal PL_modglobal
-#define PL_Imy_cxt_keys PL_my_cxt_keys
-#define PL_Imy_cxt_list PL_my_cxt_list
-#define PL_Imy_cxt_size PL_my_cxt_size
-#define PL_Ina PL_na
-#define PL_Inomemok PL_nomemok
-#define PL_Inumeric_local PL_numeric_local
-#define PL_Inumeric_name PL_numeric_name
-#define PL_Inumeric_radix_sv PL_numeric_radix_sv
-#define PL_Inumeric_standard PL_numeric_standard
-#define PL_Iofsgv PL_ofsgv
-#define PL_Ioldname PL_oldname
-#define PL_Iop PL_op
-#define PL_Iop_mask PL_op_mask
-#define PL_Iopfreehook PL_opfreehook
-#define PL_Iopsave PL_opsave
-#define PL_Iorigalen PL_origalen
-#define PL_Iorigargc PL_origargc
-#define PL_Iorigargv PL_origargv
-#define PL_Iorigenviron PL_origenviron
-#define PL_Iorigfilename PL_origfilename
-#define PL_Iors_sv PL_ors_sv
-#define PL_Iosname PL_osname
-#define PL_Ipad_reset_pending PL_pad_reset_pending
-#define PL_Ipadix PL_padix
-#define PL_Ipadix_floor PL_padix_floor
-#define PL_Iparser PL_parser
-#define PL_Ipatchlevel PL_patchlevel
-#define PL_Ipeepp PL_peepp
-#define PL_Iperl_destruct_level PL_perl_destruct_level
-#define PL_Iperldb PL_perldb
-#define PL_Iperlio PL_perlio
-#define PL_Iphase PL_phase
-#define PL_Ipidstatus PL_pidstatus
-#define PL_Ippid PL_ppid
-#define PL_Ipreambleav PL_preambleav
-#define PL_Iprofiledata PL_profiledata
-#define PL_Ipsig_name PL_psig_name
-#define PL_Ipsig_pend PL_psig_pend
-#define PL_Ipsig_ptr PL_psig_ptr
-#define PL_Iptr_table PL_ptr_table
-#define PL_Ireentrant_buffer PL_reentrant_buffer
-#define PL_Ireentrant_retint PL_reentrant_retint
-#define PL_Ireg_state PL_reg_state
-#define PL_Iregdummy PL_regdummy
-#define PL_Iregex_pad PL_regex_pad
-#define PL_Iregex_padav PL_regex_padav
-#define PL_Ireginterp_cnt PL_reginterp_cnt
-#define PL_Iregistered_mros PL_registered_mros
-#define PL_Iregmatch_slab PL_regmatch_slab
-#define PL_Iregmatch_state PL_regmatch_state
-#define PL_Irehash_seed PL_rehash_seed
-#define PL_Irehash_seed_set PL_rehash_seed_set
-#define PL_Ireplgv PL_replgv
-#define PL_Irestartjmpenv PL_restartjmpenv
-#define PL_Irestartop PL_restartop
-#define PL_Irpeepp PL_rpeepp
-#define PL_Irs PL_rs
-#define PL_Irunops PL_runops
-#define PL_Isavebegin PL_savebegin
-#define PL_Isavestack PL_savestack
-#define PL_Isavestack_ix PL_savestack_ix
-#define PL_Isavestack_max PL_savestack_max
-#define PL_Isawampersand PL_sawampersand
-#define PL_Iscopestack PL_scopestack
-#define PL_Iscopestack_ix PL_scopestack_ix
-#define PL_Iscopestack_max PL_scopestack_max
-#define PL_Iscopestack_name PL_scopestack_name
-#define PL_Iscreamfirst PL_screamfirst
-#define PL_Iscreamnext PL_screamnext
-#define PL_Isecondgv PL_secondgv
-#define PL_Isharehook PL_sharehook
-#define PL_Isig_pending PL_sig_pending
-#define PL_Isighandlerp PL_sighandlerp
-#define PL_Isignalhook PL_signalhook
-#define PL_Isignals PL_signals
-#define PL_Islab_count PL_slab_count
-#define PL_Islabs PL_slabs
-#define PL_Isort_RealCmp PL_sort_RealCmp
-#define PL_Isortcop PL_sortcop
-#define PL_Isortstash PL_sortstash
-#define PL_Isplitstr PL_splitstr
-#define PL_Isrand_called PL_srand_called
-#define PL_Istack_base PL_stack_base
-#define PL_Istack_max PL_stack_max
-#define PL_Istack_sp PL_stack_sp
-#define PL_Istart_env PL_start_env
-#define PL_Istashcache PL_stashcache
-#define PL_Istatbuf PL_statbuf
-#define PL_Istatcache PL_statcache
-#define PL_Istatgv PL_statgv
-#define PL_Istatname PL_statname
-#define PL_Istatusvalue PL_statusvalue
-#define PL_Istatusvalue_posix PL_statusvalue_posix
-#define PL_Istatusvalue_vms PL_statusvalue_vms
-#define PL_Istderrgv PL_stderrgv
-#define PL_Istdingv PL_stdingv
-#define PL_Istrtab PL_strtab
-#define PL_Isub_generation PL_sub_generation
-#define PL_Isubline PL_subline
-#define PL_Isubname PL_subname
-#define PL_Isv_arenaroot PL_sv_arenaroot
-#define PL_Isv_count PL_sv_count
-#define PL_Isv_no PL_sv_no
-#define PL_Isv_objcount PL_sv_objcount
-#define PL_Isv_root PL_sv_root
-#define PL_Isv_serial PL_sv_serial
-#define PL_Isv_undef PL_sv_undef
-#define PL_Isv_yes PL_sv_yes
-#define PL_Isys_intern PL_sys_intern
-#define PL_Itaint_warn PL_taint_warn
-#define PL_Itainted PL_tainted
-#define PL_Itainting PL_tainting
-#define PL_Ithreadhook PL_threadhook
-#define PL_Itimesbuf PL_timesbuf
-#define PL_Itmps_floor PL_tmps_floor
-#define PL_Itmps_ix PL_tmps_ix
-#define PL_Itmps_max PL_tmps_max
-#define PL_Itmps_stack PL_tmps_stack
-#define PL_Itop_env PL_top_env
-#define PL_Itoptarget PL_toptarget
-#define PL_Iuid PL_uid
-#define PL_Iunicode PL_unicode
-#define PL_Iunitcheckav PL_unitcheckav
-#define PL_Iunitcheckav_save PL_unitcheckav_save
-#define PL_Iunlockhook PL_unlockhook
-#define PL_Iunsafe PL_unsafe
-#define PL_Iutf8_X_L PL_utf8_X_L
-#define PL_Iutf8_X_LV PL_utf8_X_LV
-#define PL_Iutf8_X_LVT PL_utf8_X_LVT
-#define PL_Iutf8_X_LV_LVT_V PL_utf8_X_LV_LVT_V
-#define PL_Iutf8_X_T PL_utf8_X_T
-#define PL_Iutf8_X_V PL_utf8_X_V
-#define PL_Iutf8_X_begin PL_utf8_X_begin
-#define PL_Iutf8_X_extend PL_utf8_X_extend
-#define PL_Iutf8_X_non_hangul PL_utf8_X_non_hangul
-#define PL_Iutf8_X_prepend PL_utf8_X_prepend
-#define PL_Iutf8_alnum PL_utf8_alnum
-#define PL_Iutf8_alpha PL_utf8_alpha
-#define PL_Iutf8_ascii PL_utf8_ascii
-#define PL_Iutf8_cntrl PL_utf8_cntrl
-#define PL_Iutf8_digit PL_utf8_digit
-#define PL_Iutf8_foldable PL_utf8_foldable
-#define PL_Iutf8_foldclosures PL_utf8_foldclosures
-#define PL_Iutf8_graph PL_utf8_graph
-#define PL_Iutf8_idcont PL_utf8_idcont
-#define PL_Iutf8_idstart PL_utf8_idstart
-#define PL_Iutf8_lower PL_utf8_lower
-#define PL_Iutf8_mark PL_utf8_mark
-#define PL_Iutf8_perl_space PL_utf8_perl_space
-#define PL_Iutf8_perl_word PL_utf8_perl_word
-#define PL_Iutf8_posix_digit PL_utf8_posix_digit
-#define PL_Iutf8_print PL_utf8_print
-#define PL_Iutf8_punct PL_utf8_punct
-#define PL_Iutf8_space PL_utf8_space
-#define PL_Iutf8_tofold PL_utf8_tofold
-#define PL_Iutf8_tolower PL_utf8_tolower
-#define PL_Iutf8_totitle PL_utf8_totitle
-#define PL_Iutf8_toupper PL_utf8_toupper
-#define PL_Iutf8_upper PL_utf8_upper
-#define PL_Iutf8_xdigit PL_utf8_xdigit
-#define PL_Iutf8_xidcont PL_utf8_xidcont
-#define PL_Iutf8_xidstart PL_utf8_xidstart
-#define PL_Iutf8cache PL_utf8cache
-#define PL_Iutf8locale PL_utf8locale
-#define PL_Iwarnhook PL_warnhook
-#define PL_Iwatchaddr PL_watchaddr
-#define PL_Iwatchok PL_watchok
-#define PL_Ixmlfp PL_xmlfp
-
-
#endif /* MULTIPLICITY */
#if defined(PERL_GLOBAL_STRUCT)
-#define PL_No (my_vars->GNo)
-#define PL_GNo (my_vars->GNo)
-#define PL_Yes (my_vars->GYes)
-#define PL_GYes (my_vars->GYes)
#define PL_appctx (my_vars->Gappctx)
#define PL_Gappctx (my_vars->Gappctx)
-#define PL_charclass (my_vars->Gcharclass)
-#define PL_Gcharclass (my_vars->Gcharclass)
#define PL_check (my_vars->Gcheck)
#define PL_Gcheck (my_vars->Gcheck)
+#define PL_check_mutex (my_vars->Gcheck_mutex)
+#define PL_Gcheck_mutex (my_vars->Gcheck_mutex)
#define PL_csighandlerp (my_vars->Gcsighandlerp)
#define PL_Gcsighandlerp (my_vars->Gcsighandlerp)
#define PL_curinterp (my_vars->Gcurinterp)
@@ -729,16 +371,12 @@
#define PL_Gdollarzero_mutex (my_vars->Gdollarzero_mutex)
#define PL_fold_locale (my_vars->Gfold_locale)
#define PL_Gfold_locale (my_vars->Gfold_locale)
-#define PL_global_struct_size (my_vars->Gglobal_struct_size)
-#define PL_Gglobal_struct_size (my_vars->Gglobal_struct_size)
-#define PL_hexdigit (my_vars->Ghexdigit)
-#define PL_Ghexdigit (my_vars->Ghexdigit)
+#define PL_hash_seed (my_vars->Ghash_seed)
+#define PL_Ghash_seed (my_vars->Ghash_seed)
+#define PL_hash_seed_set (my_vars->Ghash_seed_set)
+#define PL_Ghash_seed_set (my_vars->Ghash_seed_set)
#define PL_hints_mutex (my_vars->Ghints_mutex)
#define PL_Ghints_mutex (my_vars->Ghints_mutex)
-#define PL_interp_size (my_vars->Ginterp_size)
-#define PL_Ginterp_size (my_vars->Ginterp_size)
-#define PL_interp_size_5_10_0 (my_vars->Ginterp_size_5_10_0)
-#define PL_Ginterp_size_5_10_0 (my_vars->Ginterp_size_5_10_0)
#define PL_keyword_plugin (my_vars->Gkeyword_plugin)
#define PL_Gkeyword_plugin (my_vars->Gkeyword_plugin)
#define PL_malloc_mutex (my_vars->Gmalloc_mutex)
@@ -755,8 +393,6 @@
#define PL_Gop_seq (my_vars->Gop_seq)
#define PL_op_sequence (my_vars->Gop_sequence)
#define PL_Gop_sequence (my_vars->Gop_sequence)
-#define PL_patleave (my_vars->Gpatleave)
-#define PL_Gpatleave (my_vars->Gpatleave)
#define PL_perlio_debug_fd (my_vars->Gperlio_debug_fd)
#define PL_Gperlio_debug_fd (my_vars->Gperlio_debug_fd)
#define PL_perlio_fd_refcnt (my_vars->Gperlio_fd_refcnt)
@@ -767,14 +403,10 @@
#define PL_Gperlio_mutex (my_vars->Gperlio_mutex)
#define PL_ppaddr (my_vars->Gppaddr)
#define PL_Gppaddr (my_vars->Gppaddr)
-#define PL_revision (my_vars->Grevision)
-#define PL_Grevision (my_vars->Grevision)
-#define PL_runops_dbg (my_vars->Grunops_dbg)
-#define PL_Grunops_dbg (my_vars->Grunops_dbg)
-#define PL_runops_std (my_vars->Grunops_std)
-#define PL_Grunops_std (my_vars->Grunops_std)
+#ifdef OS2
#define PL_sh_path (my_vars->Gsh_path)
#define PL_Gsh_path (my_vars->Gsh_path)
+#endif
#define PL_sig_defaulting (my_vars->Gsig_defaulting)
#define PL_Gsig_defaulting (my_vars->Gsig_defaulting)
#define PL_sig_handlers_initted (my_vars->Gsig_handlers_initted)
@@ -785,8 +417,6 @@
#define PL_Gsig_trapped (my_vars->Gsig_trapped)
#define PL_sigfpe_saved (my_vars->Gsigfpe_saved)
#define PL_Gsigfpe_saved (my_vars->Gsigfpe_saved)
-#define PL_subversion (my_vars->Gsubversion)
-#define PL_Gsubversion (my_vars->Gsubversion)
#define PL_sv_placeholder (my_vars->Gsv_placeholder)
#define PL_Gsv_placeholder (my_vars->Gsv_placeholder)
#define PL_thr_key (my_vars->Gthr_key)
@@ -795,62 +425,11 @@
#define PL_Gtimesbase (my_vars->Gtimesbase)
#define PL_use_safe_putenv (my_vars->Guse_safe_putenv)
#define PL_Guse_safe_putenv (my_vars->Guse_safe_putenv)
-#define PL_version (my_vars->Gversion)
-#define PL_Gversion (my_vars->Gversion)
#define PL_veto_cleanup (my_vars->Gveto_cleanup)
#define PL_Gveto_cleanup (my_vars->Gveto_cleanup)
#define PL_watch_pvx (my_vars->Gwatch_pvx)
#define PL_Gwatch_pvx (my_vars->Gwatch_pvx)
-#else /* !PERL_GLOBAL_STRUCT */
-
-#define PL_GNo PL_No
-#define PL_GYes PL_Yes
-#define PL_Gappctx PL_appctx
-#define PL_Gcharclass PL_charclass
-#define PL_Gcheck PL_check
-#define PL_Gcsighandlerp PL_csighandlerp
-#define PL_Gcurinterp PL_curinterp
-#define PL_Gdo_undump PL_do_undump
-#define PL_Gdollarzero_mutex PL_dollarzero_mutex
-#define PL_Gfold_locale PL_fold_locale
-#define PL_Gglobal_struct_size PL_global_struct_size
-#define PL_Ghexdigit PL_hexdigit
-#define PL_Ghints_mutex PL_hints_mutex
-#define PL_Ginterp_size PL_interp_size
-#define PL_Ginterp_size_5_10_0 PL_interp_size_5_10_0
-#define PL_Gkeyword_plugin PL_keyword_plugin
-#define PL_Gmalloc_mutex PL_malloc_mutex
-#define PL_Gmmap_page_size PL_mmap_page_size
-#define PL_Gmy_ctx_mutex PL_my_ctx_mutex
-#define PL_Gmy_cxt_index PL_my_cxt_index
-#define PL_Gop_mutex PL_op_mutex
-#define PL_Gop_seq PL_op_seq
-#define PL_Gop_sequence PL_op_sequence
-#define PL_Gpatleave PL_patleave
-#define PL_Gperlio_debug_fd PL_perlio_debug_fd
-#define PL_Gperlio_fd_refcnt PL_perlio_fd_refcnt
-#define PL_Gperlio_fd_refcnt_size PL_perlio_fd_refcnt_size
-#define PL_Gperlio_mutex PL_perlio_mutex
-#define PL_Gppaddr PL_ppaddr
-#define PL_Grevision PL_revision
-#define PL_Grunops_dbg PL_runops_dbg
-#define PL_Grunops_std PL_runops_std
-#define PL_Gsh_path PL_sh_path
-#define PL_Gsig_defaulting PL_sig_defaulting
-#define PL_Gsig_handlers_initted PL_sig_handlers_initted
-#define PL_Gsig_ignoring PL_sig_ignoring
-#define PL_Gsig_trapped PL_sig_trapped
-#define PL_Gsigfpe_saved PL_sigfpe_saved
-#define PL_Gsubversion PL_subversion
-#define PL_Gsv_placeholder PL_sv_placeholder
-#define PL_Gthr_key PL_thr_key
-#define PL_Gtimesbase PL_timesbase
-#define PL_Guse_safe_putenv PL_use_safe_putenv
-#define PL_Gversion PL_version
-#define PL_Gveto_cleanup PL_veto_cleanup
-#define PL_Gwatch_pvx PL_watch_pvx
-
#endif /* PERL_GLOBAL_STRUCT */
/* ex: set ro: */
Property changes on: trunk/contrib/perl/embedvar.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/fakesdio.h
===================================================================
--- trunk/contrib/perl/fakesdio.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/fakesdio.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -126,8 +126,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/fakesdio.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/fakethr.h
===================================================================
--- trunk/contrib/perl/fakethr.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/fakethr.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -68,8 +68,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/fakethr.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Copied: trunk/contrib/perl/feature.h (from rev 6437, vendor/perl/5.18.1/feature.h)
===================================================================
--- trunk/contrib/perl/feature.h (rev 0)
+++ trunk/contrib/perl/feature.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -0,0 +1,133 @@
+/* -*- buffer-read-only: t -*-
+ !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ This file is built by regen/feature.pl.
+ Any changes made here will be lost!
+ */
+
+
+#if defined(PERL_CORE) || defined (PERL_EXT)
+
+#define HINT_FEATURE_SHIFT 26
+
+#define FEATURE_BUNDLE_DEFAULT 0
+#define FEATURE_BUNDLE_510 1
+#define FEATURE_BUNDLE_511 2
+#define FEATURE_BUNDLE_515 3
+#define FEATURE_BUNDLE_CUSTOM (HINT_FEATURE_MASK >> HINT_FEATURE_SHIFT)
+
+#define CURRENT_HINTS \
+ (PL_curcop == &PL_compiling ? PL_hints : PL_curcop->cop_hints)
+#define CURRENT_FEATURE_BUNDLE \
+ ((CURRENT_HINTS & HINT_FEATURE_MASK) >> HINT_FEATURE_SHIFT)
+
+/* Avoid using ... && Perl_feature_is_enabled(...) as that triggers a bug in
+ the HP-UX cc on PA-RISC */
+#define FEATURE_IS_ENABLED(name) \
+ ((CURRENT_HINTS \
+ & HINT_LOCALIZE_HH) \
+ ? Perl_feature_is_enabled(aTHX_ STR_WITH_LEN(name)) : FALSE)
+/* The longest string we pass in. */
+#define MAX_FEATURE_LEN (sizeof("evalbytes")-1)
+
+#define FEATURE_FC_IS_ENABLED \
+ ( \
+ CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_515 \
+ || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \
+ FEATURE_IS_ENABLED("fc")) \
+ )
+
+#define FEATURE_SAY_IS_ENABLED \
+ ( \
+ (CURRENT_FEATURE_BUNDLE >= FEATURE_BUNDLE_510 && \
+ CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_515) \
+ || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \
+ FEATURE_IS_ENABLED("say")) \
+ )
+
+#define FEATURE_STATE_IS_ENABLED \
+ ( \
+ (CURRENT_FEATURE_BUNDLE >= FEATURE_BUNDLE_510 && \
+ CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_515) \
+ || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \
+ FEATURE_IS_ENABLED("state")) \
+ )
+
+#define FEATURE_SWITCH_IS_ENABLED \
+ ( \
+ (CURRENT_FEATURE_BUNDLE >= FEATURE_BUNDLE_510 && \
+ CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_515) \
+ || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \
+ FEATURE_IS_ENABLED("switch")) \
+ )
+
+#define FEATURE_EVALBYTES_IS_ENABLED \
+ ( \
+ CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_515 \
+ || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \
+ FEATURE_IS_ENABLED("evalbytes")) \
+ )
+
+#define FEATURE_ARYBASE_IS_ENABLED \
+ ( \
+ CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_511 \
+ || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \
+ FEATURE_IS_ENABLED("arybase")) \
+ )
+
+#define FEATURE___SUB___IS_ENABLED \
+ ( \
+ CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_515 \
+ || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \
+ FEATURE_IS_ENABLED("__SUB__")) \
+ )
+
+#define FEATURE_LEXSUBS_IS_ENABLED \
+ ( \
+ CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \
+ FEATURE_IS_ENABLED("lexsubs") \
+ )
+
+#define FEATURE_UNIEVAL_IS_ENABLED \
+ ( \
+ CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_515 \
+ || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \
+ FEATURE_IS_ENABLED("unieval")) \
+ )
+
+#define FEATURE_UNICODE_IS_ENABLED \
+ ( \
+ (CURRENT_FEATURE_BUNDLE >= FEATURE_BUNDLE_511 && \
+ CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_515) \
+ || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \
+ FEATURE_IS_ENABLED("unicode")) \
+ )
+
+
+#endif /* PERL_CORE or PERL_EXT */
+
+#ifdef PERL_IN_OP_C
+PERL_STATIC_INLINE void
+S_enable_feature_bundle(pTHX_ SV *ver)
+{
+ SV *comp_ver = sv_newmortal();
+ PL_hints = (PL_hints &~ HINT_FEATURE_MASK)
+ | (
+ (sv_setnv(comp_ver, 5.015),
+ vcmp(ver, upg_version(comp_ver, FALSE)) >= 0)
+ ? FEATURE_BUNDLE_515 :
+ (sv_setnv(comp_ver, 5.011),
+ vcmp(ver, upg_version(comp_ver, FALSE)) >= 0)
+ ? FEATURE_BUNDLE_511 :
+ (sv_setnv(comp_ver, 5.009005),
+ vcmp(ver, upg_version(comp_ver, FALSE)) >= 0)
+ ? FEATURE_BUNDLE_510 :
+ FEATURE_BUNDLE_DEFAULT
+ ) << HINT_FEATURE_SHIFT;
+ /* special case */
+ assert(PL_curcop == &PL_compiling);
+ if (FEATURE_UNICODE_IS_ENABLED) PL_hints |= HINT_UNI_8_BIT;
+ else PL_hints &= ~HINT_UNI_8_BIT;
+}
+#endif /* PERL_IN_OP_C */
+
+/* ex: set ro: */
Modified: trunk/contrib/perl/form.h
===================================================================
--- trunk/contrib/perl/form.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/form.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -1,6 +1,6 @@
/* form.h
*
- * Copyright (C) 1991, 1992, 1993, 2000, 2004 by Larry Wall and others
+ * Copyright (C) 1991, 1992, 1993, 2000, 2004, 2011 by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
@@ -7,21 +7,21 @@
*
*/
-#define FF_END 0
-#define FF_LINEMARK 1
-#define FF_LITERAL 2
-#define FF_SKIP 3
-#define FF_FETCH 4
-#define FF_CHECKNL 5
-#define FF_CHECKCHOP 6
-#define FF_SPACE 7
-#define FF_HALFSPACE 8
-#define FF_ITEM 9
-#define FF_CHOP 10
-#define FF_LINEGLOB 11
-#define FF_DECIMAL 12
-#define FF_NEWLINE 13
-#define FF_BLANK 14
-#define FF_MORE 15
-#define FF_0DECIMAL 16
-#define FF_LINESNGL 17
+#define FF_END 0 /* tidy up, then return */
+#define FF_LINEMARK 1 /* start (or end) of a line */
+#define FF_LITERAL 2 /* append <arg> literal chars */
+#define FF_SKIP 3 /* skip <arg> chars in format */
+#define FF_FETCH 4 /* get next item and set field size to <arg> */
+#define FF_CHECKNL 5 /* find max len of item (up to \n) that fits field */
+#define FF_CHECKCHOP 6 /* like CHECKNL, but up to highest split point */
+#define FF_SPACE 7 /* append padding space (diff of field, item size) */
+#define FF_HALFSPACE 8 /* like FF_SPACE, but only append half as many */
+#define FF_ITEM 9 /* append a text item, while blanking ctrl chars */
+#define FF_CHOP 10 /* (for ^*) chop the current item */
+#define FF_LINEGLOB 11 /* process @* */
+#define FF_DECIMAL 12 /* do @##, ^##, where <arg>=(precision|flags) */
+#define FF_NEWLINE 13 /* delete trailing spaces, then append \n */
+#define FF_BLANK 14 /* for arg==0: do '~'; for arg>0 : do '~~' */
+#define FF_MORE 15 /* replace long end of string with '...' */
+#define FF_0DECIMAL 16 /* like FF_DECIMAL but for 0### */
+#define FF_LINESNGL 17 /* process ^* */
Property changes on: trunk/contrib/perl/form.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/generate_uudmap.c
===================================================================
--- trunk/contrib/perl/generate_uudmap.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/generate_uudmap.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -12,17 +12,51 @@
"hello world" won't port easily to it. */
#include <errno.h>
-void output_block_to_file(const char *progname, const char *filename,
- const char *block, size_t count) {
- FILE *const out = fopen(filename, "w");
+struct mg_data_raw_t {
+ unsigned char type;
+ const char *value;
+ const char *comment;
+};
- if (!out) {
- fprintf(stderr, "%s: Could not open '%s': %s\n", progname, filename,
- strerror(errno));
- exit(1);
+static struct mg_data_raw_t mg_data_raw[] = {
+#ifdef WIN32
+# include "..\mg_raw.h"
+#else
+# include "mg_raw.h"
+#endif
+ {0, 0, 0}
+};
+
+struct mg_data_t {
+ const char *value;
+ const char *comment;
+};
+
+static struct mg_data_t mg_data[256];
+
+static void
+format_mg_data(FILE *out, const void *thing, size_t count) {
+ const struct mg_data_t *p = (const struct mg_data_t *)thing;
+
+ while (1) {
+ if (p->value) {
+ fprintf(out, " %s\n %s", p->comment, p->value);
+ } else {
+ fputs(" 0", out);
+ }
+ ++p;
+ if (!--count)
+ break;
+ fputs(",\n", out);
}
+ fputc('\n', out);
+}
- fputs("{\n ", out);
+static void
+format_char_block(FILE *out, const void *thing, size_t count) {
+ const char *block = (const char *)thing;
+
+ fputs(" ", out);
while (count--) {
fprintf(out, "%d", *block);
block++;
@@ -33,8 +67,25 @@
}
}
}
- fputs("\n}\n", out);
+ fputc('\n', out);
+}
+static void
+output_to_file(const char *progname, const char *filename,
+ void (format_function)(FILE *out, const void *thing, size_t count),
+ const void *thing, size_t count) {
+ FILE *const out = fopen(filename, "w");
+
+ if (!out) {
+ fprintf(stderr, "%s: Could not open '%s': %s\n", progname, filename,
+ strerror(errno));
+ exit(1);
+ }
+
+ fputs("{\n", out);
+ format_function(out, thing, count);
+ fputs("}\n", out);
+
if (fclose(out)) {
fprintf(stderr, "%s: Could not close '%s': %s\n", progname, filename,
strerror(errno));
@@ -55,9 +106,11 @@
int main(int argc, char **argv) {
size_t i;
int bits;
+ struct mg_data_raw_t *p = mg_data_raw;
- if (argc < 3 || argv[1][0] == '\0' || argv[2][0] == '\0') {
- fprintf(stderr, "Usage: %s uudemap.h bitcount.h\n", argv[0]);
+ if (argc < 4 || argv[1][0] == '\0' || argv[2][0] == '\0'
+ || argv[3][0] == '\0') {
+ fprintf(stderr, "Usage: %s uudemap.h bitcount.h mg_data.h\n", argv[0]);
return 1;
}
@@ -69,7 +122,8 @@
*/
PL_uudmap[(U8)' '] = 0;
- output_block_to_file(argv[0], argv[1], PL_uudmap, sizeof(PL_uudmap));
+ output_to_file(argv[0], argv[1], &format_char_block,
+ (const void *)PL_uudmap, sizeof(PL_uudmap));
for (bits = 1; bits < 256; bits++) {
if (bits & 1) PL_bitcount[bits]++;
@@ -82,9 +136,17 @@
if (bits & 128) PL_bitcount[bits]++;
}
- output_block_to_file(argv[0], argv[2], PL_bitcount, sizeof(PL_bitcount));
+ output_to_file(argv[0], argv[2], &format_char_block,
+ (const void *)PL_bitcount, sizeof(PL_bitcount));
+ while (p->value) {
+ mg_data[p->type].value = p->value;
+ mg_data[p->type].comment = p->comment;
+ ++p;
+ }
+
+ output_to_file(argv[0], argv[3], &format_mg_data,
+ (const void *)mg_data, sizeof(mg_data)/sizeof(mg_data[0]));
+
return 0;
}
-
-
Property changes on: trunk/contrib/perl/generate_uudmap.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/genpacksizetables.pl
===================================================================
--- trunk/contrib/perl/genpacksizetables.pl 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/genpacksizetables.pl 2013-12-02 21:18:17 UTC (rev 6438)
Property changes on: trunk/contrib/perl/genpacksizetables.pl
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/globals.c
===================================================================
--- trunk/contrib/perl/globals.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/globals.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -1,6 +1,6 @@
/* globals.c
*
- * Copyright (C) 1995, 1999, 2000, 2001, by Larry Wall and others
+ * Copyright (C) 1995, 1999, 2000, 2001, 2008 by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
@@ -37,8 +37,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/globals.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/gv.c
===================================================================
--- trunk/contrib/perl/gv.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/gv.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -16,7 +16,7 @@
* history of Middle-earth and Over-heaven and of the Sundering Seas,'
* laughed Pippin.
*
- * [p.599 of _The Lord of the Rings_, III/xi: "The Palant\xEDr"]
+ * [p.599 of _The Lord of the Rings_, III/xi: "The PalantÃr"]
*/
/*
@@ -36,6 +36,8 @@
#define PERL_IN_GV_C
#include "perl.h"
#include "overload.c"
+#include "keywords.h"
+#include "feature.h"
static const char S_autoload[] = "AUTOLOAD";
static const STRLEN S_autolen = sizeof(S_autoload)-1;
@@ -58,18 +60,14 @@
* if it walks like a dirhandle, then let's assume that
* this is a dirhandle.
*/
- what = PL_op->op_type == OP_READDIR ||
- PL_op->op_type == OP_TELLDIR ||
- PL_op->op_type == OP_SEEKDIR ||
- PL_op->op_type == OP_REWINDDIR ||
- PL_op->op_type == OP_CLOSEDIR ?
+ what = OP_IS_DIRHOP(PL_op->op_type) ?
"dirhandle" : "filehandle";
- /* diag_listed_as: Bad symbol for filehandle */
} else if (type == SVt_PVHV) {
what = "hash";
} else {
what = type == SVt_PVAV ? "array" : "scalar";
}
+ /* diag_listed_as: Bad symbol for filehandle */
Perl_croak(aTHX_ "Bad symbol for %s", what);
}
@@ -85,6 +83,9 @@
if (!*where)
*where = newSV_type(type);
+ if (type == SVt_PVAV && GvNAMELEN(gv) == 3
+ && strnEQ(GvNAME(gv), "ISA", 3))
+ sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0);
return gv;
}
@@ -161,17 +162,38 @@
{
GP *gp;
U32 hash;
-#ifdef USE_ITHREADS
- const char *const file
- = (PL_curcop && CopFILE(PL_curcop)) ? CopFILE(PL_curcop) : "";
- const STRLEN len = strlen(file);
-#else
- SV *const temp_sv = CopFILESV(PL_curcop);
const char *file;
STRLEN len;
+#ifndef USE_ITHREADS
+ SV * temp_sv;
+#endif
+ dVAR;
PERL_ARGS_ASSERT_NEWGP;
+ Newxz(gp, 1, GP);
+ gp->gp_egv = gv; /* allow compiler to reuse gv after this */
+#ifndef PERL_DONT_CREATE_GVSV
+ gp->gp_sv = newSV(0);
+#endif
+#ifdef USE_ITHREADS
+ if (PL_curcop) {
+ gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */
+ if (CopFILE(PL_curcop)) {
+ file = CopFILE(PL_curcop);
+ len = strlen(file);
+ }
+ else goto no_file;
+ }
+ else {
+ no_file:
+ file = "";
+ len = 0;
+ }
+#else
+ if(PL_curcop)
+ gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */
+ temp_sv = CopFILESV(PL_curcop);
if (temp_sv) {
file = SvPVX(temp_sv);
len = SvCUR(temp_sv);
@@ -182,18 +204,7 @@
#endif
PERL_HASH(hash, file, len);
-
- Newxz(gp, 1, GP);
-
-#ifndef PERL_DONT_CREATE_GVSV
- gp->gp_sv = newSV(0);
-#endif
-
- gp->gp_line = PL_curcop ? CopLINE(PL_curcop) : 0;
- /* XXX Ideally this cast would be replaced with a change to const char*
- in the struct. */
gp->gp_file_hek = share_hek(file, len, hash);
- gp->gp_egv = gv;
gp->gp_refcnt = 1;
return gp;
@@ -206,6 +217,7 @@
Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
{
GV * const oldgv = CvGV(cv);
+ HEK *hek;
PERL_ARGS_ASSERT_CVGV_SET;
if (oldgv == gv)
@@ -213,7 +225,7 @@
if (oldgv) {
if (CvCVGV_RC(cv)) {
- SvREFCNT_dec(oldgv);
+ SvREFCNT_dec_NN(oldgv);
CvCVGV_RC_off(cv);
}
else {
@@ -220,8 +232,9 @@
sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv));
}
}
+ else if ((hek = CvNAME_HEK(cv))) unshare_hek(hek);
- SvANY(cv)->xcv_gv = gv;
+ SvANY(cv)->xcv_gv_u.xcv_gv = gv;
assert(!CvCVGV_RC(cv));
if (!gv)
@@ -251,18 +264,83 @@
Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv));
}
+/*
+=for apidoc gv_init_pvn
+
+Converts a scalar into a typeglob. This is an incoercible typeglob;
+assigning a reference to it will assign to one of its slots, instead of
+overwriting it as happens with typeglobs created by SvSetSV. Converting
+any scalar that is SvOK() may produce unpredictable results and is reserved
+for perl's internal use.
+
+C<gv> is the scalar to be converted.
+
+C<stash> is the parent stash/package, if any.
+
+C<name> and C<len> give the name. The name must be unqualified;
+that is, it must not include the package name. If C<gv> is a
+stash element, it is the caller's responsibility to ensure that the name
+passed to this function matches the name of the element. If it does not
+match, perl's internal bookkeeping will get out of sync.
+
+C<flags> can be set to SVf_UTF8 if C<name> is a UTF8 string, or
+the return value of SvUTF8(sv). It can also take the
+GV_ADDMULTI flag, which means to pretend that the GV has been
+seen before (i.e., suppress "Used once" warnings).
+
+=for apidoc gv_init
+
+The old form of gv_init_pvn(). It does not work with UTF8 strings, as it
+has no flags parameter. If the C<multi> parameter is set, the
+GV_ADDMULTI flag will be passed to gv_init_pvn().
+
+=for apidoc gv_init_pv
+
+Same as gv_init_pvn(), but takes a nul-terminated string for the name
+instead of separate char * and length parameters.
+
+=for apidoc gv_init_sv
+
+Same as gv_init_pvn(), but takes an SV * for the name instead of separate
+char * and length parameters. C<flags> is currently unused.
+
+=cut
+*/
+
void
-Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
+Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, U32 flags)
{
+ char *namepv;
+ STRLEN namelen;
+ PERL_ARGS_ASSERT_GV_INIT_SV;
+ namepv = SvPV(namesv, namelen);
+ if (SvUTF8(namesv))
+ flags |= SVf_UTF8;
+ gv_init_pvn(gv, stash, namepv, namelen, flags);
+}
+
+void
+Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, U32 flags)
+{
+ PERL_ARGS_ASSERT_GV_INIT_PV;
+ gv_init_pvn(gv, stash, name, strlen(name), flags);
+}
+
+void
+Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flags)
+{
dVAR;
const U32 old_type = SvTYPE(gv);
const bool doproto = old_type > SVt_NULL;
- char * const proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
+ char * const proto = (doproto && SvPOK(gv))
+ ? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv))
+ : NULL;
const STRLEN protolen = proto ? SvCUR(gv) : 0;
+ const U32 proto_utf8 = proto ? SvUTF8(gv) : 0;
SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
- PERL_ARGS_ASSERT_GV_INIT;
+ PERL_ARGS_ASSERT_GV_INIT_PVN;
assert (!(proto && has_constant));
if (has_constant) {
@@ -302,54 +380,39 @@
GvSTASH(gv) = stash;
if (stash)
Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
- gv_name_set(gv, name, len, GV_ADD);
- if (multi || doproto) /* doproto means it _was_ mentioned */
- GvMULTI_on(gv);
- if (doproto) { /* Replicate part of newSUB here. */
+ gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ));
+ if (flags & GV_ADDMULTI || doproto) /* doproto means it */
+ GvMULTI_on(gv); /* _was_ mentioned */
+ if (doproto) {
CV *cv;
- ENTER;
if (has_constant) {
- char *name0 = NULL;
- if (name[len])
- /* newCONSTSUB doesn't take a len arg, so make sure we
- * give it a \0-terminated string */
- name0 = savepvn(name,len);
-
/* newCONSTSUB takes ownership of the reference from us. */
- cv = newCONSTSUB(stash, (name0 ? name0 : name), has_constant);
+ cv = newCONSTSUB_flags(stash, name, len, flags, has_constant);
/* In case op.c:S_process_special_blocks stole it: */
if (!GvCV(gv))
GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv));
assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */
- if (name0)
- Safefree(name0);
/* If this reference was a copy of another, then the subroutine
must have been "imported", by a Perl space assignment to a GV
from a reference to CV. */
if (exported_constant)
GvIMPORTED_CV_on(gv);
+ CvSTASH_set(cv, PL_curstash); /* XXX Why is this needed? */
} else {
- (void) start_subparse(0,0); /* Create empty CV in compcv. */
- cv = PL_compcv;
- GvCV_set(gv,cv);
+ cv = newSTUB(gv,1);
}
- LEAVE;
-
- mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub ASDF::baz($); *ASDF::baz = \&Foo::bar */
- CvGV_set(cv, gv);
- CvFILE_set_from_cop(cv, PL_curcop);
- CvSTASH_set(cv, PL_curstash);
if (proto) {
sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
SV_HAS_TRAILING_NUL);
+ if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
}
}
}
STATIC void
-S_gv_init_sv(pTHX_ GV *gv, const svtype sv_type)
+S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
{
- PERL_ARGS_ASSERT_GV_INIT_SV;
+ PERL_ARGS_ASSERT_GV_INIT_SVTYPE;
switch (sv_type) {
case SVt_PVIO:
@@ -377,9 +440,183 @@
}
}
+static void core_xsub(pTHX_ CV* cv);
+
+static GV *
+S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
+ const char * const name, const STRLEN len)
+{
+ const int code = keyword(name, len, 1);
+ static const char file[] = __FILE__;
+ CV *cv, *oldcompcv = NULL;
+ int opnum = 0;
+ bool ampable = TRUE; /* &{}-able */
+ COP *oldcurcop = NULL;
+ yy_parser *oldparser = NULL;
+ I32 oldsavestack_ix = 0;
+
+ assert(gv || stash);
+ assert(name);
+
+ if (!code) return NULL; /* Not a keyword */
+ switch (code < 0 ? -code : code) {
+ /* no support for \&CORE::infix;
+ no support for funcs that do not parse like funcs */
+ case KEY___DATA__: case KEY___END__: case KEY_and: case KEY_AUTOLOAD:
+ case KEY_BEGIN : case KEY_CHECK : case KEY_cmp: case KEY_CORE :
+ case KEY_default : case KEY_DESTROY:
+ case KEY_do : case KEY_dump : case KEY_else : case KEY_elsif :
+ case KEY_END : case KEY_eq : case KEY_eval :
+ case KEY_for : case KEY_foreach: case KEY_format: case KEY_ge :
+ case KEY_given : case KEY_goto : case KEY_grep :
+ case KEY_gt : case KEY_if: case KEY_INIT: case KEY_last: case KEY_le:
+ case KEY_local: case KEY_lt: case KEY_m : case KEY_map : case KEY_my:
+ case KEY_ne : case KEY_next : case KEY_no: case KEY_or: case KEY_our:
+ case KEY_package: case KEY_print: case KEY_printf:
+ case KEY_q : case KEY_qq : case KEY_qr : case KEY_qw :
+ case KEY_qx : case KEY_redo : case KEY_require: case KEY_return:
+ case KEY_s : case KEY_say : case KEY_sort :
+ case KEY_state: case KEY_sub :
+ case KEY_tr : case KEY_UNITCHECK: case KEY_unless:
+ case KEY_until: case KEY_use : case KEY_when : case KEY_while :
+ case KEY_x : case KEY_xor : case KEY_y :
+ return NULL;
+ case KEY_chdir:
+ case KEY_chomp: case KEY_chop: case KEY_defined: case KEY_delete:
+ case KEY_each : case KEY_eof : case KEY_exec : case KEY_exists:
+ case KEY_keys:
+ case KEY_lstat:
+ case KEY_pop:
+ case KEY_push:
+ case KEY_shift:
+ case KEY_splice: case KEY_split:
+ case KEY_stat:
+ case KEY_system:
+ case KEY_truncate: case KEY_unlink:
+ case KEY_unshift:
+ case KEY_values:
+ ampable = FALSE;
+ }
+ if (!gv) {
+ gv = (GV *)newSV(0);
+ gv_init(gv, stash, name, len, TRUE);
+ }
+ GvMULTI_on(gv);
+ if (ampable) {
+ ENTER;
+ oldcurcop = PL_curcop;
+ oldparser = PL_parser;
+ lex_start(NULL, NULL, 0);
+ oldcompcv = PL_compcv;
+ PL_compcv = NULL; /* Prevent start_subparse from setting
+ CvOUTSIDE. */
+ oldsavestack_ix = start_subparse(FALSE,0);
+ cv = PL_compcv;
+ }
+ else {
+ /* Avoid calling newXS, as it calls us, and things start to
+ get hairy. */
+ cv = MUTABLE_CV(newSV_type(SVt_PVCV));
+ GvCV_set(gv,cv);
+ GvCVGEN(gv) = 0;
+ mro_method_changed_in(GvSTASH(gv));
+ CvISXSUB_on(cv);
+ CvXSUB(cv) = core_xsub;
+ }
+ CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
+ from PL_curcop. */
+ (void)gv_fetchfile(file);
+ CvFILE(cv) = (char *)file;
+ /* XXX This is inefficient, as doing things this order causes
+ a prototype check in newATTRSUB. But we have to do
+ it this order as we need an op number before calling
+ new ATTRSUB. */
+ (void)core_prototype((SV *)cv, name, code, &opnum);
+ if (stash)
+ (void)hv_store(stash,name,len,(SV *)gv,0);
+ if (ampable) {
+#ifdef DEBUGGING
+ CV *orig_cv = cv;
+#endif
+ CvLVALUE_on(cv);
+ /* newATTRSUB will free the CV and return NULL if we're still
+ compiling after a syntax error */
+ if ((cv = newATTRSUB_flags(
+ oldsavestack_ix, (OP *)gv,
+ NULL,NULL,
+ coresub_op(
+ opnum
+ ? newSVuv((UV)opnum)
+ : newSVpvn(name,len),
+ code, opnum
+ ),
+ 1
+ )) != NULL) {
+ assert(GvCV(gv) == orig_cv);
+ if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS
+ && opnum != OP_UNDEF)
+ CvLVALUE_off(cv); /* Now *that* was a neat trick. */
+ }
+ LEAVE;
+ PL_parser = oldparser;
+ PL_curcop = oldcurcop;
+ PL_compcv = oldcompcv;
+ }
+ if (cv) {
+ SV *opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL;
+ cv_set_call_checker(
+ cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv
+ );
+ SvREFCNT_dec(opnumsv);
+ }
+
+ return gv;
+}
+
/*
=for apidoc gv_fetchmeth
+Like L</gv_fetchmeth_pvn>, but lacks a flags parameter.
+
+=for apidoc gv_fetchmeth_sv
+
+Exactly like L</gv_fetchmeth_pvn>, but takes the name string in the form
+of an SV instead of a string/length pair.
+
+=cut
+*/
+
+GV *
+Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
+{
+ char *namepv;
+ STRLEN namelen;
+ PERL_ARGS_ASSERT_GV_FETCHMETH_SV;
+ namepv = SvPV(namesv, namelen);
+ if (SvUTF8(namesv))
+ flags |= SVf_UTF8;
+ return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags);
+}
+
+/*
+=for apidoc gv_fetchmeth_pv
+
+Exactly like L</gv_fetchmeth_pvn>, but takes a nul-terminated string
+instead of a string/length pair.
+
+=cut
+*/
+
+GV *
+Perl_gv_fetchmeth_pv(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
+{
+ PERL_ARGS_ASSERT_GV_FETCHMETH_PV;
+ return gv_fetchmeth_pvn(stash, name, strlen(name), level, flags);
+}
+
+/*
+=for apidoc gv_fetchmeth_pvn
+
Returns the glob with the given C<name> and a defined subroutine or
C<NULL>. The glob lives in the given C<stash>, or in the stashes
accessible via @ISA and UNIVERSAL::.
@@ -389,7 +626,12 @@
which in the case of success contains an alias for the subroutine, and sets
up caching info for this glob.
-This function grants C<"SUPER"> token as a postfix of the stash name. The
+The only significant values for C<flags> are GV_SUPER and SVf_UTF8.
+
+GV_SUPER indicates that we want to look up the method in the superclasses
+of the C<stash>.
+
+The
GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
visible to Perl code. So when calling C<call_sv>, you should not use
the GV directly; instead, you should use the method's CV, which can be
@@ -401,7 +643,7 @@
/* NOTE: No support for tied ISA */
GV *
-Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
+Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
{
dVAR;
GV** gvp;
@@ -408,18 +650,17 @@
AV* linear_av;
SV** linear_svp;
SV* linear_sv;
- HV* cstash;
+ HV* cstash, *cachestash;
GV* candidate = NULL;
CV* cand_cv = NULL;
- CV* old_cv;
GV* topgv = NULL;
const char *hvname;
I32 create = (level >= 0) ? 1 : 0;
I32 items;
- STRLEN packlen;
U32 topgen_cmp;
+ U32 is_utf8 = flags & SVf_UTF8;
- PERL_ARGS_ASSERT_GV_FETCHMETH;
+ PERL_ARGS_ASSERT_GV_FETCHMETH_PVN;
/* UNIVERSAL methods should be callable without a stash */
if (!stash) {
@@ -437,17 +678,26 @@
assert(hvname);
assert(name);
- DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) );
+ DEBUG_o( Perl_deb(aTHX_ "Looking for %smethod %s in package %s\n",
+ flags & GV_SUPER ? "SUPER " : "",name,hvname) );
topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
+ if (flags & GV_SUPER) {
+ if (!HvAUX(stash)->xhv_super) HvAUX(stash)->xhv_super = newHV();
+ cachestash = HvAUX(stash)->xhv_super;
+ }
+ else cachestash = stash;
+
/* check locally for a real method or a cache entry */
- gvp = (GV**)hv_fetch(stash, name, len, create);
+ gvp = (GV**)hv_fetch(cachestash, name, is_utf8 ? -(I32)len : (I32)len,
+ create);
if(gvp) {
topgv = *gvp;
+ have_gv:
assert(topgv);
if (SvTYPE(topgv) != SVt_PVGV)
- gv_init(topgv, stash, name, len, TRUE);
+ gv_init_pvn(topgv, stash, name, len, GV_ADDMULTI|is_utf8);
if ((cand_cv = GvCV(topgv))) {
/* If genuine method or valid cache entry, use it */
if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
@@ -455,7 +705,7 @@
}
else {
/* stale cache entry, junk it and move on */
- SvREFCNT_dec(cand_cv);
+ SvREFCNT_dec_NN(cand_cv);
GvCV_set(topgv, NULL);
cand_cv = NULL;
GvCVGEN(topgv) = 0;
@@ -465,19 +715,14 @@
/* cache indicates no such method definitively */
return 0;
}
+ else if (stash == cachestash
+ && len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4
+ && strnEQ(hvname, "CORE", 4)
+ && S_maybe_add_coresub(aTHX_ NULL,topgv,name,len))
+ goto have_gv;
}
- packlen = HvNAMELEN_get(stash);
- if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
- HV* basestash;
- packlen -= 7;
- basestash = gv_stashpvn(hvname, packlen, GV_ADD);
- linear_av = mro_get_linear_isa(basestash);
- }
- else {
- linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
- }
-
+ linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
items = AvFILLp(linear_av); /* no +1, to skip over self */
while (items--) {
@@ -486,18 +731,32 @@
cstash = gv_stashsv(linear_sv, 0);
if (!cstash) {
- Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
- SVfARG(linear_sv), hvname);
+ Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "Can't locate package %"SVf" for @%"HEKf"::ISA",
+ SVfARG(linear_sv),
+ HEKfARG(HvNAME_HEK(stash)));
continue;
}
assert(cstash);
- gvp = (GV**)hv_fetch(cstash, name, len, 0);
- if (!gvp) continue;
- candidate = *gvp;
+ gvp = (GV**)hv_fetch(cstash, name, is_utf8 ? -(I32)len : (I32)len, 0);
+ if (!gvp) {
+ if (len > 1 && HvNAMELEN_get(cstash) == 4) {
+ const char *hvname = HvNAME(cstash); assert(hvname);
+ if (strnEQ(hvname, "CORE", 4)
+ && (candidate =
+ S_maybe_add_coresub(aTHX_ cstash,NULL,name,len)
+ ))
+ goto have_candidate;
+ }
+ continue;
+ }
+ else candidate = *gvp;
+ have_candidate:
assert(candidate);
- if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, cstash, name, len, TRUE);
+ if (SvTYPE(candidate) != SVt_PVGV)
+ gv_init_pvn(candidate, cstash, name, len, GV_ADDMULTI|is_utf8);
if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
/*
* Found real method, cache method in topgv if:
@@ -505,7 +764,8 @@
* 2. method isn't a stub (else AUTOLOAD fails spectacularly)
*/
if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
- if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv);
+ CV *old_cv = GvCV(topgv);
+ SvREFCNT_dec(old_cv);
SvREFCNT_inc_simple_void_NN(cand_cv);
GvCV_set(topgv, cand_cv);
GvCVGEN(topgv) = topgen_cmp;
@@ -516,11 +776,12 @@
/* Check UNIVERSAL without caching */
if(level == 0 || level == -1) {
- candidate = gv_fetchmeth(NULL, name, len, 1);
+ candidate = gv_fetchmeth_pvn(NULL, name, len, 1, flags &~GV_SUPER);
if(candidate) {
cand_cv = GvCV(candidate);
if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
- if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv);
+ CV *old_cv = GvCV(topgv);
+ SvREFCNT_dec(old_cv);
SvREFCNT_inc_simple_void_NN(cand_cv);
GvCV_set(topgv, cand_cv);
GvCVGEN(topgv) = topgen_cmp;
@@ -540,7 +801,49 @@
/*
=for apidoc gv_fetchmeth_autoload
-Same as gv_fetchmeth(), but looks for autoloaded subroutines too.
+This is the old form of L</gv_fetchmeth_pvn_autoload>, which has no flags
+parameter.
+
+=for apidoc gv_fetchmeth_sv_autoload
+
+Exactly like L</gv_fetchmeth_pvn_autoload>, but takes the name string in the form
+of an SV instead of a string/length pair.
+
+=cut
+*/
+
+GV *
+Perl_gv_fetchmeth_sv_autoload(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
+{
+ char *namepv;
+ STRLEN namelen;
+ PERL_ARGS_ASSERT_GV_FETCHMETH_SV_AUTOLOAD;
+ namepv = SvPV(namesv, namelen);
+ if (SvUTF8(namesv))
+ flags |= SVf_UTF8;
+ return gv_fetchmeth_pvn_autoload(stash, namepv, namelen, level, flags);
+}
+
+/*
+=for apidoc gv_fetchmeth_pv_autoload
+
+Exactly like L</gv_fetchmeth_pvn_autoload>, but takes a nul-terminated string
+instead of a string/length pair.
+
+=cut
+*/
+
+GV *
+Perl_gv_fetchmeth_pv_autoload(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
+{
+ PERL_ARGS_ASSERT_GV_FETCHMETH_PV_AUTOLOAD;
+ return gv_fetchmeth_pvn_autoload(stash, name, strlen(name), level, flags);
+}
+
+/*
+=for apidoc gv_fetchmeth_pvn_autoload
+
+Same as gv_fetchmeth_pvn(), but looks for autoloaded subroutines too.
Returns a glob for the subroutine.
For an autoloaded subroutine without a GV, will create a GV even
@@ -547,15 +850,17 @@
if C<level < 0>. For an autoloaded subroutine without a stub, GvCV()
of the result may be zero.
+Currently, the only significant value for C<flags> is SVf_UTF8.
+
=cut
*/
GV *
-Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
+Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
{
- GV *gv = gv_fetchmeth(stash, name, len, level);
+ GV *gv = gv_fetchmeth_pvn(stash, name, len, level, flags);
- PERL_ARGS_ASSERT_GV_FETCHMETH_AUTOLOAD;
+ PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD;
if (!gv) {
CV *cv;
@@ -565,7 +870,7 @@
return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */
if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
return NULL;
- if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
+ if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags)))
return NULL;
cv = GvCV(gv);
if (!(CvROOT(cv) || CvXSUB(cv)))
@@ -572,8 +877,9 @@
return NULL;
/* Have an autoload */
if (level < 0) /* Cannot do without a stub */
- gv_fetchmeth(stash, name, len, 0);
- gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
+ gv_fetchmeth_pvn(stash, name, len, 0, flags);
+ gvp = (GV**)hv_fetch(stash, name,
+ (flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0));
if (!gvp)
return NULL;
return *gvp;
@@ -609,54 +915,40 @@
=cut
*/
-STATIC HV*
-S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen)
+GV *
+Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
{
- AV* superisa;
- GV** gvp;
- GV* gv;
- HV* stash;
+ PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
- PERL_ARGS_ASSERT_GV_GET_SUPER_PKG;
+ return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
+}
- stash = gv_stashpvn(name, namelen, 0);
- if(stash) return stash;
-
- /* If we must create it, give it an @ISA array containing
- the real package this SUPER is for, so that it's tied
- into the cache invalidation code correctly */
- stash = gv_stashpvn(name, namelen, GV_ADD);
- gvp = (GV**)hv_fetchs(stash, "ISA", TRUE);
- gv = *gvp;
- gv_init(gv, stash, "ISA", 3, TRUE);
- superisa = GvAVn(gv);
- GvMULTI_on(gv);
- sv_magic(MUTABLE_SV(superisa), MUTABLE_SV(gv), PERL_MAGIC_isa, NULL, 0);
-#ifdef USE_ITHREADS
- av_push(superisa, newSVpv(CopSTASHPV(PL_curcop), 0));
-#else
- av_push(superisa, newSVhek(CopSTASH(PL_curcop)
- ? HvNAME_HEK(CopSTASH(PL_curcop)) : NULL));
-#endif
-
- return stash;
+GV *
+Perl_gv_fetchmethod_sv_flags(pTHX_ HV *stash, SV *namesv, U32 flags)
+{
+ char *namepv;
+ STRLEN namelen;
+ PERL_ARGS_ASSERT_GV_FETCHMETHOD_SV_FLAGS;
+ namepv = SvPV(namesv, namelen);
+ if (SvUTF8(namesv))
+ flags |= SVf_UTF8;
+ return gv_fetchmethod_pvn_flags(stash, namepv, namelen, flags);
}
GV *
-Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
+Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags)
{
- PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
-
- return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
+ PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS;
+ return gv_fetchmethod_pvn_flags(stash, name, strlen(name), flags);
}
/* Don't merge this yet, as it's likely to get a len parameter, and possibly
even a U32 hash */
GV *
-Perl_gv_fetchmethod_flags(pTHX_ HV *stash, const char *name, U32 flags)
+Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
{
dVAR;
- register const char *nend;
+ const char *nend;
const char *nsplit = NULL;
GV* gv;
HV* ostash = stash;
@@ -664,8 +956,9 @@
SV *const error_report = MUTABLE_SV(stash);
const U32 autoload = flags & GV_AUTOLOAD;
const U32 do_croak = flags & GV_CROAK;
+ const U32 is_utf8 = flags & SVf_UTF8;
- PERL_ARGS_ASSERT_GV_FETCHMETHOD_FLAGS;
+ PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS;
if (SvTYPE(stash) < SVt_PVHV)
stash = NULL;
@@ -675,7 +968,7 @@
the error reporting code. */
}
- for (nend = name; *nend; nend++) {
+ for (nend = name; *nend || nend != (origname + len); nend++) {
if (*nend == '\'') {
nsplit = nend;
name = nend + 1;
@@ -688,33 +981,32 @@
if (nsplit) {
if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) {
/* ->SUPER::method should really be looked up in original stash */
- SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
- CopSTASHPV(PL_curcop)));
- /* __PACKAGE__::SUPER stash should be autovivified */
- stash = gv_get_super_pkg(SvPVX_const(tmpstr), SvCUR(tmpstr));
+ stash = CopSTASH(PL_curcop);
+ flags |= GV_SUPER;
DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
- origname, HvNAME_get(stash), name) );
+ origname, HvENAME_get(stash), name) );
}
+ else if ((nsplit - origname) >= 7 &&
+ strnEQ(nsplit - 7, "::SUPER", 7)) {
+ /* don't autovifify if ->NoSuchStash::SUPER::method */
+ stash = gv_stashpvn(origname, nsplit - origname - 7, is_utf8);
+ if (stash) flags |= GV_SUPER;
+ }
else {
/* don't autovifify if ->NoSuchStash::method */
- stash = gv_stashpvn(origname, nsplit - origname, 0);
-
- /* however, explicit calls to Pkg::SUPER::method may
- happen, and may require autovivification to work */
- if (!stash && (nsplit - origname) >= 7 &&
- strnEQ(nsplit - 7, "::SUPER", 7) &&
- gv_stashpvn(origname, nsplit - origname - 7, 0))
- stash = gv_get_super_pkg(origname, nsplit - origname);
+ stash = gv_stashpvn(origname, nsplit - origname, is_utf8);
}
ostash = stash;
}
- gv = gv_fetchmeth(stash, name, nend - name, 0);
+ gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
if (!gv) {
if (strEQ(name,"import") || strEQ(name,"unimport"))
gv = MUTABLE_GV(&PL_sv_yes);
else if (autoload)
- gv = gv_autoload4(ostash, name, nend - name, TRUE);
+ gv = gv_autoload_pvn(
+ ostash, name, nend - name, GV_AUTOLOAD_ISMETHOD|flags
+ );
if (!gv && do_croak) {
/* Right now this is exclusively for the benefit of S_method_common
in pp_hot.c */
@@ -729,29 +1021,33 @@
HV_FETCH_ISEXISTS, NULL, 0)
) {
require_pv("IO/File.pm");
- gv = gv_fetchmeth(stash, name, nend - name, 0);
+ gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
if (gv)
return gv;
}
Perl_croak(aTHX_
- "Can't locate object method \"%s\" via package \"%.*s\"",
- name, (int)HvNAMELEN_get(stash), HvNAME_get(stash));
+ "Can't locate object method \"%"SVf
+ "\" via package \"%"HEKf"\"",
+ SVfARG(newSVpvn_flags(name, nend - name,
+ SVs_TEMP | is_utf8)),
+ HEKfARG(HvNAME_HEK(stash)));
}
else {
- STRLEN packlen;
- const char *packname;
+ SV* packnamesv;
if (nsplit) {
- packlen = nsplit - origname;
- packname = origname;
+ packnamesv = newSVpvn_flags(origname, nsplit - origname,
+ SVs_TEMP | is_utf8);
} else {
- packname = SvPV_const(error_report, packlen);
+ packnamesv = sv_2mortal(newSVsv(error_report));
}
Perl_croak(aTHX_
- "Can't locate object method \"%s\" via package \"%.*s\""
- " (perhaps you forgot to load \"%.*s\"?)",
- name, (int)packlen, packname, (int)packlen, packname);
+ "Can't locate object method \"%"SVf"\" via package \"%"SVf"\""
+ " (perhaps you forgot to load \"%"SVf"\"?)",
+ SVfARG(newSVpvn_flags(name, nend - name,
+ SVs_TEMP | is_utf8)),
+ SVfARG(packnamesv), SVfARG(packnamesv));
}
}
}
@@ -768,8 +1064,10 @@
if (GvCV(stubgv) != cv) /* orphaned import */
stubgv = gv;
}
- autogv = gv_autoload4(GvSTASH(stubgv),
- GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
+ autogv = gv_autoload_pvn(GvSTASH(stubgv),
+ GvNAME(stubgv), GvNAMELEN(stubgv),
+ GV_AUTOLOAD_ISMETHOD
+ | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0));
if (autogv)
gv = autogv;
}
@@ -779,8 +1077,27 @@
}
GV*
-Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
+Perl_gv_autoload_sv(pTHX_ HV *stash, SV* namesv, U32 flags)
{
+ char *namepv;
+ STRLEN namelen;
+ PERL_ARGS_ASSERT_GV_AUTOLOAD_SV;
+ namepv = SvPV(namesv, namelen);
+ if (SvUTF8(namesv))
+ flags |= SVf_UTF8;
+ return gv_autoload_pvn(stash, namepv, namelen, flags);
+}
+
+GV*
+Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags)
+{
+ PERL_ARGS_ASSERT_GV_AUTOLOAD_PV;
+ return gv_autoload_pvn(stash, namepv, strlen(namepv), flags);
+}
+
+GV*
+Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
+{
dVAR;
GV* gv;
CV* cv;
@@ -787,24 +1104,26 @@
HV* varstash;
GV* vargv;
SV* varsv;
- const char *packname = "";
- STRLEN packname_len = 0;
+ SV *packname = NULL;
+ U32 is_utf8 = flags & SVf_UTF8 ? SVf_UTF8 : 0;
- PERL_ARGS_ASSERT_GV_AUTOLOAD4;
+ PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN;
if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
return NULL;
if (stash) {
if (SvTYPE(stash) < SVt_PVHV) {
- packname = SvPV_const(MUTABLE_SV(stash), packname_len);
+ STRLEN packname_len = 0;
+ const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len);
+ packname = newSVpvn_flags(packname_ptr, packname_len,
+ SVs_TEMP | SvUTF8(stash));
stash = NULL;
}
- else {
- packname = HvNAME_get(stash);
- packname_len = HvNAMELEN_get(stash);
- }
+ else
+ packname = sv_2mortal(newSVhek(HvNAME_HEK(stash)));
+ if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER");
}
- if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
+ if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, is_utf8)))
return NULL;
cv = GvCV(gv);
@@ -814,22 +1133,66 @@
/*
* Inheriting AUTOLOAD for non-methods works ... for now.
*/
- if (!method && (GvCVGEN(gv) || GvSTASH(gv) != stash)
+ if (
+ !(flags & GV_AUTOLOAD_ISMETHOD)
+ && (GvCVGEN(gv) || GvSTASH(gv) != stash)
)
Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
- packname, (int)len, name);
+ "Use of inherited AUTOLOAD for non-method %"SVf"::%"SVf"() is deprecated",
+ SVfARG(packname),
+ SVfARG(newSVpvn_flags(name, len, SVs_TEMP | is_utf8)));
if (CvISXSUB(cv)) {
- /* rather than lookup/init $AUTOLOAD here
- * only to have the XSUB do another lookup for $AUTOLOAD
- * and split that value on the last '::',
- * pass along the same data via some unused fields in the CV
+ /* Instead of forcing the XSUB do another lookup for $AUTOLOAD
+ * and split that value on the last '::', pass along the same data
+ * via the SvPVX field in the CV, and the stash in CvSTASH.
+ *
+ * Due to an unfortunate accident of history, the SvPVX field
+ * serves two purposes. It is also used for the subroutine's pro-
+ * type. Since SvPVX has been documented as returning the sub name
+ * for a long time, but not as returning the prototype, we have
+ * to preserve the SvPVX AUTOLOAD behaviour and put the prototype
+ * elsewhere.
+ *
+ * We put the prototype in the same allocated buffer, but after
+ * the sub name. The SvPOK flag indicates the presence of a proto-
+ * type. The CvAUTOLOAD flag indicates the presence of a sub name.
+ * If both flags are on, then SvLEN is used to indicate the end of
+ * the prototype (artificially lower than what is actually allo-
+ * cated), at the risk of having to reallocate a few bytes unneces-
+ * sarily--but that should happen very rarely, if ever.
+ *
+ * We use SvUTF8 for both prototypes and sub names, so if one is
+ * UTF8, the other must be upgraded.
*/
CvSTASH_set(cv, stash);
- SvPV_set(cv, (char *)name); /* cast to lose constness warning */
- SvCUR_set(cv, len);
- return gv;
+ if (SvPOK(cv)) { /* Ouch! */
+ SV * const tmpsv = newSVpvn_flags(name, len, is_utf8);
+ STRLEN ulen;
+ const char *proto = CvPROTO(cv);
+ assert(proto);
+ if (SvUTF8(cv))
+ sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2);
+ ulen = SvCUR(tmpsv);
+ SvCUR(tmpsv)++; /* include null in string */
+ sv_catpvn_flags(
+ tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv)
+ );
+ SvTEMP_on(tmpsv); /* Allow theft */
+ sv_setsv_nomg((SV *)cv, tmpsv);
+ SvTEMP_off(tmpsv);
+ SvREFCNT_dec_NN(tmpsv);
+ SvLEN(cv) = SvCUR(cv) + 1;
+ SvCUR(cv) = ulen;
+ }
+ else {
+ sv_setpvn((SV *)cv, name, len);
+ SvPOK_off(cv);
+ if (is_utf8)
+ SvUTF8_on(cv);
+ else SvUTF8_off(cv);
+ }
+ CvAUTOLOAD_on(cv);
}
/*
@@ -843,7 +1206,7 @@
ENTER;
if (!isGV(vargv)) {
- gv_init(vargv, varstash, S_autoload, S_autolen, FALSE);
+ gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0);
#ifdef PERL_DONT_CREATE_GVSV
GvSV(vargv) = newSV(0);
#endif
@@ -850,11 +1213,18 @@
}
LEAVE;
varsv = GvSVn(vargv);
- sv_setpvn(varsv, packname, packname_len);
+ SvTAINTED_off(varsv); /* previous $AUTOLOAD taint is obsolete */
+ /* XXX: this process is not careful to avoid extra magic gets and sets; tied $AUTOLOAD will get noise */
+ sv_setsv(varsv, packname);
sv_catpvs(varsv, "::");
/* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */
- sv_catpvn_mg(varsv, name, len);
+ sv_catpvn_flags(
+ varsv, name, len,
+ SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES)
+ );
+ if (is_utf8)
+ SvUTF8_on(varsv);
return gv;
}
@@ -879,29 +1249,30 @@
PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
- if (!stash || !(gv_fetchmethod(stash, methpv))) {
+ if (!stash || !(gv_fetchmethod_autoload(stash, methpv, FALSE))) {
SV *module = newSVsv(namesv);
char varname = *varpv; /* varpv might be clobbered by load_module,
so save it. For the moment it's always
a single char. */
+ const char type = varname == '[' ? '$' : '%';
dSP;
ENTER;
+ SAVEFREESV(namesv);
if ( flags & 1 )
save_scalar(gv);
PUSHSTACKi(PERLSI_MAGIC);
Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
POPSTACK;
- LEAVE;
- SPAGAIN;
stash = gv_stashsv(namesv, 0);
if (!stash)
- Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" is not available",
- varname, SVfARG(namesv));
+ Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" is not available",
+ type, varname, SVfARG(namesv));
else if (!gv_fetchmethod(stash, methpv))
- Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" does not support method %s",
- varname, SVfARG(namesv), methpv);
+ Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" does not support method %s",
+ type, varname, SVfARG(namesv), methpv);
+ LEAVE;
}
- SvREFCNT_dec(namesv);
+ else SvREFCNT_dec_NN(namesv);
return stash;
}
@@ -931,7 +1302,17 @@
C<flags> is 0 (or any other setting that does not create packages) then NULL
is returned.
+Flags may be one of:
+ GV_ADD
+ SVf_UTF8
+ GV_NOADD_NOINIT
+ GV_NOINIT
+ GV_NOEXPAND
+ GV_ADDMG
+
+The most important of which are probably GV_ADD and SVf_UTF8.
+
=cut
*/
@@ -960,8 +1341,9 @@
return NULL;
stash = GvHV(tmpgv);
if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
+ assert(stash);
if (!HvNAME_get(stash)) {
- hv_name_set(stash, name, namelen, 0);
+ hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 );
/* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
/* If the containing stash has multiple effective
@@ -969,7 +1351,6 @@
if (HvAUX(GvSTASH(tmpgv))->xhv_name_count)
mro_package_moved(stash, NULL, tmpgv, 1);
}
- assert(stash);
return stash;
}
@@ -989,7 +1370,7 @@
PERL_ARGS_ASSERT_GV_STASHSV;
- return gv_stashpvn(ptr, len, flags);
+ return gv_stashpvn(ptr, len, flags | SvUTF8(sv));
}
@@ -1002,7 +1383,8 @@
GV *
Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
STRLEN len;
- const char * const nambeg = SvPV_const(name, len);
+ const char * const nambeg =
+ SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC);
PERL_ARGS_ASSERT_GV_FETCHSV;
return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
}
@@ -1020,32 +1402,22 @@
NULL, 0);
}
-STATIC void
-S_gv_magicalize_overload(pTHX_ GV *gv)
-{
- HV* hv;
-
- PERL_ARGS_ASSERT_GV_MAGICALIZE_OVERLOAD;
-
- hv = GvHVn(gv);
- GvMULTI_on(gv);
- hv_magic(hv, NULL, PERL_MAGIC_overload);
-}
-
GV *
Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
const svtype sv_type)
{
dVAR;
- register const char *name = nambeg;
- register GV *gv = NULL;
+ const char *name = nambeg;
+ GV *gv = NULL;
GV**gvp;
I32 len;
- register const char *name_cursor;
+ const char *name_cursor;
HV *stash = NULL;
const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
const I32 no_expand = flags & GV_NOEXPAND;
const I32 add = flags & ~GV_NOADD_MASK;
+ const U32 is_utf8 = flags & SVf_UTF8;
+ bool addmg = !!(flags & GV_ADDMG);
const char *const name_end = nambeg + full_len;
const char *const name_em1 = name_end - 1;
U32 faking_it;
@@ -1058,15 +1430,16 @@
goto no_stash;
}
- if (full_len > 2 && *name == '*' && isALPHA(name[1])) {
+ if (full_len > 2 && *name == '*' && isIDFIRST_lazy_if(name + 1, is_utf8)) {
/* accidental stringify on a GV? */
name++;
}
for (name_cursor = name; name_cursor < name_end; name_cursor++) {
- if ((*name_cursor == ':' && name_cursor < name_em1
+ if (name_cursor < name_em1 &&
+ ((*name_cursor == ':'
&& name_cursor[1] == ':')
- || (*name_cursor == '\'' && name_cursor[1]))
+ || *name_cursor == '\''))
{
if (!stash)
stash = PL_defstash;
@@ -1087,11 +1460,11 @@
tmpbuf[len++] = ':';
key = tmpbuf;
}
- gvp = (GV**)hv_fetch(stash, key, len, add);
+ gvp = (GV**)hv_fetch(stash, key, is_utf8 ? -len : len, add);
gv = gvp ? *gvp : NULL;
if (gv && gv != (const GV *)&PL_sv_undef) {
if (SvTYPE(gv) != SVt_PVGV)
- gv_init(gv, stash, key, len, (add & GV_ADDMULTI));
+ gv_init_pvn(gv, stash, key, len, (add & GV_ADDMULTI)|is_utf8);
else
GvMULTI_on(gv);
}
@@ -1104,7 +1477,13 @@
{
stash = GvHV(gv) = newHV();
if (!HvNAME_get(stash)) {
- hv_name_set(stash, nambeg, name_cursor-nambeg, 0);
+ if (GvSTASH(gv) == PL_defstash && len == 6
+ && strnEQ(name, "CORE", 4))
+ hv_name_set(stash, "CORE", 4, 0);
+ else
+ hv_name_set(
+ stash, nambeg, name_cursor-nambeg, is_utf8
+ );
/* If the containing stash has multiple effective
names, see that this one gets them, too. */
if (HvAUX(GvSTASH(gv))->xhv_name_count)
@@ -1112,7 +1491,7 @@
}
}
else if (!HvNAME_get(stash))
- hv_name_set(stash, nambeg, name_cursor - nambeg, 0);
+ hv_name_set(stash, nambeg, name_cursor - nambeg, is_utf8);
}
if (*name_cursor == ':')
@@ -1129,7 +1508,7 @@
if (!stash) {
no_stash:
- if (len && isIDFIRST_lazy(name)) {
+ if (len && isIDFIRST_lazy_if(name, is_utf8)) {
bool global = FALSE;
switch (len) {
@@ -1179,7 +1558,7 @@
!(len == 1 && sv_type == SVt_PV &&
(*name == 'a' || *name == 'b')) )
{
- gvp = (GV**)hv_fetch(stash,name,len,0);
+ gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,0);
if (!gvp ||
*gvp == (const GV *)&PL_sv_undef ||
SvTYPE(*gvp) != SVt_PVGV)
@@ -1190,17 +1569,18 @@
(sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
(sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
{
+ SV* namesv = newSVpvn_flags(name, len, SVs_TEMP | is_utf8);
/* diag_listed_as: Variable "%s" is not imported%s */
Perl_ck_warner_d(
aTHX_ packWARN(WARN_MISC),
- "Variable \"%c%s\" is not imported",
+ "Variable \"%c%"SVf"\" is not imported",
sv_type == SVt_PVAV ? '@' :
sv_type == SVt_PVHV ? '%' : '$',
- name);
+ SVfARG(namesv));
if (GvCVu(*gvp))
Perl_ck_warner_d(
aTHX_ packWARN(WARN_MISC),
- "\t(Did you mean &%s instead?)\n", name
+ "\t(Did you mean &%"SVf" instead?)\n", SVfARG(namesv)
);
stash = NULL;
}
@@ -1216,15 +1596,17 @@
/* By this point we should have a stash and a name */
if (!stash) {
- if (add) {
+ if (add && !PL_in_clean_all) {
+ SV * const namesv = newSVpvn_flags(name, len, is_utf8);
SV * const err = Perl_mess(aTHX_
- "Global symbol \"%s%s\" requires explicit package name",
+ "Global symbol \"%s%"SVf"\" requires explicit package name",
(sv_type == SVt_PV ? "$"
: sv_type == SVt_PVAV ? "@"
: sv_type == SVt_PVHV ? "%"
- : ""), name);
+ : ""), SVfARG(namesv));
GV *gv;
- if (USE_UTF8_IN_NAMES)
+ SvREFCNT_dec_NN(namesv);
+ if (is_utf8)
SvUTF8_on(err);
qerror(err);
gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
@@ -1241,20 +1623,58 @@
if (!SvREFCNT(stash)) /* symbol table under destruction */
return NULL;
- gvp = (GV**)hv_fetch(stash,name,len,add);
- if (!gvp || *gvp == (const GV *)&PL_sv_undef)
- return NULL;
- gv = *gvp;
+ gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,add);
+ if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
+ if (addmg) gv = (GV *)newSV(0);
+ else return NULL;
+ }
+ else gv = *gvp, addmg = 0;
+ /* From this point on, addmg means gv has not been inserted in the
+ symtab yet. */
+
if (SvTYPE(gv) == SVt_PVGV) {
if (add) {
GvMULTI_on(gv);
- gv_init_sv(gv, sv_type);
- if (len == 1 && stash == PL_defstash
- && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) {
+ gv_init_svtype(gv, sv_type);
+ /* You reach this path once the typeglob has already been created,
+ either by the same or a different sigil. If this path didn't
+ exist, then (say) referencing $! first, and %! second would
+ mean that %! was not handled correctly. */
+ if (len == 1 && stash == PL_defstash) {
+ if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
if (*name == '!')
require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
else if (*name == '-' || *name == '+')
require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
+ } else if (sv_type == SVt_PV) {
+ if (*name == '*' || *name == '#') {
+ /* diag_listed_as: $* is no longer supported */
+ Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,
+ WARN_SYNTAX),
+ "$%c is no longer supported", *name);
+ }
+ }
+ if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
+ switch (*name) {
+ case '[':
+ require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
+ break;
+#ifdef PERL_SAWAMPERSAND
+ case '`':
+ PL_sawampersand |= SAWAMPERSAND_LEFT;
+ (void)GvSVn(gv);
+ break;
+ case '&':
+ PL_sawampersand |= SAWAMPERSAND_MIDDLE;
+ (void)GvSVn(gv);
+ break;
+ case '\'':
+ PL_sawampersand |= SAWAMPERSAND_RIGHT;
+ (void)GvSVn(gv);
+ break;
+#endif
+ }
+ }
}
else if (len == 3 && sv_type == SVt_PVAV
&& strnEQ(name, "ISA", 3)
@@ -1263,8 +1683,10 @@
}
return gv;
} else if (no_init) {
+ assert(!addmg);
return gv;
} else if (no_expand && SvROK(gv)) {
+ assert(!addmg);
return gv;
}
@@ -1278,19 +1700,20 @@
faking_it = SvOK(gv);
if (add & GV_ADDWARN)
- Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
- gv_init(gv, stash, name, len, add & GV_ADDMULTI);
- gv_init_sv(gv, faking_it ? SVt_PVCV : sv_type);
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %"SVf" unexpectedly",
+ SVfARG(newSVpvn_flags(nambeg, name_end-nambeg, SVs_TEMP | is_utf8 )));
+ gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
- if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
- : (PL_dowarn & G_WARN_ON ) ) )
+ if ( isIDFIRST_lazy_if(name, is_utf8)
+ && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) : (PL_dowarn & G_WARN_ON ) ) )
GvMULTI_on(gv) ;
/* set up magic where warranted */
if (stash != PL_defstash) { /* not the main stash */
- /* We only have to check for four names here: EXPORT, ISA, OVERLOAD
- and VERSION. All the others apply only to the main stash. */
- if (len > 1) {
+ /* We only have to check for three names here: EXPORT, ISA
+ and VERSION. All the others apply only to the main stash or to
+ CORE (which is checked right after this). */
+ if (len > 2) {
const char * const name2 = name + 1;
switch (*name) {
case 'E':
@@ -1301,16 +1724,22 @@
if (strEQ(name2, "SA"))
gv_magicalize_isa(gv);
break;
- case 'O':
- if (strEQ(name2, "VERLOAD"))
- gv_magicalize_overload(gv);
- break;
case 'V':
if (strEQ(name2, "ERSION"))
GvMULTI_on(gv);
break;
+ default:
+ goto try_core;
}
+ goto add_magical_gv;
}
+ try_core:
+ if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
+ /* Avoid null warning: */
+ const char * const stashname = HvNAME(stash); assert(stashname);
+ if (strnEQ(stashname, "CORE", 4))
+ S_maybe_add_coresub(aTHX_ 0, gv, name, len);
+ }
}
else if (len > 1) {
#ifndef EBCDIC
@@ -1342,11 +1771,6 @@
gv_magicalize_isa(gv);
}
break;
- case 'O':
- if (strEQ(name2, "VERLOAD")) {
- gv_magicalize_overload(gv);
- }
- break;
case 'S':
if (strEQ(name2, "IG")) {
HV *hv;
@@ -1394,6 +1818,10 @@
if (strEQ(name2, "LOBAL_PHASE"))
goto ro_magicalize;
break;
+ case '\014': /* $^LAST_FH */
+ if (strEQ(name2, "AST_FH"))
+ goto ro_magicalize;
+ break;
case '\015': /* $^MATCH */
if (strEQ(name2, "ATCH"))
goto magicalize;
@@ -1436,7 +1864,7 @@
/* This snippet is taken from is_gv_magical */
const char *end = name + len;
while (--end > name) {
- if (!isDIGIT(*end)) return gv;
+ if (!isDIGIT(*end)) goto add_magical_gv;
}
goto magicalize;
}
@@ -1449,14 +1877,21 @@
case '&': /* $& */
case '`': /* $` */
case '\'': /* $' */
- if (
+#ifdef PERL_SAWAMPERSAND
+ if (!(
sv_type == SVt_PVAV ||
sv_type == SVt_PVHV ||
sv_type == SVt_PVCV ||
sv_type == SVt_PVFM ||
sv_type == SVt_PVIO
- ) { break; }
- PL_sawampersand = TRUE;
+ )) { PL_sawampersand |=
+ (*name == '`')
+ ? SAWAMPERSAND_LEFT
+ : (*name == '&')
+ ? SAWAMPERSAND_MIDDLE
+ : SAWAMPERSAND_RIGHT;
+ }
+#endif
goto magicalize;
case ':': /* $: */
@@ -1477,7 +1912,11 @@
/* magicalization must be done before require_tie_mod is called */
if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
+ {
+ if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
+ addmg = 0;
require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
+ }
break;
case '-': /* $- */
@@ -1494,7 +1933,11 @@
SvREADONLY_on(av);
if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
+ {
+ if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
+ addmg = 0;
require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
+ }
break;
}
@@ -1501,13 +1944,10 @@
case '*': /* $* */
case '#': /* $# */
if (sv_type == SVt_PV)
+ /* diag_listed_as: $* is no longer supported */
Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"$%c is no longer supported", *name);
break;
- case '|': /* $| */
- sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
- goto magicalize;
-
case '\010': /* $^H */
{
HV *const hv = GvHVn(gv);
@@ -1514,6 +1954,15 @@
hv_magic(hv, NULL, PERL_MAGIC_hints);
}
goto magicalize;
+ case '[': /* $[ */
+ if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
+ && FEATURE_ARYBASE_IS_ENABLED) {
+ if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
+ require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
+ addmg = 0;
+ }
+ else goto magicalize;
+ break;
case '\023': /* $^S */
ro_magicalize:
SvREADONLY_on(GvSVn(gv));
@@ -1528,7 +1977,6 @@
case '7': /* $7 */
case '8': /* $8 */
case '9': /* $9 */
- case '[': /* $[ */
case '^': /* $^ */
case '~': /* $~ */
case '=': /* $= */
@@ -1540,6 +1988,8 @@
case '>': /* $> */
case '\\': /* $\ */
case '/': /* $/ */
+ case '|': /* $| */
+ case '$': /* $$ */
case '\001': /* $^A */
case '\003': /* $^C */
case '\004': /* $^D */
@@ -1557,7 +2007,6 @@
case '\014': /* $^L */
sv_setpvs(GvSVn(gv),"\f");
- PL_formfeed = GvSVn(gv);
break;
case ';': /* $; */
sv_setpvs(GvSVn(gv),"\034");
@@ -1564,7 +2013,7 @@
break;
case ']': /* $] */
{
- SV * const sv = GvSVn(gv);
+ SV * const sv = GvSV(gv);
if (!sv_derived_from(PL_patchlevel, "version"))
upg_version(PL_patchlevel, TRUE);
GvSV(gv) = vnumify(PL_patchlevel);
@@ -1574,7 +2023,7 @@
break;
case '\026': /* $^V */
{
- SV * const sv = GvSVn(gv);
+ SV * const sv = GvSV(gv);
GvSV(gv) = new_version(PL_patchlevel);
SvREADONLY_on(GvSV(gv));
SvREFCNT_dec(sv);
@@ -1582,6 +2031,15 @@
break;
}
}
+ add_magical_gv:
+ if (addmg) {
+ if (GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv) || (
+ GvSV(gv) && (SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv)))
+ ))
+ (void)hv_store(stash,name,len,(SV *)gv,0);
+ else SvREFCNT_dec_NN(gv), gv = NULL;
+ }
+ if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
return gv;
}
@@ -1589,30 +2047,21 @@
Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
{
const char *name;
- STRLEN namelen;
const HV * const hv = GvSTASH(gv);
PERL_ARGS_ASSERT_GV_FULLNAME4;
- if (!hv) {
- SvOK_off(sv);
- return;
- }
sv_setpv(sv, prefix ? prefix : "");
- name = HvNAME_get(hv);
- if (name) {
- namelen = HvNAMELEN_get(hv);
- } else {
- name = "__ANON__";
- namelen = 8;
- }
-
- if (keepmain || strNE(name, "main")) {
- sv_catpvn(sv,name,namelen);
+ if (hv && (name = HvNAME(hv))) {
+ const STRLEN len = HvNAMELEN(hv);
+ if (keepmain || strnNE(name, "main", len)) {
+ sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
sv_catpvs(sv,"::");
+ }
}
- sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
+ else sv_catpvs(sv,"__ANON__::");
+ sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
}
void
@@ -1629,7 +2078,7 @@
Perl_gv_check(pTHX_ const HV *stash)
{
dVAR;
- register I32 i;
+ I32 i;
PERL_ARGS_ASSERT_GV_CHECK;
@@ -1638,7 +2087,7 @@
for (i = 0; i <= (I32) HvMAX(stash); i++) {
const HE *entry;
for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
- register GV *gv;
+ GV *gv;
HV *hv;
if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
(gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
@@ -1646,7 +2095,8 @@
if (hv != PL_defstash && hv != stash)
gv_check(hv); /* nested package */
}
- else if (isALPHA(*HeKEY(entry))) {
+ else if ( *HeKEY(entry) != '_'
+ && isIDFIRST_lazy_if(HeKEY(entry), HeUTF8(entry)) ) {
const char *file;
gv = MUTABLE_GV(HeVAL(entry));
if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
@@ -1660,8 +2110,10 @@
= gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
#endif
Perl_warner(aTHX_ packWARN(WARN_ONCE),
- "Name \"%s::%s\" used only once: possible typo",
- HvNAME_get(stash), GvNAME(gv));
+ "Name \"%"HEKf"::%"HEKf
+ "\" used only once: possible typo",
+ HEKfARG(HvNAME_HEK(stash)),
+ HEKfARG(GvNAME_HEK(gv)));
}
}
}
@@ -1668,14 +2120,16 @@
}
GV *
-Perl_newGVgen(pTHX_ const char *pack)
+Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
{
dVAR;
+ PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
- PERL_ARGS_ASSERT_NEWGVGEN;
-
- return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
- GV_ADD, SVt_PVGV);
+ return gv_fetchpv(Perl_form(aTHX_ "%"SVf"::_GEN_%ld",
+ SVfARG(newSVpvn_flags(pack, strlen(pack),
+ SVs_TEMP | flags)),
+ (long)PL_gensym++),
+ GV_ADD, SVt_PVGV);
}
/* hopefully this is only called on local symbol table entries */
@@ -1692,7 +2146,7 @@
/* If the GP they asked for a reference to contains
a method cache entry, clear it first, so that we
don't infect them with our cached entry */
- SvREFCNT_dec(gp->gp_cv);
+ SvREFCNT_dec_NN(gp->gp_cv);
gp->gp_cv = NULL;
gp->gp_cvgen = 0;
}
@@ -1749,10 +2203,12 @@
/* FIXME - another reference loop GV -> symtab -> GV ?
Somehow gp->gp_hv can end up pointing at freed garbage. */
if (hv && SvTYPE(hv) == SVt_PVHV) {
- const char *hvname = HvNAME_get(hv);
- if (PL_stashcache && hvname)
- (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(hv),
- G_DISCARD);
+ const HEK *hvname_hek = HvNAME_HEK(hv);
+ DEBUG_o(Perl_deb(aTHX_ "gp_free clearing PL_stashcache for '%"HEKf"'\n", hvname_hek));
+ if (PL_stashcache && hvname_hek)
+ (void)hv_delete(PL_stashcache, HEK_KEY(hvname_hek),
+ (HEK_UTF8(hvname_hek) ? -HEK_LEN(hvname_hek) : HEK_LEN(hvname_hek)),
+ G_DISCARD);
SvREFCNT_dec(hv);
}
SvREFCNT_dec(io);
@@ -1792,7 +2248,7 @@
for (i = 1; i < NofAMmeth; i++) {
CV * const cv = amtp->table[i];
if (cv) {
- SvREFCNT_dec(MUTABLE_SV(cv));
+ SvREFCNT_dec_NN(MUTABLE_SV(cv));
amtp->table[i] = NULL;
}
}
@@ -1821,9 +2277,8 @@
newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
if (mg) {
const AMT * const amtp = (AMT*)mg->mg_ptr;
- if (amtp->was_ok_am == PL_amagic_generation
- && amtp->was_ok_sub == newgen) {
- return AMT_OVERLOADED(amtp) ? 1 : 0;
+ if (amtp->was_ok_sub == newgen) {
+ return AMT_AMAGIC(amtp) ? 1 : 0;
}
sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
}
@@ -1831,24 +2286,26 @@
DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
Zero(&amt,1,AMT);
- amt.was_ok_am = PL_amagic_generation;
amt.was_ok_sub = newgen;
amt.fallback = AMGfallNO;
amt.flags = 0;
{
- int filled = 0, have_ovl = 0;
- int i, lim = 1;
+ int filled = 0;
+ int i;
/* Work with "fallback" key, which we assume to be first in PL_AMG_names */
/* Try to find via inheritance. */
- GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
+ GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
SV * const sv = gv ? GvSV(gv) : NULL;
CV* cv;
if (!gv)
- lim = DESTROY_amg; /* Skip overloading entries. */
+ {
+ if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0))
+ goto no_table;
+ }
#ifdef PERL_DONT_CREATE_GVSV
else if (!sv) {
NOOP; /* Equivalent to !SvTRUE and !SvOK */
@@ -1855,16 +2312,21 @@
}
#endif
else if (SvTRUE(sv))
+ /* don't need to set overloading here because fallback => 1
+ * is the default setting for classes without overloading */
amt.fallback=AMGfallYES;
- else if (SvOK(sv))
+ else if (SvOK(sv)) {
amt.fallback=AMGfallNEVER;
+ filled = 1;
+ }
+ else {
+ filled = 1;
+ }
- for (i = 1; i < lim; i++)
- amt.table[i] = NULL;
- for (; i < NofAMmeth; i++) {
+ for (i = 1; i < NofAMmeth; i++) {
const char * const cooky = PL_AMG_names[i];
/* Human-readable form, for debugging: */
- const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
+ const char * const cp = AMG_id2name(i);
const STRLEN l = PL_AMG_namelens[i];
DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
@@ -1876,15 +2338,13 @@
then we could have created stubs for "(+0" in A and C too.
But if B overloads "bool", we may want to use it for
numifying instead of C's "+0". */
- if (i >= DESTROY_amg)
- gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
- else /* Autoload taken care of below */
- gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
+ gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
cv = 0;
if (gv && (cv = GvCV(gv))) {
- const char *hvname;
- if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
- && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
+ if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){
+ const char * const hvname = HvNAME_get(GvSTASH(CvGV(cv)));
+ if (hvname && HEK_LEN(HvNAME_HEK(GvSTASH(CvGV(cv)))) == 8
+ && strEQ(hvname, "overload")) {
/* This is a hack to support autoloading..., while
knowing *which* methods were declared as overloaded. */
/* GvSV contains the name of the method. */
@@ -1893,10 +2353,9 @@
DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
"\" for overloaded \"%s\" in package \"%.256s\"\n",
- (void*)GvSV(gv), cp, hvname) );
+ (void*)GvSV(gv), cp, HvNAME(stash)) );
if (!gvsv || !SvPOK(gvsv)
- || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
- FALSE)))
+ || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
{
/* Can be an import stub (created by "can"). */
if (destructing) {
@@ -1903,22 +2362,28 @@
return -1;
}
else {
- const char * const name = (gvsv && SvPOK(gvsv)) ? SvPVX_const(gvsv) : "???";
- Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
- "in package \"%.256s\"",
+ const SV * const name = (gvsv && SvPOK(gvsv))
+ ? gvsv
+ : newSVpvs_flags("???", SVs_TEMP);
+ /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
+ Perl_croak(aTHX_ "%s method \"%"SVf256
+ "\" overloading \"%s\" "\
+ "in package \"%"HEKf256"\"",
(GvCVGEN(gv) ? "Stub found while resolving"
: "Can't resolve"),
- name, cp, hvname);
+ SVfARG(name), cp,
+ HEKfARG(
+ HvNAME_HEK(stash)
+ ));
}
}
cv = GvCV(gv = ngv);
+ }
}
DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
GvNAME(CvGV(cv))) );
filled = 1;
- if (i < DESTROY_amg)
- have_ovl = 1;
} else if (gv) { /* Autoloaded... */
cv = MUTABLE_CV(gv);
filled = 1;
@@ -1927,15 +2392,13 @@
}
if (filled) {
AMT_AMAGIC_on(&amt);
- if (have_ovl)
- AMT_OVERLOADED_on(&amt);
sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
(char*)&amt, sizeof(AMT));
- return have_ovl;
+ return TRUE;
}
}
/* Here we have no table: */
- /* no_table: */
+ no_table:
AMT_AMAGIC_off(&amt);
sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
(char*)&amt, sizeof(AMTS));
@@ -1961,25 +2424,13 @@
mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
if (!mg) {
do_update:
- /* If we're looking up a destructor to invoke, we must avoid
- * that Gv_AMupdate croaks, because we might be dying already */
- if (Gv_AMupdate(stash, cBOOL(id == DESTROY_amg)) == -1) {
- /* and if it didn't found a destructor, we fall back
- * to a simpler method that will only look for the
- * destructor instead of the whole magic */
- if (id == DESTROY_amg) {
- GV * const gv = gv_fetchmethod(stash, "DESTROY");
- if (gv)
- return GvCV(gv);
- }
+ if (Gv_AMupdate(stash, 0) == -1)
return NULL;
- }
mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
}
assert(mg);
amtp = (AMT*)mg->mg_ptr;
- if ( amtp->was_ok_am != PL_amagic_generation
- || amtp->was_ok_sub != newgen )
+ if ( amtp->was_ok_sub != newgen )
goto do_update;
if (AMT_AMAGIC(amtp)) {
CV * const ret = amtp->table[id];
@@ -2125,6 +2576,31 @@
return tmpsv ? tmpsv : ref;
}
+bool
+Perl_amagic_is_enabled(pTHX_ int method)
+{
+ SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
+
+ assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
+
+ if ( !lex_mask || !SvOK(lex_mask) )
+ /* overloading lexically disabled */
+ return FALSE;
+ else if ( lex_mask && SvPOK(lex_mask) ) {
+ /* we have an entry in the hints hash, check if method has been
+ * masked by overloading.pm */
+ STRLEN len;
+ const int offset = method / 8;
+ const int bit = method % 8;
+ char *pv = SvPV(lex_mask, len);
+
+ /* Bit set, so this overloading operator is disabled */
+ if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
+ return FALSE;
+ }
+ return TRUE;
+}
+
SV*
Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
{
@@ -2138,6 +2614,7 @@
int assign = AMGf_assign & flags;
const int assignshift = assign ? 1 : 0;
int use_default_op = 0;
+ int force_scalar = 0;
#ifdef DEBUGGING
int fl=0;
#endif
@@ -2146,27 +2623,11 @@
PERL_ARGS_ASSERT_AMAGIC_CALL;
if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
- SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
-
- if ( !lex_mask || !SvOK(lex_mask) )
- /* overloading lexically disabled */
- return NULL;
- else if ( lex_mask && SvPOK(lex_mask) ) {
- /* we have an entry in the hints hash, check if method has been
- * masked by overloading.pm */
- STRLEN len;
- const int offset = method / 8;
- const int bit = method % 8;
- char *pv = SvPV(lex_mask, len);
-
- /* Bit set, so this overloading operator is disabled */
- if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
- return NULL;
- }
+ if (!amagic_is_enabled(method)) return NULL;
}
if (!(AMGf_noleft & flags) && SvAMAGIC(left)
- && (stash = SvSTASH(SvRV(left)))
+ && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash)
&& (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
&& (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
@@ -2231,12 +2692,8 @@
*/
SV* const newref = newSVsv(tmpRef);
SvOBJECT_on(newref);
- /* As a bit of a source compatibility hack, SvAMAGIC() and
- friends dereference an RV, to behave the same was as when
- overloading was stored on the reference, not the referant.
- Hence we can't use SvAMAGIC_on()
- */
- SvFLAGS(newref) |= SVf_AMAGIC;
+ /* No need to do SvAMAGIC_on here, as SvAMAGIC macros
+ delegate to the stash. */
SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
return newref;
}
@@ -2293,7 +2750,7 @@
}
if (!cv) goto not_found;
} else if (!(AMGf_noright & flags) && SvAMAGIC(right)
- && (stash = SvSTASH(SvRV(right)))
+ && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash)
&& (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
&& (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
? (amtp = (AMT*)mg->mg_ptr)->table
@@ -2370,25 +2827,25 @@
SV *msg;
if (off==-1) off=method;
msg = sv_2mortal(Perl_newSVpvf(aTHX_
- "Operation \"%s\": no method found,%sargument %s%s%s%s",
- AMG_id2name(method + assignshift),
- (flags & AMGf_unary ? " " : "\n\tleft "),
- SvAMAGIC(left)?
- "in overloaded package ":
- "has no overloaded magic",
- SvAMAGIC(left)?
- HvNAME_get(SvSTASH(SvRV(left))):
- "",
- SvAMAGIC(right)?
- ",\n\tright argument in overloaded package ":
- (flags & AMGf_unary
- ? ""
- : ",\n\tright argument has no overloaded magic"),
- SvAMAGIC(right)?
- HvNAME_get(SvSTASH(SvRV(right))):
- ""));
+ "Operation \"%s\": no method found,%sargument %s%"SVf"%s%"SVf,
+ AMG_id2name(method + assignshift),
+ (flags & AMGf_unary ? " " : "\n\tleft "),
+ SvAMAGIC(left)?
+ "in overloaded package ":
+ "has no overloaded magic",
+ SvAMAGIC(left)?
+ SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
+ SVfARG(&PL_sv_no),
+ SvAMAGIC(right)?
+ ",\n\tright argument in overloaded package ":
+ (flags & AMGf_unary
+ ? ""
+ : ",\n\tright argument has no overloaded magic"),
+ SvAMAGIC(right)?
+ SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
+ SVfARG(&PL_sv_no)));
if (use_default_op) {
- DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
+ DEBUG_o( Perl_deb(aTHX_ "%"SVf, SVfARG(msg)) );
} else {
Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
}
@@ -2397,10 +2854,68 @@
force_cpy = force_cpy || assign;
}
}
+
+ switch (method) {
+ /* in these cases, we're calling '+' or '-' as a fallback for a ++ or --
+ * operation. we need this to return a value, so that it can be assigned
+ * later on, in the postpr block (case inc_amg/dec_amg), even if the
+ * increment or decrement was itself called in void context */
+ case inc_amg:
+ if (off == add_amg)
+ force_scalar = 1;
+ break;
+ case dec_amg:
+ if (off == subtr_amg)
+ force_scalar = 1;
+ break;
+ /* in these cases, we're calling an assignment variant of an operator
+ * (+= rather than +, for instance). regardless of whether it's a
+ * fallback or not, it always has to return a value, which will be
+ * assigned to the proper variable later */
+ case add_amg:
+ case subtr_amg:
+ case mult_amg:
+ case div_amg:
+ case modulo_amg:
+ case pow_amg:
+ case lshift_amg:
+ case rshift_amg:
+ case repeat_amg:
+ case concat_amg:
+ case band_amg:
+ case bor_amg:
+ case bxor_amg:
+ if (assign)
+ force_scalar = 1;
+ break;
+ /* the copy constructor always needs to return a value */
+ case copy_amg:
+ force_scalar = 1;
+ break;
+ /* because of the way these are implemented (they don't perform the
+ * dereferencing themselves, they return a reference that perl then
+ * dereferences later), they always have to be in scalar context */
+ case to_sv_amg:
+ case to_av_amg:
+ case to_hv_amg:
+ case to_gv_amg:
+ case to_cv_amg:
+ force_scalar = 1;
+ break;
+ /* these don't have an op of their own; they're triggered by their parent
+ * op, so the context there isn't meaningful ('$a and foo()' in void
+ * context still needs to pass scalar context on to $a's bool overload) */
+ case bool__amg:
+ case numer_amg:
+ case string_amg:
+ force_scalar = 1;
+ break;
+ }
+
#ifdef DEBUGGING
if (!notfound) {
DEBUG_o(Perl_deb(aTHX_
- "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
+ "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %"SVf"%s\n",
AMG_id2name(off),
method+assignshift==off? "" :
" (initially \"",
@@ -2410,7 +2925,7 @@
flags & AMGf_unary? "" :
lr==1 ? " for right argument": " for left argument",
flags & AMGf_unary? " for argument" : "",
- stash ? HvNAME_get(stash) : "null",
+ stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
fl? ",\n\tassignment variant used": "") );
}
#endif
@@ -2436,9 +2951,9 @@
/* off is method, method+assignshift, or a result of opcode substitution.
* In the latter case assignshift==0, so only notfound case is important.
*/
- if (( (method + assignshift == off)
+ if ( (lr == -1) && ( ( (method + assignshift == off)
&& (assign || (method == inc_amg) || (method == dec_amg)))
- || force_cpy)
+ || force_cpy) )
{
/* newSVsv does not behave as advertised, so we copy missing
* information by hand */
@@ -2447,7 +2962,7 @@
if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
SvRV_set(left, rv_copy);
SvSETMAGIC(left);
- SvREFCNT_dec(tmpRef);
+ SvREFCNT_dec_NN(tmpRef);
}
}
@@ -2456,13 +2971,30 @@
BINOP myop;
SV* res;
const bool oldcatch = CATCH_GET;
+ I32 oldmark, nret;
+ int gimme = force_scalar ? G_SCALAR : GIMME_V;
CATCH_SET(TRUE);
Zero(&myop, 1, BINOP);
myop.op_last = (OP *) &myop;
myop.op_next = NULL;
- myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
+ myop.op_flags = OPf_STACKED;
+ switch (gimme) {
+ case G_VOID:
+ myop.op_flags |= OPf_WANT_VOID;
+ break;
+ case G_ARRAY:
+ if (flags & AMGf_want_list) {
+ myop.op_flags |= OPf_WANT_LIST;
+ break;
+ }
+ /* FALLTHROUGH */
+ default:
+ myop.op_flags |= OPf_WANT_SCALAR;
+ break;
+ }
+
PUSHSTACKi(PERLSI_OVERLOAD);
ENTER;
SAVEOP();
@@ -2482,13 +3014,37 @@
}
PUSHs(MUTABLE_SV(cv));
PUTBACK;
+ oldmark = TOPMARK;
if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
CALLRUNOPS(aTHX);
LEAVE;
SPAGAIN;
+ nret = SP - (PL_stack_base + oldmark);
- res=POPs;
+ switch (gimme) {
+ case G_VOID:
+ /* returning NULL has another meaning, and we check the context
+ * at the call site too, so this can be differentiated from the
+ * scalar case */
+ res = &PL_sv_undef;
+ SP = PL_stack_base + oldmark;
+ break;
+ case G_ARRAY: {
+ if (flags & AMGf_want_list) {
+ res = sv_2mortal((SV *)newAV());
+ av_extend((AV *)res, nret);
+ while (nret--)
+ av_store((AV *)res, nret, POPs);
+ break;
+ }
+ /* FALLTHROUGH */
+ }
+ default:
+ res = POPs;
+ break;
+ }
+
PUTBACK;
POPSTACK;
CATCH_SET(oldcatch);
@@ -2534,148 +3090,6 @@
}
}
-/*
-=for apidoc is_gv_magical_sv
-
-Returns C<TRUE> if given the name of a magical GV.
-
-Currently only useful internally when determining if a GV should be
-created even in rvalue contexts.
-
-C<flags> is not used at present but available for future extension to
-allow selecting particular classes of magical variable.
-
-Currently assumes that C<name> is NUL terminated (as well as len being valid).
-This assumption is met by all callers within the perl core, which all pass
-pointers returned by SvPV.
-
-=cut
-*/
-
-bool
-Perl_is_gv_magical_sv(pTHX_ SV *const name_sv, U32 flags)
-{
- STRLEN len;
- const char *const name = SvPV_const(name_sv, len);
-
- PERL_UNUSED_ARG(flags);
- PERL_ARGS_ASSERT_IS_GV_MAGICAL_SV;
-
- if (len > 1) {
- const char * const name1 = name + 1;
- switch (*name) {
- case 'I':
- if (len == 3 && name[1] == 'S' && name[2] == 'A')
- goto yes;
- break;
- case 'O':
- if (len == 8 && strEQ(name1, "VERLOAD"))
- goto yes;
- break;
- case 'S':
- if (len == 3 && name[1] == 'I' && name[2] == 'G')
- goto yes;
- break;
- /* Using ${^...} variables is likely to be sufficiently rare that
- it seems sensible to avoid the space hit of also checking the
- length. */
- case '\017': /* ${^OPEN} */
- if (strEQ(name1, "PEN"))
- goto yes;
- break;
- case '\024': /* ${^TAINT} */
- if (strEQ(name1, "AINT"))
- goto yes;
- break;
- case '\025': /* ${^UNICODE} */
- if (strEQ(name1, "NICODE"))
- goto yes;
- if (strEQ(name1, "TF8LOCALE"))
- goto yes;
- break;
- case '\027': /* ${^WARNING_BITS} */
- if (strEQ(name1, "ARNING_BITS"))
- goto yes;
- break;
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- case '8':
- case '9':
- {
- const char *end = name + len;
- while (--end > name) {
- if (!isDIGIT(*end))
- return FALSE;
- }
- goto yes;
- }
- }
- } else {
- /* Because we're already assuming that name is NUL terminated
- below, we can treat an empty name as "\0" */
- switch (*name) {
- case '&':
- case '`':
- case '\'':
- case ':':
- case '?':
- case '!':
- case '-':
- case '#':
- case '[':
- case '^':
- case '~':
- case '=':
- case '%':
- case '.':
- case '(':
- case ')':
- case '<':
- case '>':
- case '\\':
- case '/':
- case '|':
- case '+':
- case ';':
- case ']':
- case '\001': /* $^A */
- case '\003': /* $^C */
- case '\004': /* $^D */
- case '\005': /* $^E */
- case '\006': /* $^F */
- case '\010': /* $^H */
- case '\011': /* $^I, NOT \t in EBCDIC */
- case '\014': /* $^L */
- case '\016': /* $^N */
- case '\017': /* $^O */
- case '\020': /* $^P */
- case '\023': /* $^S */
- case '\024': /* $^T */
- case '\026': /* $^V */
- case '\027': /* $^W */
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- case '8':
- case '9':
- yes:
- return TRUE;
- default:
- break;
- }
- }
- return FALSE;
-}
-
void
Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
{
@@ -2683,7 +3097,6 @@
U32 hash;
PERL_ARGS_ASSERT_GV_NAME_SET;
- PERL_UNUSED_ARG(flags);
if (len > I32_MAX)
Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
@@ -2693,7 +3106,7 @@
}
PERL_HASH(hash, name, len);
- GvNAME_HEK(gv) = share_hek(name, len, hash);
+ GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
}
/*
@@ -2771,12 +3184,22 @@
}
}
+#include "XSUB.h"
+
+static void
+core_xsub(pTHX_ CV* cv)
+{
+ Perl_croak(aTHX_
+ "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
+ );
+}
+
/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/gv.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/gv.h
===================================================================
--- trunk/contrib/perl/gv.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/gv.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -56,6 +56,7 @@
}))
# define GvNAME_get(gv) ({ assert(GvNAME_HEK(gv)); (char *)HEK_KEY(GvNAME_HEK(gv)); })
# define GvNAMELEN_get(gv) ({ assert(GvNAME_HEK(gv)); HEK_LEN(GvNAME_HEK(gv)); })
+# define GvNAMEUTF8(gv) ({ assert(GvNAME_HEK(gv)); HEK_UTF8(GvNAME_HEK(gv)); })
#else
# define GvGP(gv) (0+(gv)->sv_u.svu_gp)
# define GvGP_set(gv,gp) ((gv)->sv_u.svu_gp = (gp))
@@ -64,6 +65,7 @@
# define GvNAME_HEK(gv) (GvXPVGV(gv)->xiv_u.xivu_namehek)
# define GvNAME_get(gv) HEK_KEY(GvNAME_HEK(gv))
# define GvNAMELEN_get(gv) HEK_LEN(GvNAME_HEK(gv))
+# define GvNAMEUTF8(gv) HEK_UTF8(GvNAME_HEK(gv))
#endif
#define GvNAME(gv) GvNAME_get(gv)
@@ -81,6 +83,18 @@
Return the SV from the GV.
+=for apidoc Am|AV*|GvAV|GV* gv
+
+Return the AV from the GV.
+
+=for apidoc Am|HV*|GvHV|GV* gv
+
+Return the HV from the GV.
+
+=for apidoc Am|CV*|GvCV|GV* gv
+
+Return the CV from the GV.
+
=cut
*/
@@ -133,6 +147,9 @@
#define GvEGV(gv) (GvGP(gv)->gp_egv)
#define GvEGVx(gv) (isGV_with_GP(gv) ? GvEGV(gv) : NULL)
#define GvENAME(gv) GvNAME(GvEGV(gv) ? GvEGV(gv) : gv)
+#define GvENAMELEN(gv) GvNAMELEN(GvEGV(gv) ? GvEGV(gv) : gv)
+#define GvENAMEUTF8(gv) GvNAMEUTF8(GvEGV(gv) ? GvEGV(gv) : gv)
+#define GvENAME_HEK(gv) GvNAME_HEK(GvEGV(gv) ? GvEGV(gv) : gv)
#define GvESTASH(gv) GvSTASH(GvEGV(gv) ? GvEGV(gv) : gv)
#define GVf_INTRO 0x01
@@ -145,9 +162,6 @@
#define GVf_IMPORTED_HV 0x40
#define GVf_IMPORTED_CV 0x80
-/* Temporary flag for the tie $handle deprecation warnings. */
-#define GVf_TIEWARNED 0x100
-
#define GvINTRO(gv) (GvFLAGS(gv) & GVf_INTRO)
#define GvINTRO_on(gv) (GvFLAGS(gv) |= GVf_INTRO)
#define GvINTRO_off(gv) (GvFLAGS(gv) &= ~GVf_INTRO)
@@ -203,7 +217,8 @@
#define GV_ADD 0x01 /* add, if symbol not already there
For gv_name_set, adding a HEK for the first
time, so don't try to free what's there. */
-#define GV_ADDMULTI 0x02 /* add, pretending it has been added already */
+#define GV_ADDMULTI 0x02 /* add, pretending it has been added
+ already; used also by gv_init_* */
#define GV_ADDWARN 0x04 /* add, but warn if symbol wasn't already there */
#define GV_ADDINEVAL 0x08 /* add, as though we're doing so within an eval */
#define GV_NOINIT 0x10 /* add, but don't init symbol, if type != PVGV */
@@ -216,17 +231,46 @@
package (so skip checks for :: and ') */
#define GV_AUTOLOAD 0x100 /* gv_fetchmethod_flags() should AUTOLOAD */
#define GV_CROAK 0x200 /* gv_fetchmethod_flags() should croak */
+#define GV_ADDMG 0x400 /* add if magical */
+#define GV_NO_SVGMAGIC 0x800 /* Skip get-magic on an SV argument;
+ used only by gv_fetchsv(_nomg) */
+/* Flags for gv_fetchmeth_pvn and gv_autoload_pvn*/
+#define GV_SUPER 0x1000 /* SUPER::method */
+
+/* Flags for gv_autoload_*/
+#define GV_AUTOLOAD_ISMETHOD 1 /* autoloading a method? */
+
/* SVf_UTF8 (more accurately the return value from SvUTF8) is also valid
- as a flag to gv_fetch_pvn_flags, so ensure it lies outside this range.
+ as a flag to various gv_* functions, so ensure it lies
+ outside this range.
*/
-#define GV_NOADD_MASK (SVf_UTF8|GV_NOADD_NOINIT|GV_NOEXPAND|GV_NOTQUAL)
-/* The bit flags that don't cause gv_fetchpv() to add a symbol if not found */
+#define GV_NOADD_MASK \
+ (SVf_UTF8|GV_NOADD_NOINIT|GV_NOEXPAND|GV_NOTQUAL|GV_ADDMG|GV_NO_SVGMAGIC)
+/* The bit flags that don't cause gv_fetchpv() to add a symbol if not
+ found (with the exception GV_ADDMG, which *might* cause the symbol
+ to be added) */
#define gv_fullname3(sv,gv,prefix) gv_fullname4(sv,gv,prefix,TRUE)
#define gv_efullname3(sv,gv,prefix) gv_efullname4(sv,gv,prefix,TRUE)
#define gv_fetchmethod(stash, name) gv_fetchmethod_autoload(stash, name, TRUE)
+#define gv_fetchsv_nomg(n,f,t) gv_fetchsv(n,(f)|GV_NO_SVGMAGIC,t)
+#define gv_init(gv,stash,name,len,multi) \
+ gv_init_pvn(gv,stash,name,len,GV_ADDMULTI*!!(multi))
+#define gv_fetchmeth(stash,name,len,level) gv_fetchmeth_pvn(stash, name, len, level, 0)
+#define gv_fetchmeth_autoload(stash,name,len,level) gv_fetchmeth_pvn_autoload(stash, name, len, level, 0)
+#define gv_fetchmethod_flags(stash,name,flags) gv_fetchmethod_pv_flags(stash, name, flags)
+#define gv_autoload4(stash, name, len, method) \
+ gv_autoload_pvn(stash, name, len, !!(method))
+#define newGVgen(pack) newGVgen_flags(pack, 0)
+#define gv_method_changed(gv) \
+ ( \
+ assert_(isGV_with_GP(gv)) \
+ GvREFCNT(gv) > 1 \
+ ? (void)++PL_sub_generation \
+ : mro_method_changed_in(GvSTASH(gv)) \
+ )
#define gv_AVadd(gv) gv_add_by_type((gv), SVt_PVAV)
#define gv_HVadd(gv) gv_add_by_type((gv), SVt_PVHV)
@@ -237,8 +281,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/gv.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/handy.h
===================================================================
--- trunk/contrib/perl/handy.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/handy.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -1,7 +1,7 @@
/* handy.h
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1999, 2000,
- * 2001, 2002, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
+ * 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2012 by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
@@ -8,16 +8,15 @@
*
*/
+#ifndef HANDY_H /* Guard against nested #inclusion */
+#define HANDY_H
+
#if !defined(__STDC__)
#ifdef NULL
#undef NULL
#endif
-#ifndef I286
# define NULL 0
-#else
-# define NULL 0L
#endif
-#endif
#ifndef PERL_CORE
# define Null(type) ((type)NULL)
@@ -70,10 +69,13 @@
#define MUTABLE_IO(p) ((IO *)MUTABLE_PTR(p))
#define MUTABLE_SV(p) ((SV *)MUTABLE_PTR(p))
-/* XXX Configure ought to have a test for a boolean type, if I can
- just figure out all the headers such a test needs.
- Andy Dougherty August 1996
-*/
+#ifdef I_STDBOOL
+# include <stdbool.h>
+# ifndef HAS_BOOL
+# define HAS_BOOL 1
+# endif
+#endif
+
/* bool is built-in for g++-2.6.3 and later, which might be used
for extensions. <_G_config.h> defines _G_HAVE_BOOL, but we can't
be sure _G_config.h will be included before this file. _G_config.h
@@ -102,7 +104,7 @@
#endif /* NeXT || __NeXT__ */
#ifndef HAS_BOOL
-# if defined(UTS) || defined(VMS)
+# if defined(VMS)
# define bool int
# else
# define bool char
@@ -112,9 +114,10 @@
/* a simple (bool) cast may not do the right thing: if bool is defined
* as char for example, then the cast from int is implementation-defined
+ * (bool)!!(cbool) in a ternary triggers a bug in xlc on AIX
*/
-#define cBOOL(cbool) ((bool)!!(cbool))
+#define cBOOL(cbool) ((cbool) ? (bool)1 : (bool)0)
/* Try to figure out __func__ or __FUNCTION__ equivalent, if any.
* XXX Should really be a Configure probe, with HAS__FUNCTION__
@@ -123,7 +126,7 @@
#if (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) || (defined(__SUNPRO_C)) /* C99 or close enough. */
# define FUNCTION__ __func__
#else
-# if (defined(_MSC_VER) && _MSC_VER < 1300) || /* Pre-MSVC 7.0 has neither __func__ nor __FUNCTION and no good workarounds, either. */ \
+# if (defined(_MSC_VER) && _MSC_VER < 1300) || /* MSVC6 has neither __func__ nor __FUNCTION and no good workarounds, either. */ \
(defined(__DECC_VER)) /* Tru64 or VMS, and strict C89 being used, but not modern enough cc (in Tur64, -c99 not known, only -std1). */
# define FUNCTION__ ""
# else
@@ -187,25 +190,29 @@
#endif /* PERL_CORE */
#if defined(HAS_QUAD) && defined(USE_64_BIT_INT)
-# ifndef UINT64_C /* usually from <inttypes.h> */
-# if defined(HAS_LONG_LONG) && QUADKIND == QUAD_IS_LONG_LONG
-# define INT64_C(c) CAT2(c,LL)
-# define UINT64_C(c) CAT2(c,ULL)
+# if defined(HAS_LONG_LONG) && QUADKIND == QUAD_IS_LONG_LONG
+# define PeRl_INT64_C(c) CAT2(c,LL)
+# define PeRl_UINT64_C(c) CAT2(c,ULL)
+# else
+# if QUADKIND == QUAD_IS___INT64
+# define PeRl_INT64_C(c) CAT2(c,I64)
+# define PeRl_UINT64_C(c) CAT2(c,UI64)
# else
# if LONGSIZE == 8 && QUADKIND == QUAD_IS_LONG
-# define INT64_C(c) CAT2(c,L)
-# define UINT64_C(c) CAT2(c,UL)
+# define PeRl_INT64_C(c) CAT2(c,L)
+# define PeRl_UINT64_C(c) CAT2(c,UL)
# else
-# if defined(_WIN64) && defined(_MSC_VER)
-# define INT64_C(c) CAT2(c,I64)
-# define UINT64_C(c) CAT2(c,UI64)
-# else
-# define INT64_C(c) ((I64TYPE)(c))
-# define UINT64_C(c) ((U64TYPE)(c))
-# endif
+# define PeRl_INT64_C(c) ((I64TYPE)(c))
+# define PeRl_UINT64_C(c) ((U64TYPE)(c))
# endif
# endif
# endif
+# ifndef UINT64_C
+# define UINT64_C(c) PeRl_UINT64_C(c)
+# endif
+# ifndef INT64_C
+# define INT64_C(c) PeRl_INT64_C(c)
+# endif
#endif
#if defined(UINT8_MAX) && defined(INT16_MAX) && defined(INT32_MAX)
@@ -335,12 +342,13 @@
=cut
*/
-/* concatenating with "" ensures that only literal strings are accepted as argument */
+/* concatenating with "" ensures that only literal strings are accepted as
+ * argument */
#define STR_WITH_LEN(s) ("" s ""), (sizeof(s)-1)
-/* note that STR_WITH_LEN() can't be used as argument to macros or functions that
- * under some configurations might be macros, which means that it requires the full
- * Perl_xxx(aTHX_ ...) form for any API calls where it's used.
+/* note that STR_WITH_LEN() can't be used as argument to macros or functions
+ * that under some configurations might be macros, which means that it requires
+ * the full Perl_xxx(aTHX_ ...) form for any API calls where it's used.
*/
/* STR_WITH_LEN() shortcuts */
@@ -466,155 +474,396 @@
/*
=head1 Character classes
-There are three variants for all the functions in this section. The base ones
-operate using the character set of the platform Perl is running on. The ones
-with an C<_A> suffix operate on the ASCII character set, and the ones with an
-C<_L1> suffix operate on the full Latin1 character set. All are unaffected by
-locale
+This section is about functions (really macros) that classify characters
+into types, such as punctuation versus alphabetic, etc. Most of these are
+analogous to regular expression character classes. (See
+L<perlrecharclass/POSIX Character Classes>.) There are several variants for
+each class. (Not all macros have all variants; each item below lists the
+ones valid for it.) None are affected by C<use bytes>, and only the ones
+with C<LC> in the name are affected by the current locale.
-For ASCII platforms, the base function with no suffix and the one with the
-C<_A> suffix are identical. The function with the C<_L1> suffix imposes the
-Latin-1 character set onto the platform. That is, the code points that are
-ASCII are unaffected, since ASCII is a subset of Latin-1. But the non-ASCII
-code points are treated as if they are Latin-1 characters. For example,
-C<isSPACE_L1()> will return true when called with the code point 0xA0, which is
-the Latin-1 NO-BREAK SPACE.
+The base function, e.g., C<isALPHA()>, takes an octet (either a C<char> or a
+C<U8>) as input and returns a boolean as to whether or not the character
+represented by that octet is (or on non-ASCII platforms, corresponds to) an
+ASCII character in the named class based on platform, Unicode, and Perl rules.
+If the input is a number that doesn't fit in an octet, FALSE is returned.
-For EBCDIC platforms, the base function with no suffix and the one with the
-C<_L1> suffix should be identical, since, as of this writing, the EBCDIC code
-pages that Perl knows about all are equivalent to Latin-1. The function that
-ends in an C<_A> suffix will not return true unless the specified character also
-has an ASCII equivalent.
+Variant C<isFOO_A> (e.g., C<isALPHA_A()>) is identical to the base function
+with no suffix C<"_A">.
+Variant C<isFOO_L1> imposes the Latin-1 (or EBCDIC equivlalent) character set
+onto the platform. That is, the code points that are ASCII are unaffected,
+since ASCII is a subset of Latin-1. But the non-ASCII code points are treated
+as if they are Latin-1 characters. For example, C<isWORDCHAR_L1()> will return
+true when called with the code point 0xDF, which is a word character in both
+ASCII and EBCDIC (though it represent different characters in each).
+
+Variant C<isFOO_uni> is like the C<isFOO_L1> variant, but accepts any UV code
+point as input. If the code point is larger than 255, Unicode rules are used
+to determine if it is in the character class. For example,
+C<isWORDCHAR_uni(0x100)> returns TRUE, since 0x100 is LATIN CAPITAL LETTER A
+WITH MACRON in Unicode, and is a word character.
+
+Variant C<isFOO_utf8> is like C<isFOO_uni>, but the input is a pointer to a
+(known to be well-formed) UTF-8 encoded string (C<U8*> or C<char*>). The
+classification of just the first (possibly multi-byte) character in the string
+is tested.
+
+Variant C<isFOO_LC> is like the C<isFOO_A> and C<isFOO_L1> variants, but uses
+the C library function that gives the named classification instead of
+hard-coded rules. For example, C<isDIGIT_LC()> returns the result of calling
+C<isdigit()>. This means that the result is based on the current locale, which
+is what C<LC> in the name stands for. FALSE is always returned if the input
+won't fit into an octet.
+
+Variant C<isFOO_LC_uvchr> is like C<isFOO_LC>, but is defined on any UV. It
+returns the same as C<isFOO_LC> for input code points less than 256, and
+returns the hard-coded, not-affected-by-locale, Unicode results for larger ones.
+
+Variant C<isFOO_LC_utf8> is like C<isFOO_LC_uvchr>, but the input is a pointer to a
+(known to be well-formed) UTF-8 encoded string (C<U8*> or C<char*>). The
+classification of just the first (possibly multi-byte) character in the string
+is tested.
+
=for apidoc Am|bool|isALPHA|char ch
Returns a boolean indicating whether the specified character is an
-alphabetic character in the platform's native character set.
+alphabetic character, analogous to C<m/[[:alpha:]]/>.
See the L<top of this section|/Character classes> for an explanation of variants
-C<isALPHA_A> and C<isALPHA_L1>.
+C<isALPHA_A>, C<isALPHA_L1>, C<isALPHA_uni>, C<isALPHA_utf8>, C<isALPHA_LC>,
+C<isALPHA_LC_uvchr>, and C<isALPHA_LC_utf8>.
+=for apidoc Am|bool|isALPHANUMERIC|char ch
+Returns a boolean indicating whether the specified character is a either an
+alphabetic character or decimal digit, analogous to C<m/[[:alnum:]]/>.
+See the L<top of this section|/Character classes> for an explanation of variants
+C<isALPHANUMERIC_A>, C<isALPHANUMERIC_L1>, C<isALPHANUMERIC_uni>,
+C<isALPHANUMERIC_utf8>, C<isALPHANUMERIC_LC>, C<isALPHANUMERIC_LC_uvchr>, and
+C<isALPHANUMERIC_LC_utf8>.
+
=for apidoc Am|bool|isASCII|char ch
Returns a boolean indicating whether the specified character is one of the 128
-characters in the ASCII character set. On non-ASCII platforms, it is if this
+characters in the ASCII character set, analogous to C<m/[[:ascii:]]/>.
+On non-ASCII platforms, it returns TRUE iff this
character corresponds to an ASCII character. Variants C<isASCII_A()> and
C<isASCII_L1()> are identical to C<isASCII()>.
+See the L<top of this section|/Character classes> for an explanation of variants
+C<isASCII_uni>, C<isASCII_utf8>, C<isASCII_LC>, C<isASCII_LC_uvchr>, and
+C<isASCII_LC_utf8>. Note, however, that some platforms do not have the C
+library routine C<isascii()>. In these cases, the variants whose names contain
+C<LC> are the same as the corresponding ones without.
+=for apidoc Am|bool|isBLANK|char ch
+Returns a boolean indicating whether the specified character is a
+character considered to be a blank, analogous to C<m/[[:blank:]]/>.
+See the L<top of this section|/Character classes> for an explanation of variants
+C<isBLANK_A>, C<isBLANK_L1>, C<isBLANK_uni>, C<isBLANK_utf8>, C<isBLANK_LC>,
+C<isBLANK_LC_uvchr>, and C<isBLANK_LC_utf8>. Note, however, that some
+platforms do not have the C library routine C<isblank()>. In these cases, the
+variants whose names contain C<LC> are the same as the corresponding ones
+without.
+
+=for apidoc Am|bool|isCNTRL|char ch
+Returns a boolean indicating whether the specified character is a
+control character, analogous to C<m/[[:cntrl:]]/>.
+See the L<top of this section|/Character classes> for an explanation of variants
+C<isCNTRL_A>, C<isCNTRL_L1>, C<isCNTRL_uni>, C<isCNTRL_utf8>, C<isCNTRL_LC>,
+C<isCNTRL_LC_uvchr>, and C<isCNTRL_LC_utf8>
+On EBCDIC platforms, you almost always want to use the C<isCNTRL_L1> variant.
+
=for apidoc Am|bool|isDIGIT|char ch
Returns a boolean indicating whether the specified character is a
-digit in the platform's native character set.
+digit, analogous to C<m/[[:digit:]]/>.
Variants C<isDIGIT_A> and C<isDIGIT_L1> are identical to C<isDIGIT>.
+See the L<top of this section|/Character classes> for an explanation of variants
+C<isDIGIT_uni>, C<isDIGIT_utf8>, C<isDIGIT_LC>, C<isDIGIT_LC_uvchr>, and
+C<isDIGIT_LC_utf8>.
+=for apidoc Am|bool|isGRAPH|char ch
+Returns a boolean indicating whether the specified character is a
+graphic character, analogous to C<m/[[:graph:]]/>.
+See the L<top of this section|/Character classes> for an explanation of variants
+C<isGRAPH_A>, C<isGRAPH_L1>, C<isGRAPH_uni>, C<isGRAPH_utf8>, C<isGRAPH_LC>,
+C<isGRAPH_LC_uvchr>, and C<isGRAPH_LC_utf8>.
+
=for apidoc Am|bool|isLOWER|char ch
Returns a boolean indicating whether the specified character is a
-lowercase character in the platform's native character set.
+lowercase character, analogous to C<m/[[:lower:]]/>.
See the L<top of this section|/Character classes> for an explanation of variants
-C<isLOWER_A> and C<isLOWER_L1>.
+C<isLOWER_A>, C<isLOWER_L1>, C<isLOWER_uni>, C<isLOWER_utf8>, C<isLOWER_LC>,
+C<isLOWER_LC_uvchr>, and C<isLOWER_LC_utf8>.
=for apidoc Am|bool|isOCTAL|char ch
Returns a boolean indicating whether the specified character is an
-octal digit, [0-7] in the platform's native character set.
-Variants C<isOCTAL_A> and C<isOCTAL_L1> are identical to C<isOCTAL>.
+octal digit, [0-7].
+The only two variants are C<isOCTAL_A> and C<isOCTAL_L1>; each is identical to
+C<isOCTAL>.
+=for apidoc Am|bool|isPUNCT|char ch
+Returns a boolean indicating whether the specified character is a
+punctuation character, analogous to C<m/[[:punct:]]/>.
+Note that the definition of what is punctuation isn't as
+straightforward as one might desire. See L<perlrecharclass/POSIX Character
+Classes> for details.
+See the L<top of this section|/Character classes> for an explanation of variants
+C<isPUNCT_A>, C<isPUNCT_L1>, C<isPUNCT_uni>, C<isPUNCT_utf8>, C<isPUNCT_LC>,
+C<isPUNCT_LC_uvchr>, and C<isPUNCT_LC_utf8>.
+
=for apidoc Am|bool|isSPACE|char ch
Returns a boolean indicating whether the specified character is a
-whitespace character in the platform's native character set. This is the same
-as what C<\s> matches in a regular expression.
+whitespace character. This is analogous
+to what C<m/\s/> matches in a regular expression. Starting in Perl 5.18
+(experimentally), this also matches what C<m/[[:space:]]/> does.
+("Experimentally" means that this change may be backed out in 5.20 or 5.22 if
+field experience indicates that it was unwise.) Prior to 5.18, only the
+locale forms of this macro (the ones with C<LC> in their names) matched
+precisely what C<m/[[:space:]]/> does. In those releases, the only difference,
+in the non-locale variants, was that C<isSPACE()> did not match a vertical tab.
+(See L</isPSXSPC> for a macro that matches a vertical tab in all releases.)
See the L<top of this section|/Character classes> for an explanation of variants
-C<isSPACE_A> and C<isSPACE_L1>.
+C<isSPACE_A>, C<isSPACE_L1>, C<isSPACE_uni>, C<isSPACE_utf8>, C<isSPACE_LC>,
+C<isSPACE_LC_uvchr>, and C<isSPACE_LC_utf8>.
+=for apidoc Am|bool|isPSXSPC|char ch
+(short for Posix Space)
+Starting in 5.18, this is identical (experimentally) in all its forms to the
+corresponding C<isSPACE()> macros. ("Experimentally" means that this change
+may be backed out in 5.20 or 5.22 if field experience indicates that it
+was unwise.)
+The locale forms of this macro are identical to their corresponding
+C<isSPACE()> forms in all Perl releases. In releases prior to 5.18, the
+non-locale forms differ from their C<isSPACE()> forms only in that the
+C<isSPACE()> forms don't match a Vertical Tab, and the C<isPSXSPC()> forms do.
+Otherwise they are identical. Thus this macro is analogous to what
+C<m/[[:space:]]/> matches in a regular expression.
+See the L<top of this section|/Character classes> for an explanation of variants
+C<isPSXSPC_A>, C<isPSXSPC_L1>, C<isPSXSPC_uni>, C<isPSXSPC_utf8>, C<isPSXSPC_LC>,
+C<isPSXSPC_LC_uvchr>, and C<isPSXSPC_LC_utf8>.
+
=for apidoc Am|bool|isUPPER|char ch
Returns a boolean indicating whether the specified character is an
-uppercase character in the platform's native character set.
+uppercase character, analogous to C<m/[[:upper:]]/>.
See the L<top of this section|/Character classes> for an explanation of variants
-C<isUPPER_A> and C<isUPPER_L1>.
+C<isUPPER_A>, C<isUPPER_L1>, C<isUPPER_uni>, C<isUPPER_utf8>, C<isUPPER_LC>,
+C<isUPPER_LC_uvchr>, and C<isUPPER_LC_utf8>.
-=for apidoc Am|bool|isWORDCHAR|char ch
+=for apidoc Am|bool|isPRINT|char ch
Returns a boolean indicating whether the specified character is a
-character that is any of: alphabetic, numeric, or an underscore. This is the
-same as what C<\w> matches in a regular expression.
-C<isALNUM()> is a synonym provided for backward compatibility. Note that it
-does not have the standard C language meaning of alphanumeric, since it matches
-an underscore and the standard meaning does not.
+printable character, analogous to C<m/[[:print:]]/>.
See the L<top of this section|/Character classes> for an explanation of variants
-C<isWORDCHAR_A> and C<isWORDCHAR_L1>.
+C<isPRINT_A>, C<isPRINT_L1>, C<isPRINT_uni>, C<isPRINT_utf8>, C<isPRINT_LC>,
+C<isPRINT_LC_uvchr>, and C<isPRINT_LC_utf8>.
+=for apidoc Am|bool|isWORDCHAR|char ch
+Returns a boolean indicating whether the specified character is a character
+that is a word character, analogous to what C<m/\w/> and C<m/[[:word:]]/> match
+in a regular expression. A word character is an alphabetic character, a
+decimal digit, a connecting punctuation character (such as an underscore), or
+a "mark" character that attaches to one of those (like some sort of accent).
+C<isALNUM()> is a synonym provided for backward compatibility, even though a
+word character includes more than the standard C language meaning of
+alphanumeric.
+See the L<top of this section|/Character classes> for an explanation of variants
+C<isWORDCHAR_A>, C<isWORDCHAR_L1>, C<isWORDCHAR_uni>, C<isWORDCHAR_utf8>,
+C<isWORDCHAR_LC>, C<isWORDCHAR_LC_uvchr>, and C<isWORDCHAR_LC_utf8>.
+
=for apidoc Am|bool|isXDIGIT|char ch
Returns a boolean indicating whether the specified character is a hexadecimal
-digit, [0-9A-Fa-f]. Variants C<isXDIGIT_A()> and C<isXDIGIT_L1()> are
-identical to C<isXDIGIT()>.
+digit. In the ASCII range these are C<[0-9A-Fa-f]>. Variants C<isXDIGIT_A()>
+and C<isXDIGIT_L1()> are identical to C<isXDIGIT()>.
+See the L<top of this section|/Character classes> for an explanation of variants
+C<isXDIGIT_uni>, C<isXDIGIT_utf8>, C<isXDIGIT_LC>, C<isXDIGIT_LC_uvchr>, and
+C<isXDIGIT_LC_utf8>.
+=for apidoc Am|bool|isIDFIRST|char ch
+Returns a boolean indicating whether the specified character can be the first
+character of an identifier. This is very close to, but not quite the same as
+the official Unicode property C<XID_Start>. The difference is that this
+returns true only if the input character also matches L</isWORDCHAR>.
+See the L<top of this section|/Character classes> for an explanation of variants
+C<isIDFIRST_A>, C<isIDFIRST_L1>, C<isIDFIRST_uni>, C<isIDFIRST_utf8>,
+C<isIDFIRST_LC>, C<isIDFIRST_LC_uvchr>, and C<isIDFIRST_LC_utf8>.
+
+=for apidoc Am|bool|isIDCONT|char ch
+Returns a boolean indicating whether the specified character can be the
+second or succeeding character of an identifier. This is very close to, but
+not quite the same as the official Unicode property C<XID_Continue>. The
+difference is that this returns true only if the input character also matches
+L</isWORDCHAR>. See the L<top of this section|/Character classes> for an
+explanation of variants C<isIDCONT_A>, C<isIDCONT_L1>, C<isIDCONT_uni>,
+C<isIDCONT_utf8>, C<isIDCONT_LC>, C<isIDCONT_LC_uvchr>, and
+C<isIDCONT_LC_utf8>.
+
+=head1 Miscellaneous Functions
+
+=for apidoc Am|U8|READ_XDIGIT|char str*
+Returns the value of an ASCII-range hex digit and advances the string pointer.
+Behaviour is only well defined when isXDIGIT(*str) is true.
+
=head1 Character case changing
=for apidoc Am|char|toUPPER|char ch
-Converts the specified character to uppercase in the platform's native
-character set, if possible; otherwise returns the input character itself.
+Converts the specified character to uppercase, if possible; otherwise returns
+the input character itself.
=for apidoc Am|char|toLOWER|char ch
-Converts the specified character to lowercase in the platform's native
-character set, if possible; otherwise returns the input character itself.
+Converts the specified character to lowercase, if possible; otherwise returns
+the input character itself.
=cut
+XXX Still undocumented isVERTWS_uni and _utf8, and the other toUPPER etc functions
+
Note that these macros are repeated in Devel::PPPort, so should also be
patched there. The file as of this writing is cpan/Devel-PPPort/parts/inc/misc
*/
-/* FITS_IN_8_BITS(c) returns true if c occupies no more than 8 bits. It is
- * designed to be hopefully bomb-proof, making sure that no bits of
- * information are lost even on a 64-bit machine, but to get the compiler to
- * optimize it out if possible. This is because Configure makes sure that the
- * machine has an 8-bit byte, so if c is stored in a byte, the sizeof()
- * guarantees that this evaluates to a constant true at compile time. The use
- * of the mask instead of '< 256' keeps gcc from complaining that it is alway
- * true, when c's storage class is a byte. Use U64TYPE because U64 is known
- * only in the perl core, and this macro can be called from outside that */
+/* Specify the widest unsigned type on the platform. Use U64TYPE because U64
+ * is known only in the perl core, and this macro can be called from outside
+ * that */
#ifdef HAS_QUAD
-# define FITS_IN_8_BITS(c) ((sizeof(c) == 1) || (((U64TYPE)(c) & 0xFF) == (U64TYPE)(c)))
+# define WIDEST_UTYPE U64TYPE
#else
-# define FITS_IN_8_BITS(c) ((sizeof(c) == 1) || (((U32)(c) & 0xFF) == (U32)(c)))
+# define WIDEST_UTYPE U32
#endif
-#define isASCII(c) (FITS_IN_8_BITS(c) ? NATIVE_TO_UNI((U8) c) <= 127 : 0)
+/* FITS_IN_8_BITS(c) returns true if c doesn't have a bit set other than in
+ * the lower 8. It is designed to be hopefully bomb-proof, making sure that no
+ * bits of information are lost even on a 64-bit machine, but to get the
+ * compiler to optimize it out if possible. This is because Configure makes
+ * sure that the machine has an 8-bit byte, so if c is stored in a byte, the
+ * sizeof() guarantees that this evaluates to a constant true at compile time.
+ */
+#define FITS_IN_8_BITS(c) ((sizeof(c) == 1) || !(((WIDEST_UTYPE)(c)) & ~0xFF))
+
+#ifdef EBCDIC
+# define isASCII(c) (FITS_IN_8_BITS(c) && (NATIVE_TO_UNI((U8) (c)) < 128))
+#else
+# 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 */
-/* Bits for PL_charclass[] */
-# define _CC_ALNUMC_A (1<<0)
-# define _CC_ALNUMC_L1 (1<<1)
-# define _CC_ALPHA_A (1<<2)
-# define _CC_ALPHA_L1 (1<<3)
-# define _CC_BLANK_A (1<<4)
-# define _CC_BLANK_L1 (1<<5)
-# define _CC_CHARNAME_CONT (1<<6)
-# define _CC_CNTRL_A (1<<7)
-# define _CC_CNTRL_L1 (1<<8)
-# define _CC_DIGIT_A (1<<9)
-# define _CC_GRAPH_A (1<<10)
-# define _CC_GRAPH_L1 (1<<11)
-# define _CC_IDFIRST_A (1<<12)
-# define _CC_IDFIRST_L1 (1<<13)
-# define _CC_LOWER_A (1<<14)
-# define _CC_LOWER_L1 (1<<15)
-# define _CC_OCTAL_A (1<<16)
-# define _CC_PRINT_A (1<<17)
-# define _CC_PRINT_L1 (1<<18)
-# define _CC_PSXSPC_A (1<<19)
-# define _CC_PSXSPC_L1 (1<<20)
-# define _CC_PUNCT_A (1<<21)
-# define _CC_PUNCT_L1 (1<<22)
-# define _CC_SPACE_A (1<<23)
-# define _CC_SPACE_L1 (1<<24)
-# define _CC_UPPER_A (1<<25)
-# define _CC_UPPER_L1 (1<<26)
-# define _CC_WORDCHAR_A (1<<27)
-# define _CC_WORDCHAR_L1 (1<<28)
-# define _CC_XDIGIT_A (1<<29)
-# define _CC_NONLATIN1_FOLD (1<<30)
-/* Unused
- * (1<<31)
- */
+/* Character class numbers. For internal core Perl use only. The ones less
+ * than 32 are used in PL_charclass[] and the ones up through the one that
+ * corresponds to <_HIGHEST_REGCOMP_DOT_H_SYNC> are used by regcomp.h and
+ * related files. PL_charclass ones use names used in l1_char_class_tab.h but
+ * their actual definitions are here. If that file has a name not used here,
+ * it won't compile.
+ *
+ * The first group of these is ordered in what I (khw) estimate to be the
+ * frequency of their use. This gives a slight edge to exiting a loop earlier
+ * (in reginclass() in regexec.c) */
+# define _CC_WORDCHAR 0 /* \w and [:word:] */
+# define _CC_DIGIT 1 /* \d and [:digit:] */
+# define _CC_ALPHA 2 /* [:alpha:] */
+# define _CC_LOWER 3 /* [:lower:] */
+# define _CC_UPPER 4 /* [:upper:] */
+# define _CC_PUNCT 5 /* [:punct:] */
+# define _CC_PRINT 6 /* [:print:] */
+# define _CC_ALPHANUMERIC 7 /* [:alnum:] */
+# define _CC_GRAPH 8 /* [:graph:] */
+# define _CC_CASED 9 /* [:lower:] and [:upper:] under /i */
+
+#define _FIRST_NON_SWASH_CC 10
+/* The character classes above are implemented with swashes. The second group
+ * (just below) contains the ones implemented without. These are also sorted
+ * in rough order of the frequency of their use, except that \v should be last,
+ * as it isn't a real Posix character class, and some (small) inefficiencies in
+ * regular expression handling would be introduced by putting it in the middle
+ * of those that are. Also, cntrl and ascii come after the others as it may be
+ * useful to group these which have no members that match above Latin1, (or
+ * above ASCII in the latter case) */
+
+# define _CC_SPACE 10 /* \s */
+# define _CC_BLANK 11 /* [:blank:] */
+# define _CC_XDIGIT 12 /* [:xdigit:] */
+# define _CC_PSXSPC 13 /* [:space:] */
+# define _CC_CNTRL 14 /* [:cntrl:] */
+# define _CC_ASCII 15 /* [:ascii:] */
+# define _CC_VERTSPACE 16 /* \v */
+
+# define _HIGHEST_REGCOMP_DOT_H_SYNC _CC_VERTSPACE
+
+/* The members of the third group below do not need to be coordinated with data
+ * structures in regcomp.[ch] and regexec.c */
+# define _CC_IDFIRST 17
+# define _CC_CHARNAME_CONT 18
+# define _CC_NONLATIN1_FOLD 19
+# define _CC_QUOTEMETA 20
+# define _CC_NON_FINAL_FOLD 21
+# define _CC_IS_IN_SOME_FOLD 22
+# define _CC_BACKSLASH_FOO_LBRACE_IS_META 31 /* temp, see mk_PL_charclass.pl */
+/* Unused: 23-30
+ * If more bits are needed, one could add a second word for non-64bit
+ * QUAD_IS_INT systems, using some #ifdefs to distinguish between having a 2nd
+ * word or not. The IS_IN_SOME_FOLD bit is the most easily expendable, as it
+ * is used only for optimization (as of this writing), and differs in the
+ * Latin1 range from the ALPHA bit only in two relatively unimportant
+ * characters: the masculine and feminine ordinal indicators, so removing it
+ * would just cause /i regexes which match them to run less efficiently */
+
+#if defined(PERL_CORE) || defined(PERL_EXT)
+/* An enum version of the character class numbers, to help compilers
+ * optimize */
+typedef enum {
+ _CC_ENUM_ALPHA = _CC_ALPHA,
+ _CC_ENUM_ALPHANUMERIC = _CC_ALPHANUMERIC,
+ _CC_ENUM_ASCII = _CC_ASCII,
+ _CC_ENUM_BLANK = _CC_BLANK,
+ _CC_ENUM_CASED = _CC_CASED,
+ _CC_ENUM_CNTRL = _CC_CNTRL,
+ _CC_ENUM_DIGIT = _CC_DIGIT,
+ _CC_ENUM_GRAPH = _CC_GRAPH,
+ _CC_ENUM_LOWER = _CC_LOWER,
+ _CC_ENUM_PRINT = _CC_PRINT,
+ _CC_ENUM_PSXSPC = _CC_PSXSPC,
+ _CC_ENUM_PUNCT = _CC_PUNCT,
+ _CC_ENUM_SPACE = _CC_SPACE,
+ _CC_ENUM_UPPER = _CC_UPPER,
+ _CC_ENUM_VERTSPACE = _CC_VERTSPACE,
+ _CC_ENUM_WORDCHAR = _CC_WORDCHAR,
+ _CC_ENUM_XDIGIT = _CC_XDIGIT
+} _char_class_number;
+#endif
+
+#define POSIX_SWASH_COUNT _FIRST_NON_SWASH_CC
+#define POSIX_CC_COUNT (_HIGHEST_REGCOMP_DOT_H_SYNC + 1)
+
+#if defined(PERL_IN_UTF8_C) || defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_REGEXEC_C)
+# if _CC_WORDCHAR != 0 || _CC_DIGIT != 1 || _CC_ALPHA != 2 || _CC_LOWER != 3 \
+ || _CC_UPPER != 4 || _CC_PUNCT != 5 || _CC_PRINT != 6 \
+ || _CC_ALPHANUMERIC != 7 || _CC_GRAPH != 8 || _CC_CASED != 9
+ #error Need to adjust order of swash_property_names[]
+# endif
+
+/* This is declared static in each of the few files that this is #defined for
+ * to keep them from being publicly accessible. Hence there is a small amount
+ * of wasted space */
+
+static const char* const swash_property_names[] = {
+ "XPosixWord",
+ "XPosixDigit",
+ "XPosixAlpha",
+ "XPosixLower",
+ "XPosixUpper",
+ "XPosixPunct",
+ "XPosixPrint",
+ "XPosixAlnum",
+ "XPosixGraph",
+ "Cased"
+};
+#endif
+
# ifdef DOINIT
EXTCONST U32 PL_charclass[] = {
# include "l1_char_class_tab.h"
@@ -624,30 +873,50 @@
EXTCONST U32 PL_charclass[];
# endif
-# define isALNUMC_A(c) cBOOL(FITS_IN_8_BITS(c) && (PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_ALNUMC_A))
-# define isALPHA_A(c) cBOOL(FITS_IN_8_BITS(c) && (PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_ALPHA_A))
-# define isBLANK_A(c) cBOOL(FITS_IN_8_BITS(c) && (PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_BLANK_A))
-# define isCNTRL_A(c) cBOOL(FITS_IN_8_BITS(c) && (PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_CNTRL_A))
-# define isDIGIT_A(c) cBOOL(FITS_IN_8_BITS(c) && (PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_DIGIT_A))
-# define isGRAPH_A(c) cBOOL(FITS_IN_8_BITS(c) && (PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_GRAPH_A))
-# define isIDFIRST_A(c) cBOOL(FITS_IN_8_BITS(c) && (PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_IDFIRST_A))
-# define isLOWER_A(c) cBOOL(FITS_IN_8_BITS(c) && (PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_LOWER_A))
-# define isOCTAL_A(c) cBOOL(FITS_IN_8_BITS(c) && (PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_OCTAL_A))
-# define isPRINT_A(c) cBOOL(FITS_IN_8_BITS(c) && (PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_PRINT_A))
-# define isPSXSPC_A(c) cBOOL(FITS_IN_8_BITS(c) && (PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_PSXSPC_A))
-# define isPUNCT_A(c) cBOOL(FITS_IN_8_BITS(c) && (PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_PUNCT_A))
-# define isSPACE_A(c) cBOOL(FITS_IN_8_BITS(c) && (PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_SPACE_A))
-# define isUPPER_A(c) cBOOL(FITS_IN_8_BITS(c) && (PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_UPPER_A))
-# define isWORDCHAR_A(c) cBOOL(FITS_IN_8_BITS(c) && (PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_WORDCHAR_A))
-# define isXDIGIT_A(c) cBOOL(FITS_IN_8_BITS(c) && (PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_XDIGIT_A))
+ /* The 1U keeps Solaris from griping when shifting sets the uppermost bit */
+# define _CC_mask(classnum) (1U << (classnum))
+# define _generic_isCC(c, classnum) cBOOL(FITS_IN_8_BITS(c) \
+ && (PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_mask(classnum)))
+
+ /* The mask for the _A versions of the macros; it just adds in the bit for
+ * ASCII. */
+# define _CC_mask_A(classnum) (_CC_mask(classnum) | _CC_mask(_CC_ASCII))
+
+ /* The _A version makes sure that both the desired bit and the ASCII bit
+ * are present */
+# define _generic_isCC_A(c, classnum) (FITS_IN_8_BITS(c) \
+ && ((PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_mask_A(classnum)) \
+ == _CC_mask_A(classnum)))
+
+# define isALPHA_A(c) _generic_isCC_A(c, _CC_ALPHA)
+# define isALPHANUMERIC_A(c) _generic_isCC_A(c, _CC_ALPHANUMERIC)
+# define isBLANK_A(c) _generic_isCC_A(c, _CC_BLANK)
+# define isCNTRL_A(c) _generic_isCC_A(c, _CC_CNTRL)
+# define isDIGIT_A(c) _generic_isCC(c, _CC_DIGIT)
+# define isGRAPH_A(c) _generic_isCC_A(c, _CC_GRAPH)
+# define isLOWER_A(c) _generic_isCC_A(c, _CC_LOWER)
+# define isPRINT_A(c) _generic_isCC_A(c, _CC_PRINT)
+# define isPSXSPC_A(c) _generic_isCC_A(c, _CC_PSXSPC)
+# define isPUNCT_A(c) _generic_isCC_A(c, _CC_PUNCT)
+# define isSPACE_A(c) _generic_isCC_A(c, _CC_SPACE)
+# define isUPPER_A(c) _generic_isCC_A(c, _CC_UPPER)
+# define isWORDCHAR_A(c) _generic_isCC_A(c, _CC_WORDCHAR)
+# define isXDIGIT_A(c) _generic_isCC(c, _CC_XDIGIT)
+# define isIDFIRST_A(c) _generic_isCC_A(c, ( _CC_IDFIRST))
+
/* Either participates in a fold with a character above 255, or is a
* multi-char fold */
-# define _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(c) ((! cBOOL(FITS_IN_8_BITS(c))) || (PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_NONLATIN1_FOLD))
+# define _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(c) ((! cBOOL(FITS_IN_8_BITS(c))) || (PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_mask(_CC_NONLATIN1_FOLD)))
+
+# define _isQUOTEMETA(c) _generic_isCC(c, _CC_QUOTEMETA)
+# define _IS_NON_FINAL_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c) \
+ _generic_isCC(c, _CC_NON_FINAL_FOLD)
+# define _IS_IN_SOME_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c) \
+ _generic_isCC(c, _CC_IS_IN_SOME_FOLD)
#else /* No perl.h. */
-# define isOCTAL_A(c) ((c) >= '0' && (c) <= '9')
# ifdef EBCDIC
-# define isALNUMC_A(c) (isASCII(c) && isALNUMC(c))
# define isALPHA_A(c) (isASCII(c) && isALPHA(c))
+# define isALPHANUMERIC_A(c) (isASCII(c) && isALPHANUMERIC(c))
# define isBLANK_A(c) (isASCII(c) && isBLANK(c))
# define isCNTRL_A(c) (isASCII(c) && isCNTRL(c))
# define isDIGIT_A(c) (isASCII(c) && isDIGIT(c))
@@ -662,41 +931,52 @@
# define isWORDCHAR_A(c) (isASCII(c) && isWORDCHAR(c))
# define isXDIGIT_A(c) (isASCII(c) && isXDIGIT(c))
# else /* ASCII platform, no perl.h */
-# define isALNUMC_A(c) (isALPHA_A(c) || isDIGIT_A(c))
# 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) (FITS_IN_8_BITS(c) ? ((U8) (c) < ' ' || (c) == 127) : 0)
-# define isDIGIT_A(c) ((c) >= '0' && (c) <= '9')
+# define isCNTRL_A(c) (FITS_IN_8_BITS(c) && ((U8) (c) < ' ' || (c) == 127))
+# define isDIGIT_A(c) ((c) <= '9' && (c) >= '0')
# define isGRAPH_A(c) (isWORDCHAR_A(c) || isPUNCT_A(c))
# define isIDFIRST_A(c) (isALPHA_A(c) || (c) == '_')
# define isLOWER_A(c) ((c) >= 'a' && (c) <= 'z')
# define isPRINT_A(c) (((c) >= 32 && (c) < 127))
# define isPSXSPC_A(c) (isSPACE_A(c) || (c) == '\v')
-# define isPUNCT_A(c) (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64) || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126))
-# define isSPACE_A(c) ((c) == ' ' || (c) == '\t' || (c) == '\n' || (c) =='\r' || (c) == '\f')
-# define isUPPER_A(c) ((c) >= 'A' && (c) <= 'Z')
+# define isPUNCT_A(c) (((c) >= 33 && (c) <= 47) \
+ || ((c) >= 58 && (c) <= 64) \
+ || ((c) >= 91 && (c) <= 96) \
+ || ((c) >= 123 && (c) <= 126))
+# define isSPACE_A(c) ((c) == ' ' \
+ || (c) == '\t' \
+ || (c) == '\n' \
+ || (c) =='\r' \
+ || (c) == '\f')
+# define isUPPER_A(c) ((c) <= 'Z' && (c) >= 'A')
# define isWORDCHAR_A(c) (isALPHA_A(c) || isDIGIT_A(c) || (c) == '_')
-# define isXDIGIT_A(c) (isDIGIT_A(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F'))
+# define isXDIGIT_A(c) (isDIGIT_A(c) \
+ || ((c) >= 'a' && (c) <= 'f') \
+ || ((c) <= 'F' && (c) >= 'A'))
# endif
#endif /* ASCII range definitions */
/* Latin1 definitions */
#ifdef H_PERL
-# define isALNUMC_L1(c) cBOOL(FITS_IN_8_BITS(c) && (PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_ALNUMC_L1))
-# define isALPHA_L1(c) cBOOL(FITS_IN_8_BITS(c) && (PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_ALPHA_L1))
-# define isBLANK_L1(c) cBOOL(FITS_IN_8_BITS(c) && (PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_BLANK_L1))
+# define isALPHA_L1(c) _generic_isCC(c, _CC_ALPHA)
+# define isALPHANUMERIC_L1(c) _generic_isCC(c, _CC_ALPHANUMERIC)
+# define isBLANK_L1(c) _generic_isCC(c, _CC_BLANK)
+
/* continuation character for legal NAME in \N{NAME} */
-# define isCHARNAME_CONT(c) cBOOL(FITS_IN_8_BITS(c) && (PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_CHARNAME_CONT))
-# define isCNTRL_L1(c) cBOOL(FITS_IN_8_BITS(c) && (PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_CNTRL_L1))
-# define isGRAPH_L1(c) cBOOL(FITS_IN_8_BITS(c) && (PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_GRAPH_L1))
-# define isIDFIRST_L1(c) cBOOL(FITS_IN_8_BITS(c) && (PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_IDFIRST_L1))
-# define isLOWER_L1(c) cBOOL(FITS_IN_8_BITS(c) && (PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_LOWER_L1))
-# define isPRINT_L1(c) cBOOL(FITS_IN_8_BITS(c) && (PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_PRINT_L1))
-# define isPSXSPC_L1(c) cBOOL(FITS_IN_8_BITS(c) && (PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_PSXSPC_L1))
-# define isPUNCT_L1(c) cBOOL(FITS_IN_8_BITS(c) && (PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_PUNCT_L1))
-# define isSPACE_L1(c) cBOOL(FITS_IN_8_BITS(c) && (PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_SPACE_L1))
-# define isUPPER_L1(c) cBOOL(FITS_IN_8_BITS(c) && (PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_UPPER_L1))
-# define isWORDCHAR_L1(c) cBOOL(FITS_IN_8_BITS(c) && (PL_charclass[(U8) NATIVE_TO_UNI(c)] & _CC_WORDCHAR_L1))
+# define isCHARNAME_CONT(c) _generic_isCC(c, _CC_CHARNAME_CONT)
+
+# define isCNTRL_L1(c) _generic_isCC(c, _CC_CNTRL)
+# define isGRAPH_L1(c) _generic_isCC(c, _CC_GRAPH)
+# define isLOWER_L1(c) _generic_isCC(c, _CC_LOWER)
+# define isPRINT_L1(c) _generic_isCC(c, _CC_PRINT)
+# define isPSXSPC_L1(c) _generic_isCC(c, _CC_PSXSPC)
+# define isPUNCT_L1(c) _generic_isCC(c, _CC_PUNCT)
+# define isSPACE_L1(c) _generic_isCC(c, _CC_SPACE)
+# define isUPPER_L1(c) _generic_isCC(c, _CC_UPPER)
+# define isWORDCHAR_L1(c) _generic_isCC(c, _CC_WORDCHAR)
+# define isIDFIRST_L1(c) _generic_isCC(c, _CC_IDFIRST)
#else /* No access to perl.h. Only a few provided here, just in case needed
* for backwards compatibility */
/* ALPHAU includes Unicode semantics for latin1 characters. It has an extra
@@ -703,23 +983,19 @@
* >= AA test to speed up ASCII-only tests at the expense of the others */
# define isALPHA_L1(c) (isALPHA(c) || (NATIVE_TO_UNI((U8) c) >= 0xAA \
&& ((NATIVE_TO_UNI((U8) c) >= 0xC0 \
- && NATIVE_TO_UNI((U8) c) != 0xD7 && NATIVE_TO_UNI((U8) c) != 0xF7) \
+ && NATIVE_TO_UNI((U8) c) != 0xD7 && NATIVE_TO_UNI((U8) c) != 0xF7) \
|| NATIVE_TO_UNI((U8) c) == 0xAA \
|| NATIVE_TO_UNI((U8) c) == 0xB5 \
|| NATIVE_TO_UNI((U8) c) == 0xBA)))
-# define isCHARNAME_CONT(c) (isALNUM_L1(c) || (c) == ' ' || (c) == '-' || (c) == '(' || (c) == ')' || (c) == ':' || NATIVE_TO_UNI((U8) c) == 0xA0)
+# define isCHARNAME_CONT(c) (isWORDCHAR_L1(c) \
+ || (c) == ' ' \
+ || (c) == '-' \
+ || (c) == '(' \
+ || (c) == ')' \
+ || (c) == ':' \
+ || NATIVE_TO_UNI((U8) c) == 0xA0)
#endif
-/* Macros for backwards compatibility and for completeness when the ASCII and
- * Latin1 values are identical */
-#define isALNUM(c) isWORDCHAR(c)
-#define isALNUMU(c) isWORDCHAR_L1(c)
-#define isALPHAU(c) isALPHA_L1(c)
-#define isDIGIT_L1(c) isDIGIT_A(c)
-#define isOCTAL(c) isOCTAL_A(c)
-#define isOCTAL_L1(c) isOCTAL_A(c)
-#define isXDIGIT_L1(c) isXDIGIT_A(c)
-
/* Macros that differ between EBCDIC and ASCII. Where C89 defines a function,
* that is used in the EBCDIC form, because in EBCDIC we do not do locales:
* therefore can use native functions. For those where C89 doesn't define a
@@ -727,8 +1003,8 @@
* with Latin1, which the three currently recognized by Perl are. Some libc's
* have an isblank(), but it's not guaranteed. */
#ifdef EBCDIC
-# define isALNUMC(c) isalnum(c)
# define isALPHA(c) isalpha(c)
+# define isALPHANUMERIC(c) isalnum(c)
# define isBLANK(c) ((c) == ' ' || (c) == '\t' || NATIVE_TO_UNI(c) == 0xA0)
# define isCNTRL(c) iscntrl(c)
# define isDIGIT(c) isdigit(c)
@@ -738,7 +1014,8 @@
# define isPRINT(c) isprint(c)
# define isPSXSPC(c) isspace(c)
# define isPUNCT(c) ispunct(c)
-# define isSPACE(c) (isPSXSPC(c) && (c) != '\v')
+# define isSPACE(c) (isPSXSPC(c) /* && (c) != '\v' (Experimentally making
+ these macros identical) */)
# define isUPPER(c) isupper(c)
# define isXDIGIT(c) isxdigit(c)
# define isWORDCHAR(c) (isalnum(c) || (c) == '_')
@@ -745,7 +1022,7 @@
# define toLOWER(c) tolower(c)
# define toUPPER(c) toupper(c)
#else /* Not EBCDIC: ASCII-only matching */
-# define isALNUMC(c) isALNUMC_A(c)
+# define isALPHANUMERIC(c) isALPHANUMERIC_A(c)
# define isALPHA(c) isALPHA_A(c)
# define isBLANK(c) isBLANK_A(c)
# define isCNTRL(c) isCNTRL_A(c)
@@ -787,150 +1064,318 @@
#ifdef USE_NEXT_CTYPE
-# define isALNUM_LC(c) \
- (NXIsAlNum((unsigned int)(c)) || (char)(c) == '_')
-# define isIDFIRST_LC(c) \
- (NXIsAlpha((unsigned int)(c)) || (char)(c) == '_')
+# define isALPHANUMERIC_LC(c) NXIsAlNum((unsigned int)(c))
# define isALPHA_LC(c) NXIsAlpha((unsigned int)(c))
-# define isSPACE_LC(c) NXIsSpace((unsigned int)(c))
+# define isASCII_LC(c) isASCII((unsigned int)(c))
+# define isBLANK_LC(c) isBLANK((unsigned int)(c))
+# define isCNTRL_LC(c) NXIsCntrl((unsigned int)(c))
# define isDIGIT_LC(c) NXIsDigit((unsigned int)(c))
-# define isUPPER_LC(c) NXIsUpper((unsigned int)(c))
+# define isGRAPH_LC(c) NXIsGraph((unsigned int)(c))
+# define isIDFIRST_LC(c) (NXIsAlpha((unsigned int)(c)) || (char)(c) == '_')
# define isLOWER_LC(c) NXIsLower((unsigned int)(c))
-# define isALNUMC_LC(c) NXIsAlNum((unsigned int)(c))
-# define isCNTRL_LC(c) NXIsCntrl((unsigned int)(c))
-# define isGRAPH_LC(c) NXIsGraph((unsigned int)(c))
# define isPRINT_LC(c) NXIsPrint((unsigned int)(c))
# define isPUNCT_LC(c) NXIsPunct((unsigned int)(c))
+# define isSPACE_LC(c) NXIsSpace((unsigned int)(c))
+# define isUPPER_LC(c) NXIsUpper((unsigned int)(c))
+# define isWORDCHAR_LC(c) (NXIsAlNum((unsigned int)(c)) || (char)(c) == '_')
+# define isXDIGIT_LC(c) NXIsXDigit((unsigned int)(c))
+# define toLOWER_LC(c) NXToLower((unsigned int)(c))
# define toUPPER_LC(c) NXToUpper((unsigned int)(c))
-# define toLOWER_LC(c) NXToLower((unsigned int)(c))
#else /* !USE_NEXT_CTYPE */
# if defined(CTYPE256) || (!defined(isascii) && !defined(HAS_ISASCII))
-# define isALNUM_LC(c) (isalnum((unsigned char)(c)) || (char)(c) == '_')
-# define isIDFIRST_LC(c) (isalpha((unsigned char)(c)) || (char)(c) == '_')
-# define isALPHA_LC(c) isalpha((unsigned char)(c))
-# define isSPACE_LC(c) isspace((unsigned char)(c))
-# define isDIGIT_LC(c) isdigit((unsigned char)(c))
-# define isUPPER_LC(c) isupper((unsigned char)(c))
-# define isLOWER_LC(c) islower((unsigned char)(c))
-# define isALNUMC_LC(c) isalnum((unsigned char)(c))
-# define isCNTRL_LC(c) iscntrl((unsigned char)(c))
-# define isGRAPH_LC(c) isgraph((unsigned char)(c))
-# define isPRINT_LC(c) isprint((unsigned char)(c))
-# define isPUNCT_LC(c) ispunct((unsigned char)(c))
-# define toUPPER_LC(c) toupper((unsigned char)(c))
-# define toLOWER_LC(c) tolower((unsigned char)(c))
+/* Use foo_LC_uvchr() instead of these for beyond the Latin1 range */
+# define isALPHA_LC(c) (FITS_IN_8_BITS(c) && isalpha((unsigned char)(c)))
+# define isALPHANUMERIC_LC(c) (FITS_IN_8_BITS(c) \
+ && isalnum((unsigned char)(c)))
+# ifdef HAS_ISASCII
+# define isASCII_LC(c) (FITS_IN_8_BITS(c) && isascii((unsigned char)(c)))
+# else
+# define isASCII_LC(c) (FITS_IN_8_BITS(c) && isASCII((unsigned char)(c)))
+# endif
+# ifdef HAS_ISBLANK
+# define isBLANK_LC(c) (FITS_IN_8_BITS(c) && isblank((unsigned char)(c)))
+# else
+# define isBLANK_LC(c) (FITS_IN_8_BITS(c) && isBLANK((unsigned char)(c)))
+# endif
+# define isCNTRL_LC(c) (FITS_IN_8_BITS(c) && iscntrl((unsigned char)(c)))
+# define isDIGIT_LC(c) (FITS_IN_8_BITS(c) && isdigit((unsigned char)(c)))
+# define isGRAPH_LC(c) (FITS_IN_8_BITS(c) && isgraph((unsigned char)(c)))
+# define isIDFIRST_LC(c) (FITS_IN_8_BITS(c) \
+ && (isalpha((unsigned char)(c)) || (char)(c) == '_'))
+# define isLOWER_LC(c) (FITS_IN_8_BITS(c) && islower((unsigned char)(c)))
+# define isPRINT_LC(c) (FITS_IN_8_BITS(c) && isprint((unsigned char)(c)))
+# define isPUNCT_LC(c) (FITS_IN_8_BITS(c) && ispunct((unsigned char)(c)))
+# define isSPACE_LC(c) (FITS_IN_8_BITS(c) && isspace((unsigned char)(c)))
+# define isUPPER_LC(c) (FITS_IN_8_BITS(c) && isupper((unsigned char)(c)))
+# define isWORDCHAR_LC(c) (FITS_IN_8_BITS(c) \
+ && (isalnum((unsigned char)(c)) || (char)(c) == '_'))
+# define isXDIGIT_LC(c) (FITS_IN_8_BITS(c) && isxdigit((unsigned char)(c)))
+# define toLOWER_LC(c) (FITS_IN_8_BITS(c) ? tolower((unsigned char)(c)) : (c))
+# define toUPPER_LC(c) (FITS_IN_8_BITS(c) ? toupper((unsigned char)(c)) : (c))
+
# else
-# define isALNUM_LC(c) (isascii(c) && (isalnum(c) || (c) == '_'))
-# define isIDFIRST_LC(c) (isascii(c) && (isalpha(c) || (c) == '_'))
# define isALPHA_LC(c) (isascii(c) && isalpha(c))
-# define isSPACE_LC(c) (isascii(c) && isspace(c))
+# define isALPHANUMERIC_LC(c) (isascii(c) && isalnum(c))
+# define isASCII_LC(c) isascii(c)
+# ifdef HAS_ISBLANK
+# define isBLANK_LC(c) (isascii(c) && isblank(c))
+# else
+# define isBLANK_LC(c) isBLANK_A(c)
+# endif
+# define isCNTRL_LC(c) (isascii(c) && iscntrl(c))
# define isDIGIT_LC(c) (isascii(c) && isdigit(c))
-# define isUPPER_LC(c) (isascii(c) && isupper(c))
+# define isGRAPH_LC(c) (isascii(c) && isgraph(c))
+# define isIDFIRST_LC(c) (isascii(c) && (isalpha(c) || (c) == '_'))
# define isLOWER_LC(c) (isascii(c) && islower(c))
-# define isALNUMC_LC(c) (isascii(c) && isalnum(c))
-# define isCNTRL_LC(c) (isascii(c) && iscntrl(c))
-# define isGRAPH_LC(c) (isascii(c) && isgraph(c))
# define isPRINT_LC(c) (isascii(c) && isprint(c))
# define isPUNCT_LC(c) (isascii(c) && ispunct(c))
-# define toUPPER_LC(c) toupper(c)
-# define toLOWER_LC(c) tolower(c)
+# define isSPACE_LC(c) (isascii(c) && isspace(c))
+# define isUPPER_LC(c) (isascii(c) && isupper(c))
+# define isWORDCHAR_LC(c) (isascii(c) && (isalnum(c) || (c) == '_'))
+# define isXDIGIT_LC(c) (isascii(c) && isxdigit(c))
+# define toLOWER_LC(c) (isascii(c) ? tolower(c) : (c))
+# define toUPPER_LC(c) (isascii(c) ? toupper(c) : (c))
# endif
#endif /* USE_NEXT_CTYPE */
-#define isPSXSPC_LC(c) (isSPACE_LC(c) || (c) == '\v')
-#define isBLANK_LC(c) isBLANK(c) /* could be wrong */
+#define isIDCONT(c) isWORDCHAR(c)
+#define isIDCONT_A(c) isWORDCHAR_A(c)
+#define isIDCONT_L1(c) isWORDCHAR_L1(c)
+#define isIDCONT_LC(c) isWORDCHAR_LC(c)
+#define isPSXSPC_LC(c) isSPACE_LC(c)
-#define isALNUM_uni(c) is_uni_alnum(c)
-#define isIDFIRST_uni(c) is_uni_idfirst(c)
-#define isALPHA_uni(c) is_uni_alpha(c)
-#define isSPACE_uni(c) is_uni_space(c)
-#define isDIGIT_uni(c) is_uni_digit(c)
-#define isUPPER_uni(c) is_uni_upper(c)
-#define isLOWER_uni(c) is_uni_lower(c)
-#define isASCII_uni(c) is_uni_ascii(c)
-#define isCNTRL_uni(c) is_uni_cntrl(c)
-#define isGRAPH_uni(c) is_uni_graph(c)
-#define isPRINT_uni(c) is_uni_print(c)
-#define isPUNCT_uni(c) is_uni_punct(c)
-#define isXDIGIT_uni(c) is_uni_xdigit(c)
+/* For internal core Perl use only. If the input is Latin1, use the Latin1
+ * macro; otherwise use the function 'above_latin1'. Won't compile if 'c' isn't unsigned, as
+ * won't match above_latin1 prototype. The macros do bounds checking, so have
+ * duplicate checks here, so could create versions of the macros that don't,
+ * but experiments show that gcc optimizes them out anyway. */
+
+/* Note that all ignore 'use bytes' */
+#define _generic_uni(classnum, above_latin1, c) ((c) < 256 \
+ ? _generic_isCC(c, classnum) \
+ : above_latin1(c))
+#define _generic_swash_uni(classnum, c) ((c) < 256 \
+ ? _generic_isCC(c, classnum) \
+ : _is_uni_FOO(classnum, c))
+#define isALPHA_uni(c) _generic_swash_uni(_CC_ALPHA, c)
+#define isALPHANUMERIC_uni(c) _generic_swash_uni(_CC_ALPHANUMERIC, c)
+#define isASCII_uni(c) isASCII(c)
+#define isBLANK_uni(c) _generic_uni(_CC_BLANK, is_HORIZWS_cp_high, c)
+#define isCNTRL_uni(c) isCNTRL_L1(c) /* All controls are in Latin1 */
+#define isDIGIT_uni(c) _generic_swash_uni(_CC_DIGIT, c)
+#define isGRAPH_uni(c) _generic_swash_uni(_CC_GRAPH, c)
+#define isIDCONT_uni(c) _generic_uni(_CC_WORDCHAR, _is_uni_perl_idcont, c)
+#define isIDFIRST_uni(c) _generic_uni(_CC_IDFIRST, _is_uni_perl_idstart, c)
+#define isLOWER_uni(c) _generic_swash_uni(_CC_LOWER, c)
+#define isPRINT_uni(c) _generic_swash_uni(_CC_PRINT, c)
+
+/* Posix and regular space are identical above Latin1 */
+#define isPSXSPC_uni(c) _generic_uni(_CC_PSXSPC, is_XPERLSPACE_cp_high, c)
+
+#define isPUNCT_uni(c) _generic_swash_uni(_CC_PUNCT, c)
+#define isSPACE_uni(c) _generic_uni(_CC_SPACE, is_XPERLSPACE_cp_high, c)
+#define isUPPER_uni(c) _generic_swash_uni(_CC_UPPER, c)
+#define isVERTWS_uni(c) _generic_uni(_CC_VERTSPACE, is_VERTWS_cp_high, c)
+#define isWORDCHAR_uni(c) _generic_swash_uni(_CC_WORDCHAR, c)
+#define isXDIGIT_uni(c) _generic_uni(_CC_XDIGIT, is_XDIGIT_cp_high, c)
+
+#define toFOLD_uni(c,s,l) to_uni_fold(c,s,l)
+#define toLOWER_uni(c,s,l) to_uni_lower(c,s,l)
+#define toTITLE_uni(c,s,l) to_uni_title(c,s,l)
#define toUPPER_uni(c,s,l) to_uni_upper(c,s,l)
-#define toTITLE_uni(c,s,l) to_uni_title(c,s,l)
-#define toLOWER_uni(c,s,l) to_uni_lower(c,s,l)
-#define toFOLD_uni(c,s,l) to_uni_fold(c,s,l)
-#define isPSXSPC_uni(c) (isSPACE_uni(c) ||(c) == '\f')
-#define isBLANK_uni(c) isBLANK(c) /* could be wrong */
+#define _generic_LC_uvchr(latin1, above_latin1, c) \
+ (c < 256 ? latin1(c) : above_latin1(c))
+#define _generic_LC_swash_uvchr(latin1, classnum, c) \
+ (c < 256 ? latin1(c) : _is_uni_FOO(classnum, c))
-#define isALNUM_LC_uvchr(c) (c < 256 ? isALNUM_LC(c) : is_uni_alnum_lc(c))
-#define isIDFIRST_LC_uvchr(c) (c < 256 ? isIDFIRST_LC(c) : is_uni_idfirst_lc(c))
-#define isALPHA_LC_uvchr(c) (c < 256 ? isALPHA_LC(c) : is_uni_alpha_lc(c))
-#define isSPACE_LC_uvchr(c) (c < 256 ? isSPACE_LC(c) : is_uni_space_lc(c))
-#define isDIGIT_LC_uvchr(c) (c < 256 ? isDIGIT_LC(c) : is_uni_digit_lc(c))
-#define isUPPER_LC_uvchr(c) (c < 256 ? isUPPER_LC(c) : is_uni_upper_lc(c))
-#define isLOWER_LC_uvchr(c) (c < 256 ? isLOWER_LC(c) : is_uni_lower_lc(c))
-#define isCNTRL_LC_uvchr(c) (c < 256 ? isCNTRL_LC(c) : is_uni_cntrl_lc(c))
-#define isGRAPH_LC_uvchr(c) (c < 256 ? isGRAPH_LC(c) : is_uni_graph_lc(c))
-#define isPRINT_LC_uvchr(c) (c < 256 ? isPRINT_LC(c) : is_uni_print_lc(c))
-#define isPUNCT_LC_uvchr(c) (c < 256 ? isPUNCT_LC(c) : is_uni_punct_lc(c))
+#define isALPHA_LC_uvchr(c) _generic_LC_swash_uvchr(isALPHA_LC, _CC_ALPHA, c)
+#define isALPHANUMERIC_LC_uvchr(c) _generic_LC_swash_uvchr(isALPHANUMERIC_LC, \
+ _CC_ALPHANUMERIC, c)
+#define isASCII_LC_uvchr(c) isASCII_LC(c)
+#define isBLANK_LC_uvchr(c) _generic_LC_uvchr(isBLANK_LC, is_HORIZWS_cp_high, c)
+#define isCNTRL_LC_uvchr(c) (c < 256 ? isCNTRL_LC(c) : 0)
+#define isDIGIT_LC_uvchr(c) _generic_LC_swash_uvchr(isDIGIT_LC, _CC_DIGIT, c)
+#define isGRAPH_LC_uvchr(c) _generic_LC_swash_uvchr(isGRAPH_LC, _CC_GRAPH, c)
+#define isIDCONT_LC_uvchr(c) _generic_LC_uvchr(isIDCONT_LC, \
+ _is_uni_perl_idcont, c)
+#define isIDFIRST_LC_uvchr(c) _generic_LC_uvchr(isIDFIRST_LC, \
+ _is_uni_perl_idstart, c)
+#define isLOWER_LC_uvchr(c) _generic_LC_swash_uvchr(isLOWER_LC, _CC_LOWER, c)
+#define isPRINT_LC_uvchr(c) _generic_LC_swash_uvchr(isPRINT_LC, _CC_PRINT, c)
+#define isPSXSPC_LC_uvchr(c) isSPACE_LC_uvchr(c) /* space is identical to posix
+ space under locale */
+#define isPUNCT_LC_uvchr(c) _generic_LC_swash_uvchr(isPUNCT_LC, _CC_PUNCT, c)
+#define isSPACE_LC_uvchr(c) _generic_LC_uvchr(isSPACE_LC, \
+ is_XPERLSPACE_cp_high, c)
+#define isUPPER_LC_uvchr(c) _generic_LC_swash_uvchr(isUPPER_LC, _CC_UPPER, c)
+#define isWORDCHAR_LC_uvchr(c) _generic_LC_swash_uvchr(isWORDCHAR_LC, \
+ _CC_WORDCHAR, c)
+#define isXDIGIT_LC_uvchr(c) _generic_LC_uvchr(isXDIGIT_LC, is_XDIGIT_cp_high, c)
-#define isPSXSPC_LC_uni(c) (isSPACE_LC_uni(c) ||(c) == '\f')
-#define isBLANK_LC_uni(c) isBLANK(c) /* could be wrong */
-#define isALNUM_utf8(p) is_utf8_alnum(p)
+#define isBLANK_LC_uni(c) isBLANK_LC_uvchr(UNI_TO_NATIVE(c))
+
+/* Everything whose name begins with an underscore is for internal core Perl
+ * use only. */
+
+/* If the input is in the Latin1 range, use
+ * the Latin1 macro 'classnum' on 'p' which is a pointer to a UTF-8 string.
+ * Otherwise use the value given by the 'utf8' parameter. This relies on the
+ * fact that ASCII characters have the same representation whether utf8 or not.
+ * Note that it assumes that the utf8 has been validated, and ignores 'use
+ * bytes' */
+#define _generic_utf8(classnum, p, utf8) (UTF8_IS_INVARIANT(*(p)) \
+ ? _generic_isCC(*(p), classnum) \
+ : (UTF8_IS_DOWNGRADEABLE_START(*(p))) \
+ ? _generic_isCC( \
+ TWO_BYTE_UTF8_TO_UNI(*(p), \
+ *((p)+1 )), \
+ classnum) \
+ : utf8)
+/* Like the above, but calls 'above_latin1(p)' to get the utf8 value. 'above_latin1'
+ * can be a macro */
+#define _generic_func_utf8(classnum, above_latin1, p) \
+ _generic_utf8(classnum, p, above_latin1(p))
+/* Like the above, but passes classnum to _isFOO_utf8(), instead of having a
+ * 'above_latin1' parameter */
+#define _generic_swash_utf8(classnum, p) \
+ _generic_utf8(classnum, p, _is_utf8_FOO(classnum, p))
+
+/* Like the above, but should be used only when it is known that there are no
+ * characters in the range 128-255 which the class is TRUE for. Hence it can
+ * skip the tests for this range. 'above_latin1' should include its arguments */
+#define _generic_utf8_no_upper_latin1(classnum, p, above_latin1) \
+ (UTF8_IS_INVARIANT(*(p)) \
+ ? _generic_isCC(*(p), classnum) \
+ : (UTF8_IS_ABOVE_LATIN1(*(p))) \
+ ? above_latin1 \
+ : 0)
+
+/* NOTE that some of these macros have very similar ones in regcharclass.h.
+ * For example, there is (at the time of this writing) an 'is_SPACE_utf8()'
+ * there, differing in name only by an underscore from the one here
+ * 'isSPACE_utf8(). The difference is that the ones here are probably more
+ * efficient and smaller, using an O(1) array lookup for Latin1-range code
+ * points; the regcharclass.h ones are implemented as a series of
+ * "if-else-if-else ..." */
+
+#define isALPHA_utf8(p) _generic_swash_utf8(_CC_ALPHA, p)
+#define isALPHANUMERIC_utf8(p) _generic_swash_utf8(_CC_ALPHANUMERIC, p)
+#define isASCII_utf8(p) isASCII(*p) /* Because ASCII is invariant under
+ utf8, the non-utf8 macro works
+ */
+#define isBLANK_utf8(p) _generic_func_utf8(_CC_BLANK, is_HORIZWS_high, p)
+#define isCNTRL_utf8(p) _generic_utf8(_CC_CNTRL, p, 0)
+#define isDIGIT_utf8(p) _generic_utf8_no_upper_latin1(_CC_DIGIT, p, \
+ _is_utf8_FOO(_CC_DIGIT, p))
+#define isGRAPH_utf8(p) _generic_swash_utf8(_CC_GRAPH, p)
+#define isIDCONT_utf8(p) _generic_func_utf8(_CC_WORDCHAR, \
+ _is_utf8_perl_idcont, p)
+
/* To prevent S_scan_word in toke.c from hanging, we have to make sure that
* IDFIRST is an alnum. See
- * http://rt.perl.org/rt3/Ticket/Display.html?id=74022
- * for more detail than you ever wanted to know about. This used to be not the
- * XID version, but we decided to go with the more modern Unicode definition */
-#define isIDFIRST_utf8(p) (is_utf8_xidfirst(p) && is_utf8_alnum(p))
-#define isIDCONT_utf8(p) is_utf8_xidcont(p)
-#define isALPHA_utf8(p) is_utf8_alpha(p)
-#define isSPACE_utf8(p) is_utf8_space(p)
-#define isDIGIT_utf8(p) is_utf8_digit(p)
-#define isUPPER_utf8(p) is_utf8_upper(p)
-#define isLOWER_utf8(p) is_utf8_lower(p)
-#define isASCII_utf8(p) is_utf8_ascii(p)
-#define isCNTRL_utf8(p) is_utf8_cntrl(p)
-#define isGRAPH_utf8(p) is_utf8_graph(p)
-#define isPRINT_utf8(p) is_utf8_print(p)
-#define isPUNCT_utf8(p) is_utf8_punct(p)
-#define isXDIGIT_utf8(p) is_utf8_xdigit(p)
+ * http://rt.perl.org/rt3/Ticket/Display.html?id=74022 for more detail than you
+ * ever wanted to know about. (In the ASCII range, there isn't a difference.)
+ * This used to be not the XID version, but we decided to go with the more
+ * modern Unicode definition */
+#define isIDFIRST_utf8(p) _generic_func_utf8(_CC_IDFIRST, \
+ _is_utf8_perl_idstart, p)
+
+#define isLOWER_utf8(p) _generic_swash_utf8(_CC_LOWER, p)
+#define isPRINT_utf8(p) _generic_swash_utf8(_CC_PRINT, p)
+
+/* Posix and regular space are identical above Latin1 */
+#define isPSXSPC_utf8(p) _generic_func_utf8(_CC_PSXSPC, is_XPERLSPACE_high, p)
+
+#define isPUNCT_utf8(p) _generic_swash_utf8(_CC_PUNCT, p)
+#define isSPACE_utf8(p) _generic_func_utf8(_CC_SPACE, is_XPERLSPACE_high, p)
+#define isUPPER_utf8(p) _generic_swash_utf8(_CC_UPPER, p)
+#define isVERTWS_utf8(p) _generic_func_utf8(_CC_VERTSPACE, is_VERTWS_high, p)
+#define isWORDCHAR_utf8(p) _generic_swash_utf8(_CC_WORDCHAR, p)
+#define isXDIGIT_utf8(p) _generic_utf8_no_upper_latin1(_CC_XDIGIT, p, \
+ is_XDIGIT_high(p))
+
+#define toLOWER_utf8(p,s,l) to_utf8_lower(p,s,l)
+#define toTITLE_utf8(p,s,l) to_utf8_title(p,s,l)
#define toUPPER_utf8(p,s,l) to_utf8_upper(p,s,l)
-#define toTITLE_utf8(p,s,l) to_utf8_title(p,s,l)
-#define toLOWER_utf8(p,s,l) to_utf8_lower(p,s,l)
-#define isPSXSPC_utf8(c) (isSPACE_utf8(c) ||(c) == '\f')
-#define isBLANK_utf8(c) isBLANK(c) /* could be wrong */
+/* For internal core Perl use only. If the input is in the Latin1 range, use
+ * the macro 'macro' on 'p' which is a pointer to a UTF-8 string. Otherwise
+ * use the value given by the 'utf8' parameter. This relies on the fact that
+ * ASCII characters have the same representation whether utf8 or not. Note
+ * that it assumes that the utf8 has been validated, and ignores 'use bytes' */
+#define _generic_LC_utf8(macro, p, utf8) \
+ (UTF8_IS_INVARIANT(*(p)) \
+ ? macro(*(p)) \
+ : (UTF8_IS_DOWNGRADEABLE_START(*(p))) \
+ ? macro(TWO_BYTE_UTF8_TO_UNI(*(p), *((p)+1))) \
+ : utf8)
-#define isALNUM_LC_utf8(p) isALNUM_LC_uvchr(utf8_to_uvchr(p, 0))
-#define isIDFIRST_LC_utf8(p) isIDFIRST_LC_uvchr(utf8_to_uvchr(p, 0))
-#define isALPHA_LC_utf8(p) isALPHA_LC_uvchr(utf8_to_uvchr(p, 0))
-#define isSPACE_LC_utf8(p) isSPACE_LC_uvchr(utf8_to_uvchr(p, 0))
-#define isDIGIT_LC_utf8(p) isDIGIT_LC_uvchr(utf8_to_uvchr(p, 0))
-#define isUPPER_LC_utf8(p) isUPPER_LC_uvchr(utf8_to_uvchr(p, 0))
-#define isLOWER_LC_utf8(p) isLOWER_LC_uvchr(utf8_to_uvchr(p, 0))
-#define isALNUMC_LC_utf8(p) isALNUMC_LC_uvchr(utf8_to_uvchr(p, 0))
-#define isCNTRL_LC_utf8(p) isCNTRL_LC_uvchr(utf8_to_uvchr(p, 0))
-#define isGRAPH_LC_utf8(p) isGRAPH_LC_uvchr(utf8_to_uvchr(p, 0))
-#define isPRINT_LC_utf8(p) isPRINT_LC_uvchr(utf8_to_uvchr(p, 0))
-#define isPUNCT_LC_utf8(p) isPUNCT_LC_uvchr(utf8_to_uvchr(p, 0))
+#define _generic_LC_swash_utf8(macro, classnum, p) \
+ _generic_LC_utf8(macro, p, _is_utf8_FOO(classnum, p))
+#define _generic_LC_func_utf8(macro, above_latin1, p) \
+ _generic_LC_utf8(macro, p, above_latin1(p))
-#define isPSXSPC_LC_utf8(c) (isSPACE_LC_utf8(c) ||(c) == '\f')
-#define isBLANK_LC_utf8(c) isBLANK(c) /* could be wrong */
+#define isALPHANUMERIC_LC_utf8(p) _generic_LC_swash_utf8(isALPHANUMERIC_LC, \
+ _CC_ALPHANUMERIC, p)
+#define isALPHA_LC_utf8(p) _generic_LC_swash_utf8(isALPHA_LC, _CC_ALPHA, p)
+#define isASCII_LC_utf8(p) isASCII_LC(*p)
+#define isBLANK_LC_utf8(p) _generic_LC_func_utf8(isBLANK_LC, is_HORIZWS_high, p)
+#define isCNTRL_LC_utf8(p) _generic_LC_utf8(isCNTRL_LC, p, 0)
+#define isDIGIT_LC_utf8(p) _generic_LC_swash_utf8(isDIGIT_LC, _CC_DIGIT, p)
+#define isGRAPH_LC_utf8(p) _generic_LC_swash_utf8(isGRAPH_LC, _CC_GRAPH, p)
+#define isIDCONT_LC_utf8(p) _generic_LC_func_utf8(isIDCONT_LC, _is_utf8_perl_idcont, p)
+#define isIDFIRST_LC_utf8(p) _generic_LC_func_utf8(isIDFIRST_LC, _is_utf8_perl_idstart, p)
+#define isLOWER_LC_utf8(p) _generic_LC_swash_utf8(isLOWER_LC, _CC_LOWER, p)
+#define isPRINT_LC_utf8(p) _generic_LC_swash_utf8(isPRINT_LC, _CC_PRINT, p)
+#define isPSXSPC_LC_utf8(p) isSPACE_LC_utf8(p) /* space is identical to posix
+ space under locale */
+#define isPUNCT_LC_utf8(p) _generic_LC_swash_utf8(isPUNCT_LC, _CC_PUNCT, p)
+#define isSPACE_LC_utf8(p) _generic_LC_func_utf8(isSPACE_LC, is_XPERLSPACE_high, p)
+#define isUPPER_LC_utf8(p) _generic_LC_swash_utf8(isUPPER_LC, _CC_UPPER, p)
+#define isWORDCHAR_LC_utf8(p) _generic_LC_swash_utf8(isWORDCHAR_LC, \
+ _CC_WORDCHAR, p)
+#define isXDIGIT_LC_utf8(p) _generic_LC_func_utf8(isXDIGIT_LC, is_XDIGIT_high, p)
+/* Macros for backwards compatibility and for completeness when the ASCII and
+ * Latin1 values are identical */
+#define isALPHAU(c) isALPHA_L1(c)
+#define isDIGIT_L1(c) isDIGIT_A(c)
+#define isOCTAL(c) isOCTAL_A(c)
+#define isOCTAL_L1(c) isOCTAL_A(c)
+#define isXDIGIT_L1(c) isXDIGIT_A(c)
+#define isALNUM(c) isWORDCHAR(c)
+#define isALNUMU(c) isWORDCHAR_L1(c)
+#define isALNUM_LC(c) isWORDCHAR_LC(c)
+#define isALNUM_uni(c) isWORDCHAR_uni(c)
+#define isALNUM_LC_uvchr(c) isWORDCHAR_LC_uvchr(c)
+#define isALNUM_utf8(p) isWORDCHAR_utf8(p)
+#define isALNUM_LC_utf8(p) isWORDCHAR_LC_utf8(p)
+#define isALNUMC_A(c) isALPHANUMERIC_A(c) /* Mnemonic: "C's alnum" */
+#define isALNUMC_L1(c) isALPHANUMERIC_L1(c)
+#define isALNUMC(c) isALPHANUMERIC(c)
+#define isALNUMC_LC(c) isALPHANUMERIC_LC(c)
+#define isALNUMC_uni(c) isALPHANUMERIC_uni(c)
+#define isALNUMC_LC_uvchr(c) isALPHANUMERIC_LC_uvchr(c)
+#define isALNUMC_utf8(p) isALPHANUMERIC_utf8(p)
+#define isALNUMC_LC_utf8(p) isALPHANUMERIC_LC_utf8(p)
+
/* This conversion works both ways, strangely enough. On EBCDIC platforms,
- * CTRL-@ is 0, CTRL-A is 1, etc, just like on ASCII */
+ * CTRL-@ is 0, CTRL-A is 1, etc, just like on ASCII, except that they don't
+ * necessarily mean the same characters, e.g. CTRL-D is 4 on both systems, but
+ * that is EOT on ASCII; ST on EBCDIC */
# define toCTRL(c) (toUPPER(NATIVE_TO_UNI(c)) ^ 64)
/* Line numbers are unsigned, 32 bits. */
typedef U32 line_t;
-#define NOLINE ((line_t) 4294967295UL)
+#define NOLINE ((line_t) 4294967295UL) /* = FFFFFFFF */
/* Helpful alias for version prescan */
#define is_LAX_VERSION(a,b) \
@@ -945,6 +1390,8 @@
} \
return a;
+#define READ_XDIGIT(s) (isALPHA(*(s)) ? ((*(s)++ + 9) & 0xf) : (*(s)++ & 0xf))
+
/*
=head1 Memory Management
@@ -954,7 +1401,7 @@
In 5.9.3, Newx() and friends replace the older New() API, and drops
the first parameter, I<x>, a debug aid which allowed callers to identify
themselves. This aid has been superseded by a new build option,
-PERL_MEM_LOG (see L<perlhack/PERL_MEM_LOG>). The older API is still
+PERL_MEM_LOG (see L<perlhacktips/PERL_MEM_LOG>). The older API is still
there for use in XS modules supporting older perls.
=for apidoc Am|void|Newxc|void* ptr|int nitems|type|cast
@@ -977,8 +1424,8 @@
=for apidoc Am|void|Move|void* src|void* dest|int nitems|type
The XSUB-writer's interface to the C C<memmove> function. The C<src> is the
-source, C<dest> is the destination, C<nitems> is the number of items, and C<type> is
-the type. Can do overlapping moves. See also C<Copy>.
+source, C<dest> is the destination, C<nitems> is the number of items, and
+C<type> is the type. Can do overlapping moves. See also C<Copy>.
=for apidoc Am|void *|MoveD|void* src|void* dest|int nitems|type
Like C<Move> but returns dest. Useful for encouraging compilers to tail-call
@@ -986,8 +1433,8 @@
=for apidoc Am|void|Copy|void* src|void* dest|int nitems|type
The XSUB-writer's interface to the C C<memcpy> function. The C<src> is the
-source, C<dest> is the destination, C<nitems> is the number of items, and C<type> is
-the type. May fail on overlapping copies. See also C<Move>.
+source, C<dest> is the destination, C<nitems> is the number of items, and
+C<type> is the type. May fail on overlapping copies. See also C<Move>.
=for apidoc Am|void *|CopyD|void* src|void* dest|int nitems|type
@@ -1004,7 +1451,7 @@
Like C<Zero> but returns dest. Useful for encouraging compilers to tail-call
optimise.
-=for apidoc Am|void|StructCopy|type src|type dest|type
+=for apidoc Am|void|StructCopy|type *src|type *dest|type
This is an architecture-independent macro to copy one structure to another.
=for apidoc Am|void|PoisonWith|void* dest|int nitems|type|U8 byte
@@ -1037,13 +1484,13 @@
* overly eager compilers that will bleat about e.g.
* (U16)n > (size_t)~0/sizeof(U16) always being false. */
#ifdef PERL_MALLOC_WRAP
-#define MEM_WRAP_CHECK(n,t) MEM_WRAP_CHECK_1(n,t,PL_memory_wrap)
+#define MEM_WRAP_CHECK(n,t) \
+ (void)(sizeof(t) > 1 && ((MEM_SIZE)(n)+0.0) > MEM_SIZE_MAX/sizeof(t) && (Perl_croak_memory_wrap(),0))
#define MEM_WRAP_CHECK_1(n,t,a) \
(void)(sizeof(t) > 1 && ((MEM_SIZE)(n)+0.0) > MEM_SIZE_MAX/sizeof(t) && (Perl_croak_nocontext("%s",(a)),0))
#define MEM_WRAP_CHECK_(n,t) MEM_WRAP_CHECK(n,t),
-#define PERL_STRLEN_ROUNDUP(n) ((void)(((n) > MEM_SIZE_MAX - 2 * PERL_STRLEN_ROUNDUP_QUANTUM) ? (Perl_croak_nocontext("%s",PL_memory_wrap),0):0),((n-1+PERL_STRLEN_ROUNDUP_QUANTUM)&~((MEM_SIZE)PERL_STRLEN_ROUNDUP_QUANTUM-1)))
-
+#define PERL_STRLEN_ROUNDUP(n) ((void)(((n) > MEM_SIZE_MAX - 2 * PERL_STRLEN_ROUNDUP_QUANTUM) ? (Perl_croak_memory_wrap(),0):0),((n-1+PERL_STRLEN_ROUNDUP_QUANTUM)&~((MEM_SIZE)PERL_STRLEN_ROUNDUP_QUANTUM-1)))
#else
#define MEM_WRAP_CHECK(n,t)
@@ -1214,12 +1661,14 @@
# define deprecate(s) Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), "Use of " s " is deprecated")
#endif
+#endif /* HANDY_H */
+
/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/handy.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/hv.c
===================================================================
--- trunk/contrib/perl/hv.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/hv.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -19,10 +19,10 @@
/*
=head1 Hash Manipulation Functions
-A HV structure represents a Perl hash. It consists mainly of an array
-of pointers, each of which points to a linked list of HE structures. The
+A HV structure represents a Perl hash. It consists mainly of an array
+of pointers, each of which points to a linked list of HE structures. The
array is indexed by the hash function of the key, so each linked list
-represents all the hash entries with the same hash value. Each HE contains
+represents all the hash entries with the same hash value. Each HE contains
a pointer to the actual value, plus a pointer to a HEK structure which
holds the key and hash value.
@@ -35,7 +35,7 @@
#define PERL_HASH_INTERNAL_ACCESS
#include "perl.h"
-#define HV_MAX_LENGTH_BEFORE_SPLIT 14
+#define DO_HSPLIT(xhv) ((xhv)->xhv_keys > (xhv)->xhv_max) /* HvTOTALKEYS(hv) > HvMAX(hv) */
static const char S_strtab_error[]
= "Cannot modify shared string table in hv_%s";
@@ -78,7 +78,7 @@
{
const int flags_masked = flags & HVhek_MASK;
char *k;
- register HEK *hek;
+ HEK *hek;
PERL_ARGS_ASSERT_SAVE_HEK_FLAGS;
@@ -217,9 +217,13 @@
/*
=for apidoc hv_store
-Stores an SV in a hash. The hash key is specified as C<key> and C<klen> is
-the length of the key. The C<hash> parameter is the precomputed hash
-value; if it is zero then Perl will compute it. The return value will be
+Stores an SV in a hash. The hash key is specified as C<key> and the
+absolute value of C<klen> is the length of the key. If C<klen> is
+negative the key is assumed to be in UTF-8-encoded Unicode. The
+C<hash> parameter is the precomputed hash value; if it is zero then
+Perl will compute it.
+
+The return value will be
NULL if the operation failed or if the value did not need to be actually
stored within the hash (as in the case of tied hashes). Otherwise it can
be dereferenced to get the original C<SV*>. Note that the caller is
@@ -265,14 +269,19 @@
=for apidoc hv_exists
Returns a boolean indicating whether the specified hash key exists. The
-C<klen> is the length of the key.
+absolute value of C<klen> is the length of the key. If C<klen> is
+negative the key is assumed to be in UTF-8-encoded Unicode.
=for apidoc hv_fetch
-Returns the SV which corresponds to the specified key in the hash. The
-C<klen> is the length of the key. If C<lval> is set then the fetch will be
-part of a store. Check that the return value is non-null before
-dereferencing it to an C<SV*>.
+Returns the SV which corresponds to the specified key in the hash.
+The absolute value of C<klen> is the length of the key. If C<klen> is
+negative the key is assumed to be in UTF-8-encoded Unicode. If
+C<lval> is set then the fetch will be part of a store. This means that if
+there is no value in the hash associated with the given key, then one is
+created and a pointer to it is returned. The C<SV*> it points to can be
+assigned to. But always check that the
+return value is non-null before dereferencing it to an C<SV*>.
See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
information on how to use this function on tied hashes.
@@ -279,7 +288,8 @@
=for apidoc hv_exists_ent
-Returns a boolean indicating whether the specified hash key exists. C<hash>
+Returns a boolean indicating whether
+the specified hash key exists. C<hash>
can be a valid precomputed hash value, or 0 to ask for it to be
computed.
@@ -327,7 +337,7 @@
void *
Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
- int flags, int action, SV *val, register U32 hash)
+ int flags, int action, SV *val, U32 hash)
{
dVAR;
XPVHV* xhv;
@@ -340,7 +350,7 @@
if (!hv)
return NULL;
- if (SvTYPE(hv) == SVTYPEMASK)
+ if (SvTYPE(hv) == (svtype)SVTYPEMASK)
return NULL;
assert(SvTYPE(hv) == SVt_PVHV);
@@ -378,7 +388,7 @@
if (SvIsCOW_shared_hash(keysv)) {
flags = HVhek_KEYCANONICAL | (is_utf8 ? HVhek_UTF8 : 0);
} else {
- flags = 0;
+ flags = is_utf8 ? HVhek_UTF8 : 0;
}
} else {
is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
@@ -386,8 +396,7 @@
if (action & HV_DELETE) {
return (void *) hv_delete_common(hv, keysv, key, klen,
- flags | (is_utf8 ? HVhek_UTF8 : 0),
- action, hash);
+ flags, action, hash);
}
xhv = (XPVHV*)SvANY(hv);
@@ -517,13 +526,13 @@
bool needs_store;
hv_magic_check (hv, &needs_copy, &needs_store);
if (needs_copy) {
- const bool save_taint = PL_tainted;
+ const bool save_taint = TAINT_get;
if (keysv || is_utf8) {
if (!keysv) {
keysv = newSVpvn_utf8(key, klen, TRUE);
}
- if (PL_tainting)
- PL_tainted = SvTAINTED(keysv);
+ if (TAINTING_get)
+ TAINT_set(SvTAINTED(keysv));
keysv = sv_2mortal(newSVsv(keysv));
mg_copy(MUTABLE_SV(hv), val, (char*)keysv, HEf_SVKEY);
} else {
@@ -531,6 +540,9 @@
}
TAINT_IF(save_taint);
+#ifdef NO_TAINT_SUPPORT
+ PERL_UNUSED_VAR(save_taint);
+#endif
if (!needs_store) {
if (flags & HVhek_FREEKEY)
Safefree(key);
@@ -585,7 +597,7 @@
}
}
- if (is_utf8 & !(flags & HVhek_KEYCANONICAL)) {
+ if (is_utf8 && !(flags & HVhek_KEYCANONICAL)) {
char * const keysave = (char *)key;
key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
if (is_utf8)
@@ -604,20 +616,11 @@
}
}
- if (HvREHASH(hv)) {
- PERL_HASH_INTERNAL(hash, key, klen);
- /* We don't have a pointer to the hv, so we have to replicate the
- flag into every HEK, so that hv_iterkeysv can see it. */
- /* And yes, you do need this even though you are not "storing" because
- you can flip the flags below if doing an lval lookup. (And that
- was put in to give the semantics Andreas was expecting.) */
- flags |= HVhek_REHASH;
- } else if (!hash) {
- if (keysv && (SvIsCOW_shared_hash(keysv))) {
+ if (!hash) {
+ if (keysv && (SvIsCOW_shared_hash(keysv)))
hash = SvSHARED_HASH(keysv);
- } else {
+ else
PERL_HASH(hash, key, klen);
- }
}
masked_flags = (flags & HVhek_MASK);
@@ -786,37 +789,76 @@
else /* gotta do the real thing */
HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
HeVAL(entry) = val;
- HeNEXT(entry) = *oentry;
- *oentry = entry;
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+ /* This logic semi-randomizes the insert order in a bucket.
+ * Either we insert into the top, or the slot below the top,
+ * making it harder to see if there is a collision. We also
+ * reset the iterator randomizer if there is one.
+ */
+ if ( *oentry && PL_HASH_RAND_BITS_ENABLED) {
+ PL_hash_rand_bits++;
+ PL_hash_rand_bits= ROTL_UV(PL_hash_rand_bits,1);
+ if ( PL_hash_rand_bits & 1 ) {
+ HeNEXT(entry) = HeNEXT(*oentry);
+ HeNEXT(*oentry) = entry;
+ } else {
+ HeNEXT(entry) = *oentry;
+ *oentry = entry;
+ }
+ } else
+#endif
+ {
+ HeNEXT(entry) = *oentry;
+ *oentry = entry;
+ }
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+ if (SvOOK(hv)) {
+ /* Currently this makes various tests warn in annoying ways.
+ * So Silenced for now. - Yves | bogus end of comment =>* /
+ if (HvAUX(hv)->xhv_riter != -1) {
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
+ "[TESTING] Inserting into a hash during each() traversal results in undefined behavior"
+ pTHX__FORMAT
+ pTHX__VALUE);
+ }
+ */
+ if (PL_HASH_RAND_BITS_ENABLED) {
+ if (PL_HASH_RAND_BITS_ENABLED == 1)
+ PL_hash_rand_bits += (PTRV)entry + 1; /* we don't bother to use ptr_hash here */
+ PL_hash_rand_bits= ROTL_UV(PL_hash_rand_bits,1);
+ }
+ HvAUX(hv)->xhv_rand= (U32)PL_hash_rand_bits;
+ }
+#endif
+
if (val == &PL_sv_placeholder)
HvPLACEHOLDERS(hv)++;
if (masked_flags & HVhek_ENABLEHVKFLAGS)
HvHASKFLAGS_on(hv);
- {
- const HE *counter = HeNEXT(entry);
+ xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
+ if ( DO_HSPLIT(xhv) ) {
+ const STRLEN oldsize = xhv->xhv_max + 1;
+ const U32 items = (U32)HvPLACEHOLDERS_get(hv);
- xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
- if (!counter) { /* initial entry? */
- } else if (xhv->xhv_keys > xhv->xhv_max) {
- /* Use only the old HvKEYS(hv) > HvMAX(hv) condition to limit
- bucket splits on a rehashed hash, as we're not going to
- split it again, and if someone is lucky (evil) enough to
- get all the keys in one list they could exhaust our memory
- as we repeatedly double the number of buckets on every
- entry. Linear search feels a less worse thing to do. */
- hsplit(hv);
- } else if(!HvREHASH(hv)) {
- U32 n_links = 1;
-
- while ((counter = HeNEXT(counter)))
- n_links++;
-
- if (n_links > HV_MAX_LENGTH_BEFORE_SPLIT) {
- hsplit(hv);
- }
- }
+ if (items /* hash has placeholders */
+ && !SvREADONLY(hv) /* but is not a restricted hash */) {
+ /* If this hash previously was a "restricted hash" and had
+ placeholders, but the "restricted" flag has been turned off,
+ then the placeholders no longer serve any useful purpose.
+ However, they have the downsides of taking up RAM, and adding
+ extra steps when finding used values. It's safe to clear them
+ at this point, even though Storable rebuilds restricted hashes by
+ putting in all the placeholders (first) before turning on the
+ readonly flag, because Storable always pre-splits the hash.
+ If we're lucky, then we may clear sufficient placeholders to
+ avoid needing to split the hash at all. */
+ clear_placeholders(hv, items);
+ if (DO_HSPLIT(xhv))
+ hsplit(hv, oldsize, oldsize * 2);
+ } else
+ hsplit(hv, oldsize, oldsize * 2);
}
if (return_svp) {
@@ -880,10 +922,12 @@
/*
=for apidoc hv_delete
-Deletes a key/value pair in the hash. The value's SV is removed from the
-hash, made mortal, and returned to the caller. The C<klen> is the length of
-the key. The C<flags> value will normally be zero; if set to G_DISCARD then
-NULL will be returned. NULL will also be returned if the key is not found.
+Deletes a key/value pair in the hash. The value's SV is removed from
+the hash, made mortal, and returned to the caller. The absolute
+value of C<klen> is the length of the key. If C<klen> is negative the
+key is assumed to be in UTF-8-encoded Unicode. The C<flags> value
+will normally be zero; if set to G_DISCARD then NULL will be returned.
+NULL will also be returned if the key is not found.
=for apidoc hv_delete_ent
@@ -901,10 +945,9 @@
int k_flags, I32 d_flags, U32 hash)
{
dVAR;
- register XPVHV* xhv;
- register HE *entry;
- register HE **oentry;
- HE *const *first_entry;
+ XPVHV* xhv;
+ HE *entry;
+ HE **oentry;
bool is_utf8 = (k_flags & HVhek_UTF8) ? TRUE : FALSE;
int masked_flags;
@@ -952,7 +995,7 @@
if (!HvARRAY(hv))
return NULL;
- if (is_utf8) {
+ if (is_utf8 && !(k_flags & HVhek_KEYCANONICAL)) {
const char * const keysave = key;
key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
@@ -971,19 +1014,16 @@
HvHASKFLAGS_on(MUTABLE_SV(hv));
}
- if (HvREHASH(hv)) {
- PERL_HASH_INTERNAL(hash, key, klen);
- } else if (!hash) {
- if (keysv && (SvIsCOW_shared_hash(keysv))) {
+ if (!hash) {
+ if (keysv && (SvIsCOW_shared_hash(keysv)))
hash = SvSHARED_HASH(keysv);
- } else {
+ else
PERL_HASH(hash, key, klen);
- }
}
masked_flags = (k_flags & HVhek_MASK);
- first_entry = oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
+ oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
entry = *oentry;
for (; entry; oentry = &HeNEXT(entry), entry = *oentry) {
SV *sv;
@@ -1050,11 +1090,13 @@
mro_changes = 1;
}
- if (d_flags & G_DISCARD)
- sv = NULL;
- else {
- sv = sv_2mortal(HeVAL(entry));
- HeVAL(entry) = &PL_sv_placeholder;
+ sv = d_flags & G_DISCARD ? HeVAL(entry) : sv_2mortal(HeVAL(entry));
+ HeVAL(entry) = &PL_sv_placeholder;
+ if (sv) {
+ /* deletion of method from stash */
+ if (isGV(sv) && isGV_with_GP(sv) && GvCVu(sv)
+ && HvENAME_get(hv))
+ mro_method_changed_in(hv);
}
/*
@@ -1063,13 +1105,11 @@
* we can still access via not-really-existing key without raising
* an error.
*/
- if (SvREADONLY(hv)) {
- SvREFCNT_dec(HeVAL(entry));
- HeVAL(entry) = &PL_sv_placeholder;
+ if (SvREADONLY(hv))
/* We'll be saving this slot, so the number of allocated keys
* doesn't go down, but the number placeholders goes up */
HvPLACEHOLDERS(hv)++;
- } else {
+ else {
*oentry = HeNEXT(entry);
if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */)
HvLAZYDEL_on(hv);
@@ -1084,6 +1124,11 @@
HvHASKFLAGS_off(hv);
}
+ if (d_flags & G_DISCARD) {
+ SvREFCNT_dec(sv);
+ sv = NULL;
+ }
+
if (mro_changes == 1) mro_isa_changed_in(hv);
else if (mro_changes == 2)
mro_package_moved(NULL, stash, gv, 1);
@@ -1102,17 +1147,12 @@
}
STATIC void
-S_hsplit(pTHX_ HV *hv)
+S_hsplit(pTHX_ HV *hv, STRLEN const oldsize, STRLEN newsize)
{
dVAR;
- register XPVHV* const xhv = (XPVHV*)SvANY(hv);
- const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
- register I32 newsize = oldsize * 2;
- register I32 i;
+ STRLEN i = 0;
char *a = (char*) HvARRAY(hv);
- register HE **aep;
- int longest_chain = 0;
- int was_shared;
+ HE **aep;
PERL_ARGS_ASSERT_HSPLIT;
@@ -1119,16 +1159,7 @@
/*PerlIO_printf(PerlIO_stderr(), "hsplit called for %p which had %d\n",
(void*)hv, (int) oldsize);*/
- if (HvPLACEHOLDERS_get(hv) && !SvREADONLY(hv)) {
- /* Can make this clear any placeholders first for non-restricted hashes,
- even though Storable rebuilds restricted hashes by putting in all the
- placeholders (first) before turning on the readonly flag, because
- Storable always pre-splits the hash. */
- hv_clear_placeholders(hv);
- }
-
PL_nomemok = TRUE;
-#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
+ (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
if (!a) {
@@ -1135,129 +1166,80 @@
PL_nomemok = FALSE;
return;
}
- if (SvOOK(hv)) {
- Move(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+ /* the idea of this is that we create a "random" value by hashing the address of
+ * the array, we then use the low bit to decide if we insert at the top, or insert
+ * second from top. After each such insert we rotate the hashed value. So we can
+ * use the same hashed value over and over, and in normal build environments use
+ * very few ops to do so. ROTL32() should produce a single machine operation. */
+ if (PL_HASH_RAND_BITS_ENABLED) {
+ if (PL_HASH_RAND_BITS_ENABLED == 1)
+ PL_hash_rand_bits += ptr_hash((PTRV)a);
+ PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,1);
}
-#else
- Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
- + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
- if (!a) {
- PL_nomemok = FALSE;
- return;
- }
- Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
+#endif
+
if (SvOOK(hv)) {
- Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
+ struct xpvhv_aux *const dest
+ = (struct xpvhv_aux*) &a[newsize * sizeof(HE*)];
+ Move(&a[oldsize * sizeof(HE*)], dest, 1, struct xpvhv_aux);
+ /* we reset the iterator's xhv_rand as well, so they get a totally new ordering */
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+ dest->xhv_rand = (U32)PL_hash_rand_bits;
+#endif
}
- Safefree(HvARRAY(hv));
-#endif
PL_nomemok = FALSE;
Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
- xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
+ HvMAX(hv) = --newsize;
HvARRAY(hv) = (HE**) a;
+
+ if (!HvTOTALKEYS(hv)) /* skip rest if no entries */
+ return;
+
aep = (HE**)a;
+ do {
+ HE **oentry = aep + i;
+ HE *entry = aep[i];
- for (i=0; i<oldsize; i++,aep++) {
- int left_length = 0;
- int right_length = 0;
- HE **oentry = aep;
- HE *entry = *aep;
- register HE **bep;
-
if (!entry) /* non-existent */
continue;
- bep = aep+oldsize;
do {
- if ((HeHASH(entry) & newsize) != (U32)i) {
+ U32 j = (HeHASH(entry) & newsize);
+ if (j != (U32)i) {
*oentry = HeNEXT(entry);
- HeNEXT(entry) = *bep;
- *bep = entry;
- right_length++;
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+ /* if the target cell is empty or PL_HASH_RAND_BITS_ENABLED is false
+ * insert to top, otherwise rotate the bucket rand 1 bit,
+ * and use the new low bit to decide if we insert at top,
+ * or next from top. IOW, we only rotate on a collision.*/
+ if (aep[j] && PL_HASH_RAND_BITS_ENABLED) {
+ PL_hash_rand_bits+= ROTL_UV(HeHASH(entry), 17);
+ PL_hash_rand_bits= ROTL_UV(PL_hash_rand_bits,1);
+ if (PL_hash_rand_bits & 1) {
+ HeNEXT(entry)= HeNEXT(aep[j]);
+ HeNEXT(aep[j])= entry;
+ } else {
+ /* Note, this is structured in such a way as the optimizer
+ * should eliminate the duplicated code here and below without
+ * us needing to explicitly use a goto. */
+ HeNEXT(entry) = aep[j];
+ aep[j] = entry;
+ }
+ } else
+#endif
+ {
+ /* see comment above about duplicated code */
+ HeNEXT(entry) = aep[j];
+ aep[j] = entry;
+ }
}
else {
oentry = &HeNEXT(entry);
- left_length++;
}
entry = *oentry;
} while (entry);
- /* I think we don't actually need to keep track of the longest length,
- merely flag if anything is too long. But for the moment while
- developing this code I'll track it. */
- if (left_length > longest_chain)
- longest_chain = left_length;
- if (right_length > longest_chain)
- longest_chain = right_length;
- }
-
-
- /* Pick your policy for "hashing isn't working" here: */
- if (longest_chain <= HV_MAX_LENGTH_BEFORE_SPLIT /* split worked? */
- || HvREHASH(hv)) {
- return;
- }
-
- if (hv == PL_strtab) {
- /* Urg. Someone is doing something nasty to the string table.
- Can't win. */
- return;
- }
-
- /* Awooga. Awooga. Pathological data. */
- /*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", (void*)hv,
- longest_chain, HvTOTALKEYS(hv), HvFILL(hv), 1+HvMAX(hv));*/
-
- ++newsize;
- Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
- + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
- if (SvOOK(hv)) {
- Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
- }
-
- was_shared = HvSHAREKEYS(hv);
-
- HvSHAREKEYS_off(hv);
- HvREHASH_on(hv);
-
- aep = HvARRAY(hv);
-
- for (i=0; i<newsize; i++,aep++) {
- register HE *entry = *aep;
- while (entry) {
- /* We're going to trash this HE's next pointer when we chain it
- into the new hash below, so store where we go next. */
- HE * const next = HeNEXT(entry);
- UV hash;
- HE **bep;
-
- /* Rehash it */
- PERL_HASH_INTERNAL(hash, HeKEY(entry), HeKLEN(entry));
-
- if (was_shared) {
- /* Unshare it. */
- HEK * const new_hek
- = save_hek_flags(HeKEY(entry), HeKLEN(entry),
- hash, HeKFLAGS(entry));
- unshare_hek (HeKEY_hek(entry));
- HeKEY_hek(entry) = new_hek;
- } else {
- /* Not shared, so simply write the new hash in. */
- HeHASH(entry) = hash;
- }
- /*PerlIO_printf(PerlIO_stderr(), "%d ", HeKFLAGS(entry));*/
- HEK_REHASH_on(HeKEY_hek(entry));
- /*PerlIO_printf(PerlIO_stderr(), "%d\n", HeKFLAGS(entry));*/
-
- /* Copy oentry to the correct new chain. */
- bep = ((HE**)a) + (hash & (I32) xhv->xhv_max);
- HeNEXT(entry) = *bep;
- *bep = entry;
-
- entry = next;
- }
- }
- Safefree (HvARRAY(hv));
- HvARRAY(hv) = (HE **)a;
+ } while (i++ < oldsize);
}
void
@@ -1264,12 +1246,10 @@
Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
{
dVAR;
- register XPVHV* xhv = (XPVHV*)SvANY(hv);
+ XPVHV* xhv = (XPVHV*)SvANY(hv);
const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
- register I32 newsize;
- register I32 i;
- register char *a;
- register HE **aep;
+ I32 newsize;
+ char *a;
PERL_ARGS_ASSERT_HV_KSPLIT;
@@ -1286,64 +1266,29 @@
a = (char *) HvARRAY(hv);
if (a) {
- PL_nomemok = TRUE;
-#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
- Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
- + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
- if (!a) {
- PL_nomemok = FALSE;
- return;
- }
- if (SvOOK(hv)) {
- Copy(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
- }
-#else
- Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
- + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
- if (!a) {
- PL_nomemok = FALSE;
- return;
- }
- Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
- if (SvOOK(hv)) {
- Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
- }
- Safefree(HvARRAY(hv));
-#endif
- PL_nomemok = FALSE;
- Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
+ hsplit(hv, oldsize, newsize);
+ } else {
+ Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
+ xhv->xhv_max = --newsize;
+ HvARRAY(hv) = (HE **) a;
}
- else {
- Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
- }
- xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
- HvARRAY(hv) = (HE **) a;
- if (!xhv->xhv_keys /* !HvTOTALKEYS(hv) */) /* skip rest if no entries */
- return;
+}
- aep = (HE**)a;
- for (i=0; i<oldsize; i++,aep++) {
- HE **oentry = aep;
- HE *entry = *aep;
+/* IMO this should also handle cases where hv_max is smaller than hv_keys
+ * as tied hashes could play silly buggers and mess us around. We will
+ * do the right thing during hv_store() afterwards, but still - Yves */
+#define HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys) STMT_START {\
+ /* Can we use fewer buckets? (hv_max is always 2^n-1) */ \
+ if (hv_max < PERL_HASH_DEFAULT_HvMAX) { \
+ hv_max = PERL_HASH_DEFAULT_HvMAX; \
+ } else { \
+ while (hv_max > PERL_HASH_DEFAULT_HvMAX && hv_max + 1 >= hv_keys * 2) \
+ hv_max = hv_max / 2; \
+ } \
+ HvMAX(hv) = hv_max; \
+} STMT_END
- if (!entry) /* non-existent */
- continue;
- do {
- register I32 j = (HeHASH(entry) & newsize);
- if (j != i) {
- j -= i;
- *oentry = HeNEXT(entry);
- HeNEXT(entry) = aep[j];
- aep[j] = entry;
- }
- else
- oentry = &HeNEXT(entry);
- entry = *oentry;
- } while (entry);
- }
-}
-
HV *
Perl_newHVhv(pTHX_ HV *ohv)
{
@@ -1351,7 +1296,7 @@
HV * const hv = newHV();
STRLEN hv_max;
- if (!ohv || !HvTOTALKEYS(ohv))
+ if (!ohv || (!HvTOTALKEYS(ohv) && !SvMAGICAL((const SV *)ohv)))
return hv;
hv_max = HvMAX(ohv);
@@ -1405,18 +1350,19 @@
HE *entry;
const I32 riter = HvRITER_get(ohv);
HE * const eiter = HvEITER_get(ohv);
- STRLEN hv_fill = HvFILL(ohv);
+ STRLEN hv_keys = HvTOTALKEYS(ohv);
- /* Can we use fewer buckets? (hv_max is always 2^n-1) */
- while (hv_max && hv_max + 1 >= hv_fill * 2)
- hv_max = hv_max / 2;
- HvMAX(hv) = hv_max;
+ HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys);
hv_iterinit(ohv);
while ((entry = hv_iternext_flags(ohv, 0))) {
- SV *const val = HeVAL(entry);
- (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
- SvIMMORTAL(val) ? val : newSVsv(val),
+ SV *val = hv_iterval(ohv,entry);
+ SV * const keysv = HeSVKEY(entry);
+ val = SvIMMORTAL(val) ? val : newSVsv(val);
+ if (keysv)
+ (void)hv_store_ent(hv, keysv, val, 0);
+ else
+ (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry), val,
HeHASH(entry), HeKFLAGS(entry));
}
HvRITER_set(ohv, riter);
@@ -1443,48 +1389,54 @@
{
HV * const hv = newHV();
- if (ohv && HvTOTALKEYS(ohv)) {
+ if (ohv) {
STRLEN hv_max = HvMAX(ohv);
- STRLEN hv_fill = HvFILL(ohv);
+ STRLEN hv_keys = HvTOTALKEYS(ohv);
HE *entry;
const I32 riter = HvRITER_get(ohv);
HE * const eiter = HvEITER_get(ohv);
- while (hv_max && hv_max + 1 >= hv_fill * 2)
- hv_max = hv_max / 2;
- HvMAX(hv) = hv_max;
+ ENTER;
+ SAVEFREESV(hv);
+ HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys);
+
hv_iterinit(ohv);
while ((entry = hv_iternext_flags(ohv, 0))) {
- SV *const sv = newSVsv(HeVAL(entry));
- SV *heksv = newSVhek(HeKEY_hek(entry));
- sv_magic(sv, NULL, PERL_MAGIC_hintselem,
+ SV *const sv = newSVsv(hv_iterval(ohv,entry));
+ SV *heksv = HeSVKEY(entry);
+ if (!heksv && sv) heksv = newSVhek(HeKEY_hek(entry));
+ if (sv) sv_magic(sv, NULL, PERL_MAGIC_hintselem,
(char *)heksv, HEf_SVKEY);
- SvREFCNT_dec(heksv);
- (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
- sv, HeHASH(entry), HeKFLAGS(entry));
+ if (heksv == HeSVKEY(entry))
+ (void)hv_store_ent(hv, heksv, sv, 0);
+ else {
+ (void)hv_common(hv, heksv, HeKEY(entry), HeKLEN(entry),
+ HeKFLAGS(entry), HV_FETCH_ISSTORE|HV_FETCH_JUST_SV, sv, HeHASH(entry));
+ SvREFCNT_dec_NN(heksv);
+ }
}
HvRITER_set(ohv, riter);
HvEITER_set(ohv, eiter);
+
+ SvREFCNT_inc_simple_void_NN(hv);
+ LEAVE;
}
hv_magic(hv, NULL, PERL_MAGIC_hints);
return hv;
}
+#undef HV_SET_MAX_ADJUSTED_FOR_KEYS
-void
-Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
+/* like hv_free_ent, but returns the SV rather than freeing it */
+STATIC SV*
+S_hv_free_ent_ret(pTHX_ HV *hv, HE *entry)
{
dVAR;
SV *val;
- PERL_ARGS_ASSERT_HV_FREE_ENT;
+ PERL_ARGS_ASSERT_HV_FREE_ENT_RET;
- if (!entry)
- return;
val = HeVAL(entry);
- if (val && isGV(val) && isGV_with_GP(val) && GvCVu(val) && HvENAME(hv))
- mro_method_changed_in(hv); /* deletion of method from stash */
- SvREFCNT_dec(val);
if (HeKLEN(entry) == HEf_SVKEY) {
SvREFCNT_dec(HeKEY_sv(entry));
Safefree(HeKEY_hek(entry));
@@ -1494,14 +1446,30 @@
else
Safefree(HeKEY_hek(entry));
del_HE(entry);
+ return val;
}
void
-Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
+Perl_hv_free_ent(pTHX_ HV *hv, HE *entry)
{
dVAR;
+ SV *val;
+ PERL_ARGS_ASSERT_HV_FREE_ENT;
+
+ if (!entry)
+ return;
+ val = hv_free_ent_ret(hv, entry);
+ SvREFCNT_dec(val);
+}
+
+
+void
+Perl_hv_delayfree_ent(pTHX_ HV *hv, HE *entry)
+{
+ dVAR;
+
PERL_ARGS_ASSERT_HV_DELAYFREE_ENT;
if (!entry)
@@ -1517,8 +1485,12 @@
/*
=for apidoc hv_clear
-Clears a hash, making it empty.
+Frees the all the elements of a hash, leaving it empty.
+The XS equivalent of C<%hash = ()>. See also L</hv_undef>.
+If any destructors are triggered as a result, the hv itself may
+be freed.
+
=cut
*/
@@ -1526,7 +1498,7 @@
Perl_hv_clear(pTHX_ HV *hv)
{
dVAR;
- register XPVHV* xhv;
+ XPVHV* xhv;
if (!hv)
return;
@@ -1534,6 +1506,8 @@
xhv = (XPVHV*)SvANY(hv);
+ ENTER;
+ SAVEFREESV(SvREFCNT_inc_simple_NN(hv));
if (SvREADONLY(hv) && HvARRAY(hv) != NULL) {
/* restricted hash: convert all keys to placeholders */
STRLEN i;
@@ -1542,38 +1516,36 @@
for (; entry; entry = HeNEXT(entry)) {
/* not already placeholder */
if (HeVAL(entry) != &PL_sv_placeholder) {
- if (HeVAL(entry) && SvREADONLY(HeVAL(entry))
- && !SvIsCOW(HeVAL(entry))) {
- SV* const keysv = hv_iterkeysv(entry);
- Perl_croak(aTHX_
- "Attempt to delete readonly key '%"SVf"' from a restricted hash",
- (void*)keysv);
+ if (HeVAL(entry)) {
+ if (SvREADONLY(HeVAL(entry)) && !SvIsCOW(HeVAL(entry))) {
+ SV* const keysv = hv_iterkeysv(entry);
+ Perl_croak_nocontext(
+ "Attempt to delete readonly key '%"SVf"' from a restricted hash",
+ (void*)keysv);
+ }
+ SvREFCNT_dec_NN(HeVAL(entry));
}
- SvREFCNT_dec(HeVAL(entry));
HeVAL(entry) = &PL_sv_placeholder;
HvPLACEHOLDERS(hv)++;
}
}
}
- goto reset;
}
+ else {
+ hfreeentries(hv);
+ HvPLACEHOLDERS_set(hv, 0);
- hfreeentries(hv);
- HvPLACEHOLDERS_set(hv, 0);
- if (HvARRAY(hv))
- Zero(HvARRAY(hv), xhv->xhv_max+1 /* HvMAX(hv)+1 */, HE*);
+ if (SvRMAGICAL(hv))
+ mg_clear(MUTABLE_SV(hv));
- if (SvRMAGICAL(hv))
- mg_clear(MUTABLE_SV(hv));
-
- HvHASKFLAGS_off(hv);
- HvREHASH_off(hv);
- reset:
+ HvHASKFLAGS_off(hv);
+ }
if (SvOOK(hv)) {
if(HvENAME_get(hv))
mro_isa_changed_in(hv);
HvEITER_set(hv, NULL);
}
+ LEAVE;
}
/*
@@ -1616,7 +1588,6 @@
i = HvMAX(hv);
do {
/* Loop down the linked list heads */
- bool first = TRUE;
HE **oentry = &(HvARRAY(hv))[i];
HE *entry;
@@ -1635,7 +1606,7 @@
if (--items == 0) {
/* Finished. */
HvTOTALKEYS(hv) -= (IV)HvPLACEHOLDERS_get(hv);
- if (HvKEYS(hv) == 0)
+ if (HvUSEDKEYS(hv) == 0)
HvHASKFLAGS_off(hv);
HvPLACEHOLDERS_set(hv, 0);
return;
@@ -1642,7 +1613,6 @@
}
} else {
oentry = &HeNEXT(entry);
- first = FALSE;
}
}
} while (--i >= 0);
@@ -1654,213 +1624,101 @@
STATIC void
S_hfreeentries(pTHX_ HV *hv)
{
- /* This is the array that we're going to restore */
- HE **const orig_array = HvARRAY(hv);
- HE **tmp_array = NULL;
- const bool has_aux = (SvOOK(hv) == SVf_OOK);
- struct xpvhv_aux * current_aux = NULL;
- int attempts = 100;
-
- const bool mpm = PL_phase != PERL_PHASE_DESTRUCT && HvENAME(hv);
+ STRLEN index = 0;
+ XPVHV * const xhv = (XPVHV*)SvANY(hv);
+ SV *sv;
PERL_ARGS_ASSERT_HFREEENTRIES;
- if (!orig_array)
- return;
+ while ((sv = Perl_hfree_next_entry(aTHX_ hv, &index))||xhv->xhv_keys) {
+ SvREFCNT_dec(sv);
+ }
+}
- /* orig_array remains unchanged throughout the loop. If after freeing all
- the entries it turns out that one of the little blighters has triggered
- an action that has caused HvARRAY to be re-allocated, then we set
- array to the new HvARRAY, and try again. */
- while (1) {
- /* This is the one we're going to try to empty. First time round
- it's the original array. (Hopefully there will only be 1 time
- round) */
- HE ** const array = HvARRAY(hv);
- I32 i = HvMAX(hv);
+/* hfree_next_entry()
+ * For use only by S_hfreeentries() and sv_clear().
+ * Delete the next available HE from hv and return the associated SV.
+ * Returns null on empty hash. Nevertheless null is not a reliable
+ * indicator that the hash is empty, as the deleted entry may have a
+ * null value.
+ * indexp is a pointer to the current index into HvARRAY. The index should
+ * initially be set to 0. hfree_next_entry() may update it. */
- struct xpvhv_aux *iter = SvOOK(hv) ? HvAUX(hv) : NULL;
+SV*
+Perl_hfree_next_entry(pTHX_ HV *hv, STRLEN *indexp)
+{
+ struct xpvhv_aux *iter;
+ HE *entry;
+ HE ** array;
+#ifdef DEBUGGING
+ STRLEN orig_index = *indexp;
+#endif
- /* If there are no keys, we only need to free items in the aux
- structure and then exit the loop. */
- const bool empty = !((XPVHV*) SvANY(hv))->xhv_keys;
+ PERL_ARGS_ASSERT_HFREE_NEXT_ENTRY;
- /* make everyone else think the array is empty, so that the destructors
- * called for freed entries can't recursively mess with us */
- if (!empty) HvARRAY(hv) = NULL;
-
- if (SvOOK(hv)) {
- HE *entry;
-
- if (!empty) {
- SvFLAGS(hv) &= ~SVf_OOK; /* Goodbye, aux structure. */
- /* What aux structure? */
- /* (But we still have a pointer to it in iter.) */
-
- /* Copy the name and MRO stuff to a new aux structure
- if present. */
- if (iter->xhv_name_u.xhvnameu_name || iter->xhv_mro_meta) {
- struct xpvhv_aux * const newaux = hv_auxinit(hv);
- newaux->xhv_name_count = iter->xhv_name_count;
- if (newaux->xhv_name_count)
- newaux->xhv_name_u.xhvnameu_names
- = iter->xhv_name_u.xhvnameu_names;
- else
- newaux->xhv_name_u.xhvnameu_name
- = iter->xhv_name_u.xhvnameu_name;
-
- iter->xhv_name_u.xhvnameu_name = NULL;
- newaux->xhv_mro_meta = iter->xhv_mro_meta;
- iter->xhv_mro_meta = NULL;
- }
-
- /* Because we have taken xhv_name and xhv_mro_meta out, the
- only allocated pointers in the aux structure that might
- exist are the back-reference array and xhv_eiter.
- */
- }
-
- /* weak references: if called from sv_clear(), the backrefs
- * should already have been killed; if there are any left, its
- * because we're doing hv_clear() or hv_undef(), and the HV
- * will continue to live.
- * Because while freeing the entries we fake up a NULL HvARRAY
- * (and hence HvAUX), we need to store the backref array
- * somewhere else; but it still needs to be visible in case
- * any the things we free happen to call sv_del_backref().
- * We do this by storing it in magic instead.
- * If, during the entry freeing, a destructor happens to add
- * a new weak backref, then sv_add_backref will look in both
- * places (magic in HvAUX) for the AV, but will create a new
- * AV in HvAUX if it can't find one (if it finds it in magic,
- * it moves it back into HvAUX. So at the end of the iteration
- * we have to allow for this. */
-
-
- if (iter->xhv_backreferences) {
- if (SvTYPE(iter->xhv_backreferences) == SVt_PVAV) {
- /* The sv_magic will increase the reference count of the AV,
- so we need to drop it first. */
- SvREFCNT_dec(iter->xhv_backreferences);
- if (AvFILLp(iter->xhv_backreferences) == -1) {
- /* Turns out that the array is empty. Just free it. */
- SvREFCNT_dec(iter->xhv_backreferences);
-
- } else {
- sv_magic(MUTABLE_SV(hv),
- MUTABLE_SV(iter->xhv_backreferences),
- PERL_MAGIC_backref, NULL, 0);
- }
- }
- else {
- MAGIC *mg;
- sv_magic(MUTABLE_SV(hv), NULL, PERL_MAGIC_backref, NULL, 0);
- mg = mg_find(MUTABLE_SV(hv), PERL_MAGIC_backref);
- mg->mg_obj = (SV*)iter->xhv_backreferences;
- }
- iter->xhv_backreferences = NULL;
- }
-
- entry = iter->xhv_eiter; /* HvEITER(hv) */
- if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
- HvLAZYDEL_off(hv);
- hv_free_ent(hv, entry);
- }
- iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
- iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
-
- /* There are now no allocated pointers in the aux structure
- unless the hash is empty. */
+ if (SvOOK(hv) && ((iter = HvAUX(hv)))
+ && ((entry = iter->xhv_eiter)) )
+ {
+ /* the iterator may get resurrected after each
+ * destructor call, so check each time */
+ if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
+ HvLAZYDEL_off(hv);
+ hv_free_ent(hv, entry);
+ /* warning: at this point HvARRAY may have been
+ * re-allocated, HvMAX changed etc */
}
+ iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
+ iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+ iter->xhv_last_rand = iter->xhv_rand;
+#endif
+ }
- /* If there are no keys, there is nothing left to free. */
- if (empty) break;
+ if (!((XPVHV*)SvANY(hv))->xhv_keys)
+ return NULL;
- /* Since we have removed the HvARRAY (and possibly replaced it by
- calling hv_auxinit), set the number of keys accordingly. */
- ((XPVHV*) SvANY(hv))->xhv_keys = 0;
+ array = HvARRAY(hv);
+ assert(array);
+ while ( ! ((entry = array[*indexp])) ) {
+ if ((*indexp)++ >= HvMAX(hv))
+ *indexp = 0;
+ assert(*indexp != orig_index);
+ }
+ array[*indexp] = HeNEXT(entry);
+ ((XPVHV*) SvANY(hv))->xhv_keys--;
- do {
- /* Loop down the linked list heads */
- HE *entry = array[i];
-
- while (entry) {
- register HE * const oentry = entry;
- entry = HeNEXT(entry);
- if (
- mpm && HeVAL(oentry) && isGV(HeVAL(oentry)) &&
- GvHV(HeVAL(oentry)) && HvENAME(GvHV(HeVAL(oentry)))
- ) {
- STRLEN klen;
- const char * const key = HePV(oentry,klen);
- if ((klen > 1 && key[klen-1]==':' && key[klen-2]==':')
- || (klen == 1 && key[0] == ':')) {
- mro_package_moved(
- NULL, GvHV(HeVAL(oentry)),
- (GV *)HeVAL(oentry), 0
- );
- }
- }
- hv_free_ent(hv, oentry);
- }
- } while (--i >= 0);
-
- /* As there are no allocated pointers in the aux structure, it's now
- safe to free the array we just cleaned up, if it's not the one we're
- going to put back. */
- if (array != orig_array) {
- Safefree(array);
+ if ( PL_phase != PERL_PHASE_DESTRUCT && HvENAME(hv)
+ && HeVAL(entry) && isGV(HeVAL(entry))
+ && GvHV(HeVAL(entry)) && HvENAME(GvHV(HeVAL(entry)))
+ ) {
+ STRLEN klen;
+ const char * const key = HePV(entry,klen);
+ if ((klen > 1 && key[klen-1]==':' && key[klen-2]==':')
+ || (klen == 1 && key[0] == ':')) {
+ mro_package_moved(
+ NULL, GvHV(HeVAL(entry)),
+ (GV *)HeVAL(entry), 0
+ );
}
-
- if (!HvARRAY(hv)) {
- /* Good. No-one added anything this time round. */
- break;
- }
-
- if (--attempts == 0) {
- Perl_die(aTHX_ "panic: hfreeentries failed to free hash - something is repeatedly re-creating entries");
- }
}
+ return hv_free_ent_ret(hv, entry);
+}
- /* If the array was not replaced, the rest does not apply. */
- if (HvARRAY(hv) == orig_array) return;
-
- /* Set aside the current array for now, in case we still need it. */
- if (SvOOK(hv)) current_aux = HvAUX(hv);
- if (HvARRAY(hv))
- tmp_array = HvARRAY(hv);
- HvARRAY(hv) = orig_array;
+/*
+=for apidoc hv_undef
- if (has_aux && current_aux)
- SvFLAGS(hv) |= SVf_OOK;
- else
- SvFLAGS(hv) &=~SVf_OOK;
+Undefines the hash. The XS equivalent of C<undef(%hash)>.
- /* If the hash was actually a symbol table, put the name and MRO
- caches back. */
- if (current_aux) {
- struct xpvhv_aux * const aux
- = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
- aux->xhv_name_count = current_aux->xhv_name_count;
- if(aux->xhv_name_count)
- aux->xhv_name_u.xhvnameu_names
- = current_aux->xhv_name_u.xhvnameu_names;
- else
- aux->xhv_name_u.xhvnameu_name
- = current_aux->xhv_name_u.xhvnameu_name;
- aux->xhv_mro_meta = current_aux->xhv_mro_meta;
- }
+As well as freeing all the elements of the hash (like hv_clear()), this
+also frees any auxiliary data and storage associated with the hash.
- if (tmp_array) Safefree(tmp_array);
-}
+If any destructors are triggered as a result, the hv itself may
+be freed.
-/*
-=for apidoc hv_undef
+See also L</hv_clear>.
-Undefines the hash.
-
=cut
*/
@@ -1868,8 +1726,9 @@
Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags)
{
dVAR;
- register XPVHV* xhv;
+ XPVHV* xhv;
const char *name;
+ const bool save = !!SvREFCNT(hv);
if (!hv)
return;
@@ -1884,30 +1743,40 @@
allocate an array for storing the effective name. We can skip that
during global destruction, as it does not matter where the CVs point
if they will be freed anyway. */
+ /* note that the code following prior to hfreeentries is duplicated
+ * in sv_clear(), and changes here should be done there too */
if (PL_phase != PERL_PHASE_DESTRUCT && (name = HvNAME(hv))) {
- if (PL_stashcache)
- (void)hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD);
+ if (PL_stashcache) {
+ DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for '%"
+ HEKf"'\n", HvNAME_HEK(hv)));
+ (void)hv_delete(PL_stashcache, name,
+ HEK_UTF8(HvNAME_HEK(hv)) ? -HvNAMELEN_get(hv) : HvNAMELEN_get(hv),
+ G_DISCARD
+ );
+ }
hv_name_set(hv, NULL, 0, 0);
}
+ if (save) {
+ ENTER;
+ SAVEFREESV(SvREFCNT_inc_simple_NN(hv));
+ }
hfreeentries(hv);
if (SvOOK(hv)) {
struct xpvhv_aux * const aux = HvAUX(hv);
struct mro_meta *meta;
- bool zeroed = FALSE;
if ((name = HvENAME_get(hv))) {
- if (PL_phase != PERL_PHASE_DESTRUCT) {
- /* This must come at this point in case
- mro_isa_changed_in dies. */
- Zero(HvARRAY(hv), xhv->xhv_max+1 /* HvMAX(hv)+1 */, HE*);
- zeroed = TRUE;
-
+ if (PL_phase != PERL_PHASE_DESTRUCT)
mro_isa_changed_in(hv);
- }
- if (PL_stashcache)
+ if (PL_stashcache) {
+ DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for effective name '%"
+ HEKf"'\n", HvENAME_HEK(hv)));
(void)hv_delete(
- PL_stashcache, name, HvENAMELEN_get(hv), G_DISCARD
+ PL_stashcache, name,
+ HEK_UTF8(HvENAME_HEK(hv)) ? -HvENAMELEN_get(hv) : HvENAMELEN_get(hv),
+ G_DISCARD
);
+ }
}
/* If this call originated from sv_clear, then we must check for
@@ -1914,41 +1783,45 @@
* effective names that need freeing, as well as the usual name. */
name = HvNAME(hv);
if (flags & HV_NAME_SETALL ? !!aux->xhv_name_u.xhvnameu_name : !!name) {
- if (name && PL_stashcache)
- (void)hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD);
+ if (name && PL_stashcache) {
+ DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for name '%"
+ HEKf"'\n", HvNAME_HEK(hv)));
+ (void)hv_delete(PL_stashcache, name, (HEK_UTF8(HvNAME_HEK(hv)) ? -HvNAMELEN_get(hv) : HvNAMELEN_get(hv)), G_DISCARD);
+ }
hv_name_set(hv, NULL, 0, flags);
}
if((meta = aux->xhv_mro_meta)) {
if (meta->mro_linear_all) {
- SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all));
- meta->mro_linear_all = NULL;
- /* This is just acting as a shortcut pointer. */
- meta->mro_linear_current = NULL;
- } else if (meta->mro_linear_current) {
+ SvREFCNT_dec_NN(meta->mro_linear_all);
+ /* mro_linear_current is just acting as a shortcut pointer,
+ hence the else. */
+ }
+ else
/* Only the current MRO is stored, so this owns the data.
*/
SvREFCNT_dec(meta->mro_linear_current);
- meta->mro_linear_current = NULL;
- }
- if(meta->mro_nextmethod) SvREFCNT_dec(meta->mro_nextmethod);
+ SvREFCNT_dec(meta->mro_nextmethod);
SvREFCNT_dec(meta->isa);
Safefree(meta);
aux->xhv_mro_meta = NULL;
}
- if (!aux->xhv_name_u.xhvnameu_name)
+ SvREFCNT_dec(aux->xhv_super);
+ if (!aux->xhv_name_u.xhvnameu_name && ! aux->xhv_backreferences)
SvFLAGS(hv) &= ~SVf_OOK;
- else if (!zeroed)
- Zero(HvARRAY(hv), xhv->xhv_max+1 /* HvMAX(hv)+1 */, HE*);
}
if (!SvOOK(hv)) {
Safefree(HvARRAY(hv));
- xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
+ xhv->xhv_max = PERL_HASH_DEFAULT_HvMAX; /* HvMAX(hv) = 7 (it's a normal hash) */
HvARRAY(hv) = 0;
}
- HvPLACEHOLDERS_set(hv, 0);
+ /* if we're freeing the HV, the SvMAGIC field has been reused for
+ * other purposes, and so there can't be any placeholder magic */
+ if (SvREFCNT(hv))
+ HvPLACEHOLDERS_set(hv, 0);
if (SvRMAGICAL(hv))
mg_clear(MUTABLE_SV(hv));
+ if (save) LEAVE;
}
/*
@@ -1983,32 +1856,82 @@
return count;
}
+/* hash a pointer to a U32 - Used in the hash traversal randomization
+ * and bucket order randomization code
+ *
+ * this code was derived from Sereal, which was derived from autobox.
+ */
+
+PERL_STATIC_INLINE U32 S_ptr_hash(PTRV u) {
+#if PTRSIZE == 8
+ /*
+ * This is one of Thomas Wang's hash functions for 64-bit integers from:
+ * http://www.concentric.net/~Ttwang/tech/inthash.htm
+ */
+ u = (~u) + (u << 18);
+ u = u ^ (u >> 31);
+ u = u * 21;
+ u = u ^ (u >> 11);
+ u = u + (u << 6);
+ u = u ^ (u >> 22);
+#else
+ /*
+ * This is one of Bob Jenkins' hash functions for 32-bit integers
+ * from: http://burtleburtle.net/bob/hash/integer.html
+ */
+ u = (u + 0x7ed55d16) + (u << 12);
+ u = (u ^ 0xc761c23c) ^ (u >> 19);
+ u = (u + 0x165667b1) + (u << 5);
+ u = (u + 0xd3a2646c) ^ (u << 9);
+ u = (u + 0xfd7046c5) + (u << 3);
+ u = (u ^ 0xb55a4f09) ^ (u >> 16);
+#endif
+ return (U32)u;
+}
+
+
static struct xpvhv_aux*
-S_hv_auxinit(HV *hv) {
+S_hv_auxinit(pTHX_ HV *hv) {
struct xpvhv_aux *iter;
char *array;
PERL_ARGS_ASSERT_HV_AUXINIT;
- if (!HvARRAY(hv)) {
- Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
- + sizeof(struct xpvhv_aux), char);
+ if (!SvOOK(hv)) {
+ if (!HvARRAY(hv)) {
+ Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
+ + sizeof(struct xpvhv_aux), char);
+ } else {
+ array = (char *) HvARRAY(hv);
+ Renew(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
+ + sizeof(struct xpvhv_aux), char);
+ }
+ HvARRAY(hv) = (HE**)array;
+ SvOOK_on(hv);
+ iter = HvAUX(hv);
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+ if (PL_HASH_RAND_BITS_ENABLED) {
+ /* mix in some new state to PL_hash_rand_bits to "randomize" the traversal order*/
+ if (PL_HASH_RAND_BITS_ENABLED == 1)
+ PL_hash_rand_bits += ptr_hash((PTRV)array);
+ PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,1);
+ }
+ iter->xhv_rand = (U32)PL_hash_rand_bits;
+#endif
} else {
- array = (char *) HvARRAY(hv);
- Renew(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
- + sizeof(struct xpvhv_aux), char);
+ iter = HvAUX(hv);
}
- HvARRAY(hv) = (HE**) array;
- /* SvOOK_on(hv) attacks the IV flags. */
- SvFLAGS(hv) |= SVf_OOK;
- iter = HvAUX(hv);
iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+ iter->xhv_last_rand = iter->xhv_rand;
+#endif
iter->xhv_name_u.xhvnameu_name = 0;
iter->xhv_name_count = 0;
iter->xhv_backreferences = 0;
iter->xhv_mro_meta = NULL;
+ iter->xhv_super = NULL;
return iter;
}
@@ -2016,7 +1939,7 @@
=for apidoc hv_iterinit
Prepares a starting point to traverse a hash table. Returns the number of
-keys in the hash (i.e. the same as C<HvKEYS(hv)>). The return value is
+keys in the hash (i.e. the same as C<HvUSEDKEYS(hv)>). The return value is
currently only meaningful for hashes without tie magic.
NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
@@ -2046,6 +1969,9 @@
}
iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+ iter->xhv_last_rand = iter->xhv_rand;
+#endif
} else {
hv_auxinit(hv);
}
@@ -2101,6 +2027,27 @@
}
void
+Perl_hv_rand_set(pTHX_ HV *hv, U32 new_xhv_rand) {
+ struct xpvhv_aux *iter;
+
+ PERL_ARGS_ASSERT_HV_RAND_SET;
+
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+ if (!hv)
+ Perl_croak(aTHX_ "Bad hash");
+
+ if (SvOOK(hv)) {
+ iter = HvAUX(hv);
+ } else {
+ iter = hv_auxinit(hv);
+ }
+ iter->xhv_rand = new_xhv_rand;
+#else
+ Perl_croak(aTHX_ "This Perl has not been built with support for randomized hash key traversal but something called Perl_hv_rand_set().");
+#endif
+}
+
+void
Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) {
struct xpvhv_aux *iter;
@@ -2131,7 +2078,6 @@
HEK **spot;
PERL_ARGS_ASSERT_HV_NAME_SET;
- PERL_UNUSED_ARG(flags);
if (len > I32_MAX)
Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
@@ -2192,13 +2138,35 @@
spot = &iter->xhv_name_u.xhvnameu_name;
}
PERL_HASH(hash, name, len);
- *spot = name ? share_hek(name, len, hash) : NULL;
+ *spot = name ? share_hek(name, flags & SVf_UTF8 ? -(I32)len : (I32)len, hash) : NULL;
}
/*
+This is basically sv_eq_flags() in sv.c, but we avoid the magic
+and bytes checking.
+*/
+
+STATIC I32
+hek_eq_pvn_flags(pTHX_ const HEK *hek, const char* pv, const I32 pvlen, const U32 flags) {
+ if ( (HEK_UTF8(hek) ? 1 : 0) != (flags & SVf_UTF8 ? 1 : 0) ) {
+ if (flags & SVf_UTF8)
+ return (bytes_cmp_utf8(
+ (const U8*)HEK_KEY(hek), HEK_LEN(hek),
+ (const U8*)pv, pvlen) == 0);
+ else
+ return (bytes_cmp_utf8(
+ (const U8*)pv, pvlen,
+ (const U8*)HEK_KEY(hek), HEK_LEN(hek)) == 0);
+ }
+ else
+ return HEK_LEN(hek) == pvlen && ((HEK_KEY(hek) == pv)
+ || memEQ(HEK_KEY(hek), pv, pvlen));
+}
+
+/*
=for apidoc hv_ename_add
-Adds a name to a stash's internal list of effective names. See
+Adds a name to a stash's internal list of effective names. See
C<hv_ename_delete>.
This is called when a stash is assigned to a new location in the symbol
@@ -2215,7 +2183,6 @@
U32 hash;
PERL_ARGS_ASSERT_HV_ENAME_ADD;
- PERL_UNUSED_ARG(flags);
if (len > I32_MAX)
Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
@@ -2228,8 +2195,10 @@
HEK **hekp = xhv_name + (count < 0 ? -count : count);
while (hekp-- > xhv_name)
if (
- HEK_LEN(*hekp) == (I32)len && memEQ(HEK_KEY(*hekp), name, len)
- ) {
+ (HEK_UTF8(*hekp) || (flags & SVf_UTF8))
+ ? hek_eq_pvn_flags(aTHX_ *hekp, name, (I32)len, flags)
+ : (HEK_LEN(*hekp) == (I32)len && memEQ(HEK_KEY(*hekp), name, len))
+ ) {
if (hekp == xhv_name && count < 0)
aux->xhv_name_count = -count;
return;
@@ -2237,18 +2206,21 @@
if (count < 0) aux->xhv_name_count--, count = -count;
else aux->xhv_name_count++;
Renew(aux->xhv_name_u.xhvnameu_names, count + 1, HEK *);
- (aux->xhv_name_u.xhvnameu_names)[count] = share_hek(name, len, hash);
+ (aux->xhv_name_u.xhvnameu_names)[count] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
}
else {
HEK *existing_name = aux->xhv_name_u.xhvnameu_name;
if (
- existing_name && HEK_LEN(existing_name) == (I32)len
- && memEQ(HEK_KEY(existing_name), name, len)
+ existing_name && (
+ (HEK_UTF8(existing_name) || (flags & SVf_UTF8))
+ ? hek_eq_pvn_flags(aTHX_ existing_name, name, (I32)len, flags)
+ : (HEK_LEN(existing_name) == (I32)len && memEQ(HEK_KEY(existing_name), name, len))
+ )
) return;
Newx(aux->xhv_name_u.xhvnameu_names, 2, HEK *);
aux->xhv_name_count = existing_name ? 2 : -2;
*aux->xhv_name_u.xhvnameu_names = existing_name;
- (aux->xhv_name_u.xhvnameu_names)[1] = share_hek(name, len, hash);
+ (aux->xhv_name_u.xhvnameu_names)[1] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
}
}
@@ -2255,7 +2227,7 @@
/*
=for apidoc hv_ename_delete
-Removes a name from a stash's internal list of effective names. If this is
+Removes a name from a stash's internal list of effective names. If this is
the name returned by C<HvENAME>, then another name in the list will take
its place (C<HvENAME> will use it).
@@ -2271,7 +2243,6 @@
struct xpvhv_aux *aux;
PERL_ARGS_ASSERT_HV_ENAME_DELETE;
- PERL_UNUSED_ARG(flags);
if (len > I32_MAX)
Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
@@ -2287,8 +2258,9 @@
HEK **victim = namep + (count < 0 ? -count : count);
while (victim-- > namep + 1)
if (
- HEK_LEN(*victim) == (I32)len
- && memEQ(HEK_KEY(*victim), name, len)
+ (HEK_UTF8(*victim) || (flags & SVf_UTF8))
+ ? hek_eq_pvn_flags(aTHX_ *victim, name, (I32)len, flags)
+ : (HEK_LEN(*victim) == (I32)len && memEQ(HEK_KEY(*victim), name, len))
) {
unshare_hek_or_pvn(*victim, 0, 0, 0);
if (count < 0) ++aux->xhv_name_count;
@@ -2309,15 +2281,18 @@
return;
}
if (
- count > 0 && HEK_LEN(*namep) == (I32)len
- && memEQ(HEK_KEY(*namep),name,len)
+ count > 0 && (HEK_UTF8(*namep) || (flags & SVf_UTF8))
+ ? hek_eq_pvn_flags(aTHX_ *namep, name, (I32)len, flags)
+ : (HEK_LEN(*namep) == (I32)len && memEQ(HEK_KEY(*namep), name, len))
) {
aux->xhv_name_count = -count;
}
}
else if(
- HEK_LEN(aux->xhv_name_u.xhvnameu_name) == (I32)len
- && memEQ(HEK_KEY(aux->xhv_name_u.xhvnameu_name), name, len)
+ (HEK_UTF8(aux->xhv_name_u.xhvnameu_name) || (flags & SVf_UTF8))
+ ? hek_eq_pvn_flags(aTHX_ aux->xhv_name_u.xhvnameu_name, name, (I32)len, flags)
+ : (HEK_LEN(aux->xhv_name_u.xhvnameu_name) == (I32)len &&
+ memEQ(HEK_KEY(aux->xhv_name_u.xhvnameu_name), name, len))
) {
HEK * const namehek = aux->xhv_name_u.xhvnameu_name;
Newx(aux->xhv_name_u.xhvnameu_names, 1, HEK *);
@@ -2351,7 +2326,7 @@
HvAUX(hv)->xhv_backreferences = 0;
Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av);
if (SvTYPE(av) == SVt_PVAV)
- SvREFCNT_dec(av);
+ SvREFCNT_dec_NN(av);
}
}
@@ -2377,7 +2352,7 @@
set the placeholders keys (for restricted hashes) will be returned in addition
to normal keys. By default placeholders are automatically skipped over.
Currently a placeholder is implemented with a value that is
-C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
+C<&PL_sv_placeholder>. Note that the implementation of placeholders and
restricted hashes may change, and the implementation currently is
insufficiently abstracted for any change to be tidy.
@@ -2388,8 +2363,8 @@
Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
{
dVAR;
- register XPVHV* xhv;
- register HE *entry;
+ XPVHV* xhv;
+ HE *entry;
HE *oldentry;
MAGIC* mg;
struct xpvhv_aux *iter;
@@ -2403,7 +2378,7 @@
if (!SvOOK(hv)) {
/* Too many things (well, pp_each at least) merrily assume that you can
- call iv_iternext without calling hv_iterinit, so we'll have to deal
+ call hv_iternext without calling hv_iterinit, so we'll have to deal
with it. */
hv_iterinit(hv);
}
@@ -2416,6 +2391,7 @@
if (entry) {
sv_setsv(key, HeSVKEY_force(entry));
SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
+ HeSVKEY_set(entry, NULL);
}
else {
char *k;
@@ -2423,6 +2399,7 @@
/* one HE per MAGICAL hash */
iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
+ HvLAZYDEL_on(hv); /* make sure entry gets freed */
Zero(entry, 1, HE);
Newxz(k, HEK_BASESIZE + sizeof(const SV *), char);
hek = (HEK*)k;
@@ -2439,6 +2416,7 @@
Safefree(HeKEY_hek(entry));
del_HE(entry);
iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
+ HvLAZYDEL_off(hv);
return NULL;
}
}
@@ -2457,7 +2435,7 @@
}
#endif
- /* hv_iterint now ensures this. */
+ /* hv_iterinit now ensures this. */
assert (HvARRAY(hv));
/* At start of hash, entry is NULL. */
@@ -2475,6 +2453,18 @@
}
}
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+ if (iter->xhv_last_rand != iter->xhv_rand) {
+ if (iter->xhv_riter != -1) {
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
+ "Use of each() on hash after insertion without resetting hash iterator results in undefined behavior"
+ pTHX__FORMAT
+ pTHX__VALUE);
+ }
+ iter->xhv_last_rand = iter->xhv_rand;
+ }
+#endif
+
/* Skip the entire loop if the hash is empty. */
if ((flags & HV_ITERNEXT_WANTPLACEHOLDERS)
? HvTOTALKEYS(hv) : HvUSEDKEYS(hv)) {
@@ -2485,9 +2475,12 @@
if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
/* There is no next one. End of the hash. */
iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+ iter->xhv_last_rand = iter->xhv_rand; /* reset xhv_last_rand so we can detect inserts during traversal */
+#endif
break;
}
- entry = (HvARRAY(hv))[iter->xhv_riter];
+ entry = (HvARRAY(hv))[ PERL_HASH_ITER_BUCKET(iter) & xhv->xhv_max ];
if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
/* If we have an entry, but it's a placeholder, don't count it.
@@ -2500,6 +2493,12 @@
or if we run through it and find only placeholders. */
}
}
+ else {
+ iter->xhv_riter = -1;
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+ iter->xhv_last_rand = iter->xhv_rand;
+#endif
+ }
if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
HvLAZYDEL_off(hv);
@@ -2506,9 +2505,6 @@
hv_free_ent(hv, oldentry);
}
- /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
- PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", (void*)hv, (void*)entry);*/
-
iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
return entry;
}
@@ -2523,7 +2519,7 @@
*/
char *
-Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
+Perl_hv_iterkey(pTHX_ HE *entry, I32 *retlen)
{
PERL_ARGS_ASSERT_HV_ITERKEY;
@@ -2551,7 +2547,7 @@
*/
SV *
-Perl_hv_iterkeysv(pTHX_ register HE *entry)
+Perl_hv_iterkeysv(pTHX_ HE *entry)
{
PERL_ARGS_ASSERT_HV_ITERKEYSV;
@@ -2568,7 +2564,7 @@
*/
SV *
-Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
+Perl_hv_iterval(pTHX_ HV *hv, HE *entry)
{
PERL_ARGS_ASSERT_HV_ITERVAL;
@@ -2643,10 +2639,9 @@
S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
{
dVAR;
- register XPVHV* xhv;
+ XPVHV* xhv;
HE *entry;
- register HE **oentry;
- HE **first;
+ HE **oentry;
bool is_utf8 = FALSE;
int k_flags = 0;
const char * const save = str;
@@ -2687,7 +2682,7 @@
} */
xhv = (XPVHV*)SvANY(PL_strtab);
/* assert(xhv_array != 0) */
- first = oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
+ oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
if (he) {
const HE *const he_he = &(he->shared_he_he);
for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
@@ -2719,7 +2714,7 @@
if (!entry)
Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
- "Attempt to free non-existent shared string '%s'%s"
+ "Attempt to free nonexistent shared string '%s'%s"
pTHX__FORMAT,
hek ? HEK_KEY(hek) : str,
((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
@@ -2732,7 +2727,7 @@
* len and hash must both be valid for str.
*/
HEK *
-Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
+Perl_share_hek(pTHX_ const char *str, I32 len, U32 hash)
{
bool is_utf8 = FALSE;
int flags = 0;
@@ -2753,8 +2748,11 @@
/* If we found we were able to downgrade the string to bytes, then
we should flag that it needs upgrading on keys or each. Also flag
that we need share_hek_flags to free the string. */
- if (str != save)
+ if (str != save) {
+ dVAR;
+ PERL_HASH(hash, str, len);
flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
+ }
}
return share_hek_flags (str, len, hash, flags);
@@ -2761,13 +2759,13 @@
}
STATIC HEK *
-S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
+S_share_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
{
dVAR;
- register HE *entry;
+ HE *entry;
const int flags_masked = flags & HVhek_MASK;
const U32 hindex = hash & (I32) HvMAX(PL_strtab);
- register XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
+ XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
PERL_ARGS_ASSERT_SHARE_HEK_FLAGS;
@@ -2807,7 +2805,7 @@
/* We don't actually store a HE from the arena and a regular HEK.
Instead we allocate one chunk of memory big enough for both,
and put the HEK straight after the HE. This way we can find the
- HEK directly from the HE.
+ HE directly from the HEK.
*/
Newx(k, STRUCT_OFFSET(struct shared_he,
@@ -2831,8 +2829,9 @@
xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
if (!next) { /* initial entry? */
- } else if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
- hsplit(PL_strtab);
+ } else if ( DO_HSPLIT(xhv) ) {
+ const STRLEN oldsize = xhv->xhv_max + 1;
+ hsplit(PL_strtab, oldsize, oldsize * 2);
}
}
@@ -3063,7 +3062,7 @@
U8 utf8_flag;
PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PVN;
- if (flags & ~REFCOUNTED_HE_KEY_UTF8)
+ if (flags & ~(REFCOUNTED_HE_KEY_UTF8|REFCOUNTED_HE_EXISTS))
Perl_croak(aTHX_ "panic: refcounted_he_fetch_pvn bad flags %"UVxf,
(UV)flags);
if (!chain)
@@ -3114,10 +3113,15 @@
memEQ(HEK_KEY(chain->refcounted_he_hek), keypv, keylen) &&
utf8_flag == (HEK_FLAGS(chain->refcounted_he_hek) & HVhek_UTF8)
#endif
- )
+ ) {
+ if (flags & REFCOUNTED_HE_EXISTS)
+ return (chain->refcounted_he_data[0] & HVrhek_typemask)
+ == HVrhek_delete
+ ? NULL : &PL_sv_yes;
return sv_2mortal(refcounted_he_value(chain));
+ }
}
- return &PL_sv_placeholder;
+ return flags & REFCOUNTED_HE_EXISTS ? NULL : &PL_sv_placeholder;
}
/*
@@ -3398,6 +3402,7 @@
struct refcounted_he *
Perl_refcounted_he_inc(pTHX_ struct refcounted_he *he)
{
+ dVAR;
if (he) {
HINTS_REFCNT_LOCK;
he->refcounted_he_refcnt++;
@@ -3406,13 +3411,22 @@
return he;
}
+/*
+=for apidoc cop_fetch_label
+
+Returns the label attached to a cop.
+The flags pointer may be set to C<SVf_UTF8> or 0.
+
+=cut
+*/
+
/* pp_entereval is aware that labels are stored with a key ':' at the top of
the linked list. */
const char *
-Perl_fetch_cop_label(pTHX_ COP *const cop, STRLEN *len, U32 *flags) {
+Perl_cop_fetch_label(pTHX_ COP *const cop, STRLEN *len, U32 *flags) {
struct refcounted_he *const chain = cop->cop_hints_hash;
- PERL_ARGS_ASSERT_FETCH_COP_LABEL;
+ PERL_ARGS_ASSERT_COP_FETCH_LABEL;
if (!chain)
return NULL;
@@ -3442,15 +3456,24 @@
return chain->refcounted_he_data + 1;
}
+/*
+=for apidoc cop_store_label
+
+Save a label into a C<cop_hints_hash>. You need to set flags to C<SVf_UTF8>
+for a utf-8 label.
+
+=cut
+*/
+
void
-Perl_store_cop_label(pTHX_ COP *const cop, const char *label, STRLEN len,
+Perl_cop_store_label(pTHX_ COP *const cop, const char *label, STRLEN len,
U32 flags)
{
SV *labelsv;
- PERL_ARGS_ASSERT_STORE_COP_LABEL;
+ PERL_ARGS_ASSERT_COP_STORE_LABEL;
if (flags & ~(SVf_UTF8))
- Perl_croak(aTHX_ "panic: store_cop_label illegal flag bits 0x%" UVxf,
+ Perl_croak(aTHX_ "panic: cop_store_label illegal flag bits 0x%" UVxf,
(UV)flags);
labelsv = newSVpvn_flags(label, len, SVs_TEMP);
if (flags & SVf_UTF8)
@@ -3538,8 +3561,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/hv.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.4
\ No newline at end of property
Modified: trunk/contrib/perl/hv.h
===================================================================
--- trunk/contrib/perl/hv.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/hv.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -8,6 +8,26 @@
*
*/
+/* These control hash traversal randomization and the environment variable PERL_PERTURB_KEYS.
+ * Currently disabling this functionality will break a few tests, but should otherwise work fine.
+ * See perlrun for more details. */
+
+#if defined(PERL_PERTURB_KEYS_DISABLED)
+# define PL_HASH_RAND_BITS_ENABLED 0
+# define PERL_HASH_ITER_BUCKET(iter) ((iter)->xhv_riter)
+#else
+# define PERL_HASH_RANDOMIZE_KEYS 1
+# if defined(PERL_PERTURB_KEYS_RANDOM)
+# define PL_HASH_RAND_BITS_ENABLED 1
+# elif defined(PERL_PERTURB_KEYS_DETERMINISTIC)
+# define PL_HASH_RAND_BITS_ENABLED 2
+# else
+# define USE_PERL_PERTURB_KEYS 1
+# define PL_HASH_RAND_BITS_ENABLED PL_hash_rand_bits_enabled
+# endif
+# define PERL_HASH_ITER_BUCKET(iter) (((iter)->xhv_riter) ^ ((iter)->xhv_rand))
+#endif
+
/* entry in hash value chain */
struct he {
/* Keep hent_next first in this structure, because sv_free_arenas take
@@ -82,6 +102,7 @@
AV *xhv_backreferences; /* back references for weak references */
HE *xhv_eiter; /* current entry of iterator */
I32 xhv_riter; /* current root of iterator */
+
/* Concerning xhv_name_count: When non-zero, xhv_name_u contains a pointer
* to an array of HEK pointers, this being the length. The first element is
* the name of the stash, which may be NULL. If xhv_name_count is positive,
@@ -90,6 +111,12 @@
*/
I32 xhv_name_count;
struct mro_meta *xhv_mro_meta;
+ HV * xhv_super; /* SUPER method cache */
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+ U32 xhv_rand; /* random value for hash traversal */
+ U32 xhv_last_rand; /* last random value for hash traversal,
+ used to detect each() after insert for warnings */
+#endif
};
/* hash structure: */
@@ -101,67 +128,6 @@
STRLEN xhv_max; /* subscript of last element of xhv_array */
};
-/* hash a key */
-/* FYI: This is the "One-at-a-Time" algorithm by Bob Jenkins
- * from requirements by Colin Plumb.
- * (http://burtleburtle.net/bob/hash/doobs.html) */
-/* The use of a temporary pointer and the casting games
- * is needed to serve the dual purposes of
- * (a) the hashed data being interpreted as "unsigned char" (new since 5.8,
- * a "char" can be either signed or unsigned, depending on the compiler)
- * (b) catering for old code that uses a "char"
- *
- * The "hash seed" feature was added in Perl 5.8.1 to perturb the results
- * to avoid "algorithmic complexity attacks".
- *
- * If USE_HASH_SEED is defined, hash randomisation is done by default
- * If USE_HASH_SEED_EXPLICIT is defined, hash randomisation is done
- * only if the environment variable PERL_HASH_SEED is set.
- * For maximal control, one can define PERL_HASH_SEED.
- * (see also perl.c:perl_parse()).
- */
-#ifndef PERL_HASH_SEED
-# if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
-# define PERL_HASH_SEED PL_hash_seed
-# else
-# define PERL_HASH_SEED 0
-# endif
-#endif
-#define PERL_HASH(hash,str,len) \
- STMT_START { \
- register const char * const s_PeRlHaSh_tmp = str; \
- register const unsigned char *s_PeRlHaSh = (const unsigned char *)s_PeRlHaSh_tmp; \
- register I32 i_PeRlHaSh = len; \
- register U32 hash_PeRlHaSh = PERL_HASH_SEED; \
- while (i_PeRlHaSh--) { \
- hash_PeRlHaSh += *s_PeRlHaSh++; \
- hash_PeRlHaSh += (hash_PeRlHaSh << 10); \
- hash_PeRlHaSh ^= (hash_PeRlHaSh >> 6); \
- } \
- hash_PeRlHaSh += (hash_PeRlHaSh << 3); \
- hash_PeRlHaSh ^= (hash_PeRlHaSh >> 11); \
- (hash) = (hash_PeRlHaSh + (hash_PeRlHaSh << 15)); \
- } STMT_END
-
-/* Only hv.c and mod_perl should be doing this. */
-#ifdef PERL_HASH_INTERNAL_ACCESS
-#define PERL_HASH_INTERNAL(hash,str,len) \
- STMT_START { \
- register const char * const s_PeRlHaSh_tmp = str; \
- register const unsigned char *s_PeRlHaSh = (const unsigned char *)s_PeRlHaSh_tmp; \
- register I32 i_PeRlHaSh = len; \
- register U32 hash_PeRlHaSh = PL_rehash_seed; \
- while (i_PeRlHaSh--) { \
- hash_PeRlHaSh += *s_PeRlHaSh++; \
- hash_PeRlHaSh += (hash_PeRlHaSh << 10); \
- hash_PeRlHaSh ^= (hash_PeRlHaSh >> 6); \
- } \
- hash_PeRlHaSh += (hash_PeRlHaSh << 3); \
- hash_PeRlHaSh ^= (hash_PeRlHaSh >> 11); \
- (hash) = (hash_PeRlHaSh + (hash_PeRlHaSh << 15)); \
- } STMT_END
-#endif
-
/*
=head1 Hash Manipulation Functions
@@ -183,6 +149,12 @@
Returns the package name of a stash, or NULL if C<stash> isn't a stash.
See C<SvSTASH>, C<CvSTASH>.
+=for apidoc Am|STRLEN|HvNAMELEN|HV *stash
+Returns the length of the stash's name.
+
+=for apidoc Am|unsigned char|HvNAMEUTF8|HV *stash
+Returns true if the name is in UTF8 encoding.
+
=for apidoc Am|char*|HvENAME|HV* stash
Returns the effective name of a stash, or NULL if there is none. The
effective name represents a location in the symbol table where this stash
@@ -191,6 +163,12 @@
name is preferable to C<HvNAME> for use in MRO linearisations and isa
caches.
+=for apidoc Am|STRLEN|HvENAMELEN|HV *stash
+Returns the length of the stash's effective name.
+
+=for apidoc Am|unsigned char|HvENAMEUTF8|HV *stash
+Returns true if the effective name is in UTF8 encoding.
+
=for apidoc Am|void*|HeKEY|HE* he
Returns the actual pointer stored in the key slot of the hash entry. The
pointer may be either C<char*> or C<SV*>, depending on the value of
@@ -204,8 +182,13 @@
lengths.
=for apidoc Am|SV*|HeVAL|HE* he
-Returns the value slot (type C<SV*>) stored in the hash entry.
+Returns the value slot (type C<SV*>) stored in the hash entry. Can be assigned
+to.
+ SV *foo= HeVAL(hv);
+ HeVAL(hv)= sv;
+
+
=for apidoc Am|U32|HeHASH|HE* he
Returns the computed hash stored in the hash entry.
@@ -247,6 +230,8 @@
=cut
*/
+#define PERL_HASH_DEFAULT_HvMAX 7
+
/* these hash entry flags ride on hent_klen (for use only in magic/tied HVs) */
#define HEf_SVKEY -2 /* hent_key is an SV* */
@@ -265,8 +250,13 @@
#define HvEITER_set(hv,e) Perl_hv_eiter_set(aTHX_ MUTABLE_HV(hv), e)
#define HvRITER_get(hv) (SvOOK(hv) ? HvAUX(hv)->xhv_riter : -1)
#define HvEITER_get(hv) (SvOOK(hv) ? HvAUX(hv)->xhv_eiter : NULL)
+#define HvRAND_get(hv) (SvOOK(hv) ? HvAUX(hv)->xhv_rand : 0)
+#define HvLASTRAND_get(hv) (SvOOK(hv) ? HvAUX(hv)->xhv_last_rand : 0)
+
#define HvNAME(hv) HvNAME_get(hv)
+#define HvNAMELEN(hv) HvNAMELEN_get(hv)
#define HvENAME(hv) HvENAME_get(hv)
+#define HvENAMELEN(hv) HvENAMELEN_get(hv)
/* Checking that hv is a valid package stash is the
caller's responsibility */
@@ -274,8 +264,6 @@
? HvAUX(hv)->xhv_mro_meta \
: Perl_mro_meta_init(aTHX_ hv))
-/* FIXME - all of these should use a UTF8 aware API, which should also involve
- getting the length. */
#define HvNAME_HEK_NN(hv) \
( \
HvAUX(hv)->xhv_name_count \
@@ -291,6 +279,9 @@
#define HvNAMELEN_get(hv) \
((SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name && HvNAME_HEK_NN(hv)) \
? HEK_LEN(HvNAME_HEK_NN(hv)) : 0)
+#define HvNAMEUTF8(hv) \
+ ((SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name && HvNAME_HEK_NN(hv)) \
+ ? HEK_UTF8(HvNAME_HEK_NN(hv)) : 0)
#define HvENAME_HEK_NN(hv) \
( \
HvAUX(hv)->xhv_name_count > 0 ? HvAUX(hv)->xhv_name_u.xhvnameu_names[0] : \
@@ -301,11 +292,14 @@
#define HvENAME_HEK(hv) \
(SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name ? HvENAME_HEK_NN(hv) : NULL)
#define HvENAME_get(hv) \
- ((SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(hv)) \
+ ((SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name && HvAUX(hv)->xhv_name_count != -1) \
? HEK_KEY(HvENAME_HEK_NN(hv)) : NULL)
#define HvENAMELEN_get(hv) \
- ((SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(hv)) \
+ ((SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name && HvAUX(hv)->xhv_name_count != -1) \
? HEK_LEN(HvENAME_HEK_NN(hv)) : 0)
+#define HvENAMEUTF8(hv) \
+ ((SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name && HvAUX(hv)->xhv_name_count != -1) \
+ ? HEK_UTF8(HvENAME_HEK_NN(hv)) : 0)
/* the number of keys (including any placeholders) */
#define XHvTOTALKEYS(xhv) ((xhv)->xhv_keys)
@@ -342,10 +336,6 @@
#define HvLAZYDEL_on(hv) (SvFLAGS(hv) |= SVphv_LAZYDEL)
#define HvLAZYDEL_off(hv) (SvFLAGS(hv) &= ~SVphv_LAZYDEL)
-#define HvREHASH(hv) (SvFLAGS(hv) & SVphv_REHASH)
-#define HvREHASH_on(hv) (SvFLAGS(hv) |= SVphv_REHASH)
-#define HvREHASH_off(hv) (SvFLAGS(hv) &= ~SVphv_REHASH)
-
#ifndef PERL_CORE
# define Nullhe Null(HE*)
#endif
@@ -356,7 +346,6 @@
#define HeKLEN(he) HEK_LEN(HeKEY_hek(he))
#define HeKUTF8(he) HEK_UTF8(HeKEY_hek(he))
#define HeKWASUTF8(he) HEK_WASUTF8(HeKEY_hek(he))
-#define HeKREHASH(he) HEK_REHASH(HeKEY_hek(he))
#define HeKLEN_UTF8(he) (HeKUTF8(he) ? -HeKLEN(he) : HeKLEN(he))
#define HeKFLAGS(he) HEK_FLAGS(HeKEY_hek(he))
#define HeVAL(he) (he)->he_valu.hent_val
@@ -391,7 +380,6 @@
#define HVhek_UTF8 0x01 /* Key is utf8 encoded. */
#define HVhek_WASUTF8 0x02 /* Key is bytes here, but was supplied as utf8. */
-#define HVhek_REHASH 0x04 /* This key is in an hv using a custom HASH . */
#define HVhek_UNSHARED 0x08 /* This key isn't a shared hash key. */
#define HVhek_FREEKEY 0x100 /* Internal flag to say key is malloc()ed. */
#define HVhek_PLACEHOLD 0x200 /* Internal flag to create placeholder.
@@ -401,16 +389,7 @@
converted to bytes. */
#define HVhek_MASK 0xFF
-/* Which flags enable HvHASKFLAGS? Somewhat a hack on a hack, as
- HVhek_REHASH is only needed because the rehash flag has to be duplicated
- into all keys as hv_iternext has no access to the hash flags. At this
- point Storable's tests get upset, because sometimes hashes are "keyed"
- and sometimes not, depending on the order of data insertion, and whether
- it triggered rehashing. So currently HVhek_REHASH is exempt.
- Similarly UNSHARED
-*/
-
-#define HVhek_ENABLEHVKFLAGS (HVhek_MASK & ~(HVhek_REHASH|HVhek_UNSHARED))
+#define HVhek_ENABLEHVKFLAGS (HVhek_MASK & ~(HVhek_UNSHARED))
#define HEK_UTF8(hek) (HEK_FLAGS(hek) & HVhek_UTF8)
#define HEK_UTF8_on(hek) (HEK_FLAGS(hek) |= HVhek_UTF8)
@@ -418,8 +397,6 @@
#define HEK_WASUTF8(hek) (HEK_FLAGS(hek) & HVhek_WASUTF8)
#define HEK_WASUTF8_on(hek) (HEK_FLAGS(hek) |= HVhek_WASUTF8)
#define HEK_WASUTF8_off(hek) (HEK_FLAGS(hek) &= ~HVhek_WASUTF8)
-#define HEK_REHASH(hek) (HEK_FLAGS(hek) & HVhek_REHASH)
-#define HEK_REHASH_on(hek) (HEK_FLAGS(hek) |= HVhek_REHASH)
/* calculate HV array allocation */
#ifndef PERL_USE_LARGE_HV_ALLOC
@@ -442,9 +419,8 @@
#define hv_magic(hv, gv, how) sv_magic(MUTABLE_SV(hv), MUTABLE_SV(gv), how, NULL, 0)
#define hv_undef(hv) Perl_hv_undef_flags(aTHX_ hv, 0)
-/* available as a function in hv.c */
-#define Perl_sharepvn(sv, len, hash) HEK_KEY(share_hek(sv, len, hash))
-#define sharepvn(sv, len, hash) Perl_sharepvn(sv, len, hash)
+#define Perl_sharepvn(pv, len, hash) HEK_KEY(share_hek(pv, len, hash))
+#define sharepvn(pv, len, hash) Perl_sharepvn(pv, len, hash)
#define share_hek_hek(hek) \
(++(((struct shared_he *)(((char *)hek) \
@@ -500,6 +476,9 @@
/* flags for the refcounted_he API */
#define REFCOUNTED_HE_KEY_UTF8 0x00000001
+#ifdef PERL_CORE
+# define REFCOUNTED_HE_EXISTS 0x00000002
+#endif
#ifdef PERL_CORE
@@ -610,12 +589,14 @@
#define newHV() MUTABLE_HV(newSV_type(SVt_PVHV))
+#include "hv_func.h"
+
/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/hv.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/hv_func.h (from rev 6437, vendor/perl/5.18.1/hv_func.h)
===================================================================
--- trunk/contrib/perl/hv_func.h (rev 0)
+++ trunk/contrib/perl/hv_func.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -0,0 +1,560 @@
+/* hash a key
+ *--------------------------------------------------------------------------------------
+ * The "hash seed" feature was added in Perl 5.8.1 to perturb the results
+ * to avoid "algorithmic complexity attacks".
+ *
+ * If USE_HASH_SEED is defined, hash randomisation is done by default
+ * If USE_HASH_SEED_EXPLICIT is defined, hash randomisation is done
+ * only if the environment variable PERL_HASH_SEED is set.
+ * (see also perl.c:perl_parse() and S_init_tls_and_interp() and util.c:get_hash_seed())
+ */
+
+#ifndef PERL_SEEN_HV_FUNC_H /* compile once */
+#define PERL_SEEN_HV_FUNC_H
+
+#if !( 0 \
+ || defined(PERL_HASH_FUNC_SIPHASH) \
+ || defined(PERL_HASH_FUNC_SDBM) \
+ || defined(PERL_HASH_FUNC_DJB2) \
+ || defined(PERL_HASH_FUNC_SUPERFAST) \
+ || defined(PERL_HASH_FUNC_MURMUR3) \
+ || defined(PERL_HASH_FUNC_ONE_AT_A_TIME) \
+ || defined(PERL_HASH_FUNC_ONE_AT_A_TIME_HARD) \
+ || defined(PERL_HASH_FUNC_ONE_AT_A_TIME_OLD) \
+ )
+#define PERL_HASH_FUNC_ONE_AT_A_TIME_HARD
+#endif
+
+#if defined(PERL_HASH_FUNC_SIPHASH)
+# define PERL_HASH_FUNC "SIPHASH_2_4"
+# define PERL_HASH_SEED_BYTES 16
+# define PERL_HASH(hash,str,len) (hash)= S_perl_hash_siphash_2_4(PERL_HASH_SEED,(U8*)(str),(len))
+#elif defined(PERL_HASH_FUNC_SUPERFAST)
+# define PERL_HASH_FUNC "SUPERFAST"
+# define PERL_HASH_SEED_BYTES 4
+# define PERL_HASH(hash,str,len) (hash)= S_perl_hash_superfast(PERL_HASH_SEED,(U8*)(str),(len))
+#elif defined(PERL_HASH_FUNC_MURMUR3)
+# define PERL_HASH_FUNC "MURMUR3"
+# define PERL_HASH_SEED_BYTES 4
+# define PERL_HASH(hash,str,len) (hash)= S_perl_hash_murmur3(PERL_HASH_SEED,(U8*)(str),(len))
+#elif defined(PERL_HASH_FUNC_DJB2)
+# define PERL_HASH_FUNC "DJB2"
+# define PERL_HASH_SEED_BYTES 4
+# define PERL_HASH(hash,str,len) (hash)= S_perl_hash_djb2(PERL_HASH_SEED,(U8*)(str),(len))
+#elif defined(PERL_HASH_FUNC_SDBM)
+# define PERL_HASH_FUNC "SDBM"
+# define PERL_HASH_SEED_BYTES 4
+# define PERL_HASH(hash,str,len) (hash)= S_perl_hash_sdbm(PERL_HASH_SEED,(U8*)(str),(len))
+#elif defined(PERL_HASH_FUNC_ONE_AT_A_TIME_HARD)
+# define PERL_HASH_FUNC "ONE_AT_A_TIME_HARD"
+# define PERL_HASH_SEED_BYTES 8
+# define PERL_HASH(hash,str,len) (hash)= S_perl_hash_one_at_a_time_hard(PERL_HASH_SEED,(U8*)(str),(len))
+#elif defined(PERL_HASH_FUNC_ONE_AT_A_TIME)
+# define PERL_HASH_FUNC "ONE_AT_A_TIME"
+# define PERL_HASH_SEED_BYTES 4
+# define PERL_HASH(hash,str,len) (hash)= S_perl_hash_one_at_a_time(PERL_HASH_SEED,(U8*)(str),(len))
+#elif defined(PERL_HASH_FUNC_ONE_AT_A_TIME_OLD)
+# define PERL_HASH_FUNC "ONE_AT_A_TIME_OLD"
+# define PERL_HASH_SEED_BYTES 4
+# define PERL_HASH(hash,str,len) (hash)= S_perl_hash_old_one_at_a_time(PERL_HASH_SEED,(U8*)(str),(len))
+#endif
+
+#ifndef PERL_HASH
+#error "No hash function defined!"
+#endif
+#ifndef PERL_HASH_SEED_BYTES
+#error "PERL_HASH_SEED_BYTES not defined"
+#endif
+#ifndef PERL_HASH_FUNC
+#error "PERL_HASH_FUNC not defined"
+#endif
+
+#ifndef PERL_HASH_SEED
+# if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
+# define PERL_HASH_SEED PL_hash_seed
+# elif PERL_HASH_SEED_BYTES == 4
+# define PERL_HASH_SEED "PeRl"
+# elif PERL_HASH_SEED_BYTES == 16
+# define PERL_HASH_SEED "PeRlHaShhAcKpErl"
+# else
+# error "No PERL_HASH_SEED definition for " PERL_HASH_FUNC
+# endif
+#endif
+
+/*-----------------------------------------------------------------------------
+ * Endianess, misalignment capabilities and util macros
+ *
+ * The following 3 macros are defined in this section. The other macros defined
+ * are only needed to help derive these 3.
+ *
+ * U8TO32_LE(x) Read a little endian unsigned 32-bit int
+ * UNALIGNED_SAFE Defined if READ_UINT32 works on non-word boundaries
+ * ROTL32(x,r) Rotate x left by r bits
+ */
+
+#if (defined(__GNUC__) && defined(__i386__)) || defined(__WATCOMC__) \
+ || defined(_MSC_VER) || defined (__BORLANDC__) || defined (__TURBOC__)
+#define U8TO16_LE(d) (*((const U16 *) (d)))
+#endif
+
+#if !defined (U8TO16_LE)
+#define U8TO16_LE(d) ((((const U8 *)(d))[1] << 8)\
+ +((const U8 *)(d))[0])
+#endif
+
+
+/* Now find best way we can to READ_UINT32 */
+#if (BYTEORDER == 0x1234 || BYTEORDER == 0x12345678) && U32SIZE == 4
+ /* CPU endian matches murmurhash algorithm, so read 32-bit word directly */
+ #define U8TO32_LE(ptr) (*((U32*)(ptr)))
+#elif BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
+ /* TODO: Add additional cases below where a compiler provided bswap32 is available */
+ #if defined(__GNUC__) && (__GNUC__>4 || (__GNUC__==4 && __GNUC_MINOR__>=3))
+ #define U8TO32_LE(ptr) (__builtin_bswap32(*((U32*)(ptr))))
+ #else
+ /* Without a known fast bswap32 we're just as well off doing this */
+ #define U8TO32_LE(ptr) (ptr[0]|ptr[1]<<8|ptr[2]<<16|ptr[3]<<24)
+ #define UNALIGNED_SAFE
+ #endif
+#else
+ /* Unknown endianess so last resort is to read individual bytes */
+ #define U8TO32_LE(ptr) (ptr[0]|ptr[1]<<8|ptr[2]<<16|ptr[3]<<24)
+ /* Since we're not doing word-reads we can skip the messing about with realignment */
+ #define UNALIGNED_SAFE
+#endif
+
+#ifdef HAS_QUAD
+#ifndef U64TYPE
+/* This probably isn't going to work, but failing with a compiler error due to
+ lack of uint64_t is no worse than failing right now with an #error. */
+#define U64TYPE uint64_t
+#endif
+#endif
+
+/* Find best way to ROTL32/ROTL64 */
+#if defined(_MSC_VER)
+ #include <stdlib.h> /* Microsoft put _rotl declaration in here */
+ #define ROTL32(x,r) _rotl(x,r)
+ #ifdef HAS_QUAD
+ #define ROTL64(x,r) _rotl64(x,r)
+ #endif
+#else
+ /* gcc recognises this code and generates a rotate instruction for CPUs with one */
+ #define ROTL32(x,r) (((U32)x << r) | ((U32)x >> (32 - r)))
+ #ifdef HAS_QUAD
+ #define ROTL64(x,r) (((U64TYPE)x << r) | ((U64TYPE)x >> (64 - r)))
+ #endif
+#endif
+
+
+#ifdef UV_IS_QUAD
+#define ROTL_UV(x,r) ROTL64(x,r)
+#else
+#define ROTL_UV(x,r) ROTL32(x,r)
+#endif
+
+/* This is SipHash by Jean-Philippe Aumasson and Daniel J. Bernstein.
+ * The authors claim it is relatively secure compared to the alternatives
+ * and that performance wise it is a suitable hash for languages like Perl.
+ * See:
+ *
+ * https://www.131002.net/siphash/
+ *
+ * This implementation seems to perform slightly slower than one-at-a-time for
+ * short keys, but degrades slower for longer keys. Murmur Hash outperforms it
+ * regardless of keys size.
+ *
+ * It is 64 bit only.
+ */
+
+#ifdef HAS_QUAD
+
+#define U8TO64_LE(p) \
+ (((U64TYPE)((p)[0]) ) | \
+ ((U64TYPE)((p)[1]) << 8) | \
+ ((U64TYPE)((p)[2]) << 16) | \
+ ((U64TYPE)((p)[3]) << 24) | \
+ ((U64TYPE)((p)[4]) << 32) | \
+ ((U64TYPE)((p)[5]) << 40) | \
+ ((U64TYPE)((p)[6]) << 48) | \
+ ((U64TYPE)((p)[7]) << 56))
+
+#define SIPROUND \
+ do { \
+ v0 += v1; v1=ROTL64(v1,13); v1 ^= v0; v0=ROTL64(v0,32); \
+ v2 += v3; v3=ROTL64(v3,16); v3 ^= v2; \
+ v0 += v3; v3=ROTL64(v3,21); v3 ^= v0; \
+ v2 += v1; v1=ROTL64(v1,17); v1 ^= v2; v2=ROTL64(v2,32); \
+ } while(0)
+
+/* SipHash-2-4 */
+
+PERL_STATIC_INLINE U32
+S_perl_hash_siphash_2_4(const unsigned char * const seed, const unsigned char *in, const STRLEN inlen) {
+ /* "somepseudorandomlygeneratedbytes" */
+ U64TYPE v0 = 0x736f6d6570736575ULL;
+ U64TYPE v1 = 0x646f72616e646f6dULL;
+ U64TYPE v2 = 0x6c7967656e657261ULL;
+ U64TYPE v3 = 0x7465646279746573ULL;
+
+ U64TYPE b;
+ U64TYPE k0 = ((U64TYPE*)seed)[0];
+ U64TYPE k1 = ((U64TYPE*)seed)[1];
+ U64TYPE m;
+ const int left = inlen & 7;
+ const U8 *end = in + inlen - left;
+
+ b = ( ( U64TYPE )(inlen) ) << 56;
+ v3 ^= k1;
+ v2 ^= k0;
+ v1 ^= k1;
+ v0 ^= k0;
+
+ for ( ; in != end; in += 8 )
+ {
+ m = U8TO64_LE( in );
+ v3 ^= m;
+ SIPROUND;
+ SIPROUND;
+ v0 ^= m;
+ }
+
+ switch( left )
+ {
+ case 7: b |= ( ( U64TYPE )in[ 6] ) << 48;
+ case 6: b |= ( ( U64TYPE )in[ 5] ) << 40;
+ case 5: b |= ( ( U64TYPE )in[ 4] ) << 32;
+ case 4: b |= ( ( U64TYPE )in[ 3] ) << 24;
+ case 3: b |= ( ( U64TYPE )in[ 2] ) << 16;
+ case 2: b |= ( ( U64TYPE )in[ 1] ) << 8;
+ case 1: b |= ( ( U64TYPE )in[ 0] ); break;
+ case 0: break;
+ }
+
+ v3 ^= b;
+ SIPROUND;
+ SIPROUND;
+ v0 ^= b;
+
+ v2 ^= 0xff;
+ SIPROUND;
+ SIPROUND;
+ SIPROUND;
+ SIPROUND;
+ b = v0 ^ v1 ^ v2 ^ v3;
+ return (U32)(b & U32_MAX);
+}
+#endif /* defined(HAS_QUAD) */
+
+/* FYI: This is the "Super-Fast" algorithm mentioned by Bob Jenkins in
+ * (http://burtleburtle.net/bob/hash/doobs.html)
+ * It is by Paul Hsieh (c) 2004 and is analysed here
+ * http://www.azillionmonkeys.com/qed/hash.html
+ * license terms are here:
+ * http://www.azillionmonkeys.com/qed/weblicense.html
+ */
+
+
+PERL_STATIC_INLINE U32
+S_perl_hash_superfast(const unsigned char * const seed, const unsigned char *str, STRLEN len) {
+ U32 hash = *((U32*)seed) + len;
+ U32 tmp;
+ int rem= len & 3;
+ len >>= 2;
+
+ for (;len > 0; len--) {
+ hash += U8TO16_LE (str);
+ tmp = (U8TO16_LE (str+2) << 11) ^ hash;
+ hash = (hash << 16) ^ tmp;
+ str += 2 * sizeof (U16);
+ hash += hash >> 11;
+ }
+
+ /* Handle end cases */
+ switch (rem) { \
+ case 3: hash += U8TO16_LE (str);
+ hash ^= hash << 16;
+ hash ^= str[sizeof (U16)] << 18;
+ hash += hash >> 11;
+ break;
+ case 2: hash += U8TO16_LE (str);
+ hash ^= hash << 11;
+ hash += hash >> 17;
+ break;
+ case 1: hash += *str;
+ hash ^= hash << 10;
+ hash += hash >> 1;
+ }
+ /* Force "avalanching" of final 127 bits */
+ hash ^= hash << 3;
+ hash += hash >> 5;
+ hash ^= hash << 4;
+ hash += hash >> 17;
+ hash ^= hash << 25;
+ return (hash + (hash >> 6));
+}
+
+
+/*-----------------------------------------------------------------------------
+ * MurmurHash3 was written by Austin Appleby, and is placed in the public
+ * domain.
+ *
+ * This implementation was originally written by Shane Day, and is also public domain,
+ * and was modified to function as a macro similar to other perl hash functions by
+ * Yves Orton.
+ *
+ * This is a portable ANSI C implementation of MurmurHash3_x86_32 (Murmur3A)
+ * with support for progressive processing.
+ *
+ * If you want to understand the MurmurHash algorithm you would be much better
+ * off reading the original source. Just point your browser at:
+ * http://code.google.com/p/smhasher/source/browse/trunk/MurmurHash3.cpp
+ *
+ * How does it work?
+ *
+ * We can only process entire 32 bit chunks of input, except for the very end
+ * that may be shorter.
+ *
+ * To handle endianess I simply use a macro that reads a U32 and define
+ * that macro to be a direct read on little endian machines, a read and swap
+ * on big endian machines, or a byte-by-byte read if the endianess is unknown.
+ */
+
+
+/*-----------------------------------------------------------------------------
+ * Core murmurhash algorithm macros */
+
+#define MURMUR_C1 (0xcc9e2d51)
+#define MURMUR_C2 (0x1b873593)
+#define MURMUR_C3 (0xe6546b64)
+#define MURMUR_C4 (0x85ebca6b)
+#define MURMUR_C5 (0xc2b2ae35)
+
+/* This is the main processing body of the algorithm. It operates
+ * on each full 32-bits of input. */
+#define MURMUR_DOBLOCK(h1, k1) STMT_START { \
+ k1 *= MURMUR_C1; \
+ k1 = ROTL32(k1,15); \
+ k1 *= MURMUR_C2; \
+ \
+ h1 ^= k1; \
+ h1 = ROTL32(h1,13); \
+ h1 = h1 * 5 + MURMUR_C3; \
+} STMT_END
+
+
+/* Append unaligned bytes to carry, forcing hash churn if we have 4 bytes */
+/* cnt=bytes to process, h1=name of h1 var, c=carry, n=bytes in c, ptr/len=payload */
+#define MURMUR_DOBYTES(cnt, h1, c, n, ptr, len) STMT_START { \
+ int MURMUR_DOBYTES_i = cnt; \
+ while(MURMUR_DOBYTES_i--) { \
+ c = c>>8 | *ptr++<<24; \
+ n++; len--; \
+ if(n==4) { \
+ MURMUR_DOBLOCK(h1, c); \
+ n = 0; \
+ } \
+ } \
+} STMT_END
+
+
+/* now we create the hash function */
+PERL_STATIC_INLINE U32
+S_perl_hash_murmur3(const unsigned char * const seed, const unsigned char *ptr, STRLEN len) {
+ U32 h1 = *((U32*)seed);
+ U32 k1;
+ U32 carry = 0;
+
+ const unsigned char *end;
+ int bytes_in_carry = 0; /* bytes in carry */
+ I32 total_length= len;
+
+#if defined(UNALIGNED_SAFE)
+ /* Handle carry: commented out as its only used in incremental mode - it never fires for us
+ int i = (4-n) & 3;
+ if(i && i <= len) {
+ MURMUR_DOBYTES(i, h1, carry, bytes_in_carry, ptr, len);
+ }
+ */
+
+ /* This CPU handles unaligned word access */
+ /* Process 32-bit chunks */
+ end = ptr + len/4*4;
+ for( ; ptr < end ; ptr+=4) {
+ k1 = U8TO32_LE(ptr);
+ MURMUR_DOBLOCK(h1, k1);
+ }
+#else
+ /* This CPU does not handle unaligned word access */
+
+ /* Consume enough so that the next data byte is word aligned */
+ STRLEN i = -PTR2IV(ptr) & 3;
+ if(i && i <= len) {
+ MURMUR_DOBYTES(i, h1, carry, bytes_in_carry, ptr, len);
+ }
+
+ /* We're now aligned. Process in aligned blocks. Specialise for each possible carry count */
+ end = ptr + len/4*4;
+ switch(bytes_in_carry) { /* how many bytes in carry */
+ case 0: /* c=[----] w=[3210] b=[3210]=w c'=[----] */
+ for( ; ptr < end ; ptr+=4) {
+ k1 = U8TO32_LE(ptr);
+ MURMUR_DOBLOCK(h1, k1);
+ }
+ break;
+ case 1: /* c=[0---] w=[4321] b=[3210]=c>>24|w<<8 c'=[4---] */
+ for( ; ptr < end ; ptr+=4) {
+ k1 = carry>>24;
+ carry = U8TO32_LE(ptr);
+ k1 |= carry<<8;
+ MURMUR_DOBLOCK(h1, k1);
+ }
+ break;
+ case 2: /* c=[10--] w=[5432] b=[3210]=c>>16|w<<16 c'=[54--] */
+ for( ; ptr < end ; ptr+=4) {
+ k1 = carry>>16;
+ carry = U8TO32_LE(ptr);
+ k1 |= carry<<16;
+ MURMUR_DOBLOCK(h1, k1);
+ }
+ break;
+ case 3: /* c=[210-] w=[6543] b=[3210]=c>>8|w<<24 c'=[654-] */
+ for( ; ptr < end ; ptr+=4) {
+ k1 = carry>>8;
+ carry = U8TO32_LE(ptr);
+ k1 |= carry<<24;
+ MURMUR_DOBLOCK(h1, k1);
+ }
+ }
+#endif
+ /* Advance over whole 32-bit chunks, possibly leaving 1..3 bytes */
+ len -= len/4*4;
+
+ /* Append any remaining bytes into carry */
+ MURMUR_DOBYTES(len, h1, carry, bytes_in_carry, ptr, len);
+
+ if (bytes_in_carry) {
+ k1 = carry >> ( 4 - bytes_in_carry ) * 8;
+ k1 *= MURMUR_C1;
+ k1 = ROTL32(k1,15);
+ k1 *= MURMUR_C2;
+ h1 ^= k1;
+ }
+ h1 ^= total_length;
+
+ /* fmix */
+ h1 ^= h1 >> 16;
+ h1 *= MURMUR_C4;
+ h1 ^= h1 >> 13;
+ h1 *= MURMUR_C5;
+ h1 ^= h1 >> 16;
+ return h1;
+}
+
+
+PERL_STATIC_INLINE U32
+S_perl_hash_djb2(const unsigned char * const seed, const unsigned char *str, const STRLEN len) {
+ const unsigned char * const end = (const unsigned char *)str + len;
+ U32 hash = *((U32*)seed + len);
+ while (str < end) {
+ hash = ((hash << 5) + hash) + *str++;
+ }
+ return hash;
+}
+
+PERL_STATIC_INLINE U32
+S_perl_hash_sdbm(const unsigned char * const seed, const unsigned char *str, const STRLEN len) {
+ const unsigned char * const end = (const unsigned char *)str + len;
+ U32 hash = *((U32*)seed + len);
+ while (str < end) {
+ hash = (hash << 6) + (hash << 16) - hash + *str++;
+ }
+ return hash;
+}
+
+
+/* This is the "One-at-a-Time" algorithm by Bob Jenkins
+ * from requirements by Colin Plumb.
+ * (http://burtleburtle.net/bob/hash/doobs.html)
+ * With seed/len tweak.
+ * */
+PERL_STATIC_INLINE U32
+S_perl_hash_one_at_a_time(const unsigned char * const seed, const unsigned char *str, const STRLEN len) {
+ const unsigned char * const end = (const unsigned char *)str + len;
+ U32 hash = *((U32*)seed) + len;
+ while (str < end) {
+ hash += *str++;
+ hash += (hash << 10);
+ hash ^= (hash >> 6);
+ }
+ hash += (hash << 3);
+ hash ^= (hash >> 11);
+ return (hash + (hash << 15));
+}
+
+/* Derived from "One-at-a-Time" algorithm by Bob Jenkins */
+PERL_STATIC_INLINE U32
+S_perl_hash_one_at_a_time_hard(const unsigned char * const seed, const unsigned char *str, const STRLEN len) {
+ const unsigned char * const end = (const unsigned char *)str + len;
+ U32 hash = *((U32*)seed) + len;
+
+ while (str < end) {
+ hash += (hash << 10);
+ hash ^= (hash >> 6);
+ hash += *str++;
+ }
+
+ hash += (hash << 10);
+ hash ^= (hash >> 6);
+ hash += seed[4];
+
+ hash += (hash << 10);
+ hash ^= (hash >> 6);
+ hash += seed[5];
+
+ hash += (hash << 10);
+ hash ^= (hash >> 6);
+ hash += seed[6];
+
+ hash += (hash << 10);
+ hash ^= (hash >> 6);
+ hash += seed[7];
+
+ hash += (hash << 10);
+ hash ^= (hash >> 6);
+
+ hash += (hash << 3);
+ hash ^= (hash >> 11);
+ return (hash + (hash << 15));
+}
+
+PERL_STATIC_INLINE U32
+S_perl_hash_old_one_at_a_time(const unsigned char * const seed, const unsigned char *str, const STRLEN len) {
+ const unsigned char * const end = (const unsigned char *)str + len;
+ U32 hash = *((U32*)seed);
+ while (str < end) {
+ hash += *str++;
+ hash += (hash << 10);
+ hash ^= (hash >> 6);
+ }
+ hash += (hash << 3);
+ hash ^= (hash >> 11);
+ return (hash + (hash << 15));
+}
+
+/* legacy - only mod_perl should be doing this. */
+#ifdef PERL_HASH_INTERNAL_ACCESS
+#define PERL_HASH_INTERNAL(hash,str,len) PERL_HASH(hash,str,len)
+#endif
+
+#endif /*compile once*/
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: nil
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 et:
+ */
Copied: trunk/contrib/perl/inline.h (from rev 6437, vendor/perl/5.18.1/inline.h)
===================================================================
--- trunk/contrib/perl/inline.h (rev 0)
+++ trunk/contrib/perl/inline.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -0,0 +1,156 @@
+/* inline.h
+ *
+ * Copyright (C) 2012 by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * This file is a home for static inline functions that cannot go in other
+ * headers files, because they depend on proto.h (included after most other
+ * headers) or struct definitions.
+ *
+ * Each section names the header file that the functions "belong" to.
+ */
+
+/* ------------------------------- av.h ------------------------------- */
+
+PERL_STATIC_INLINE I32
+S_av_top_index(pTHX_ AV *av)
+{
+ PERL_ARGS_ASSERT_AV_TOP_INDEX;
+ assert(SvTYPE(av) == SVt_PVAV);
+
+ return AvFILL(av);
+}
+
+/* ------------------------------- cv.h ------------------------------- */
+
+PERL_STATIC_INLINE I32 *
+S_CvDEPTHp(const CV * const sv)
+{
+ assert(SvTYPE(sv) == SVt_PVCV || SvTYPE(sv) == SVt_PVFM);
+ return &((XPVCV*)SvANY(sv))->xcv_depth;
+}
+
+/* ----------------------------- regexp.h ----------------------------- */
+
+PERL_STATIC_INLINE struct regexp *
+S_ReANY(const REGEXP * const re)
+{
+ assert(isREGEXP(re));
+ return re->sv_u.svu_rx;
+}
+
+/* ------------------------------- sv.h ------------------------------- */
+
+PERL_STATIC_INLINE SV *
+S_SvREFCNT_inc(SV *sv)
+{
+ if (LIKELY(sv != NULL))
+ SvREFCNT(sv)++;
+ return sv;
+}
+PERL_STATIC_INLINE SV *
+S_SvREFCNT_inc_NN(SV *sv)
+{
+ SvREFCNT(sv)++;
+ return sv;
+}
+PERL_STATIC_INLINE void
+S_SvREFCNT_inc_void(SV *sv)
+{
+ if (LIKELY(sv != NULL))
+ SvREFCNT(sv)++;
+}
+PERL_STATIC_INLINE void
+S_SvREFCNT_dec(pTHX_ SV *sv)
+{
+ if (LIKELY(sv != NULL)) {
+ U32 rc = SvREFCNT(sv);
+ if (rc > 1)
+ SvREFCNT(sv) = rc - 1;
+ else
+ Perl_sv_free2(aTHX_ sv, rc);
+ }
+}
+
+PERL_STATIC_INLINE void
+S_SvREFCNT_dec_NN(pTHX_ SV *sv)
+{
+ U32 rc = SvREFCNT(sv);
+ if (rc > 1)
+ SvREFCNT(sv) = rc - 1;
+ else
+ Perl_sv_free2(aTHX_ sv, rc);
+}
+
+PERL_STATIC_INLINE void
+SvAMAGIC_on(SV *sv)
+{
+ assert(SvROK(sv));
+ if (SvOBJECT(SvRV(sv))) HvAMAGIC_on(SvSTASH(SvRV(sv)));
+}
+PERL_STATIC_INLINE void
+SvAMAGIC_off(SV *sv)
+{
+ if (SvROK(sv) && SvOBJECT(SvRV(sv)))
+ HvAMAGIC_off(SvSTASH(SvRV(sv)));
+}
+
+PERL_STATIC_INLINE U32
+S_SvPADTMP_on(SV *sv)
+{
+ assert(!(SvFLAGS(sv) & SVs_PADMY));
+ return SvFLAGS(sv) |= SVs_PADTMP;
+}
+PERL_STATIC_INLINE U32
+S_SvPADTMP_off(SV *sv)
+{
+ assert(!(SvFLAGS(sv) & SVs_PADMY));
+ return SvFLAGS(sv) &= ~SVs_PADTMP;
+}
+PERL_STATIC_INLINE U32
+S_SvPADSTALE_on(SV *sv)
+{
+ assert(SvFLAGS(sv) & SVs_PADMY);
+ return SvFLAGS(sv) |= SVs_PADSTALE;
+}
+PERL_STATIC_INLINE U32
+S_SvPADSTALE_off(SV *sv)
+{
+ assert(SvFLAGS(sv) & SVs_PADMY);
+ return SvFLAGS(sv) &= ~SVs_PADSTALE;
+}
+#ifdef PERL_CORE
+PERL_STATIC_INLINE STRLEN
+S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp)
+{
+ if (SvGAMAGIC(sv)) {
+ U8 *hopped = utf8_hop((U8 *)pv, pos);
+ if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped);
+ return (STRLEN)(hopped - (U8 *)pv);
+ }
+ return sv_pos_u2b_flags(sv,pos,lenp,SV_CONST_RETURN);
+}
+#endif
+
+/* ------------------------------- utf8.h ------------------------------- */
+
+/* These exist only to replace the macros they formerly were so that their use
+ * can be deprecated */
+
+PERL_STATIC_INLINE bool
+S_isIDFIRST_lazy(pTHX_ const char* p)
+{
+ PERL_ARGS_ASSERT_ISIDFIRST_LAZY;
+
+ return isIDFIRST_lazy_if(p,1);
+}
+
+PERL_STATIC_INLINE bool
+S_isALNUM_lazy(pTHX_ const char* p)
+{
+ PERL_ARGS_ASSERT_ISALNUM_LAZY;
+
+ return isALNUM_lazy_if(p,1);
+}
Copied: trunk/contrib/perl/inline_invlist.c (from rev 6437, vendor/perl/5.18.1/inline_invlist.c)
===================================================================
--- trunk/contrib/perl/inline_invlist.c (rev 0)
+++ trunk/contrib/perl/inline_invlist.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -0,0 +1,77 @@
+/* inline_invlist.c
+ *
+ * Copyright (C) 2012 by Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ */
+
+#if defined(PERL_IN_UTF8_C) || defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_REGEXEC_C)
+
+#define INVLIST_LEN_OFFSET 0 /* Number of elements in the inversion list */
+#define INVLIST_ITER_OFFSET 1 /* Current iteration position */
+#define INVLIST_PREVIOUS_INDEX_OFFSET 2 /* Place to cache index of previous
+ result */
+
+/* This is a combination of a version and data structure type, so that one
+ * being passed in can be validated to be an inversion list of the correct
+ * vintage. When the structure of the header is changed, a new random number
+ * in the range 2**31-1 should be generated and the new() method changed to
+ * insert that at this location. Then, if an auxiliary program doesn't change
+ * correspondingly, it will be discovered immediately */
+#define INVLIST_VERSION_ID_OFFSET 3
+#define INVLIST_VERSION_ID 290655244
+
+/* For safety, when adding new elements, remember to #undef them at the end of
+ * the inversion list code section */
+
+#define INVLIST_ZERO_OFFSET 4 /* 0 or 1; must be last element in header */
+/* The UV at position ZERO contains either 0 or 1. If 0, the inversion list
+ * contains the code point U+00000, and begins here. If 1, the inversion list
+ * doesn't contain U+0000, and it begins at the next UV in the array.
+ * Inverting an inversion list consists of adding or removing the 0 at the
+ * beginning of it. By reserving a space for that 0, inversion can be made
+ * very fast */
+
+#define HEADER_LENGTH (INVLIST_ZERO_OFFSET + 1)
+
+/* An element is in an inversion list iff its index is even numbered: 0, 2, 4,
+ * etc */
+#define ELEMENT_RANGE_MATCHES_INVLIST(i) (! ((i) & 1))
+#define PREV_RANGE_MATCHES_INVLIST(i) (! ELEMENT_RANGE_MATCHES_INVLIST(i))
+
+PERL_STATIC_INLINE UV*
+S__get_invlist_len_addr(pTHX_ SV* invlist)
+{
+ /* Return the address of the UV that contains the current number
+ * of used elements in the inversion list */
+
+ PERL_ARGS_ASSERT__GET_INVLIST_LEN_ADDR;
+
+ return (UV *) (SvPVX(invlist) + (INVLIST_LEN_OFFSET * sizeof (UV)));
+}
+
+PERL_STATIC_INLINE UV
+S__invlist_len(pTHX_ SV* const invlist)
+{
+ /* Returns the current number of elements stored in the inversion list's
+ * array */
+
+ PERL_ARGS_ASSERT__INVLIST_LEN;
+
+ return *_get_invlist_len_addr(invlist);
+}
+
+PERL_STATIC_INLINE bool
+S__invlist_contains_cp(pTHX_ SV* const invlist, const UV cp)
+{
+ /* Does <invlist> contain code point <cp> as part of the set? */
+
+ IV index = _invlist_search(invlist, cp);
+
+ PERL_ARGS_ASSERT__INVLIST_CONTAINS_CP;
+
+ return index >= 0 && ELEMENT_RANGE_MATCHES_INVLIST(index);
+}
+
+#endif
Modified: trunk/contrib/perl/install_lib.pl
===================================================================
--- trunk/contrib/perl/install_lib.pl 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/install_lib.pl 2013-12-02 21:18:17 UTC (rev 6438)
@@ -120,7 +120,7 @@
my($dev1, $ino1, $dev2, $ino2);
($dev1, $ino1) = stat($p1);
($dev2, $ino2) = stat($p2);
- ($dev1 ~~ $dev2 && $ino1 ~~ $ino2);
+ ($dev1 == $dev2 && $ino1 == $ino2);
}
else {
1;
Property changes on: trunk/contrib/perl/install_lib.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/intrpvar.h
===================================================================
--- trunk/contrib/perl/intrpvar.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/intrpvar.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -8,6 +8,8 @@
*
*/
+#include "handy.h"
+
/*
=head1 Per-Interpreter Variables
*/
@@ -17,11 +19,9 @@
* Don't forget to re-run regen/embed.pl to propagate changes! */
-/* New variables must be added to the very end for binary compatibility.
- * XSUB.h provides wrapper functions via perlapi.h that make this
- * irrelevant, but not all code may be expected to #include XSUB.h. */
+/* New variables must be added to the very end for binary compatibility. */
-/* Don't forget to add your variable also to perl_clone()! */
+/* Don't forget to add your variable also to perl_clone()! (in sv.c) */
/* The 'I' prefix is only needed for vars that need appropriate #defines
* generated when built with or without MULTIPLICITY. It is also used
@@ -32,45 +32,129 @@
*
* Important ones in the first cache line (if alignment is done right) */
-PERLVAR(Istack_sp, SV **) /* top of the stack */
+PERLVAR(I, stack_sp, SV **) /* top of the stack */
#ifdef OP_IN_REGISTER
-PERLVAR(Iopsave, OP *)
+PERLVAR(I, opsave, OP *)
#else
-PERLVAR(Iop, OP *) /* currently executing op */
+PERLVAR(I, op, OP *) /* currently executing op */
#endif
-PERLVAR(Icurpad, SV **) /* active pad (lexicals+tmps) */
+PERLVAR(I, curpad, SV **) /* active pad (lexicals+tmps) */
-PERLVAR(Istack_base, SV **)
-PERLVAR(Istack_max, SV **)
+PERLVAR(I, stack_base, SV **)
+PERLVAR(I, stack_max, SV **)
-PERLVAR(Iscopestack, I32 *) /* scopes we've ENTERed */
-/* name of the scopes we've ENTERed. Only used with -DDEBUGGING, but needs to be
- present always, as -DDEUBGGING must be binary compatible with non. */
-PERLVARI(Iscopestack_name, const char * *, NULL)
-PERLVAR(Iscopestack_ix, I32)
-PERLVAR(Iscopestack_max,I32)
-
-PERLVAR(Isavestack, ANY *) /* items that need to be restored when
+PERLVAR(I, savestack, ANY *) /* items that need to be restored when
LEAVEing scopes we've ENTERed */
-PERLVAR(Isavestack_ix, I32)
-PERLVAR(Isavestack_max, I32)
+PERLVAR(I, savestack_ix, I32)
+PERLVAR(I, savestack_max, I32)
-PERLVAR(Itmps_stack, SV **) /* mortals we've made */
-PERLVARI(Itmps_ix, I32, -1)
-PERLVARI(Itmps_floor, I32, -1)
-PERLVAR(Itmps_max, I32)
-PERLVAR(Imodcount, I32) /* how much op_lvalue()ification in
- assignment? */
+PERLVAR(I, scopestack, I32 *) /* scopes we've ENTERed */
+PERLVAR(I, scopestack_ix, I32)
+PERLVAR(I, scopestack_max, I32)
-PERLVAR(Imarkstack, I32 *) /* stack_sp locations we're
+PERLVAR(I, tmps_stack, SV **) /* mortals we've made */
+PERLVARI(I, tmps_ix, I32, -1)
+PERLVARI(I, tmps_floor, I32, -1)
+PERLVAR(I, tmps_max, I32)
+
+PERLVARI(I, sub_generation, U32, 1) /* incr to invalidate method cache */
+
+PERLVAR(I, markstack, I32 *) /* stack_sp locations we're
remembering */
-PERLVAR(Imarkstack_ptr, I32 *)
-PERLVAR(Imarkstack_max, I32 *)
+PERLVAR(I, markstack_ptr, I32 *)
+PERLVAR(I, markstack_max, I32 *)
-PERLVAR(ISv, SV *) /* used to hold temporary values */
-PERLVAR(IXpv, XPV *) /* used to hold temporary values */
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+#ifdef USE_PERL_PERTURB_KEYS
+PERLVARI(I, hash_rand_bits_enabled, U8, 1) /* used to randomize hash stuff 0 == no-random, 1 == random, 2 == determinsitic */
+#endif
+PERLVARI(I, hash_rand_bits, UV, 0) /* used to randomize hash stuff */
+#endif
+PERLVAR(I, strtab, HV *) /* shared string table */
+/* Fields used by magic variables such as $@, $/ and so on */
+PERLVAR(I, curpm, PMOP *) /* what to do \ interps in REs from */
+
+PERLVAR(I, tainting, bool) /* doing taint checks */
+PERLVAR(I, tainted, bool) /* using variables controlled by $< */
+PERLVAR(I, delaymagic, U16) /* ($<,$>) = ... */
+PERLVAR(I, localizing, U8) /* are we processing a local() list? */
+PERLVAR(I, in_eval, U8) /* trap "fatal" errors? */
/*
+
+=for apidoc mn|bool|PL_dowarn
+
+The C variable which corresponds to Perl's $^W warning variable.
+
+=cut
+*/
+
+PERLVAR(I, dowarn, U8)
+
+#if defined (PERL_UTF8_CACHE_ASSERT) || defined (DEBUGGING)
+# define PERL___I -1
+#else
+# define PERL___I 1
+#endif
+PERLVARI(I, utf8cache, I8, PERL___I) /* Is the utf8 caching code enabled? */
+#undef PERL___I
+
+
+/* Stashes */
+PERLVAR(I, defstash, HV *) /* main symbol table */
+PERLVAR(I, curstash, HV *) /* symbol table for current package */
+
+PERLVAR(I, curcop, COP *)
+PERLVAR(I, curstack, AV *) /* THE STACK */
+PERLVAR(I, curstackinfo, PERL_SI *) /* current stack + context */
+PERLVAR(I, mainstack, AV *) /* the stack when nothing funny is
+ happening */
+
+/* memory management */
+PERLVAR(I, sv_count, IV) /* how many SV* are currently allocated */
+PERLVAR(I, sv_objcount, IV) /* DEPRECATED AND UNMAINTAINED.
+ * Will be removed in Perl 5.20.
+ * Used to be: how many objects are currently allocated. */
+
+PERLVAR(I, sv_root, SV *) /* storage for SVs belonging to interp */
+PERLVAR(I, sv_arenaroot, SV *) /* list of areas for garbage collection */
+
+PERLVAR(I, reg_state, struct re_save_state)
+
+/* the currently active slab in a chain of slabs of regmatch states,
+ * and the currently active state within that slab */
+
+PERLVARI(I, regmatch_slab, regmatch_slab *, NULL)
+PERLVAR(I, regmatch_state, regmatch_state *)
+
+PERLVAR(I, comppad, PAD *) /* storage for lexically scoped temporaries */
+
+/*
+=for apidoc Amn|SV|PL_sv_undef
+This is the C<undef> SV. Always refer to this as C<&PL_sv_undef>.
+
+=for apidoc Amn|SV|PL_sv_no
+This is the C<false> SV. See C<PL_sv_yes>. Always refer to this as
+C<&PL_sv_no>.
+
+=for apidoc Amn|SV|PL_sv_yes
+This is the C<true> SV. See C<PL_sv_no>. Always refer to this as
+C<&PL_sv_yes>.
+
+=cut
+*/
+
+PERLVAR(I, sv_undef, SV)
+PERLVAR(I, sv_no, SV)
+PERLVAR(I, sv_yes, SV)
+PERLVAR(I, Sv, SV *) /* used to hold temporary values */
+
+PERLVAR(I, parser, yy_parser *) /* current parser state */
+
+PERLVAR(I, stashcache, HV *) /* Cache to speed up S_method_common */
+
+
+/*
=for apidoc Amn|STRLEN|PL_na
A convenience variable which is typically used with C<SvPV> when one
@@ -81,22 +165,19 @@
=cut
*/
-PERLVAR(Ina, STRLEN) /* for use in SvPV when length is
+PERLVAR(I, na, STRLEN) /* for use in SvPV when length is
Not Applicable */
/* stat stuff */
-PERLVAR(Istatbuf, Stat_t)
-PERLVAR(Istatcache, Stat_t) /* _ */
-PERLVAR(Istatgv, GV *)
-PERLVARI(Istatname, SV *, NULL)
+PERLVAR(I, statbuf, Stat_t)
+PERLVAR(I, statcache, Stat_t) /* _ */
+PERLVAR(I, statgv, GV *)
+PERLVARI(I, statname, SV *, NULL)
#ifdef HAS_TIMES
-PERLVAR(Itimesbuf, struct tms)
+PERLVAR(I, timesbuf, struct tms)
#endif
-/* Fields used by magic variables such as $@, $/ and so on */
-PERLVAR(Icurpm, PMOP *) /* what to do \ interps in REs from */
-
/*
=for apidoc mn|SV*|PL_rs
@@ -113,64 +194,48 @@
=cut
*/
-PERLVAR(Irs, SV *) /* input record separator $/ */
-PERLVAR(Ilast_in_gv, GV *) /* GV used in last <FH> */
-PERLVAR(Iofsgv, GV *) /* GV of output field separator *, */
-PERLVAR(Idefoutgv, GV *) /* default FH for output */
-PERLVARI(Ichopset, const char *, " \n-") /* $: */
-PERLVAR(Iformtarget, SV *)
-PERLVAR(Ibodytarget, SV *)
-PERLVAR(Itoptarget, SV *)
+PERLVAR(I, rs, SV *) /* input record separator $/ */
+PERLVAR(I, last_in_gv, GV *) /* GV used in last <FH> */
+PERLVAR(I, ofsgv, GV *) /* GV of output field separator *, */
+PERLVAR(I, defoutgv, GV *) /* default FH for output */
+PERLVARI(I, chopset, const char *, " \n-") /* $: */
+PERLVAR(I, formtarget, SV *)
+PERLVAR(I, bodytarget, SV *)
+PERLVAR(I, toptarget, SV *)
-/* Stashes */
-PERLVAR(Idefstash, HV *) /* main symbol table */
-PERLVAR(Icurstash, HV *) /* symbol table for current package */
-PERLVAR(Irestartop, OP *) /* propagating an error from croak? */
-PERLVAR(Irestartjmpenv, JMPENV *) /* target frame for longjmp in die */
-PERLVAR(Icurcop, COP *)
-PERLVAR(Icurstack, AV *) /* THE STACK */
-PERLVAR(Icurstackinfo, PERL_SI *) /* current stack + context */
-PERLVAR(Imainstack, AV *) /* the stack when nothing funny is
- happening */
+PERLVAR(I, restartop, OP *) /* propagating an error from croak? */
+PERLVAR(I, restartjmpenv, JMPENV *) /* target frame for longjmp in die */
-PERLVAR(Itop_env, JMPENV *) /* ptr to current sigjmp environment */
-PERLVAR(Istart_env, JMPENV) /* empty startup sigjmp environment */
-PERLVARI(Ierrors, SV *, NULL) /* outstanding queued errors */
+PERLVAR(I, top_env, JMPENV *) /* ptr to current sigjmp environment */
+PERLVAR(I, start_env, JMPENV) /* empty startup sigjmp environment */
+PERLVARI(I, errors, SV *, NULL) /* outstanding queued errors */
/* statics "owned" by various functions */
-PERLVAR(Ihv_fetch_ent_mh, HE*) /* owned by hv_fetch_ent() */
+PERLVAR(I, hv_fetch_ent_mh, HE*) /* owned by hv_fetch_ent() */
-PERLVAR(Ilastgotoprobe, OP*) /* from pp_ctl.c */
+PERLVAR(I, lastgotoprobe, OP*) /* from pp_ctl.c */
/* sort stuff */
-PERLVAR(Isortcop, OP *) /* user defined sort routine */
-PERLVAR(Isortstash, HV *) /* which is in some package or other */
-PERLVAR(Ifirstgv, GV *) /* $a */
-PERLVAR(Isecondgv, GV *) /* $b */
+PERLVAR(I, sortcop, OP *) /* user defined sort routine */
+PERLVAR(I, sortstash, HV *) /* which is in some package or other */
+PERLVAR(I, firstgv, GV *) /* $a */
+PERLVAR(I, secondgv, GV *) /* $b */
/* float buffer */
-PERLVAR(Iefloatbuf, char *)
-PERLVAR(Iefloatsize, STRLEN)
+PERLVAR(I, efloatbuf, char *)
+PERLVAR(I, efloatsize, STRLEN)
-/* regex stuff */
+PERLVAR(I, regdummy, regnode) /* from regcomp.c */
-PERLVAR(Iscreamfirst, I32 *)
-PERLVAR(Iscreamnext, I32 *)
-PERLVAR(Ilastscream, SV *)
-
-PERLVAR(Ireg_state, struct re_save_state)
-
-PERLVAR(Iregdummy, regnode) /* from regcomp.c */
-
-PERLVARI(Idumpindent, U16, 4) /* number of blanks per dump
+PERLVARI(I, dumpindent, U16, 4) /* number of blanks per dump
indentation level */
+PERLVAR(I, exit_flags, U8) /* was exit() unexpected, etc. */
-PERLVAR(Iutf8locale, bool) /* utf8 locale detected */
-PERLVARI(Irehash_seed_set, bool, FALSE) /* 582 hash initialized? */
+PERLVAR(I, utf8locale, bool) /* utf8 locale detected */
-PERLVARA(Icolors,6, char *) /* from regcomp.c */
+PERLVARA(I, colors,6, char *) /* from regcomp.c */
/*
=for apidoc Amn|peep_t|PL_peepp
@@ -193,7 +258,7 @@
=cut
*/
-PERLVARI(Ipeepp, peep_t, Perl_peep)
+PERLVARI(I, peepp, peep_t, Perl_peep)
/*
=for apidoc Amn|peep_t|PL_rpeepp
@@ -217,7 +282,7 @@
=cut
*/
-PERLVARI(Irpeepp, peep_t, Perl_rpeep)
+PERLVARI(I, rpeepp, peep_t, Perl_rpeep)
/*
=for apidoc Amn|Perl_ophook_t|PL_opfreehook
@@ -231,117 +296,76 @@
=cut
*/
-PERLVARI(Iopfreehook, Perl_ophook_t, 0) /* op_free() hook */
+PERLVARI(I, opfreehook, Perl_ophook_t, 0) /* op_free() hook */
-PERLVARI(Imaxscream, I32, -1)
-PERLVARI(Ireginterp_cnt,I32, 0) /* Whether "Regexp" was interpolated. */
-PERLVARI(Iwatchaddr, char **, 0)
-PERLVAR(Iwatchok, char *)
+PERLVARI(I, watchaddr, char **, 0)
+PERLVAR(I, watchok, char *)
-/* the currently active slab in a chain of slabs of regmatch states,
- * and the currently active state within that slab */
+PERLVAR(I, perldb, U32)
-PERLVARI(Iregmatch_slab, regmatch_slab *, NULL)
-PERLVAR(Iregmatch_state, regmatch_state *)
+PERLVAR(I, signals, U32) /* Using which pre-5.8 signals */
-/* Put anything new that is pointer aligned here. */
+PERLVAR(I, reentrant_retint, int) /* Integer return value from reentrant functions */
-PERLVAR(Idelaymagic, U16) /* ($<,$>) = ... */
-PERLVAR(Ilocalizing, U8) /* are we processing a local() list? */
-PERLVAR(Icolorset, bool) /* from regcomp.c */
-PERLVAR(Iin_eval, U8) /* trap "fatal" errors? */
-PERLVAR(Itainted, bool) /* using variables controlled by $< */
-
-/* current phase the interpreter is in */
-PERLVARI(Iphase, enum perl_phase, PERL_PHASE_CONSTRUCT)
-
-/* This value may be set when embedding for full cleanup */
-/* 0=none, 1=full, 2=full with checks */
-/* mod_perl is special, and also assigns a meaning -1 */
-PERLVARI(Iperl_destruct_level, signed char, 0)
-
-PERLVAR(Iperldb, U32)
-
/* pseudo environmental stuff */
-PERLVAR(Iorigargc, int)
-PERLVAR(Iorigargv, char **)
-PERLVAR(Ienvgv, GV *)
-PERLVAR(Iincgv, GV *)
-PERLVAR(Ihintgv, GV *)
-PERLVAR(Iorigfilename, char *)
-PERLVAR(Idiehook, SV *)
-PERLVAR(Iwarnhook, SV *)
+PERLVAR(I, origargc, int)
+PERLVAR(I, origargv, char **)
+PERLVAR(I, envgv, GV *)
+PERLVAR(I, incgv, GV *)
+PERLVAR(I, hintgv, GV *)
+PERLVAR(I, origfilename, char *)
+PERLVAR(I, diehook, SV *)
+PERLVAR(I, warnhook, SV *)
/* switches */
-PERLVAR(Ipatchlevel, SV *)
-PERLVAR(Iapiversion, SV *)
-PERLVAR(Ilocalpatches, const char * const *)
-PERLVARI(Isplitstr, const char *, " ")
+PERLVAR(I, patchlevel, SV *)
+PERLVAR(I, apiversion, SV *)
+PERLVAR(I, localpatches, const char * const *)
+PERLVARI(I, splitstr, const char *, " ")
-PERLVAR(Iminus_c, bool)
-PERLVAR(Iminus_n, bool)
-PERLVAR(Iminus_p, bool)
-PERLVAR(Iminus_l, bool)
-PERLVAR(Iminus_a, bool)
-PERLVAR(Iminus_F, bool)
-PERLVAR(Idoswitches, bool)
-PERLVAR(Iminus_E, bool)
+PERLVAR(I, minus_c, bool)
+PERLVAR(I, minus_n, bool)
+PERLVAR(I, minus_p, bool)
+PERLVAR(I, minus_l, bool)
+PERLVAR(I, minus_a, bool)
+PERLVAR(I, minus_F, bool)
+PERLVAR(I, doswitches, bool)
+PERLVAR(I, minus_E, bool)
-/*
+PERLVAR(I, inplace, char *)
+PERLVAR(I, e_script, SV *)
-=for apidoc mn|bool|PL_dowarn
+PERLVAR(I, basetime, Time_t) /* $^T */
-The C variable which corresponds to Perl's $^W warning variable.
-
-=cut
-*/
-
-PERLVAR(Idowarn, U8)
- /* Space for a U8 */
-PERLVAR(Isawampersand, bool) /* must save all match strings */
-PERLVAR(Iunsafe, bool)
-PERLVAR(Iexit_flags, U8) /* was exit() unexpected, etc. */
-PERLVAR(Isrand_called, bool)
-/* Part of internal state, but makes the 16th 1 byte variable in a row. */
-PERLVAR(Itainting, bool) /* doing taint checks */
-PERLVARI(Iin_load_module, bool, FALSE) /* to prevent recursions in PerlIO_find_layer */
-PERLVAR(Iinplace, char *)
-PERLVAR(Ie_script, SV *)
-
-/* magical thingies */
-PERLVAR(Ibasetime, Time_t) /* $^T */
-PERLVAR(Iformfeed, SV *) /* $^L */
-
-
-PERLVARI(Imaxsysfd, I32, MAXSYSFD)
+PERLVARI(I, maxsysfd, I32, MAXSYSFD)
/* top fd to pass to subprocesses */
-PERLVAR(Istatusvalue, I32) /* $? */
+PERLVAR(I, statusvalue, I32) /* $? */
#ifdef VMS
-PERLVAR(Istatusvalue_vms,U32)
+PERLVAR(I, statusvalue_vms, U32)
#else
-PERLVAR(Istatusvalue_posix,I32)
+PERLVAR(I, statusvalue_posix, I32)
#endif
-PERLVARI(Isig_pending, int,0) /* Number if highest signal pending */
-PERLVAR(Ipsig_pend, int *) /* per-signal "count" of pending */
+PERLVARI(I, sig_pending, int, 0) /* Number if highest signal pending */
+PERLVAR(I, psig_pend, int *) /* per-signal "count" of pending */
/* shortcuts to various I/O objects */
-PERLVAR(Istdingv, GV *) /* *STDIN */
-PERLVAR(Istderrgv, GV *) /* *STDERR */
-PERLVAR(Idefgv, GV *)
-PERLVAR(Iargvgv, GV *) /* *ARGV */
-PERLVAR(Iargvoutgv, GV *) /* *ARGVOUT */
-PERLVAR(Iargvout_stack, AV *)
+PERLVAR(I, stdingv, GV *) /* *STDIN */
+PERLVAR(I, stderrgv, GV *) /* *STDERR */
+PERLVAR(I, defgv, GV *)
+PERLVAR(I, argvgv, GV *) /* *ARGV */
+PERLVAR(I, argvoutgv, GV *) /* *ARGVOUT */
+PERLVAR(I, argvout_stack, AV *)
/* shortcuts to regexp stuff */
-PERLVAR(Ireplgv, GV *) /* *^R */
+PERLVAR(I, replgv, GV *) /* *^R */
/* shortcuts to misc objects */
-PERLVAR(Ierrgv, GV *) /* *@ */
+PERLVAR(I, errgv, GV *) /* *@ */
/* shortcuts to debugging objects */
-PERLVAR(IDBgv, GV *) /* *DB::DB */
-PERLVAR(IDBline, GV *) /* *DB::line */
+PERLVAR(I, DBgv, GV *) /* *DB::DB */
+PERLVAR(I, DBline, GV *) /* *DB::line */
/*
=for apidoc mn|GV *|PL_DBsub
@@ -365,71 +389,68 @@
=cut
*/
-PERLVAR(IDBsub, GV *) /* *DB::sub */
-PERLVAR(IDBsingle, SV *) /* $DB::single */
-PERLVAR(IDBtrace, SV *) /* $DB::trace */
-PERLVAR(IDBsignal, SV *) /* $DB::signal */
-PERLVAR(Idbargs, AV *) /* args to call listed by caller function */
+PERLVAR(I, DBsub, GV *) /* *DB::sub */
+PERLVAR(I, DBsingle, SV *) /* $DB::single */
+PERLVAR(I, DBtrace, SV *) /* $DB::trace */
+PERLVAR(I, DBsignal, SV *) /* $DB::signal */
+PERLVAR(I, dbargs, AV *) /* args to call listed by caller function */
/* symbol tables */
-PERLVAR(Idebstash, HV *) /* symbol table for perldb package */
-PERLVAR(Iglobalstash, HV *) /* global keyword overrides imported here */
-PERLVAR(Icurstname, SV *) /* name of current package */
-PERLVAR(Ibeginav, AV *) /* names of BEGIN subroutines */
-PERLVAR(Iendav, AV *) /* names of END subroutines */
-PERLVAR(Iunitcheckav, AV *) /* names of UNITCHECK subroutines */
-PERLVAR(Icheckav, AV *) /* names of CHECK subroutines */
-PERLVAR(Iinitav, AV *) /* names of INIT subroutines */
-PERLVAR(Istrtab, HV *) /* shared string table */
-PERLVARI(Isub_generation,U32,1) /* incr to invalidate method cache */
+PERLVAR(I, debstash, HV *) /* symbol table for perldb package */
+PERLVAR(I, globalstash, HV *) /* global keyword overrides imported here */
+PERLVAR(I, curstname, SV *) /* name of current package */
+PERLVAR(I, beginav, AV *) /* names of BEGIN subroutines */
+PERLVAR(I, endav, AV *) /* names of END subroutines */
+PERLVAR(I, unitcheckav, AV *) /* names of UNITCHECK subroutines */
+PERLVAR(I, checkav, AV *) /* names of CHECK subroutines */
+PERLVAR(I, initav, AV *) /* names of INIT subroutines */
-/* funky return mechanisms */
-PERLVAR(Iforkprocess, int) /* so do_open |- can return proc# */
-
-/* memory management */
-PERLVAR(Isv_count, I32) /* how many SV* are currently allocated */
-PERLVAR(Isv_objcount, I32) /* how many objects are currently allocated */
-PERLVAR(Isv_root, SV*) /* storage for SVs belonging to interp */
-PERLVAR(Isv_arenaroot, SV*) /* list of areas for garbage collection */
-
/* subprocess state */
-PERLVAR(Ifdpid, AV *) /* keep fd-to-pid mappings for my_popen */
+PERLVAR(I, fdpid, AV *) /* keep fd-to-pid mappings for my_popen */
/* internal state */
-PERLVARI(Iop_mask, char *, NULL) /* masked operations for safe evals */
+PERLVARI(I, op_mask, char *, NULL) /* masked operations for safe evals */
/* current interpreter roots */
-PERLVAR(Imain_cv, CV *)
-PERLVAR(Imain_root, OP *)
-PERLVAR(Imain_start, OP *)
-PERLVAR(Ieval_root, OP *)
-PERLVAR(Ieval_start, OP *)
+PERLVAR(I, main_cv, CV *)
+PERLVAR(I, main_root, OP *)
+PERLVAR(I, main_start, OP *)
+PERLVAR(I, eval_root, OP *)
+PERLVAR(I, eval_start, OP *)
/* runtime control stuff */
-PERLVARI(Icurcopdb, COP *, NULL)
+PERLVARI(I, curcopdb, COP *, NULL)
-PERLVAR(Ifilemode, int) /* so nextargv() can preserve mode */
-PERLVAR(Ilastfd, int) /* what to preserve mode on */
-PERLVAR(Ioldname, char *) /* what to preserve mode on */
-PERLVAR(IArgv, const char **) /* stuff to free from do_aexec, vfork safe */
-PERLVAR(ICmd, char *) /* stuff to free from do_aexec, vfork safe */
+PERLVAR(I, filemode, int) /* so nextargv() can preserve mode */
+PERLVAR(I, lastfd, int) /* what to preserve mode on */
+PERLVAR(I, oldname, char *) /* what to preserve mode on */
+PERLVAR(I, Argv, const char **) /* stuff to free from do_aexec, vfork safe */
+PERLVAR(I, Cmd, char *) /* stuff to free from do_aexec, vfork safe */
/* Elements in this array have ';' appended and are injected as a single line
into the tokeniser. You can't put any (literal) newlines into any program
you stuff in into this array, as the point where it's injected is expecting
a single physical line. */
-PERLVAR(Ipreambleav, AV *)
-PERLVAR(Imess_sv, SV *)
-PERLVAR(Iors_sv, SV *) /* output record separator $\ */
+PERLVAR(I, preambleav, AV *)
+PERLVAR(I, mess_sv, SV *)
+PERLVAR(I, ors_sv, SV *) /* output record separator $\ */
+
+/* funky return mechanisms */
+PERLVAR(I, forkprocess, int) /* so do_open |- can return proc# */
+
/* statics moved here for shared library purposes */
-PERLVARI(Igensym, I32, 0) /* next symbol for getsym() to define */
-PERLVARI(Icv_has_eval, bool, FALSE) /* PL_compcv includes an entereval or similar */
-PERLVAR(Itaint_warn, bool) /* taint warns instead of dying */
-PERLVARI(Ilaststype, U16, OP_STAT)
-PERLVARI(Ilaststatval, int, -1)
+PERLVARI(I, gensym, I32, 0) /* next symbol for getsym() to define */
+PERLVARI(I, cv_has_eval, bool, FALSE) /* PL_compcv includes an entereval or similar */
+PERLVAR(I, taint_warn, bool) /* taint warns instead of dying */
+PERLVARI(I, laststype, U16, OP_STAT)
+PERLVARI(I, laststatval, int, -1)
+
+PERLVAR(I, modcount, I32) /* how much op_lvalue()ification in
+ assignment? */
+
/* interpreter atexit processing */
-PERLVARI(Iexitlistlen, I32, 0) /* length of same */
-PERLVARI(Iexitlist, PerlExitListEntry *, NULL)
+PERLVARI(I, exitlistlen, I32, 0) /* length of same */
+PERLVARI(I, exitlist, PerlExitListEntry *, NULL)
/* list of exit functions */
/*
@@ -444,39 +465,44 @@
=cut
*/
-PERLVAR(Imodglobal, HV *) /* per-interp module data */
+PERLVAR(I, modglobal, HV *) /* per-interp module data */
/* these used to be in global before 5.004_68 */
-PERLVARI(Iprofiledata, U32 *, NULL) /* table of ops, counts */
+PERLVARI(I, profiledata, U32 *, NULL) /* table of ops, counts */
-PERLVAR(Icompiling, COP) /* compiling/done executing marker */
+PERLVAR(I, compiling, COP) /* compiling/done executing marker */
-PERLVAR(Icompcv, CV *) /* currently compiling subroutine */
-PERLVAR(Icomppad, AV *) /* storage for lexically scoped temporaries */
-PERLVAR(Icomppad_name, AV *) /* variable names for "my" variables */
-PERLVAR(Icomppad_name_fill, I32) /* last "introduced" variable offset */
-PERLVAR(Icomppad_name_floor, I32) /* start of vars in innermost block */
+PERLVAR(I, compcv, CV *) /* currently compiling subroutine */
+PERLVAR(I, comppad_name, PADNAMELIST *) /* variable names for "my" variables */
+PERLVAR(I, comppad_name_fill, I32) /* last "introduced" variable offset */
+PERLVAR(I, comppad_name_floor, I32) /* start of vars in innermost block */
#ifdef HAVE_INTERP_INTERN
-PERLVAR(Isys_intern, struct interp_intern)
+PERLVAR(I, sys_intern, struct interp_intern)
/* platform internals */
#endif
/* more statics moved here */
-PERLVAR(IDBcv, CV *) /* from perl.c */
-PERLVARI(Igeneration, int, 100) /* from op.c */
+PERLVAR(I, DBcv, CV *) /* from perl.c */
+PERLVARI(I, generation, int, 100) /* from op.c */
-PERLVARI(Iin_clean_objs,bool, FALSE) /* from sv.c */
-PERLVARI(Iin_clean_all, bool, FALSE) /* ptrs to freed SVs now legal */
-PERLVAR(Inomemok, bool) /* let malloc context handle nomem */
-PERLVARI(Isavebegin, bool, FALSE) /* save BEGINs for compiler */
+PERLVAR(I, unicode, U32) /* Unicode features: $ENV{PERL_UNICODE} or -C */
-PERLVAR(Iuid, Uid_t) /* current real user id */
-PERLVAR(Ieuid, Uid_t) /* current effective user id */
-PERLVAR(Igid, Gid_t) /* current real group id */
-PERLVAR(Iegid, Gid_t) /* current effective group id */
-PERLVARI(Ian, U32, 0) /* malloc sequence number */
+PERLVARI(I, in_clean_objs,bool, FALSE) /* from sv.c */
+PERLVARI(I, in_clean_all, bool, FALSE) /* ptrs to freed SVs now legal */
+PERLVAR(I, nomemok, bool) /* let malloc context handle nomem */
+PERLVARI(I, savebegin, bool, FALSE) /* save BEGINs for compiler */
+
+PERLVAR(I, delaymagic_uid, Uid_t) /* current real user id, only for delaymagic */
+PERLVAR(I, delaymagic_euid, Uid_t) /* current effective user id, only for delaymagic */
+PERLVAR(I, delaymagic_gid, Gid_t) /* current real group id, only for delaymagic */
+PERLVAR(I, delaymagic_egid, Gid_t) /* current effective group id, only for delaymagic */
+PERLVARI(I, an, U32, 0) /* malloc sequence number */
+
+/* Perl_Ibreakable_sub_generation_ptr was too long for VMS, hence "gen" */
+PERLVARI(I, breakable_sub_gen, U32, 0)
+
#ifdef DEBUGGING
/* exercise wrap-around */
#define PERL_COP_SEQMAX (U32_MAX-50)
@@ -483,221 +509,189 @@
#else
#define PERL_COP_SEQMAX 0
#endif
-PERLVARI(Icop_seqmax, U32, PERL_COP_SEQMAX) /* statement sequence number */
+PERLVARI(I, cop_seqmax, U32, PERL_COP_SEQMAX) /* statement sequence number */
#undef PERL_COP_SEQMAX
-PERLVARI(Ievalseq, U32, 0) /* eval sequence number */
-PERLVAR(Iorigalen, U32)
-PERLVAR(Iorigenviron, char **)
+PERLVARI(I, evalseq, U32, 0) /* eval sequence number */
+PERLVAR(I, origalen, U32)
+PERLVAR(I, origenviron, char **)
#ifdef PERL_USES_PL_PIDSTATUS
-PERLVAR(Ipidstatus, HV *) /* pid-to-status mappings for waitpid */
+PERLVAR(I, pidstatus, HV *) /* pid-to-status mappings for waitpid */
#endif
-PERLVAR(Iosname, char *) /* operating system */
+PERLVAR(I, osname, char *) /* operating system */
-PERLVAR(Isighandlerp, Sighandler_t)
+PERLVAR(I, sighandlerp, Sighandler_t)
-PERLVARA(Ibody_roots, PERL_ARENA_ROOTS_SIZE, void*) /* array of body roots */
+PERLVARA(I, body_roots, PERL_ARENA_ROOTS_SIZE, void*) /* array of body roots */
-PERLVAR(Iunicode, U32) /* Unicode features: $ENV{PERL_UNICODE} or -C */
+PERLVAR(I, debug, VOL U32) /* flags given to -D switch */
-PERLVARI(Imaxo, int, MAXO) /* maximum number of ops */
+PERLVARI(I, maxo, int, MAXO) /* maximum number of ops */
-PERLVARI(Irunops, runops_proc_t, RUNOPS_DEFAULT)
+PERLVARI(I, runops, runops_proc_t, RUNOPS_DEFAULT)
-/*
-=for apidoc Amn|SV|PL_sv_undef
-This is the C<undef> SV. Always refer to this as C<&PL_sv_undef>.
+PERLVAR(I, subname, SV *) /* name of current subroutine */
-=for apidoc Amn|SV|PL_sv_no
-This is the C<false> SV. See C<PL_sv_yes>. Always refer to this as
-C<&PL_sv_no>.
+PERLVAR(I, subline, I32) /* line this subroutine began on */
+PERLVAR(I, min_intro_pending, I32) /* start of vars to introduce */
-=for apidoc Amn|SV|PL_sv_yes
-This is the C<true> SV. See C<PL_sv_no>. Always refer to this as
-C<&PL_sv_yes>.
+PERLVAR(I, max_intro_pending, I32) /* end of vars to introduce */
+PERLVAR(I, padix, I32) /* max used index in current "register" pad */
-=cut
-*/
+PERLVAR(I, padix_floor, I32) /* how low may inner block reset padix */
-PERLVAR(Isv_undef, SV)
-PERLVAR(Isv_no, SV)
-PERLVAR(Isv_yes, SV)
+PERLVAR(I, hints, U32) /* pragma-tic compile-time flags */
-PERLVAR(Isubname, SV *) /* name of current subroutine */
-
-PERLVAR(Isubline, I32) /* line this subroutine began on */
-PERLVAR(Imin_intro_pending, I32) /* start of vars to introduce */
-
-PERLVAR(Imax_intro_pending, I32) /* end of vars to introduce */
-PERLVAR(Ipadix, I32) /* max used index in current "register" pad */
-
-PERLVAR(Ipadix_floor, I32) /* how low may inner block reset padix */
-
-PERLVAR(Ihints, U32) /* pragma-tic compile-time flags */
-
-PERLVAR(Idebug, VOL U32) /* flags given to -D switch */
-
-/* Perl_Ibreakable_sub_generation_ptr was too long for VMS, hence "gen" */
-PERLVARI(Ibreakable_sub_gen, U32, 0)
-
-PERLVARI(Iamagic_generation, long, 0)
-
#ifdef USE_LOCALE_COLLATE
-PERLVAR(Icollation_name,char *) /* Name of current collation */
-PERLVAR(Icollxfrm_base, Size_t) /* Basic overhead in *xfrm() */
-PERLVARI(Icollxfrm_mult,Size_t, 2) /* Expansion factor in *xfrm() */
-PERLVARI(Icollation_ix, U32, 0) /* Collation generation index */
-PERLVARI(Icollation_standard, bool, TRUE)
+PERLVAR(I, collation_name, char *) /* Name of current collation */
+PERLVAR(I, collxfrm_base, Size_t) /* Basic overhead in *xfrm() */
+PERLVARI(I, collxfrm_mult,Size_t, 2) /* Expansion factor in *xfrm() */
+PERLVARI(I, collation_ix, U32, 0) /* Collation generation index */
+PERLVARI(I, collation_standard, bool, TRUE)
/* Assume simple collation */
#endif /* USE_LOCALE_COLLATE */
-
-#if defined (PERL_UTF8_CACHE_ASSERT) || defined (DEBUGGING)
-# define PERL___I -1
-#else
-# define PERL___I 1
+#ifdef PERL_SAWAMPERSAND
+PERLVAR(I, sawampersand, U8) /* must save all match strings */
#endif
-PERLVARI(Iutf8cache, I8, PERL___I) /* Is the utf8 caching code enabled? */
-#undef PERL___I
+PERLVAR(I, unsafe, bool)
+PERLVAR(I, colorset, bool) /* from regcomp.c */
+/* current phase the interpreter is in
+ for ordering this structure to remove holes, we're assuming that this is 4
+ bytes. */
+PERLVARI(I, phase, enum perl_phase, PERL_PHASE_CONSTRUCT)
+
+PERLVARI(I, in_load_module, bool, FALSE) /* to prevent recursions in PerlIO_find_layer */
+
+/* This value may be set when embedding for full cleanup */
+/* 0=none, 1=full, 2=full with checks */
+/* mod_perl is special, and also assigns a meaning -1 */
+PERLVARI(I, perl_destruct_level, signed char, 0)
+
#ifdef USE_LOCALE_NUMERIC
-PERLVARI(Inumeric_standard, bool, TRUE)
+PERLVARI(I, numeric_standard, bool, TRUE)
/* Assume simple numerics */
-PERLVARI(Inumeric_local, bool, TRUE)
+PERLVARI(I, numeric_local, bool, TRUE)
/* Assume local numerics */
-PERLVAR(Inumeric_name, char *) /* Name of current numeric locale */
+PERLVAR(I, numeric_name, char *) /* Name of current numeric locale */
+PERLVAR(I, numeric_radix_sv, SV *) /* The radix separator if not '.' */
+
#endif /* !USE_LOCALE_NUMERIC */
-/* utf8 character classes */
-PERLVAR(Iutf8_alnum, SV *)
-PERLVAR(Iutf8_ascii, SV *)
-PERLVAR(Iutf8_alpha, SV *)
-PERLVAR(Iutf8_space, SV *)
-PERLVAR(Iutf8_perl_space, SV *)
-PERLVAR(Iutf8_perl_word, SV *)
-PERLVAR(Iutf8_posix_digit, SV *)
-PERLVAR(Iutf8_cntrl, SV *)
-PERLVAR(Iutf8_graph, SV *)
-PERLVAR(Iutf8_digit, SV *)
-PERLVAR(Iutf8_upper, SV *)
-PERLVAR(Iutf8_lower, SV *)
-PERLVAR(Iutf8_print, SV *)
-PERLVAR(Iutf8_punct, SV *)
-PERLVAR(Iutf8_xdigit, SV *)
-PERLVAR(Iutf8_mark, SV *)
-PERLVAR(Iutf8_X_begin, SV *)
-PERLVAR(Iutf8_X_extend, SV *)
-PERLVAR(Iutf8_X_prepend, SV *)
-PERLVAR(Iutf8_X_non_hangul, SV *)
-PERLVAR(Iutf8_X_L, SV *)
-PERLVAR(Iutf8_X_LV, SV *)
-PERLVAR(Iutf8_X_LVT, SV *)
-PERLVAR(Iutf8_X_T, SV *)
-PERLVAR(Iutf8_X_V, SV *)
-PERLVAR(Iutf8_X_LV_LVT_V, SV *)
-PERLVAR(Iutf8_toupper, SV *)
-PERLVAR(Iutf8_totitle, SV *)
-PERLVAR(Iutf8_tolower, SV *)
-PERLVAR(Iutf8_tofold, SV *)
-PERLVAR(Ilast_swash_hv, HV *)
-PERLVAR(Ilast_swash_tmps, U8 *)
-PERLVAR(Ilast_swash_slen, STRLEN)
-PERLVARA(Ilast_swash_key,10, U8)
-PERLVAR(Ilast_swash_klen, U8) /* Only needs to store 0-10 */
+/* Unicode inversion lists */
+PERLVAR(I, ASCII, SV *)
+PERLVAR(I, Latin1, SV *)
+PERLVAR(I, AboveLatin1, SV *)
-#ifdef FCRYPT
-PERLVARI(Icryptseen, bool, FALSE) /* has fast crypt() been initialized? */
-#endif
+PERLVAR(I, NonL1NonFinalFold, SV *)
+PERLVAR(I, HasMultiCharFold, SV *)
-PERLVAR(Ipad_reset_pending, bool) /* reset pad on next attempted alloc */
+/* utf8 character class swashes */
+PERLVAR(I, utf8_mark, SV *)
+PERLVAR(I, utf8_X_regular_begin, SV *)
+PERLVAR(I, utf8_X_extend, SV *)
+PERLVAR(I, utf8_toupper, SV *)
+PERLVAR(I, utf8_totitle, SV *)
+PERLVAR(I, utf8_tolower, SV *)
+PERLVAR(I, utf8_tofold, SV *)
+PERLVAR(I, utf8_charname_begin, SV *)
+PERLVAR(I, utf8_charname_continue, SV *)
-PERLVARI(Iglob_index, int, 0)
+PERLVARA(I, utf8_swash_ptrs, POSIX_SWASH_COUNT, SV *)
+PERLVARA(I, Posix_ptrs, POSIX_CC_COUNT, SV *)
+PERLVARA(I, L1Posix_ptrs, POSIX_CC_COUNT, SV *)
+PERLVARA(I, XPosix_ptrs, POSIX_CC_COUNT, SV *)
+PERLVAR(I, last_swash_hv, HV *)
+PERLVAR(I, last_swash_tmps, U8 *)
+PERLVAR(I, last_swash_slen, STRLEN)
+PERLVARA(I, last_swash_key,UTF8_MAXBYTES-1, U8)
+PERLVAR(I, last_swash_klen, U8) /* Only needs to store 0-12 */
-PERLVAR(Iparser, yy_parser *) /* current parser state */
+#ifdef FCRYPT
+PERLVARI(I, cryptseen, bool, FALSE) /* has fast crypt() been initialized? */
+#else
+/* One byte hole in the interpreter structure. */
+#endif
+PERLVAR(I, pad_reset_pending, bool) /* reset pad on next attempted alloc */
+PERLVAR(I, srand_called, bool)
+
/* Array of signal handlers, indexed by signal number, through which the C
signal handler dispatches. */
-PERLVAR(Ipsig_ptr, SV**)
+PERLVAR(I, psig_ptr, SV **)
/* Array of names of signals, indexed by signal number, for (re)use as the first
argument to a signal handler. Only one block of memory is allocated for
both psig_name and psig_ptr. */
-PERLVAR(Ipsig_name, SV**)
+PERLVAR(I, psig_name, SV **)
#if defined(PERL_IMPLICIT_SYS)
-PERLVAR(IMem, struct IPerlMem*)
-PERLVAR(IMemShared, struct IPerlMem*)
-PERLVAR(IMemParse, struct IPerlMem*)
-PERLVAR(IEnv, struct IPerlEnv*)
-PERLVAR(IStdIO, struct IPerlStdIO*)
-PERLVAR(ILIO, struct IPerlLIO*)
-PERLVAR(IDir, struct IPerlDir*)
-PERLVAR(ISock, struct IPerlSock*)
-PERLVAR(IProc, struct IPerlProc*)
+PERLVAR(I, Mem, struct IPerlMem *)
+PERLVAR(I, MemShared, struct IPerlMem *)
+PERLVAR(I, MemParse, struct IPerlMem *)
+PERLVAR(I, Env, struct IPerlEnv *)
+PERLVAR(I, StdIO, struct IPerlStdIO *)
+PERLVAR(I, LIO, struct IPerlLIO *)
+PERLVAR(I, Dir, struct IPerlDir *)
+PERLVAR(I, Sock, struct IPerlSock *)
+PERLVAR(I, Proc, struct IPerlProc *)
#endif
-PERLVAR(Iptr_table, PTR_TBL_t*)
-PERLVARI(Ibeginav_save, AV*, NULL) /* save BEGIN{}s when compiling */
+PERLVAR(I, ptr_table, PTR_TBL_t *)
+PERLVARI(I, beginav_save, AV *, NULL) /* save BEGIN{}s when compiling */
-PERLVAR(Ibody_arenas, void*) /* pointer to list of body-arenas */
+PERLVAR(I, body_arenas, void *) /* pointer to list of body-arenas */
-#ifdef USE_LOCALE_NUMERIC
-
-PERLVAR(Inumeric_radix_sv, SV *) /* The radix separator if not '.' */
-
-#endif
-
#if defined(USE_ITHREADS)
-PERLVAR(Iregex_pad, SV**) /* Shortcut into the array of
+PERLVAR(I, regex_pad, SV **) /* Shortcut into the array of
regex_padav */
-PERLVAR(Iregex_padav, AV*) /* All regex objects, indexed via the
+PERLVAR(I, regex_padav, AV *) /* All regex objects, indexed via the
values in op_pmoffset of pmop.
Entry 0 is an SV whose PV is a
"packed" list of IVs listing
the now-free slots in the array */
+PERLVAR(I, stashpad, HV **) /* for CopSTASH */
+PERLVARI(I, stashpadmax, PADOFFSET, 64)
+PERLVARI(I, stashpadix, PADOFFSET, 0)
#endif
#ifdef USE_REENTRANT_API
-PERLVAR(Ireentrant_buffer, REENTR*) /* here we store the _r buffers */
+PERLVAR(I, reentrant_buffer, REENTR *) /* here we store the _r buffers */
#endif
-PERLVAR(Icustom_op_names, HV*) /* Names of user defined ops */
-PERLVAR(Icustom_op_descs, HV*) /* Descriptions of user defined ops */
+PERLVAR(I, custom_op_names, HV *) /* Names of user defined ops */
+PERLVAR(I, custom_op_descs, HV *) /* Descriptions of user defined ops */
#ifdef PERLIO_LAYERS
-PERLVARI(Iperlio, PerlIOl *,NULL)
-PERLVARI(Iknown_layers, PerlIO_list_t *,NULL)
-PERLVARI(Idef_layerlist, PerlIO_list_t *,NULL)
+PERLVARI(I, perlio, PerlIOl *, NULL)
+PERLVARI(I, known_layers, PerlIO_list_t *, NULL)
+PERLVARI(I, def_layerlist, PerlIO_list_t *, NULL)
#endif
-PERLVARI(Iencoding, SV*, NULL) /* character encoding */
+PERLVARI(I, encoding, SV *, NULL) /* character encoding */
-PERLVAR(Idebug_pad, struct perl_debug_pad) /* always needed because of the re extension */
+PERLVAR(I, utf8_idstart, SV *)
+PERLVAR(I, utf8_idcont, SV *)
+PERLVAR(I, utf8_xidstart, SV *)
+PERLVAR(I, utf8_perl_idstart, SV *)
+PERLVAR(I, utf8_perl_idcont, SV *)
+PERLVAR(I, utf8_xidcont, SV *)
-PERLVAR(Iutf8_idstart, SV *)
-PERLVAR(Iutf8_idcont, SV *)
-PERLVAR(Iutf8_xidstart, SV *)
-PERLVAR(Iutf8_xidcont, SV *)
+PERLVAR(I, sort_RealCmp, SVCOMPARE_t)
-PERLVAR(Isort_RealCmp, SVCOMPARE_t)
+PERLVARI(I, checkav_save, AV *, NULL) /* save CHECK{}s when compiling */
+PERLVARI(I, unitcheckav_save, AV *, NULL)
+ /* save UNITCHECK{}s when compiling */
-PERLVARI(Icheckav_save, AV*, NULL) /* save CHECK{}s when compiling */
-PERLVARI(Iunitcheckav_save, AV*, NULL) /* save UNITCHECK{}s when compiling */
+PERLVARI(I, clocktick, long, 0) /* this many times() ticks in a second */
-PERLVARI(Iclocktick, long, 0) /* this many times() ticks in a second */
-
-PERLVAR(Isignals, U32) /* Using which pre-5.8 signals */
-
-PERLVAR(Ireentrant_retint, int) /* Integer return value from reentrant functions */
-
-PERLVAR(Istashcache, HV *) /* Cache to speed up S_method_common */
-
/* Hooks to shared SVs and locks. */
-PERLVARI(Isharehook, share_proc_t, Perl_sv_nosharing)
-PERLVARI(Ilockhook, share_proc_t, Perl_sv_nosharing)
+PERLVARI(I, sharehook, share_proc_t, Perl_sv_nosharing)
+PERLVARI(I, lockhook, share_proc_t, Perl_sv_nosharing)
#ifdef NO_MATHOMS
# define PERL_UNLOCK_HOOK Perl_sv_nosharing
#else
@@ -704,93 +698,83 @@
/* This reference ensures that the mathoms are linked with perl */
# define PERL_UNLOCK_HOOK Perl_sv_nounlocking
#endif
-PERLVARI(Iunlockhook, share_proc_t, PERL_UNLOCK_HOOK)
+PERLVARI(I, unlockhook, share_proc_t, PERL_UNLOCK_HOOK)
-PERLVARI(Ithreadhook, thrhook_proc_t, Perl_nothreadhook)
+PERLVARI(I, threadhook, thrhook_proc_t, Perl_nothreadhook)
+/* Can shared object be destroyed */
+PERLVARI(I, destroyhook, destroyable_proc_t, Perl_sv_destroyable)
+
#ifndef PERL_MICRO
-PERLVARI(Isignalhook, despatch_signals_proc_t, Perl_despatch_signals)
+PERLVARI(I, signalhook, despatch_signals_proc_t, Perl_despatch_signals)
#endif
-PERLVARI(Ihash_seed, UV, 0) /* Hash initializer */
+PERLVARI(I, isarev, HV *, NULL) /* Reverse map of @ISA dependencies */
-PERLVARI(Irehash_seed, UV, 0) /* 582 hash initializer */
+/* Register of known Method Resolution Orders.
+ What this actually points to is an implementation detail (it may change to
+ a structure incorporating a reference count - use mro_get_from_name to
+ retrieve a C<struct mro_alg *> */
+PERLVAR(I, registered_mros, HV *)
-PERLVARI(Iisarev, HV*, NULL) /* Reverse map of @ISA dependencies */
+/* Compile-time block start/end hooks */
+PERLVAR(I, blockhooks, AV *)
-/* The last unconditional member of the interpreter structure when 5.10.0 was
+/* Everything that folds to a given character, for case insensitivity regex
+ * matching */
+PERLVARI(I, utf8_foldclosures, HV *, NULL)
+
+/* List of characters that participate in folds (except marks, etc in
+ * multi-char folds) */
+PERLVARI(I, utf8_foldable, SV *, NULL)
+
+PERLVAR(I, custom_ops, HV *) /* custom op registrations */
+
+PERLVAR(I, Xpv, XPV *) /* (unused) held temporary value */
+
+/* name of the scopes we've ENTERed. Only used with -DDEBUGGING, but needs to be
+ present always, as -DDEBUGGING must be binary compatible with non. */
+PERLVARI(I, scopestack_name, const char * *, NULL)
+
+PERLVAR(I, debug_pad, struct perl_debug_pad) /* always needed because of the re extension */
+
+/* Hook for File::Glob */
+PERLVARI(I, globhook, globhook_t, NULL)
+
+/* The last unconditional member of the interpreter structure when 5.18.1 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. */
-#define PERL_LAST_5_10_0_INTERP_MEMBER Iisarev
+#define PERL_LAST_5_18_0_INTERP_MEMBER Iglobhook
#ifdef PERL_IMPLICIT_CONTEXT
-PERLVARI(Imy_cxt_size, int, 0) /* size of PL_my_cxt_list */
-PERLVARI(Imy_cxt_list, void **, NULL) /* per-module array of MY_CXT pointers */
+PERLVARI(I, my_cxt_list, void **, NULL) /* per-module array of MY_CXT pointers */
+PERLVARI(I, my_cxt_size, int, 0) /* size of PL_my_cxt_list */
# ifdef PERL_GLOBAL_STRUCT_PRIVATE
-PERLVARI(Imy_cxt_keys, const char **, NULL) /* per-module array of pointers to MY_CXT_KEY constants */
+PERLVARI(I, my_cxt_keys, const char **, NULL) /* per-module array of pointers to MY_CXT_KEY constants */
# endif
#endif
#ifdef PERL_TRACK_MEMPOOL
/* For use with the memory debugging code in util.c */
-PERLVAR(Imemory_debug_header, struct perl_memory_debug_header)
+PERLVAR(I, memory_debug_header, struct perl_memory_debug_header)
#endif
#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
/* File descriptor to talk to the child which dumps scalars. */
-PERLVARI(Idumper_fd, int, -1)
+PERLVARI(I, dumper_fd, int, -1)
#endif
-/* Stores the PPID */
-#ifdef THREADS_HAVE_PIDS
-PERLVARI(Ippid, IV, 0)
-#endif
-
#ifdef PERL_MAD
-PERLVARI(Imadskills, bool, FALSE) /* preserve all syntactic info */
+PERLVARI(I, madskills, bool, FALSE) /* preserve all syntactic info */
/* (MAD = Misc Attribute Decoration) */
-PERLVARI(Ixmlfp, PerlIO *,NULL)
+PERLVARI(I, xmlfp, PerlIO *, NULL)
#endif
-#ifdef PL_OP_SLAB_ALLOC
-PERLVAR(IOpPtr,I32 **)
-PERLVARI(IOpSpace,I32,0)
-PERLVAR(IOpSlab,I32 *)
-#endif
-
-#ifdef PERL_DEBUG_READONLY_OPS
-PERLVARI(Islabs, I32**, NULL) /* Array of slabs that have been allocated */
-PERLVARI(Islab_count, U32, 0) /* Size of the array */
-#endif
-
-/* Can shared object be destroyed */
-PERLVARI(Idestroyhook, destroyable_proc_t, Perl_sv_destroyable)
-
#ifdef DEBUG_LEAKING_SCALARS
-PERLVARI(Isv_serial, U32, 0) /* SV serial number, used in sv.c */
+PERLVARI(I, sv_serial, U32, 0) /* SV serial number, used in sv.c */
#endif
-/* Register of known Method Resolution Orders.
- What this actually points to is an implementation detail (it may change to
- a structure incorporating a reference count - use mro_get_from_name to
- retrieve a C<struct mro_alg *> */
-PERLVAR(Iregistered_mros, HV *)
-
-/* Compile-time block start/end hooks */
-PERLVAR(Iblockhooks, AV *)
-
-
-/* Everything that folds to a given character, for case insensitivity regex
- * matching */
-PERLVARI(Iutf8_foldclosures, HV *, NULL)
-
-/* List of characters that participate in folds (except marks, etc in
- * multi-char folds) */
-PERLVARI(Iutf8_foldable, HV *, NULL)
-
-PERLVAR(Icustom_ops, HV *) /* custom op registrations */
-
/* If you are adding a U8 or U16, check to see if there are 'Space' comments
* above on where there are gaps which currently will be structure padding. */
Property changes on: trunk/contrib/perl/intrpvar.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/iperlsys.h
===================================================================
--- trunk/contrib/perl/iperlsys.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/iperlsys.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -1416,8 +1416,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/iperlsys.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/keywords.c
===================================================================
--- trunk/contrib/perl/keywords.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/keywords.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -8,6 +8,7 @@
#define PERL_IN_KEYWORDS_C
#include "perl.h"
#include "keywords.h"
+#include "feature.h"
I32
Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
@@ -50,7 +51,7 @@
goto unknown;
}
- case 2: /* 18 tokens of length 2 */
+ case 2: /* 19 tokens of length 2 */
switch (name[0])
{
case 'd':
@@ -69,6 +70,14 @@
goto unknown;
+ case 'f':
+ if (name[1] == 'c')
+ { /* fc */
+ return (all_keywords || FEATURE_FC_IS_ENABLED ? -KEY_fc : 0);
+ }
+
+ goto unknown;
+
case 'g':
switch (name[1])
{
@@ -416,7 +425,7 @@
case 'a':
if (name[2] == 'y')
{ /* say */
- return (all_keywords || FEATURE_IS_ENABLED("say") ? KEY_say : 0);
+ return (all_keywords || FEATURE_SAY_IS_ENABLED ? KEY_say : 0);
}
goto unknown;
@@ -940,7 +949,7 @@
if (name[2] == 'e' &&
name[3] == 'n')
{ /* when */
- return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_when : 0);
+ return (all_keywords || FEATURE_SWITCH_IS_ENABLED ? KEY_when : 0);
}
goto unknown;
@@ -1023,7 +1032,7 @@
name[3] == 'a' &&
name[4] == 'k')
{ /* break */
- return (all_keywords || FEATURE_IS_ENABLED("switch") ? -KEY_break : 0);
+ return (all_keywords || FEATURE_SWITCH_IS_ENABLED ? -KEY_break : 0);
}
goto unknown;
@@ -1151,7 +1160,7 @@
name[3] == 'e' &&
name[4] == 'n')
{ /* given */
- return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_given : 0);
+ return (all_keywords || FEATURE_SWITCH_IS_ENABLED ? KEY_given : 0);
}
goto unknown;
@@ -1319,7 +1328,7 @@
if (name[3] == 't' &&
name[4] == 'e')
{ /* state */
- return (all_keywords || FEATURE_IS_ENABLED("state") ? KEY_state : 0);
+ return (all_keywords || FEATURE_STATE_IS_ENABLED ? KEY_state : 0);
}
goto unknown;
@@ -1906,7 +1915,7 @@
goto unknown;
}
- case 7: /* 29 tokens of length 7 */
+ case 7: /* 30 tokens of length 7 */
switch (name[0])
{
case 'D':
@@ -1923,14 +1932,35 @@
goto unknown;
case '_':
- if (name[1] == '_' &&
- name[2] == 'E' &&
- name[3] == 'N' &&
- name[4] == 'D' &&
- name[5] == '_' &&
- name[6] == '_')
- { /* __END__ */
- return KEY___END__;
+ if (name[1] == '_')
+ {
+ switch (name[2])
+ {
+ case 'E':
+ if (name[3] == 'N' &&
+ name[4] == 'D' &&
+ name[5] == '_' &&
+ name[6] == '_')
+ { /* __END__ */
+ return KEY___END__;
+ }
+
+ goto unknown;
+
+ case 'S':
+ if (name[3] == 'U' &&
+ name[4] == 'B' &&
+ name[5] == '_' &&
+ name[6] == '_')
+ { /* __SUB__ */
+ return (all_keywords || FEATURE___SUB___IS_ENABLED ? -KEY___SUB__ : 0);
+ }
+
+ goto unknown;
+
+ default:
+ goto unknown;
+ }
}
goto unknown;
@@ -1986,7 +2016,7 @@
name[5] == 'l' &&
name[6] == 't')
{ /* default */
- return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_default : 0);
+ return (all_keywords || FEATURE_SWITCH_IS_ENABLED ? KEY_default : 0);
}
goto unknown;
@@ -2740,7 +2770,7 @@
goto unknown;
}
- case 9: /* 9 tokens of length 9 */
+ case 9: /* 10 tokens of length 9 */
switch (name[0])
{
case 'U':
@@ -2759,20 +2789,40 @@
goto unknown;
case 'e':
- if (name[1] == 'n' &&
- name[2] == 'd' &&
- name[3] == 'n' &&
- name[4] == 'e' &&
- name[5] == 't' &&
- name[6] == 'e' &&
- name[7] == 'n' &&
- name[8] == 't')
- { /* endnetent */
- return -KEY_endnetent;
+ switch (name[1])
+ {
+ case 'n':
+ if (name[2] == 'd' &&
+ name[3] == 'n' &&
+ name[4] == 'e' &&
+ name[5] == 't' &&
+ name[6] == 'e' &&
+ name[7] == 'n' &&
+ name[8] == 't')
+ { /* endnetent */
+ return -KEY_endnetent;
+ }
+
+ goto unknown;
+
+ case 'v':
+ if (name[2] == 'a' &&
+ name[3] == 'l' &&
+ name[4] == 'b' &&
+ name[5] == 'y' &&
+ name[6] == 't' &&
+ name[7] == 'e' &&
+ name[8] == 's')
+ { /* evalbytes */
+ return (all_keywords || FEATURE_EVALBYTES_IS_ENABLED ? -KEY_evalbytes : 0);
+ }
+
+ goto unknown;
+
+ default:
+ goto unknown;
}
- goto unknown;
-
case 'g':
if (name[1] == 'e' &&
name[2] == 't' &&
@@ -3399,5 +3449,5 @@
}
/* Generated from:
- * 28d95638560707fb8bee100dab74c90107c3e000f635e3bd310d4e2501d3b073 regen/keywords.pl
+ * e5a540774760ea54c761ef17ee4a153cc264e9a700b817d561e390730c457406 regen/keywords.pl
* ex: set ro: */
Property changes on: trunk/contrib/perl/keywords.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/keywords.h
===================================================================
--- trunk/contrib/perl/keywords.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/keywords.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -19,254 +19,257 @@
#define KEY___PACKAGE__ 3
#define KEY___DATA__ 4
#define KEY___END__ 5
-#define KEY_AUTOLOAD 6
-#define KEY_BEGIN 7
-#define KEY_UNITCHECK 8
-#define KEY_CORE 9
-#define KEY_DESTROY 10
-#define KEY_END 11
-#define KEY_INIT 12
-#define KEY_CHECK 13
-#define KEY_abs 14
-#define KEY_accept 15
-#define KEY_alarm 16
-#define KEY_and 17
-#define KEY_atan2 18
-#define KEY_bind 19
-#define KEY_binmode 20
-#define KEY_bless 21
-#define KEY_break 22
-#define KEY_caller 23
-#define KEY_chdir 24
-#define KEY_chmod 25
-#define KEY_chomp 26
-#define KEY_chop 27
-#define KEY_chown 28
-#define KEY_chr 29
-#define KEY_chroot 30
-#define KEY_close 31
-#define KEY_closedir 32
-#define KEY_cmp 33
-#define KEY_connect 34
-#define KEY_continue 35
-#define KEY_cos 36
-#define KEY_crypt 37
-#define KEY_dbmclose 38
-#define KEY_dbmopen 39
-#define KEY_default 40
-#define KEY_defined 41
-#define KEY_delete 42
-#define KEY_die 43
-#define KEY_do 44
-#define KEY_dump 45
-#define KEY_each 46
-#define KEY_else 47
-#define KEY_elsif 48
-#define KEY_endgrent 49
-#define KEY_endhostent 50
-#define KEY_endnetent 51
-#define KEY_endprotoent 52
-#define KEY_endpwent 53
-#define KEY_endservent 54
-#define KEY_eof 55
-#define KEY_eq 56
-#define KEY_eval 57
-#define KEY_exec 58
-#define KEY_exists 59
-#define KEY_exit 60
-#define KEY_exp 61
-#define KEY_fcntl 62
-#define KEY_fileno 63
-#define KEY_flock 64
-#define KEY_for 65
-#define KEY_foreach 66
-#define KEY_fork 67
-#define KEY_format 68
-#define KEY_formline 69
-#define KEY_ge 70
-#define KEY_getc 71
-#define KEY_getgrent 72
-#define KEY_getgrgid 73
-#define KEY_getgrnam 74
-#define KEY_gethostbyaddr 75
-#define KEY_gethostbyname 76
-#define KEY_gethostent 77
-#define KEY_getlogin 78
-#define KEY_getnetbyaddr 79
-#define KEY_getnetbyname 80
-#define KEY_getnetent 81
-#define KEY_getpeername 82
-#define KEY_getpgrp 83
-#define KEY_getppid 84
-#define KEY_getpriority 85
-#define KEY_getprotobyname 86
-#define KEY_getprotobynumber 87
-#define KEY_getprotoent 88
-#define KEY_getpwent 89
-#define KEY_getpwnam 90
-#define KEY_getpwuid 91
-#define KEY_getservbyname 92
-#define KEY_getservbyport 93
-#define KEY_getservent 94
-#define KEY_getsockname 95
-#define KEY_getsockopt 96
-#define KEY_given 97
-#define KEY_glob 98
-#define KEY_gmtime 99
-#define KEY_goto 100
-#define KEY_grep 101
-#define KEY_gt 102
-#define KEY_hex 103
-#define KEY_if 104
-#define KEY_index 105
-#define KEY_int 106
-#define KEY_ioctl 107
-#define KEY_join 108
-#define KEY_keys 109
-#define KEY_kill 110
-#define KEY_last 111
-#define KEY_lc 112
-#define KEY_lcfirst 113
-#define KEY_le 114
-#define KEY_length 115
-#define KEY_link 116
-#define KEY_listen 117
-#define KEY_local 118
-#define KEY_localtime 119
-#define KEY_lock 120
-#define KEY_log 121
-#define KEY_lstat 122
-#define KEY_lt 123
-#define KEY_m 124
-#define KEY_map 125
-#define KEY_mkdir 126
-#define KEY_msgctl 127
-#define KEY_msgget 128
-#define KEY_msgrcv 129
-#define KEY_msgsnd 130
-#define KEY_my 131
-#define KEY_ne 132
-#define KEY_next 133
-#define KEY_no 134
-#define KEY_not 135
-#define KEY_oct 136
-#define KEY_open 137
-#define KEY_opendir 138
-#define KEY_or 139
-#define KEY_ord 140
-#define KEY_our 141
-#define KEY_pack 142
-#define KEY_package 143
-#define KEY_pipe 144
-#define KEY_pop 145
-#define KEY_pos 146
-#define KEY_print 147
-#define KEY_printf 148
-#define KEY_prototype 149
-#define KEY_push 150
-#define KEY_q 151
-#define KEY_qq 152
-#define KEY_qr 153
-#define KEY_quotemeta 154
-#define KEY_qw 155
-#define KEY_qx 156
-#define KEY_rand 157
-#define KEY_read 158
-#define KEY_readdir 159
-#define KEY_readline 160
-#define KEY_readlink 161
-#define KEY_readpipe 162
-#define KEY_recv 163
-#define KEY_redo 164
-#define KEY_ref 165
-#define KEY_rename 166
-#define KEY_require 167
-#define KEY_reset 168
-#define KEY_return 169
-#define KEY_reverse 170
-#define KEY_rewinddir 171
-#define KEY_rindex 172
-#define KEY_rmdir 173
-#define KEY_s 174
-#define KEY_say 175
-#define KEY_scalar 176
-#define KEY_seek 177
-#define KEY_seekdir 178
-#define KEY_select 179
-#define KEY_semctl 180
-#define KEY_semget 181
-#define KEY_semop 182
-#define KEY_send 183
-#define KEY_setgrent 184
-#define KEY_sethostent 185
-#define KEY_setnetent 186
-#define KEY_setpgrp 187
-#define KEY_setpriority 188
-#define KEY_setprotoent 189
-#define KEY_setpwent 190
-#define KEY_setservent 191
-#define KEY_setsockopt 192
-#define KEY_shift 193
-#define KEY_shmctl 194
-#define KEY_shmget 195
-#define KEY_shmread 196
-#define KEY_shmwrite 197
-#define KEY_shutdown 198
-#define KEY_sin 199
-#define KEY_sleep 200
-#define KEY_socket 201
-#define KEY_socketpair 202
-#define KEY_sort 203
-#define KEY_splice 204
-#define KEY_split 205
-#define KEY_sprintf 206
-#define KEY_sqrt 207
-#define KEY_srand 208
-#define KEY_stat 209
-#define KEY_state 210
-#define KEY_study 211
-#define KEY_sub 212
-#define KEY_substr 213
-#define KEY_symlink 214
-#define KEY_syscall 215
-#define KEY_sysopen 216
-#define KEY_sysread 217
-#define KEY_sysseek 218
-#define KEY_system 219
-#define KEY_syswrite 220
-#define KEY_tell 221
-#define KEY_telldir 222
-#define KEY_tie 223
-#define KEY_tied 224
-#define KEY_time 225
-#define KEY_times 226
-#define KEY_tr 227
-#define KEY_truncate 228
-#define KEY_uc 229
-#define KEY_ucfirst 230
-#define KEY_umask 231
-#define KEY_undef 232
-#define KEY_unless 233
-#define KEY_unlink 234
-#define KEY_unpack 235
-#define KEY_unshift 236
-#define KEY_untie 237
-#define KEY_until 238
-#define KEY_use 239
-#define KEY_utime 240
-#define KEY_values 241
-#define KEY_vec 242
-#define KEY_wait 243
-#define KEY_waitpid 244
-#define KEY_wantarray 245
-#define KEY_warn 246
-#define KEY_when 247
-#define KEY_while 248
-#define KEY_write 249
-#define KEY_x 250
-#define KEY_xor 251
-#define KEY_y 252
+#define KEY___SUB__ 6
+#define KEY_AUTOLOAD 7
+#define KEY_BEGIN 8
+#define KEY_UNITCHECK 9
+#define KEY_CORE 10
+#define KEY_DESTROY 11
+#define KEY_END 12
+#define KEY_INIT 13
+#define KEY_CHECK 14
+#define KEY_abs 15
+#define KEY_accept 16
+#define KEY_alarm 17
+#define KEY_and 18
+#define KEY_atan2 19
+#define KEY_bind 20
+#define KEY_binmode 21
+#define KEY_bless 22
+#define KEY_break 23
+#define KEY_caller 24
+#define KEY_chdir 25
+#define KEY_chmod 26
+#define KEY_chomp 27
+#define KEY_chop 28
+#define KEY_chown 29
+#define KEY_chr 30
+#define KEY_chroot 31
+#define KEY_close 32
+#define KEY_closedir 33
+#define KEY_cmp 34
+#define KEY_connect 35
+#define KEY_continue 36
+#define KEY_cos 37
+#define KEY_crypt 38
+#define KEY_dbmclose 39
+#define KEY_dbmopen 40
+#define KEY_default 41
+#define KEY_defined 42
+#define KEY_delete 43
+#define KEY_die 44
+#define KEY_do 45
+#define KEY_dump 46
+#define KEY_each 47
+#define KEY_else 48
+#define KEY_elsif 49
+#define KEY_endgrent 50
+#define KEY_endhostent 51
+#define KEY_endnetent 52
+#define KEY_endprotoent 53
+#define KEY_endpwent 54
+#define KEY_endservent 55
+#define KEY_eof 56
+#define KEY_eq 57
+#define KEY_eval 58
+#define KEY_evalbytes 59
+#define KEY_exec 60
+#define KEY_exists 61
+#define KEY_exit 62
+#define KEY_exp 63
+#define KEY_fc 64
+#define KEY_fcntl 65
+#define KEY_fileno 66
+#define KEY_flock 67
+#define KEY_for 68
+#define KEY_foreach 69
+#define KEY_fork 70
+#define KEY_format 71
+#define KEY_formline 72
+#define KEY_ge 73
+#define KEY_getc 74
+#define KEY_getgrent 75
+#define KEY_getgrgid 76
+#define KEY_getgrnam 77
+#define KEY_gethostbyaddr 78
+#define KEY_gethostbyname 79
+#define KEY_gethostent 80
+#define KEY_getlogin 81
+#define KEY_getnetbyaddr 82
+#define KEY_getnetbyname 83
+#define KEY_getnetent 84
+#define KEY_getpeername 85
+#define KEY_getpgrp 86
+#define KEY_getppid 87
+#define KEY_getpriority 88
+#define KEY_getprotobyname 89
+#define KEY_getprotobynumber 90
+#define KEY_getprotoent 91
+#define KEY_getpwent 92
+#define KEY_getpwnam 93
+#define KEY_getpwuid 94
+#define KEY_getservbyname 95
+#define KEY_getservbyport 96
+#define KEY_getservent 97
+#define KEY_getsockname 98
+#define KEY_getsockopt 99
+#define KEY_given 100
+#define KEY_glob 101
+#define KEY_gmtime 102
+#define KEY_goto 103
+#define KEY_grep 104
+#define KEY_gt 105
+#define KEY_hex 106
+#define KEY_if 107
+#define KEY_index 108
+#define KEY_int 109
+#define KEY_ioctl 110
+#define KEY_join 111
+#define KEY_keys 112
+#define KEY_kill 113
+#define KEY_last 114
+#define KEY_lc 115
+#define KEY_lcfirst 116
+#define KEY_le 117
+#define KEY_length 118
+#define KEY_link 119
+#define KEY_listen 120
+#define KEY_local 121
+#define KEY_localtime 122
+#define KEY_lock 123
+#define KEY_log 124
+#define KEY_lstat 125
+#define KEY_lt 126
+#define KEY_m 127
+#define KEY_map 128
+#define KEY_mkdir 129
+#define KEY_msgctl 130
+#define KEY_msgget 131
+#define KEY_msgrcv 132
+#define KEY_msgsnd 133
+#define KEY_my 134
+#define KEY_ne 135
+#define KEY_next 136
+#define KEY_no 137
+#define KEY_not 138
+#define KEY_oct 139
+#define KEY_open 140
+#define KEY_opendir 141
+#define KEY_or 142
+#define KEY_ord 143
+#define KEY_our 144
+#define KEY_pack 145
+#define KEY_package 146
+#define KEY_pipe 147
+#define KEY_pop 148
+#define KEY_pos 149
+#define KEY_print 150
+#define KEY_printf 151
+#define KEY_prototype 152
+#define KEY_push 153
+#define KEY_q 154
+#define KEY_qq 155
+#define KEY_qr 156
+#define KEY_quotemeta 157
+#define KEY_qw 158
+#define KEY_qx 159
+#define KEY_rand 160
+#define KEY_read 161
+#define KEY_readdir 162
+#define KEY_readline 163
+#define KEY_readlink 164
+#define KEY_readpipe 165
+#define KEY_recv 166
+#define KEY_redo 167
+#define KEY_ref 168
+#define KEY_rename 169
+#define KEY_require 170
+#define KEY_reset 171
+#define KEY_return 172
+#define KEY_reverse 173
+#define KEY_rewinddir 174
+#define KEY_rindex 175
+#define KEY_rmdir 176
+#define KEY_s 177
+#define KEY_say 178
+#define KEY_scalar 179
+#define KEY_seek 180
+#define KEY_seekdir 181
+#define KEY_select 182
+#define KEY_semctl 183
+#define KEY_semget 184
+#define KEY_semop 185
+#define KEY_send 186
+#define KEY_setgrent 187
+#define KEY_sethostent 188
+#define KEY_setnetent 189
+#define KEY_setpgrp 190
+#define KEY_setpriority 191
+#define KEY_setprotoent 192
+#define KEY_setpwent 193
+#define KEY_setservent 194
+#define KEY_setsockopt 195
+#define KEY_shift 196
+#define KEY_shmctl 197
+#define KEY_shmget 198
+#define KEY_shmread 199
+#define KEY_shmwrite 200
+#define KEY_shutdown 201
+#define KEY_sin 202
+#define KEY_sleep 203
+#define KEY_socket 204
+#define KEY_socketpair 205
+#define KEY_sort 206
+#define KEY_splice 207
+#define KEY_split 208
+#define KEY_sprintf 209
+#define KEY_sqrt 210
+#define KEY_srand 211
+#define KEY_stat 212
+#define KEY_state 213
+#define KEY_study 214
+#define KEY_sub 215
+#define KEY_substr 216
+#define KEY_symlink 217
+#define KEY_syscall 218
+#define KEY_sysopen 219
+#define KEY_sysread 220
+#define KEY_sysseek 221
+#define KEY_system 222
+#define KEY_syswrite 223
+#define KEY_tell 224
+#define KEY_telldir 225
+#define KEY_tie 226
+#define KEY_tied 227
+#define KEY_time 228
+#define KEY_times 229
+#define KEY_tr 230
+#define KEY_truncate 231
+#define KEY_uc 232
+#define KEY_ucfirst 233
+#define KEY_umask 234
+#define KEY_undef 235
+#define KEY_unless 236
+#define KEY_unlink 237
+#define KEY_unpack 238
+#define KEY_unshift 239
+#define KEY_untie 240
+#define KEY_until 241
+#define KEY_use 242
+#define KEY_utime 243
+#define KEY_values 244
+#define KEY_vec 245
+#define KEY_wait 246
+#define KEY_waitpid 247
+#define KEY_wantarray 248
+#define KEY_warn 249
+#define KEY_when 250
+#define KEY_while 251
+#define KEY_write 252
+#define KEY_x 253
+#define KEY_xor 254
+#define KEY_y 255
/* Generated from:
- * 28d95638560707fb8bee100dab74c90107c3e000f635e3bd310d4e2501d3b073 regen/keywords.pl
+ * e5a540774760ea54c761ef17ee4a153cc264e9a700b817d561e390730c457406 regen/keywords.pl
* ex: set ro: */
Property changes on: trunk/contrib/perl/keywords.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/l1_char_class_tab.h
===================================================================
--- trunk/contrib/perl/l1_char_class_tab.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/l1_char_class_tab.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -1,265 +1,264 @@
/* -*- buffer-read-only: t -*-
* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
- * This file is built by regen/mk_PL_charclass.pl from
- * lib/unicore/CaseFolding.txt.
+ * This file is built by regen/mk_PL_charclass.pl from property definitions.
* Any changes made here will be lost!
*/
-/* U+00 NUL */ _CC_CNTRL_A|_CC_CNTRL_L1,
-/* U+01 SOH */ _CC_CNTRL_A|_CC_CNTRL_L1,
-/* U+02 STX */ _CC_CNTRL_A|_CC_CNTRL_L1,
-/* U+03 ETX */ _CC_CNTRL_A|_CC_CNTRL_L1,
-/* U+04 EOT */ _CC_CNTRL_A|_CC_CNTRL_L1,
-/* U+05 ENQ */ _CC_CNTRL_A|_CC_CNTRL_L1,
-/* U+06 ACK */ _CC_CNTRL_A|_CC_CNTRL_L1,
-/* U+07 BEL */ _CC_CNTRL_A|_CC_CNTRL_L1,
-/* U+08 BS */ _CC_CNTRL_A|_CC_CNTRL_L1,
-/* U+09 HT */ _CC_BLANK_A|_CC_BLANK_L1|_CC_CNTRL_A|_CC_CNTRL_L1|_CC_PSXSPC_A|_CC_PSXSPC_L1|_CC_SPACE_A|_CC_SPACE_L1,
-/* U+0A LF */ _CC_CNTRL_A|_CC_CNTRL_L1|_CC_PSXSPC_A|_CC_PSXSPC_L1|_CC_SPACE_A|_CC_SPACE_L1,
-/* U+0B VT */ _CC_CNTRL_A|_CC_CNTRL_L1|_CC_PSXSPC_A|_CC_PSXSPC_L1,
-/* U+0C FF */ _CC_CNTRL_A|_CC_CNTRL_L1|_CC_PSXSPC_A|_CC_PSXSPC_L1|_CC_SPACE_A|_CC_SPACE_L1,
-/* U+0D CR */ _CC_CNTRL_A|_CC_CNTRL_L1|_CC_PSXSPC_A|_CC_PSXSPC_L1|_CC_SPACE_A|_CC_SPACE_L1,
-/* U+0E SO */ _CC_CNTRL_A|_CC_CNTRL_L1,
-/* U+0F SI */ _CC_CNTRL_A|_CC_CNTRL_L1,
-/* U+10 DLE */ _CC_CNTRL_A|_CC_CNTRL_L1,
-/* U+11 DC1 */ _CC_CNTRL_A|_CC_CNTRL_L1,
-/* U+12 DC2 */ _CC_CNTRL_A|_CC_CNTRL_L1,
-/* U+13 DC3 */ _CC_CNTRL_A|_CC_CNTRL_L1,
-/* U+14 DC4 */ _CC_CNTRL_A|_CC_CNTRL_L1,
-/* U+15 NAK */ _CC_CNTRL_A|_CC_CNTRL_L1,
-/* U+16 SYN */ _CC_CNTRL_A|_CC_CNTRL_L1,
-/* U+17 ETB */ _CC_CNTRL_A|_CC_CNTRL_L1,
-/* U+18 CAN */ _CC_CNTRL_A|_CC_CNTRL_L1,
-/* U+19 EOM */ _CC_CNTRL_A|_CC_CNTRL_L1,
-/* U+1A SUB */ _CC_CNTRL_A|_CC_CNTRL_L1,
-/* U+1B ESC */ _CC_CNTRL_A|_CC_CNTRL_L1,
-/* U+1C FS */ _CC_CNTRL_A|_CC_CNTRL_L1,
-/* U+1D GS */ _CC_CNTRL_A|_CC_CNTRL_L1,
-/* U+1E RS */ _CC_CNTRL_A|_CC_CNTRL_L1,
-/* U+1F US */ _CC_CNTRL_A|_CC_CNTRL_L1,
-/* U+20 SPACE */ _CC_BLANK_A|_CC_BLANK_L1|_CC_CHARNAME_CONT|_CC_PRINT_A|_CC_PRINT_L1|_CC_PSXSPC_A|_CC_PSXSPC_L1|_CC_SPACE_A|_CC_SPACE_L1,
-/* U+21 '!' */ _CC_GRAPH_A|_CC_GRAPH_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_PUNCT_A|_CC_PUNCT_L1,
-/* U+22 '"' */ _CC_GRAPH_A|_CC_GRAPH_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_PUNCT_A|_CC_PUNCT_L1,
-/* U+23 '#' */ _CC_GRAPH_A|_CC_GRAPH_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_PUNCT_A|_CC_PUNCT_L1,
-/* U+24 '$' */ _CC_GRAPH_A|_CC_GRAPH_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_PUNCT_A|_CC_PUNCT_L1,
-/* U+25 '%' */ _CC_GRAPH_A|_CC_GRAPH_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_PUNCT_A|_CC_PUNCT_L1,
-/* U+26 '&' */ _CC_GRAPH_A|_CC_GRAPH_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_PUNCT_A|_CC_PUNCT_L1,
-/* U+27 ''' */ _CC_GRAPH_A|_CC_GRAPH_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_PUNCT_A|_CC_PUNCT_L1,
-/* U+28 '(' */ _CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_PUNCT_A|_CC_PUNCT_L1,
-/* U+29 ')' */ _CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_PUNCT_A|_CC_PUNCT_L1,
-/* U+2A '*' */ _CC_GRAPH_A|_CC_GRAPH_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_PUNCT_A|_CC_PUNCT_L1,
-/* U+2B '+' */ _CC_GRAPH_A|_CC_GRAPH_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_PUNCT_A|_CC_PUNCT_L1,
-/* U+2C ',' */ _CC_GRAPH_A|_CC_GRAPH_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_PUNCT_A|_CC_PUNCT_L1,
-/* U+2D '-' */ _CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_PUNCT_A|_CC_PUNCT_L1,
-/* U+2E '.' */ _CC_GRAPH_A|_CC_GRAPH_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_PUNCT_A|_CC_PUNCT_L1,
-/* U+2F '/' */ _CC_GRAPH_A|_CC_GRAPH_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_PUNCT_A|_CC_PUNCT_L1,
-/* U+30 '0' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_CHARNAME_CONT|_CC_DIGIT_A|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_OCTAL_A|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1|_CC_XDIGIT_A,
-/* U+31 '1' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_CHARNAME_CONT|_CC_DIGIT_A|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_OCTAL_A|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1|_CC_XDIGIT_A,
-/* U+32 '2' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_CHARNAME_CONT|_CC_DIGIT_A|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_OCTAL_A|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1|_CC_XDIGIT_A,
-/* U+33 '3' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_CHARNAME_CONT|_CC_DIGIT_A|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_OCTAL_A|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1|_CC_XDIGIT_A,
-/* U+34 '4' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_CHARNAME_CONT|_CC_DIGIT_A|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_OCTAL_A|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1|_CC_XDIGIT_A,
-/* U+35 '5' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_CHARNAME_CONT|_CC_DIGIT_A|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_OCTAL_A|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1|_CC_XDIGIT_A,
-/* U+36 '6' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_CHARNAME_CONT|_CC_DIGIT_A|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_OCTAL_A|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1|_CC_XDIGIT_A,
-/* U+37 '7' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_CHARNAME_CONT|_CC_DIGIT_A|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_OCTAL_A|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1|_CC_XDIGIT_A,
-/* U+38 '8' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_CHARNAME_CONT|_CC_DIGIT_A|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1|_CC_XDIGIT_A,
-/* U+39 '9' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_CHARNAME_CONT|_CC_DIGIT_A|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1|_CC_XDIGIT_A,
-/* U+3A ':' */ _CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_PUNCT_A|_CC_PUNCT_L1,
-/* U+3B ';' */ _CC_GRAPH_A|_CC_GRAPH_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_PUNCT_A|_CC_PUNCT_L1,
-/* U+3C '<' */ _CC_GRAPH_A|_CC_GRAPH_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_PUNCT_A|_CC_PUNCT_L1,
-/* U+3D '=' */ _CC_GRAPH_A|_CC_GRAPH_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_PUNCT_A|_CC_PUNCT_L1,
-/* U+3E '>' */ _CC_GRAPH_A|_CC_GRAPH_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_PUNCT_A|_CC_PUNCT_L1,
-/* U+3F '?' */ _CC_GRAPH_A|_CC_GRAPH_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_PUNCT_A|_CC_PUNCT_L1,
-/* U+40 '@' */ _CC_GRAPH_A|_CC_GRAPH_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_PUNCT_A|_CC_PUNCT_L1,
-/* U+41 'A' */ _CC_NONLATIN1_FOLD|_CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_UPPER_A|_CC_UPPER_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1|_CC_XDIGIT_A,
-/* U+42 'B' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_UPPER_A|_CC_UPPER_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1|_CC_XDIGIT_A,
-/* U+43 'C' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_UPPER_A|_CC_UPPER_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1|_CC_XDIGIT_A,
-/* U+44 'D' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_UPPER_A|_CC_UPPER_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1|_CC_XDIGIT_A,
-/* U+45 'E' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_UPPER_A|_CC_UPPER_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1|_CC_XDIGIT_A,
-/* U+46 'F' */ _CC_NONLATIN1_FOLD|_CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_UPPER_A|_CC_UPPER_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1|_CC_XDIGIT_A,
-/* U+47 'G' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_UPPER_A|_CC_UPPER_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+48 'H' */ _CC_NONLATIN1_FOLD|_CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_UPPER_A|_CC_UPPER_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+49 'I' */ _CC_NONLATIN1_FOLD|_CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_UPPER_A|_CC_UPPER_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+4A 'J' */ _CC_NONLATIN1_FOLD|_CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_UPPER_A|_CC_UPPER_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+4B 'K' */ _CC_NONLATIN1_FOLD|_CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_UPPER_A|_CC_UPPER_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+4C 'L' */ _CC_NONLATIN1_FOLD|_CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_UPPER_A|_CC_UPPER_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+4D 'M' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_UPPER_A|_CC_UPPER_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+4E 'N' */ _CC_NONLATIN1_FOLD|_CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_UPPER_A|_CC_UPPER_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+4F 'O' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_UPPER_A|_CC_UPPER_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+50 'P' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_UPPER_A|_CC_UPPER_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+51 'Q' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_UPPER_A|_CC_UPPER_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+52 'R' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_UPPER_A|_CC_UPPER_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+53 'S' */ _CC_NONLATIN1_FOLD|_CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_UPPER_A|_CC_UPPER_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+54 'T' */ _CC_NONLATIN1_FOLD|_CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_UPPER_A|_CC_UPPER_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+55 'U' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_UPPER_A|_CC_UPPER_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+56 'V' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_UPPER_A|_CC_UPPER_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+57 'W' */ _CC_NONLATIN1_FOLD|_CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_UPPER_A|_CC_UPPER_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+58 'X' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_UPPER_A|_CC_UPPER_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+59 'Y' */ _CC_NONLATIN1_FOLD|_CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_UPPER_A|_CC_UPPER_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+5A 'Z' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_UPPER_A|_CC_UPPER_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+5B '[' */ _CC_GRAPH_A|_CC_GRAPH_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_PUNCT_A|_CC_PUNCT_L1,
-/* U+5C '\' */ _CC_GRAPH_A|_CC_GRAPH_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_PUNCT_A|_CC_PUNCT_L1,
-/* U+5D ']' */ _CC_GRAPH_A|_CC_GRAPH_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_PUNCT_A|_CC_PUNCT_L1,
-/* U+5E '^' */ _CC_GRAPH_A|_CC_GRAPH_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_PUNCT_A|_CC_PUNCT_L1,
-/* U+5F '_' */ _CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_PUNCT_A|_CC_PUNCT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+60 '`' */ _CC_GRAPH_A|_CC_GRAPH_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_PUNCT_A|_CC_PUNCT_L1,
-/* U+61 'a' */ _CC_NONLATIN1_FOLD|_CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_LOWER_A|_CC_LOWER_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1|_CC_XDIGIT_A,
-/* U+62 'b' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_LOWER_A|_CC_LOWER_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1|_CC_XDIGIT_A,
-/* U+63 'c' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_LOWER_A|_CC_LOWER_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1|_CC_XDIGIT_A,
-/* U+64 'd' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_LOWER_A|_CC_LOWER_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1|_CC_XDIGIT_A,
-/* U+65 'e' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_LOWER_A|_CC_LOWER_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1|_CC_XDIGIT_A,
-/* U+66 'f' */ _CC_NONLATIN1_FOLD|_CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_LOWER_A|_CC_LOWER_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1|_CC_XDIGIT_A,
-/* U+67 'g' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_LOWER_A|_CC_LOWER_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+68 'h' */ _CC_NONLATIN1_FOLD|_CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_LOWER_A|_CC_LOWER_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+69 'i' */ _CC_NONLATIN1_FOLD|_CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_LOWER_A|_CC_LOWER_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+6A 'j' */ _CC_NONLATIN1_FOLD|_CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_LOWER_A|_CC_LOWER_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+6B 'k' */ _CC_NONLATIN1_FOLD|_CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_LOWER_A|_CC_LOWER_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+6C 'l' */ _CC_NONLATIN1_FOLD|_CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_LOWER_A|_CC_LOWER_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+6D 'm' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_LOWER_A|_CC_LOWER_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+6E 'n' */ _CC_NONLATIN1_FOLD|_CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_LOWER_A|_CC_LOWER_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+6F 'o' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_LOWER_A|_CC_LOWER_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+70 'p' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_LOWER_A|_CC_LOWER_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+71 'q' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_LOWER_A|_CC_LOWER_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+72 'r' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_LOWER_A|_CC_LOWER_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+73 's' */ _CC_NONLATIN1_FOLD|_CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_LOWER_A|_CC_LOWER_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+74 't' */ _CC_NONLATIN1_FOLD|_CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_LOWER_A|_CC_LOWER_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+75 'u' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_LOWER_A|_CC_LOWER_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+76 'v' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_LOWER_A|_CC_LOWER_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+77 'w' */ _CC_NONLATIN1_FOLD|_CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_LOWER_A|_CC_LOWER_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+78 'x' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_LOWER_A|_CC_LOWER_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+79 'y' */ _CC_NONLATIN1_FOLD|_CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_LOWER_A|_CC_LOWER_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+7A 'z' */ _CC_ALNUMC_A|_CC_ALNUMC_L1|_CC_ALPHA_A|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_A|_CC_GRAPH_L1|_CC_IDFIRST_A|_CC_IDFIRST_L1|_CC_LOWER_A|_CC_LOWER_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_WORDCHAR_A|_CC_WORDCHAR_L1,
-/* U+7B '{' */ _CC_GRAPH_A|_CC_GRAPH_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_PUNCT_A|_CC_PUNCT_L1,
-/* U+7C '|' */ _CC_GRAPH_A|_CC_GRAPH_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_PUNCT_A|_CC_PUNCT_L1,
-/* U+7D '}' */ _CC_GRAPH_A|_CC_GRAPH_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_PUNCT_A|_CC_PUNCT_L1,
-/* U+7E '~' */ _CC_GRAPH_A|_CC_GRAPH_L1|_CC_PRINT_A|_CC_PRINT_L1|_CC_PUNCT_A|_CC_PUNCT_L1,
-/* U+7F DEL */ _CC_CNTRL_A|_CC_CNTRL_L1,
-/* U+80 PAD */ _CC_CNTRL_L1,
-/* U+81 HOP */ _CC_CNTRL_L1,
-/* U+82 BPH */ _CC_CNTRL_L1,
-/* U+83 NBH */ _CC_CNTRL_L1,
-/* U+84 IND */ _CC_CNTRL_L1,
-/* U+85 NEL */ _CC_CNTRL_L1|_CC_PSXSPC_L1|_CC_SPACE_L1,
-/* U+86 SSA */ _CC_CNTRL_L1,
-/* U+87 ESA */ _CC_CNTRL_L1,
-/* U+88 HTS */ _CC_CNTRL_L1,
-/* U+89 HTJ */ _CC_CNTRL_L1,
-/* U+8A VTS */ _CC_CNTRL_L1,
-/* U+8B PLD */ _CC_CNTRL_L1,
-/* U+8C PLU */ _CC_CNTRL_L1,
-/* U+8D RI */ _CC_CNTRL_L1,
-/* U+8E SS2 */ _CC_CNTRL_L1,
-/* U+8F SS3 */ _CC_CNTRL_L1,
-/* U+90 DCS */ _CC_CNTRL_L1,
-/* U+91 PU1 */ _CC_CNTRL_L1,
-/* U+92 PU2 */ _CC_CNTRL_L1,
-/* U+93 STS */ _CC_CNTRL_L1,
-/* U+94 CCH */ _CC_CNTRL_L1,
-/* U+95 MW */ _CC_CNTRL_L1,
-/* U+96 SPA */ _CC_CNTRL_L1,
-/* U+97 EPA */ _CC_CNTRL_L1,
-/* U+98 SOS */ _CC_CNTRL_L1,
-/* U+99 SGC */ _CC_CNTRL_L1,
-/* U+9A SCI */ _CC_CNTRL_L1,
-/* U+9B CSI */ _CC_CNTRL_L1,
-/* U+9C ST */ _CC_CNTRL_L1,
-/* U+9D OSC */ _CC_CNTRL_L1,
-/* U+9E PM */ _CC_CNTRL_L1,
-/* U+9F APC */ _CC_CNTRL_L1,
-/* U+A0 NO-BREAK SPACE */ _CC_BLANK_L1|_CC_CHARNAME_CONT|_CC_PRINT_L1|_CC_PSXSPC_L1|_CC_SPACE_L1,
-/* U+A1 INVERTED EXCLAMATION MARK */ _CC_GRAPH_L1|_CC_PRINT_L1|_CC_PUNCT_L1,
-/* U+A2 CENT SIGN */ _CC_GRAPH_L1|_CC_PRINT_L1,
-/* U+A3 POUND SIGN */ _CC_GRAPH_L1|_CC_PRINT_L1,
-/* U+A4 CURRENCY SIGN */ _CC_GRAPH_L1|_CC_PRINT_L1,
-/* U+A5 YEN SIGN */ _CC_GRAPH_L1|_CC_PRINT_L1,
-/* U+A6 BROKEN BAR */ _CC_GRAPH_L1|_CC_PRINT_L1,
-/* U+A7 SECTION SIGN */ _CC_GRAPH_L1|_CC_PRINT_L1,
-/* U+A8 DIAERESIS */ _CC_GRAPH_L1|_CC_PRINT_L1,
-/* U+A9 COPYRIGHT SIGN */ _CC_GRAPH_L1|_CC_PRINT_L1,
-/* U+AA FEMININE ORDINAL INDICATOR */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+AB LEFT-POINTING DOUBLE ANGLE QUOTATION MARK */ _CC_GRAPH_L1|_CC_PRINT_L1|_CC_PUNCT_L1,
-/* U+AC NOT SIGN */ _CC_GRAPH_L1|_CC_PRINT_L1,
-/* U+AD SOFT HYPHEN */ _CC_GRAPH_L1|_CC_PRINT_L1,
-/* U+AE REGISTERED SIGN */ _CC_GRAPH_L1|_CC_PRINT_L1,
-/* U+AF MACRON */ _CC_GRAPH_L1|_CC_PRINT_L1,
-/* U+B0 DEGREE SIGN */ _CC_GRAPH_L1|_CC_PRINT_L1,
-/* U+B1 PLUS-MINUS SIGN */ _CC_GRAPH_L1|_CC_PRINT_L1,
-/* U+B2 SUPERSCRIPT TWO */ _CC_GRAPH_L1|_CC_PRINT_L1,
-/* U+B3 SUPERSCRIPT THREE */ _CC_GRAPH_L1|_CC_PRINT_L1,
-/* U+B4 ACUTE ACCENT */ _CC_GRAPH_L1|_CC_PRINT_L1,
-/* U+B5 MICRO SIGN */ _CC_NONLATIN1_FOLD|_CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+B6 PILCROW SIGN */ _CC_GRAPH_L1|_CC_PRINT_L1,
-/* U+B7 MIDDLE DOT */ _CC_GRAPH_L1|_CC_PRINT_L1|_CC_PUNCT_L1,
-/* U+B8 CEDILLA */ _CC_GRAPH_L1|_CC_PRINT_L1,
-/* U+B9 SUPERSCRIPT ONE */ _CC_GRAPH_L1|_CC_PRINT_L1,
-/* U+BA MASCULINE ORDINAL INDICATOR */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+BB RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK */ _CC_GRAPH_L1|_CC_PRINT_L1|_CC_PUNCT_L1,
-/* U+BC VULGAR FRACTION ONE QUARTER */ _CC_GRAPH_L1|_CC_PRINT_L1,
-/* U+BD VULGAR FRACTION ONE HALF */ _CC_GRAPH_L1|_CC_PRINT_L1,
-/* U+BE VULGAR FRACTION THREE QUARTERS */ _CC_GRAPH_L1|_CC_PRINT_L1,
-/* U+BF INVERTED QUESTION MARK */ _CC_GRAPH_L1|_CC_PRINT_L1|_CC_PUNCT_L1,
-/* U+C0 A WITH GRAVE */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_PRINT_L1|_CC_UPPER_L1|_CC_WORDCHAR_L1,
-/* U+C1 A WITH ACUTE */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_PRINT_L1|_CC_UPPER_L1|_CC_WORDCHAR_L1,
-/* U+C2 A WITH CIRCUMFLEX */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_PRINT_L1|_CC_UPPER_L1|_CC_WORDCHAR_L1,
-/* U+C3 A WITH TILDE */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_PRINT_L1|_CC_UPPER_L1|_CC_WORDCHAR_L1,
-/* U+C4 A WITH DIAERESIS */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_PRINT_L1|_CC_UPPER_L1|_CC_WORDCHAR_L1,
-/* U+C5 A WITH RING ABOVE */ _CC_NONLATIN1_FOLD|_CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_PRINT_L1|_CC_UPPER_L1|_CC_WORDCHAR_L1,
-/* U+C6 AE */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_PRINT_L1|_CC_UPPER_L1|_CC_WORDCHAR_L1,
-/* U+C7 C WITH CEDILLA */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_PRINT_L1|_CC_UPPER_L1|_CC_WORDCHAR_L1,
-/* U+C8 E WITH GRAVE */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_PRINT_L1|_CC_UPPER_L1|_CC_WORDCHAR_L1,
-/* U+C9 E WITH ACUTE */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_PRINT_L1|_CC_UPPER_L1|_CC_WORDCHAR_L1,
-/* U+CA E WITH CIRCUMFLEX */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_PRINT_L1|_CC_UPPER_L1|_CC_WORDCHAR_L1,
-/* U+CB E WITH DIAERESIS */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_PRINT_L1|_CC_UPPER_L1|_CC_WORDCHAR_L1,
-/* U+CC I WITH GRAVE */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_PRINT_L1|_CC_UPPER_L1|_CC_WORDCHAR_L1,
-/* U+CD I WITH ACUTE */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_PRINT_L1|_CC_UPPER_L1|_CC_WORDCHAR_L1,
-/* U+CE I WITH CIRCUMFLEX */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_PRINT_L1|_CC_UPPER_L1|_CC_WORDCHAR_L1,
-/* U+CF I WITH DIAERESIS */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_PRINT_L1|_CC_UPPER_L1|_CC_WORDCHAR_L1,
-/* U+D0 ETH */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_PRINT_L1|_CC_UPPER_L1|_CC_WORDCHAR_L1,
-/* U+D1 N WITH TILDE */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_PRINT_L1|_CC_UPPER_L1|_CC_WORDCHAR_L1,
-/* U+D2 O WITH GRAVE */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_PRINT_L1|_CC_UPPER_L1|_CC_WORDCHAR_L1,
-/* U+D3 O WITH ACUTE */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_PRINT_L1|_CC_UPPER_L1|_CC_WORDCHAR_L1,
-/* U+D4 O WITH CIRCUMFLEX */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_PRINT_L1|_CC_UPPER_L1|_CC_WORDCHAR_L1,
-/* U+D5 O WITH TILDE */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_PRINT_L1|_CC_UPPER_L1|_CC_WORDCHAR_L1,
-/* U+D6 O WITH DIAERESIS */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_PRINT_L1|_CC_UPPER_L1|_CC_WORDCHAR_L1,
-/* U+D7 MULTIPLICATION SIGN */ _CC_GRAPH_L1|_CC_PRINT_L1,
-/* U+D8 O WITH STROKE */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_PRINT_L1|_CC_UPPER_L1|_CC_WORDCHAR_L1,
-/* U+D9 U WITH GRAVE */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_PRINT_L1|_CC_UPPER_L1|_CC_WORDCHAR_L1,
-/* U+DA U WITH ACUTE */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_PRINT_L1|_CC_UPPER_L1|_CC_WORDCHAR_L1,
-/* U+DB U WITH CIRCUMFLEX */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_PRINT_L1|_CC_UPPER_L1|_CC_WORDCHAR_L1,
-/* U+DC U WITH DIAERESIS */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_PRINT_L1|_CC_UPPER_L1|_CC_WORDCHAR_L1,
-/* U+DD Y WITH ACUTE */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_PRINT_L1|_CC_UPPER_L1|_CC_WORDCHAR_L1,
-/* U+DE THORN */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_PRINT_L1|_CC_UPPER_L1|_CC_WORDCHAR_L1,
-/* U+DF sharp s */ _CC_NONLATIN1_FOLD|_CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+E0 a with grave */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+E1 a with acute */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+E2 a with circumflex */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+E3 a with tilde */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+E4 a with diaeresis */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+E5 a with ring above */ _CC_NONLATIN1_FOLD|_CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+E6 ae */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+E7 c with cedilla */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+E8 e with grave */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+E9 e with acute */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+EA e with circumflex */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+EB e with diaeresis */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+EC i with grave */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+ED i with acute */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+EE i with circumflex */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+EF i with diaeresis */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+F0 eth */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+F1 n with tilde */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+F2 o with grave */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+F3 o with acute */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+F4 o with circumflex */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+F5 o with tilde */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+F6 o with diaeresis */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+F7 DIVISION SIGN */ _CC_GRAPH_L1|_CC_PRINT_L1,
-/* U+F8 o with stroke */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+F9 u with grave */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+FA u with acute */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+FB u with circumflex */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+FC u with diaeresis */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+FD y with acute */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+FE thorn */ _CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
-/* U+FF y with diaeresis */ _CC_NONLATIN1_FOLD|_CC_ALNUMC_L1|_CC_ALPHA_L1|_CC_CHARNAME_CONT|_CC_GRAPH_L1|_CC_IDFIRST_L1|_CC_LOWER_L1|_CC_PRINT_L1|_CC_WORDCHAR_L1,
+/* U+00 NUL */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+01 SOH */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+02 STX */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+03 ETX */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+04 EOT */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+05 ENQ */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+06 ACK */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+07 BEL */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+08 BS */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+09 HT */ (1U<<_CC_ASCII)|(1U<<_CC_BLANK)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE),
+/* U+0A LF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE),
+/* U+0B VT */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE),
+/* U+0C FF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE),
+/* U+0D CR */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE),
+/* U+0E SO */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+0F SI */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+10 DLE */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+11 DC1 */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+12 DC2 */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+13 DC3 */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+14 DC4 */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+15 NAK */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+16 SYN */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+17 ETB */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+18 CAN */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+19 EOM */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+1A SUB */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+1B ESC */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+1C FS */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+1D GS */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+1E RS */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+1F US */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+20 SPACE */ (1U<<_CC_ASCII)|(1U<<_CC_BLANK)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_PRINT)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE),
+/* U+21 '!' */ (1U<<_CC_ASCII)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+22 '"' */ (1U<<_CC_ASCII)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+23 '#' */ (1U<<_CC_ASCII)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+24 '$' */ (1U<<_CC_ASCII)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+25 '%' */ (1U<<_CC_ASCII)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+26 '&' */ (1U<<_CC_ASCII)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+27 ''' */ (1U<<_CC_ASCII)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+28 '(' */ (1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+29 ')' */ (1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+2A '*' */ (1U<<_CC_ASCII)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+2B '+' */ (1U<<_CC_ASCII)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+2C ',' */ (1U<<_CC_ASCII)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+2D '-' */ (1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+2E '.' */ (1U<<_CC_ASCII)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+2F '/' */ (1U<<_CC_ASCII)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+30 '0' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* U+31 '1' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* U+32 '2' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* U+33 '3' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* U+34 '4' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* U+35 '5' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* U+36 '6' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* U+37 '7' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* U+38 '8' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* U+39 '9' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* U+3A ':' */ (1U<<_CC_ASCII)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+3B ';' */ (1U<<_CC_ASCII)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+3C '<' */ (1U<<_CC_ASCII)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+3D '=' */ (1U<<_CC_ASCII)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+3E '>' */ (1U<<_CC_ASCII)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+3F '?' */ (1U<<_CC_ASCII)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+40 '@' */ (1U<<_CC_ASCII)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+41 'A' */ (1U<<_CC_NONLATIN1_FOLD)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_NON_FINAL_FOLD)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+42 'B' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+43 'C' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+44 'D' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+45 'E' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+46 'F' */ (1U<<_CC_NONLATIN1_FOLD)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_NON_FINAL_FOLD)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+47 'G' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+48 'H' */ (1U<<_CC_NONLATIN1_FOLD)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_NON_FINAL_FOLD)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+49 'I' */ (1U<<_CC_NONLATIN1_FOLD)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_NON_FINAL_FOLD)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+4A 'J' */ (1U<<_CC_NONLATIN1_FOLD)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_NON_FINAL_FOLD)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+4B 'K' */ (1U<<_CC_NONLATIN1_FOLD)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+4C 'L' */ (1U<<_CC_NONLATIN1_FOLD)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+4D 'M' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+4E 'N' */ (1U<<_CC_NONLATIN1_FOLD)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD)|(1U<<_CC_BACKSLASH_FOO_LBRACE_IS_META),
+/* U+4F 'O' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+50 'P' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD)|(1U<<_CC_BACKSLASH_FOO_LBRACE_IS_META),
+/* U+51 'Q' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+52 'R' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+53 'S' */ (1U<<_CC_NONLATIN1_FOLD)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_NON_FINAL_FOLD)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+54 'T' */ (1U<<_CC_NONLATIN1_FOLD)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_NON_FINAL_FOLD)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+55 'U' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+56 'V' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+57 'W' */ (1U<<_CC_NONLATIN1_FOLD)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_NON_FINAL_FOLD)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+58 'X' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+59 'Y' */ (1U<<_CC_NONLATIN1_FOLD)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_NON_FINAL_FOLD)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+5A 'Z' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+5B '[' */ (1U<<_CC_ASCII)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+5C '\' */ (1U<<_CC_ASCII)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+5D ']' */ (1U<<_CC_ASCII)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+5E '^' */ (1U<<_CC_ASCII)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+5F '_' */ (1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_WORDCHAR),
+/* U+60 '`' */ (1U<<_CC_ASCII)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+61 'a' */ (1U<<_CC_NONLATIN1_FOLD)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_NON_FINAL_FOLD)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+62 'b' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+63 'c' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+64 'd' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+65 'e' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+66 'f' */ (1U<<_CC_NONLATIN1_FOLD)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_NON_FINAL_FOLD)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+67 'g' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD)|(1U<<_CC_BACKSLASH_FOO_LBRACE_IS_META),
+/* U+68 'h' */ (1U<<_CC_NONLATIN1_FOLD)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_NON_FINAL_FOLD)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+69 'i' */ (1U<<_CC_NONLATIN1_FOLD)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_NON_FINAL_FOLD)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+6A 'j' */ (1U<<_CC_NONLATIN1_FOLD)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_NON_FINAL_FOLD)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+6B 'k' */ (1U<<_CC_NONLATIN1_FOLD)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD)|(1U<<_CC_BACKSLASH_FOO_LBRACE_IS_META),
+/* U+6C 'l' */ (1U<<_CC_NONLATIN1_FOLD)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+6D 'm' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+6E 'n' */ (1U<<_CC_NONLATIN1_FOLD)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+6F 'o' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD)|(1U<<_CC_BACKSLASH_FOO_LBRACE_IS_META),
+/* U+70 'p' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD)|(1U<<_CC_BACKSLASH_FOO_LBRACE_IS_META),
+/* U+71 'q' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+72 'r' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+73 's' */ (1U<<_CC_NONLATIN1_FOLD)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_NON_FINAL_FOLD)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+74 't' */ (1U<<_CC_NONLATIN1_FOLD)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_NON_FINAL_FOLD)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+75 'u' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+76 'v' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+77 'w' */ (1U<<_CC_NONLATIN1_FOLD)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_NON_FINAL_FOLD)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+78 'x' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD)|(1U<<_CC_BACKSLASH_FOO_LBRACE_IS_META),
+/* U+79 'y' */ (1U<<_CC_NONLATIN1_FOLD)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_NON_FINAL_FOLD)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+7A 'z' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_ASCII)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+7B '{' */ (1U<<_CC_ASCII)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+7C '|' */ (1U<<_CC_ASCII)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+7D '}' */ (1U<<_CC_ASCII)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+7E '~' */ (1U<<_CC_ASCII)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+7F DEL */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+80 PAD */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+81 HOP */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+82 BPH */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+83 NBH */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+84 IND */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+85 NEL */ (1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE),
+/* U+86 SSA */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+87 ESA */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+88 HTS */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+89 HTJ */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+8A VTS */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+8B PLD */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+8C PLU */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+8D RI */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+8E SS2 */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+8F SS3 */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+90 DCS */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+91 PU1 */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+92 PU2 */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+93 STS */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+94 CCH */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+95 MW */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+96 SPA */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+97 EPA */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+98 SOS */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+99 SGC */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+9A SCI */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+9B CSI */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+9C ST */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+9D OSC */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+9E PM */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+9F APC */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+A0 NO-BREAK SPACE */ (1U<<_CC_BLANK)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_PRINT)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE),
+/* U+A1 INVERTED EXCLAMATION MARK */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+A2 CENT SIGN */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_QUOTEMETA),
+/* U+A3 POUND SIGN */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_QUOTEMETA),
+/* U+A4 CURRENCY SIGN */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_QUOTEMETA),
+/* U+A5 YEN SIGN */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_QUOTEMETA),
+/* U+A6 BROKEN BAR */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_QUOTEMETA),
+/* U+A7 SECTION SIGN */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+A8 DIAERESIS */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT),
+/* U+A9 COPYRIGHT SIGN */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_QUOTEMETA),
+/* U+AA FEMININE ORDINAL INDICATOR */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR),
+/* U+AB LEFT-POINTING DOUBLE ANGLE QUOTATION MARK */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+AC NOT SIGN */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_QUOTEMETA),
+/* U+AD SOFT HYPHEN */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_QUOTEMETA),
+/* U+AE REGISTERED SIGN */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_QUOTEMETA),
+/* U+AF MACRON */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT),
+/* U+B0 DEGREE SIGN */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_QUOTEMETA),
+/* U+B1 PLUS-MINUS SIGN */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_QUOTEMETA),
+/* U+B2 SUPERSCRIPT TWO */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT),
+/* U+B3 SUPERSCRIPT THREE */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT),
+/* U+B4 ACUTE ACCENT */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT),
+/* U+B5 MICRO SIGN */ (1U<<_CC_NONLATIN1_FOLD)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+B6 PILCROW SIGN */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+B7 MIDDLE DOT */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT),
+/* U+B8 CEDILLA */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT),
+/* U+B9 SUPERSCRIPT ONE */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT),
+/* U+BA MASCULINE ORDINAL INDICATOR */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR),
+/* U+BB RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+BC VULGAR FRACTION ONE QUARTER */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT),
+/* U+BD VULGAR FRACTION ONE HALF */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT),
+/* U+BE VULGAR FRACTION THREE QUARTERS */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT),
+/* U+BF INVERTED QUESTION MARK */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
+/* U+C0 A WITH GRAVE */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+C1 A WITH ACUTE */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+C2 A WITH CIRCUMFLEX */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+C3 A WITH TILDE */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+C4 A WITH DIAERESIS */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+C5 A WITH RING ABOVE */ (1U<<_CC_NONLATIN1_FOLD)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+C6 AE */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+C7 C WITH CEDILLA */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+C8 E WITH GRAVE */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+C9 E WITH ACUTE */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+CA E WITH CIRCUMFLEX */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+CB E WITH DIAERESIS */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+CC I WITH GRAVE */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+CD I WITH ACUTE */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+CE I WITH CIRCUMFLEX */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+CF I WITH DIAERESIS */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+D0 ETH */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+D1 N WITH TILDE */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+D2 O WITH GRAVE */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+D3 O WITH ACUTE */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+D4 O WITH CIRCUMFLEX */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+D5 O WITH TILDE */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+D6 O WITH DIAERESIS */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+D7 MULTIPLICATION SIGN */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_QUOTEMETA),
+/* U+D8 O WITH STROKE */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+D9 U WITH GRAVE */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+DA U WITH ACUTE */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+DB U WITH CIRCUMFLEX */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+DC U WITH DIAERESIS */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+DD Y WITH ACUTE */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+DE THORN */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+DF sharp s */ (1U<<_CC_NONLATIN1_FOLD)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+E0 a with grave */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+E1 a with acute */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+E2 a with circumflex */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+E3 a with tilde */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+E4 a with diaeresis */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+E5 a with ring above */ (1U<<_CC_NONLATIN1_FOLD)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+E6 ae */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+E7 c with cedilla */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+E8 e with grave */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+E9 e with acute */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+EA e with circumflex */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+EB e with diaeresis */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+EC i with grave */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+ED i with acute */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+EE i with circumflex */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+EF i with diaeresis */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+F0 eth */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+F1 n with tilde */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+F2 o with grave */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+F3 o with acute */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+F4 o with circumflex */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+F5 o with tilde */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+F6 o with diaeresis */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+F7 DIVISION SIGN */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_QUOTEMETA),
+/* U+F8 o with stroke */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+F9 u with grave */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+FA u with acute */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+FB u with circumflex */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+FC u with diaeresis */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+FD y with acute */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+FE thorn */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
+/* U+FF y with diaeresis */ (1U<<_CC_NONLATIN1_FOLD)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD),
/* ex: set ro: */
Property changes on: trunk/contrib/perl/l1_char_class_tab.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/locale.c
===================================================================
--- trunk/contrib/perl/locale.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/locale.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -10,9 +10,9 @@
/*
* A Elbereth Gilthoniel,
- * silivren penna m\xEDriel
+ * silivren penna mÃriel
* o menel aglar elenath!
- * Na-chaered palan-d\xEDriel
+ * Na-chaered palan-dÃriel
* o galadhremmin ennorath,
* Fanuilos, le linnathon
* nef aear, si nef aearon!
@@ -28,10 +28,6 @@
#define PERL_IN_LOCALE_C
#include "perl.h"
-#ifdef I_LOCALE
-# include <locale.h>
-#endif
-
#ifdef I_LANGINFO
# include <langinfo.h>
#endif
@@ -231,8 +227,9 @@
const Size_t fa = strxfrm(xbuf, "a", XFRMBUFSIZE);
const Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE);
const SSize_t mult = fb - fa;
- if (mult < 1)
- Perl_croak(aTHX_ "strxfrm() gets absurd");
+ if (mult < 1 && !(fa == 0 && fb == 0))
+ Perl_croak(aTHX_ "panic: strxfrm() gets absurd - a => %"UVuf", ab => %"UVuf,
+ (UV) fa, (UV) fb);
PL_collxfrm_base = (fa > (Size_t)mult) ? (fa - mult) : 0;
PL_collxfrm_mult = mult;
}
@@ -634,8 +631,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/locale.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/madly.c
===================================================================
--- trunk/contrib/perl/madly.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/madly.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -19,8 +19,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/madly.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/make_ext.pl
===================================================================
--- trunk/contrib/perl/make_ext.pl 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/make_ext.pl 2013-12-02 21:18:17 UTC (rev 6438)
@@ -2,15 +2,6 @@
use strict;
use warnings;
use Config;
-BEGIN {
- if ($^O eq 'MSWin32') {
- unshift @INC, '../dist/Cwd';
- require FindExt;
- } else {
- unshift @INC, 'dist/Cwd';
- }
-}
-use Cwd;
my $is_Win32 = $^O eq 'MSWin32';
my $is_VMS = $^O eq 'VMS';
@@ -147,7 +138,9 @@
my %extra_passthrough;
if ($is_Win32) {
- my $build = getcwd();
+ require Cwd;
+ require FindExt;
+ my $build = Cwd::getcwd();
$perl = $^X;
if ($perl =~ m#^\.\.#) {
my $here = $build;
@@ -167,7 +160,7 @@
print "In $build";
foreach my $dir (@dirs) {
chdir($dir) or die "Cannot cd to $dir: $!\n";
- (my $ext = getcwd()) =~ s{/}{\\}g;
+ (my $ext = Cwd::getcwd()) =~ s{/}{\\}g;
FindExt::scan_ext($ext);
FindExt::set_static_extensions(split ' ', $Config{static_ext});
chdir $build
@@ -211,10 +204,11 @@
{
# Cwd needs to be built before Encode recurses into subdirectories.
+ # Pod::Simple needs to be built before Pod::Functions
# This seems to be the simplest way to ensure this ordering:
my (@first, @other);
foreach (@extspec) {
- if ($_ eq 'Cwd') {
+ if ($_ eq 'Cwd' || $_ eq 'Pod/Simple') {
push @first, $_;
} else {
push @other, $_;
@@ -287,6 +281,28 @@
$makefile = 'Makefile';
}
+ if (-f $makefile) {
+ open my $mfh, $makefile or die "Cannot open $makefile: $!";
+ while (<$mfh>) {
+ # Plagiarised from CPAN::Distribution
+ last if /MakeMaker post_initialize section/;
+ next unless /^#\s+VERSION_FROM\s+=>\s+(.+)/;
+ my $vmod = eval $1;
+ my $oldv;
+ while (<$mfh>) {
+ next unless /^XS_VERSION = (\S+)/;
+ $oldv = $1;
+ last;
+ }
+ last unless defined $oldv;
+ require ExtUtils::MM_Unix;
+ defined (my $newv = parse_version MM $vmod) or last;
+ if ($newv ne $oldv) {
+ 1 while unlink $makefile
+ }
+ }
+ }
+
if (!-f $makefile) {
if (!-f 'Makefile.PL') {
print "\nCreating Makefile.PL in $ext_dir for $mname\n";
@@ -376,6 +392,16 @@
# ex: set ro:
EOM
close $fh or die "Can't close Makefile.PL: $!";
+ # As described in commit 23525070d6c0e51f:
+ # Push the atime and mtime of generated Makefile.PLs back 4
+ # seconds. In certain circumstances ( on virtual machines ) the
+ # generated Makefile.PL can produce a Makefile that is older than
+ # the Makefile.PL. Altering the atime and mtime backwards by 4
+ # seconds seems to resolve the issue.
+ eval {
+ my $ftime = time - 4;
+ utime $ftime, $ftime, 'Makefile.PL';
+ };
}
print "\nRunning Makefile.PL in $ext_dir\n";
@@ -388,7 +414,7 @@
# Inherited from make_ext.pl
@cross = '-MCross';
}
-
+
my @args = ("-I$lib_dir", @cross, 'Makefile.PL');
if ($is_VMS) {
my $libd = VMS::Filespec::vmspath($lib_dir);
@@ -445,8 +471,11 @@
}
if ($is_VMS) {
- _macroify_passthrough($pass_through);
- unshift @$pass_through, "/DESCRIPTION=$makefile";
+ _quote_args($pass_through);
+ @$pass_through = (
+ "/DESCRIPTION=$makefile",
+ '/MACRO=(' . join(',',@$pass_through) . ')'
+ );
}
if (!$target or $target !~ /clean$/) {
@@ -453,11 +482,9 @@
# Give makefile an opportunity to rewrite itself.
# reassure users that life goes on...
my @args = ('config', @$pass_through);
- _quote_args(\@args) if $is_VMS;
system(@run, @make, @args) and print "@run @make @args failed, continuing anyway...\n";
}
my @targ = ($target, @$pass_through);
- _quote_args(\@targ) if $is_VMS;
print "Making $target in $ext_dir\n at run @make @targ\n";
my $code = system(@run, @make, @targ);
die "Unsuccessful make($ext_dir): code=$code" if $code != 0;
@@ -476,11 +503,3 @@
} @{$args}
;
}
-
-sub _macroify_passthrough {
- my $passthrough = shift;
- _quote_args($passthrough);
- my $macro = '/MACRO=(' . join(',',@$passthrough) . ')';
- @$passthrough = ();
- @$passthrough[0] = $macro;
-}
Property changes on: trunk/contrib/perl/make_ext.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/make_patchnum.pl
===================================================================
--- trunk/contrib/perl/make_patchnum.pl 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/make_patchnum.pl 2013-12-02 21:18:17 UTC (rev 6438)
@@ -17,9 +17,9 @@
This program creates the files holding the information
about locally applied patches to the source code. The created
-files are C<git_version.h> and C<lib/Config_git.pl>.
+files are F<git_version.h> and F<lib/Config_git.pl>.
-=head2 C<lib/Config_git.pl>
+=head2 F<lib/Config_git.pl>
Contains status information from git in a form meant to be processed
by the tied hash logic of Config.pm. It is actually optional,
@@ -133,7 +133,8 @@
}
elsif (-d "$srcdir/.git") {
# git branch | awk 'BEGIN{ORS=""} /\*/ { print $2 }'
- ($branch) = map { /\* ([^(]\S*)/ ? $1 : "" } backtick("git branch");
+ ($branch) = map { /\* ([^(]\S*)/ ? $1 : () } backtick("git branch");
+ $branch //= "";
my ($remote,$merge);
if (length $branch) {
$merge= backtick("git config branch.$branch.merge");
Property changes on: trunk/contrib/perl/make_patchnum.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/makedef.pl
===================================================================
--- trunk/contrib/perl/makedef.pl 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/makedef.pl 2013-12-02 21:18:17 UTC (rev 6438)
@@ -3,13 +3,14 @@
# Create the export list for perl.
#
# Needed by WIN32 and OS/2 for creating perl.dll,
-# and by AIX for creating libperl.a when -Dusershrplib is in effect,
+# and by AIX for creating libperl.a when -Duseshrplib is in effect,
+# and by VMS for creating perlshr.exe.
#
# Reads from information stored in
#
+# %Config::Config (ie config.sh)
# config.h
-# config.sh
-# global.sym
+# embed.fnc
# globvar.sym
# intrpvar.h
# miniperl.map (on OS/2)
@@ -16,9 +17,9 @@
# perl5.def (on OS/2; this is the old version of the file being made)
# perlio.sym
# perlvars.h
+# regen/opcodes
#
-# plus long lists of function names hard-coded directly in this script and
-# in the DATA section.
+# plus long lists of function names hard-coded directly in this script.
#
# Writes the result to STDOUT.
#
@@ -29,62 +30,68 @@
# perldll.def Windows
# perl.exp AIX
# perl.imp NetWare
+# makedef.lis VMS
-
BEGIN { unshift @INC, "lib" }
use Config;
use strict;
-use vars qw($PLATFORM $CCTYPE $FILETYPE $CONFIG_ARGS $ARCHNAME $PATCHLEVEL);
+my %ARGS = (CCTYPE => 'MSVC', TARG_DIR => '');
-my (%define, %ordinal);
+my %define;
+my $fold;
+
+sub process_cc_flags {
+ foreach (map {split /\s+/, $_} @_) {
+ $define{$1} = $2 // 1 if /^-D(\w+)(?:=(.+))?/;
+ }
+}
+
while (@ARGV) {
my $flag = shift;
- if ($flag =~ s/^CC_FLAGS=/ /) {
- for my $fflag ($flag =~ /(?:^|\s)-D(\S+)/g) {
- $fflag .= '=1' unless $fflag =~ /^(\w+)=/;
- $define{$1} = $2 if $fflag =~ /^(\w+)=(.+)$/;
- }
- next;
+ if ($flag =~ /^(?:CC_FLAGS=)?(-D\w.*)/) {
+ process_cc_flags($1);
+ } elsif ($flag =~ /^(CCTYPE|FILETYPE|PLATFORM|TARG_DIR)=(.+)$/) {
+ $ARGS{$1} = $2;
+ } elsif ($flag eq '--sort-fold') {
+ ++$fold;
}
- $define{$1} = 1 if ($flag =~ /^-D(\w+)$/);
- $define{$1} = $2 if ($flag =~ /^-D(\w+)=(.+)$/);
- $CCTYPE = $1 if ($flag =~ /^CCTYPE=(\w+)$/);
- $PLATFORM = $1 if ($flag =~ /^PLATFORM=(\w+)$/);
- if ($PLATFORM eq 'netware') {
- $FILETYPE = $1 if ($flag =~ /^FILETYPE=(\w+)$/);
- }
}
-my @PLATFORM = qw(aix win32 wince os2 netware);
-my %PLATFORM;
- at PLATFORM{@PLATFORM} = ();
+require "$ARGS{TARG_DIR}regen/embed_lib.pl";
-defined $PLATFORM || die "PLATFORM undefined, must be one of: @PLATFORM\n";
-exists $PLATFORM{$PLATFORM} || die "PLATFORM must be one of: @PLATFORM\n";
+{
+ my @PLATFORM = qw(aix win32 wince os2 netware vms test);
+ my %PLATFORM;
+ @PLATFORM{@PLATFORM} = ();
-if ($PLATFORM eq 'win32' or $PLATFORM eq 'wince' or $PLATFORM eq "aix") {
- # Add the compile-time options that miniperl was built with to %define.
- # On Win32 these are not the same options as perl itself will be built
- # with since miniperl is built with a canned config (one of the win32/
- # config_H.*) and none of the BUILDOPT's that are set in the makefiles,
- # but they do include some #define's that are hard-coded in various
- # source files and header files and don't include any BUILDOPT's that
- # the user might have chosen to disable because the canned configs are
- # minimal configs that don't include any of those options.
- my $opts = ($PLATFORM eq 'wince' ? '-MCross' : ''); # for wince need Cross.pm to get Config.pm
+ die "PLATFORM undefined, must be one of: @PLATFORM\n"
+ unless defined $ARGS{PLATFORM};
+ die "PLATFORM must be one of: @PLATFORM\n"
+ unless exists $PLATFORM{$ARGS{PLATFORM}};
+}
- $ENV{PERL5LIB} = join $Config{path_sep}, @INC;
- my $cmd = "$^X $opts -V";
- my $config = `$cmd`
- or die "Couldn't run [$cmd]: $!";
- my($options) = $config =~ /^ Compile-time options: (.*?)\n^ \S/ms;
- $options =~ s/\s+/ /g;
- print STDERR "Options: ($options)\n";
- foreach (split /\s+/, $options) {
- $define{$_} = 1;
- }
+# Is the following guard strictly necessary? Added during refactoring
+# to keep the same behaviour when merging other code into here.
+process_cc_flags(@Config{qw(ccflags optimize)})
+ if $ARGS{PLATFORM} ne 'win32' && $ARGS{PLATFORM} ne 'wince'
+ && $ARGS{PLATFORM} ne 'netware';
+
+# Add the compile-time options that miniperl was built with to %define.
+# On Win32 these are not the same options as perl itself will be built
+# with since miniperl is built with a canned config (one of the win32/
+# config_H.*) and none of the BUILDOPT's that are set in the makefiles,
+# but they do include some #define's that are hard-coded in various
+# source files and header files and don't include any BUILDOPT's that
+# the user might have chosen to disable because the canned configs are
+# minimal configs that don't include any of those options.
+
+#don't use the host Perl's -V defines for the WinCE Perl
+if($ARGS{PLATFORM} ne 'wince') {
+ my @options = sort(Config::bincompat_options(), Config::non_bincompat_options());
+ print STDERR "Options: (@options)\n" unless $ARGS{PLATFORM} eq 'test';
+ $define{$_} = 1 foreach @options;
}
my %exportperlmalloc =
@@ -95,69 +102,20 @@
Perl_calloc => "calloc",
);
-my $exportperlmalloc = $PLATFORM eq 'os2';
+my $exportperlmalloc = $ARGS{PLATFORM} eq 'os2';
-my $config_sh = "config.sh";
-my $config_h = "config.h";
-my $intrpvar_h = "intrpvar.h";
-my $perlvars_h = "perlvars.h";
-my $global_sym = "global.sym";
-my $globvar_sym = "globvar.sym";
-my $perlio_sym = "perlio.sym";
-my $static_ext = "";
-
-if ($PLATFORM eq 'aix') {
- # Nothing for now.
-}
-elsif ($PLATFORM =~ /^win(?:32|ce)$/ || $PLATFORM eq 'netware') {
- $CCTYPE = "MSVC" unless defined $CCTYPE;
- foreach ($intrpvar_h, $perlvars_h, $global_sym, $globvar_sym, $perlio_sym) {
- s!^!..\\!;
- }
-}
-
-unless ($PLATFORM eq 'win32' || $PLATFORM eq 'wince' || $PLATFORM eq 'netware') {
- open(CFG,$config_sh) || die "Cannot open $config_sh: $!\n";
- while (<CFG>) {
- if (/^(?:ccflags|optimize)='(.+)'$/) {
- $_ = $1;
- $define{$1} = 1 while /-D(\w+)/g;
- }
- if (/^(d_(?:mmap|sigaction))='(.+)'$/) {
- $define{$1} = $2;
- }
- if ($PLATFORM eq 'os2') {
- $CONFIG_ARGS = $1 if /^config_args='(.+)'$/;
- $ARCHNAME = $1 if /^archname='(.+)'$/;
- $PATCHLEVEL = $1 if /^perl_patchlevel='(.+)'$/;
- }
- }
- close(CFG);
-}
-if ($PLATFORM eq 'win32' || $PLATFORM eq 'wince') {
- open(CFG,"<..\\$config_sh") || die "Cannot open ..\\$config_sh: $!\n";
- if ((join '', <CFG>) =~ /^static_ext='(.*)'$/m) {
- $static_ext = $1;
- }
- close(CFG);
-}
-
-open(CFG,$config_h) || die "Cannot open $config_h: $!\n";
+my $config_h = $ARGS{PLATFORM} eq 'wince' ? 'xconfig.h' : 'config.h';
+open(CFG, '<', $config_h) || die "Cannot open $config_h: $!\n";
while (<CFG>) {
- $define{$1} = 1 if /^\s*#\s*define\s+(MYMALLOC)\b/;
- $define{$1} = 1 if /^\s*#\s*define\s+(MULTIPLICITY)\b/;
- $define{$1} = 1 if /^\s*#\s*define\s+(PERL_\w+)\b/;
- $define{$1} = 1 if /^\s*#\s*define\s+(USE_\w+)\b/;
- $define{$1} = 1 if /^\s*#\s*define\s+(HAS_\w+)\b/;
+ $define{$1} = 1 if /^\s*\#\s*define\s+(MYMALLOC|MULTIPLICITY
+ |SPRINTF_RETURNS_STRLEN
+ |KILL_BY_SIGPRC
+ |(?:PERL|USE|HAS)_\w+)\b/x;
}
close(CFG);
# perl.h logic duplication begins
-if ($define{PERL_IMPLICIT_SYS}) {
- $define{PL_OP_SLAB_ALLOC} = 1;
-}
-
if ($define{USE_ITHREADS}) {
if (!$define{MULTIPLICITY}) {
$define{MULTIPLICITY} = 1;
@@ -168,34 +126,19 @@
$define{USE_ITHREADS} ||
$define{MULTIPLICITY} ;
-if ($define{USE_ITHREADS} && $PLATFORM ne 'win32' && $^O ne 'darwin') {
+if ($define{USE_ITHREADS} && $ARGS{PLATFORM} ne 'win32' && $^O ne 'darwin') {
$define{USE_REENTRANT_API} = 1;
}
# perl.h logic duplication ends
+print STDERR "Defines: (" . join(' ', sort keys %define) . ")\n"
+ unless $ARGS{PLATFORM} eq 'test';
+
my $sym_ord = 0;
+my %ordinal;
-print STDERR "Defines: (" . join(' ', sort keys %define) . ")\n";
-
-if ($PLATFORM =~ /^win(?:32|ce)$/) {
- (my $dll = ($define{PERL_DLL} || "perl514")) =~ s/\.dll$//i;
- print "LIBRARY $dll\n";
- # The DESCRIPTION module definition file statement is not supported
- # by VC7 onwards.
- if ($CCTYPE =~ /^(?:MSVC60|GCC|BORLAND)$/) {
- print "DESCRIPTION 'Perl interpreter'\n";
- }
- print "EXPORTS\n";
- if ($define{PERL_IMPLICIT_SYS}) {
- output_symbol("perl_get_host_info");
- output_symbol("perl_alloc_override");
- }
- if ($define{USE_ITHREADS} and $define{PERL_IMPLICIT_SYS}) {
- output_symbol("perl_clone_host");
- }
-}
-elsif ($PLATFORM eq 'os2') {
+if ($ARGS{PLATFORM} eq 'os2') {
if (open my $fh, '<', 'perl5.def') {
while (<$fh>) {
last if /^\s*EXPORTS\b/;
@@ -207,201 +150,47 @@
}
$sym_ord < $_ and $sym_ord = $_ for values %ordinal; # Take the max
}
- (my $v = $]) =~ s/(\d\.\d\d\d)(\d\d)$/$1_$2/;
- $v .= '-thread' if $ARCHNAME =~ /-thread/;
- (my $dll = $define{PERL_DLL}) =~ s/\.dll$//i;
- $v .= "\@$PATCHLEVEL" if $PATCHLEVEL;
- my $d = "DESCRIPTION '\@#perl5-porters\@perl.org:$v#\@ Perl interpreter, configured as $CONFIG_ARGS'";
- $d = substr($d, 0, 249) . "...'" if length $d > 253;
- print <<"---EOP---";
-LIBRARY '$dll' INITINSTANCE TERMINSTANCE
-$d
-STACKSIZE 32768
-CODE LOADONCALL
-DATA LOADONCALL NONSHARED MULTIPLE
-EXPORTS
----EOP---
}
-elsif ($PLATFORM eq 'aix') {
- my $OSVER = `uname -v`;
- chop $OSVER;
- my $OSREL = `uname -r`;
- chop $OSREL;
- if ($OSVER > 4 || ($OSVER == 4 && $OSREL >= 3)) {
- print "#! ..\n";
- } else {
- print "#!\n";
- }
-}
-elsif ($PLATFORM eq 'netware') {
- if ($FILETYPE eq 'def') {
- print "LIBRARY perl514\n";
- print "DESCRIPTION 'Perl interpreter for NetWare'\n";
- print "EXPORTS\n";
- }
- if ($define{PERL_IMPLICIT_SYS}) {
- output_symbol("perl_get_host_info");
- output_symbol("perl_alloc_override");
- output_symbol("perl_clone_host");
- }
-}
my %skip;
-my %export;
+# All platforms export boot_DynaLoader unconditionally.
+my %export = ( boot_DynaLoader => 1 );
-sub skip_symbols {
- my $list = shift;
- foreach my $symbol (@$list) {
- $skip{$symbol} = 1;
+sub try_symbols {
+ foreach my $symbol (@_) {
+ ++$export{$symbol} unless exists $skip{$symbol};
}
}
-sub emit_symbols {
- my $list = shift;
- foreach my $symbol (@$list) {
- my $skipsym = $symbol;
- # XXX hack
- if ($define{MULTIPLICITY}) {
- $skipsym =~ s/^Perl_[GIT](\w+)_ptr$/PL_$1/;
- }
- emit_symbol($symbol) unless exists $skip{$skipsym};
+sub readvar {
+ # $hash is the hash that we're adding to. For one of our callers, it will
+ # actually be the skip hash but that doesn't affect the intent of what
+ # we're doing, as in that case we skip adding something to the skip hash
+ # for the second time.
+
+ my $file = $ARGS{TARG_DIR} . shift;
+ my $hash = shift;
+ my $proc = shift;
+ open my $vars, '<', $file or die die "Cannot open $file: $!\n";
+
+ while (<$vars>) {
+ # All symbols have a Perl_ prefix because that's what embed.h sticks
+ # in front of them. The A?I?S?C? is strictly speaking wrong.
+ next unless /\bPERLVAR(A?I?S?C?)\(([IGT]),\s*(\w+)/;
+
+ my $var = "PL_$3";
+ my $symbol = $proc ? &$proc($1,$2,$3) : $var;
+ ++$hash->{$symbol} unless exists $skip{$var};
}
}
-if ($PLATFORM eq 'win32') {
- skip_symbols [qw(
- PL_statusvalue_vms
- PL_archpat_auto
+if ($ARGS{PLATFORM} ne 'os2') {
+ ++$skip{$_} foreach qw(
PL_cryptseen
- PL_DBcv
- PL_generation
- PL_lastgotoprobe
- PL_linestart
- PL_modcount
- PL_pending_ident
- PL_sublex_info
- PL_timesbuf
- main
- Perl_ErrorNo
- Perl_GetVars
- Perl_do_exec3
- Perl_do_ipcctl
- Perl_do_ipcget
- Perl_do_msgrcv
- Perl_do_msgsnd
- Perl_do_semop
- Perl_do_shmio
- Perl_dump_fds
- Perl_init_thread_intern
- Perl_my_bzero
- Perl_my_bcopy
- Perl_my_htonl
- Perl_my_ntohl
- Perl_my_swap
- Perl_my_chsize
- Perl_same_dirent
- Perl_setenv_getix
- Perl_unlnk
- Perl_watch
- Perl_safexcalloc
- Perl_safexmalloc
- Perl_safexfree
- Perl_safexrealloc
- Perl_my_memcmp
- Perl_my_memset
- PL_cshlen
- PL_cshname
PL_opsave
- Perl_do_exec
- Perl_getenv_len
- Perl_my_pclose
- Perl_my_popen
- Perl_my_sprintf
- )];
-}
-else {
- skip_symbols [qw(
- Perl_do_spawn
- Perl_do_spawn_nowait
- Perl_do_aspawn
- )];
-}
-if ($PLATFORM eq 'wince') {
- skip_symbols [qw(
- PL_statusvalue_vms
- PL_archpat_auto
- PL_cryptseen
- PL_DBcv
- PL_generation
- PL_lastgotoprobe
- PL_linestart
- PL_modcount
- PL_pending_ident
- PL_sublex_info
- PL_timesbuf
- PL_collation_ix
- PL_collation_name
- PL_collation_standard
- PL_collxfrm_base
- PL_collxfrm_mult
- PL_numeric_compat1
- PL_numeric_local
- PL_numeric_name
- PL_numeric_radix_sv
- PL_numeric_standard
- PL_vtbl_collxfrm
- Perl_sv_collxfrm
- setgid
- setuid
- win32_free_childdir
- win32_free_childenv
- win32_get_childdir
- win32_get_childenv
- win32_spawnvp
- main
- Perl_ErrorNo
Perl_GetVars
- Perl_do_exec3
- Perl_do_ipcctl
- Perl_do_ipcget
- Perl_do_msgrcv
- Perl_do_msgsnd
- Perl_do_semop
- Perl_do_shmio
Perl_dump_fds
- Perl_init_thread_intern
- Perl_my_bzero
Perl_my_bcopy
- Perl_my_htonl
- Perl_my_ntohl
- Perl_my_swap
- Perl_my_chsize
- Perl_same_dirent
- Perl_setenv_getix
- Perl_unlnk
- Perl_watch
- Perl_safexcalloc
- Perl_safexmalloc
- Perl_safexfree
- Perl_safexrealloc
- Perl_my_memcmp
- Perl_my_memset
- PL_cshlen
- PL_cshname
- PL_opsave
- Perl_do_exec
- Perl_getenv_len
- Perl_my_pclose
- Perl_my_popen
- Perl_my_sprintf
- )];
-}
-elsif ($PLATFORM eq 'aix') {
- skip_symbols([qw(
- Perl_dump_fds
- Perl_ErrorNo
- Perl_GetVars
- Perl_my_bcopy
Perl_my_bzero
Perl_my_chsize
Perl_my_htonl
@@ -409,212 +198,72 @@
Perl_my_memset
Perl_my_ntohl
Perl_my_swap
- Perl_safexcalloc
- Perl_safexfree
- Perl_safexmalloc
- Perl_safexrealloc
- Perl_same_dirent
- Perl_unlnk
- Perl_sys_intern_clear
- Perl_sys_intern_dup
- Perl_sys_intern_init
- Perl_my_sprintf
- PL_cryptseen
- PL_opsave
- PL_statusvalue_vms
- PL_sys_intern
- )]);
- skip_symbols([qw(
- Perl_signbit
- )])
- if $define{'HAS_SIGNBIT'};
- emit_symbols([qw(
- boot_DynaLoader
- )]);
+ );
+ if ($ARGS{PLATFORM} eq 'vms') {
+ ++$skip{PL_statusvalue_posix};
+ # This is a wrapper if we have symlink, not a replacement
+ # if we don't.
+ ++$skip{Perl_my_symlink} unless $Config{d_symlink};
+ } else {
+ ++$skip{PL_statusvalue_vms};
+ if ($ARGS{PLATFORM} ne 'aix') {
+ ++$skip{$_} foreach qw(
+ PL_DBcv
+ PL_generation
+ PL_lastgotoprobe
+ PL_modcount
+ PL_timesbuf
+ main
+ );
+ }
+ }
}
-elsif ($PLATFORM eq 'os2') {
- emit_symbols([qw(
- ctermid
- get_sysinfo
- Perl_OS2_init
- Perl_OS2_init3
- Perl_OS2_term
- OS2_Perl_data
- dlopen
- dlsym
- dlerror
- dlclose
- dup2
- dup
- my_tmpfile
- my_tmpnam
- my_flock
- my_rmdir
- my_mkdir
- my_getpwuid
- my_getpwnam
- my_getpwent
- my_setpwent
- my_endpwent
- fork_with_resources
- croak_with_os2error
- setgrent
- endgrent
- getgrent
- malloc_mutex
- threads_mutex
- nthreads
- nthreads_cond
- os2_cond_wait
- os2_stat
- os2_execname
- async_mssleep
- msCounter
- InfoTable
- pthread_join
- pthread_create
- pthread_detach
- XS_Cwd_change_drive
- XS_Cwd_current_drive
- XS_Cwd_extLibpath
- XS_Cwd_extLibpath_set
- XS_Cwd_sys_abspath
- XS_Cwd_sys_chdir
- XS_Cwd_sys_cwd
- XS_Cwd_sys_is_absolute
- XS_Cwd_sys_is_relative
- XS_Cwd_sys_is_rooted
- XS_DynaLoader_mod2fname
- XS_File__Copy_syscopy
- Perl_Register_MQ
- Perl_Deregister_MQ
- Perl_Serve_Messages
- Perl_Process_Messages
- init_PMWIN_entries
- PMWIN_entries
- Perl_hab_GET
- loadByOrdinal
- pExtFCN
- os2error
- ResetWinError
- CroakWinError
- PL_do_undump
- )]);
- emit_symbols([qw(os2_cond_wait
- pthread_join
- pthread_create
- pthread_detach
- )])
- if $define{'USE_5005THREADS'} or $define{'USE_ITHREADS'};
+
+if ($ARGS{PLATFORM} ne 'vms') {
+ # VMS does its own thing for these symbols.
+ ++$skip{$_} foreach qw(
+ PL_sig_handlers_initted
+ PL_sig_ignoring
+ PL_sig_defaulting
+ );
+ if ($ARGS{PLATFORM} ne 'win32') {
+ ++$skip{$_} foreach qw(
+ Perl_do_spawn
+ Perl_do_spawn_nowait
+ Perl_do_aspawn
+ );
+ }
}
-elsif ($PLATFORM eq 'netware') {
- skip_symbols [qw(
- PL_statusvalue_vms
- PL_archpat_auto
- PL_cryptseen
- PL_DBcv
- PL_generation
- PL_lastgotoprobe
- PL_linestart
- PL_modcount
- PL_pending_ident
- PL_sublex_info
- PL_timesbuf
- main
- Perl_ErrorNo
- Perl_GetVars
- Perl_do_exec3
- Perl_do_ipcctl
- Perl_do_ipcget
- Perl_do_msgrcv
- Perl_do_msgsnd
- Perl_do_semop
- Perl_do_shmio
- Perl_dump_fds
- Perl_init_thread_intern
- Perl_my_bzero
- Perl_my_htonl
- Perl_my_ntohl
- Perl_my_swap
- Perl_my_chsize
- Perl_same_dirent
- Perl_setenv_getix
- Perl_unlnk
- Perl_watch
- Perl_safexcalloc
- Perl_safexmalloc
- Perl_safexfree
- Perl_safexrealloc
- Perl_my_memcmp
- Perl_my_memset
- PL_cshlen
- PL_cshname
- PL_opsave
- Perl_do_exec
- Perl_getenv_len
- Perl_my_pclose
- Perl_my_popen
- Perl_sys_intern_init
- Perl_sys_intern_dup
- Perl_sys_intern_clear
- Perl_my_bcopy
- Perl_PerlIO_write
- Perl_PerlIO_unread
- Perl_PerlIO_tell
- Perl_PerlIO_stdout
- Perl_PerlIO_stdin
- Perl_PerlIO_stderr
- Perl_PerlIO_setlinebuf
- Perl_PerlIO_set_ptrcnt
- Perl_PerlIO_set_cnt
- Perl_PerlIO_seek
- Perl_PerlIO_read
- Perl_PerlIO_get_ptr
- Perl_PerlIO_get_cnt
- Perl_PerlIO_get_bufsiz
- Perl_PerlIO_get_base
- Perl_PerlIO_flush
- Perl_PerlIO_fill
- Perl_PerlIO_fileno
- Perl_PerlIO_error
- Perl_PerlIO_eof
- Perl_PerlIO_close
- Perl_PerlIO_clearerr
- PerlIO_perlio
- )];
+
+unless ($define{UNLINK_ALL_VERSIONS}) {
+ ++$skip{Perl_unlnk};
}
unless ($define{'DEBUGGING'}) {
- skip_symbols [qw(
- Perl_deb_growlevel
+ ++$skip{$_} foreach qw(
Perl_debop
Perl_debprofdump
Perl_debstack
Perl_debstackptrs
Perl_pad_sv
+ Perl_pad_setsv
Perl_hv_assert
- PL_block_type
PL_watchaddr
PL_watchok
PL_watch_pvx
- )];
+ );
}
-if ($define{'PERL_IMPLICIT_CONTEXT'}) {
- skip_symbols [qw(
- PL_sig_sv
- )];
-}
-
if ($define{'PERL_IMPLICIT_SYS'}) {
- skip_symbols [qw(
- Perl_getenv_len
+ ++$skip{$_} foreach qw(
Perl_my_popen
Perl_my_pclose
- )];
+ );
+ ++$export{$_} foreach qw(perl_get_host_info perl_alloc_override);
+ ++$export{perl_clone_host} if $define{USE_ITHREADS};
}
else {
- skip_symbols [qw(
+ ++$skip{$_} foreach qw(
PL_Mem
PL_MemShared
PL_MemParse
@@ -624,23 +273,26 @@
PL_Dir
PL_Sock
PL_Proc
- )];
+ perl_alloc_using
+ perl_clone_using
+ );
}
-unless ($define{'PERL_OLD_COPY_ON_WRITE'}) {
- skip_symbols [qw(
- Perl_sv_setsv_cow
- )];
+unless ($define{'PERL_OLD_COPY_ON_WRITE'}
+ || $define{'PERL_NEW_COPY_ON_WRITE'}) {
+ ++$skip{Perl_sv_setsv_cow};
}
+unless ($define{PERL_SAWAMPERSAND}) {
+ ++$skip{PL_sawampersand};
+}
+
unless ($define{'USE_REENTRANT_API'}) {
- skip_symbols [qw(
- PL_reentrant_buffer
- )];
+ ++$skip{PL_reentrant_buffer};
}
if ($define{'MYMALLOC'}) {
- emit_symbols [qw(
+ try_symbols(qw(
Perl_dump_mstats
Perl_get_mstats
Perl_strdup
@@ -647,44 +299,31 @@
Perl_putenv
MallocCfg_ptr
MallocCfgP_ptr
- )];
- if ($define{'USE_ITHREADS'}) {
- emit_symbols [qw(
- PL_malloc_mutex
- )];
+ ));
+ unless ($define{USE_ITHREADS}) {
+ ++$skip{PL_malloc_mutex}
}
- else {
- skip_symbols [qw(
- PL_malloc_mutex
- )];
- }
}
else {
- skip_symbols [qw(
+ ++$skip{$_} foreach qw(
PL_malloc_mutex
Perl_dump_mstats
Perl_get_mstats
- Perl_malloced_size
- Perl_malloc_good_size
MallocCfg_ptr
MallocCfgP_ptr
- )];
+ );
}
if ($define{'PERL_USE_SAFE_PUTENV'}) {
- skip_symbols [qw(
- PL_use_safe_putenv
- )];
+ ++$skip{PL_use_safe_putenv};
}
unless ($define{'USE_ITHREADS'}) {
- skip_symbols [qw(
- PL_thr_key
- )];
+ ++$skip{PL_thr_key};
}
# USE_5005THREADS symbols. Kept as reference for easier removal
- skip_symbols [qw(
+++$skip{$_} foreach qw(
PL_sv_mutex
PL_strtab_mutex
PL_svref_mutex
@@ -709,20 +348,22 @@
Perl_unlock_condpair
Perl_magic_mutexfree
Perl_sv_lock
- )];
+ );
unless ($define{'USE_ITHREADS'}) {
- skip_symbols [qw(
+ ++$skip{$_} foreach qw(
+ PL_check_mutex
PL_op_mutex
PL_regex_pad
PL_regex_padav
- PL_sharedsv_space
- PL_sharedsv_space_mutex
PL_dollarzero_mutex
PL_hints_mutex
PL_my_ctx_mutex
PL_perlio_mutex
- PL_regdupe
+ PL_stashpad
+ PL_stashpadix
+ PL_stashpadmax
+ Perl_alloccopstash
Perl_clone_params_del
Perl_clone_params_new
Perl_parser_dup
@@ -735,7 +376,6 @@
Perl_gp_dup
Perl_he_dup
Perl_mg_dup
- Perl_mro_meta_dup
Perl_re_dup_guts
Perl_sv_dup
Perl_sv_dup_inc
@@ -744,21 +384,14 @@
Perl_sys_intern_dup
perl_clone
perl_clone_using
- Perl_sharedsv_find
- Perl_sharedsv_init
- Perl_sharedsv_lock
- Perl_sharedsv_new
- Perl_sharedsv_thrcnt_dec
- Perl_sharedsv_thrcnt_inc
- Perl_sharedsv_unlock
Perl_stashpv_hvname_match
Perl_regdupe_internal
Perl_newPADOP
- )];
+ );
}
unless ($define{'PERL_IMPLICIT_CONTEXT'}) {
- skip_symbols [qw(
+ ++$skip{$_} foreach qw(
PL_my_cxt_index
PL_my_cxt_list
PL_my_cxt_size
@@ -778,193 +411,138 @@
Perl_sv_setpvf_mg_nocontext
Perl_my_cxt_init
Perl_my_cxt_index
- )];
+ );
}
-unless ($define{'PERL_IMPLICIT_SYS'}) {
- skip_symbols [qw(
- perl_alloc_using
- perl_clone_using
- )];
-}
-
-unless ($define{'FAKE_THREADS'}) {
- skip_symbols [qw(PL_curthr)];
-}
-
-unless ($define{'PL_OP_SLAB_ALLOC'}) {
- skip_symbols [qw(
- PL_OpPtr
- PL_OpSlab
- PL_OpSpace
- Perl_Slab_Alloc
- Perl_Slab_Free
- )];
-}
-
-unless ($define{'PERL_DEBUG_READONLY_OPS'}) {
- skip_symbols [qw(
- PL_slab_count
- PL_slabs
- )];
-}
-
-unless ($define{'THREADS_HAVE_PIDS'}) {
- skip_symbols [qw(PL_ppid)];
-}
-
unless ($define{'PERL_NEED_APPCTX'}) {
- skip_symbols [qw(
- PL_appctx
- )];
+ ++$skip{PL_appctx};
}
unless ($define{'PERL_NEED_TIMESBASE'}) {
- skip_symbols [qw(
- PL_timesbase
- )];
+ ++$skip{PL_timesbase};
}
unless ($define{'DEBUG_LEAKING_SCALARS'}) {
- skip_symbols [qw(
- PL_sv_serial
- )];
+ ++$skip{PL_sv_serial};
}
unless ($define{'DEBUG_LEAKING_SCALARS_FORK_DUMP'}) {
- skip_symbols [qw(
- PL_dumper_fd
- )];
+ ++$skip{PL_dumper_fd};
}
+
unless ($define{'PERL_DONT_CREATE_GVSV'}) {
- skip_symbols [qw(
- Perl_gv_SVadd
- )];
+ ++$skip{Perl_gv_SVadd};
}
+
if ($define{'SPRINTF_RETURNS_STRLEN'}) {
- skip_symbols [qw(
- Perl_my_sprintf
- )];
+ ++$skip{Perl_my_sprintf};
}
+
unless ($define{'PERL_USES_PL_PIDSTATUS'}) {
- skip_symbols [qw(
- Perl_pidgone
- PL_pidstatus
- )];
+ ++$skip{PL_pidstatus};
}
unless ($define{'PERL_TRACK_MEMPOOL'}) {
- skip_symbols [qw(
- PL_memory_debug_header
- )];
+ ++$skip{PL_memory_debug_header};
}
-if ($define{'PERL_MAD'}) {
- skip_symbols [qw(
- PL_nextval
- PL_nexttype
- )];
-} else {
- skip_symbols [qw(
+unless ($define{PERL_MAD}) {
+ ++$skip{$_} foreach qw(
PL_madskills
PL_xmlfp
- PL_lasttoke
- PL_realtokenstart
- PL_faketokens
- PL_thismad
- PL_thistoken
- PL_thisopen
- PL_thisstuff
- PL_thisclose
- PL_thiswhite
- PL_nextwhite
- PL_skipwhite
- PL_endwhite
- PL_curforce
- Perl_pad_peg
- Perl_xmldump_indent
- Perl_xmldump_vindent
- Perl_xmldump_all
- Perl_xmldump_packsubs
- Perl_xmldump_sub
- Perl_xmldump_form
- Perl_xmldump_eval
- Perl_sv_catxmlsv
- Perl_sv_catxmlpvn
- Perl_sv_xmlpeek
- Perl_do_pmop_xmldump
- Perl_pmop_xmldump
- Perl_do_op_xmldump
- Perl_op_xmldump
- )];
+ );
}
unless ($define{'MULTIPLICITY'}) {
- skip_symbols [qw(
+ ++$skip{$_} foreach qw(
PL_interp_size
- PL_interp_size_5_10_0
- )];
+ PL_interp_size_5_18_0
+ );
}
unless ($define{'PERL_GLOBAL_STRUCT'}) {
- skip_symbols [qw(
- PL_global_struct_size
- )];
+ ++$skip{PL_global_struct_size};
}
unless ($define{'PERL_GLOBAL_STRUCT_PRIVATE'}) {
- skip_symbols [qw(
+ ++$skip{$_} foreach qw(
PL_my_cxt_keys
Perl_my_cxt_index
- )];
+ );
}
-unless ($define{'d_mmap'}) {
- skip_symbols [qw(
- PL_mmap_page_size
- )];
+unless ($define{HAS_MMAP}) {
+ ++$skip{PL_mmap_page_size};
}
-if ($define{'d_sigaction'}) {
- skip_symbols [qw(
- PL_sig_trapped
- )];
+if ($define{HAS_SIGACTION}) {
+ ++$skip{PL_sig_trapped};
+
+ if ($ARGS{PLATFORM} eq 'vms') {
+ # FAKE_PERSISTENT_SIGNAL_HANDLERS defined as !defined(HAS_SIGACTION)
+ ++$skip{PL_sig_ignoring};
+ ++$skip{PL_sig_handlers_initted} unless $define{KILL_BY_SIGPRC};
+ }
}
-if ($^O ne 'vms') {
- # VMS does its own thing for these symbols.
- skip_symbols [qw(PL_sig_handlers_initted
- PL_sig_ignoring
- PL_sig_defaulting)];
-}
+if ($ARGS{PLATFORM} eq 'vms' && !$define{KILL_BY_SIGPRC}) {
+ # FAKE_DEFAULT_SIGNAL_HANDLERS defined as KILL_BY_SIGPRC
+ ++$skip{Perl_csighandler_init};
+ ++$skip{Perl_my_kill};
+ ++$skip{Perl_sig_to_vmscondition};
+ ++$skip{PL_sig_defaulting};
+ ++$skip{PL_sig_handlers_initted} unless !$define{HAS_SIGACTION};
+}
-sub readvar {
- my $file = shift;
- my $proc = shift || sub { "PL_$_[2]" };
- open(VARS,$file) || die "Cannot open $file: $!\n";
- my @syms;
- while (<VARS>) {
- # All symbols have a Perl_ prefix because that's what embed.h
- # sticks in front of them. The A?I?S?C? is strictly speaking
- # wrong.
- push(@syms, &$proc($1,$2,$3)) if (/\bPERLVAR(A?I?S?C?)\(([IGT])(\w+)/);
- }
- close(VARS);
- return \@syms;
+unless ($define{USE_LOCALE_COLLATE}) {
+ ++$skip{$_} foreach qw(
+ PL_collation_ix
+ PL_collation_name
+ PL_collation_standard
+ PL_collxfrm_base
+ PL_collxfrm_mult
+ Perl_sv_collxfrm
+ Perl_sv_collxfrm_flags
+ );
}
+unless ($define{USE_LOCALE_NUMERIC}) {
+ ++$skip{$_} foreach qw(
+ PL_numeric_local
+ PL_numeric_name
+ PL_numeric_radix_sv
+ PL_numeric_standard
+ );
+}
+
+unless ($define{HAVE_INTERP_INTERN}) {
+ ++$skip{$_} foreach qw(
+ Perl_sys_intern_clear
+ Perl_sys_intern_dup
+ Perl_sys_intern_init
+ PL_sys_intern
+ );
+}
+
+if ($define{HAS_SIGNBIT}) {
+ ++$skip{Perl_signbit};
+}
+
if ($define{'PERL_GLOBAL_STRUCT'}) {
- my $global = readvar($perlvars_h);
- skip_symbols $global;
- emit_symbol('Perl_GetVars');
- emit_symbols [qw(PL_Vars PL_VarsPtr)] unless $CCTYPE eq 'GCC';
+ readvar('perlvars.h', \%skip);
+ # This seems like the least ugly way to cope with the fact that PL_sh_path
+ # is mentioned in perlvar.h and globvar.sym, and always exported.
+ delete $skip{PL_sh_path};
+ ++$export{Perl_GetVars};
+ try_symbols(qw(PL_Vars PL_VarsPtr))
+ unless $ARGS{CCTYPE} eq 'GCC' || $define{PERL_GLOBAL_STRUCT_PRIVATE};
} else {
- skip_symbols [qw(Perl_init_global_struct Perl_free_global_struct)];
+ ++$skip{$_} foreach qw(Perl_init_global_struct Perl_free_global_struct);
}
# functions from *.sym files
-my @syms = ($global_sym, $globvar_sym);
+my @syms = qw(globvar.sym);
# Symbols that are the public face of the PerlIO layers implementation
# These are in _addition to_ the public face of the abstraction
@@ -977,6 +555,7 @@
PerlIOBase_eof
PerlIOBase_error
PerlIOBase_fileno
+ PerlIOBase_open
PerlIOBase_noop_fail
PerlIOBase_noop_ok
PerlIOBase_popped
@@ -1043,7 +622,7 @@
Perl_PerlIO_unread
Perl_PerlIO_write
);
-if ($PLATFORM eq 'netware') {
+if ($ARGS{PLATFORM} eq 'netware') {
push(@layer_syms,'PL_def_layerlist','PL_known_layers','PL_perlio');
}
@@ -1050,18 +629,18 @@
if ($define{'USE_PERLIO'}) {
# Export the symols that make up the PerlIO abstraction, regardless
# of its implementation - read from a file
- push @syms, $perlio_sym;
+ push @syms, 'perlio.sym';
# This part is then dependent on how the abstraction is implemented
if ($define{'USE_SFIO'}) {
# Old legacy non-stdio "PerlIO"
- skip_symbols \@layer_syms;
- skip_symbols [qw(perlsio_binmode)];
+ ++$skip{$_} foreach @layer_syms;
+ ++$skip{perlsio_binmode};
# SFIO defines most of the PerlIO routines as macros
# So undo most of what $perlio_sym has just done - d'oh !
# Perhaps it would be better to list the ones which do exist
# And emit them
- skip_symbols [qw(
+ ++$skip{$_} foreach qw(
PerlIO_canset_cnt
PerlIO_clearerr
PerlIO_close
@@ -1129,29 +708,18 @@
PL_def_layerlist
PL_known_layers
PL_perlio
- )];
+ );
}
else {
# PerlIO with layers - export implementation
- emit_symbols \@layer_syms;
- emit_symbols [qw(perlsio_binmode)];
+ try_symbols(@layer_syms, 'perlsio_binmode');
}
- if ($define{'USE_ITHREADS'}) {
- emit_symbols [qw(
- PL_perlio_mutex
- )];
- }
- else {
- skip_symbols [qw(
- PL_perlio_mutex
- )];
- }
} else {
# -Uuseperlio
# Skip the PerlIO layer symbols - although
# nothing should have exported them anyway.
- skip_symbols \@layer_syms;
- skip_symbols [qw(
+ ++$skip{$_} foreach @layer_syms;
+ ++$skip{$_} foreach qw(
perlsio_binmode
PL_def_layerlist
PL_known_layers
@@ -1159,72 +727,101 @@
PL_perlio_debug_fd
PL_perlio_fd_refcnt
PL_perlio_fd_refcnt_size
- )];
+ PL_perlio_mutex
+ );
# Also do NOT add abstraction symbols from $perlio_sym
# abstraction is done as #define to stdio
- # Remaining remnants that _may_ be functions
- # are handled in <DATA>
+ # Remaining remnants that _may_ be functions are handled below.
}
-for my $syms (@syms) {
- open (GLOBAL, "<$syms") || die "failed to open $syms: $!\n";
- while (<GLOBAL>) {
- next if (!/^[A-Za-z]/);
- # Functions have a Perl_ prefix
- # Variables have a PL_ prefix
- chomp($_);
- my $symbol = ($syms =~ /var\.sym$/i ? "PL_" : "");
- $symbol .= $_;
- emit_symbol($symbol) unless exists $skip{$symbol};
+###############################################################################
+
+# At this point all skip lists should be completed, as we are about to test
+# many symbols against them.
+
+{
+ my %seen;
+ my ($embed) = setup_embed($ARGS{TARG_DIR});
+
+ foreach (@$embed) {
+ my ($flags, $retval, $func, @args) = @$_;
+ next unless $func;
+ if ($flags =~ /[AX]/ && $flags !~ /[xmi]/ || $flags =~ /b/) {
+ # public API, so export
+
+ # If a function is defined twice, for example before and after
+ # an #else, only export its name once. Important to do this test
+ # within the block, as the *first* definition may have flags which
+ # mean "don't export"
+ next if $seen{$func}++;
+ # Should we also skip adding the Perl_ prefix if $flags =~ /o/ ?
+ $func = "Perl_$func" if ($flags =~ /[pbX]/ && $func !~ /^Perl_/);
+ ++$export{$func} unless exists $skip{$func};
+ }
}
- close(GLOBAL);
}
+foreach (@syms) {
+ my $syms = $ARGS{TARG_DIR} . $_;
+ open my $global, '<', $syms or die "failed to open $syms: $!\n";
+ # Functions already have a Perl_ prefix
+ # Variables need a PL_ prefix
+ my $prefix = $syms =~ /var\.sym$/i ? 'PL_' : '';
+ while (<$global>) {
+ next unless /^([A-Za-z].*)/;
+ my $symbol = "$prefix$1";
+ ++$export{$symbol} unless exists $skip{$symbol};
+ }
+}
+
# variables
if ($define{'MULTIPLICITY'} && $define{PERL_GLOBAL_STRUCT}) {
- for my $f ($perlvars_h) {
- my $glob = readvar($f, sub { "Perl_" . $_[1] . $_[2] . "_ptr" });
- emit_symbols $glob;
- }
+ readvar('perlvars.h', \%export, sub { "Perl_" . $_[1] . $_[2] . "_ptr" });
# XXX AIX seems to want the perlvars.h symbols, for some reason
- if ($PLATFORM eq 'aix' or $PLATFORM eq 'os2') { # OS/2 needs PL_thr_key
- my $glob = readvar($perlvars_h);
- emit_symbols $glob;
+ if ($ARGS{PLATFORM} eq 'aix' or $ARGS{PLATFORM} eq 'os2') { # OS/2 needs PL_thr_key
+ readvar('perlvars.h', \%export);
}
}
else {
unless ($define{'PERL_GLOBAL_STRUCT'}) {
- my $glob = readvar($perlvars_h);
- emit_symbols $glob;
+ readvar('perlvars.h', \%export);
}
unless ($define{MULTIPLICITY}) {
- my $glob = readvar($intrpvar_h);
- emit_symbols $glob;
+ readvar('intrpvar.h', \%export);
}
}
-sub try_symbol {
- my $symbol = shift;
+# Oddities from PerlIO
+# All have alternate implementations in perlio.c, so always exist.
+# Should they be considered to be part of the API?
+try_symbols(qw(
+ PerlIO_binmode
+ PerlIO_getpos
+ PerlIO_init
+ PerlIO_setpos
+ PerlIO_sprintf
+ PerlIO_tmpfile
+ PerlIO_vsprintf
+ ));
- return if $symbol !~ /^[A-Za-z_]/;
- return if $symbol =~ /^\#/;
- $symbol =~s/\r//g;
- chomp($symbol);
- return if exists $skip{$symbol};
- emit_symbol($symbol);
+if ($ARGS{PLATFORM} eq 'win32') {
+ try_symbols(qw(
+ win32_free_childdir
+ win32_free_childenv
+ win32_get_childdir
+ win32_get_childenv
+ win32_spawnvp
+ ));
}
-while (<DATA>) {
- try_symbol($_);
+if ($ARGS{PLATFORM} eq 'wince') {
+ ++$skip{'win32_isatty'}; # commit 4342f4d6df is win32-only
}
-if ($PLATFORM =~ /^win(?:32|ce)$/) {
- foreach my $symbol (qw(
- setuid
- setgid
- boot_DynaLoader
+if ($ARGS{PLATFORM} =~ /^win(?:32|ce)$/) {
+ try_symbols(qw(
Perl_init_os_extras
Perl_thread_create
Perl_win32_init
@@ -1252,7 +849,6 @@
win32_isatty
win32_read
win32_write
- win32_spawnvp
win32_mkdir
win32_rmdir
win32_chdir
@@ -1338,11 +934,7 @@
win32_getpid
win32_crypt
win32_dynaload
- win32_get_childenv
- win32_free_childenv
win32_clearenv
- win32_get_childdir
- win32_free_childdir
win32_stdin
win32_stdout
win32_stderr
@@ -1383,28 +975,164 @@
win32_puts
win32_getchar
win32_putchar
- ))
- {
- try_symbol($symbol);
- }
- if ($CCTYPE eq "BORLAND") {
- try_symbol('_matherr');
- }
+ ));
}
-elsif ($PLATFORM eq 'os2') {
- my (%mapped, @missing);
- open MAP, 'miniperl.map' or die 'Cannot read miniperl.map';
- /^\s*[\da-f:]+\s+(\w+)/i and $mapped{$1}++ foreach <MAP>;
- close MAP or die 'Cannot close miniperl.map';
-
- @missing = grep { !exists $mapped{$_} }
- keys %export;
- @missing = grep { !exists $exportperlmalloc{$_} } @missing;
- delete $export{$_} foreach @missing;
+elsif ($ARGS{PLATFORM} eq 'vms') {
+ try_symbols(qw(
+ Perl_cando
+ Perl_cando_by_name
+ Perl_closedir
+ Perl_csighandler_init
+ Perl_do_rmdir
+ Perl_fileify_dirspec
+ Perl_fileify_dirspec_ts
+ Perl_fileify_dirspec_utf8
+ Perl_fileify_dirspec_utf8_ts
+ Perl_flex_fstat
+ Perl_flex_lstat
+ Perl_flex_stat
+ Perl_kill_file
+ Perl_my_chdir
+ Perl_my_chmod
+ Perl_my_crypt
+ Perl_my_endpwent
+ Perl_my_fclose
+ Perl_my_fdopen
+ Perl_my_fgetname
+ Perl_my_flush
+ Perl_my_fwrite
+ Perl_my_gconvert
+ Perl_my_getenv
+ Perl_my_getenv_len
+ Perl_my_getlogin
+ Perl_my_getpwnam
+ Perl_my_getpwuid
+ Perl_my_gmtime
+ Perl_my_kill
+ Perl_my_localtime
+ Perl_my_mkdir
+ Perl_my_sigaction
+ Perl_my_symlink
+ Perl_my_time
+ Perl_my_tmpfile
+ Perl_my_trnlnm
+ Perl_my_utime
+ Perl_my_waitpid
+ Perl_opendir
+ Perl_pathify_dirspec
+ Perl_pathify_dirspec_ts
+ Perl_pathify_dirspec_utf8
+ Perl_pathify_dirspec_utf8_ts
+ Perl_readdir
+ Perl_readdir_r
+ Perl_rename
+ Perl_rmscopy
+ Perl_rmsexpand
+ Perl_rmsexpand_ts
+ Perl_rmsexpand_utf8
+ Perl_rmsexpand_utf8_ts
+ Perl_seekdir
+ Perl_sig_to_vmscondition
+ Perl_telldir
+ Perl_tounixpath
+ Perl_tounixpath_ts
+ Perl_tounixpath_utf8
+ Perl_tounixpath_utf8_ts
+ Perl_tounixspec
+ Perl_tounixspec_ts
+ Perl_tounixspec_utf8
+ Perl_tounixspec_utf8_ts
+ Perl_tovmspath
+ Perl_tovmspath_ts
+ Perl_tovmspath_utf8
+ Perl_tovmspath_utf8_ts
+ Perl_tovmsspec
+ Perl_tovmsspec_ts
+ Perl_tovmsspec_utf8
+ Perl_tovmsspec_utf8_ts
+ Perl_trim_unixpath
+ Perl_vms_case_tolerant
+ Perl_vms_do_aexec
+ Perl_vms_do_exec
+ Perl_vms_image_init
+ Perl_vms_realpath
+ Perl_vmssetenv
+ Perl_vmssetuserlnm
+ Perl_vmstrnenv
+ PerlIO_openn
+ ));
}
-elsif ($PLATFORM eq 'netware') {
-foreach my $symbol (qw(
- boot_DynaLoader
+elsif ($ARGS{PLATFORM} eq 'os2') {
+ try_symbols(qw(
+ ctermid
+ get_sysinfo
+ Perl_OS2_init
+ Perl_OS2_init3
+ Perl_OS2_term
+ OS2_Perl_data
+ dlopen
+ dlsym
+ dlerror
+ dlclose
+ dup2
+ dup
+ my_tmpfile
+ my_tmpnam
+ my_flock
+ my_rmdir
+ my_mkdir
+ my_getpwuid
+ my_getpwnam
+ my_getpwent
+ my_setpwent
+ my_endpwent
+ fork_with_resources
+ croak_with_os2error
+ setgrent
+ endgrent
+ getgrent
+ malloc_mutex
+ threads_mutex
+ nthreads
+ nthreads_cond
+ os2_cond_wait
+ os2_stat
+ os2_execname
+ async_mssleep
+ msCounter
+ InfoTable
+ pthread_join
+ pthread_create
+ pthread_detach
+ XS_Cwd_change_drive
+ XS_Cwd_current_drive
+ XS_Cwd_extLibpath
+ XS_Cwd_extLibpath_set
+ XS_Cwd_sys_abspath
+ XS_Cwd_sys_chdir
+ XS_Cwd_sys_cwd
+ XS_Cwd_sys_is_absolute
+ XS_Cwd_sys_is_relative
+ XS_Cwd_sys_is_rooted
+ XS_DynaLoader_mod2fname
+ XS_File__Copy_syscopy
+ Perl_Register_MQ
+ Perl_Deregister_MQ
+ Perl_Serve_Messages
+ Perl_Process_Messages
+ init_PMWIN_entries
+ PMWIN_entries
+ Perl_hab_GET
+ loadByOrdinal
+ pExtFCN
+ os2error
+ ResetWinError
+ CroakWinError
+ PL_do_undump
+ ));
+}
+elsif ($ARGS{PLATFORM} eq 'netware') {
+ try_symbols(qw(
Perl_init_os_extras
Perl_thread_create
Perl_nw5_init
@@ -1539,75 +1267,100 @@
Perl_sv_2pv
nw_freeenviron
Remove_Thread_Ctx
- ))
- {
- try_symbol($symbol);
- }
+ ));
}
-# records of type boot_module for statically linked modules (except Dynaloader)
-$static_ext =~ s/\//__/g;
-$static_ext =~ s/\bDynaLoader\b//;
-my @stat_mods = map {"boot_$_"} grep {/\S/} split /\s+/, $static_ext;
-foreach my $symbol (@stat_mods)
- {
- try_symbol($symbol);
- }
+# When added this code was only run for Win32 and WinCE
+# Currently only Win32 links static extensions into the shared library.
+# The WinCE makefile doesn't appear to support static extensions, so this code
+# can't have any effect there.
+# The NetWare Makefile doesn't support static extensions (and hardcodes the
+# list of dynamic extensions, and the rules to build them)
+# For *nix (and presumably OS/2) with a shared libperl, Makefile.SH compiles
+# static extensions with -fPIC, but links them to perl, not libperl.so
+# The VMS build scripts don't yet implement static extensions at all.
-try_symbol("init_Win32CORE") if $static_ext =~ /\bWin32CORE\b/;
+if ($ARGS{PLATFORM} =~ /^win(?:32|ce)$/) {
+ # records of type boot_module for statically linked modules (except Dynaloader)
+ my $static_ext = $Config{static_ext} // "";
+ $static_ext =~ s/\//__/g;
+ $static_ext =~ s/\bDynaLoader\b//;
+ try_symbols(map {"boot_$_"} grep {/\S/} split /\s+/, $static_ext);
+ try_symbols("init_Win32CORE") if $static_ext =~ /\bWin32CORE\b/;
+}
-# Now all symbols should be defined because
-# next we are going to output them.
+if ($ARGS{PLATFORM} eq 'os2') {
+ my (%mapped, @missing);
+ open MAP, 'miniperl.map' or die 'Cannot read miniperl.map';
+ /^\s*[\da-f:]+\s+(\w+)/i and $mapped{$1}++ foreach <MAP>;
+ close MAP or die 'Cannot close miniperl.map';
-foreach my $symbol (sort keys %export) {
- output_symbol($symbol);
+ @missing = grep { !exists $mapped{$_} }
+ keys %export;
+ @missing = grep { !exists $exportperlmalloc{$_} } @missing;
+ delete $export{$_} foreach @missing;
}
-if ($PLATFORM eq 'os2') {
- print <<EOP;
- dll_perlmain=main
- fill_extLibpath
- dir_subst
- Perl_OS2_handler_install
+###############################################################################
-; LAST_ORDINAL=$sym_ord
-EOP
-}
+# Now all symbols should be defined because next we are going to output them.
-sub emit_symbol {
- my $symbol = shift;
- chomp($symbol);
- $export{$symbol} = 1;
+# Start with platform specific headers:
+
+if ($ARGS{PLATFORM} =~ /^win(?:32|ce)$/) {
+ my $dll = $define{PERL_DLL} ? $define{PERL_DLL} =~ s/\.dll$//ir
+ : "perl$Config{api_revision}$Config{api_version}";
+ print "LIBRARY $dll\n";
+ # The DESCRIPTION module definition file statement is not supported
+ # by VC7 onwards.
+ if ($ARGS{CCTYPE} =~ /^(?:MSVC60|GCC)$/) {
+ print "DESCRIPTION 'Perl interpreter'\n";
+ }
+ print "EXPORTS\n";
}
+elsif ($ARGS{PLATFORM} eq 'os2') {
+ (my $v = $]) =~ s/(\d\.\d\d\d)(\d\d)$/$1_$2/;
+ $v .= '-thread' if $Config{archname} =~ /-thread/;
+ (my $dll = $define{PERL_DLL}) =~ s/\.dll$//i;
+ $v .= "\@$Config{perl_patchlevel}" if $Config{perl_patchlevel};
+ my $d = "DESCRIPTION '\@#perl5-porters\@perl.org:$v#\@ Perl interpreter, configured as $Config{config_args}'";
+ $d = substr($d, 0, 249) . "...'" if length $d > 253;
+ print <<"---EOP---";
+LIBRARY '$dll' INITINSTANCE TERMINSTANCE
+$d
+STACKSIZE 32768
+CODE LOADONCALL
+DATA LOADONCALL NONSHARED MULTIPLE
+EXPORTS
+---EOP---
+}
+elsif ($ARGS{PLATFORM} eq 'aix') {
+ my $OSVER = `uname -v`;
+ chop $OSVER;
+ my $OSREL = `uname -r`;
+ chop $OSREL;
+ if ($OSVER > 4 || ($OSVER == 4 && $OSREL >= 3)) {
+ print "#! ..\n";
+ } else {
+ print "#!\n";
+ }
+}
+elsif ($ARGS{PLATFORM} eq 'netware') {
+ if ($ARGS{FILETYPE} eq 'def') {
+ print "LIBRARY perl$Config{api_revision}$Config{api_version}\n";
+ print "DESCRIPTION 'Perl interpreter for NetWare'\n";
+ print "EXPORTS\n";
+ }
+}
-sub output_symbol {
- my $symbol = shift;
- if ($PLATFORM =~ /^win(?:32|ce)$/) {
- $symbol = "_$symbol" if $CCTYPE eq 'BORLAND';
+# Then the symbols
+
+my @symbols = $fold ? sort {lc $a cmp lc $b} keys %export : sort keys %export;
+foreach my $symbol (@symbols) {
+ if ($ARGS{PLATFORM} =~ /^win(?:32|ce)$/) {
print "\t$symbol\n";
-# XXX: binary compatibility between compilers is an exercise
-# in frustration :-(
-# if ($CCTYPE eq "BORLAND") {
-# # workaround Borland quirk by exporting both the straight
-# # name and a name with leading underscore. Note the
-# # alias *must* come after the symbol itself, if both
-# # are to be exported. (Linker bug?)
-# print "\t_$symbol\n";
-# print "\t$symbol = _$symbol\n";
-# }
-# elsif ($CCTYPE eq 'GCC') {
-# # Symbols have leading _ whole process is $%@"% slow
-# # so skip aliases for now
-# nprint "\t$symbol\n";
-# }
-# else {
-# # for binary coexistence, export both the symbol and
-# # alias with leading underscore
-# print "\t$symbol\n";
-# print "\t_$symbol = $symbol\n";
-# }
}
- elsif ($PLATFORM eq 'os2') {
+ elsif ($ARGS{PLATFORM} eq 'os2') {
printf qq( %-31s \@%s\n),
qq("$symbol"), $ordinal{$symbol} || ++$sym_ord;
printf qq( %-31s \@%s\n),
@@ -1615,22 +1368,24 @@
$ordinal{$exportperlmalloc{$symbol}} || ++$sym_ord
if $exportperlmalloc and exists $exportperlmalloc{$symbol};
}
- elsif ($PLATFORM eq 'aix') {
+ elsif ($ARGS{PLATFORM} eq 'netware') {
+ print "\t$symbol,\n";
+ } else {
print "$symbol\n";
}
- elsif ($PLATFORM eq 'netware') {
- print "\t$symbol,\n";
- }
}
+# Then platform specific footers.
+
+if ($ARGS{PLATFORM} eq 'os2') {
+ print <<EOP;
+ dll_perlmain=main
+ fill_extLibpath
+ dir_subst
+ Perl_OS2_handler_install
+
+; LAST_ORDINAL=$sym_ord
+EOP
+}
+
1;
-__DATA__
-# Oddities from PerlIO
-PerlIO_binmode
-PerlIO_getpos
-PerlIO_init
-PerlIO_setpos
-PerlIO_sprintf
-PerlIO_sv_dup
-PerlIO_tmpfile
-PerlIO_vsprintf
Property changes on: trunk/contrib/perl/makedef.pl
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/makedepend.SH
===================================================================
--- trunk/contrib/perl/makedepend.SH 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/makedepend.SH 2013-12-02 21:18:17 UTC (rev 6438)
@@ -131,13 +131,38 @@
*) finc= ;;
esac
$echo "Finding dependencies for $filebase$_o."
- ( $echo "#line 1 \"$file\""; \
+ # Below, we strip out all but preprocessor directives.
+ # We have to take care of situations like
+ # #if defined(FOO) BAR /* comment line 1
+ # more comment lines */
+ # If we just delete text starting from the '/*' to the end of line, we will
+ # screw up cases like
+ # #if defined(FOO) /* comment */ \
+ # && 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 '/^[ ]*#/{' \
-e 's|/\*.*$||' \
- -e 's|\\$||' \
-e p \
-e '}' ) >UU/$file.c
Property changes on: trunk/contrib/perl/makedepend.SH
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/malloc.c
===================================================================
--- trunk/contrib/perl/malloc.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/malloc.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -5,7 +5,7 @@
/*
* 'The Chamber of Records,' said Gimli. 'I guess that is where we now stand.'
*
- * [p.321 of _The Lord of the Rings_, II/v: "The Bridge of Khazad-D\xFBm"]
+ * [p.321 of _The Lord of the Rings_, II/v: "The Bridge of Khazad-Dûm"]
*/
/* This file contains Perl's own implementation of the malloc library.
@@ -15,9 +15,8 @@
*/
/*
- Here are some notes on configuring Perl's malloc. (For non-perl
- usage see below.)
-
+ Here are some notes on configuring Perl's malloc.
+
There are two macros which serve as bulk disablers of advanced
features of this malloc: NO_FANCY_MALLOC, PLAIN_MALLOC (undef by
default). Look in the list of default values below to understand
@@ -40,10 +39,10 @@
# Enable code for an emergency memory pool in $^M. See perlvar.pod
# for a description of $^M.
- PERL_EMERGENCY_SBRK (!PLAIN_MALLOC && (PERL_CORE || !NO_MALLOC_DYNAMIC_CFG))
+ PERL_EMERGENCY_SBRK !PLAIN_MALLOC
# Enable code for printing memory statistics.
- DEBUGGING_MSTATS (!PLAIN_MALLOC && PERL_CORE)
+ DEBUGGING_MSTATS !PLAIN_MALLOC
# Move allocation info for small buckets into separate areas.
# Memory optimization (especially for small allocations, of the
@@ -163,73 +162,7 @@
*/
-/*
- If used outside of Perl environment, it may be useful to redefine
- the following macros (listed below with defaults):
- # Type of address returned by allocation functions
- Malloc_t void *
-
- # Type of size argument for allocation functions
- MEM_SIZE unsigned long
-
- # size of void*
- PTRSIZE 4
-
- # Maximal value in LONG
- LONG_MAX 0x7FFFFFFF
-
- # Unsigned integer type big enough to keep a pointer
- UV unsigned long
-
- # Signed integer of the same sizeof() as UV
- IV long
-
- # Type of pointer with 1-byte granularity
- caddr_t char *
-
- # Type returned by free()
- Free_t void
-
- # Conversion of pointer to integer
- PTR2UV(ptr) ((UV)(ptr))
-
- # Conversion of integer to pointer
- INT2PTR(type, i) ((type)(i))
-
- # printf()-%-Conversion of UV to pointer
- UVuf "lu"
-
- # printf()-%-Conversion of UV to hex pointer
- UVxf "lx"
-
- # Alignment to use
- MEM_ALIGNBYTES 4
-
- # Very fatal condition reporting function (cannot call any )
- fatalcroak(arg) write(2,arg,strlen(arg)) + exit(2)
-
- # Fatal error reporting function
- croak(format, arg) warn(idem) + exit(1)
-
- # Fatal error reporting function
- croak2(format, arg1, arg2) warn2(idem) + exit(1)
-
- # Error reporting function
- warn(format, arg) fprintf(stderr, idem)
-
- # Error reporting function
- warn2(format, arg1, arg2) fprintf(stderr, idem)
-
- # Locking/unlocking for MT operation
- MALLOC_LOCK MUTEX_LOCK(&PL_malloc_mutex)
- MALLOC_UNLOCK MUTEX_UNLOCK(&PL_malloc_mutex)
-
- # Locking/unlocking mutex for MT operation
- MUTEX_LOCK(l) void
- MUTEX_UNLOCK(l) void
- */
-
#ifdef HAVE_MALLOC_CFG_H
# include "malloc_cfg.h"
#endif
@@ -253,10 +186,10 @@
# ifndef TWO_POT_OPTIMIZE
# define TWO_POT_OPTIMIZE
# endif
-# if (defined(PERL_CORE) || !defined(NO_MALLOC_DYNAMIC_CFG)) && !defined(PERL_EMERGENCY_SBRK)
+# ifndef PERL_EMERGENCY_SBRK
# define PERL_EMERGENCY_SBRK
# endif
-# if defined(PERL_CORE) && !defined(DEBUGGING_MSTATS)
+# ifndef DEBUGGING_MSTATS
# define DEBUGGING_MSTATS
# endif
#endif
@@ -264,14 +197,7 @@
#define MIN_BUC_POW2 (sizeof(void*) > 4 ? 3 : 2) /* Allow for 4-byte arena. */
#define MIN_BUCKET (MIN_BUC_POW2 * BUCKETS_PER_POW2)
-#if !(defined(I286) || defined(atarist))
- /* take 2k unless the block is bigger than that */
-# define LOG_OF_MIN_ARENA 11
-#else
- /* take 16k unless the block is bigger than that
- (80286s like large segments!), probably good on the atari too */
-# define LOG_OF_MIN_ARENA 14
-#endif
+#define LOG_OF_MIN_ARENA 11
#if defined(DEBUGGING) && !defined(NO_RCHECK)
# define RCHECK
@@ -309,131 +235,23 @@
*
*/
-#ifdef PERL_CORE
-# include "EXTERN.h"
-# define PERL_IN_MALLOC_C
-# include "perl.h"
-# if defined(PERL_IMPLICIT_CONTEXT)
+#include "EXTERN.h"
+#define PERL_IN_MALLOC_C
+#include "perl.h"
+#if defined(PERL_IMPLICIT_CONTEXT)
# define croak Perl_croak_nocontext
# define croak2 Perl_croak_nocontext
# define warn Perl_warn_nocontext
# define warn2 Perl_warn_nocontext
-# else
+#else
# define croak2 croak
# define warn2 warn
-# endif
-# if defined(USE_5005THREADS) || defined(USE_ITHREADS)
+#endif
+#ifdef USE_ITHREADS
# define PERL_MAYBE_ALIVE PL_thr_key
-# else
+#else
# define PERL_MAYBE_ALIVE 1
-# endif
-#else
-# ifdef PERL_FOR_X2P
-# include "../EXTERN.h"
-# include "../perl.h"
-# else
-# include <stdlib.h>
-# include <stdio.h>
-# include <memory.h>
-# ifdef OS2
-# include <io.h>
-# endif
-# include <string.h>
-# ifndef Malloc_t
-# define Malloc_t void *
-# endif
-# ifndef PTRSIZE
-# define PTRSIZE 4
-# endif
-# ifndef MEM_SIZE
-# define MEM_SIZE unsigned long
-# endif
-# ifndef LONG_MAX
-# define LONG_MAX 0x7FFFFFFF
-# endif
-# ifndef UV
-# define UV unsigned long
-# endif
-# ifndef IV
-# define IV long
-# endif
-# ifndef caddr_t
-# define caddr_t char *
-# endif
-# ifndef Free_t
-# define Free_t void
-# endif
-# define Copy(s,d,n,t) (void)memcpy((char*)(d),(char*)(s), (n) * sizeof(t))
-# define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t))
-# define PerlEnv_getenv getenv
-# define PerlIO_printf fprintf
-# define PerlIO_stderr() stderr
-# define PerlIO_puts(f,s) fputs(s,f)
-# ifndef INT2PTR
-# define INT2PTR(t,i) ((t)(i))
-# endif
-# ifndef PTR2UV
-# define PTR2UV(p) ((UV)(p))
-# endif
-# ifndef UVuf
-# define UVuf "lu"
-# endif
-# ifndef UVxf
-# define UVxf "lx"
-# endif
-# ifndef MEM_ALIGNBYTES
-# define MEM_ALIGNBYTES 4
-# endif
-# endif
-# ifndef croak /* make depend */
-# define croak(mess, arg) (warn((mess), (arg)), exit(1))
-# endif
-# ifndef croak2 /* make depend */
-# define croak2(mess, arg1, arg2) (warn2((mess), (arg1), (arg2)), exit(1))
-# endif
-# ifndef warn
-# define warn(mess, arg) fprintf(stderr, (mess), (arg))
-# endif
-# ifndef warn2
-# define warn2(mess, arg1, arg2) fprintf(stderr, (mess), (arg1), (arg2))
-# endif
-# ifdef DEBUG_m
-# undef DEBUG_m
-# endif
-# define DEBUG_m(a)
-# ifdef DEBUGGING
-# undef DEBUGGING
-# endif
-# ifndef pTHX
-# define pTHX void
-# define pTHX_
-# ifdef HASATTRIBUTE_UNUSED
-# define dTHX extern int Perl___notused PERL_UNUSED_DECL
-# else
-# define dTHX extern int Perl___notused
-# endif
-# define WITH_THX(s) s
-# endif
-# ifndef PERL_GET_INTERP
-# define PERL_GET_INTERP PL_curinterp
-# endif
-# define PERL_MAYBE_ALIVE 1
-# ifndef Perl_malloc
-# define Perl_malloc malloc
-# endif
-# ifndef Perl_mfree
-# define Perl_mfree free
-# endif
-# ifndef Perl_realloc
-# define Perl_realloc realloc
-# endif
-# ifndef Perl_calloc
-# define Perl_calloc calloc
-# endif
-# ifndef Perl_strdup
-# define Perl_strdup strdup
-# endif
-#endif /* defined PERL_CORE */
+#endif
#ifndef MUTEX_LOCK
# define MUTEX_LOCK(l)
@@ -551,8 +369,7 @@
*/
#define u_short unsigned short
-/* 286 and atarist like big chunks, which gives too much overhead. */
-#if (defined(RCHECK) || defined(I286) || defined(atarist)) && defined(PACK_MALLOC)
+#if defined(RCHECK) && defined(PACK_MALLOC)
# undef PACK_MALLOC
#endif
@@ -630,7 +447,7 @@
char c;
void *p;
};
-# define ALIGN_SMALL ((int)((caddr_t)&(((struct aligner*)0)->p)))
+# define ALIGN_SMALL ((IV)((caddr_t)&(((struct aligner*)0)->p)))
#else
# define ALIGN_SMALL MEM_ALIGNBYTES
#endif
@@ -938,7 +755,7 @@
# define POW2_OPTIMIZE_SURPLUS(bucket) 0
#endif /* !TWO_POT_OPTIMIZE */
-#if defined(HAS_64K_LIMIT) && defined(PERL_CORE)
+#ifdef HAS_64K_LIMIT
# define BARK_64K_LIMIT(what,nbytes,size) \
if (nbytes > 0xffff) { \
PerlIO_printf(PerlIO_stderr(), \
@@ -945,9 +762,9 @@
"%s too large: %lx\n", what, size); \
my_exit(1); \
}
-#else /* !HAS_64K_LIMIT || !PERL_CORE */
+#else /* !HAS_64K_LIMIT */
# define BARK_64K_LIMIT(what,nbytes,size)
-#endif /* !HAS_64K_LIMIT || !PERL_CORE */
+#endif /* !HAS_64K_LIMIT */
#ifndef MIN_SBRK
# define MIN_SBRK 2048
@@ -970,7 +787,7 @@
# define SBRK_FAILURE_PRICE 50
#endif
-static void morecore (register int bucket);
+static void morecore (int bucket);
# if defined(DEBUGGING)
static void botch (const char *diag, const char *s, const char *file, int line);
# endif
@@ -980,8 +797,6 @@
static union overhead *getpages (MEM_SIZE needed, int *nblksp, int bucket);
static int getpages_adjacent(MEM_SIZE require);
-#ifdef PERL_CORE
-
#ifdef I_MACH_CTHREADS
# undef MUTEX_LOCK
# define MUTEX_LOCK(m) STMT_START { if (*m) mutex_lock(*m); } STMT_END
@@ -989,8 +804,6 @@
# define MUTEX_UNLOCK(m) STMT_START { if (*m) mutex_unlock(*m); } STMT_END
#endif
-#endif /* defined PERL_CORE */
-
#ifndef PTRSIZE
# define PTRSIZE sizeof(void*)
#endif
@@ -1148,7 +961,6 @@
# define emergency_sbrk_croak croak2
# endif
-# ifdef PERL_CORE
static char *
perl_get_emergency_buffer(IV *size)
{
@@ -1178,10 +990,7 @@
*size = malloced_size(pv) + M_OVERHEAD;
return pv - sizeof(union overhead);
}
-# define PERL_GET_EMERGENCY_BUFFER(p) perl_get_emergency_buffer(p)
-# else
-# define PERL_GET_EMERGENCY_BUFFER(p) NULL
-# endif /* defined PERL_CORE */
+# define PERL_GET_EMERGENCY_BUFFER(p) perl_get_emergency_buffer(p)
# ifndef NO_MALLOC_DYNAMIC_CFG
static char *
@@ -1274,7 +1083,7 @@
do_croak:
MALLOC_UNLOCK;
emergency_sbrk_croak("Out of memory during request for %"UVuf" bytes, total sbrk() is %"UVuf" bytes", (UV)size, (UV)(goodsbrk + sbrk_slack));
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
return NULL;
}
@@ -1282,11 +1091,8 @@
# define emergency_sbrk(size) -1
#endif /* defined PERL_EMERGENCY_SBRK */
-static void
-write2(const char *mess)
-{
- write(2, mess, strlen(mess));
-}
+/* Don't use PerlIO buffered writes as they allocate memory. */
+#define MYMALLOC_WRITE2STDERR(s) PerlLIO_write(PerlIO_fileno(PerlIO_stderr()),s,strlen(s))
#ifdef DEBUGGING
#undef ASSERT
@@ -1304,13 +1110,13 @@
"assertion botched (%s?): %s %s:%d\n",
diag, s, file, line) != 0) {
do_write: /* Can be initializing interpreter */
- write2("assertion botched (");
- write2(diag);
- write2("?): ");
- write2(s);
- write2(" (");
- write2(file);
- write2(":");
+ MYMALLOC_WRITE2STDERR("assertion botched (");
+ MYMALLOC_WRITE2STDERR(diag);
+ MYMALLOC_WRITE2STDERR("?): ");
+ MYMALLOC_WRITE2STDERR(s);
+ MYMALLOC_WRITE2STDERR(" (");
+ MYMALLOC_WRITE2STDERR(file);
+ MYMALLOC_WRITE2STDERR(":");
{
char linebuf[10];
char *s = linebuf + sizeof(linebuf) - 1;
@@ -1319,9 +1125,9 @@
do {
*--s = '0' + (n % 10);
} while (n /= 10);
- write2(s);
+ MYMALLOC_WRITE2STDERR(s);
}
- write2(")\n");
+ MYMALLOC_WRITE2STDERR(")\n");
}
PerlProc_abort();
}
@@ -1454,8 +1260,8 @@
Perl_malloc(size_t nbytes)
{
dVAR;
- register union overhead *p;
- register int bucket;
+ union overhead *p;
+ int bucket;
#if defined(DEBUGGING) || defined(RCHECK)
MEM_SIZE size = nbytes;
@@ -1477,12 +1283,11 @@
morecore(bucket);
if ((p = nextf[bucket]) == NULL) {
MALLOC_UNLOCK;
-#ifdef PERL_CORE
{
dTHX;
if (!PL_nomemok) {
#if defined(PLAIN_MALLOC) && defined(NO_FANCY_MALLOC)
- PerlIO_puts(PerlIO_stderr(),"Out of memory!\n");
+ MYMALLOC_WRITE2STDERR("Out of memory!\n");
#else
char buff[80];
char *eb = buff + sizeof(buff) - 1;
@@ -1489,7 +1294,7 @@
char *s = eb;
size_t n = nbytes;
- PerlIO_puts(PerlIO_stderr(),"Out of memory during request for ");
+ MYMALLOC_WRITE2STDERR("Out of memory during request for ");
#if defined(DEBUGGING) || defined(RCHECK)
n = size;
#endif
@@ -1497,20 +1302,19 @@
do {
*--s = '0' + (n % 10);
} while (n /= 10);
- PerlIO_puts(PerlIO_stderr(),s);
- PerlIO_puts(PerlIO_stderr()," bytes, total sbrk() is ");
+ MYMALLOC_WRITE2STDERR(s);
+ MYMALLOC_WRITE2STDERR(" bytes, total sbrk() is ");
s = eb;
n = goodsbrk + sbrk_slack;
do {
*--s = '0' + (n % 10);
} while (n /= 10);
- PerlIO_puts(PerlIO_stderr(),s);
- PerlIO_puts(PerlIO_stderr()," bytes!\n");
+ MYMALLOC_WRITE2STDERR(s);
+ MYMALLOC_WRITE2STDERR(" bytes!\n");
#endif /* defined(PLAIN_MALLOC) && defined(NO_FANCY_MALLOC) */
my_exit(1);
}
}
-#endif
return (NULL);
}
@@ -1691,7 +1495,7 @@
require = FIRST_SBRK;
else if (require < (MEM_SIZE)MIN_SBRK) require = MIN_SBRK;
- if (require < goodsbrk * MIN_SBRK_FRAC1000 / 1000)
+ if (require < (Size_t)(goodsbrk * MIN_SBRK_FRAC1000 / 1000))
require = goodsbrk * MIN_SBRK_FRAC1000 / 1000;
require = ((require - 1 + MIN_SBRK) / MIN_SBRK) * MIN_SBRK;
} else {
@@ -1734,8 +1538,6 @@
/* Second, check alignment. */
slack = 0;
-#if !defined(atarist) /* on the atari we dont have to worry about this */
-# ifndef I286 /* The sbrk(0) call on the I286 always returns the next segment */
/* WANTED_ALIGNMENT may be more than NEEDED_ALIGNMENT, but this may
improve performance of memory access. */
if (PTR2UV(cp) & (WANTED_ALIGNMENT - 1)) { /* Not aligned. */
@@ -1742,8 +1544,6 @@
slack = WANTED_ALIGNMENT - (PTR2UV(cp) & (WANTED_ALIGNMENT - 1));
add += slack;
}
-# endif
-#endif /* !atarist */
if (add) {
DEBUG_m(PerlIO_printf(Perl_debug_log,
@@ -1804,7 +1604,6 @@
fatalcroak("Misalignment of sbrk()\n");
else
# endif
-#ifndef I286 /* Again, this should always be ok on an 80286 */
if (PTR2UV(ovp) & (MEM_ALIGNBYTES - 1)) {
DEBUG_m(PerlIO_printf(Perl_debug_log,
"fixing sbrk(): %d bytes off machine alignment\n",
@@ -1817,7 +1616,6 @@
sbrk_slack += (1 << (bucket >> BUCKET_POW2_SHIFT));
# endif
}
-#endif
; /* Finish "else" */
sbrked_remains = require - needed;
last_op = cp;
@@ -1877,13 +1675,13 @@
* Allocate more memory to the indicated bucket.
*/
static void
-morecore(register int bucket)
+morecore(int bucket)
{
dVAR;
- register union overhead *ovp;
- register int rnu; /* 2^rnu bytes will be requested */
+ union overhead *ovp;
+ int rnu; /* 2^rnu bytes will be requested */
int nblks; /* become nblks blocks of the desired size */
- register MEM_SIZE siz, needed;
+ MEM_SIZE siz, needed;
static int were_called = 0;
if (nextf[bucket])
@@ -1913,9 +1711,10 @@
}
}
if (t && *t) {
- write2("Unrecognized part of PERL_MALLOC_OPT: \"");
- write2(t);
- write2("\"\n");
+ dTHX;
+ MYMALLOC_WRITE2STDERR("Unrecognized part of PERL_MALLOC_OPT: \"");
+ MYMALLOC_WRITE2STDERR(t);
+ MYMALLOC_WRITE2STDERR("\"\n");
}
if (changed)
MallocCfg[MallocCfg_cfg_env_read] = 1;
@@ -2015,8 +1814,8 @@
Perl_mfree(Malloc_t where)
{
dVAR;
- register MEM_SIZE size;
- register union overhead *ovp;
+ MEM_SIZE size;
+ union overhead *ovp;
char *cp = (char*)where;
#ifdef PACK_MALLOC
u_char bucket;
@@ -2053,7 +1852,6 @@
if (!bad_free_warn)
return;
#ifdef RCHECK
-#ifdef PERL_CORE
{
dTHX;
if (!PERL_IS_ALIVE || !PL_curcop)
@@ -2062,20 +1860,12 @@
"Duplicate" : "Bad");
}
#else
- warn("%s free() ignored (RMAGIC)",
- ovp->ov_rmagic == RMAGIC - 1 ? "Duplicate" : "Bad");
-#endif
-#else
-#ifdef PERL_CORE
{
dTHX;
if (!PERL_IS_ALIVE || !PL_curcop)
Perl_ck_warner_d(aTHX_ packWARN(WARN_MALLOC), "%s", "Bad free() ignored (PERL_CORE)");
}
-#else
- warn("%s", "Bad free() ignored");
#endif
-#endif
return; /* sanity */
}
#ifdef RCHECK
@@ -2120,16 +1910,16 @@
Perl_realloc(void *mp, size_t nbytes)
{
dVAR;
- register MEM_SIZE onb;
+ MEM_SIZE onb;
union overhead *ovp;
char *res;
int prev_bucket;
- register int bucket;
+ int bucket;
int incr; /* 1 if does not fit, -1 if "easily" fits in a
smaller bucket, otherwise 0. */
char *cp = (char*)mp;
-#if defined(DEBUGGING) || !defined(PERL_CORE)
+#ifdef DEBUGGING
MEM_SIZE size = nbytes;
if ((long)nbytes < 0)
@@ -2160,7 +1950,6 @@
if (!bad_free_warn)
return NULL;
#ifdef RCHECK
-#ifdef PERL_CORE
{
dTHX;
if (!PERL_IS_ALIVE || !PL_curcop)
@@ -2170,12 +1959,6 @@
? "of freed memory " : "");
}
#else
- warn2("%srealloc() %signored",
- (ovp->ov_rmagic == RMAGIC - 1 ? "" : "Bad "),
- ovp->ov_rmagic == RMAGIC - 1 ? "of freed memory " : "");
-#endif
-#else
-#ifdef PERL_CORE
{
dTHX;
if (!PERL_IS_ALIVE || !PL_curcop)
@@ -2182,10 +1965,7 @@
Perl_ck_warner_d(aTHX_ packWARN(WARN_MALLOC), "%s",
"Bad realloc() ignored");
}
-#else
- warn("%s", "Bad realloc() ignored");
#endif
-#endif
return NULL; /* sanity */
}
@@ -2320,7 +2100,7 @@
}
Malloc_t
-Perl_calloc(register size_t elements, register size_t size)
+Perl_calloc(size_t elements, size_t size)
{
long sz = elements * size;
Malloc_t p = Perl_malloc(sz);
@@ -2340,7 +2120,6 @@
return (char *)CopyD(s, s1, (MEM_SIZE)(l+1), char);
}
-#ifdef PERL_CORE
int
Perl_putenv(char *a)
{
@@ -2368,7 +2147,6 @@
Perl_mfree(var);
return 0;
}
-# endif
MEM_SIZE
Perl_malloced_size(void *p)
@@ -2408,8 +2186,8 @@
Perl_get_mstats(pTHX_ perl_mstats_t *buf, int buflen, int level)
{
#ifdef DEBUGGING_MSTATS
- register int i, j;
- register union overhead *p;
+ int i, j;
+ union overhead *p;
struct chunk_chain_s* nextchain;
PERL_ARGS_ASSERT_GET_MSTATS;
@@ -2470,7 +2248,7 @@
Perl_dump_mstats(pTHX_ const char *s)
{
#ifdef DEBUGGING_MSTATS
- register int i;
+ int i;
perl_mstats_t buffer;
UV nf[NBUCKETS];
UV nt[NBUCKETS];
@@ -2569,9 +2347,7 @@
int small, reqsize;
if (!size) return 0;
-#ifdef PERL_CORE
reqsize = size; /* just for the DEBUG_m statement */
-#endif
#ifdef PACK_MALLOC
size = (size + 0x7ff) & ~0x7ff;
#endif
@@ -2612,8 +2388,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/malloc.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/malloc_ctl.h
===================================================================
--- trunk/contrib/perl/malloc_ctl.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/malloc_ctl.h 2013-12-02 21:18:17 UTC (rev 6438)
Property changes on: trunk/contrib/perl/malloc_ctl.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/mathoms.c
===================================================================
--- trunk/contrib/perl/mathoms.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/mathoms.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -1,6 +1,7 @@
/* mathoms.c
*
- * Copyright (C) 2005, 2006, 2007, 2008 by Larry Wall and others
+ * Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010,
+ * 2011, 2012 by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
@@ -25,6 +26,8 @@
*
* SMP - Oct. 24, 2005
*
+ * The compilation of this file can be suppressed; see INSTALL
+ *
*/
#include "EXTERN.h"
@@ -37,27 +40,32 @@
*/
#else
+/* Not all of these have prototypes elsewhere, so do this to get
+ * non-mangled names.
+ */
+START_EXTERN_C
+
PERL_CALLCONV OP * Perl_ref(pTHX_ OP *o, I32 type);
PERL_CALLCONV void Perl_sv_unref(pTHX_ SV *sv);
PERL_CALLCONV void Perl_sv_taint(pTHX_ SV *sv);
-PERL_CALLCONV IV Perl_sv_2iv(pTHX_ register SV *sv);
-PERL_CALLCONV UV Perl_sv_2uv(pTHX_ register SV *sv);
-PERL_CALLCONV NV Perl_sv_2nv(pTHX_ register SV *sv);
-PERL_CALLCONV char * Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp);
-PERL_CALLCONV char * Perl_sv_2pv_nolen(pTHX_ register SV *sv);
-PERL_CALLCONV char * Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv);
-PERL_CALLCONV char * Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv);
-PERL_CALLCONV void Perl_sv_force_normal(pTHX_ register SV *sv);
-PERL_CALLCONV void Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr);
+PERL_CALLCONV IV Perl_sv_2iv(pTHX_ SV *sv);
+PERL_CALLCONV UV Perl_sv_2uv(pTHX_ SV *sv);
+PERL_CALLCONV NV Perl_sv_2nv(pTHX_ SV *sv);
+PERL_CALLCONV char * Perl_sv_2pv(pTHX_ SV *sv, STRLEN *lp);
+PERL_CALLCONV char * Perl_sv_2pv_nolen(pTHX_ SV *sv);
+PERL_CALLCONV char * Perl_sv_2pvbyte_nolen(pTHX_ SV *sv);
+PERL_CALLCONV char * Perl_sv_2pvutf8_nolen(pTHX_ SV *sv);
+PERL_CALLCONV void Perl_sv_force_normal(pTHX_ SV *sv);
+PERL_CALLCONV void Perl_sv_setsv(pTHX_ SV *dstr, SV *sstr);
PERL_CALLCONV void Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen);
-PERL_CALLCONV void Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len);
-PERL_CALLCONV void Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr);
-PERL_CALLCONV void Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv);
+PERL_CALLCONV void Perl_sv_catpvn_mg(pTHX_ SV *sv, const char *ptr, STRLEN len);
+PERL_CALLCONV void Perl_sv_catsv(pTHX_ SV *dstr, SV *sstr);
+PERL_CALLCONV void Perl_sv_catsv_mg(pTHX_ SV *dsv, SV *ssv);
PERL_CALLCONV char * Perl_sv_pv(pTHX_ SV *sv);
PERL_CALLCONV char * Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp);
PERL_CALLCONV char * Perl_sv_pvbyte(pTHX_ SV *sv);
PERL_CALLCONV char * Perl_sv_pvutf8(pTHX_ SV *sv);
-PERL_CALLCONV STRLEN Perl_sv_utf8_upgrade(pTHX_ register SV *sv);
+PERL_CALLCONV STRLEN Perl_sv_utf8_upgrade(pTHX_ SV *sv);
PERL_CALLCONV NV Perl_huge(void);
PERL_CALLCONV void Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix);
PERL_CALLCONV void Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix);
@@ -64,9 +72,8 @@
PERL_CALLCONV GV * Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name);
PERL_CALLCONV HE * Perl_hv_iternext(pTHX_ HV *hv);
PERL_CALLCONV void Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how);
-PERL_CALLCONV bool Perl_do_open(pTHX_ GV *gv, register const char *name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO *supplied_fp);
-PERL_CALLCONV bool Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp);
-PERL_CALLCONV bool Perl_do_exec(pTHX_ const char *cmd);
+PERL_CALLCONV bool Perl_do_open(pTHX_ GV *gv, const char *name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO *supplied_fp);
+PERL_CALLCONV bool Perl_do_aexec(pTHX_ SV *really, SV **mark, SV **sp);
PERL_CALLCONV U8 * Perl_uvuni_to_utf8(pTHX_ U8 *d, UV uv);
PERL_CALLCONV bool Perl_is_utf8_string_loc(pTHX_ const U8 *s, STRLEN len, const U8 **ep);
PERL_CALLCONV void Perl_sv_nolocking(pTHX_ SV *sv);
@@ -80,10 +87,15 @@
PERL_CALLCONV IO * Perl_newIO(pTHX);
PERL_CALLCONV I32 Perl_my_stat(pTHX);
PERL_CALLCONV I32 Perl_my_lstat(pTHX);
-PERL_CALLCONV I32 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2);
+PERL_CALLCONV I32 Perl_sv_eq(pTHX_ SV *sv1, SV *sv2);
PERL_CALLCONV char * Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp);
-PERL_CALLCONV bool Perl_sv_2bool(pTHX_ register SV *const sv);
+PERL_CALLCONV bool Perl_sv_2bool(pTHX_ SV *const sv);
PERL_CALLCONV CV * Perl_newSUB(pTHX_ I32 floor, OP* o, OP* proto, OP* block);
+PERL_CALLCONV UV Perl_to_utf8_lower(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp);
+PERL_CALLCONV UV Perl_to_utf8_title(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp);
+PERL_CALLCONV UV Perl_to_utf8_upper(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp);
+PERL_CALLCONV UV Perl_to_utf8_fold(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp);
+PERL_CALLCONV SV *Perl_sv_mortalcopy(pTHX_ SV *const oldstr);
/* ref() is now a macro using Perl_doref;
* this version provided for binary compatibility only.
@@ -117,6 +129,7 @@
=for apidoc sv_taint
Taint an SV. Use C<SvTAINTED_on> instead.
+
=cut
*/
@@ -133,7 +146,7 @@
*/
IV
-Perl_sv_2iv(pTHX_ register SV *sv)
+Perl_sv_2iv(pTHX_ SV *sv)
{
return sv_2iv_flags(sv, SV_GMAGIC);
}
@@ -143,7 +156,7 @@
*/
UV
-Perl_sv_2uv(pTHX_ register SV *sv)
+Perl_sv_2uv(pTHX_ SV *sv)
{
return sv_2uv_flags(sv, SV_GMAGIC);
}
@@ -153,7 +166,7 @@
*/
NV
-Perl_sv_2nv(pTHX_ register SV *sv)
+Perl_sv_2nv(pTHX_ SV *sv)
{
return sv_2nv_flags(sv, SV_GMAGIC);
}
@@ -164,7 +177,7 @@
*/
char *
-Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
+Perl_sv_2pv(pTHX_ SV *sv, STRLEN *lp)
{
return sv_2pv_flags(sv, lp, SV_GMAGIC);
}
@@ -174,11 +187,12 @@
Like C<sv_2pv()>, but doesn't return the length too. You should usually
use the macro wrapper C<SvPV_nolen(sv)> instead.
+
=cut
*/
char *
-Perl_sv_2pv_nolen(pTHX_ register SV *sv)
+Perl_sv_2pv_nolen(pTHX_ SV *sv)
{
PERL_ARGS_ASSERT_SV_2PV_NOLEN;
return sv_2pv(sv, NULL);
@@ -196,7 +210,7 @@
*/
char *
-Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
+Perl_sv_2pvbyte_nolen(pTHX_ SV *sv)
{
PERL_ARGS_ASSERT_SV_2PVBYTE_NOLEN;
@@ -215,7 +229,7 @@
*/
char *
-Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
+Perl_sv_2pvutf8_nolen(pTHX_ SV *sv)
{
PERL_ARGS_ASSERT_SV_2PVUTF8_NOLEN;
@@ -233,7 +247,7 @@
*/
void
-Perl_sv_force_normal(pTHX_ register SV *sv)
+Perl_sv_force_normal(pTHX_ SV *sv)
{
PERL_ARGS_ASSERT_SV_FORCE_NORMAL;
@@ -245,7 +259,7 @@
*/
void
-Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
+Perl_sv_setsv(pTHX_ SV *dstr, SV *sstr)
{
PERL_ARGS_ASSERT_SV_SETSV;
@@ -273,7 +287,7 @@
*/
void
-Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
+Perl_sv_catpvn_mg(pTHX_ SV *sv, const char *ptr, STRLEN len)
{
PERL_ARGS_ASSERT_SV_CATPVN_MG;
@@ -285,7 +299,7 @@
*/
void
-Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
+Perl_sv_catsv(pTHX_ SV *dstr, SV *sstr)
{
PERL_ARGS_ASSERT_SV_CATSV;
@@ -301,7 +315,7 @@
*/
void
-Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
+Perl_sv_catsv_mg(pTHX_ SV *dsv, SV *ssv)
{
PERL_ARGS_ASSERT_SV_CATSV_MG;
@@ -318,7 +332,7 @@
*/
IV
-Perl_sv_iv(pTHX_ register SV *sv)
+Perl_sv_iv(pTHX_ SV *sv)
{
PERL_ARGS_ASSERT_SV_IV;
@@ -340,7 +354,7 @@
*/
UV
-Perl_sv_uv(pTHX_ register SV *sv)
+Perl_sv_uv(pTHX_ SV *sv)
{
PERL_ARGS_ASSERT_SV_UV;
@@ -362,7 +376,7 @@
*/
NV
-Perl_sv_nv(pTHX_ register SV *sv)
+Perl_sv_nv(pTHX_ SV *sv)
{
PERL_ARGS_ASSERT_SV_NV;
@@ -398,7 +412,7 @@
char *
-Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
+Perl_sv_pvn_nomg(pTHX_ SV *sv, STRLEN *lp)
{
PERL_ARGS_ASSERT_SV_PVN_NOMG;
@@ -513,7 +527,7 @@
*/
STRLEN
-Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
+Perl_sv_utf8_upgrade(pTHX_ SV *sv)
{
PERL_ARGS_ASSERT_SV_UTF8_UPGRADE;
@@ -604,7 +618,7 @@
/*
=for apidoc gv_fetchmethod
-See L<gv_fetchmethod_autoload>.
+See L</gv_fetchmethod_autoload>.
=cut
*/
@@ -634,7 +648,7 @@
}
bool
-Perl_do_open(pTHX_ GV *gv, register const char *name, I32 len, int as_raw,
+Perl_do_open(pTHX_ GV *gv, const char *name, I32 len, int as_raw,
int rawmode, int rawperm, PerlIO *supplied_fp)
{
PERL_ARGS_ASSERT_DO_OPEN;
@@ -644,7 +658,7 @@
}
bool
-Perl_do_open9(pTHX_ GV *gv, register const char *name, I32 len, int
+Perl_do_open9(pTHX_ GV *gv, const char *name, I32 len, int
as_raw,
int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs,
I32 num_svs)
@@ -675,7 +689,7 @@
#ifndef OS2
bool
-Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp)
+Perl_do_aexec(pTHX_ SV *really, SV **mark, SV **sp)
{
PERL_ARGS_ASSERT_DO_AEXEC;
@@ -683,16 +697,6 @@
}
#endif
-#ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION
-bool
-Perl_do_exec(pTHX_ const char *cmd)
-{
- PERL_ARGS_ASSERT_DO_EXEC;
-
- return do_exec3(cmd,0,0);
-}
-#endif
-
/* Backwards compatibility. */
int
Perl_init_i18nl14n(pTHX_ int printwarn)
@@ -794,16 +798,18 @@
}
void
-Perl_save_list(pTHX_ register SV **sarg, I32 maxsarg)
+Perl_save_list(pTHX_ SV **sarg, I32 maxsarg)
{
dVAR;
- register I32 i;
+ I32 i;
PERL_ARGS_ASSERT_SAVE_LIST;
for (i = 1; i <= maxsarg; i++) {
- register SV * const sv = newSV(0);
- sv_setsv(sv,sarg[i]);
+ SV *sv;
+ SvGETMAGIC(sarg[i]);
+ sv = newSV(0);
+ sv_setsv_nomg(sv,sarg[i]);
SSCHECK(3);
SSPUSHPTR(sarg[i]); /* remember the pointer */
SSPUSHPTR(sv); /* remember the value */
@@ -877,7 +883,7 @@
*/
void
-Perl_pack_cat(pTHX_ SV *cat, const char *pat, const char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
+Perl_pack_cat(pTHX_ SV *cat, const char *pat, const char *patend, SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
{
PERL_ARGS_ASSERT_PACK_CAT;
@@ -1085,13 +1091,13 @@
}
GV *
-Perl_gv_HVadd(pTHX_ register GV *gv)
+Perl_gv_HVadd(pTHX_ GV *gv)
{
return gv_HVadd(gv);
}
GV *
-Perl_gv_IOadd(pTHX_ register GV *gv)
+Perl_gv_IOadd(pTHX_ GV *gv)
{
return gv_IOadd(gv);
}
@@ -1115,7 +1121,7 @@
}
I32
-Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
+Perl_sv_eq(pTHX_ SV *sv1, SV *sv2)
{
return sv_eq_flags(sv1, sv2, SV_GMAGIC);
}
@@ -1129,7 +1135,7 @@
#endif
bool
-Perl_sv_2bool(pTHX_ register SV *const sv)
+Perl_sv_2bool(pTHX_ SV *const sv)
{
return sv_2bool_flags(sv, SV_GMAGIC);
}
@@ -1168,6 +1174,47 @@
{
return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
}
+
+UV
+Perl_to_utf8_fold(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
+{
+ PERL_ARGS_ASSERT_TO_UTF8_FOLD;
+
+ return _to_utf8_fold_flags(p, ustrp, lenp, FOLD_FLAGS_FULL, NULL);
+}
+
+UV
+Perl_to_utf8_lower(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
+{
+ PERL_ARGS_ASSERT_TO_UTF8_LOWER;
+
+ return _to_utf8_lower_flags(p, ustrp, lenp, FALSE, NULL);
+}
+
+UV
+Perl_to_utf8_title(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
+{
+ PERL_ARGS_ASSERT_TO_UTF8_TITLE;
+
+ return _to_utf8_title_flags(p, ustrp, lenp, FALSE, NULL);
+}
+
+UV
+Perl_to_utf8_upper(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
+{
+ PERL_ARGS_ASSERT_TO_UTF8_UPPER;
+
+ return _to_utf8_upper_flags(p, ustrp, lenp, FALSE, NULL);
+}
+
+SV *
+Perl_sv_mortalcopy(pTHX_ SV *const oldstr)
+{
+ return Perl_sv_mortalcopy_flags(aTHX_ oldstr, SV_GMAGIC);
+}
+
+END_EXTERN_C
+
#endif /* NO_MATHOMS */
/*
@@ -1174,8 +1221,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/mathoms.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/metaconfig.SH
===================================================================
--- trunk/contrib/perl/metaconfig.SH 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/metaconfig.SH 2013-12-02 21:18:17 UTC (rev 6438)
Property changes on: trunk/contrib/perl/metaconfig.SH
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/metaconfig.h
===================================================================
--- trunk/contrib/perl/metaconfig.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/metaconfig.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -1,7 +1,7 @@
/* This is a placeholder file for symbols that should be exported
* into config_h.SH and Porting/Glossary. See also metaconfig.SH
*
- * First version was created from the part in handy.h (which includes this)
+ * First version was created from the part in handy.h
* H.Merijn Brand 21 Dec 2010 (Tux)
*
* Mentioned variables are forced to be included into config_h.SH
@@ -10,35 +10,29 @@
* they won't be available unless used. When new symbols are probed
* in Configure, this is the way to force them into availability.
*
+ * BOOTSTRAP_CHARSET
* CHARBITS
- * GMTIME_MAX
- * GMTIME_MIN
* HAS_ASCTIME64
* HAS_CTIME64
* HAS_DIFFTIME64
- * HAS_GETADDRINFO
- * HAS_GETNAMEINFO
* HAS_GMTIME64
- * HAS_INETNTOP
- * HAS_INETPTON
+ * HAS_ISBLANK
* HAS_LOCALTIME64
+ * HAS_IP_MREQ
+ * HAS_IP_MREQ_SOURCE
+ * HAS_IPV6_MREQ
+ * HAS_IPV6_MREQ_SOURCE
* HAS_MKTIME64
* HAS_PRCTL
* HAS_PSEUDOFORK
- * HAS_SIN6_SCOPE_ID
- * HAS_SOCKADDR_SA_LEN
* HAS_TIMEGM
+ * HAS_SOCKADDR_IN6
* I16SIZE
- * I32SIZE
* I64SIZE
* I8SIZE
- * LOCALTIME_MAX
- * LOCALTIME_MIN
* LOCALTIME_R_NEEDS_TZSET
- * U16SIZE
- * U32SIZE
- * U64SIZE
* U8SIZE
- * USE_DTRACE
+ * USE_KERN_PROC_PATHNAME
+ * USE_NSGETEXECUTABLEPATH
*
*/
Property changes on: trunk/contrib/perl/metaconfig.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/mg.c
===================================================================
--- trunk/contrib/perl/mg.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/mg.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -76,6 +76,7 @@
#endif
/*
+ * Pre-magic setup and post-magic takedown.
* Use the "DESTRUCTOR" scope cleanup to reinstate magic.
*/
@@ -97,6 +98,8 @@
PERL_ARGS_ASSERT_SAVE_MAGIC;
+ assert(SvMAGICAL(sv));
+
/* we shouldn't really be called here with RC==0, but it can sometimes
* happen via mg_clear() (which also shouldn't be called when RC==0,
* but it can happen). Handle this case gracefully(ish) by not RC++
@@ -108,27 +111,19 @@
bumped = TRUE;
}
- assert(SvMAGICAL(sv));
- /* Turning READONLY off for a copy-on-write scalar (including shared
- hash keys) is a bad idea. */
- if (SvIsCOW(sv))
- sv_force_normal_flags(sv, 0);
-
SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
mgs = SSPTR(mgs_ix, MGS*);
mgs->mgs_sv = sv;
mgs->mgs_magical = SvMAGICAL(sv);
- mgs->mgs_readonly = SvREADONLY(sv) != 0;
+ mgs->mgs_readonly = SvREADONLY(sv) && !SvIsCOW(sv);
mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
mgs->mgs_bumped = bumped;
SvMAGICAL_off(sv);
- SvREADONLY_off(sv);
- if (!(SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK))) {
- /* No public flags are set, so promote any private flags to public. */
- SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
- }
+ /* Turning READONLY off for a copy-on-write scalar (including shared
+ hash keys) is a bad idea. */
+ if (!SvIsCOW(sv)) SvREADONLY_off(sv);
}
/*
@@ -164,46 +159,11 @@
}
}
-
-/* is this container magic (%ENV, $1 etc), or value magic (pos, taint etc)? */
-
-STATIC bool
-S_is_container_magic(const MAGIC *mg)
-{
- assert(mg);
- switch (mg->mg_type) {
- case PERL_MAGIC_bm:
- case PERL_MAGIC_fm:
- case PERL_MAGIC_regex_global:
- case PERL_MAGIC_nkeys:
-#ifdef USE_LOCALE_COLLATE
- case PERL_MAGIC_collxfrm:
-#endif
- case PERL_MAGIC_qr:
- case PERL_MAGIC_taint:
- case PERL_MAGIC_vec:
- case PERL_MAGIC_vstring:
- case PERL_MAGIC_utf8:
- case PERL_MAGIC_substr:
- case PERL_MAGIC_defelem:
- case PERL_MAGIC_arylen:
- case PERL_MAGIC_pos:
- case PERL_MAGIC_backref:
- case PERL_MAGIC_arylen_p:
- case PERL_MAGIC_rhash:
- case PERL_MAGIC_symtab:
- case PERL_MAGIC_tied: /* treat as value, so 'local @tied' isn't tied */
- case PERL_MAGIC_checkcall:
- return 0;
- default:
- return 1;
- }
-}
-
/*
=for apidoc mg_get
-Do magic after a value is retrieved from the SV. See C<sv_magic>.
+Do magic before a value is retrieved from the SV. The type of SV must
+be >= SVt_PVMG. See C<sv_magic>.
=cut
*/
@@ -213,12 +173,13 @@
{
dVAR;
const I32 mgs_ix = SSNEW(sizeof(MGS));
+ bool saved = FALSE;
bool have_new = 0;
MAGIC *newmg, *head, *cur, *mg;
PERL_ARGS_ASSERT_MG_GET;
- save_magic(mgs_ix, sv);
+ if (PL_localizing == 1 && sv == DEFSV) return 0;
/* We must call svt_get(sv, mg) for each valid entry in the linked
list of magic. svt_get() may delete the current entry, add new
@@ -230,6 +191,13 @@
MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */
if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
+
+ /* taint's mg get is so dumb it doesn't need flag saving */
+ if (!saved && mg->mg_type != PERL_MAGIC_taint) {
+ save_magic(mgs_ix, sv);
+ saved = TRUE;
+ }
+
vtbl->svt_get(aTHX_ sv, mg);
/* guard against magic having been deleted - eg FETCH calling
@@ -243,6 +211,10 @@
if (mg->mg_flags & MGf_GSKIP)
(SSPTR(mgs_ix, MGS *))->mgs_magical = 0;
}
+ else if (vtbl == &PL_vtbl_utf8) {
+ /* get-magic can reallocate the PV */
+ magic_setutf8(sv, mg);
+ }
mg = nextmg;
@@ -265,7 +237,9 @@
}
}
- restore_magic(INT2PTR(void *, (IV)mgs_ix));
+ if (saved)
+ restore_magic(INT2PTR(void *, (IV)mgs_ix));
+
return 0;
}
@@ -287,6 +261,8 @@
PERL_ARGS_ASSERT_MG_SET;
+ if (PL_localizing == 2 && sv == DEFSV) return 0;
+
save_magic(mgs_ix, sv);
for (mg = SvMAGIC(sv); mg; mg = nextmg) {
@@ -296,7 +272,8 @@
mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
(SSPTR(mgs_ix, MGS*))->mgs_magical = 0;
}
- if (PL_localizing == 2 && (!S_is_container_magic(mg) || sv == DEFSV))
+ if (PL_localizing == 2
+ && PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
continue;
if (vtbl && vtbl->svt_set)
vtbl->svt_set(aTHX_ sv, mg);
@@ -309,8 +286,14 @@
/*
=for apidoc mg_length
-Report on the SV's length. See C<sv_magic>.
+This function is deprecated.
+It reports on the SV's length in bytes, calling length magic if available,
+but does not set the UTF8 flag on the sv. It will fall back to 'get'
+magic if there is no 'length' magic, but with no indication as to
+whether it called 'get' magic. It assumes the sv is a PVMG or
+higher. Use sv_len() instead.
+
=cut
*/
@@ -335,15 +318,7 @@
}
}
- {
- /* You can't know whether it's UTF-8 until you get the string again...
- */
- const U8 *s = (U8*)SvPV_const(sv, len);
-
- if (DO_UTF8(sv)) {
- len = utf8_length(s, s + len);
- }
- }
+ (void)SvPV_const(sv, len);
return len;
}
@@ -412,7 +387,7 @@
return 0;
}
-MAGIC*
+static MAGIC*
S_mg_findext_flags(pTHX_ const SV *sv, int type, const MGVTBL *vtbl, U32 flags)
{
PERL_UNUSED_CONTEXT;
@@ -526,7 +501,7 @@
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
const MGVTBL* const vtbl = mg->mg_virtual;
- if (!S_is_container_magic(mg))
+ if (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
continue;
if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
@@ -637,7 +612,7 @@
PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
if (PL_curpm) {
- register const REGEXP * const rx = PM_GETRE(PL_curpm);
+ const REGEXP * const rx = PM_GETRE(PL_curpm);
if (rx) {
if (mg->mg_obj) { /* @+ */
/* return the number possible */
@@ -658,6 +633,8 @@
return (U32)-1;
}
+/* @-, @+ */
+
int
Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
{
@@ -666,11 +643,11 @@
PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
if (PL_curpm) {
- register const REGEXP * const rx = PM_GETRE(PL_curpm);
+ const REGEXP * const rx = PM_GETRE(PL_curpm);
if (rx) {
- register const I32 paren = mg->mg_len;
- register I32 s;
- register I32 t;
+ const I32 paren = mg->mg_len;
+ I32 s;
+ I32 t;
if (paren < 0)
return 0;
if (paren <= (I32)RX_NPARENS(rx) &&
@@ -677,7 +654,7 @@
(s = RX_OFFS(rx)[paren].start) != -1 &&
(t = RX_OFFS(rx)[paren].end) != -1)
{
- register I32 i;
+ I32 i;
if (mg->mg_obj) /* @+ */
i = t;
else /* @- */
@@ -686,7 +663,9 @@
if (i > 0 && RX_MATCH_UTF8(rx)) {
const char * const b = RX_SUBBEG(rx);
if (b)
- i = utf8_length((U8*)b, (U8*)(b+i));
+ i = RX_SUBCOFFSET(rx) +
+ utf8_length((U8*)b,
+ (U8*)(b-RX_SUBOFFSET(rx)+i));
}
sv_setiv(sv, i);
@@ -696,6 +675,8 @@
return 0;
}
+/* @-, @+ */
+
int
Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
{
@@ -702,89 +683,10 @@
PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
PERL_UNUSED_ARG(sv);
PERL_UNUSED_ARG(mg);
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
NORETURN_FUNCTION_END;
}
-U32
-Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
-{
- dVAR;
- register I32 paren;
- register I32 i;
- register const REGEXP * rx;
- const char * const remaining = mg->mg_ptr + 1;
-
- PERL_ARGS_ASSERT_MAGIC_LEN;
-
- switch (*mg->mg_ptr) {
- case '\020':
- if (*remaining == '\0') { /* ^P */
- break;
- } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
- goto do_prematch;
- } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
- goto do_postmatch;
- }
- break;
- case '\015': /* $^MATCH */
- if (strEQ(remaining, "ATCH")) {
- goto do_match;
- } else {
- break;
- }
- case '`':
- do_prematch:
- paren = RX_BUFF_IDX_PREMATCH;
- goto maybegetparen;
- case '\'':
- do_postmatch:
- paren = RX_BUFF_IDX_POSTMATCH;
- goto maybegetparen;
- case '&':
- do_match:
- paren = RX_BUFF_IDX_FULLMATCH;
- goto maybegetparen;
- case '1': case '2': case '3': case '4':
- case '5': case '6': case '7': case '8': case '9':
- paren = atoi(mg->mg_ptr);
- maybegetparen:
- if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- getparen:
- i = CALLREG_NUMBUF_LENGTH((REGEXP * const)rx, sv, paren);
-
- if (i < 0)
- Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
- return i;
- } else {
- if (ckWARN(WARN_UNINITIALIZED))
- report_uninit(sv);
- return 0;
- }
- case '+':
- if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- paren = RX_LASTPAREN(rx);
- if (paren)
- goto getparen;
- }
- return 0;
- case '\016': /* ^N */
- if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- paren = RX_LASTCLOSEPAREN(rx);
- if (paren)
- goto getparen;
- }
- return 0;
- }
- magic_get(sv,mg);
- if (!SvPOK(sv) && SvNIOK(sv)) {
- sv_2pv(sv, 0);
- }
- if (SvPOK(sv))
- return SvCUR(sv);
- return 0;
-}
-
#define SvRTRIM(sv) STMT_START { \
if (SvPOK(sv)) { \
STRLEN len = SvCUR(sv); \
@@ -820,13 +722,18 @@
}
}
+#ifdef VMS
+#include <descrip.h>
+#include <starlet.h>
+#endif
+
int
Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
- register I32 paren;
- register const char *s = NULL;
- register REGEXP *rx;
+ I32 paren;
+ const char *s = NULL;
+ REGEXP *rx;
const char * const remaining = mg->mg_ptr + 1;
const char nextchar = *remaining;
@@ -834,7 +741,8 @@
switch (*mg->mg_ptr) {
case '\001': /* ^A */
- sv_setsv(sv, PL_bodytarget);
+ if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget);
+ else sv_setsv(sv, &PL_sv_undef);
if (SvTAINTED(PL_bodytarget))
SvTAINTED_on(sv);
break;
@@ -854,8 +762,6 @@
if (nextchar == '\0') {
#if defined(VMS)
{
-# include <descrip.h>
-# include <starlet.h>
char msg[255];
$DESCRIPTOR(msgdsc,msg);
sv_setnv(sv,(NV) vaxc$errno);
@@ -917,6 +823,20 @@
case '\011': /* ^I */ /* NOT \t in EBCDIC */
sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
break;
+ case '\014': /* ^LAST_FH */
+ if (strEQ(remaining, "AST_FH")) {
+ if (PL_last_in_gv) {
+ assert(isGV_with_GP(PL_last_in_gv));
+ SV_CHECK_THINKFIRST_COW_DROP(sv);
+ prepare_SV_for_RV(sv);
+ SvOK_off(sv);
+ SvRV_set(sv, SvREFCNT_inc_simple_NN(PL_last_in_gv));
+ SvROK_on(sv);
+ sv_rvweaken(sv);
+ }
+ else sv_setsv_nomg(sv, NULL);
+ }
+ break;
case '\017': /* ^O & ^OPEN */
if (nextchar == '\0') {
sv_setpv(sv, PL_osname);
@@ -930,9 +850,12 @@
if (nextchar == '\0') { /* ^P */
sv_setiv(sv, (IV)PL_perldb);
} else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
- goto do_prematch_fetch;
+
+ paren = RX_BUFF_IDX_CARET_PREMATCH;
+ goto do_numbuf_fetch;
} else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
- goto do_postmatch_fetch;
+ paren = RX_BUFF_IDX_CARET_POSTMATCH;
+ goto do_numbuf_fetch;
}
break;
case '\023': /* ^S */
@@ -954,8 +877,8 @@
#endif
}
else if (strEQ(remaining, "AINT"))
- sv_setiv(sv, PL_tainting
- ? (PL_taint_warn || PL_unsafe ? -1 : 1)
+ sv_setiv(sv, TAINTING_get
+ ? (TAINT_WARN_get || PL_unsafe ? -1 : 1)
: 0);
break;
case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
@@ -974,83 +897,67 @@
sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
}
else if (PL_compiling.cop_warnings == pWARN_STD) {
- sv_setpvn(
- sv,
- (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
- WARNsize
- );
+ sv_setsv(sv, &PL_sv_undef);
+ break;
}
else if (PL_compiling.cop_warnings == pWARN_ALL) {
/* Get the bit mask for $warnings::Bits{all}, because
* it could have been extended by warnings::register */
- HV * const bits=get_hv("warnings::Bits", 0);
- if (bits) {
- SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
- if (bits_all)
- sv_setsv(sv, *bits_all);
- }
- else {
- sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
- }
+ HV * const bits = get_hv("warnings::Bits", 0);
+ SV ** const bits_all = bits ? hv_fetchs(bits, "all", FALSE) : NULL;
+ if (bits_all)
+ sv_copypv(sv, *bits_all);
+ else
+ sv_setpvn(sv, WARN_ALLstring, WARNsize);
}
else {
sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
*PL_compiling.cop_warnings);
}
- SvPOK_only(sv);
}
break;
case '\015': /* $^MATCH */
if (strEQ(remaining, "ATCH")) {
+ paren = RX_BUFF_IDX_CARET_FULLMATCH;
+ goto do_numbuf_fetch;
+ }
+
case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9': case '&':
- if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- /*
- * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj));
- * XXX Does the new way break anything?
- */
- paren = atoi(mg->mg_ptr); /* $& is in [0] */
- CALLREG_NUMBUF_FETCH(rx,paren,sv);
- break;
- }
- sv_setsv(sv,&PL_sv_undef);
- }
+ /*
+ * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj));
+ * XXX Does the new way break anything?
+ */
+ paren = atoi(mg->mg_ptr); /* $& is in [0] */
+ do_numbuf_fetch:
+ if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
+ CALLREG_NUMBUF_FETCH(rx,paren,sv);
+ break;
+ }
+ sv_setsv(sv,&PL_sv_undef);
break;
case '+':
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- if (RX_LASTPAREN(rx)) {
- CALLREG_NUMBUF_FETCH(rx,RX_LASTPAREN(rx),sv);
- break;
- }
+ paren = RX_LASTPAREN(rx);
+ if (paren)
+ goto do_numbuf_fetch;
}
sv_setsv(sv,&PL_sv_undef);
break;
case '\016': /* ^N */
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- if (RX_LASTCLOSEPAREN(rx)) {
- CALLREG_NUMBUF_FETCH(rx,RX_LASTCLOSEPAREN(rx),sv);
- break;
- }
-
+ paren = RX_LASTCLOSEPAREN(rx);
+ if (paren)
+ goto do_numbuf_fetch;
}
sv_setsv(sv,&PL_sv_undef);
break;
case '`':
- do_prematch_fetch:
- if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- CALLREG_NUMBUF_FETCH(rx,-2,sv);
- break;
- }
- sv_setsv(sv,&PL_sv_undef);
- break;
+ paren = RX_BUFF_IDX_PREMATCH;
+ goto do_numbuf_fetch;
case '\'':
- do_postmatch_fetch:
- if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- CALLREG_NUMBUF_FETCH(rx,-1,sv);
- break;
- }
- sv_setsv(sv,&PL_sv_undef);
- break;
+ paren = RX_BUFF_IDX_POSTMATCH;
+ goto do_numbuf_fetch;
case '.':
if (GvIO(PL_last_in_gv)) {
sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
@@ -1067,9 +974,7 @@
}
break;
case '^':
- if (!isGV_with_GP(PL_defoutgv))
- s = "";
- else if (GvIOp(PL_defoutgv))
+ if (GvIOp(PL_defoutgv))
s = IoTOP_NAME(GvIOp(PL_defoutgv));
if (s)
sv_setpv(sv,s);
@@ -1079,9 +984,7 @@
}
break;
case '~':
- if (!isGV_with_GP(PL_defoutgv))
- s = "";
- else if (GvIOp(PL_defoutgv))
+ if (GvIOp(PL_defoutgv))
s = IoFMT_NAME(GvIOp(PL_defoutgv));
if (!s)
s = GvENAME(PL_defoutgv);
@@ -1104,7 +1007,7 @@
case '/':
break;
case '[':
- sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
+ sv_setiv(sv, 0);
break;
case '|':
if (GvIO(PL_defoutgv))
@@ -1113,7 +1016,22 @@
case '\\':
if (PL_ors_sv)
sv_copypv(sv, PL_ors_sv);
+ else
+ sv_setsv(sv, &PL_sv_undef);
break;
+ case '$': /* $$ */
+ {
+ IV const pid = (IV)PerlProc_getpid();
+ if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) {
+ /* never set manually, or at least not since last fork */
+ sv_setiv(sv, pid);
+ /* never unsafe, even if reading in a tainted expression */
+ SvTAINTED_off(sv);
+ }
+ /* else a value has been assigned manually, so do nothing */
+ }
+ break;
+
case '!':
{
dSAVE_ERRNO;
@@ -1128,8 +1046,6 @@
else
#endif
sv_setpv(sv, errno ? Strerror(errno) : "");
- if (SvPOKp(sv))
- SvPOK_on(sv); /* may have got removed during taint processing */
RESTORE_ERRNO;
}
@@ -1137,16 +1053,16 @@
SvNOK_on(sv); /* what a wonderful hack! */
break;
case '<':
- sv_setiv(sv, (IV)PL_uid);
+ sv_setiv(sv, (IV)PerlProc_getuid());
break;
case '>':
- sv_setiv(sv, (IV)PL_euid);
+ sv_setiv(sv, (IV)PerlProc_geteuid());
break;
case '(':
- sv_setiv(sv, (IV)PL_gid);
+ sv_setiv(sv, (IV)PerlProc_getgid());
goto add_groups;
case ')':
- sv_setiv(sv, (IV)PL_egid);
+ sv_setiv(sv, (IV)PerlProc_getegid());
add_groups:
#ifdef HAS_GETGROUPS
{
@@ -1184,17 +1100,31 @@
{
dVAR;
STRLEN len = 0, klen;
- const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
- const char * const ptr = MgPV_const(mg,klen);
- my_setenv(ptr, s);
+ const char * const key = MgPV_const(mg,klen);
+ const char *s = "";
PERL_ARGS_ASSERT_MAGIC_SETENV;
+ SvGETMAGIC(sv);
+ if (SvOK(sv)) {
+ /* defined environment variables are byte strings; unfortunately
+ there is no SvPVbyte_force_nomg(), so we must do this piecewise */
+ (void)SvPV_force_nomg_nolen(sv);
+ sv_utf8_downgrade(sv, /* fail_ok */ TRUE);
+ if (SvUTF8(sv)) {
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "setenv");
+ SvUTF8_off(sv);
+ }
+ s = SvPVX(sv);
+ len = SvCUR(sv);
+ }
+ my_setenv(key, s); /* does the deed */
+
#ifdef DYNAMIC_ENV_FETCH
/* We just undefd an environment var. Is a replacement */
/* waiting in the wings? */
if (!len) {
- SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
+ SV ** const valp = hv_fetch(GvHVn(PL_envgv), key, klen, FALSE);
if (valp)
s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
}
@@ -1203,10 +1133,10 @@
#if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
/* And you'll never guess what the dog had */
/* in its mouth... */
- if (PL_tainting) {
+ if (TAINTING_get) {
MgTAINTEDDIR_off(mg);
#ifdef VMS
- if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
+ if (s && klen == 8 && strEQ(key, "DCL$PATH")) {
char pathbuf[256], eltbuf[256], *cp, *elt;
int i = 0, j = 0;
@@ -1232,7 +1162,7 @@
} while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
}
#endif /* VMS */
- if (s && klen == 4 && strEQ(ptr,"PATH")) {
+ if (s && klen == 4 && strEQ(key,"PATH")) {
const char * const strend = s + len;
while (s < strend) {
@@ -1331,7 +1261,9 @@
PERL_ARGS_ASSERT_MAGIC_GETSIG;
if (!i) {
- mg->mg_private = i = whichsig(MgPV_nolen_const(mg));
+ STRLEN siglen;
+ const char * sig = MgPV_const(mg, siglen);
+ mg->mg_private = i = whichsig_pvn(sig, siglen);
}
if (i > 0) {
@@ -1362,7 +1294,6 @@
Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
{
PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
- PERL_UNUSED_ARG(sv);
magic_setsig(NULL, mg);
return sv_unmagic(sv, mg->mg_type);
@@ -1518,14 +1449,14 @@
sigset_t set, save;
SV* save_sv;
#endif
- register const char *s = MgPV_const(mg,len);
+ const char *s = MgPV_const(mg,len);
PERL_ARGS_ASSERT_MAGIC_SETSIG;
if (*s == '_') {
- if (strEQ(s,"__DIE__"))
+ if (memEQs(s, len, "__DIE__"))
svp = &PL_diehook;
- else if (strEQ(s,"__WARN__")
+ else if (memEQs(s, len, "__WARN__")
&& (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
/* Merge the existing behaviours, which are as follows:
magic_setsig, we always set svp to &PL_warnhook
@@ -1533,8 +1464,11 @@
For magic_clearsig, we don't change the warnings handler if it's
set to the &PL_warnhook. */
svp = &PL_warnhook;
- } else if (sv)
- Perl_croak(aTHX_ "No such hook: %s", s);
+ } else if (sv) {
+ SV *tmp = sv_newmortal();
+ Perl_croak(aTHX_ "No such hook: %s",
+ pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
+ }
i = 0;
if (svp && *svp) {
if (*svp != PERL_WARNHOOK_FATAL)
@@ -1545,12 +1479,15 @@
else {
i = (I16)mg->mg_private;
if (!i) {
- i = whichsig(s); /* ...no, a brick */
+ i = whichsig_pvn(s, len); /* ...no, a brick */
mg->mg_private = (U16)i;
}
if (i <= 0) {
- if (sv)
- Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
+ if (sv) {
+ SV *tmp = sv_newmortal();
+ Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s",
+ pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
+ }
return 0;
}
#ifdef HAS_SIGPROCMASK
@@ -1606,7 +1543,7 @@
} else {
sv = NULL;
}
- if (sv && strEQ(s,"IGNORE")) {
+ if (sv && memEQs(s, len,"IGNORE")) {
if (i) {
#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
PL_sig_ignoring[i] = 1;
@@ -1616,7 +1553,7 @@
#endif
}
}
- else if (!sv || strEQ(s,"DEFAULT") || !len) {
+ else if (!sv || memEQs(s, len,"DEFAULT") || !len) {
if (i) {
#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
PL_sig_defaulting[i] = 1;
@@ -1709,18 +1646,6 @@
}
int
-Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
-{
- dVAR;
- PERL_ARGS_ASSERT_MAGIC_SETAMAGIC;
- PERL_UNUSED_ARG(sv);
- PERL_UNUSED_ARG(mg);
- PL_amagic_generation++;
-
- return 0;
-}
-
-int
Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
{
HV * const hv = MUTABLE_HV(LvTARG(sv));
@@ -1732,7 +1657,7 @@
if (hv) {
(void) hv_iterinit(hv);
if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
- i = HvKEYS(hv);
+ i = HvUSEDKEYS(hv);
else {
while (hv_iternext(hv))
i++;
@@ -1759,14 +1684,21 @@
Invoke a magic method (like FETCH).
-* sv and mg are the tied thingy and the tie magic;
-* meth is the name of the method to call;
-* argc is the number of args (in addition to $self) to pass to the method;
- the args themselves are any values following the argc argument.
-* flags:
- G_DISCARD: invoke method with G_DISCARD flag and don't return a value
- G_UNDEF_FILL: fill the stack with argc pointers to PL_sv_undef.
+C<sv> and C<mg> are the tied thingy and the tie magic.
+C<meth> is the name of the method to call.
+
+C<argc> is the number of args (in addition to $self) to pass to the method.
+
+The C<flags> can be:
+
+ G_DISCARD invoke method with G_DISCARD flag and don't
+ return a value
+ G_UNDEF_FILL fill the stack with argc pointers to
+ PL_sv_undef
+
+The arguments themselves are any values following the C<flags> argument.
+
Returns the SV (if any) returned by the method, or NULL on failure.
@@ -1901,7 +1833,7 @@
* fake up a temporary tainted value (this is easier than temporarily
* re-enabling magic on sv). */
- if (PL_tainting && (tmg = mg_find(sv, PERL_MAGIC_taint))
+ if (TAINTING_get && (tmg = mg_find(sv, PERL_MAGIC_taint))
&& (tmg->mg_len & 1))
{
val = sv_mortalcopy(sv);
@@ -1919,6 +1851,7 @@
{
PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
+ if (mg->mg_type == PERL_MAGIC_tiedscalar) return 0;
return magic_methpack(sv,mg,"DELETE");
}
@@ -2018,11 +1951,17 @@
if (svp && SvIOKp(*svp)) {
OP * const o = INT2PTR(OP*,SvIVX(*svp));
if (o) {
+#ifdef PERL_DEBUG_READONLY_OPS
+ Slab_to_rw(OpSLAB(o));
+#endif
/* set or clear breakpoint in the relevant control op */
if (i)
o->op_flags |= OPf_SPECIAL;
else
o->op_flags &= ~OPf_SPECIAL;
+#ifdef PERL_DEBUG_READONLY_OPS
+ Slab_to_ro(OpSLAB(o));
+#endif
}
}
return 0;
@@ -2037,7 +1976,7 @@
PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
if (obj) {
- sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
+ sv_setiv(sv, AvFILL(obj));
} else {
SvOK_off(sv);
}
@@ -2053,7 +1992,7 @@
PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
if (obj) {
- av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
+ av_fill(obj, SvIV(sv));
} else {
Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
"Attempt to set length of freed array");
@@ -2062,6 +2001,25 @@
}
int
+Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg)
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P;
+ PERL_UNUSED_ARG(sv);
+
+ /* Reset the iterator when the array is cleared */
+#if IVSIZE == I32SIZE
+ *((IV *) &(mg->mg_len)) = 0;
+#else
+ if (mg->mg_ptr)
+ *((IV *) mg->mg_ptr) = 0;
+#endif
+
+ return 0;
+}
+
+int
Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
@@ -2101,7 +2059,7 @@
I32 i = found->mg_len;
if (DO_UTF8(lsv))
sv_pos_b2u(lsv, &i);
- sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
+ sv_setiv(sv, i);
return 0;
}
}
@@ -2118,6 +2076,7 @@
STRLEN len;
STRLEN ulen = 0;
MAGIC* found;
+ const char *s;
PERL_ARGS_ASSERT_MAGIC_SETPOS;
PERL_UNUSED_ARG(mg);
@@ -2140,12 +2099,12 @@
found->mg_len = -1;
return 0;
}
- len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
+ s = SvPV_const(lsv, len);
- pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
+ pos = SvIV(sv);
if (DO_UTF8(lsv)) {
- ulen = sv_len_utf8(lsv);
+ ulen = sv_or_pv_len_utf8(lsv, s, len);
if (ulen)
len = ulen;
}
@@ -2159,9 +2118,7 @@
pos = len;
if (ulen) {
- I32 p = pos;
- sv_pos_u2b(lsv, &p, 0);
- pos = p;
+ pos = sv_or_pv_pos_u2b(lsv, s, pos, 0);
}
found->mg_len = pos;
@@ -2178,16 +2135,24 @@
const char * const tmps = SvPV_const(lsv,len);
STRLEN offs = LvTARGOFF(sv);
STRLEN rem = LvTARGLEN(sv);
+ const bool negoff = LvFLAGS(sv) & 1;
+ const bool negrem = LvFLAGS(sv) & 2;
PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
PERL_UNUSED_ARG(mg);
+ if (!translate_substr_offsets(
+ SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len,
+ negoff ? -(IV)offs : (IV)offs, !negoff,
+ negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem
+ )) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
+ sv_setsv_nomg(sv, &PL_sv_undef);
+ return 0;
+ }
+
if (SvUTF8(lsv))
- offs = sv_pos_u2b_flags(lsv, offs, &rem, SV_CONST_RETURN);
- if (offs > len)
- offs = len;
- if (rem > len - offs)
- rem = len - offs;
+ offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem);
sv_setpvn(sv, tmps + offs, rem);
if (SvUTF8(lsv))
SvUTF8_on(sv);
@@ -2198,34 +2163,52 @@
Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
- STRLEN len;
+ STRLEN len, lsv_len, oldtarglen, newtarglen;
const char * const tmps = SvPV_const(sv, len);
SV * const lsv = LvTARG(sv);
STRLEN lvoff = LvTARGOFF(sv);
STRLEN lvlen = LvTARGLEN(sv);
+ const bool negoff = LvFLAGS(sv) & 1;
+ const bool neglen = LvFLAGS(sv) & 2;
PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
PERL_UNUSED_ARG(mg);
+ SvGETMAGIC(lsv);
+ if (SvROK(lsv))
+ Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
+ "Attempt to use reference as lvalue in substr"
+ );
+ SvPV_force_nomg(lsv,lsv_len);
+ if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv);
+ if (!translate_substr_offsets(
+ lsv_len,
+ negoff ? -(IV)lvoff : (IV)lvoff, !negoff,
+ neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen
+ ))
+ Perl_croak(aTHX_ "substr outside of string");
+ oldtarglen = lvlen;
if (DO_UTF8(sv)) {
- sv_utf8_upgrade(lsv);
+ sv_utf8_upgrade_nomg(lsv);
lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
- sv_insert(lsv, lvoff, lvlen, tmps, len);
- LvTARGLEN(sv) = sv_len_utf8(sv);
+ sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
+ newtarglen = sv_or_pv_len_utf8(sv, tmps, len);
SvUTF8_on(lsv);
}
- else if (lsv && SvUTF8(lsv)) {
+ else if (SvUTF8(lsv)) {
const char *utf8;
lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
- LvTARGLEN(sv) = len;
+ newtarglen = len;
utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
- sv_insert(lsv, lvoff, lvlen, utf8, len);
+ sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0);
Safefree(utf8);
}
else {
- sv_insert(lsv, lvoff, lvlen, tmps, len);
- LvTARGLEN(sv) = len;
+ sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
+ newtarglen = len;
}
+ if (!neglen) LvTARGLEN(sv) = newtarglen;
+ if (negoff) LvTARGOFF(sv) += newtarglen - oldtarglen;
return 0;
}
@@ -2237,6 +2220,9 @@
PERL_ARGS_ASSERT_MAGIC_GETTAINT;
PERL_UNUSED_ARG(sv);
+#ifdef NO_TAINT_SUPPORT
+ PERL_UNUSED_ARG(mg);
+#endif
TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
return 0;
@@ -2251,7 +2237,7 @@
PERL_UNUSED_ARG(sv);
/* update taint status */
- if (PL_tainted)
+ if (TAINT_get)
mg->mg_len |= 1;
else
mg->mg_len &= ~1;
@@ -2384,9 +2370,8 @@
{
PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
PERL_UNUSED_CONTEXT;
+ PERL_UNUSED_ARG(sv);
mg->mg_len = -1;
- if (!isGV_with_GP(sv))
- SvSCREAM_off(sv);
return 0;
}
@@ -2457,9 +2442,9 @@
Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
- register const char *s;
- register I32 paren;
- register const REGEXP * rx;
+ const char *s;
+ I32 paren;
+ const REGEXP * rx;
const char * const remaining = mg->mg_ptr + 1;
I32 i;
STRLEN len;
@@ -2488,20 +2473,31 @@
paren = atoi(mg->mg_ptr);
setparen:
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
+ setparen_got_rx:
CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
} else {
/* Croak with a READONLY error when a numbered match var is
* set without a previous pattern match. Unless it's C<local $1>
*/
+ croakparen:
if (!PL_localizing) {
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
}
}
break;
case '\001': /* ^A */
- sv_setsv(PL_bodytarget, sv);
+ if (SvOK(sv)) sv_copypv(PL_bodytarget, sv);
+ else SvOK_off(PL_bodytarget);
+ FmLINES(PL_bodytarget) = 0;
+ if (SvPOK(PL_bodytarget)) {
+ char *s = SvPVX(PL_bodytarget);
+ while ( ((s = strchr(s, '\n'))) ) {
+ FmLINES(PL_bodytarget)++;
+ s++;
+ }
+ }
/* mg_set() has temporarily made sv non-magical */
- if (PL_tainting) {
+ if (TAINTING_get) {
if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
SvTAINTED_on(PL_bodytarget);
else
@@ -2559,6 +2555,10 @@
Safefree(PL_inplace);
PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
break;
+ case '\016': /* ^N */
+ if (PL_curpm && (rx = PM_GETRE(PL_curpm))
+ && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
+ goto croakparen;
case '\017': /* ^O */
if (*(mg->mg_ptr+1) == '\0') {
Safefree(PL_osname);
@@ -2626,9 +2626,8 @@
}
else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
- if (!SvPOK(sv) && PL_localizing) {
- sv_setpvn(sv, WARN_NONEstring, WARNsize);
- PL_compiling.cop_warnings = pWARN_NONE;
+ if (!SvPOK(sv)) {
+ PL_compiling.cop_warnings = pWARN_STD;
break;
}
{
@@ -2678,33 +2677,25 @@
IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
break;
case '^':
- if (isGV_with_GP(PL_defoutgv)) {
- Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
- s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
- IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
- }
+ Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
+ s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
+ IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
break;
case '~':
- if (isGV_with_GP(PL_defoutgv)) {
- Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
- s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
- IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
- }
+ Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
+ s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
+ IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
break;
case '=':
- if (isGV_with_GP(PL_defoutgv))
- IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
+ IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
break;
case '-':
- if (isGV_with_GP(PL_defoutgv)) {
- IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
- if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
+ IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
+ if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
- }
break;
case '%':
- if (isGV_with_GP(PL_defoutgv))
- IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
+ IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
break;
case '|':
{
@@ -2729,7 +2720,7 @@
break;
case '\\':
SvREFCNT_dec(PL_ors_sv);
- if (SvOK(sv) || SvGMAGICAL(sv)) {
+ if (SvOK(sv)) {
PL_ors_sv = newSVsv(sv);
}
else {
@@ -2737,7 +2728,8 @@
}
break;
case '[':
- CopARYBASE_set(&PL_compiling, SvIV(sv));
+ if (SvIV(sv) != 0)
+ Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
break;
case '?':
#ifdef COMPLEX_STATUS
@@ -2767,89 +2759,94 @@
}
break;
case '<':
- PL_uid = SvIV(sv);
+ {
+ const IV new_uid = SvIV(sv);
+ PL_delaymagic_uid = new_uid;
if (PL_delaymagic) {
PL_delaymagic |= DM_RUID;
break; /* don't do magic till later */
}
#ifdef HAS_SETRUID
- (void)setruid((Uid_t)PL_uid);
+ (void)setruid((Uid_t)new_uid);
#else
#ifdef HAS_SETREUID
- (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
+ (void)setreuid((Uid_t)new_uid, (Uid_t)-1);
#else
#ifdef HAS_SETRESUID
- (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
+ (void)setresuid((Uid_t)new_uid, (Uid_t)-1, (Uid_t)-1);
#else
- if (PL_uid == PL_euid) { /* special case $< = $> */
+ if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */
#ifdef PERL_DARWIN
/* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
- if (PL_uid != 0 && PerlProc_getuid() == 0)
+ if (new_uid != 0 && PerlProc_getuid() == 0)
(void)PerlProc_setuid(0);
#endif
- (void)PerlProc_setuid(PL_uid);
+ (void)PerlProc_setuid(new_uid);
} else {
- PL_uid = PerlProc_getuid();
Perl_croak(aTHX_ "setruid() not implemented");
}
#endif
#endif
#endif
- PL_uid = PerlProc_getuid();
break;
+ }
case '>':
- PL_euid = SvIV(sv);
+ {
+ const UV new_euid = SvIV(sv);
+ PL_delaymagic_euid = new_euid;
if (PL_delaymagic) {
PL_delaymagic |= DM_EUID;
break; /* don't do magic till later */
}
#ifdef HAS_SETEUID
- (void)seteuid((Uid_t)PL_euid);
+ (void)seteuid((Uid_t)new_euid);
#else
#ifdef HAS_SETREUID
- (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
+ (void)setreuid((Uid_t)-1, (Uid_t)new_euid);
#else
#ifdef HAS_SETRESUID
- (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
+ (void)setresuid((Uid_t)-1, (Uid_t)new_euid, (Uid_t)-1);
#else
- if (PL_euid == PL_uid) /* special case $> = $< */
- PerlProc_setuid(PL_euid);
+ if (new_euid == PerlProc_getuid()) /* special case $> = $< */
+ PerlProc_setuid(new_euid);
else {
- PL_euid = PerlProc_geteuid();
Perl_croak(aTHX_ "seteuid() not implemented");
}
#endif
#endif
#endif
- PL_euid = PerlProc_geteuid();
break;
+ }
case '(':
- PL_gid = SvIV(sv);
+ {
+ const UV new_gid = SvIV(sv);
+ PL_delaymagic_gid = new_gid;
if (PL_delaymagic) {
PL_delaymagic |= DM_RGID;
break; /* don't do magic till later */
}
#ifdef HAS_SETRGID
- (void)setrgid((Gid_t)PL_gid);
+ (void)setrgid((Gid_t)new_gid);
#else
#ifdef HAS_SETREGID
- (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
+ (void)setregid((Gid_t)new_gid, (Gid_t)-1);
#else
#ifdef HAS_SETRESGID
- (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
+ (void)setresgid((Gid_t)new_gid, (Gid_t)-1, (Gid_t) -1);
#else
- if (PL_gid == PL_egid) /* special case $( = $) */
- (void)PerlProc_setgid(PL_gid);
+ if (new_gid == PerlProc_getegid()) /* special case $( = $) */
+ (void)PerlProc_setgid(new_gid);
else {
- PL_gid = PerlProc_getgid();
Perl_croak(aTHX_ "setrgid() not implemented");
}
#endif
#endif
#endif
- PL_gid = PerlProc_getgid();
break;
+ }
case ')':
+ {
+ UV new_egid;
#ifdef HAS_SETGROUPS
{
const char *p = SvPV_const(sv, len);
@@ -2865,7 +2862,7 @@
while (isSPACE(*p))
++p;
- PL_egid = Atol(p);
+ new_egid = Atol(p);
for (i = 0; i < maxgrp; ++i) {
while (*p && !isSPACE(*p))
++p;
@@ -2884,35 +2881,46 @@
Safefree(gary);
}
#else /* HAS_SETGROUPS */
- PL_egid = SvIV(sv);
+ new_egid = SvIV(sv);
#endif /* HAS_SETGROUPS */
+ PL_delaymagic_egid = new_egid;
if (PL_delaymagic) {
PL_delaymagic |= DM_EGID;
break; /* don't do magic till later */
}
#ifdef HAS_SETEGID
- (void)setegid((Gid_t)PL_egid);
+ (void)setegid((Gid_t)new_egid);
#else
#ifdef HAS_SETREGID
- (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
+ (void)setregid((Gid_t)-1, (Gid_t)new_egid);
#else
#ifdef HAS_SETRESGID
- (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
+ (void)setresgid((Gid_t)-1, (Gid_t)new_egid, (Gid_t)-1);
#else
- if (PL_egid == PL_gid) /* special case $) = $( */
- (void)PerlProc_setgid(PL_egid);
+ if (new_egid == PerlProc_getgid()) /* special case $) = $( */
+ (void)PerlProc_setgid(new_egid);
else {
- PL_egid = PerlProc_getegid();
Perl_croak(aTHX_ "setegid() not implemented");
}
#endif
#endif
#endif
- PL_egid = PerlProc_getegid();
break;
+ }
case ':':
PL_chopset = SvPV_force(sv,len);
break;
+ case '$': /* $$ */
+ /* Store the pid in mg->mg_obj so we can tell when a fork has
+ occurred. mg->mg_obj points to *$ by default, so clear it. */
+ if (isGV(mg->mg_obj)) {
+ if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
+ SvREFCNT_dec(mg->mg_obj);
+ mg->mg_flags |= MGf_REFCOUNTED;
+ mg->mg_obj = newSViv((IV)PerlProc_getpid());
+ }
+ else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
+ break;
case '0':
LOCK_DOLLARZERO_MUTEX;
#ifdef HAS_SETPROCTITLE
@@ -2990,22 +2998,41 @@
}
I32
-Perl_whichsig(pTHX_ const char *sig)
+Perl_whichsig_sv(pTHX_ SV *sigsv)
{
- register char* const* sigv;
+ const char *sigpv;
+ STRLEN siglen;
+ PERL_ARGS_ASSERT_WHICHSIG_SV;
+ PERL_UNUSED_CONTEXT;
+ sigpv = SvPV_const(sigsv, siglen);
+ return whichsig_pvn(sigpv, siglen);
+}
- PERL_ARGS_ASSERT_WHICHSIG;
+I32
+Perl_whichsig_pv(pTHX_ const char *sig)
+{
+ PERL_ARGS_ASSERT_WHICHSIG_PV;
PERL_UNUSED_CONTEXT;
+ return whichsig_pvn(sig, strlen(sig));
+}
+I32
+Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
+{
+ char* const* sigv;
+
+ PERL_ARGS_ASSERT_WHICHSIG_PVN;
+ PERL_UNUSED_CONTEXT;
+
for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
- if (strEQ(sig,*sigv))
+ if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
return PL_sig_num[sigv - (char* const*)PL_sig_name];
#ifdef SIGCLD
- if (strEQ(sig,"CHLD"))
+ if (memEQs(sig, len, "CHLD"))
return SIGCLD;
#endif
#ifdef SIGCHLD
- if (strEQ(sig,"CLD"))
+ if (memEQs(sig, len, "CLD"))
return SIGCHLD;
#endif
return -1;
@@ -3032,6 +3059,7 @@
U32 flags = 0;
XPV * const tXpv = PL_Xpv;
I32 old_ss_ix = PL_savestack_ix;
+ SV *errsv_save = NULL;
if (!PL_psig_ptr[sig]) {
@@ -3110,10 +3138,15 @@
#endif
PUTBACK;
+ errsv_save = newSVsv(ERRSV);
+
call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
POPSTACK;
- if (SvTRUE(ERRSV)) {
+ {
+ SV * const errsv = ERRSV;
+ if (SvTRUE_NN(errsv)) {
+ SvREFCNT_dec(errsv_save);
#ifndef PERL_MICRO
/* Handler "died", for example to get out of a restart-able read().
* Before we re-do that on its behalf re-enable the signal which was
@@ -3121,22 +3154,28 @@
*/
#ifdef HAS_SIGPROCMASK
#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
- if (sip || uap)
+ if (sip || uap)
#endif
- {
- sigset_t set;
- sigemptyset(&set);
- sigaddset(&set,sig);
- sigprocmask(SIG_UNBLOCK, &set, NULL);
- }
+ {
+ sigset_t set;
+ sigemptyset(&set);
+ sigaddset(&set,sig);
+ sigprocmask(SIG_UNBLOCK, &set, NULL);
+ }
#else
- /* Not clear if this will work */
- (void)rsignal(sig, SIG_IGN);
- (void)rsignal(sig, PL_csighandlerp);
+ /* Not clear if this will work */
+ (void)rsignal(sig, SIG_IGN);
+ (void)rsignal(sig, PL_csighandlerp);
#endif
#endif /* !PERL_MICRO */
- die_sv(ERRSV);
+ die_sv(errsv);
+ }
+ else {
+ sv_setsv(errsv, errsv_save);
+ SvREFCNT_dec(errsv_save);
+ }
}
+
cleanup:
/* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
PL_savestack_ix = old_ss_ix;
@@ -3161,8 +3200,8 @@
if (!sv)
return;
- if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
- {
+ if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
+ SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
#ifdef PERL_OLD_COPY_ON_WRITE
/* While magic was saved (and off) sv_setsv may well have seen
this SV as a prime candidate for COW. */
@@ -3169,7 +3208,6 @@
if (SvIsCOW(sv))
sv_force_normal_flags(sv, 0);
#endif
-
if (mgs->mgs_readonly)
SvREADONLY_on(sv);
if (mgs->mgs_magical)
@@ -3176,16 +3214,6 @@
SvFLAGS(sv) |= mgs->mgs_magical;
else
mg_magical(sv);
- if (SvGMAGICAL(sv)) {
- /* downgrade public flags to private,
- and discard any other private flags */
-
- const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
- if (pubflags) {
- SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
- SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
- }
- }
}
bumped = mgs->mgs_bumped;
@@ -3214,12 +3242,8 @@
So artificially keep it alive a bit longer.
We avoid turning on the TEMP flag, which can cause the SV's
buffer to get stolen (and maybe other stuff). */
- int was_temp = SvTEMP(sv);
sv_2mortal(sv);
- if (!was_temp) {
- SvTEMP_off(sv);
- }
- SvOK_off(sv);
+ SvTEMP_off(sv);
}
else
SvREFCNT_dec(sv); /* undo the inc in S_save_magic() */
@@ -3289,14 +3313,13 @@
PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
PERL_UNUSED_ARG(sv);
- assert(mg->mg_len == HEf_SVKEY);
-
- PERL_UNUSED_ARG(sv);
-
PL_hints |= HINT_LOCALIZE_HH;
CopHINTHASH_set(&PL_compiling,
- cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
- MUTABLE_SV(mg->mg_ptr), 0, 0));
+ mg->mg_len == HEf_SVKEY
+ ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
+ MUTABLE_SV(mg->mg_ptr), 0, 0)
+ : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
+ mg->mg_ptr, mg->mg_len, 0, 0));
return 0;
}
@@ -3318,12 +3341,32 @@
return 0;
}
+int
+Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
+ const char *name, I32 namlen)
+{
+ MAGIC *nmg;
+
+ PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
+ PERL_UNUSED_ARG(sv);
+ PERL_UNUSED_ARG(name);
+ PERL_UNUSED_ARG(namlen);
+
+ sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
+ nmg = mg_find(nsv, mg->mg_type);
+ if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
+ nmg->mg_ptr = mg->mg_ptr;
+ nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
+ nmg->mg_flags |= MGf_REFCOUNTED;
+ return 1;
+}
+
/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/mg.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.4
\ No newline at end of property
Modified: trunk/contrib/perl/mg.h
===================================================================
--- trunk/contrib/perl/mg.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/mg.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -61,12 +61,14 @@
#define SvTIED_obj(sv,mg) \
((mg)->mg_obj ? (mg)->mg_obj : sv_2mortal(newRV(sv)))
+#define whichsig(pv) whichsig_pv(pv)
+
/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/mg.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/mg_names.c (from rev 6437, vendor/perl/5.18.1/mg_names.c)
===================================================================
--- trunk/contrib/perl/mg_names.c (rev 0)
+++ trunk/contrib/perl/mg_names.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -0,0 +1,52 @@
+/* -*- buffer-read-only: t -*-
+ *
+ * mg_names.c
+ * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ * This file is built by regen/mg_vtable.pl.
+ * Any changes made here will be lost!
+ */
+
+ { PERL_MAGIC_sv, "sv(\\0)" },
+ { PERL_MAGIC_arylen, "arylen(#)" },
+ { PERL_MAGIC_rhash, "rhash(%)" },
+ { PERL_MAGIC_proto, "proto(&)" },
+ { PERL_MAGIC_pos, "pos(.)" },
+ { PERL_MAGIC_symtab, "symtab(:)" },
+ { PERL_MAGIC_backref, "backref(<)" },
+ { PERL_MAGIC_arylen_p, "arylen_p(@)" },
+ { PERL_MAGIC_bm, "bm(B)" },
+ { PERL_MAGIC_overload_table, "overload_table(c)" },
+ { PERL_MAGIC_regdata, "regdata(D)" },
+ { PERL_MAGIC_regdatum, "regdatum(d)" },
+ { PERL_MAGIC_env, "env(E)" },
+ { PERL_MAGIC_envelem, "envelem(e)" },
+ { PERL_MAGIC_fm, "fm(f)" },
+ { PERL_MAGIC_regex_global, "regex_global(g)" },
+ { PERL_MAGIC_hints, "hints(H)" },
+ { PERL_MAGIC_hintselem, "hintselem(h)" },
+ { PERL_MAGIC_isa, "isa(I)" },
+ { PERL_MAGIC_isaelem, "isaelem(i)" },
+ { PERL_MAGIC_nkeys, "nkeys(k)" },
+ { PERL_MAGIC_dbfile, "dbfile(L)" },
+ { PERL_MAGIC_dbline, "dbline(l)" },
+ { PERL_MAGIC_shared, "shared(N)" },
+ { PERL_MAGIC_shared_scalar, "shared_scalar(n)" },
+ { PERL_MAGIC_collxfrm, "collxfrm(o)" },
+ { PERL_MAGIC_tied, "tied(P)" },
+ { PERL_MAGIC_tiedelem, "tiedelem(p)" },
+ { PERL_MAGIC_tiedscalar, "tiedscalar(q)" },
+ { PERL_MAGIC_qr, "qr(r)" },
+ { PERL_MAGIC_sig, "sig(S)" },
+ { PERL_MAGIC_sigelem, "sigelem(s)" },
+ { PERL_MAGIC_taint, "taint(t)" },
+ { PERL_MAGIC_uvar, "uvar(U)" },
+ { PERL_MAGIC_uvar_elem, "uvar_elem(u)" },
+ { PERL_MAGIC_vstring, "vstring(V)" },
+ { PERL_MAGIC_vec, "vec(v)" },
+ { PERL_MAGIC_utf8, "utf8(w)" },
+ { PERL_MAGIC_substr, "substr(x)" },
+ { PERL_MAGIC_defelem, "defelem(y)" },
+ { PERL_MAGIC_checkcall, "checkcall(])" },
+ { PERL_MAGIC_ext, "ext(~)" },
+
+/* ex: set ro: */
Copied: trunk/contrib/perl/mg_raw.h (from rev 6437, vendor/perl/5.18.1/mg_raw.h)
===================================================================
--- trunk/contrib/perl/mg_raw.h (rev 0)
+++ trunk/contrib/perl/mg_raw.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -0,0 +1,88 @@
+/* -*- buffer-read-only: t -*-
+ *
+ * mg_raw.h
+ * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ * This file is built by regen/mg_vtable.pl.
+ * Any changes made here will be lost!
+ */
+
+ { '\0', "want_vtbl_sv | PERL_MAGIC_READONLY_ACCEPTABLE",
+ "/* sv '\\0' Special scalar variable */" },
+ { '#', "want_vtbl_arylen | PERL_MAGIC_VALUE_MAGIC",
+ "/* arylen '#' Array length ($#ary) */" },
+ { '%', "magic_vtable_max | PERL_MAGIC_VALUE_MAGIC",
+ "/* rhash '%' extra data for restricted hashes */" },
+ { '&', "magic_vtable_max",
+ "/* proto '&' my sub prototype CV */" },
+ { '.', "want_vtbl_pos | PERL_MAGIC_VALUE_MAGIC",
+ "/* pos '.' pos() lvalue */" },
+ { ':', "magic_vtable_max | PERL_MAGIC_VALUE_MAGIC",
+ "/* symtab ':' extra data for symbol tables */" },
+ { '<', "want_vtbl_backref | PERL_MAGIC_READONLY_ACCEPTABLE | PERL_MAGIC_VALUE_MAGIC",
+ "/* backref '<' for weak ref data */" },
+ { '@', "magic_vtable_max | PERL_MAGIC_VALUE_MAGIC",
+ "/* arylen_p '@' to move arylen out of XPVAV */" },
+ { 'B', "want_vtbl_regexp | PERL_MAGIC_READONLY_ACCEPTABLE | PERL_MAGIC_VALUE_MAGIC",
+ "/* bm 'B' Boyer-Moore (fast string search) */" },
+ { 'c', "want_vtbl_ovrld",
+ "/* overload_table 'c' Holds overload table (AMT) on stash */" },
+ { 'D', "want_vtbl_regdata",
+ "/* regdata 'D' Regex match position data (@+ and @- vars) */" },
+ { 'd', "want_vtbl_regdatum",
+ "/* regdatum 'd' Regex match position data element */" },
+ { 'E', "want_vtbl_env",
+ "/* env 'E' %ENV hash */" },
+ { 'e', "want_vtbl_envelem",
+ "/* envelem 'e' %ENV hash element */" },
+ { 'f', "want_vtbl_regexp | PERL_MAGIC_READONLY_ACCEPTABLE | PERL_MAGIC_VALUE_MAGIC",
+ "/* fm 'f' Formline ('compiled' format) */" },
+ { 'g', "want_vtbl_mglob | PERL_MAGIC_READONLY_ACCEPTABLE | PERL_MAGIC_VALUE_MAGIC",
+ "/* regex_global 'g' m//g target */" },
+ { 'H', "want_vtbl_hints",
+ "/* hints 'H' %^H hash */" },
+ { 'h', "want_vtbl_hintselem",
+ "/* hintselem 'h' %^H hash element */" },
+ { 'I', "want_vtbl_isa",
+ "/* isa 'I' @ISA array */" },
+ { 'i', "want_vtbl_isaelem",
+ "/* isaelem 'i' @ISA array element */" },
+ { 'k', "want_vtbl_nkeys | PERL_MAGIC_VALUE_MAGIC",
+ "/* nkeys 'k' scalar(keys()) lvalue */" },
+ { 'L', "magic_vtable_max",
+ "/* dbfile 'L' Debugger %_<filename */" },
+ { 'l', "want_vtbl_dbline",
+ "/* dbline 'l' Debugger %_<filename element */" },
+ { 'o', "want_vtbl_collxfrm | PERL_MAGIC_VALUE_MAGIC",
+ "/* collxfrm 'o' Locale transformation */" },
+ { 'P', "want_vtbl_pack | PERL_MAGIC_VALUE_MAGIC",
+ "/* tied 'P' Tied array or hash */" },
+ { 'p', "want_vtbl_packelem",
+ "/* tiedelem 'p' Tied array or hash element */" },
+ { 'q', "want_vtbl_packelem",
+ "/* tiedscalar 'q' Tied scalar or handle */" },
+ { 'r', "want_vtbl_regexp | PERL_MAGIC_VALUE_MAGIC",
+ "/* qr 'r' precompiled qr// regex */" },
+ { 'S', "magic_vtable_max",
+ "/* sig 'S' %SIG hash */" },
+ { 's', "want_vtbl_sigelem",
+ "/* sigelem 's' %SIG hash element */" },
+ { 't', "want_vtbl_taint | PERL_MAGIC_VALUE_MAGIC",
+ "/* taint 't' Taintedness */" },
+ { 'U', "want_vtbl_uvar",
+ "/* uvar 'U' Available for use by extensions */" },
+ { 'V', "magic_vtable_max | PERL_MAGIC_VALUE_MAGIC",
+ "/* vstring 'V' SV was vstring literal */" },
+ { 'v', "want_vtbl_vec | PERL_MAGIC_VALUE_MAGIC",
+ "/* vec 'v' vec() lvalue */" },
+ { 'w', "want_vtbl_utf8 | PERL_MAGIC_VALUE_MAGIC",
+ "/* utf8 'w' Cached UTF-8 information */" },
+ { 'x', "want_vtbl_substr | PERL_MAGIC_VALUE_MAGIC",
+ "/* substr 'x' substr() lvalue */" },
+ { 'y', "want_vtbl_defelem | PERL_MAGIC_VALUE_MAGIC",
+ "/* defelem 'y' Shadow \"foreach\" iterator variable / smart parameter vivification */" },
+ { ']', "want_vtbl_checkcall | PERL_MAGIC_VALUE_MAGIC",
+ "/* checkcall ']' inlining/mutation of call to this CV */" },
+ { '~', "magic_vtable_max",
+ "/* ext '~' Available for use by extensions */" },
+
+/* ex: set ro: */
Copied: trunk/contrib/perl/mg_vtable.h (from rev 6437, vendor/perl/5.18.1/mg_vtable.h)
===================================================================
--- trunk/contrib/perl/mg_vtable.h (rev 0)
+++ trunk/contrib/perl/mg_vtable.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -0,0 +1,225 @@
+/* -*- buffer-read-only: t -*-
+ *
+ * mg_vtable.h
+ * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ * This file is built by regen/mg_vtable.pl.
+ * Any changes made here will be lost!
+ */
+
+/* These constants should be used in preference to raw characters
+ * when using magic. Note that some perl guts still assume
+ * certain character properties of these constants, namely that
+ * isUPPER() and toLOWER() may do useful mappings.
+ */
+
+#define PERL_MAGIC_sv '\0' /* Special scalar variable */
+#define PERL_MAGIC_arylen '#' /* Array length ($#ary) */
+#define PERL_MAGIC_rhash '%' /* extra data for restricted hashes */
+#define PERL_MAGIC_proto '&' /* my sub prototype CV */
+#define PERL_MAGIC_pos '.' /* pos() lvalue */
+#define PERL_MAGIC_symtab ':' /* extra data for symbol tables */
+#define PERL_MAGIC_backref '<' /* for weak ref data */
+#define PERL_MAGIC_arylen_p '@' /* to move arylen out of XPVAV */
+#define PERL_MAGIC_bm 'B' /* Boyer-Moore (fast string search) */
+#define PERL_MAGIC_overload_table 'c' /* Holds overload table (AMT) on stash */
+#define PERL_MAGIC_regdata 'D' /* Regex match position data
+ (@+ and @- vars) */
+#define PERL_MAGIC_regdatum 'd' /* Regex match position data element */
+#define PERL_MAGIC_env 'E' /* %ENV hash */
+#define PERL_MAGIC_envelem 'e' /* %ENV hash element */
+#define PERL_MAGIC_fm 'f' /* Formline ('compiled' format) */
+#define PERL_MAGIC_regex_global 'g' /* m//g target */
+#define PERL_MAGIC_hints 'H' /* %^H hash */
+#define PERL_MAGIC_hintselem 'h' /* %^H hash element */
+#define PERL_MAGIC_isa 'I' /* @ISA array */
+#define PERL_MAGIC_isaelem 'i' /* @ISA array element */
+#define PERL_MAGIC_nkeys 'k' /* scalar(keys()) lvalue */
+#define PERL_MAGIC_dbfile 'L' /* Debugger %_<filename */
+#define PERL_MAGIC_dbline 'l' /* Debugger %_<filename element */
+#define PERL_MAGIC_shared 'N' /* Shared between threads */
+#define PERL_MAGIC_shared_scalar 'n' /* Shared between threads */
+#define PERL_MAGIC_collxfrm 'o' /* Locale transformation */
+#define PERL_MAGIC_tied 'P' /* Tied array or hash */
+#define PERL_MAGIC_tiedelem 'p' /* Tied array or hash element */
+#define PERL_MAGIC_tiedscalar 'q' /* Tied scalar or handle */
+#define PERL_MAGIC_qr 'r' /* precompiled qr// regex */
+#define PERL_MAGIC_sig 'S' /* %SIG hash */
+#define PERL_MAGIC_sigelem 's' /* %SIG hash element */
+#define PERL_MAGIC_taint 't' /* Taintedness */
+#define PERL_MAGIC_uvar 'U' /* Available for use by extensions */
+#define PERL_MAGIC_uvar_elem 'u' /* Reserved for use by extensions */
+#define PERL_MAGIC_vstring 'V' /* SV was vstring literal */
+#define PERL_MAGIC_vec 'v' /* vec() lvalue */
+#define PERL_MAGIC_utf8 'w' /* Cached UTF-8 information */
+#define PERL_MAGIC_substr 'x' /* substr() lvalue */
+#define PERL_MAGIC_defelem 'y' /* Shadow "foreach" iterator variable /
+ smart parameter vivification */
+#define PERL_MAGIC_checkcall ']' /* inlining/mutation of call to this CV */
+#define PERL_MAGIC_ext '~' /* Available for use by extensions */
+
+enum { /* pass one of these to get_vtbl */
+ want_vtbl_arylen,
+ want_vtbl_arylen_p,
+ want_vtbl_backref,
+ want_vtbl_checkcall,
+ want_vtbl_collxfrm,
+ want_vtbl_dbline,
+ want_vtbl_defelem,
+ want_vtbl_env,
+ want_vtbl_envelem,
+ want_vtbl_hints,
+ want_vtbl_hintselem,
+ want_vtbl_isa,
+ want_vtbl_isaelem,
+ want_vtbl_mglob,
+ want_vtbl_nkeys,
+ want_vtbl_ovrld,
+ want_vtbl_pack,
+ want_vtbl_packelem,
+ want_vtbl_pos,
+ want_vtbl_regdata,
+ want_vtbl_regdatum,
+ want_vtbl_regexp,
+ want_vtbl_sigelem,
+ want_vtbl_substr,
+ want_vtbl_sv,
+ want_vtbl_taint,
+ want_vtbl_utf8,
+ want_vtbl_uvar,
+ want_vtbl_vec,
+ magic_vtable_max
+};
+
+#ifdef DOINIT
+EXTCONST char * const PL_magic_vtable_names[magic_vtable_max] = {
+ "arylen",
+ "arylen_p",
+ "backref",
+ "checkcall",
+ "collxfrm",
+ "dbline",
+ "defelem",
+ "env",
+ "envelem",
+ "hints",
+ "hintselem",
+ "isa",
+ "isaelem",
+ "mglob",
+ "nkeys",
+ "ovrld",
+ "pack",
+ "packelem",
+ "pos",
+ "regdata",
+ "regdatum",
+ "regexp",
+ "sigelem",
+ "substr",
+ "sv",
+ "taint",
+ "utf8",
+ "uvar",
+ "vec"
+};
+#else
+EXTCONST char * const PL_magic_vtable_names[magic_vtable_max];
+#endif
+
+/* These all need to be 0, not NULL, as NULL can be (void*)0, which is a
+ * pointer to data, whereas we're assigning pointers to functions, which are
+ * not the same beast. ANSI doesn't allow the assignment from one to the other.
+ * (although most, but not all, compilers are prepared to do it)
+ */
+
+/* order is:
+ get
+ set
+ len
+ clear
+ free
+ copy
+ dup
+ local
+*/
+
+#ifdef DOINIT
+EXT_MGVTBL PL_magic_vtables[magic_vtable_max] = {
+ { (int (*)(pTHX_ SV *, MAGIC *))Perl_magic_getarylen, Perl_magic_setarylen, 0, 0, 0, 0, 0, 0 },
+ { 0, 0, 0, Perl_magic_cleararylen_p, Perl_magic_freearylen_p, 0, 0, 0 },
+ { 0, 0, 0, 0, Perl_magic_killbackrefs, 0, 0, 0 },
+ { 0, 0, 0, 0, 0, Perl_magic_copycallchecker, 0, 0 },
+#ifdef USE_LOCALE_COLLATE
+ { 0, Perl_magic_setcollxfrm, 0, 0, 0, 0, 0, 0 },
+#else
+ { 0, 0, 0, 0, 0, 0, 0, 0 },
+#endif
+ { 0, Perl_magic_setdbline, 0, 0, 0, 0, 0, 0 },
+ { Perl_magic_getdefelem, Perl_magic_setdefelem, 0, 0, 0, 0, 0, 0 },
+ { 0, Perl_magic_set_all_env, 0, Perl_magic_clear_all_env, 0, 0, 0, 0 },
+ { 0, Perl_magic_setenv, 0, Perl_magic_clearenv, 0, 0, 0, 0 },
+ { 0, 0, 0, Perl_magic_clearhints, 0, 0, 0, 0 },
+ { 0, Perl_magic_sethint, 0, Perl_magic_clearhint, 0, 0, 0, 0 },
+ { 0, Perl_magic_setisa, 0, Perl_magic_clearisa, 0, 0, 0, 0 },
+ { 0, Perl_magic_setisa, 0, 0, 0, 0, 0, 0 },
+ { 0, Perl_magic_setmglob, 0, 0, 0, 0, 0, 0 },
+ { Perl_magic_getnkeys, Perl_magic_setnkeys, 0, 0, 0, 0, 0, 0 },
+ { 0, 0, 0, 0, Perl_magic_freeovrld, 0, 0, 0 },
+ { 0, 0, Perl_magic_sizepack, Perl_magic_wipepack, 0, 0, 0, 0 },
+ { Perl_magic_getpack, Perl_magic_setpack, 0, Perl_magic_clearpack, 0, 0, 0, 0 },
+ { Perl_magic_getpos, Perl_magic_setpos, 0, 0, 0, 0, 0, 0 },
+ { 0, 0, Perl_magic_regdata_cnt, 0, 0, 0, 0, 0 },
+ { Perl_magic_regdatum_get, Perl_magic_regdatum_set, 0, 0, 0, 0, 0, 0 },
+ { 0, Perl_magic_setregexp, 0, 0, 0, 0, 0, 0 },
+#ifndef PERL_MICRO
+ { Perl_magic_getsig, Perl_magic_setsig, 0, Perl_magic_clearsig, 0, 0, 0, 0 },
+#else
+ { 0, 0, 0, 0, 0, 0, 0, 0 },
+#endif
+ { Perl_magic_getsubstr, Perl_magic_setsubstr, 0, 0, 0, 0, 0, 0 },
+ { Perl_magic_get, Perl_magic_set, 0, 0, 0, 0, 0, 0 },
+ { Perl_magic_gettaint, Perl_magic_settaint, 0, 0, 0, 0, 0, 0 },
+ { 0, Perl_magic_setutf8, 0, 0, 0, 0, 0, 0 },
+ { Perl_magic_getuvar, Perl_magic_setuvar, 0, 0, 0, 0, 0, 0 },
+ { Perl_magic_getvec, Perl_magic_setvec, 0, 0, 0, 0, 0, 0 }
+};
+#else
+EXT_MGVTBL PL_magic_vtables[magic_vtable_max];
+#endif
+
+#define want_vtbl_bm want_vtbl_regexp
+#define want_vtbl_fm want_vtbl_regexp
+
+#define PL_vtbl_arylen PL_magic_vtables[want_vtbl_arylen]
+#define PL_vtbl_arylen_p PL_magic_vtables[want_vtbl_arylen_p]
+#define PL_vtbl_backref PL_magic_vtables[want_vtbl_backref]
+#define PL_vtbl_bm PL_magic_vtables[want_vtbl_bm]
+#define PL_vtbl_checkcall PL_magic_vtables[want_vtbl_checkcall]
+#define PL_vtbl_collxfrm PL_magic_vtables[want_vtbl_collxfrm]
+#define PL_vtbl_dbline PL_magic_vtables[want_vtbl_dbline]
+#define PL_vtbl_defelem PL_magic_vtables[want_vtbl_defelem]
+#define PL_vtbl_env PL_magic_vtables[want_vtbl_env]
+#define PL_vtbl_envelem PL_magic_vtables[want_vtbl_envelem]
+#define PL_vtbl_fm PL_magic_vtables[want_vtbl_fm]
+#define PL_vtbl_hints PL_magic_vtables[want_vtbl_hints]
+#define PL_vtbl_hintselem PL_magic_vtables[want_vtbl_hintselem]
+#define PL_vtbl_isa PL_magic_vtables[want_vtbl_isa]
+#define PL_vtbl_isaelem PL_magic_vtables[want_vtbl_isaelem]
+#define PL_vtbl_mglob PL_magic_vtables[want_vtbl_mglob]
+#define PL_vtbl_nkeys PL_magic_vtables[want_vtbl_nkeys]
+#define PL_vtbl_ovrld PL_magic_vtables[want_vtbl_ovrld]
+#define PL_vtbl_pack PL_magic_vtables[want_vtbl_pack]
+#define PL_vtbl_packelem PL_magic_vtables[want_vtbl_packelem]
+#define PL_vtbl_pos PL_magic_vtables[want_vtbl_pos]
+#define PL_vtbl_regdata PL_magic_vtables[want_vtbl_regdata]
+#define PL_vtbl_regdatum PL_magic_vtables[want_vtbl_regdatum]
+#define PL_vtbl_regexp PL_magic_vtables[want_vtbl_regexp]
+#define PL_vtbl_sigelem PL_magic_vtables[want_vtbl_sigelem]
+#define PL_vtbl_substr PL_magic_vtables[want_vtbl_substr]
+#define PL_vtbl_sv PL_magic_vtables[want_vtbl_sv]
+#define PL_vtbl_taint PL_magic_vtables[want_vtbl_taint]
+#define PL_vtbl_utf8 PL_magic_vtables[want_vtbl_utf8]
+#define PL_vtbl_uvar PL_magic_vtables[want_vtbl_uvar]
+#define PL_vtbl_vec PL_magic_vtables[want_vtbl_vec]
+
+/* ex: set ro: */
Modified: trunk/contrib/perl/minimod.pl
===================================================================
--- trunk/contrib/perl/minimod.pl 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/minimod.pl 2013-12-02 21:18:17 UTC (rev 6438)
@@ -71,7 +71,7 @@
my ($tail1,$tail2,$tail3) = ( $tail =~ /\A(.*{\s*\n)(.*\n)(\s*\}.*)\Z/s );
print $tail1;
- print "\tconst char file[] = __FILE__;\n";
+ print "\tstatic const char file[] = __FILE__;\n";
print "\tdXSUB_SYS;\n" if $] > 5.002;
print $tail2;
Property changes on: trunk/contrib/perl/minimod.pl
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/miniperlmain.c
===================================================================
--- trunk/contrib/perl/miniperlmain.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/miniperlmain.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -42,12 +42,6 @@
static void xs_init (pTHX);
static PerlInterpreter *my_perl;
-#if defined (atarist)
-/* The Atari operating system doesn't have a dynamic stack. The
- stack size is determined from this value. */
-long _stksize = 64 * 1024;
-#endif
-
#if defined(PERL_GLOBAL_STRUCT_PRIVATE)
/* The static struct perl_vars* may seem counterproductive since the
* whole idea PERL_GLOBAL_STRUCT_PRIVATE was to avoid statics, but note
@@ -78,7 +72,7 @@
PERL_UNUSED_ARG(env);
#endif
#ifndef PERL_USE_SAFE_PUTENV
- PL_use_safe_putenv = 0;
+ PL_use_safe_putenv = FALSE;
#endif /* PERL_USE_SAFE_PUTENV */
/* if user wants control of gprof profiling off by default */
@@ -120,7 +114,7 @@
#ifndef PERL_MICRO
/* Unregister our signal handler before destroying my_perl */
- for (i = 0; PL_sig_name[i]; i++) {
+ for (i = 1; PL_sig_name[i]; i++) {
if (rsignal_state(PL_sig_num[i]) == (Sighandler_t) PL_csighandlerp) {
rsignal(PL_sig_num[i], (Sighandler_t) SIG_DFL);
}
@@ -144,12 +138,12 @@
environ = env;
#endif
+ PERL_SYS_TERM();
+
#ifdef PERL_GLOBAL_STRUCT
free_global_struct(plvarsp);
#endif /* PERL_GLOBAL_STRUCT */
- PERL_SYS_TERM();
-
exit(exitstatus);
return exitstatus;
}
@@ -169,8 +163,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/miniperlmain.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/mro.c
===================================================================
--- trunk/contrib/perl/mro.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/mro.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -1,7 +1,7 @@
/* mro.c
*
* Copyright (c) 2007 Brandon L Black
- * Copyright (c) 2007, 2008 Larry Wall and others
+ * Copyright (c) 2007, 2008, 2009, 2010, 2011 Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
@@ -114,6 +114,13 @@
return INT2PTR(const struct mro_alg *, SvUVX(*data));
}
+/*
+=for apidoc mro_register
+Registers a custom mro plugin. See L<perlmroapi> for details.
+
+=cut
+*/
+
void
Perl_mro_register(pTHX_ const struct mro_alg *mro) {
SV *wrapper = newSVuv(PTR2UV(mro));
@@ -224,8 +231,9 @@
Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
if (level > 100)
- Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
- HEK_KEY(stashhek));
+ Perl_croak(aTHX_
+ "Recursive inheritance detected in package '%"HEKf"'",
+ HEKfARG(stashhek));
meta = HvMROMETA(stash);
@@ -304,8 +312,7 @@
sv_upgrade(val, SVt_PV);
SvPV_set(val, HEK_KEY(share_hek_hek(key)));
SvCUR_set(val, HEK_LEN(key));
- SvREADONLY_on(val);
- SvFAKE_on(val);
+ SvIsCOW_on(val);
SvPOK_on(val);
if (HEK_UTF8(key))
SvUTF8_on(val);
@@ -379,10 +386,9 @@
/*
=for apidoc mro_get_linear_isa
-Returns either C<mro_get_linear_isa_c3> or
-C<mro_get_linear_isa_dfs> for the given stash,
-dependant upon which MRO is in effect
-for that stash. The return value is a
+Returns the mro linearisation for the given stash. By default, this
+will be whatever C<mro_get_linear_isa_dfs> returns unless some
+other MRO is in effect for the stash. The return value is a
read-only AV*.
You are responsible for C<SvREFCNT_inc()> on the
@@ -408,6 +414,29 @@
Perl_croak(aTHX_ "panic: invalid MRO!");
isa = meta->mro_which->resolve(aTHX_ stash, 0);
+ if (meta->mro_which != &dfs_alg) { /* skip for dfs, for speed */
+ SV * const namesv =
+ (HvENAME(stash)||HvNAME(stash))
+ ? newSVhek(HvENAME_HEK(stash)
+ ? HvENAME_HEK(stash)
+ : HvNAME_HEK(stash))
+ : NULL;
+
+ if(namesv && (AvFILLp(isa) == -1 || !sv_eq(*AvARRAY(isa), namesv)))
+ {
+ AV * const old = isa;
+ SV **svp;
+ SV **ovp = AvARRAY(old);
+ SV * const * const oend = ovp + AvFILLp(old) + 1;
+ isa = (AV *)sv_2mortal((SV *)newAV());
+ av_extend(isa, AvFILLp(isa) = AvFILLp(old)+1);
+ *AvARRAY(isa) = namesv;
+ svp = AvARRAY(isa)+1;
+ while (ovp < oend) *svp++ = SvREFCNT_inc(*ovp++);
+ }
+ else SvREFCNT_dec(namesv);
+ }
+
if (!meta->isa) {
HV *const isa_hash = newHV();
/* Linearisation didn't build it for us, so do it here. */
@@ -472,6 +501,7 @@
const char * const stashname = HvENAME_get(stash);
const STRLEN stashname_len = HvENAMELEN_get(stash);
+ const bool stashname_utf8 = HvENAMEUTF8(stash) ? 1 : 0;
PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
@@ -494,7 +524,8 @@
/* Wipe the global method cache if this package
is UNIVERSAL or one of its parents */
- svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
+ svp = hv_fetch(PL_isarev, stashname,
+ stashname_utf8 ? -(I32)stashname_len : (I32)stashname_len, 0);
isarev = svp ? MUTABLE_HV(*svp) : NULL;
if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
@@ -510,6 +541,12 @@
/* wipe next::method cache too */
if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
+ /* Changes to @ISA might turn overloading on */
+ HvAMAGIC_on(stash);
+
+ /* DESTROY can be cached in SvSTASH. */
+ if (!SvOBJECT(stash)) SvSTASH(stash) = NULL;
+
/* Iterate the isarev (classes that are our children),
wiping out their linearization, method and isa caches
and upating PL_isarev. */
@@ -518,7 +555,7 @@
/* We have to iterate through isarev twice to avoid a chicken and
* egg problem: if A inherits from B and both are in isarev, A might
- * be processed before B and use B’s previous linearisation.
+ * be processed before B and use B's previous linearisation.
*/
/* First iteration: Wipe everything, but stash away the isa hashes
@@ -531,9 +568,7 @@
isa_hashes = (HV *)sv_2mortal((SV *)newHV());
}
while((iter = hv_iternext(isarev))) {
- I32 len;
- const char* const revkey = hv_iterkey(iter, &len);
- HV* revstash = gv_stashpvn(revkey, len, 0);
+ HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0);
struct mro_meta* revmeta;
if(!revstash) continue;
@@ -543,6 +578,7 @@
revmeta->cache_gen++;
if(revmeta->mro_nextmethod)
hv_clear(revmeta->mro_nextmethod);
+ if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL;
(void)
hv_store(
@@ -596,7 +632,8 @@
(void)
hv_store(
- mroisarev, HEK_KEY(namehek), HEK_LEN(namehek),
+ mroisarev, HEK_KEY(namehek),
+ HEK_UTF8(namehek) ? -HEK_LEN(namehek) : HEK_LEN(namehek),
&PL_sv_yes, 0
);
}
@@ -604,7 +641,7 @@
if((SV *)isa != &PL_sv_undef)
mro_clean_isarev(
isa, HEK_KEY(namehek), HEK_LEN(namehek),
- HvMROMETA(revstash)->isa
+ HvMROMETA(revstash)->isa, (HEK_UTF8(namehek) ? SVf_UTF8 : 0)
);
}
}
@@ -638,36 +675,40 @@
save time by not making two calls to the common HV code for the
case where it doesn't exist. */
- (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
+ (void)hv_store(mroisarev, stashname,
+ stashname_utf8 ? -(I32)stashname_len : (I32)stashname_len, &PL_sv_yes, 0);
}
- /* Delete our name from our former parents’ isarevs. */
+ /* Delete our name from our former parents' isarevs. */
if(isa && HvARRAY(isa))
- mro_clean_isarev(isa, stashname, stashname_len, meta->isa);
+ mro_clean_isarev(isa, stashname, stashname_len, meta->isa,
+ (stashname_utf8 ? SVf_UTF8 : 0) );
}
/* Deletes name from all the isarev entries listed in isa */
STATIC void
S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name,
- const STRLEN len, HV * const exceptions)
+ const STRLEN len, HV * const exceptions, U32 flags)
{
HE* iter;
PERL_ARGS_ASSERT_MRO_CLEAN_ISAREV;
- /* Delete our name from our former parents’ isarevs. */
+ /* Delete our name from our former parents' isarevs. */
if(isa && HvARRAY(isa) && hv_iterinit(isa)) {
SV **svp;
while((iter = hv_iternext(isa))) {
I32 klen;
const char * const key = hv_iterkey(iter, &klen);
- if(exceptions && hv_exists(exceptions, key, klen)) continue;
- svp = hv_fetch(PL_isarev, key, klen, 0);
+ if(exceptions && hv_exists(exceptions, key, HeKUTF8(iter) ? -klen : klen))
+ continue;
+ svp = hv_fetch(PL_isarev, key, HeKUTF8(iter) ? -klen : klen, 0);
if(svp) {
HV * const isarev = (HV *)*svp;
- (void)hv_delete(isarev, name, len, G_DISCARD);
- if(!HvARRAY(isarev) || !HvKEYS(isarev))
- (void)hv_delete(PL_isarev, key, klen, G_DISCARD);
+ (void)hv_delete(isarev, name, (flags & SVf_UTF8) ? -(I32)len : (I32)len, G_DISCARD);
+ if(!HvARRAY(isarev) || !HvUSEDKEYS(isarev))
+ (void)hv_delete(PL_isarev, key,
+ HeKUTF8(iter) ? -klen : klen, G_DISCARD);
}
}
}
@@ -677,8 +718,8 @@
=for apidoc mro_package_moved
Call this function to signal to a stash that it has been assigned to
-another spot in the stash hierarchy. C<stash> is the stash that has been
-assigned. C<oldstash> is the stash it replaces, if any. C<gv> is the glob
+another spot in the stash hierarchy. C<stash> is the stash that has been
+assigned. C<oldstash> is the stash it replaces, if any. C<gv> is the glob
that is actually being assigned to.
This can also be called with a null first argument to
@@ -692,7 +733,7 @@
appropriate.
If the C<gv> is present and is not in the symbol table, then this function
-simply returns. This checked will be skipped if C<flags & 1>.
+simply returns. This checked will be skipped if C<flags & 1>.
=cut
*/
@@ -733,7 +774,8 @@
SV **svp;
if(
!GvSTASH(gv) || !HvENAME(GvSTASH(gv)) ||
- !(svp = hv_fetch(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), 0)) ||
+ !(svp = hv_fetch(GvSTASH(gv), GvNAME(gv),
+ GvNAMEUTF8(gv) ? -GvNAMELEN(gv) : GvNAMELEN(gv), 0)) ||
*svp != (SV *)gv
) return;
}
@@ -761,9 +803,13 @@
if (GvNAMELEN(gv) == 1) sv_catpvs(namesv, ":");
else sv_catpvs(namesv, "::");
}
- if (GvNAMELEN(gv) != 1)
- sv_catpvn(namesv, GvNAME(gv), GvNAMELEN(gv) - 2);
+ if (GvNAMELEN(gv) != 1) {
+ sv_catpvn_flags(
+ namesv, GvNAME(gv), GvNAMELEN(gv) - 2,
/* skip trailing :: */
+ GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
+ );
+ }
}
else {
SV *aname;
@@ -780,9 +826,13 @@
if (GvNAMELEN(gv) == 1) sv_catpvs(aname, ":");
else sv_catpvs(aname, "::");
}
- if (GvNAMELEN(gv) != 1)
- sv_catpvn(aname, GvNAME(gv), GvNAMELEN(gv) - 2);
+ if (GvNAMELEN(gv) != 1) {
+ sv_catpvn_flags(
+ aname, GvNAME(gv), GvNAMELEN(gv) - 2,
/* skip trailing :: */
+ GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
+ );
+ }
av_push((AV *)namesv, aname);
}
}
@@ -832,12 +882,12 @@
}
}
-void
+STATIC void
S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes,
HV *stash, HV *oldstash, SV *namesv)
{
- register XPVHV* xhv;
- register HE *entry;
+ XPVHV* xhv;
+ HE *entry;
I32 riter = -1;
I32 items = 0;
const bool stash_had_name = stash && HvENAME(stash);
@@ -903,11 +953,16 @@
svp = &namesv;
}
while (items--) {
+ const U32 name_utf8 = SvUTF8(*svp);
STRLEN len;
- const char *name = SvPVx_const(*svp++, len);
- if(PL_stashcache)
- (void)hv_delete(PL_stashcache, name, len, G_DISCARD);
- hv_ename_delete(oldstash, name, len, 0);
+ const char *name = SvPVx_const(*svp, len);
+ if(PL_stashcache) {
+ DEBUG_o(Perl_deb(aTHX_ "mro_gather_and_rename clearing PL_stashcache for '%"SVf"'\n",
+ *svp));
+ (void)hv_delete(PL_stashcache, name, name_utf8 ? -(I32)len : (I32)len, G_DISCARD);
+ }
+ ++svp;
+ hv_ename_delete(oldstash, name, len, name_utf8);
if (!fetched_isarev) {
/* If the name deletion caused a name change, then we
@@ -914,14 +969,15 @@
* are not going to call mro_isa_changed_in with this
* name (and not at all if it has become anonymous) so
* we need to delete old isarev entries here, both
- * those in the superclasses and this class’s own list
+ * those in the superclasses and this class's own list
* of subclasses. We simply delete the latter from
* PL_isarev, since we still need it. hv_delete morti-
* fies it for us, so sv_2mortal is not necessary. */
if(HvENAME_HEK(oldstash) != enamehek) {
if(meta->isa && HvARRAY(meta->isa))
- mro_clean_isarev(meta->isa, name, len, NULL);
- isarev = (HV *)hv_delete(PL_isarev, name, len, 0);
+ mro_clean_isarev(meta->isa, name, len, 0, name_utf8);
+ isarev = (HV *)hv_delete(PL_isarev, name,
+ name_utf8 ? -(I32)len : (I32)len, 0);
fetched_isarev=TRUE;
}
}
@@ -939,15 +995,16 @@
svp = &namesv;
}
while (items--) {
+ const U32 name_utf8 = SvUTF8(*svp);
STRLEN len;
const char *name = SvPVx_const(*svp++, len);
- hv_ename_add(stash, name, len, 0);
+ hv_ename_add(stash, name, len, name_utf8);
}
/* Add it to the big list if it needs
* mro_isa_changed_in called on it. That happens if it was
* detached from the symbol table (so it had no HvENAME) before
- * being assigned to the spot named by the ‘name’ variable, because
+ * being assigned to the spot named by the 'name' variable, because
* its cached isa linearisation is now stale (the effective name
* having changed), and subclasses will then use that cache when
* mro_package_moved calls mro_isa_changed_in. (See
@@ -1006,7 +1063,10 @@
/* Extra variable to avoid a compiler warning */
char * const hvename = HvENAME(oldstash);
fetched_isarev = TRUE;
- svp = hv_fetch(PL_isarev, hvename, HvENAMELEN_get(oldstash), 0);
+ svp = hv_fetch(PL_isarev, hvename,
+ HvENAMEUTF8(oldstash)
+ ? -HvENAMELEN_get(oldstash)
+ : HvENAMELEN_get(oldstash), 0);
if (svp) isarev = MUTABLE_HV(*svp);
}
else if(SvTYPE(namesv) == SVt_PVAV) {
@@ -1031,9 +1091,7 @@
hv_iterinit(isarev);
while((iter = hv_iternext(isarev))) {
- I32 len;
- const char* const revkey = hv_iterkey(iter, &len);
- HV* revstash = gv_stashpvn(revkey, len, 0);
+ HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0);
struct mro_meta * meta;
if(!revstash) continue;
@@ -1082,7 +1140,7 @@
|| (len == 1 && key[0] == ':')) {
HV * const oldsubstash = GvHV(HeVAL(entry));
SV ** const stashentry
- = stash ? hv_fetch(stash, key, len, 0) : NULL;
+ = stash ? hv_fetch(stash, key, HeUTF8(entry) ? -(I32)len : (I32)len, 0) : NULL;
HV *substash = NULL;
/* Avoid main::main::main::... */
@@ -1110,7 +1168,11 @@
sv_catpvs(aname, ":");
else {
sv_catpvs(aname, "::");
- sv_catpvn(aname, key, len-2);
+ sv_catpvn_flags(
+ aname, key, len-2,
+ HeUTF8(entry)
+ ? SV_CATUTF8 : SV_CATBYTES
+ );
}
av_push((AV *)subname, aname);
}
@@ -1120,7 +1182,10 @@
if (len == 1) sv_catpvs(subname, ":");
else {
sv_catpvs(subname, "::");
- sv_catpvn(subname, key, len-2);
+ sv_catpvn_flags(
+ subname, key, len-2,
+ HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES
+ );
}
}
mro_gather_and_rename(
@@ -1129,7 +1194,7 @@
);
}
- (void)hv_store(seen, key, len, &PL_sv_yes, 0);
+ (void)hv_store(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len, &PL_sv_yes, 0);
}
}
}
@@ -1161,7 +1226,7 @@
/* If this entry was seen when we iterated through the
oldstash, skip it. */
- if(seen && hv_exists(seen, key, len)) continue;
+ if(seen && hv_exists(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len)) continue;
/* We get here only if this stash has no corresponding
entry in the stash being replaced. */
@@ -1186,7 +1251,11 @@
sv_catpvs(aname, ":");
else {
sv_catpvs(aname, "::");
- sv_catpvn(aname, key, len-2);
+ sv_catpvn_flags(
+ aname, key, len-2,
+ HeUTF8(entry)
+ ? SV_CATUTF8 : SV_CATBYTES
+ );
}
av_push((AV *)subname, aname);
}
@@ -1196,7 +1265,10 @@
if (len == 1) sv_catpvs(subname, ":");
else {
sv_catpvs(subname, "::");
- sv_catpvn(subname, key, len-2);
+ sv_catpvn_flags(
+ subname, key, len-2,
+ HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES
+ );
}
}
mro_gather_and_rename(
@@ -1218,7 +1290,7 @@
the changes in this one.
Ideally, all instances of C<PL_sub_generation++> in
-perl source outside of C<mro.c> should be
+perl source outside of F<mro.c> should be
replaced by calls to this.
Perl automatically handles most of the common
@@ -1245,8 +1317,10 @@
{
const char * const stashname = HvENAME_get(stash);
const STRLEN stashname_len = HvENAMELEN_get(stash);
+ const bool stashname_utf8 = HvENAMEUTF8(stash) ? 1 : 0;
- SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
+ SV ** const svp = hv_fetch(PL_isarev, stashname,
+ stashname_utf8 ? -(I32)stashname_len : (I32)stashname_len, 0);
HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
@@ -1257,6 +1331,9 @@
/* Inc the package generation, since a local method changed */
HvMROMETA(stash)->pkg_gen++;
+ /* DESTROY can be cached in SvSTASH. */
+ if (!SvOBJECT(stash)) SvSTASH(stash) = NULL;
+
/* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
invalidate all method caches globally */
if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
@@ -1272,9 +1349,7 @@
hv_iterinit(isarev);
while((iter = hv_iternext(isarev))) {
- I32 len;
- const char* const revkey = hv_iterkey(iter, &len);
- HV* const revstash = gv_stashpvn(revkey, len, 0);
+ HV* const revstash = gv_stashsv(hv_iterkeysv(iter), 0);
struct mro_meta* mrometa;
if(!revstash) continue;
@@ -1282,8 +1357,13 @@
mrometa->cache_gen++;
if(mrometa->mro_nextmethod)
hv_clear(mrometa->mro_nextmethod);
+ if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL;
}
}
+
+ /* The method change may be due to *{$package . "::()"} = \&nil; in
+ overload.pm. */
+ HvAMAGIC_on(stash);
}
void
@@ -1353,8 +1433,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/mro.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/myconfig.SH
===================================================================
--- trunk/contrib/perl/myconfig.SH 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/myconfig.SH 2013-12-02 21:18:17 UTC (rev 6438)
@@ -1,3 +1,5 @@
+#!/bin/sh
+
case $PERL_CONFIG_SH in
'')
if test -f config.sh; then TOP=.;
Property changes on: trunk/contrib/perl/myconfig.SH
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/mydtrace.h
===================================================================
--- trunk/contrib/perl/mydtrace.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/mydtrace.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -1,6 +1,6 @@
/* mydtrace.h
*
- * Copyright (C) 2008, by Larry Wall and others
+ * Copyright (C) 2008, 2010, 2011 by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
@@ -13,21 +13,80 @@
# include "perldtrace.h"
-# define ENTRY_PROBE(func, file, line, stash) \
+# if defined(STAP_PROBE_ADDR) && !defined(DEBUGGING)
+
+/* SystemTap 1.2 uses a construct that chokes on passing a char array
+ * as a char *, in this case hek_key in struct hek. Workaround it
+ * with a temporary.
+ */
+
+# define ENTRY_PROBE(func, file, line, stash) \
if (PERL_SUB_ENTRY_ENABLED()) { \
+ const char *tmp_func = func; \
+ PERL_SUB_ENTRY(tmp_func, file, line, stash); \
+ }
+
+# define RETURN_PROBE(func, file, line, stash) \
+ if (PERL_SUB_RETURN_ENABLED()) { \
+ const char *tmp_func = func; \
+ PERL_SUB_RETURN(tmp_func, file, line, stash); \
+ }
+
+# define LOADING_FILE_PROBE(name) \
+ if (PERL_LOADING_FILE_ENABLED()) { \
+ const char *tmp_name = name; \
+ PERL_LOADING_FILE(tmp_name); \
+ }
+
+# define LOADED_FILE_PROBE(name) \
+ if (PERL_LOADED_FILE_ENABLED()) { \
+ const char *tmp_name = name; \
+ PERL_LOADED_FILE(tmp_name); \
+ }
+
+# else
+
+# define ENTRY_PROBE(func, file, line, stash) \
+ if (PERL_SUB_ENTRY_ENABLED()) { \
PERL_SUB_ENTRY(func, file, line, stash); \
}
-# define RETURN_PROBE(func, file, line, stash) \
+# define RETURN_PROBE(func, file, line, stash) \
if (PERL_SUB_RETURN_ENABLED()) { \
PERL_SUB_RETURN(func, file, line, stash); \
}
+# define LOADING_FILE_PROBE(name) \
+ if (PERL_LOADING_FILE_ENABLED()) { \
+ PERL_LOADING_FILE(name); \
+ }
+
+# define LOADED_FILE_PROBE(name) \
+ if (PERL_LOADED_FILE_ENABLED()) { \
+ PERL_LOADED_FILE(name); \
+ }
+
+# endif
+
+# define OP_ENTRY_PROBE(name) \
+ if (PERL_OP_ENTRY_ENABLED()) { \
+ PERL_OP_ENTRY(name); \
+ }
+
+# define PHASE_CHANGE_PROBE(new_phase, old_phase) \
+ if (PERL_PHASE_CHANGE_ENABLED()) { \
+ PERL_PHASE_CHANGE(new_phase, old_phase); \
+ }
+
#else
/* NOPs */
# define ENTRY_PROBE(func, file, line, stash)
# define RETURN_PROBE(func, file, line, stash)
+# define PHASE_CHANGE_PROBE(new_phase, old_phase)
+# define OP_ENTRY_PROBE(name)
+# define LOADING_FILE_PROBE(name)
+# define LOADED_FILE_PROBE(name)
#endif
@@ -35,8 +94,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/mydtrace.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/nostdio.h
===================================================================
--- trunk/contrib/perl/nostdio.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/nostdio.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -129,8 +129,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/nostdio.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/numeric.c
===================================================================
--- trunk/contrib/perl/numeric.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/numeric.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -131,6 +131,10 @@
number may use '_' characters to separate digits.
=cut
+
+Not documented yet because experimental is C<PERL_SCAN_SILENT_NON_PORTABLE
+which suppresses any message for non-portable numbers that are still valid
+on this platform.
*/
UV
@@ -176,6 +180,7 @@
continue;
}
/* Bah. We're just overflowed. */
+ /* diag_listed_as: Integer overflow in %s number */
Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
"Integer overflow in binary number");
overflowed = TRUE;
@@ -206,7 +211,8 @@
if ( ( overflowed && value_nv > 4294967295.0)
#if UVSIZE > 4
- || (!overflowed && value > 0xffffffff )
+ || (!overflowed && value > 0xffffffff
+ && ! (*flags & PERL_SCAN_SILENT_NON_PORTABLE))
#endif
) {
Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
@@ -248,6 +254,10 @@
number may use '_' characters to separate digits.
=cut
+
+Not documented yet because experimental is C<PERL_SCAN_SILENT_NON_PORTABLE
+which suppresses any message for non-portable numbers that are still valid
+on this platform.
*/
UV
@@ -293,6 +303,7 @@
continue;
}
/* Bah. We're just overflowed. */
+ /* diag_listed_as: Integer overflow in %s number */
Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
"Integer overflow in hexadecimal number");
overflowed = TRUE;
@@ -323,7 +334,8 @@
if ( ( overflowed && value_nv > 4294967295.0)
#if UVSIZE > 4
- || (!overflowed && value > 0xffffffff )
+ || (!overflowed && value > 0xffffffff
+ && ! (*flags & PERL_SCAN_SILENT_NON_PORTABLE))
#endif
) {
Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
@@ -363,6 +375,10 @@
number may use '_' characters to separate digits.
=cut
+
+Not documented yet because experimental is C<PERL_SCAN_SILENT_NON_PORTABLE>
+which suppresses any message for non-portable numbers, but which are valid
+on this platform.
*/
UV
@@ -393,6 +409,7 @@
continue;
}
/* Bah. We're just overflowed. */
+ /* diag_listed_as: Integer overflow in %s number */
Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
"Integer overflow in octal number");
overflowed = TRUE;
@@ -428,7 +445,8 @@
if ( ( overflowed && value_nv > 4294967295.0)
#if UVSIZE > 4
- || (!overflowed && value > 0xffffffff )
+ || (!overflowed && value > 0xffffffff
+ && ! (*flags & PERL_SCAN_SILENT_NON_PORTABLE))
#endif
) {
Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
@@ -515,7 +533,7 @@
PERL_ARGS_ASSERT_GROK_NUMERIC_RADIX;
- if (PL_numeric_radix_sv && IN_LOCALE) {
+ if (PL_numeric_radix_sv && IN_SOME_LOCALE_FORM) {
STRLEN len;
const char * const radix = SvPV(PL_numeric_radix_sv, len);
if (*sp + len <= send && memEQ(*sp, radix, len)) {
@@ -785,7 +803,7 @@
* a hammer. Therefore we need to catch potential overflows before
* it's too late. */
-#if ((defined(VMS) && !defined(__IEEE_FP)) || defined(_UNICOS)) && defined(NV_MAX_10_EXP)
+#if ((defined(VMS) && !defined(_IEEE_FP)) || defined(_UNICOS)) && defined(NV_MAX_10_EXP)
STMT_START {
const NV exp_v = log10(value);
if (exponent >= NV_MAX_10_EXP || exponent + exp_v >= NV_MAX_10_EXP)
@@ -829,17 +847,28 @@
PERL_ARGS_ASSERT_MY_ATOF;
- if (PL_numeric_local && IN_LOCALE) {
- NV y;
+ if (PL_numeric_local && PL_numeric_radix_sv && IN_SOME_LOCALE_FORM) {
+ const char *standard = NULL, *local = NULL;
+ bool use_standard_radix;
- /* Scan the number twice; once using locale and once without;
- * choose the larger result (in absolute value). */
- Perl_atof2(s, x);
- SET_NUMERIC_STANDARD();
- Perl_atof2(s, y);
- SET_NUMERIC_LOCAL();
- if ((y < 0.0 && y < x) || (y > 0.0 && y > x))
- return y;
+ /* Look through the string for the first thing that looks like a
+ * decimal point: either the value in the current locale or the
+ * standard fallback of '.'. The one which appears earliest in the
+ * input string is the one that we should have atof look for. Note that
+ * we have to determine this beforehand because on some systems,
+ * Perl_atof2 is just a wrapper around the system's atof. */
+ standard = strchr(s, '.');
+ local = strstr(s, SvPV_nolen(PL_numeric_radix_sv));
+
+ use_standard_radix = standard && (!local || standard < local);
+
+ if (use_standard_radix)
+ SET_NUMERIC_STANDARD();
+
+ Perl_atof2(s, x);
+
+ if (use_standard_radix)
+ SET_NUMERIC_LOCAL();
}
else
Perl_atof2(s, x);
@@ -1087,8 +1116,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/numeric.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/op.c
===================================================================
--- trunk/contrib/perl/op.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/op.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -102,137 +102,328 @@
#define PERL_IN_OP_C
#include "perl.h"
#include "keywords.h"
+#include "feature.h"
+#include "regcomp.h"
#define CALL_PEEP(o) PL_peepp(aTHX_ o)
#define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
#define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
-#if defined(PL_OP_SLAB_ALLOC)
+/* See the explanatory comments above struct opslab in op.h. */
#ifdef PERL_DEBUG_READONLY_OPS
-# define PERL_SLAB_SIZE 4096
+# define PERL_SLAB_SIZE 128
+# define PERL_MAX_SLAB_SIZE 4096
# include <sys/mman.h>
#endif
#ifndef PERL_SLAB_SIZE
-#define PERL_SLAB_SIZE 2048
+# define PERL_SLAB_SIZE 64
#endif
+#ifndef PERL_MAX_SLAB_SIZE
+# define PERL_MAX_SLAB_SIZE 2048
+#endif
+/* rounds up to nearest pointer */
+#define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
+#define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
+
+static OPSLAB *
+S_new_slab(pTHX_ size_t sz)
+{
+#ifdef PERL_DEBUG_READONLY_OPS
+ OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
+ PROT_READ|PROT_WRITE,
+ MAP_ANON|MAP_PRIVATE, -1, 0);
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
+ (unsigned long) sz, slab));
+ if (slab == MAP_FAILED) {
+ perror("mmap failed");
+ abort();
+ }
+ slab->opslab_size = (U16)sz;
+#else
+ OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
+#endif
+ slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
+ return slab;
+}
+
+/* requires double parens and aTHX_ */
+#define DEBUG_S_warn(args) \
+ DEBUG_S( \
+ PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
+ )
+
void *
Perl_Slab_Alloc(pTHX_ size_t sz)
{
dVAR;
- /*
- * To make incrementing use count easy PL_OpSlab is an I32 *
- * To make inserting the link to slab PL_OpPtr is I32 **
- * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
- * Add an overhead for pointer to slab and round up as a number of pointers
- */
- sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
- if ((PL_OpSpace -= sz) < 0) {
-#ifdef PERL_DEBUG_READONLY_OPS
- /* We need to allocate chunk by chunk so that we can control the VM
- mapping */
- PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
- MAP_ANON|MAP_PRIVATE, -1, 0);
+ OPSLAB *slab;
+ OPSLAB *slab2;
+ OPSLOT *slot;
+ OP *o;
+ size_t opsz, space;
- DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
- (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
- PL_OpPtr));
- if(PL_OpPtr == MAP_FAILED) {
- perror("mmap failed");
- abort();
- }
-#else
+ if (!PL_compcv || CvROOT(PL_compcv)
+ || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
+ return PerlMemShared_calloc(1, sz);
- PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
+#if defined(USE_ITHREADS) && IVSIZE > U32SIZE && IVSIZE > PTRSIZE
+ /* Work around a goof with alignment on our part. For sparc32 (and
+ possibly other architectures), if built with -Duse64bitint, the IV
+ op_pmoffset in struct pmop should be 8 byte aligned, but the slab
+ allocator is only providing 4 byte alignment. The real fix is to change
+ the IV to a type the same size as a pointer, such as size_t, but we
+ can't do that without breaking the ABI, which is a no-no in a maint
+ release. So instead, simply allocate struct pmop directly, which will be
+ suitably aligned: */
+ if (sz == sizeof(struct pmop))
+ return PerlMemShared_calloc(1, sz);
#endif
- if (!PL_OpPtr) {
- return NULL;
+
+ if (!CvSTART(PL_compcv)) { /* sneak it in here */
+ CvSTART(PL_compcv) =
+ (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
+ CvSLABBED_on(PL_compcv);
+ slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
+ }
+ else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
+
+ opsz = SIZE_TO_PSIZE(sz);
+ sz = opsz + OPSLOT_HEADER_P;
+
+ if (slab->opslab_freed) {
+ OP **too = &slab->opslab_freed;
+ o = *too;
+ DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", o, slab));
+ while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
+ DEBUG_S_warn((aTHX_ "Alas! too small"));
+ o = *(too = &o->op_next);
+ if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", o)); }
}
- /* We reserve the 0'th I32 sized chunk as a use count */
- PL_OpSlab = (I32 *) PL_OpPtr;
- /* Reduce size by the use count word, and by the size we need.
- * Latter is to mimic the '-=' in the if() above
- */
- PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
- /* Allocation pointer starts at the top.
- Theory: because we build leaves before trunk allocating at end
- means that at run time access is cache friendly upward
- */
- PL_OpPtr += PERL_SLAB_SIZE;
+ if (o) {
+ *too = o->op_next;
+ Zero(o, opsz, I32 *);
+ o->op_slabbed = 1;
+ return (void *)o;
+ }
+ }
-#ifdef PERL_DEBUG_READONLY_OPS
- /* We remember this slab. */
- /* This implementation isn't efficient, but it is simple. */
- PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
- PL_slabs[PL_slab_count++] = PL_OpSlab;
- DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
-#endif
+#define INIT_OPSLOT \
+ slot->opslot_slab = slab; \
+ slot->opslot_next = slab2->opslab_first; \
+ slab2->opslab_first = slot; \
+ o = &slot->opslot_op; \
+ o->op_slabbed = 1
+
+ /* The partially-filled slab is next in the chain. */
+ slab2 = slab->opslab_next ? slab->opslab_next : slab;
+ if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
+ /* Remaining space is too small. */
+
+ /* If we can fit a BASEOP, add it to the free chain, so as not
+ to waste it. */
+ if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
+ slot = &slab2->opslab_slots;
+ INIT_OPSLOT;
+ o->op_type = OP_FREED;
+ o->op_next = slab->opslab_freed;
+ slab->opslab_freed = o;
+ }
+
+ /* Create a new slab. Make this one twice as big. */
+ slot = slab2->opslab_first;
+ while (slot->opslot_next) slot = slot->opslot_next;
+ slab2 = S_new_slab(aTHX_
+ (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
+ ? PERL_MAX_SLAB_SIZE
+ : (DIFF(slab2, slot)+1)*2);
+ slab2->opslab_next = slab->opslab_next;
+ slab->opslab_next = slab2;
}
- assert( PL_OpSpace >= 0 );
- /* Move the allocation pointer down */
- PL_OpPtr -= sz;
- assert( PL_OpPtr > (I32 **) PL_OpSlab );
- *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
- (*PL_OpSlab)++; /* Increment use count of slab */
- assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
- assert( *PL_OpSlab > 0 );
- return (void *)(PL_OpPtr + 1);
+ assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
+
+ /* Create a new op slot */
+ slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
+ assert(slot >= &slab2->opslab_slots);
+ if (DIFF(&slab2->opslab_slots, slot)
+ < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
+ slot = &slab2->opslab_slots;
+ INIT_OPSLOT;
+ DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", o, slab));
+ return (void *)o;
}
+#undef INIT_OPSLOT
+
#ifdef PERL_DEBUG_READONLY_OPS
void
-Perl_pending_Slabs_to_ro(pTHX) {
- /* Turn all the allocated op slabs read only. */
- U32 count = PL_slab_count;
- I32 **const slabs = PL_slabs;
+Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
+{
+ PERL_ARGS_ASSERT_SLAB_TO_RO;
- /* Reset the array of pending OP slabs, as we're about to turn this lot
- read only. Also, do it ahead of the loop in case the warn triggers,
- and a warn handler has an eval */
+ if (slab->opslab_readonly) return;
+ slab->opslab_readonly = 1;
+ for (; slab; slab = slab->opslab_next) {
+ /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
+ (unsigned long) slab->opslab_size, slab));*/
+ if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
+ Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
+ (unsigned long)slab->opslab_size, errno);
+ }
+}
- PL_slabs = NULL;
- PL_slab_count = 0;
+void
+Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
+{
+ OPSLAB *slab2;
- /* Force a new slab for any further allocation. */
- PL_OpSpace = 0;
+ PERL_ARGS_ASSERT_SLAB_TO_RW;
- while (count--) {
- void *const start = slabs[count];
- const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
- if(mprotect(start, size, PROT_READ)) {
- Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
- start, (unsigned long) size, errno);
+ if (!slab->opslab_readonly) return;
+ slab2 = slab;
+ for (; slab2; slab2 = slab2->opslab_next) {
+ /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
+ (unsigned long) size, slab2));*/
+ if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
+ PROT_READ|PROT_WRITE)) {
+ Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
+ (unsigned long)slab2->opslab_size, errno);
}
}
+ slab->opslab_readonly = 0;
+}
- free(slabs);
+#else
+# define Slab_to_rw(op)
+#endif
+
+/* This cannot possibly be right, but it was copied from the old slab
+ allocator, to which it was originally added, without explanation, in
+ commit 083fcd5. */
+#ifdef NETWARE
+# define PerlMemShared PerlMem
+#endif
+
+void
+Perl_Slab_Free(pTHX_ void *op)
+{
+ dVAR;
+ OP * const o = (OP *)op;
+ OPSLAB *slab;
+
+ PERL_ARGS_ASSERT_SLAB_FREE;
+
+ if (!o->op_slabbed) {
+ if (!o->op_static)
+ PerlMemShared_free(op);
+ return;
+ }
+
+ slab = OpSLAB(o);
+ /* If this op is already freed, our refcount will get screwy. */
+ assert(o->op_type != OP_FREED);
+ o->op_type = OP_FREED;
+ o->op_next = slab->opslab_freed;
+ slab->opslab_freed = o;
+ DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", o, slab));
+ OpslabREFCNT_dec_padok(slab);
}
-STATIC void
-S_Slab_to_rw(pTHX_ void *op)
+void
+Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
{
- I32 * const * const ptr = (I32 **) op;
- I32 * const slab = ptr[-1];
+ dVAR;
+ const bool havepad = !!PL_comppad;
+ PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
+ if (havepad) {
+ ENTER;
+ PAD_SAVE_SETNULLPAD();
+ }
+ opslab_free(slab);
+ if (havepad) LEAVE;
+}
- PERL_ARGS_ASSERT_SLAB_TO_RW;
+void
+Perl_opslab_free(pTHX_ OPSLAB *slab)
+{
+ dVAR;
+ OPSLAB *slab2;
+ PERL_ARGS_ASSERT_OPSLAB_FREE;
+ DEBUG_S_warn((aTHX_ "freeing slab %p", slab));
+ assert(slab->opslab_refcnt == 1);
+ for (; slab; slab = slab2) {
+ slab2 = slab->opslab_next;
+#ifdef DEBUGGING
+ slab->opslab_refcnt = ~(size_t)0;
+#endif
+#ifdef PERL_DEBUG_READONLY_OPS
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
+ slab));
+ if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
+ perror("munmap failed");
+ abort();
+ }
+#else
+ PerlMemShared_free(slab);
+#endif
+ }
+}
- assert( ptr-1 > (I32 **) slab );
- assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
- assert( *slab > 0 );
- if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
- Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
- slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
+void
+Perl_opslab_force_free(pTHX_ OPSLAB *slab)
+{
+ OPSLAB *slab2;
+ OPSLOT *slot;
+#ifdef DEBUGGING
+ size_t savestack_count = 0;
+#endif
+ PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
+ slab2 = slab;
+ do {
+ for (slot = slab2->opslab_first;
+ slot->opslot_next;
+ slot = slot->opslot_next) {
+ if (slot->opslot_op.op_type != OP_FREED
+ && !(slot->opslot_op.op_savefree
+#ifdef DEBUGGING
+ && ++savestack_count
+#endif
+ )
+ ) {
+ assert(slot->opslot_op.op_slabbed);
+ op_free(&slot->opslot_op);
+ if (slab->opslab_refcnt == 1) goto free;
+ }
+ }
+ } while ((slab2 = slab2->opslab_next));
+ /* > 1 because the CV still holds a reference count. */
+ if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
+#ifdef DEBUGGING
+ assert(savestack_count == slab->opslab_refcnt-1);
+#endif
+ /* Remove the CV’s reference count. */
+ slab->opslab_refcnt--;
+ return;
}
+ free:
+ opslab_free(slab);
}
+#ifdef PERL_DEBUG_READONLY_OPS
OP *
Perl_op_refcnt_inc(pTHX_ OP *o)
{
if(o) {
- Slab_to_rw(o);
- ++o->op_targ;
+ OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
+ if (slab && slab->opslab_readonly) {
+ Slab_to_rw(slab);
+ ++o->op_targ;
+ Slab_to_ro(slab);
+ } else {
+ ++o->op_targ;
+ }
}
return o;
@@ -241,60 +432,19 @@
PADOFFSET
Perl_op_refcnt_dec(pTHX_ OP *o)
{
+ PADOFFSET result;
+ OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
+
PERL_ARGS_ASSERT_OP_REFCNT_DEC;
- Slab_to_rw(o);
- return --o->op_targ;
-}
-#else
-# define Slab_to_rw(op)
-#endif
-void
-Perl_Slab_Free(pTHX_ void *op)
-{
- I32 * const * const ptr = (I32 **) op;
- I32 * const slab = ptr[-1];
- PERL_ARGS_ASSERT_SLAB_FREE;
- assert( ptr-1 > (I32 **) slab );
- assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
- assert( *slab > 0 );
- Slab_to_rw(op);
- if (--(*slab) == 0) {
-# ifdef NETWARE
-# define PerlMemShared PerlMem
-# endif
-
-#ifdef PERL_DEBUG_READONLY_OPS
- U32 count = PL_slab_count;
- /* Need to remove this slab from our list of slabs */
- if (count) {
- while (count--) {
- if (PL_slabs[count] == slab) {
- dVAR;
- /* Found it. Move the entry at the end to overwrite it. */
- DEBUG_m(PerlIO_printf(Perl_debug_log,
- "Deallocate %p by moving %p from %lu to %lu\n",
- PL_OpSlab,
- PL_slabs[PL_slab_count - 1],
- PL_slab_count, count));
- PL_slabs[count] = PL_slabs[--PL_slab_count];
- /* Could realloc smaller at this point, but probably not
- worth it. */
- if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
- perror("munmap failed");
- abort();
- }
- break;
- }
- }
- }
-#else
- PerlMemShared_free(slab);
-#endif
- if (slab == PL_OpSlab) {
- PL_OpSpace = 0;
- }
+ if (slab && slab->opslab_readonly) {
+ Slab_to_rw(slab);
+ result = --o->op_targ;
+ Slab_to_ro(slab);
+ } else {
+ result = --o->op_targ;
}
+ return result;
}
#endif
/*
@@ -316,7 +466,7 @@
o->op_ppaddr = PL_ppaddr[type]; \
} STMT_END
-STATIC const char*
+STATIC SV*
S_gv_ename(pTHX_ GV *gv)
{
SV* const tmpsv = sv_newmortal();
@@ -324,7 +474,7 @@
PERL_ARGS_ASSERT_GV_ENAME;
gv_efullname3(tmpsv, gv, NULL);
- return SvPV_nolen_const(tmpsv);
+ return tmpsv;
}
STATIC OP *
@@ -338,35 +488,62 @@
}
STATIC OP *
-S_too_few_arguments(pTHX_ OP *o, const char *name)
+S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
{
- PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
+ PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV;
+ yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, namesv),
+ SvUTF8(namesv) | flags);
+ return o;
+}
- yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
+STATIC OP *
+S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
+{
+ PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
+ yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
return o;
}
+
+STATIC OP *
+S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
+{
+ PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
+ yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
+ return o;
+}
+
STATIC OP *
-S_too_many_arguments(pTHX_ OP *o, const char *name)
+S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
{
- PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
+ PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV;
- yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
+ yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)),
+ SvUTF8(namesv) | flags);
return o;
}
STATIC void
-S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
+S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
{
- PERL_ARGS_ASSERT_BAD_TYPE;
+ PERL_ARGS_ASSERT_BAD_TYPE_PV;
- yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
- (int)n, name, t, OP_DESC(kid)));
+ yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
+ (int)n, name, t, OP_DESC(kid)), flags);
}
STATIC void
-S_no_bareword_allowed(pTHX_ const OP *o)
+S_bad_type_sv(pTHX_ I32 n, const char *t, SV *namesv, U32 flags, const OP *kid)
{
+ PERL_ARGS_ASSERT_BAD_TYPE_SV;
+
+ yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
+ (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
+}
+
+STATIC void
+S_no_bareword_allowed(pTHX_ OP *o)
+{
PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
if (PL_madskills)
@@ -374,6 +551,7 @@
qerror(Perl_mess(aTHX_
"Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
SVfARG(cSVOPo_sv)));
+ o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
}
/* "register" allocation */
@@ -387,7 +565,7 @@
PERL_ARGS_ASSERT_ALLOCMY;
- if (flags)
+ if (flags & ~SVf_UTF8)
Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
(UV)flags);
@@ -399,25 +577,34 @@
if (len &&
!(is_our ||
isALPHA(name[1]) ||
- (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
+ ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
(name[1] == '_' && (*name == '$' || len > 2))))
{
/* name[2] is true if strlen(name) > 2 */
- if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
+ if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
+ && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
PL_parser->in_my == KEY_state ? "state" : "my"));
} else {
- yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
- PL_parser->in_my == KEY_state ? "state" : "my"));
+ yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
+ PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
}
}
+ else if (len == 2 && name[1] == '_' && !is_our)
+ /* diag_listed_as: Use of my $_ is experimental */
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
+ "Use of %s $_ is experimental",
+ PL_parser->in_my == KEY_state
+ ? "state"
+ : "my");
/* allocate a spare slot and store the name in that slot */
- off = pad_add_name(name, len,
- is_our ? padadd_OUR :
- PL_parser->in_my == KEY_state ? padadd_STATE : 0,
+ off = pad_add_name_pvn(name, len,
+ (is_our ? padadd_OUR :
+ PL_parser->in_my == KEY_state ? padadd_STATE : 0)
+ | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
PL_parser->in_my_stash,
(is_our
/* $_ is always in main::, even with our */
@@ -434,6 +621,43 @@
return off;
}
+/*
+=for apidoc alloccopstash
+
+Available only under threaded builds, this function allocates an entry in
+C<PL_stashpad> for the stash passed to it.
+
+=cut
+*/
+
+#ifdef USE_ITHREADS
+PADOFFSET
+Perl_alloccopstash(pTHX_ HV *hv)
+{
+ PADOFFSET off = 0, o = 1;
+ bool found_slot = FALSE;
+
+ PERL_ARGS_ASSERT_ALLOCCOPSTASH;
+
+ if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
+
+ for (; o < PL_stashpadmax; ++o) {
+ if (PL_stashpad[o] == hv) return PL_stashpadix = o;
+ if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
+ found_slot = TRUE, off = o;
+ }
+ if (!found_slot) {
+ Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
+ Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
+ off = PL_stashpadmax;
+ PL_stashpadmax += 10;
+ }
+
+ PL_stashpad[PL_stashpadix = off] = hv;
+ return off;
+}
+#endif
+
/* free the body of an op without examining its contents.
* Always use this rather than FreeOp directly */
@@ -440,19 +664,9 @@
static void
S_op_destroy(pTHX_ OP *o)
{
- if (o->op_latefree) {
- o->op_latefreed = 1;
- return;
- }
FreeOp(o);
}
-#ifdef USE_ITHREADS
-# define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
-#else
-# define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
-#endif
-
/* Destructor */
void
@@ -461,13 +675,13 @@
dVAR;
OPCODE type;
- if (!o)
+ /* 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;
- if (o->op_latefreed) {
- if (o->op_latefree)
- return;
- goto do_free;
- }
type = o->op_type;
if (o->op_private & OPpREFCOUNTED) {
@@ -502,35 +716,26 @@
CALL_OPFREEHOOK(o);
if (o->op_flags & OPf_KIDS) {
- register OP *kid, *nextkid;
+ OP *kid, *nextkid;
for (kid = cUNOPo->op_first; kid; kid = nextkid) {
nextkid = kid->op_sibling; /* Get before next freeing kid */
op_free(kid);
}
}
+ if (type == OP_NULL)
+ type = (OPCODE)o->op_targ;
-#ifdef PERL_DEBUG_READONLY_OPS
- Slab_to_rw(o);
-#endif
+ 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
- || (type == OP_NULL /* the COP might have been null'ed */
- && ((OPCODE)o->op_targ == OP_NEXTSTATE
- || (OPCODE)o->op_targ == OP_DBSTATE))) {
+ if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
cop_free((COP*)o);
}
- if (type == OP_NULL)
- type = (OPCODE)o->op_targ;
-
op_clear(o);
- if (o->op_latefree) {
- o->op_latefreed = 1;
- return;
- }
- do_free:
FreeOp(o);
#ifdef DEBUG_LEAKING_SCALARS
if (PL_op == o)
@@ -547,18 +752,8 @@
PERL_ARGS_ASSERT_OP_CLEAR;
#ifdef PERL_MAD
- /* if (o->op_madprop && o->op_madprop->mad_next)
- abort(); */
- /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
- "modification of a read only value" for a reason I can't fathom why.
- It's the "" stringification of $_, where $_ was set to '' in a foreach
- loop, but it defies simplification into a small test case.
- However, commenting them out has caused ext/List/Util/t/weak.t to fail
- the last test. */
- /*
- mad_free(o->op_madprop);
- o->op_madprop = 0;
- */
+ mad_free(o->op_madprop);
+ o->op_madprop = 0;
#endif
retry:
@@ -581,8 +776,7 @@
case OP_GVSV:
case OP_GV:
case OP_AELEMFAST:
- if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
- /* not an OP_PADAV replacement */
+ {
GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
#ifdef USE_ITHREADS
&& PL_curpad
@@ -619,7 +813,7 @@
#endif
if (still_valid) {
int try_downgrade = SvREFCNT(gv) == 2;
- SvREFCNT_dec(gv);
+ SvREFCNT_dec_NN(gv);
if (try_downgrade)
gv_try_downgrade(gv);
}
@@ -643,6 +837,7 @@
}
#endif
break;
+ case OP_DUMP:
case OP_GOTO:
case OP_NEXT:
case OP_LAST:
@@ -653,6 +848,7 @@
case OP_TRANS:
case OP_TRANSR:
if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
+ assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
#ifdef USE_ITHREADS
if (cPADOPo->op_padix > 0) {
pad_swipe(cPADOPo->op_padix, TRUE);
@@ -685,7 +881,10 @@
case OP_MATCH:
case OP_QR:
clear_pmop:
- forget_pmop(cPMOPo, 1);
+ if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
+ op_free(cPMOPo->op_code_list);
+ cPMOPo->op_code_list = NULL;
+ forget_pmop(cPMOPo);
cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
/* we use the same protection as the "SAFE" version of the PM_ macros
* here since sv_clean_all might release some PMOPs
@@ -721,7 +920,6 @@
PERL_ARGS_ASSERT_COP_FREE;
CopFILE_free(cop);
- CopSTASH_free(cop);
if (! specialWARN(cop->cop_warnings))
PerlMemShared_free(cop->cop_warnings);
cophh_free(CopHINTHASH_get(cop));
@@ -729,9 +927,6 @@
STATIC void
S_forget_pmop(pTHX_ PMOP *const o
-#ifdef USE_ITHREADS
- , U32 flags
-#endif
)
{
HV * const pmstash = PmopSTASH(o);
@@ -738,7 +933,7 @@
PERL_ARGS_ASSERT_FORGET_PMOP;
- if (pmstash && !SvIS_FREED(pmstash)) {
+ if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
if (mg) {
PMOP **const array = (PMOP**) mg->mg_ptr;
@@ -764,10 +959,6 @@
}
if (PL_curpm == o)
PL_curpm = NULL;
-#ifdef USE_ITHREADS
- if (flags)
- PmopSTASH_free(o);
-#endif
}
STATIC void
@@ -783,7 +974,7 @@
case OP_PUSHRE:
case OP_MATCH:
case OP_QR:
- forget_pmop((PMOP*)kid, 0);
+ forget_pmop((PMOP*)kid);
}
find_and_forget_pmops(kid);
kid = kid->op_sibling;
@@ -845,7 +1036,8 @@
case G_ARRAY: return list(o);
case G_VOID: return scalarvoid(o);
default:
- Perl_croak(aTHX_ "panic: op_contextualize bad context");
+ Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
+ (long) context);
return o;
}
}
@@ -873,7 +1065,7 @@
/* establish postfix order */
first = cUNOPo->op_first;
if (first) {
- register OP *kid;
+ OP *kid;
o->op_next = LINKLIST(first);
kid = first;
for (;;) {
@@ -915,8 +1107,11 @@
if (ckWARN(WARN_SYNTAX)) {
const line_t oldline = CopLINE(PL_curcop);
- if (PL_parser && PL_parser->copline != NOLINE)
+ if (PL_parser && PL_parser->copline != NOLINE) {
+ /* This ensures that warnings are reported at the first line
+ of the conditional, not the last. */
CopLINE_set(PL_curcop, PL_parser->copline);
+ }
Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
CopLINE_set(PL_curcop, oldline);
}
@@ -970,14 +1165,9 @@
do_kids:
while (kid) {
OP *sib = kid->op_sibling;
- if (sib && kid->op_type != OP_LEAVEWHEN) {
- if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
- scalar(kid);
- scalarvoid(sib);
- break;
- } else
- scalarvoid(kid);
- } else
+ if (sib && kid->op_type != OP_LEAVEWHEN)
+ scalarvoid(kid);
+ else
scalar(kid);
kid = sib;
}
@@ -1000,6 +1190,7 @@
{
dVAR;
OP *kid;
+ SV *useless_sv = NULL;
const char* useless = NULL;
SV* sv;
U8 want;
@@ -1079,6 +1270,7 @@
case OP_SPRINTF:
case OP_AELEM:
case OP_AELEMFAST:
+ case OP_AELEMFAST_LEX:
case OP_ASLICE:
case OP_HELEM:
case OP_HSLICE:
@@ -1126,6 +1318,7 @@
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" */
@@ -1176,15 +1369,6 @@
no_bareword_allowed(o);
else {
if (ckWARN(WARN_VOID)) {
- if (SvOK(sv)) {
- SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
- "a constant (%"SVf")", sv));
- useless = SvPV_nolen(msv);
- }
- else
- useless = "a constant (undef)";
- if (o->op_private & OPpCONST_ARYBASE)
- useless = NULL;
/* don't warn on optimised away booleans, eg
* use constant Foo, 5; Foo || print; */
if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
@@ -1206,7 +1390,24 @@
strnEQ(maybe_macro, "ds", 2) ||
strnEQ(maybe_macro, "ig", 2))
useless = NULL;
+ else {
+ SV * const dsv = newSVpvs("");
+ useless_sv
+ = Perl_newSVpvf(aTHX_
+ "a constant (%s)",
+ pv_pretty(dsv, maybe_macro,
+ 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")", sv);
+ }
+ else
+ useless = "a constant (undef)";
}
}
op_null(o); /* don't execute or even remember it */
@@ -1232,6 +1433,52 @@
o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
break;
+ case OP_SASSIGN: {
+ OP *rv2gv;
+ UNOP *refgen, *rv2cv;
+ LISTOP *exlist;
+
+ if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
+ break;
+
+ rv2gv = ((BINOP *)o)->op_last;
+ if (!rv2gv || rv2gv->op_type != OP_RV2GV)
+ break;
+
+ refgen = (UNOP *)((BINOP *)o)->op_first;
+
+ if (!refgen || refgen->op_type != OP_REFGEN)
+ 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)
+ break;
+
+ rv2cv = (UNOP*)exlist->op_last;
+
+ 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);
+
+ o->op_private |= OPpASSIGN_CV_TO_GV;
+ rv2gv->op_private |= OPpDONT_INIT_GV;
+ rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
+
+ break;
+ }
+
+ case OP_AASSIGN: {
+ inplace_aassign(o);
+ break;
+ }
+
case OP_OR:
case OP_AND:
kid = cLOGOPo->op_first;
@@ -1284,8 +1531,18 @@
case OP_SCALAR:
return scalar(o);
}
- if (useless)
- Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
+
+ if (useless_sv) {
+ /* mortalise it, in case warnings are fatal. */
+ Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
+ "Useless use of %"SVf" in void context",
+ sv_2mortal(useless_sv));
+ }
+ else if (useless) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
+ "Useless use of %s in void context",
+ useless);
+ }
return o;
}
@@ -1355,14 +1612,9 @@
do_kids:
while (kid) {
OP *sib = kid->op_sibling;
- if (sib && kid->op_type != OP_LEAVEWHEN) {
- if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
- list(kid);
- scalarvoid(sib);
- break;
- } else
- scalarvoid(kid);
- } else
+ if (sib && kid->op_type != OP_LEAVEWHEN)
+ scalarvoid(kid);
+ else
list(kid);
kid = sib;
}
@@ -1415,6 +1667,256 @@
}
/*
+=for apidoc finalize_optree
+
+This function finalizes the optree. Should be called directly after
+the complete optree is built. It does some additional
+checking which can't be done in the normal ck_xxx functions and makes
+the tree thread-safe.
+
+=cut
+*/
+void
+Perl_finalize_optree(pTHX_ OP* o)
+{
+ PERL_ARGS_ASSERT_FINALIZE_OPTREE;
+
+ ENTER;
+ SAVEVPTR(PL_curcop);
+
+ finalize_op(o);
+
+ LEAVE;
+}
+
+STATIC void
+S_finalize_op(pTHX_ OP* o)
+{
+ PERL_ARGS_ASSERT_FINALIZE_OP;
+
+#if defined(PERL_MAD) && defined(USE_ITHREADS)
+ {
+ /* Make sure mad ops are also thread-safe */
+ MADPROP *mp = o->op_madprop;
+ while (mp) {
+ if (mp->mad_type == MAD_OP && mp->mad_vlen) {
+ OP *prop_op = (OP *) mp->mad_val;
+ /* We only need "Relocate sv to the pad for thread safety.", but this
+ easiest way to make sure it traverses everything */
+ if (prop_op->op_type == OP_CONST)
+ cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
+ finalize_op(prop_op);
+ }
+ mp = mp->mad_next;
+ }
+ }
+#endif
+
+ switch (o->op_type) {
+ case OP_NEXTSTATE:
+ case OP_DBSTATE:
+ PL_curcop = ((COP*)o); /* for warnings */
+ break;
+ case OP_EXEC:
+ if ( o->op_sibling
+ && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
+ && ckWARN(WARN_SYNTAX))
+ {
+ if (o->op_sibling->op_sibling) {
+ const OPCODE type = o->op_sibling->op_sibling->op_type;
+ if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
+ const line_t oldline = CopLINE(PL_curcop);
+ CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
+ Perl_warner(aTHX_ packWARN(WARN_EXEC),
+ "Statement unlikely to be reached");
+ Perl_warner(aTHX_ packWARN(WARN_EXEC),
+ "\t(Maybe you meant system() when you said exec()?)\n");
+ CopLINE_set(PL_curcop, oldline);
+ }
+ }
+ }
+ break;
+
+ case OP_GV:
+ if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
+ GV * const gv = cGVOPo_gv;
+ if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
+ /* XXX could check prototype here instead of just carping */
+ SV * const sv = sv_newmortal();
+ gv_efullname3(sv, gv, NULL);
+ Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
+ "%"SVf"() called too early to check prototype",
+ SVfARG(sv));
+ }
+ }
+ break;
+
+ case OP_CONST:
+ if (cSVOPo->op_private & OPpCONST_STRICT)
+ no_bareword_allowed(o);
+ /* FALLTHROUGH */
+#ifdef USE_ITHREADS
+ case OP_HINTSEVAL:
+ case OP_METHOD_NAMED:
+ /* Relocate sv to the pad for thread safety.
+ * Despite being a "constant", the SV is written to,
+ * for reference counts, sv_upgrade() etc. */
+ if (cSVOPo->op_sv) {
+ const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
+ if (o->op_type != OP_METHOD_NAMED &&
+ (SvPADTMP(cSVOPo->op_sv) || SvPADMY(cSVOPo->op_sv)))
+ {
+ /* If op_sv is already a PADTMP/MY then it is being used by
+ * some pad, so make a copy. */
+ sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
+ if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
+ SvREFCNT_dec(cSVOPo->op_sv);
+ }
+ else if (o->op_type != OP_METHOD_NAMED
+ && cSVOPo->op_sv == &PL_sv_undef) {
+ /* PL_sv_undef is hack - it's unsafe to store it in the
+ AV that is the pad, because av_fetch treats values of
+ PL_sv_undef as a "free" AV entry and will merrily
+ replace them with a new SV, causing pad_alloc to think
+ that this pad slot is free. (When, clearly, it is not)
+ */
+ SvOK_off(PAD_SVl(ix));
+ SvPADTMP_on(PAD_SVl(ix));
+ SvREADONLY_on(PAD_SVl(ix));
+ }
+ else {
+ SvREFCNT_dec(PAD_SVl(ix));
+ SvPADTMP_on(cSVOPo->op_sv);
+ PAD_SETSV(ix, cSVOPo->op_sv);
+ /* XXX I don't know how this isn't readonly already. */
+ if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
+ }
+ cSVOPo->op_sv = NULL;
+ o->op_targ = ix;
+ }
+#endif
+ break;
+
+ case OP_HELEM: {
+ UNOP *rop;
+ SV *lexname;
+ GV **fields;
+ SV **svp, *sv;
+ const char *key = NULL;
+ STRLEN keylen;
+
+ if (((BINOP*)o)->op_last->op_type != OP_CONST)
+ break;
+
+ /* Make the CONST have a shared SV */
+ svp = cSVOPx_svp(((BINOP*)o)->op_last);
+ if ((!SvIsCOW(sv = *svp))
+ && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
+ key = SvPV_const(sv, keylen);
+ lexname = newSVpvn_share(key,
+ SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
+ 0);
+ SvREFCNT_dec_NN(sv);
+ *svp = lexname;
+ }
+
+ if ((o->op_private & (OPpLVAL_INTRO)))
+ break;
+
+ rop = (UNOP*)((BINOP*)o)->op_first;
+ if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
+ break;
+ lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
+ if (!SvPAD_TYPED(lexname))
+ break;
+ fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
+ if (!fields || !GvHV(*fields))
+ break;
+ key = SvPV_const(*svp, keylen);
+ if (!hv_fetch(GvHV(*fields), key,
+ SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
+ Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
+ "in variable %"SVf" of type %"HEKf,
+ SVfARG(*svp), SVfARG(lexname),
+ HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
+ }
+ break;
+ }
+
+ case OP_HSLICE: {
+ UNOP *rop;
+ SV *lexname;
+ GV **fields;
+ SV **svp;
+ const char *key;
+ STRLEN keylen;
+ SVOP *first_key_op, *key_op;
+
+ if ((o->op_private & (OPpLVAL_INTRO))
+ /* I bet there's always a pushmark... */
+ || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
+ /* hmmm, no optimization if list contains only one key. */
+ break;
+ rop = (UNOP*)((LISTOP*)o)->op_last;
+ if (rop->op_type != OP_RV2HV)
+ break;
+ if (rop->op_first->op_type == OP_PADSV)
+ /* @$hash{qw(keys here)} */
+ rop = (UNOP*)rop->op_first;
+ else {
+ /* @{$hash}{qw(keys here)} */
+ if (rop->op_first->op_type == OP_SCOPE
+ && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
+ {
+ rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
+ }
+ else
+ break;
+ }
+
+ lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
+ if (!SvPAD_TYPED(lexname))
+ break;
+ fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
+ if (!fields || !GvHV(*fields))
+ break;
+ /* Again guessing that the pushmark can be jumped over.... */
+ first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
+ ->op_first->op_sibling;
+ for (key_op = first_key_op; key_op;
+ key_op = (SVOP*)key_op->op_sibling) {
+ if (key_op->op_type != OP_CONST)
+ continue;
+ svp = cSVOPx_svp(key_op);
+ key = SvPV_const(*svp, keylen);
+ if (!hv_fetch(GvHV(*fields), key,
+ SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
+ Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
+ "in variable %"SVf" of type %"HEKf,
+ SVfARG(*svp), SVfARG(lexname),
+ HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
+ }
+ }
+ break;
+ }
+
+ case OP_SUBST: {
+ if (cPMOPo->op_pmreplrootu.op_pmreplroot)
+ finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
+ break;
+ }
+ default:
+ break;
+ }
+
+ if (o->op_flags & OPf_KIDS) {
+ OP *kid;
+ for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
+ finalize_op(kid);
+ }
+}
+
+/*
=for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
Propagate lvalue ("modifiable") context to an op and its children.
@@ -1434,7 +1936,7 @@
*/
OP *
-Perl_op_lvalue(pTHX_ OP *o, I32 type)
+Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
{
dVAR;
OP *kid;
@@ -1450,40 +1952,24 @@
return o;
}
+ assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
+
+ if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
+
switch (o->op_type) {
case OP_UNDEF:
- localize = 0;
PL_modcount++;
return o;
- case OP_CONST:
- if (!(o->op_private & OPpCONST_ARYBASE))
- goto nomod;
- localize = 0;
- if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
- CopARYBASE_set(&PL_compiling,
- (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
- PL_eval_start = 0;
- }
- else if (!type) {
- SAVECOPARYBASE(&PL_compiling);
- CopARYBASE_set(&PL_compiling, 0);
- }
- else if (type == OP_REFGEN)
- goto nomod;
- else
- Perl_croak(aTHX_ "That use of $[ is unsupported");
- break;
case OP_STUB:
if ((o->op_flags & OPf_PARENS) || PL_madskills)
break;
goto nomod;
case OP_ENTERSUB:
- if ((type == OP_UNDEF || type == OP_REFGEN) &&
+ if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
!(o->op_flags & OPf_STACKED)) {
o->op_type = OP_RV2CV; /* entersub => rv2cv */
- /* The default is to set op_private to the number of children,
- which for a UNOP such as RV2CV is always 1. And w're using
- the bit for a flag in RV2CV, so we need it clear. */
+ /* Both ENTERSUB and RV2CV use this bit, but for different pur-
+ poses, so we need it clear. */
o->op_private &= ~1;
o->op_ppaddr = PL_ppaddr[OP_RV2CV];
assert(cUNOPo->op_first->op_type == OP_NULL);
@@ -1490,13 +1976,12 @@
op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
break;
}
- else if (o->op_private & OPpENTERSUB_NOMOD)
- return o;
else { /* lvalue subroutine call */
- o->op_private |= OPpLVAL_INTRO;
+ o->op_private |= OPpLVAL_INTRO
+ |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
PL_modcount = RETURN_UNLIMITED_NUMBER;
if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
- /* Backward compatibility mode: */
+ /* Potential lvalue context: */
o->op_private |= OPpENTERSUB_INARGS;
break;
}
@@ -1503,7 +1988,6 @@
else { /* Compile-time error message: */
OP *kid = cUNOPo->op_first;
CV *cv;
- OP *okid;
if (kid->op_type != OP_PUSHMARK) {
if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
@@ -1516,33 +2000,9 @@
while (kid->op_sibling)
kid = kid->op_sibling;
if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
- /* Indirect call */
- if (kid->op_type == OP_METHOD_NAMED
- || kid->op_type == OP_METHOD)
- {
- UNOP *newop;
-
- NewOp(1101, newop, 1, UNOP);
- newop->op_type = OP_RV2CV;
- newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
- newop->op_first = NULL;
- newop->op_next = (OP*)newop;
- kid->op_sibling = (OP*)newop;
- newop->op_private |= OPpLVAL_INTRO;
- newop->op_private &= ~1;
- break;
- }
-
- if (kid->op_type != OP_RV2CV)
- Perl_croak(aTHX_
- "panic: unexpected lvalue entersub "
- "entry via type/targ %ld:%"UVuf,
- (long)kid->op_type, (UV)kid->op_targ);
- kid->op_private |= OPpLVAL_INTRO;
break; /* Postpone until runtime */
}
- okid = kid;
kid = kUNOP->op_first;
if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
kid = kUNOP->op_first;
@@ -1552,25 +2012,12 @@
"entry via type/targ %ld:%"UVuf,
(long)kid->op_type, (UV)kid->op_targ);
if (kid->op_type != OP_GV) {
- /* Restore RV2CV to check lvalueness */
- restore_2cv:
- if (kid->op_next && kid->op_next != kid) { /* Happens? */
- okid->op_next = kid->op_next;
- kid->op_next = okid;
- }
- else
- okid->op_next = NULL;
- okid->op_type = OP_RV2CV;
- okid->op_targ = 0;
- okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
- okid->op_private |= OPpLVAL_INTRO;
- okid->op_private &= ~1;
break;
}
cv = GvCV(kGVOP_gv);
if (!cv)
- goto restore_2cv;
+ break;
if (CvLVALUE(cv))
break;
}
@@ -1578,8 +2025,10 @@
/* FALL THROUGH */
default:
nomod:
+ if (flags & OP_LVALUE_NO_CROAK) return NULL;
/* grep, foreach, subcalls, refgen */
- if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
+ if (type == OP_GREPSTART || type == OP_ENTERSUB
+ || type == OP_REFGEN || type == OP_LEAVESUBLV)
break;
yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
@@ -1635,11 +2084,12 @@
/* FALL THROUGH */
case OP_ASLICE:
case OP_HSLICE:
+ localize = 1;
+ /* FALL THROUGH */
+ case OP_AASSIGN:
if (type == OP_LEAVESUBLV)
o->op_private |= OPpMAYBE_LVSUB;
- localize = 1;
/* FALL THROUGH */
- case OP_AASSIGN:
case OP_NEXTSTATE:
case OP_DBSTATE:
PL_modcount = RETURN_UNLIMITED_NUMBER;
@@ -1664,6 +2114,7 @@
break;
case OP_AELEMFAST:
+ case OP_AELEMFAST_LEX:
localize = -1;
PL_modcount++;
break;
@@ -1681,8 +2132,8 @@
case OP_PADSV:
PL_modcount++;
if (!type) /* local() */
- Perl_croak(aTHX_ "Can't localize lexical variable %s",
- PAD_COMPNAME_PV(o->op_targ));
+ Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
+ PAD_COMPNAME_SV(o->op_targ));
break;
case OP_PUSHMARK:
@@ -1691,7 +2142,7 @@
case OP_KEYS:
case OP_RKEYS:
- if (type != OP_SASSIGN)
+ if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
goto nomod;
goto lvalue_func;
case OP_SUBSTR:
@@ -1700,9 +2151,9 @@
/* FALL THROUGH */
case OP_POS:
case OP_VEC:
+ lvalue_func:
if (type == OP_LEAVESUBLV)
o->op_private |= OPpMAYBE_LVSUB;
- lvalue_func:
pad_free(o->op_targ);
o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
@@ -1745,7 +2196,10 @@
case OP_LIST:
localize = 0;
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
- op_lvalue(kid, type);
+ /* elements might be in void context because the list is
+ in scalar context or because they are attribute sub calls */
+ if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
+ op_lvalue(kid, type);
break;
case OP_RETURN:
@@ -1752,6 +2206,9 @@
if (type != OP_LEAVESUBLV)
goto nomod;
break; /* op_lvalue()ing was handled by ck_return() */
+
+ case OP_COREARGS:
+ return o;
}
/* [20011101.069] File test operators interpret OPf_REF to mean that
@@ -1786,22 +2243,13 @@
return o;
}
-/* Do not use this. It will be removed after 5.14. */
-OP *
-Perl_mod(pTHX_ OP *o, I32 type)
-{
- return op_lvalue(o,type);
-}
-
-
STATIC bool
S_scalar_mod_type(const OP *o, I32 type)
{
- PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
-
switch (type) {
+ case OP_POS:
case OP_SASSIGN:
- if (o->op_type == OP_RV2GV)
+ if (o && o->op_type == OP_RV2GV)
return FALSE;
/* FALL THROUGH */
case OP_PREINC:
@@ -1894,7 +2342,7 @@
switch (o->op_type) {
case OP_ENTERSUB:
- if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
+ 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];
@@ -1903,6 +2351,13 @@
o->op_flags |= OPf_SPECIAL;
o->op_private &= ~1;
}
+ else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
+ o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
+ : type == OP_RV2HV ? OPpDEREF_HV
+ : OPpDEREF_SV);
+ o->op_flags |= OPf_MOD;
+ }
+
break;
case OP_COND_EXPR:
@@ -1942,7 +2397,7 @@
case OP_SCALAR:
case OP_NULL:
- if (!(o->op_flags & OPf_KIDS))
+ if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
break;
doref(cBINOPo->op_first, type, set_op_ref);
break;
@@ -2006,31 +2461,20 @@
}
STATIC void
-S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
+S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
{
dVAR;
- SV *stashsv;
+ SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
PERL_ARGS_ASSERT_APPLY_ATTRS;
/* fake up C<use attributes $pkg,$rv, at attrs> */
ENTER; /* need to protect against side-effects of 'use' */
- stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
#define ATTRSMODULE "attributes"
#define ATTRSMODULE_PM "attributes.pm"
- if (for_my) {
- /* Don't force the C<use> if we don't need it. */
- SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
- if (svp && *svp != &PL_sv_undef)
- NOOP; /* already in %INC */
- else
- Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
- newSVpvs(ATTRSMODULE), NULL);
- }
- else {
- Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
+ Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
newSVpvs(ATTRSMODULE),
NULL,
op_prepend_elem(OP_LIST,
@@ -2039,7 +2483,6 @@
newSVOP(OP_CONST, 0,
newRV(target)),
dup_attrlist(attrs))));
- }
LEAVE;
}
@@ -2048,7 +2491,7 @@
{
dVAR;
OP *pack, *imop, *arg;
- SV *meth, *stashsv;
+ SV *meth, *stashsv, **svp;
PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
@@ -2060,7 +2503,15 @@
target->op_type == OP_PADAV);
/* Ensure that attributes.pm is loaded. */
- apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
+ ENTER; /* need to protect against side-effects of 'use' */
+ /* Don't force the C<use> if we don't need it. */
+ svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
+ if (svp && *svp != &PL_sv_undef)
+ NOOP; /* already in %INC */
+ else
+ Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
+ newSVpvs(ATTRSMODULE), NULL);
+ LEAVE;
/* Need package name for method call. */
pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
@@ -2083,7 +2534,6 @@
op_append_elem(OP_LIST,
op_prepend_elem(OP_LIST, pack, list(arg)),
newSVOP(OP_METHOD_NAMED, 0, meth)));
- imop->op_private |= OPpENTERSUB_NOMOD;
/* Combine the ops. */
*imopsp = op_append_elem(OP_LIST, *imopsp, imop);
@@ -2161,12 +2611,9 @@
OP *kid;
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
my_kid(kid, attrs, imopsp);
- } else if (type == OP_UNDEF
-#ifdef PERL_MAD
- || type == OP_STUB
-#endif
- ) {
return o;
+ } else if (type == OP_UNDEF || type == OP_STUB) {
+ return o;
} else if (type == OP_RV2SV || /* "our" declaration */
type == OP_RV2AV ||
type == OP_RV2HV) { /* XXX does this let anything illegal in? */
@@ -2184,7 +2631,7 @@
(type == OP_RV2SV ? GvSV(gv) :
type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
- attrs, FALSE);
+ attrs);
}
o->op_private |= OPpOUR_INTRO;
return o;
@@ -2248,8 +2695,19 @@
o = scalar(op_append_list(OP_LIST, rops, o));
o->op_private |= OPpLVAL_INTRO;
}
- else
+ else {
+ /* The listop in rops might have a pushmark at the beginning,
+ which will mess up list assignment. */
+ LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
+ if (rops->op_type == OP_LIST &&
+ lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
+ {
+ OP * const pushmark = lrops->op_first;
+ lrops->op_first = pushmark->op_sibling;
+ op_free(pushmark);
+ }
o = op_append_list(OP_LIST, o, rops);
+ }
}
PL_parser->in_my = FALSE;
PL_parser->in_my_stash = NULL;
@@ -2284,11 +2742,28 @@
|| rtype == OP_TRANSR
)
? (int)rtype : OP_MATCH];
- const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
+ const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
+ GV *gv;
+ SV * const name =
+ (ltype == OP_RV2AV || ltype == OP_RV2HV)
+ ? cUNOPx(left)->op_first->op_type == OP_GV
+ && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
+ ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
+ : NULL
+ : varname(
+ (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1
+ );
+ if (name)
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
+ "Applying %s to %"SVf" will act on scalar(%"SVf")",
+ desc, name, name);
+ else {
+ const char * const sample = (isary
? "@array" : "%hash");
- Perl_warner(aTHX_ packWARN(WARN_MISC),
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
"Applying %s to %s will act on scalar(%s)",
desc, sample, sample);
+ }
}
if (rtype == OP_CONST &&
@@ -2335,7 +2810,7 @@
}
else
return bind_match(type, left,
- pmruntime(newPMOP(OP_MATCH, 0), right, 0));
+ pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
}
OP *
@@ -2365,7 +2840,7 @@
{
dVAR;
if (o) {
- if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
+ 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];
@@ -2391,6 +2866,18 @@
return o;
}
+OP *
+Perl_op_unscope(pTHX_ OP *o)
+{
+ if (o && o->op_type == OP_LINESEQ) {
+ OP *kid = cLISTOPo->op_first;
+ for(; kid; kid = kid->op_sibling)
+ if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
+ op_null(kid);
+ }
+ return o;
+}
+
int
Perl_block_start(pTHX_ int full)
{
@@ -2414,6 +2901,7 @@
dVAR;
const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
OP* retval = scalarseq(seq);
+ OP *o;
CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
@@ -2421,8 +2909,67 @@
CopHINTS_set(&PL_compiling, PL_hints);
if (needblockscope)
PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
- pad_leavemy();
+ o = pad_leavemy();
+ if (o) {
+ /* pad_leavemy has created a sequence of introcv ops for all my
+ subs declared in the block. We have to replicate that list with
+ clonecv ops, to deal with this situation:
+
+ sub {
+ my sub s1;
+ my sub s2;
+ sub s1 { state sub foo { \&s2 } }
+ }->()
+
+ Originally, I was going to have introcv clone the CV and turn
+ off the stale flag. Since &s1 is declared before &s2, the
+ introcv op for &s1 is executed (on sub entry) before the one for
+ &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
+ cloned, since it is a state sub) closes over &s2 and expects
+ to see it in its outer CV’s pad. If the introcv op clones &s1,
+ then &s2 is still marked stale. Since &s1 is not active, and
+ &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
+ ble will not stay shared’ warning. Because it is the same stub
+ that will be used when the introcv op for &s2 is executed, clos-
+ ing over it is safe. Hence, we have to turn off the stale flag
+ on all lexical subs in the block before we clone any of them.
+ Hence, having introcv clone the sub cannot work. So we create a
+ list of ops like this:
+
+ lineseq
+ |
+ +-- introcv
+ |
+ +-- introcv
+ |
+ +-- introcv
+ |
+ .
+ .
+ .
+ |
+ +-- clonecv
+ |
+ +-- clonecv
+ |
+ +-- clonecv
+ |
+ .
+ .
+ .
+ */
+ OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
+ OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
+ for (;; kid = kid->op_sibling) {
+ OP *newkid = newOP(OP_CLONECV, 0);
+ newkid->op_targ = kid->op_targ;
+ o = op_append_elem(OP_LINESEQ, o, newkid);
+ if (kid == last) break;
+ }
+ retval = op_prepend_elem(OP_LINESEQ, o, retval);
+ }
+
CALL_BLOCK_HOOKS(bhk_post_end, &retval);
return retval;
@@ -2451,7 +2998,7 @@
S_newDEFSVOP(pTHX)
{
dVAR;
- const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
+ 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));
}
@@ -2470,22 +3017,64 @@
PERL_ARGS_ASSERT_NEWPROG;
if (PL_in_eval) {
+ PERL_CONTEXT *cx;
+ I32 i;
if (PL_eval_root)
return;
PL_eval_root = newUNOP(OP_LEAVEEVAL,
((PL_in_eval & EVAL_KEEPERR)
? OPf_SPECIAL : 0), o);
- /* don't use LINKLIST, since PL_eval_root might indirect through
- * a rather expensive function call and LINKLIST evaluates its
- * argument more than once */
+
+ cx = &cxstack[cxstack_ix];
+ assert(CxTYPE(cx) == CXt_EVAL);
+
+ if ((cx->blk_gimme & G_WANT) == G_VOID)
+ scalarvoid(PL_eval_root);
+ else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
+ list(PL_eval_root);
+ else
+ scalar(PL_eval_root);
+
PL_eval_start = op_linklist(PL_eval_root);
PL_eval_root->op_private |= OPpREFCOUNTED;
OpREFCNT_set(PL_eval_root, 1);
PL_eval_root->op_next = 0;
+ i = PL_savestack_ix;
+ SAVEFREEOP(o);
+ ENTER;
CALL_PEEP(PL_eval_start);
+ finalize_optree(PL_eval_root);
+ LEAVE;
+ PL_savestack_ix = i;
}
else {
if (o->op_type == OP_STUB) {
+ /* This block is entered if nothing is compiled for the main
+ program. This will be the case for an genuinely empty main
+ program, or one which only has BEGIN blocks etc, so already
+ run and freed.
+
+ Historically (5.000) the guard above was !o. However, commit
+ f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
+ c71fccf11fde0068, changed perly.y so that newPROG() is now
+ called with the output of block_end(), which returns a new
+ OP_STUB for the case of an empty optree. ByteLoader (and
+ maybe other things) also take this path, because they set up
+ PL_main_start and PL_main_root directly, without generating an
+ optree.
+
+ If the parsing the main program aborts (due to parse errors,
+ or due to BEGIN or similar calling exit), then newPROG()
+ isn't even called, and hence this code path and its cleanups
+ are skipped. This shouldn't make a make a difference:
+ * a non-zero return from perl_parse is a failure, and
+ perl_destruct() should be called immediately.
+ * however, if exit(0) is called during the parse, then
+ perl_parse() returns 0, and perl_run() is called. As
+ PL_main_start will be NULL, perl_run() will return
+ promptly, and the exit code will remain 0.
+ */
+
PL_comppad_name = 0;
PL_compcv = 0;
S_op_destroy(aTHX_ o);
@@ -2498,6 +3087,8 @@
OpREFCNT_set(PL_main_root, 1);
PL_main_root->op_next = 0;
CALL_PEEP(PL_main_start);
+ finalize_optree(PL_main_root);
+ cv_forget_slab(PL_compcv);
PL_compcv = 0;
/* Register with debugger */
@@ -2543,10 +3134,10 @@
while (1) {
if (*s && strchr("@$%*", *s) && *++s
- && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
+ && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
s++;
sigil = TRUE;
- while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
+ while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
s++;
while (*s && (strchr(", \t\n", *s)))
s++;
@@ -2589,11 +3180,47 @@
return o;
}
+PERL_STATIC_INLINE OP *
+S_op_std_init(pTHX_ OP *o)
+{
+ I32 type = o->op_type;
+
+ PERL_ARGS_ASSERT_OP_STD_INIT;
+
+ if (PL_opargs[type] & OA_RETSCALAR)
+ scalar(o);
+ if (PL_opargs[type] & OA_TARGET && !o->op_targ)
+ o->op_targ = pad_alloc(type, SVs_PADTMP);
+
+ return o;
+}
+
+PERL_STATIC_INLINE OP *
+S_op_integerize(pTHX_ OP *o)
+{
+ I32 type = o->op_type;
+
+ PERL_ARGS_ASSERT_OP_INTEGERIZE;
+
+ /* integerize op. */
+ if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
+ {
+ dVAR;
+ o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
+ }
+
+ if (type == OP_NEGATE)
+ /* XXX might want a ck_negate() for this */
+ cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
+
+ return o;
+}
+
static OP *
-S_fold_constants(pTHX_ register OP *o)
+S_fold_constants(pTHX_ OP *o)
{
dVAR;
- register OP * VOL curop;
+ OP * VOL curop;
OP *newop;
VOL I32 type = o->op_type;
SV * VOL sv = NULL;
@@ -2607,28 +3234,10 @@
PERL_ARGS_ASSERT_FOLD_CONSTANTS;
- if (PL_opargs[type] & OA_RETSCALAR)
- scalar(o);
- if (PL_opargs[type] & OA_TARGET && !o->op_targ)
- o->op_targ = pad_alloc(type, SVs_PADTMP);
-
- /* integerize op, unless it happens to be C<-foo>.
- * XXX should pp_i_negate() do magic string negation instead? */
- if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
- && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
- && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
- {
- o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
- }
-
if (!(PL_opargs[type] & OA_FOLDCONST))
goto nope;
switch (type) {
- case OP_NEGATE:
- /* XXX might want a ck_negate() for this */
- cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
- break;
case OP_UCFIRST:
case OP_LCFIRST:
case OP_UC:
@@ -2640,9 +3249,27 @@
case OP_SCMP:
case OP_SPRINTF:
/* XXX what about the numeric ops? */
- if (PL_hints & HINT_LOCALE)
+ if (IN_LOCALE_COMPILETIME)
goto nope;
break;
+ case OP_PACK:
+ if (!cLISTOPo->op_first->op_sibling
+ || cLISTOPo->op_first->op_sibling->op_type != OP_CONST)
+ goto nope;
+ {
+ SV * const sv = cSVOPx_sv(cLISTOPo->op_first->op_sibling);
+ if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
+ {
+ const char *s = SvPVX_const(sv);
+ while (s < SvEND(sv)) {
+ if (*s == 'p' || *s == 'P') goto nope;
+ s++;
+ }
+ }
+ }
+ break;
+ case OP_REPEAT:
+ if (o->op_private & OPpREPEAT_DOLIST) goto nope;
}
if (PL_parser && PL_parser->error_count)
@@ -2683,8 +3310,16 @@
case 0:
CALLRUNOPS(aTHX);
sv = *(PL_stack_sp--);
- if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
+ if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
+#ifdef PERL_MAD
+ /* Can't simply swipe the SV from the pad, because that relies on
+ the op being freed "real soon now". Under MAD, this doesn't
+ happen (see the #ifdef below). */
+ sv = newSVsv(sv);
+#else
pad_swipe(o->op_targ, FALSE);
+#endif
+ }
else if (SvTEMP(sv)) { /* grab mortal temp? */
SvREFCNT_inc_simple_void(sv);
SvTEMP_off(sv);
@@ -2723,7 +3358,7 @@
if (type == OP_RV2GV)
newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
else
- newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
+ newop = newSVOP(OP_CONST, OPpCONST_FOLDED<<8, MUTABLE_SV(sv));
op_getmad(o,newop,'f');
return newop;
@@ -2732,10 +3367,10 @@
}
static OP *
-S_gen_constant_list(pTHX_ register OP *o)
+S_gen_constant_list(pTHX_ OP *o)
{
dVAR;
- register OP *curop;
+ OP *curop;
const I32 oldtmps_floor = PL_tmps_floor;
list(o);
@@ -2773,6 +3408,7 @@
Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
{
dVAR;
+ if (type < 0) type = -type, flags |= OPf_SPECIAL;
if (!o || o->op_type != OP_LIST)
o = newLISTOP(OP_LIST, 0, o, NULL);
else
@@ -2780,6 +3416,13 @@
if (!(PL_opargs[type] & OA_MARK))
op_null(cLISTOPo->op_first);
+ else {
+ OP * const kid2 = cLISTOPo->op_first->op_sibling;
+ 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];
@@ -2789,7 +3432,7 @@
if (o->op_type != (unsigned)type)
return o;
- return fold_constants(o);
+ return fold_constants(op_integerize(op_std_init(o)));
}
/*
@@ -3139,8 +3782,7 @@
MADPROP *
Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
{
- MADPROP *mp;
- Newxz(mp, 1, MADPROP);
+ MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
mp->mad_next = 0;
mp->mad_key = key;
mp->mad_vlen = vlen;
@@ -3164,7 +3806,7 @@
case MAD_NULL:
break;
case MAD_PV:
- Safefree((char*)mp->mad_val);
+ Safefree(mp->mad_val);
break;
case MAD_OP:
if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
@@ -3177,7 +3819,7 @@
PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
break;
}
- Safefree(mp);
+ PerlMemShared_free(mp);
}
#endif
@@ -3273,6 +3915,11 @@
dVAR;
OP *o;
+ if (type == -OP_ENTEREVAL) {
+ type = OP_ENTEREVAL;
+ flags |= OPpEVAL_BYTES<<8;
+ }
+
assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
@@ -3282,9 +3929,6 @@
o->op_type = (OPCODE)type;
o->op_ppaddr = PL_ppaddr[type];
o->op_flags = (U8)flags;
- o->op_latefree = 0;
- o->op_latefreed = 0;
- o->op_attached = 0;
o->op_next = o;
o->op_private = (U8)(0 | (flags >> 8));
@@ -3315,6 +3959,11 @@
dVAR;
UNOP *unop;
+ if (type == -OP_ENTEREVAL) {
+ type = OP_ENTEREVAL;
+ flags |= OPpEVAL_BYTES<<8;
+ }
+
assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
@@ -3338,7 +3987,7 @@
if (unop->op_next)
return (OP*)unop;
- return fold_constants((OP *) unop);
+ return fold_constants(op_integerize(op_std_init((OP *) unop)));
}
/*
@@ -3388,7 +4037,7 @@
binop->op_last = binop->op_first->op_sibling;
- return fold_constants((OP *)binop);
+ return fold_constants(op_integerize(op_std_init((OP *)binop)));
}
static int uvcompare(const void *a, const void *b)
@@ -3423,10 +4072,10 @@
STRLEN rlen;
const U8 *t = (U8*)SvPV_const(tstr, tlen);
const U8 *r = (U8*)SvPV_const(rstr, rlen);
- register I32 i;
- register I32 j;
+ I32 i;
+ I32 j;
I32 grows = 0;
- register short *tbl;
+ short *tbl;
const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
const I32 squash = o->op_private & OPpTRANS_SQUASH;
@@ -3627,9 +4276,6 @@
else
bits = 8;
- PerlMemShared_free(cPVOPo->op_pv);
- cPVOPo->op_pv = NULL;
-
swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
#ifdef USE_ITHREADS
cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
@@ -3663,9 +4309,12 @@
return o;
}
- tbl = (short*)cPVOPo->op_pv;
+ tbl = (short*)PerlMemShared_calloc(
+ (o->op_private & OPpTRANS_COMPLEMENT) &&
+ !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
+ sizeof(short));
+ cPVOPo->op_pv = (char*)tbl;
if (complement) {
- Zero(tbl, 256, short);
for (i = 0; i < (I32)tlen; i++)
tbl[t[i]] = -1;
for (i = 0, j = 0; i < 256; i++) {
@@ -3778,10 +4427,13 @@
if (PL_hints & HINT_RE_TAINT)
pmop->op_pmflags |= PMf_RETAINT;
- if (PL_hints & HINT_LOCALE) {
+ if (IN_LOCALE_COMPILETIME) {
set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
}
- else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
+ else if ((! (PL_hints & HINT_BYTES))
+ /* Both UNI_8_BIT and locale :not_characters imply Unicode */
+ && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS)))
+ {
set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
}
if (PL_hints & HINT_RE_FLAGS) {
@@ -3834,10 +4486,14 @@
* split "pattern", which aren't. In the former case, expr will be a list
* if the pattern contains more than one term (eg /a$b/) or if it contains
* a replacement, ie s/// or tr///.
+ *
+ * When the pattern has been compiled within a new anon CV (for
+ * qr/(?{...})/ ), then floor indicates the savestack level just before
+ * the new sub was created
*/
OP *
-Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
+Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
{
dVAR;
PMOP *pm;
@@ -3844,15 +4500,15 @@
LOGOP *rcop;
I32 repl_has_vars = 0;
OP* repl = NULL;
- bool reglist;
+ bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
+ bool is_compiletime;
+ bool has_code;
PERL_ARGS_ASSERT_PMRUNTIME;
- if (
- o->op_type == OP_SUBST
- || o->op_type == OP_TRANS || o->op_type == OP_TRANSR
- ) {
- /* last element in list is the replacement; pop it */
+ /* for s/// and tr///, last element in list is the replacement; pop it */
+
+ if (is_trans || o->op_type == OP_SUBST) {
OP* kid;
repl = cLISTOPx(expr)->op_last;
kid = cLISTOPx(expr)->op_first;
@@ -3862,61 +4518,244 @@
cLISTOPx(expr)->op_last = kid;
}
- if (isreg && expr->op_type == OP_LIST &&
- cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
- {
- /* convert single element list to element */
+ /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
+
+ if (is_trans) {
OP* const oe = expr;
- expr = cLISTOPx(oe)->op_first->op_sibling;
+ assert(expr->op_type == OP_LIST);
+ assert(cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK);
+ assert(cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last);
+ expr = cLISTOPx(oe)->op_last;
cLISTOPx(oe)->op_first->op_sibling = NULL;
cLISTOPx(oe)->op_last = NULL;
op_free(oe);
- }
- if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
return pmtrans(o, expr, repl);
}
- reglist = isreg && expr->op_type == OP_LIST;
- if (reglist)
- op_null(expr);
+ /* find whether we have any runtime or code elements;
+ * at the same time, temporarily set the op_next of each DO block;
+ * then when we LINKLIST, this will cause the DO blocks to be excluded
+ * from the op_next chain (and from having LINKLIST recursively
+ * applied to them). We fix up the DOs specially later */
+ is_compiletime = 1;
+ has_code = 0;
+ if (expr->op_type == OP_LIST) {
+ OP *o;
+ for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
+ if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
+ has_code = 1;
+ assert(!o->op_next && o->op_sibling);
+ o->op_next = o->op_sibling;
+ }
+ else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
+ is_compiletime = 0;
+ }
+ }
+ else if (expr->op_type != OP_CONST)
+ is_compiletime = 0;
+
+ LINKLIST(expr);
+
+ /* fix up DO blocks; treat each one as a separate little sub;
+ * also, mark any arrays as LIST/REF */
+
+ if (expr->op_type == OP_LIST) {
+ OP *o;
+ for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
+
+ if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
+ assert( !(o->op_flags & OPf_WANT));
+ /* push the array rather than its contents. The regex
+ * engine will retrieve and join the elements later */
+ o->op_flags |= (OPf_WANT_LIST | OPf_REF);
+ continue;
+ }
+
+ if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
+ continue;
+ o->op_next = NULL; /* undo temporary hack from above */
+ scalar(o);
+ LINKLIST(o);
+ if (cLISTOPo->op_first->op_type == OP_LEAVE) {
+ LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
+ /* skip ENTER */
+ assert(leaveop->op_first->op_type == OP_ENTER);
+ assert(leaveop->op_first->op_sibling);
+ o->op_next = leaveop->op_first->op_sibling;
+ /* skip leave */
+ assert(leaveop->op_flags & OPf_KIDS);
+ assert(leaveop->op_last->op_next == (OP*)leaveop);
+ leaveop->op_next = NULL; /* stop on last op */
+ op_null((OP*)leaveop);
+ }
+ else {
+ /* skip SCOPE */
+ OP *scope = cLISTOPo->op_first;
+ assert(scope->op_type == OP_SCOPE);
+ assert(scope->op_flags & OPf_KIDS);
+ scope->op_next = NULL; /* stop on last op */
+ op_null(scope);
+ }
+ /* have to peep the DOs individually as we've removed it from
+ * the op_next chain */
+ CALL_PEEP(o);
+ if (is_compiletime)
+ /* runtime finalizes as part of finalizing whole tree */
+ finalize_optree(o);
+ }
+ }
+ else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
+ assert( !(expr->op_flags & OPf_WANT));
+ /* push the array rather than its contents. The regex
+ * engine will retrieve and join the elements later */
+ expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
+ }
+
PL_hints |= HINT_BLOCK_SCOPE;
pm = (PMOP*)o;
+ assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
- if (expr->op_type == OP_CONST) {
- SV *pat = ((SVOP*)expr)->op_sv;
- U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
+ if (is_compiletime) {
+ U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
+ regexp_engine const *eng = current_re_engine();
- if (o->op_flags & OPf_SPECIAL)
- pm_flags |= RXf_SPLIT;
+ if (o->op_flags & OPf_SPECIAL)
+ rx_flags |= RXf_SPLIT;
- if (DO_UTF8(pat)) {
- assert (SvUTF8(pat));
- } else if (SvUTF8(pat)) {
- /* Not doing UTF-8, despite what the SV says. Is this only if we're
- trapped in use 'bytes'? */
- /* Make a copy of the octet sequence, but without the flag on, as
- the compiler now honours the SvUTF8 flag on pat. */
- STRLEN len;
- const char *const p = SvPV(pat, len);
- pat = newSVpvn_flags(p, len, SVs_TEMP);
- }
+ if (!has_code || !eng->op_comp) {
+ /* compile-time simple constant pattern */
- PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
+ if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
+ /* whoops! we guessed that a qr// had a code block, but we
+ * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
+ * that isn't required now. Note that we have to be pretty
+ * confident that nothing used that CV's pad while the
+ * regex was parsed */
+ assert(AvFILLp(PL_comppad) == 0); /* just @_ */
+ /* But we know that one op is using this CV's slab. */
+ cv_forget_slab(PL_compcv);
+ LEAVE_SCOPE(floor);
+ pm->op_pmflags &= ~PMf_HAS_CV;
+ }
+ PM_SETRE(pm,
+ eng->op_comp
+ ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
+ rx_flags, pm->op_pmflags)
+ : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
+ rx_flags, pm->op_pmflags)
+ );
#ifdef PERL_MAD
- op_getmad(expr,(OP*)pm,'e');
+ op_getmad(expr,(OP*)pm,'e');
#else
- op_free(expr);
+ op_free(expr);
#endif
+ }
+ else {
+ /* compile-time pattern that includes literal code blocks */
+ REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
+ rx_flags,
+ (pm->op_pmflags |
+ ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
+ );
+ PM_SETRE(pm, re);
+ if (pm->op_pmflags & PMf_HAS_CV) {
+ CV *cv;
+ /* this QR op (and the anon sub we embed it in) is never
+ * actually executed. It's just a placeholder where we can
+ * squirrel away expr in op_code_list without the peephole
+ * optimiser etc processing it for a second time */
+ OP *qr = newPMOP(OP_QR, 0);
+ ((PMOP*)qr)->op_code_list = expr;
+
+ /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
+ SvREFCNT_inc_simple_void(PL_compcv);
+ cv = newATTRSUB(floor, 0, NULL, NULL, qr);
+ ReANY(re)->qr_anoncv = cv;
+
+ /* attach the anon CV to the pad so that
+ * pad_fixup_inner_anons() can find it */
+ (void)pad_add_anon(cv, o->op_type);
+ SvREFCNT_inc_simple_void(cv);
+ }
+ else {
+ pm->op_code_list = expr;
+ }
+ }
}
else {
- if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
- expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
- ? OP_REGCRESET
- : OP_REGCMAYBE),0,expr);
+ /* runtime pattern: build chain of regcomp etc ops */
+ bool reglist;
+ PADOFFSET cv_targ = 0;
+ reglist = isreg && expr->op_type == OP_LIST;
+ if (reglist)
+ op_null(expr);
+
+ if (has_code) {
+ pm->op_code_list = expr;
+ /* don't free op_code_list; its ops are embedded elsewhere too */
+ pm->op_pmflags |= PMf_CODELIST_PRIVATE;
+ }
+
+ if (o->op_flags & OPf_SPECIAL)
+ pm->op_pmflags |= PMf_SPLIT;
+
+ /* the OP_REGCMAYBE is a placeholder in the non-threaded case
+ * to allow its op_next to be pointed past the regcomp and
+ * preceding stacking ops;
+ * OP_REGCRESET is there to reset taint before executing the
+ * stacking ops */
+ if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
+ expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
+
+ if (pm->op_pmflags & PMf_HAS_CV) {
+ /* we have a runtime qr with literal code. This means
+ * that the qr// has been wrapped in a new CV, which
+ * means that runtime consts, vars etc will have been compiled
+ * against a new pad. So... we need to execute those ops
+ * within the environment of the new CV. So wrap them in a call
+ * to a new anon sub. i.e. for
+ *
+ * qr/a$b(?{...})/,
+ *
+ * we build an anon sub that looks like
+ *
+ * sub { "a", $b, '(?{...})' }
+ *
+ * and call it, passing the returned list to regcomp.
+ * Or to put it another way, the list of ops that get executed
+ * are:
+ *
+ * normal PMf_HAS_CV
+ * ------ -------------------
+ * pushmark (for regcomp)
+ * pushmark (for entersub)
+ * pushmark (for refgen)
+ * anoncode
+ * refgen
+ * entersub
+ * regcreset regcreset
+ * pushmark pushmark
+ * const("a") const("a")
+ * gvsv(b) gvsv(b)
+ * const("(?{...})") const("(?{...})")
+ * leavesub
+ * regcomp regcomp
+ */
+
+ SvREFCNT_inc_simple_void(PL_compcv);
+ /* these lines are just an unrolled newANONATTRSUB */
+ expr = newSVOP(OP_ANONCODE, 0,
+ MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
+ cv_targ = expr->op_targ;
+ expr = newUNOP(OP_REFGEN, 0, expr);
+
+ expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr))));
+ }
+
NewOp(1101, rcop, 1, LOGOP);
rcop->op_type = OP_REGCOMP;
rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
@@ -3924,16 +4763,15 @@
rcop->op_flags |= OPf_KIDS
| ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
| (reglist ? OPf_STACKED : 0);
- rcop->op_private = 1;
+ rcop->op_private = 0;
rcop->op_other = o;
- if (reglist)
- rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
+ 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;
/* establish postfix order */
- if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
+ if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
LINKLIST(expr);
rcop->op_next = expr;
((UNOP*)expr)->op_first->op_next = (OP*)rcop;
@@ -3947,53 +4785,42 @@
}
if (repl) {
- OP *curop;
+ OP *curop = repl;
+ bool konst;
if (pm->op_pmflags & PMf_EVAL) {
- curop = NULL;
if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
}
- else if (repl->op_type == OP_CONST)
- curop = repl;
- else {
- OP *lastop = NULL;
- for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
- if (curop->op_type == OP_SCOPE
- || curop->op_type == OP_LEAVE
- || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
- if (curop->op_type == OP_GV) {
- GV * const gv = cGVOPx_gv(curop);
- repl_has_vars = 1;
- if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
- break;
- }
- else if (curop->op_type == OP_RV2CV)
- break;
- else if (curop->op_type == OP_RV2SV ||
- curop->op_type == OP_RV2AV ||
- curop->op_type == OP_RV2HV ||
- curop->op_type == OP_RV2GV) {
- if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
- break;
- }
- else if (curop->op_type == OP_PADSV ||
- curop->op_type == OP_PADAV ||
- curop->op_type == OP_PADHV ||
- curop->op_type == OP_PADANY)
- {
- repl_has_vars = 1;
- }
- else if (curop->op_type == OP_PUSHRE)
- NOOP; /* Okay here, dangerous in newASSIGNOP */
- else
- break;
- }
- lastop = curop;
- }
+ /* If we are looking at s//.../e with a single statement, get past
+ the implicit do{}. */
+ if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
+ && cUNOPx(curop)->op_first->op_type == OP_SCOPE
+ && cUNOPx(curop)->op_first->op_flags & OPf_KIDS) {
+ OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
+ if (kid->op_type == OP_NULL && kid->op_sibling
+ && !kid->op_sibling->op_sibling)
+ curop = kid->op_sibling;
}
- if (curop == repl
+ if (curop->op_type == OP_CONST)
+ konst = TRUE;
+ else if (( (curop->op_type == OP_RV2SV ||
+ curop->op_type == OP_RV2AV ||
+ curop->op_type == OP_RV2HV ||
+ curop->op_type == OP_RV2GV)
+ && cUNOPx(curop)->op_first
+ && cUNOPx(curop)->op_first->op_type == OP_GV )
+ || curop->op_type == OP_PADSV
+ || curop->op_type == OP_PADAV
+ || curop->op_type == OP_PADHV
+ || curop->op_type == OP_PADANY) {
+ repl_has_vars = 1;
+ konst = TRUE;
+ }
+ else konst = FALSE;
+ if (konst
&& !(repl_has_vars
&& (!PM_GETRE(pm)
+ || !RX_PRELEN(PM_GETRE(pm))
|| RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
{
pm->op_pmflags |= PMf_CONST; /* const for long enough */
@@ -4000,9 +4827,6 @@
op_prepend_elem(o->op_type, scalar(repl), o);
}
else {
- if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
- pm->op_pmflags |= PMf_MAYBE_CONST;
- }
NewOp(1101, rcop, 1, LOGOP);
rcop->op_type = OP_SUBSTCONT;
rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
@@ -4054,6 +4878,7 @@
svop->op_sv = sv;
svop->op_next = (OP*)svop;
svop->op_flags = (U8)flags;
+ svop->op_private = (U8)(0 | (flags >> 8));
if (PL_opargs[type] & OA_RETSCALAR)
scalar((OP*)svop);
if (PL_opargs[type] & OA_TARGET)
@@ -4151,9 +4976,13 @@
Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
{
dVAR;
+ const bool utf8 = cBOOL(flags & SVf_UTF8);
PVOP *pvop;
+ flags &= ~SVf_UTF8;
+
assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
+ || type == OP_RUNCV
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
NewOp(1101, pvop, 1, PVOP);
@@ -4162,6 +4991,7 @@
pvop->op_pv = pv;
pvop->op_next = (OP*)pvop;
pvop->op_flags = (U8)flags;
+ pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
if (PL_opargs[type] & OA_RETSCALAR)
scalar((OP*)pvop);
if (PL_opargs[type] & OA_TARGET)
@@ -4184,10 +5014,10 @@
PERL_ARGS_ASSERT_PACKAGE;
- save_hptr(&PL_curstash);
+ SAVEGENERICSV(PL_curstash);
save_item(PL_curstname);
- PL_curstash = gv_stashsv(sv, GV_ADD);
+ PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
sv_setsv(PL_curstname, sv);
@@ -4233,7 +5063,7 @@
OP *imop;
OP *veop;
#ifdef PERL_MAD
- OP *pegop = newOP(OP_NULL,0);
+ OP *pegop = PL_madskills ? newOP(OP_NULL,0) : NULL;
#endif
SV *use_version = NULL;
@@ -4317,23 +5147,30 @@
newSTATEOP(0, NULL, imop) ));
if (use_version) {
- /* If we request a version >= 5.9.5, load feature.pm with the
+ /* Enable the
* feature bundle that corresponds to the required version. */
use_version = sv_2mortal(new_version(use_version));
+ S_enable_feature_bundle(aTHX_ use_version);
- if (vcmp(use_version,
- sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
- SV *const importsv = vnormal(use_version);
- *SvPVX_mutable(importsv) = ':';
- ENTER_with_name("load_feature");
- Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
- LEAVE_with_name("load_feature");
- }
/* If a version >= 5.11.0 is requested, strictures are on by default! */
if (vcmp(use_version,
sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
- PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
+ if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
+ PL_hints |= HINT_STRICT_REFS;
+ if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
+ PL_hints |= HINT_STRICT_SUBS;
+ if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
+ PL_hints |= HINT_STRICT_VARS;
}
+ /* otherwise they are off */
+ else {
+ if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
+ PL_hints &= ~HINT_STRICT_REFS;
+ if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
+ PL_hints &= ~HINT_STRICT_SUBS;
+ if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
+ PL_hints &= ~HINT_STRICT_VARS;
+ }
}
/* The "did you use incorrect case?" warning used to be here.
@@ -4361,11 +5198,6 @@
PL_cop_seqmax++;
#ifdef PERL_MAD
- if (!PL_madskills) {
- /* FIXME - don't allocate pegop if !PL_madskills */
- op_free(pegop);
- return NULL;
- }
return pegop;
#endif
}
@@ -4379,7 +5211,7 @@
Note that the actual module name, not its filename, should be given.
Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
-(or 0 for no flags). ver, if specified, provides version semantics
+(or 0 for no flags). ver, if specified and not NULL, provides version semantics
similar to C<use Foo::Bar VERSION>. The optional trailing SV*
arguments can be used to specify arguments to the module's import()
method, similar to C<use Foo::Bar VERSION LIST>. They must be
@@ -4388,6 +5220,8 @@
Otherwise at least a single NULL pointer to designate the default
import list is required.
+The reference count for each specified C<SV*> parameter is decremented.
+
=cut */
void
@@ -4478,10 +5312,10 @@
}
if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
- doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
+ doop = newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST, term,
scalar(newUNOP(OP_RV2CV, 0,
- newGVOP(OP_GV, 0, gv))))));
+ newGVOP(OP_GV, 0, gv)))));
}
else {
doop = newUNOP(OP_DOFILE, 0, scalar(term));
@@ -4514,7 +5348,7 @@
}
STATIC I32
-S_is_list_assignment(pTHX_ register const OP *o)
+S_is_list_assignment(pTHX_ const OP *o)
{
unsigned type;
U8 flags;
@@ -4558,6 +5392,76 @@
}
/*
+ Helper function for newASSIGNOP to detection commonality between the
+ lhs and the rhs. Marks all variables with PL_generation. If it
+ returns TRUE the assignment must be able to handle common variables.
+*/
+PERL_STATIC_INLINE bool
+S_aassign_common_vars(pTHX_ OP* o)
+{
+ OP *curop;
+ for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
+ if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
+ if (curop->op_type == OP_GV) {
+ GV *gv = cGVOPx_gv(curop);
+ if (gv == PL_defgv
+ || (int)GvASSIGN_GENERATION(gv) == PL_generation)
+ return TRUE;
+ GvASSIGN_GENERATION_set(gv, PL_generation);
+ }
+ else if (curop->op_type == OP_PADSV ||
+ curop->op_type == OP_PADAV ||
+ curop->op_type == OP_PADHV ||
+ curop->op_type == OP_PADANY)
+ {
+ if (PAD_COMPNAME_GEN(curop->op_targ)
+ == (STRLEN)PL_generation)
+ return TRUE;
+ PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
+
+ }
+ else if (curop->op_type == OP_RV2CV)
+ return TRUE;
+ else if (curop->op_type == OP_RV2SV ||
+ curop->op_type == OP_RV2AV ||
+ curop->op_type == OP_RV2HV ||
+ curop->op_type == OP_RV2GV) {
+ if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
+ return TRUE;
+ }
+ else if (curop->op_type == OP_PUSHRE) {
+#ifdef USE_ITHREADS
+ if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
+ GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
+ if (gv == PL_defgv
+ || (int)GvASSIGN_GENERATION(gv) == PL_generation)
+ return TRUE;
+ GvASSIGN_GENERATION_set(gv, PL_generation);
+ }
+#else
+ GV *const gv
+ = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
+ if (gv) {
+ if (gv == PL_defgv
+ || (int)GvASSIGN_GENERATION(gv) == PL_generation)
+ return TRUE;
+ GvASSIGN_GENERATION_set(gv, PL_generation);
+ }
+#endif
+ }
+ else
+ return TRUE;
+ }
+
+ if (curop->op_flags & OPf_KIDS) {
+ if (aassign_common_vars(curop))
+ return TRUE;
+ }
+ }
+ return FALSE;
+}
+
+/*
=for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
Constructs, checks, and returns an assignment op. I<left> and I<right>
@@ -4605,18 +5509,7 @@
bool maybe_common_vars = TRUE;
PL_modcount = 0;
- /* Grandfathering $[ assignment here. Bletch.*/
- /* Only simple assignments like C<< ($[) = 1 >> are allowed */
- PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
left = op_lvalue(left, OP_AASSIGN);
- if (PL_eval_start)
- PL_eval_start = 0;
- else if (left->op_type == OP_CONST) {
- deprecate("assignment to $[");
- /* FIXME for MAD */
- /* Result of assignment is always 1 (or we'd be dead already) */
- return newSVOP(OP_CONST, 0, newSViv(1));
- }
curop = list(force_list(left));
o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
o->op_private = (U8)(0 | (flags >> 8));
@@ -4695,64 +5588,10 @@
*/
if (maybe_common_vars) {
- OP *lastop = o;
PL_generation++;
- for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
- if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
- if (curop->op_type == OP_GV) {
- GV *gv = cGVOPx_gv(curop);
- if (gv == PL_defgv
- || (int)GvASSIGN_GENERATION(gv) == PL_generation)
- break;
- GvASSIGN_GENERATION_set(gv, PL_generation);
- }
- else if (curop->op_type == OP_PADSV ||
- curop->op_type == OP_PADAV ||
- curop->op_type == OP_PADHV ||
- curop->op_type == OP_PADANY)
- {
- if (PAD_COMPNAME_GEN(curop->op_targ)
- == (STRLEN)PL_generation)
- break;
- PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
-
- }
- else if (curop->op_type == OP_RV2CV)
- break;
- else if (curop->op_type == OP_RV2SV ||
- curop->op_type == OP_RV2AV ||
- curop->op_type == OP_RV2HV ||
- curop->op_type == OP_RV2GV) {
- if (lastop->op_type != OP_GV) /* funny deref? */
- break;
- }
- else if (curop->op_type == OP_PUSHRE) {
-#ifdef USE_ITHREADS
- if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
- GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
- if (gv == PL_defgv
- || (int)GvASSIGN_GENERATION(gv) == PL_generation)
- break;
- GvASSIGN_GENERATION_set(gv, PL_generation);
- }
-#else
- GV *const gv
- = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
- if (gv) {
- if (gv == PL_defgv
- || (int)GvASSIGN_GENERATION(gv) == PL_generation)
- break;
- GvASSIGN_GENERATION_set(gv, PL_generation);
- }
-#endif
- }
- else
- break;
- }
- lastop = curop;
- }
- if (curop != o)
+ if (aassign_common_vars(o))
o->op_private |= OPpASSIGN_COMMON;
+ LINKLIST(o);
}
if (right && right->op_type == OP_SPLIT && !PL_madskills) {
@@ -4780,7 +5619,6 @@
= MUTABLE_GV(cSVOPx(tmpop)->op_sv);
cSVOPx(tmpop)->op_sv = NULL; /* steal it */
#endif
- pm->op_pmflags |= PMf_ONCE;
tmpop = cUNOPo->op_first; /* to list (nulled) */
tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
tmpop->op_sibling = NULL; /* don't free split */
@@ -4812,19 +5650,8 @@
scalar(right));
}
else {
- PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
o = newBINOP(OP_SASSIGN, flags,
scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
- if (PL_eval_start)
- PL_eval_start = 0;
- else {
- if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
- deprecate("assignment to $[");
- op_free(o);
- o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
- o->op_private |= OPpCONST_ARYBASE;
- }
- }
}
return o;
}
@@ -4852,8 +5679,11 @@
{
dVAR;
const U32 seq = intro_my();
- register COP *cop;
+ const U32 utf8 = flags & SVf_UTF8;
+ COP *cop;
+ flags &= ~SVf_UTF8;
+
NewOp(1101, cop, 1, COP);
if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
cop->op_type = OP_DBSTATE;
@@ -4872,14 +5702,11 @@
cop->op_next = (OP*)cop;
cop->cop_seq = seq;
- /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
- CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
- */
cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
if (label) {
- Perl_store_cop_label(aTHX_ cop, label, strlen(label), 0);
-
+ Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
+
PL_hints |= HINT_BLOCK_SCOPE;
/* It seems that we need to defer freeing this pointer, as other parts
of the grammar end up wanting to copy it after this op has been
@@ -4891,8 +5718,7 @@
CopLINE_set(cop, CopLINE(PL_curcop));
else {
CopLINE_set(cop, PL_parser->copline);
- if (PL_parser)
- PL_parser->copline = NOLINE;
+ PL_parser->copline = NOLINE;
}
#ifdef USE_ITHREADS
CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
@@ -5052,6 +5878,8 @@
|| other->op_type == OP_TRANS)
/* Mark the op as being unbindable with =~ */
other->op_flags |= OPf_SPECIAL;
+ else if (other->op_type == OP_CONST)
+ other->op_private |= OPpCONST_FOLDED;
return other;
}
else {
@@ -5106,7 +5934,8 @@
if (k1->op_type == OP_READDIR
|| k1->op_type == OP_GLOB
|| (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
- || k1->op_type == OP_EACH)
+ || k1->op_type == OP_EACH
+ || k1->op_type == OP_AEACH)
{
warnop = ((k1->op_type == OP_NULL)
? (OPCODE)k1->op_targ : k1->op_type);
@@ -5115,6 +5944,8 @@
}
if (warnop) {
const line_t oldline = CopLINE(PL_curcop);
+ /* This ensures that warnings are reported at the first line
+ of the construction, not the last. */
CopLINE_set(PL_curcop, PL_parser->copline);
Perl_warner(aTHX_ packWARN(WARN_MISC),
"Value of %s%s can be \"0\"; test with defined()",
@@ -5208,6 +6039,8 @@
|| live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
/* Mark the op as being unbindable with =~ */
live->op_flags |= OPf_SPECIAL;
+ else if (live->op_type == OP_CONST)
+ live->op_private |= OPpCONST_FOLDED;
return live;
}
NewOp(1101, logop, 1, LOGOP);
@@ -5292,6 +6125,12 @@
flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
+ /* check barewords before they might be optimized aways */
+ if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
+ no_bareword_allowed(left);
+ if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
+ no_bareword_allowed(right);
+
flip->op_next = o;
if (!flip->op_private || !flop->op_private)
LINKLIST(o); /* blow off optimizer unless constant */
@@ -5332,6 +6171,7 @@
if (expr->op_type == OP_READLINE
|| expr->op_type == OP_READDIR
|| expr->op_type == OP_GLOB
+ || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
|| (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
expr = newUNOP(OP_DEFINED, 0,
newASSIGNOP(0, newDEFSVOP(), 0, expr) );
@@ -5350,7 +6190,8 @@
if (k1 && (k1->op_type == OP_READDIR
|| k1->op_type == OP_GLOB
|| (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
- || k1->op_type == OP_EACH))
+ || k1->op_type == OP_EACH
+ || k1->op_type == OP_AEACH))
expr = newUNOP(OP_DEFINED, 0, expr);
break;
}
@@ -5420,6 +6261,7 @@
if (expr->op_type == OP_READLINE
|| expr->op_type == OP_READDIR
|| expr->op_type == OP_GLOB
+ || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
|| (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
expr = newUNOP(OP_DEFINED, 0,
newASSIGNOP(0, newDEFSVOP(), 0, expr) );
@@ -5438,7 +6280,8 @@
if (k1 && (k1->op_type == OP_READDIR
|| k1->op_type == OP_GLOB
|| (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
- || k1->op_type == OP_EACH))
+ || k1->op_type == OP_EACH
+ || k1->op_type == OP_AEACH))
expr = newUNOP(OP_DEFINED, 0, expr);
break;
}
@@ -5470,9 +6313,8 @@
scalar(listop);
o = new_logop(OP_AND, 0, &expr, &listop);
if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
- op_free(expr); /* oops, it's a while (0) */
op_free((OP*)loop);
- return NULL; /* listop already freed by new_logop */
+ return expr; /* listop already freed by new_logop */
}
if (listop)
((LISTOP*)listop)->op_last->op_next =
@@ -5580,7 +6422,7 @@
}
}
else {
- const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
+ const PADOFFSET offset = pad_findmy_pvs("$_", 0);
if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
sv = newGVOP(OP_GV, 0, PL_defgv);
}
@@ -5599,7 +6441,7 @@
{
/* Basically turn for($x..$y) into the same as for($x,$y), but we
* set the STACKED flag to indicate that these values are to be
- * treated as min/max values by 'pp_iterinit'.
+ * treated as min/max values by 'pp_enteriter'.
*/
const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
LOGOP* const range = (LOGOP*) flip->op_first;
@@ -5635,7 +6477,9 @@
/* for my $x () sets OPpLVAL_INTRO;
* for our $x () sets OPpOUR_INTRO */
loop->op_private = (U8)iterpflags;
-#ifdef PL_OP_SLAB_ALLOC
+ if (loop->op_slabbed
+ && DIFF(loop, OpSLOT(loop)->opslot_next)
+ < SIZE_TO_PSIZE(sizeof(LOOP)))
{
LOOP *tmp;
NewOp(1234,tmp,1,LOOP);
@@ -5643,9 +6487,8 @@
S_op_destroy(aTHX_ (OP*)loop);
loop = tmp;
}
-#else
- loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
-#endif
+ else if (!loop->op_slabbed)
+ loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
loop->op_targ = padoff;
wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
if (madsv)
@@ -5659,7 +6502,7 @@
Constructs, checks, and returns a loop-exiting op (such as C<goto>
or C<last>). I<type> is the opcode. I<label> supplies the parameter
determining the target of the op; it is consumed by this function and
-become part of the constructed op tree.
+becomes part of the constructed op tree.
=cut
*/
@@ -5668,26 +6511,17 @@
Perl_newLOOPEX(pTHX_ I32 type, OP *label)
{
dVAR;
- OP *o;
+ OP *o = NULL;
PERL_ARGS_ASSERT_NEWLOOPEX;
assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
- if (type != OP_GOTO || label->op_type == OP_CONST) {
+ if (type != OP_GOTO) {
/* "last()" means "last" */
- if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
+ if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
o = newOP(type, OPf_SPECIAL);
- else {
- o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
- ? SvPV_nolen_const(((SVOP*)label)->op_sv)
- : ""));
}
-#ifdef PERL_MAD
- op_getmad(label,o,'L');
-#else
- op_free(label);
-#endif
}
else {
/* Check whether it's going to be a goto &function */
@@ -5694,8 +6528,30 @@
if (label->op_type == OP_ENTERSUB
&& !(label->op_flags & OPf_STACKED))
label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
- o = newUNOP(type, OPf_STACKED, label);
}
+
+ /* Check for a constant argument */
+ if (label->op_type == OP_CONST) {
+ SV * const sv = ((SVOP *)label)->op_sv;
+ STRLEN l;
+ const char *s = SvPV_const(sv,l);
+ if (l == strlen(s)) {
+ o = newPVOP(type,
+ SvUTF8(((SVOP*)label)->op_sv),
+ savesharedpv(
+ SvPV_nolen_const(((SVOP*)label)->op_sv)));
+ }
+ }
+
+ /* If we have already created an op, we do not need the label. */
+ if (o)
+#ifdef PERL_MAD
+ op_getmad(label,o,'L');
+#else
+ op_free(label);
+#endif
+ else o = newUNOP(type, OPf_STACKED, label);
+
PL_hints |= HINT_BLOCK_SCOPE;
return o;
}
@@ -5771,6 +6627,7 @@
/* This is a default {} block */
enterop->op_first = block;
enterop->op_flags |= OPf_SPECIAL;
+ o ->op_flags |= OPf_SPECIAL;
o->op_next = (OP *) enterop;
}
@@ -5873,7 +6730,7 @@
variable, and I<block> supplies the body of the C<given> construct; they
are consumed by this function and become part of the constructed op tree.
I<defsv_off> is the pad offset of the scalar lexical variable that will
-be affected.
+be affected. If it is 0, the global $_ will be used.
=cut
*/
@@ -5919,39 +6776,55 @@
scalar(ref_array_or_hash(cond)));
}
- return newGIVWHENOP(
- cond_op,
- op_append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
- OP_ENTERWHEN, OP_LEAVEWHEN, 0);
+ return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
}
void
-Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
- const STRLEN len)
+Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
+ const STRLEN len, const U32 flags)
{
- PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
+ const char * const cvp = SvROK(cv) ? "" : CvPROTO(cv);
+ const STRLEN clen = CvPROTOLEN(cv);
- /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
- relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
- if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
- || (p && (len != SvCUR(cv) /* Not the same length. */
- || memNE(p, SvPVX_const(cv), len))))
+ PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
+
+ if (((!p != !cvp) /* One has prototype, one has not. */
+ || (p && (
+ (flags & SVf_UTF8) == SvUTF8(cv)
+ ? len != clen || memNE(cvp, p, len)
+ : flags & SVf_UTF8
+ ? bytes_cmp_utf8((const U8 *)cvp, clen,
+ (const U8 *)p, len)
+ : bytes_cmp_utf8((const U8 *)p, len,
+ (const U8 *)cvp, clen)
+ )
+ )
+ )
&& ckWARN_d(WARN_PROTOTYPE)) {
SV* const msg = sv_newmortal();
SV* name = NULL;
if (gv)
+ {
+ if (isGV(gv))
gv_efullname3(name = sv_newmortal(), gv, NULL);
+ else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
+ name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1,
+ SvUTF8(gv)|SVs_TEMP);
+ else name = (SV *)gv;
+ }
sv_setpvs(msg, "Prototype mismatch:");
if (name)
Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
- if (SvPOK(cv))
- Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
+ if (cvp)
+ Perl_sv_catpvf(aTHX_ msg, " (%"SVf")",
+ SVfARG(newSVpvn_flags(cvp,clen, SvUTF8(cv)|SVs_TEMP))
+ );
else
sv_catpvs(msg, ": none");
sv_catpvs(msg, " vs ");
if (p)
- Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
+ Perl_sv_catpvf(aTHX_ msg, "(%"SVf")", SVfARG(newSVpvn_flags(p, len, flags | SVs_TEMP)));
else
sv_catpvs(msg, "none");
Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
@@ -6002,7 +6875,8 @@
*
* 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. Return the value.
+ * PADSV, ignore it if it has multiple references. In this case we
+ * return a newly created *copy* of the value.
*/
SV *
@@ -6067,43 +6941,431 @@
return sv;
}
+static bool
+S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
+ PADNAME * const name, SV ** const const_svp)
+{
+ assert (cv);
+ assert (o || name);
+ assert (const_svp);
+ if ((!block
#ifdef PERL_MAD
-OP *
-#else
-void
+ || block->op_type == OP_NULL
#endif
+ )) {
+ if (CvFLAGS(PL_compcv)) {
+ /* might have had built-in attrs applied */
+ const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
+ if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
+ && ckWARN(WARN_MISC))
+ {
+ /* protect against fatal warnings leaking compcv */
+ SAVEFREESV(PL_compcv);
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
+ SvREFCNT_inc_simple_void_NN(PL_compcv);
+ }
+ CvFLAGS(cv) |=
+ (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
+ & ~(CVf_LVALUE * pureperl));
+ }
+ return FALSE;
+ }
+
+ /* redundant check for speed: */
+ if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
+ const line_t oldline = CopLINE(PL_curcop);
+ SV *namesv = o
+ ? cSVOPo->op_sv
+ : sv_2mortal(newSVpvn_utf8(
+ PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
+ ));
+ if (PL_parser && PL_parser->copline != NOLINE)
+ /* This ensures that warnings are reported at the first
+ line of a redefinition, not the last. */
+ CopLINE_set(PL_curcop, PL_parser->copline);
+ /* protect against fatal warnings leaking compcv */
+ SAVEFREESV(PL_compcv);
+ report_redefined_cv(namesv, cv, const_svp);
+ SvREFCNT_inc_simple_void_NN(PL_compcv);
+ CopLINE_set(PL_curcop, oldline);
+ }
+#ifdef PERL_MAD
+ if (!PL_minus_c) /* keep old one around for madskills */
+#endif
+ {
+ /* (PL_madskills unset in used file.) */
+ SvREFCNT_dec(cv);
+ }
+ return TRUE;
+}
+
+CV *
Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
{
-#if 0
- /* This would be the return value, but the return cannot be reached. */
- OP* pegop = newOP(OP_NULL, 0);
+ dVAR;
+ CV **spot;
+ SV **svspot;
+ const char *ps;
+ STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
+ U32 ps_utf8 = 0;
+ CV *cv = NULL;
+ CV *compcv = PL_compcv;
+ SV *const_sv;
+ PADNAME *name;
+ PADOFFSET pax = o->op_targ;
+ CV *outcv = CvOUTSIDE(PL_compcv);
+ CV *clonee = NULL;
+ HEK *hek = NULL;
+ bool reusable = FALSE;
+
+ PERL_ARGS_ASSERT_NEWMYSUB;
+
+ /* Find the pad slot for storing the new sub.
+ We cannot use PL_comppad, as it is the pad owned by the new sub. We
+ need to look in CvOUTSIDE and find the pad belonging to the enclos-
+ ing sub. And then we need to dig deeper if this is a lexical from
+ outside, as in:
+ my sub foo; sub { sub foo { } }
+ */
+ redo:
+ name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
+ if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
+ pax = PARENT_PAD_INDEX(name);
+ outcv = CvOUTSIDE(outcv);
+ assert(outcv);
+ goto redo;
+ }
+ svspot =
+ &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
+ [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
+ spot = (CV **)svspot;
+
+ if (proto) {
+ assert(proto->op_type == OP_CONST);
+ ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
+ ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
+ }
+ else
+ ps = NULL;
+
+ if (!PL_madskills) {
+ if (proto)
+ SAVEFREEOP(proto);
+ if (attrs)
+ SAVEFREEOP(attrs);
+ }
+
+ if (PL_parser && PL_parser->error_count) {
+ op_free(block);
+ SvREFCNT_dec(PL_compcv);
+ PL_compcv = 0;
+ goto done;
+ }
+
+ if (CvDEPTH(outcv) && CvCLONE(compcv)) {
+ cv = *spot;
+ svspot = (SV **)(spot = &clonee);
+ }
+ else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
+ cv = *spot;
+ else {
+ MAGIC *mg;
+ SvUPGRADE(name, SVt_PVMG);
+ mg = mg_find(name, PERL_MAGIC_proto);
+ assert (SvTYPE(*spot) == SVt_PVCV);
+ if (CvNAMED(*spot))
+ hek = CvNAME_HEK(*spot);
+ else {
+ CvNAME_HEK_set(*spot, hek =
+ share_hek(
+ PadnamePV(name)+1,
+ PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), 0
+ )
+ );
+ }
+ if (mg) {
+ assert(mg->mg_obj);
+ cv = (CV *)mg->mg_obj;
+ }
+ else {
+ sv_magic(name, &PL_sv_undef, PERL_MAGIC_proto, NULL, 0);
+ mg = mg_find(name, PERL_MAGIC_proto);
+ }
+ spot = (CV **)(svspot = &mg->mg_obj);
+ }
+
+ if (!block || !ps || *ps || attrs
+ || (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS)
+#ifdef PERL_MAD
+ || block->op_type == OP_NULL
#endif
+ )
+ const_sv = NULL;
+ else
+ const_sv = op_const_sv(block, NULL);
- PERL_UNUSED_ARG(floor);
+ if (cv) {
+ const bool exists = CvROOT(cv) || CvXSUB(cv);
- if (o)
- SAVEFREEOP(o);
- if (proto)
- SAVEFREEOP(proto);
- if (attrs)
- SAVEFREEOP(attrs);
- if (block)
- SAVEFREEOP(block);
- Perl_croak(aTHX_ "\"my sub\" not yet implemented");
+ /* if the subroutine doesn't exist and wasn't pre-declared
+ * with a prototype, assume it will be AUTOLOADed,
+ * skipping the prototype check
+ */
+ if (exists || SvPOK(cv))
+ cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8);
+ /* already defined? */
+ if (exists) {
+ if (S_already_defined(aTHX_ cv, block, NULL, name, &const_sv))
+ cv = NULL;
+ else {
+ if (attrs) goto attrs;
+ /* just a "sub foo;" when &foo is already defined */
+ SAVEFREESV(compcv);
+ goto done;
+ }
+ }
+ else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
+ cv = NULL;
+ reusable = TRUE;
+ }
+ }
+ if (const_sv) {
+ SvREFCNT_inc_simple_void_NN(const_sv);
+ if (cv) {
+ assert(!CvROOT(cv) && !CvCONST(cv));
+ cv_forget_slab(cv);
+ }
+ else {
+ cv = MUTABLE_CV(newSV_type(SVt_PVCV));
+ CvFILE_set_from_cop(cv, PL_curcop);
+ CvSTASH_set(cv, PL_curstash);
+ *spot = cv;
+ }
+ sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
+ CvXSUBANY(cv).any_ptr = const_sv;
+ CvXSUB(cv) = const_sv_xsub;
+ CvCONST_on(cv);
+ CvISXSUB_on(cv);
+ if (PL_madskills)
+ goto install_block;
+ op_free(block);
+ SvREFCNT_dec(compcv);
+ PL_compcv = NULL;
+ goto setname;
+ }
+ /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
+ determine whether this sub definition is in the same scope as its
+ declaration. If this sub definition is inside an inner named pack-
+ age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
+ the package sub. So check PadnameOUTER(name) too.
+ */
+ if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
+ assert(!CvWEAKOUTSIDE(compcv));
+ SvREFCNT_dec(CvOUTSIDE(compcv));
+ CvWEAKOUTSIDE_on(compcv);
+ }
+ /* XXX else do we have a circular reference? */
+ if (cv) { /* must reuse cv in case stub is referenced elsewhere */
+ /* transfer PL_compcv to cv */
+ if (block
#ifdef PERL_MAD
- NORETURN_FUNCTION_END;
+ && block->op_type != OP_NULL
#endif
+ ) {
+ cv_flags_t preserved_flags =
+ CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
+ PADLIST *const temp_padl = CvPADLIST(cv);
+ CV *const temp_cv = CvOUTSIDE(cv);
+ const cv_flags_t other_flags =
+ CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
+ OP * const cvstart = CvSTART(cv);
+
+ SvPOK_off(cv);
+ CvFLAGS(cv) =
+ CvFLAGS(compcv) | preserved_flags;
+ CvOUTSIDE(cv) = CvOUTSIDE(compcv);
+ CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
+ CvPADLIST(cv) = CvPADLIST(compcv);
+ CvOUTSIDE(compcv) = temp_cv;
+ CvPADLIST(compcv) = temp_padl;
+ CvSTART(cv) = CvSTART(compcv);
+ CvSTART(compcv) = cvstart;
+ CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
+ CvFLAGS(compcv) |= other_flags;
+
+ if (CvFILE(cv) && CvDYNFILE(cv)) {
+ Safefree(CvFILE(cv));
+ }
+
+ /* inner references to compcv must be fixed up ... */
+ pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
+ if (PERLDB_INTER)/* Advice debugger on the new sub. */
+ ++PL_sub_generation;
+ }
+ else {
+ /* Might have had built-in attributes applied -- propagate them. */
+ CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
+ }
+ /* ... before we throw it away */
+ SvREFCNT_dec(compcv);
+ PL_compcv = compcv = cv;
+ }
+ else {
+ cv = compcv;
+ *spot = cv;
+ }
+ setname:
+ if (!CvNAME_HEK(cv)) {
+ CvNAME_HEK_set(cv,
+ hek
+ ? share_hek_hek(hek)
+ : share_hek(PadnamePV(name)+1,
+ PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1),
+ 0)
+ );
+ }
+ if (const_sv) goto clone;
+
+ CvFILE_set_from_cop(cv, PL_curcop);
+ CvSTASH_set(cv, PL_curstash);
+
+ if (ps) {
+ sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
+ if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
+ }
+
+ install_block:
+ if (!block)
+ goto attrs;
+
+ /* If we assign an optree to a PVCV, then we've defined a subroutine that
+ the debugger could be able to set a breakpoint in, so signal to
+ pp_entereval that it should not throw away any saved lines at scope
+ exit. */
+
+ PL_breakable_sub_gen++;
+ /* This makes sub {}; work as expected. */
+ if (block->op_type == OP_STUB) {
+ OP* const newblock = newSTATEOP(0, NULL, 0);
+#ifdef PERL_MAD
+ op_getmad(block,newblock,'B');
+#else
+ op_free(block);
+#endif
+ block = newblock;
+ }
+ CvROOT(cv) = CvLVALUE(cv)
+ ? newUNOP(OP_LEAVESUBLV, 0,
+ op_lvalue(scalarseq(block), OP_LEAVESUBLV))
+ : newUNOP(OP_LEAVESUB, 0, scalarseq(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));
+ finalize_optree(CvROOT(cv));
+
+ /* now that optimizer has done its work, adjust pad values */
+
+ 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, at attrs>. */
+ apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
+ }
+
+ if (block) {
+ if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
+ SV * const tmpstr = sv_newmortal();
+ GV * const db_postponed = gv_fetchpvs("DB::postponed",
+ GV_ADDMULTI, SVt_PVHV);
+ HV *hv;
+ SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
+ CopFILE(PL_curcop),
+ (long)PL_subline,
+ (long)CopLINE(PL_curcop));
+ if (HvNAME_HEK(PL_curstash)) {
+ sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
+ sv_catpvs(tmpstr, "::");
+ }
+ else sv_setpvs(tmpstr, "__ANON__::");
+ sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
+ PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
+ (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
+ SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
+ hv = GvHVn(db_postponed);
+ if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
+ CV * const pcv = GvCV(db_postponed);
+ if (pcv) {
+ dSP;
+ PUSHMARK(SP);
+ XPUSHs(tmpstr);
+ PUTBACK;
+ call_sv(MUTABLE_SV(pcv), G_DISCARD);
+ }
+ }
+ }
+ }
+
+ clone:
+ if (clonee) {
+ assert(CvDEPTH(outcv));
+ spot = (CV **)
+ &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
+ if (reusable) cv_clone_into(clonee, *spot);
+ else *spot = cv_clone(clonee);
+ SvREFCNT_dec_NN(clonee);
+ cv = *spot;
+ SvPADMY_on(cv);
+ }
+ if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
+ PADOFFSET depth = CvDEPTH(outcv);
+ while (--depth) {
+ SV *oldcv;
+ svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
+ oldcv = *svspot;
+ *svspot = SvREFCNT_inc_simple_NN(cv);
+ SvREFCNT_dec(oldcv);
+ }
+ }
+
+ done:
+ if (PL_parser)
+ PL_parser->copline = NOLINE;
+ LEAVE_SCOPE(floor);
+ if (o) op_free(o);
+ return cv;
}
CV *
Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
{
+ return newATTRSUB_flags(floor, o, proto, attrs, block, 0);
+}
+
+CV *
+Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
+ OP *block, U32 flags)
+{
dVAR;
GV *gv;
const char *ps;
STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
- register CV *cv = NULL;
+ U32 ps_utf8 = 0;
+ CV *cv = NULL;
SV *const_sv;
+ const bool ec = PL_parser && PL_parser->error_count;
/* If the subroutine has no body, no attributes, and no builtin attributes
then it's just a sub declaration, and we may be able to get away with
storing with a placeholder scalar in the symbol table, rather than a
@@ -6110,20 +7372,33 @@
full GV and CV. If anything is present then it will take a full CV to
store it. */
const I32 gv_fetch_flags
- = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
+ = ec ? GV_NOADD_NOINIT :
+ (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
|| PL_madskills)
? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
- const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
+ STRLEN namlen = 0;
+ const bool o_is_gv = flags & 1;
+ const char * const name =
+ 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);
+#ifdef PERL_DEBUG_READONLY_OPS
+ OPSLAB *slab = NULL;
+#endif
if (proto) {
assert(proto->op_type == OP_CONST);
ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
+ ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
}
else
ps = NULL;
- if (name) {
+ if (o_is_gv) {
+ gv = (GV*)o;
+ o = NULL;
+ has_name = TRUE;
+ } else if (name) {
gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
has_name = TRUE;
} else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
@@ -6150,18 +7425,39 @@
SAVEFREEOP(attrs);
}
+ if (ec) {
+ op_free(block);
+ if (name) SvREFCNT_dec(PL_compcv);
+ else cv = PL_compcv;
+ PL_compcv = 0;
+ if (name && block) {
+ const char *s = strrchr(name, ':');
+ s = s ? s+1 : name;
+ if (strEQ(s, "BEGIN")) {
+ if (PL_in_eval & EVAL_KEEPERR)
+ Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
+ else {
+ SV * const errsv = ERRSV;
+ /* force display of errors found but not reported */
+ sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
+ Perl_croak_nocontext("%"SVf, SVfARG(errsv));
+ }
+ }
+ }
+ goto done;
+ }
+
if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
maximum a prototype before. */
if (SvTYPE(gv) > SVt_NULL) {
- if (!SvPOK((const SV *)gv)
- && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
- {
- Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
- }
- cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
+ cv_ckproto_len_flags((const CV *)gv,
+ o ? (const GV *)cSVOPo->op_sv : NULL, ps,
+ ps_len, ps_utf8);
}
- if (ps)
+ if (ps) {
sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
+ if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
+ }
else
sv_setiv(MUTABLE_SV(gv), -1);
@@ -6190,50 +7486,17 @@
* skipping the prototype check
*/
if (exists || SvPOK(cv))
- cv_ckproto_len(cv, gv, ps, ps_len);
+ cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
/* already defined (or promised)? */
if (exists || GvASSUMECV(gv)) {
- if ((!block
-#ifdef PERL_MAD
- || block->op_type == OP_NULL
-#endif
- )&& !attrs) {
- if (CvFLAGS(PL_compcv)) {
- /* might have had built-in attrs applied */
- if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && ckWARN(WARN_MISC))
- Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
- CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS & ~CVf_LVALUE);
- }
+ if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
+ cv = NULL;
+ else {
+ if (attrs) goto attrs;
/* just a "sub foo;" when &foo is already defined */
SAVEFREESV(PL_compcv);
goto done;
}
- if (block
-#ifdef PERL_MAD
- && block->op_type != OP_NULL
-#endif
- ) {
- if (ckWARN(WARN_REDEFINE)
- || (CvCONST(cv)
- && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
- {
- const line_t oldline = CopLINE(PL_curcop);
- if (PL_parser && PL_parser->copline != NOLINE)
- CopLINE_set(PL_curcop, PL_parser->copline);
- Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
- CvCONST(cv) ? "Constant subroutine %s redefined"
- : "Subroutine %s redefined", name);
- CopLINE_set(PL_curcop, oldline);
- }
-#ifdef PERL_MAD
- if (!PL_minus_c) /* keep old one around for madskills */
-#endif
- {
- /* (PL_madskills unset in used file.) */
- SvREFCNT_dec(cv);
- }
- cv = NULL;
- }
}
}
if (const_sv) {
@@ -6240,6 +7503,7 @@
SvREFCNT_inc_simple_void_NN(const_sv);
if (cv) {
assert(!CvROOT(cv) && !CvCONST(cv));
+ cv_forget_slab(cv);
sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
CvXSUBANY(cv).any_ptr = const_sv;
CvXSUB(cv) = const_sv_xsub;
@@ -6248,15 +7512,11 @@
}
else {
GvCV_set(gv, NULL);
- cv = newCONSTSUB(NULL, name, const_sv);
+ cv = newCONSTSUB_flags(
+ NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
+ const_sv
+ );
}
- mro_method_changed_in( /* sub Foo::Bar () { 123 } */
- (CvGV(cv) && GvSTASH(CvGV(cv)))
- ? GvSTASH(CvGV(cv))
- : CvSTASH(cv)
- ? CvSTASH(cv)
- : PL_curstash
- );
if (PL_madskills)
goto install_block;
op_free(block);
@@ -6272,10 +7532,13 @@
#endif
) {
cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
- AV *const temp_av = CvPADLIST(cv);
+ PADLIST *const temp_av = CvPADLIST(cv);
CV *const temp_cv = CvOUTSIDE(cv);
+ const cv_flags_t other_flags =
+ CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
+ OP * const cvstart = CvSTART(cv);
- assert(!CvWEAKOUTSIDE(cv));
+ CvGV_set(cv,gv);
assert(!CvCVGV_RC(cv));
assert(CvGV(cv) == gv);
@@ -6286,13 +7549,14 @@
CvPADLIST(cv) = CvPADLIST(PL_compcv);
CvOUTSIDE(PL_compcv) = temp_cv;
CvPADLIST(PL_compcv) = temp_av;
+ CvSTART(cv) = CvSTART(PL_compcv);
+ CvSTART(PL_compcv) = cvstart;
+ CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
+ CvFLAGS(PL_compcv) |= other_flags;
-#ifdef USE_ITHREADS
- if (CvFILE(cv) && !CvISXSUB(cv)) {
- /* for XSUBs CvFILE point directly to static memory; __FILE__ */
+ if (CvFILE(cv) && CvDYNFILE(cv)) {
Safefree(CvFILE(cv));
}
-#endif
CvFILE_set_from_cop(cv, PL_curcop);
CvSTASH_set(cv, PL_curstash);
@@ -6313,15 +7577,10 @@
cv = PL_compcv;
if (name) {
GvCV_set(gv, cv);
- if (PL_madskills) {
- if (strEQ(name, "import")) {
- PL_formfeed = MUTABLE_SV(cv);
- /* diag_listed_as: SKIPME */
- Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
- }
- }
GvCVGEN(gv) = 0;
- mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
+ if (HvENAME_HEK(GvSTASH(gv)))
+ /* sub Foo::bar { (shift)+1 } */
+ gv_method_changed(gv);
}
}
if (!CvGV(cv)) {
@@ -6329,37 +7588,15 @@
CvFILE_set_from_cop(cv, PL_curcop);
CvSTASH_set(cv, PL_curstash);
}
- if (attrs) {
- /* Need to do a C<use attributes $stash_of_cv,\&cv, at attrs>. */
- HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
- apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
- }
- if (ps)
+ if (ps) {
sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
+ if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
+ }
- if (PL_parser && PL_parser->error_count) {
- op_free(block);
- block = NULL;
- if (name) {
- const char *s = strrchr(name, ':');
- s = s ? s+1 : name;
- if (strEQ(s, "BEGIN")) {
- const char not_safe[] =
- "BEGIN not safe after errors--compilation aborted";
- if (PL_in_eval & EVAL_KEEPERR)
- Perl_croak(aTHX_ not_safe);
- else {
- /* force display of errors found but not reported */
- sv_catpv(ERRSV, not_safe);
- Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
- }
- }
- }
- }
install_block:
if (!block)
- goto done;
+ goto attrs;
/* If we assign an optree to a PVCV, then we've defined a subroutine that
the debugger could be able to set a breakpoint in, so signal to
@@ -6367,14 +7604,8 @@
exit. */
PL_breakable_sub_gen++;
- if (CvLVALUE(cv)) {
- CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
- op_lvalue(scalarseq(block), OP_LEAVESUBLV));
- block->op_attached = 1;
- }
- else {
- /* This makes sub {}; work as expected. */
- if (block->op_type == OP_STUB) {
+ /* This makes sub {}; work as expected. */
+ if (block->op_type == OP_STUB) {
OP* const newblock = newSTATEOP(0, NULL, 0);
#ifdef PERL_MAD
op_getmad(block,newblock,'B');
@@ -6382,16 +7613,24 @@
op_free(block);
#endif
block = newblock;
- }
- else
- block->op_attached = 1;
- CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
}
+ CvROOT(cv) = CvLVALUE(cv)
+ ? newUNOP(OP_LEAVESUBLV, 0,
+ op_lvalue(scalarseq(block), OP_LEAVESUBLV))
+ : newUNOP(OP_LEAVESUB, 0, scalarseq(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));
+#ifdef PERL_DEBUG_READONLY_OPS
+ slab = (OPSLAB *)CvSTART(cv);
+#endif
CvSTART(cv) = LINKLIST(CvROOT(cv));
CvROOT(cv)->op_next = 0;
CALL_PEEP(CvSTART(cv));
+ finalize_optree(CvROOT(cv));
/* now that optimizer has done its work, adjust pad values */
@@ -6403,7 +7642,16 @@
CvCONST_on(cv);
}
- if (has_name) {
+ attrs:
+ if (attrs) {
+ /* Need to do a C<use attributes $stash_of_cv,\&cv, at attrs>. */
+ HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
+ if (!name) SAVEFREESV(cv);
+ apply_attrs(stash, MUTABLE_SV(cv), attrs);
+ if (!name) SvREFCNT_inc_simple_void_NN(cv);
+ }
+
+ if (block && has_name) {
if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
SV * const tmpstr = sv_newmortal();
GV * const db_postponed = gv_fetchpvs("DB::postponed",
@@ -6415,9 +7663,9 @@
(long)CopLINE(PL_curcop));
gv_efullname3(tmpstr, gv, NULL);
(void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
- SvCUR(tmpstr), sv, 0);
+ SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
hv = GvHVn(db_postponed);
- if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
+ if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
CV * const pcv = GvCV(db_postponed);
if (pcv) {
dSP;
@@ -6430,7 +7678,7 @@
}
if (name && ! (PL_parser && PL_parser->error_count))
- process_special_blocks(name, gv, cv);
+ process_special_blocks(floor, name, gv, cv);
}
done:
@@ -6437,11 +7685,16 @@
if (PL_parser)
PL_parser->copline = NOLINE;
LEAVE_SCOPE(floor);
+#ifdef PERL_DEBUG_READONLY_OPS
+ /* Watch out for BEGIN blocks */
+ if (slab && gv && isGV(gv) && GvCV(gv)) Slab_to_ro(slab);
+#endif
return cv;
}
STATIC void
-S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
+S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
+ GV *const gv,
CV *const cv)
{
const char *const colon = strrchr(fullname,':');
@@ -6452,9 +7705,11 @@
if (*name == 'B') {
if (strEQ(name, "BEGIN")) {
const I32 oldscope = PL_scopestack_ix;
+ if (floor) LEAVE_SCOPE(floor);
ENTER;
SAVECOPFILE(&PL_compiling);
SAVECOPLINE(&PL_compiling);
+ SAVEVPTR(PL_curcop);
DEBUG_x( dump_sub(gv) );
Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
@@ -6461,7 +7716,6 @@
GvCV_set(gv,0); /* cv has been hijacked */
call_list(oldscope, PL_beginav);
- PL_curcop = &PL_compiling;
CopHINTS_set(&PL_compiling, PL_hints);
LEAVE;
}
@@ -6484,6 +7738,7 @@
} else if (*name == 'C') {
if (strEQ(name, "CHECK")) {
if (PL_main_start)
+ /* diag_listed_as: Too late to run %s block */
Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
"Too late to run CHECK block");
Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
@@ -6493,6 +7748,7 @@
} else if (*name == 'I') {
if (strEQ(name, "INIT")) {
if (PL_main_start)
+ /* diag_listed_as: Too late to run %s block */
Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
"Too late to run INIT block");
Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
@@ -6509,9 +7765,28 @@
/*
=for apidoc newCONSTSUB
+See L</newCONSTSUB_flags>.
+
+=cut
+*/
+
+CV *
+Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
+{
+ return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
+}
+
+/*
+=for apidoc newCONSTSUB_flags
+
Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
eligible for inlining at compile-time.
+Currently, the only useful value for C<flags> is SVf_UTF8.
+
+The newly created subroutine takes ownership of a reference to the passed in
+SV.
+
Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
which won't be called if used as a destructor, but will suppress the overhead
of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
@@ -6521,7 +7796,8 @@
*/
CV *
-Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
+Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
+ U32 flags, SV *sv)
{
dVAR;
CV* cv;
@@ -6539,6 +7815,8 @@
* an op shared between threads. Use a non-shared COP for our
* dirty work */
SAVEVPTR(PL_curcop);
+ SAVECOMPILEWARNINGS();
+ PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
PL_curcop = &PL_compiling;
}
SAVECOPLINE(PL_curcop);
@@ -6548,25 +7826,22 @@
PL_hints &= ~HINT_BLOCK_SCOPE;
if (stash) {
- SAVESPTR(PL_curstash);
- SAVECOPSTASH(PL_curcop);
- PL_curstash = stash;
- CopSTASH_set(PL_curcop,stash);
+ SAVEGENERICSV(PL_curstash);
+ PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
}
- /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
+ /* Protect sv against leakage caused by fatal warnings. */
+ if (sv) SAVEFREESV(sv);
+
+ /* file becomes the CvFILE. For an XS, it's usually static storage,
and so doesn't get free()d. (It's expected to be from the C pre-
processor __FILE__ directive). But we need a dynamically allocated one,
and we need it to get freed. */
- cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
- XS_DYNAMIC_FILENAME);
- CvXSUBANY(cv).any_ptr = sv;
+ cv = newXS_len_flags(name, len, const_sv_xsub, file ? file : "", "",
+ &sv, XS_DYNAMIC_FILENAME | flags);
+ CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
CvCONST_on(cv);
-#ifdef USE_ITHREADS
- if (stash)
- CopSTASH_free(PL_curcop);
-#endif
LEAVE;
return cv;
@@ -6577,48 +7852,103 @@
const char *const filename, const char *const proto,
U32 flags)
{
- CV *cv = newXS(name, subaddr, filename);
-
PERL_ARGS_ASSERT_NEWXS_FLAGS;
+ return newXS_len_flags(
+ name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
+ );
+}
- if (flags & XS_DYNAMIC_FILENAME) {
- /* We need to "make arrangements" (ie cheat) to ensure that the
- filename lasts as long as the PVCV we just created, but also doesn't
- leak */
- STRLEN filename_len = strlen(filename);
- STRLEN proto_and_file_len = filename_len;
- char *proto_and_file;
- STRLEN proto_len;
+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)
+{
+ CV *cv;
- if (proto) {
- proto_len = strlen(proto);
- proto_and_file_len += proto_len;
+ PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
- Newx(proto_and_file, proto_and_file_len + 1, char);
- Copy(proto, proto_and_file, proto_len, char);
- Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
- } else {
- proto_len = 0;
- proto_and_file = savepvn(filename, filename_len);
- }
+ {
+ 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 */
+ SvREFCNT_dec(cv);
+ cv = NULL;
+ }
+ else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
+ /* already defined (or promised) */
+ /* Redundant check that allows us to avoid creating an SV
+ most of the time: */
+ if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
+ report_redefined_cv(newSVpvn_flags(
+ name,len,(flags&SVf_UTF8)|SVs_TEMP
+ ),
+ cv, const_svp);
+ }
+ SvREFCNT_dec_NN(cv);
+ cv = NULL;
+ }
+ }
+
+ if (cv) /* must reuse cv if autoloaded */
+ cv_undef(cv);
+ else {
+ cv = MUTABLE_CV(newSV_type(SVt_PVCV));
+ if (name) {
+ GvCV_set(gv,cv);
+ GvCVGEN(gv) = 0;
+ if (HvENAME_HEK(GvSTASH(gv)))
+ 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 */
+ CvISXSUB_on(cv);
+ CvXSUB(cv) = subaddr;
+
+ if (name)
+ process_special_blocks(0, name, gv, cv);
+ }
- /* This gets free()d. :-) */
- sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
- SV_HAS_TRAILING_NUL);
- if (proto) {
- /* This gives us the correct prototype, rather than one with the
- file name appended. */
- SvCUR_set(cv, proto_len);
- } else {
- SvPOK_off(cv);
- }
- CvFILE(cv) = proto_and_file + proto_len;
- } else {
- sv_setpv(MUTABLE_SV(cv), proto);
+ if (flags & XS_DYNAMIC_FILENAME) {
+ CvFILE(cv) = savepv(filename);
+ CvDYNFILE_on(cv);
}
+ sv_setpv(MUTABLE_SV(cv), proto);
return cv;
}
+CV *
+Perl_newSTUB(pTHX_ GV *gv, bool fake)
+{
+ CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
+ PERL_ARGS_ASSERT_NEWSTUB;
+ assert(!GvCVu(gv));
+ GvCV_set(gv, cv);
+ GvCVGEN(gv) = 0;
+ if (!fake && HvENAME_HEK(GvSTASH(gv)))
+ gv_method_changed(gv);
+ CvGV_set(cv, gv);
+ CvFILE_set_from_cop(cv, PL_curcop);
+ CvSTASH_set(cv, PL_curstash);
+ GvMULTI_on(gv);
+ return cv;
+}
+
/*
=for apidoc U||newXS
@@ -6631,73 +7961,10 @@
CV *
Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
{
- dVAR;
- GV * const gv = gv_fetchpv(name ? name :
- (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
- GV_ADDMULTI, SVt_PVCV);
- register CV *cv;
-
PERL_ARGS_ASSERT_NEWXS;
-
- 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 */
- SvREFCNT_dec(cv);
- cv = NULL;
- }
- else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
- /* already defined (or promised) */
- /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
- if (ckWARN(WARN_REDEFINE)) {
- GV * const gvcv = CvGV(cv);
- if (gvcv) {
- HV * const stash = GvSTASH(gvcv);
- if (stash) {
- const char *redefined_name = HvNAME_get(stash);
- if ( strEQ(redefined_name,"autouse") ) {
- const line_t oldline = CopLINE(PL_curcop);
- if (PL_parser && PL_parser->copline != NOLINE)
- CopLINE_set(PL_curcop, PL_parser->copline);
- Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
- CvCONST(cv) ? "Constant subroutine %s redefined"
- : "Subroutine %s redefined"
- ,name);
- CopLINE_set(PL_curcop, oldline);
- }
- }
- }
- }
- SvREFCNT_dec(cv);
- cv = NULL;
- }
- }
-
- if (cv) /* must reuse cv if autoloaded */
- cv_undef(cv);
- else {
- cv = MUTABLE_CV(newSV_type(SVt_PVCV));
- if (name) {
- GvCV_set(gv,cv);
- GvCVGEN(gv) = 0;
- mro_method_changed_in(GvSTASH(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 */
- CvISXSUB_on(cv);
- CvXSUB(cv) = subaddr;
-
- if (name)
- process_special_blocks(name, gv, cv);
-
- return cv;
+ return newXS_len_flags(
+ name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
+ );
}
#ifdef PERL_MAD
@@ -6708,12 +7975,19 @@
Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
{
dVAR;
- register CV *cv;
+ CV *cv;
#ifdef PERL_MAD
OP* pegop = newOP(OP_NULL, 0);
#endif
- GV * const gv = o
+ GV *gv;
+
+ if (PL_parser && PL_parser->error_count) {
+ op_free(block);
+ goto finish;
+ }
+
+ gv = o
? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
: gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
@@ -6727,6 +8001,7 @@
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
"Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
} else {
+ /* diag_listed_as: Format %s redefined */
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
"Format STDOUT redefined");
}
@@ -6735,7 +8010,7 @@
SvREFCNT_dec(cv);
}
cv = PL_compcv;
- GvFORM(gv) = cv;
+ GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
CvGV_set(cv, gv);
CvFILE_set_from_cop(cv, PL_curcop);
@@ -6747,6 +8022,10 @@
CvSTART(cv) = LINKLIST(CvROOT(cv));
CvROOT(cv)->op_next = 0;
CALL_PEEP(CvSTART(cv));
+ finalize_optree(CvROOT(cv));
+ cv_forget_slab(cv);
+
+ finish:
#ifdef PERL_MAD
op_getmad(o,pegop,'n');
op_getmad_weak(block, pegop, 'b');
@@ -6890,6 +8169,11 @@
OP *
Perl_newCVREF(pTHX_ I32 flags, OP *o)
{
+ if (o->op_type == OP_PADANY) {
+ dVAR;
+ o->op_type = OP_PADCV;
+ o->op_ppaddr = PL_ppaddr[OP_PADCV];
+ }
return newUNOP(OP_RV2CV, flags, scalar(o));
}
@@ -6916,7 +8200,7 @@
{
PERL_ARGS_ASSERT_CK_ANONCODE;
- cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
+ cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
if (!PL_madskills)
cSVOPo->op_sv = NULL;
return o;
@@ -6929,14 +8213,6 @@
PERL_ARGS_ASSERT_CK_BITOP;
-#define OP_IS_NUMCOMPARE(op) \
- ((op) == OP_LT || (op) == OP_I_LT || \
- (op) == OP_GT || (op) == OP_I_GT || \
- (op) == OP_LE || (op) == OP_I_LE || \
- (op) == OP_GE || (op) == OP_I_GE || \
- (op) == OP_EQ || (op) == OP_I_EQ || \
- (op) == OP_NE || (op) == OP_I_NE || \
- (op) == OP_NCMP || (op) == OP_I_NCMP)
o->op_private = (U8)(PL_hints & HINT_INTEGER);
if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
&& (o->op_type == OP_BIT_OR
@@ -6958,7 +8234,37 @@
return o;
}
+PERL_STATIC_INLINE bool
+is_dollar_bracket(pTHX_ const OP * const o)
+{
+ const OP *kid;
+ return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
+ && (kid = cUNOPx(o)->op_first)
+ && kid->op_type == OP_GV
+ && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
+}
+
OP *
+Perl_ck_cmp(pTHX_ OP *o)
+{
+ PERL_ARGS_ASSERT_CK_CMP;
+ if (ckWARN(WARN_SYNTAX)) {
+ const OP *kid = cUNOPo->op_first;
+ if (kid && (
+ (
+ is_dollar_bracket(aTHX_ kid)
+ && kid->op_sibling && kid->op_sibling->op_type == OP_CONST
+ )
+ || ( kid->op_type == OP_CONST
+ && (kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid))
+ ))
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "$[ used in %s (did you mean $] ?)", OP_DESC(o));
+ }
+ return o;
+}
+
+OP *
Perl_ck_concat(pTHX_ OP *o)
{
const OP * const kid = cUNOPo->op_first;
@@ -7000,6 +8306,8 @@
#endif
kUNOP->op_first = newop;
}
+ /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
+ * and OP_CHOMP into OP_SCHOMP */
o->op_ppaddr = PL_ppaddr[++o->op_type];
return ck_fun(o);
}
@@ -7055,6 +8363,7 @@
PERL_ARGS_ASSERT_CK_EOF;
if (o->op_flags & OPf_KIDS) {
+ OP *kid;
if (cLISTOPo->op_first->op_type == OP_STUB) {
OP * const newop
= newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
@@ -7065,7 +8374,10 @@
#endif
o = newop;
}
- return ck_fun(o);
+ o = ck_fun(o);
+ kid = cLISTOPo->op_first;
+ if (kid->op_type == OP_RV2GV)
+ kid->op_private |= OPpALLOW_FAKE;
}
return o;
}
@@ -7117,16 +8429,19 @@
}
}
else {
+ const U8 priv = o->op_private;
#ifdef PERL_MAD
OP* const oldo = o;
#else
op_free(o);
#endif
- o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
+ o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
op_getmad(oldo,o,'O');
}
o->op_targ = (PADOFFSET)PL_hints;
- if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
+ if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
+ if ((PL_hints & HINT_LOCALIZE_HH) != 0
+ && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
/* Store a copy of %^H that pp_entereval can pick up. */
OP *hhop = newSVOP(OP_HINTSEVAL, 0,
MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
@@ -7133,6 +8448,9 @@
cUNOPo->op_first->op_sibling = hhop;
o->op_private |= OPpEVAL_HAS_HH;
}
+ if (!(o->op_private & OPpEVAL_BYTES)
+ && FEATURE_UNIEVAL_IS_ENABLED)
+ o->op_private |= OPpEVAL_UNICODE;
return o;
}
@@ -7199,7 +8517,7 @@
}
OP *
-Perl_ck_rvconst(pTHX_ register OP *o)
+Perl_ck_rvconst(pTHX_ OP *o)
{
dVAR;
SVOP * const kid = (SVOP*)cUNOPo->op_first;
@@ -7322,7 +8640,8 @@
SVOP * const kid = (SVOP*)cUNOPo->op_first;
const OPCODE kidtype = kid->op_type;
- if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
+ if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
+ && !(kid->op_private & OPpCONST_FOLDED)) {
OP * const newop = newGVOP(type, OPf_REF,
gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
#ifdef PERL_MAD
@@ -7335,8 +8654,15 @@
if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
o->op_private |= OPpFT_ACCESS;
if (PL_check[kidtype] == Perl_ck_ftst
- && kidtype != OP_STAT && kidtype != OP_LSTAT)
+ && kidtype != OP_STAT && kidtype != OP_LSTAT) {
o->op_private |= OPpFT_STACKED;
+ kid->op_private |= OPpFT_STACKING;
+ if (kidtype == OP_FTTTY && (
+ !(kid->op_private & OPpFT_STACKED)
+ || kid->op_private & OPpFT_AFTER_t
+ ))
+ o->op_private |= OPpFT_AFTER_t;
+ }
}
else {
#ifdef PERL_MAD
@@ -7358,7 +8684,7 @@
{
dVAR;
const int type = o->op_type;
- register I32 oa = PL_opargs[type] >> OASHIFT;
+ I32 oa = PL_opargs[type] >> OASHIFT;
PERL_ARGS_ASSERT_CK_FUN;
@@ -7371,9 +8697,10 @@
if (o->op_flags & OPf_KIDS) {
OP **tokid = &cLISTOPo->op_first;
- register OP *kid = cLISTOPo->op_first;
+ OP *kid = cLISTOPo->op_first;
OP *sibl;
I32 numargs = 0;
+ bool seen_optional = FALSE;
if (kid->op_type == OP_PUSHMARK ||
(kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
@@ -7381,10 +8708,25 @@
tokid = &kid->op_sibling;
kid = kid->op_sibling;
}
- if (!kid && PL_opargs[type] & OA_DEFGV)
- *tokid = kid = newDEFSVOP();
+ if (kid && kid->op_type == OP_COREARGS) {
+ bool optional = FALSE;
+ while (oa) {
+ numargs++;
+ if (oa & OA_OPTIONAL) optional = TRUE;
+ oa = oa >> 4;
+ }
+ if (optional) o->op_private |= numargs;
+ return o;
+ }
- while (oa && kid) {
+ while (oa) {
+ if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
+ if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
+ *tokid = kid = newDEFSVOP();
+ seen_optional = TRUE;
+ }
+ if (!kid) break;
+
numargs++;
sibl = kid->op_sibling;
#ifdef PERL_MAD
@@ -7399,7 +8741,7 @@
if (numargs == 1 && !(oa >> 4)
&& kid->op_type == OP_LIST && type != OP_SCALAR)
{
- return too_many_arguments(o,PL_op_desc[type]);
+ return too_many_arguments_pv(o,PL_op_desc[type], 0);
}
scalar(kid);
break;
@@ -7439,7 +8781,7 @@
&& ( !SvROK(cSVOPx_sv(kid))
|| SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
)
- bad_type(numargs, "array", PL_op_desc[type], kid);
+ bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
/* Defer checks to run-time if we have a scalar arg */
if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
op_lvalue(kid, type);
@@ -7464,7 +8806,7 @@
*tokid = kid;
}
else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
- bad_type(numargs, "hash", PL_op_desc[type], kid);
+ bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
op_lvalue(kid, type);
break;
case OA_CVREF:
@@ -7471,7 +8813,6 @@
{
OP * const newop = newUNOP(OP_NULL, 0, kid);
kid->op_sibling = 0;
- LINKLIST(kid);
newop->op_next = newop;
kid = newop;
kid->op_sibling = sibl;
@@ -7497,7 +8838,7 @@
}
else if (kid->op_type == OP_READLINE) {
/* neophyte patrol: open(<FH>), close(<FH>) etc. */
- bad_type(numargs, "HANDLE", OP_DESC(o), kid);
+ bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
}
else {
I32 flags = OPf_SPECIAL;
@@ -7508,6 +8849,8 @@
if (is_handle_constructor(o,numargs)) {
const char *name = NULL;
STRLEN len = 0;
+ U32 name_utf8 = 0;
+ bool want_dollar = TRUE;
flags = 0;
/* Set a flag to tell rv2gv to vivify
@@ -7519,6 +8862,7 @@
SV *const namesv
= PAD_COMPNAME_SV(kid->op_targ);
name = SvPV_const(namesv, len);
+ name_utf8 = SvUTF8(namesv);
}
else if (kid->op_type == OP_RV2SV
&& kUNOP->op_first->op_type == OP_GV)
@@ -7526,6 +8870,7 @@
GV * const gv = cGVOPx_gv(kUNOP->op_first);
name = GvNAME(gv);
len = GvNAMELEN(gv);
+ name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
}
else if (kid->op_type == OP_AELEM
|| kid->op_type == OP_HELEM)
@@ -7565,6 +8910,7 @@
}
if (tmpstr) {
name = SvPV_const(tmpstr, len);
+ name_utf8 = SvUTF8(tmpstr);
sv_2mortal(tmpstr);
}
}
@@ -7571,6 +8917,7 @@
if (!name) {
name = "__ANONIO__";
len = 10;
+ want_dollar = FALSE;
}
op_lvalue(kid, type);
}
@@ -7579,9 +8926,10 @@
targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
namesv = PAD_SVl(targ);
SvUPGRADE(namesv, SVt_PV);
- if (*name != '$')
+ if (want_dollar && *name != '$')
sv_setpvs(namesv, "$");
sv_catpvn(namesv, name, len);
+ if ( name_utf8 ) SvUTF8_on(namesv);
}
}
kid->op_sibling = 0;
@@ -7595,6 +8943,10 @@
scalar(kid);
break;
case OA_SCALARREF:
+ if ((type == OP_UNDEF || type == OP_POS)
+ && numargs == 1 && !(oa >> 4)
+ && kid->op_type == OP_LIST)
+ return too_many_arguments_pv(o,PL_op_desc[type], 0);
op_lvalue(scalar(kid), type);
break;
}
@@ -7604,13 +8956,13 @@
}
#ifdef PERL_MAD
if (kid && kid->op_type != OP_STUB)
- return too_many_arguments(o,OP_DESC(o));
+ return too_many_arguments_pv(o,OP_DESC(o), 0);
o->op_private |= numargs;
#else
/* FIXME - should the numargs move as for the PERL_MAD case? */
o->op_private |= numargs;
if (kid)
- return too_many_arguments(o,OP_DESC(o));
+ return too_many_arguments_pv(o,OP_DESC(o), 0);
#endif
listkids(o);
}
@@ -7630,7 +8982,7 @@
while (oa & OA_OPTIONAL)
oa >>= 4;
if (oa && oa != OA_LIST)
- return too_few_arguments(o,OP_DESC(o));
+ return too_few_arguments_pv(o,OP_DESC(o), 0);
}
return o;
}
@@ -7640,6 +8992,7 @@
{
dVAR;
GV *gv;
+ const bool core = o->op_flags & OPf_SPECIAL;
PERL_ARGS_ASSERT_CK_GLOB;
@@ -7647,30 +9000,15 @@
if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
- if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
+ if (core) gv = NULL;
+ else if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
&& GvCVu(gv) && GvIMPORTED_CV(gv)))
{
- gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
+ GV * const * const gvp =
+ (GV **)hv_fetchs(PL_globalstash, "glob", FALSE);
+ gv = gvp ? *gvp : NULL;
}
-#if !defined(PERL_EXTERNAL_GLOB)
- /* XXX this can be tightened up and made more failsafe. */
- if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
- GV *glob_gv;
- ENTER;
- Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
- newSVpvs("File::Glob"), NULL, NULL, NULL);
- if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
- gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
- GvCV_set(gv, GvCV(glob_gv));
- SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
- GvIMPORTED_CV_on(gv);
- }
- LEAVE;
- }
-#endif /* PERL_EXTERNAL_GLOB */
-
- assert(!(o->op_flags & OPf_SPECIAL));
if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
/* convert
* glob
@@ -7682,24 +9020,33 @@
* \ mark - glob - rv2cv
* | \ gv(CORE::GLOBAL::glob)
* |
- * \ null - const(wildcard) - const(ix)
+ * \ null - const(wildcard)
*/
o->op_flags |= OPf_SPECIAL;
o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
- op_append_elem(OP_GLOB, o,
- newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
o = newLISTOP(OP_LIST, 0, o, NULL);
o = newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST, o,
scalar(newUNOP(OP_RV2CV, 0,
newGVOP(OP_GV, 0, gv)))));
- o = newUNOP(OP_NULL, 0, ck_subr(o));
+ o = newUNOP(OP_NULL, 0, o);
o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
return o;
}
- gv = newGVgen("main");
+ else o->op_flags &= ~OPf_SPECIAL;
+#if !defined(PERL_EXTERNAL_GLOB)
+ if (!PL_globhook) {
+ ENTER;
+ Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
+ newSVpvs("File::Glob"), NULL, NULL, NULL);
+ LEAVE;
+ }
+#endif /* !PERL_EXTERNAL_GLOB */
+ gv = (GV *)newSV(0);
+ gv_init(gv, 0, "", 0, 0);
gv_IOadd(gv);
op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
+ SvREFCNT_dec_NN(gv); /* newGVOP increased it */
scalarkids(o);
return o;
}
@@ -7708,7 +9055,7 @@
Perl_ck_grep(pTHX_ OP *o)
{
dVAR;
- LOGOP *gwop = NULL;
+ LOGOP *gwop;
OP *kid;
const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
PADOFFSET offset;
@@ -7719,16 +9066,9 @@
/* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
if (o->op_flags & OPf_STACKED) {
- OP* k;
- o = ck_sort(o);
kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
return no_fh_allowed(o);
- for (k = kid; k; k = k->op_next) {
- kid = k;
- }
- NewOp(1101, gwop, 1, LOGOP);
- kid->op_next = (OP*)gwop;
o->op_flags &= ~OPf_STACKED;
}
kid = cLISTOPo->op_first->op_sibling;
@@ -7741,18 +9081,17 @@
return o;
kid = cLISTOPo->op_first->op_sibling;
if (kid->op_type != OP_NULL)
- Perl_croak(aTHX_ "panic: ck_grep");
+ Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
kid = kUNOP->op_first;
- if (!gwop)
- NewOp(1101, gwop, 1, LOGOP);
+ NewOp(1101, gwop, 1, LOGOP);
gwop->op_type = type;
gwop->op_ppaddr = PL_ppaddr[type];
- gwop->op_first = listkids(o);
+ gwop->op_first = o;
gwop->op_flags |= OPf_KIDS;
gwop->op_other = LINKLIST(kid);
kid->op_next = (OP*)gwop;
- offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
+ offset = pad_findmy_pvs("$_", 0);
if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
o->op_private = gwop->op_private = 0;
gwop->op_targ = pad_alloc(type, SVs_PADTMP);
@@ -7763,8 +9102,6 @@
}
kid = cLISTOPo->op_first->op_sibling;
- if (!kid || !kid->op_sibling)
- return too_few_arguments(o,OP_DESC(o));
for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
op_lvalue(kid, OP_GREPSTART);
@@ -7780,8 +9117,14 @@
OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
if (kid)
kid = kid->op_sibling; /* get past "big" */
- if (kid && kid->op_type == OP_CONST)
+ if (kid && kid->op_type == OP_CONST) {
+ const bool save_taint = TAINT_get;
fbm_compile(((SVOP*)kid)->op_sv, 0);
+ TAINT_set(save_taint);
+#ifdef NO_TAINT_SUPPORT
+ PERL_UNUSED_VAR(save_taint);
+#endif
+ }
}
return ck_fun(o);
}
@@ -7804,11 +9147,6 @@
if ((o->op_flags & OPf_KIDS)) {
switch (cUNOPo->op_first->op_type) {
case OP_RV2AV:
- /* This is needed for
- if (defined %stash::)
- to work. Do not break Tk.
- */
- break; /* Globals via GV can be undef */
case OP_PADAV:
case OP_AASSIGN: /* Is this a good idea? */
Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
@@ -7836,7 +9174,11 @@
{
PERL_ARGS_ASSERT_CK_READLINE;
- if (!(o->op_flags & OPf_KIDS)) {
+ if (o->op_flags & OPf_KIDS) {
+ OP *kid = cLISTOPo->op_first;
+ if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
+ }
+ else {
OP * const newop
= newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
#ifdef PERL_MAD
@@ -7862,7 +9204,7 @@
OP *
Perl_ck_listiob(pTHX_ OP *o)
{
- register OP *kid;
+ OP *kid;
PERL_ARGS_ASSERT_CK_LISTIOB;
@@ -7876,7 +9218,8 @@
if (kid && o->op_flags & OPf_STACKED)
kid = kid->op_sibling;
else if (kid && !kid->op_sibling) { /* print HANDLE; */
- if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
+ if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
+ && !(kid->op_private & OPpCONST_FOLDED)) {
o->op_flags |= OPf_STACKED; /* make it a filehandle */
kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
cLISTOPo->op_first->op_sibling = kid;
@@ -7888,6 +9231,7 @@
if (!kid)
op_append_elem(o->op_type, o, newDEFSVOP());
+ if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
return listkids(o);
}
@@ -7999,7 +9343,7 @@
PERL_ARGS_ASSERT_CK_MATCH;
if (o->op_type != OP_QR && PL_compcv) {
- const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
+ const PADOFFSET offset = pad_findmy_pvs("$_", 0);
if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
o->op_targ = offset;
o->op_private |= OPpTARGET_MY;
@@ -8022,8 +9366,8 @@
const char * const method = SvPVX_const(sv);
if (!(strchr(method, ':') || strchr(method, '\''))) {
OP *cmop;
- if (!SvREADONLY(sv) || !SvFAKE(sv)) {
- sv = newSVpvn_share(method, SvCUR(sv), 0);
+ if (!SvIsCOW(sv)) {
+ sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
}
else {
kSVOP->op_sv = NULL;
@@ -8147,14 +9491,9 @@
const char *end;
if (was_readonly) {
- if (SvFAKE(sv)) {
- sv_force_normal_flags(sv, 0);
- assert(!SvREADONLY(sv));
- was_readonly = 0;
- } else {
SvREADONLY_off(sv);
- }
}
+ if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
s = SvPVX(sv);
len = SvCUR(sv);
@@ -8182,18 +9521,22 @@
}
if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
- OP * const kid = cUNOPo->op_first;
- OP * newop;
-
- cUNOPo->op_first = 0;
+ OP *kid, *newop;
+ if (o->op_flags & OPf_KIDS) {
+ kid = cUNOPo->op_first;
+ cUNOPo->op_first = NULL;
+ }
+ else {
+ kid = newDEFSVOP();
+ }
#ifndef PERL_MAD
op_free(o);
#endif
- newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
+ newop = newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST, kid,
scalar(newUNOP(OP_RV2CV, 0,
newGVOP(OP_GV, 0,
- gv))))));
+ gv)))));
op_getmad(o,newop,'O');
return newop;
}
@@ -8213,19 +9556,6 @@
if (CvLVALUE(PL_compcv)) {
for (; kid; kid = kid->op_sibling)
op_lvalue(kid, OP_LEAVESUBLV);
- } else {
- for (; kid; kid = kid->op_sibling)
- if ((kid->op_type == OP_NULL)
- && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
- /* This is a do block */
- OP *op = kUNOP->op_first;
- if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
- op = cUNOPx(op)->op_first;
- assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
- /* Force the use of the caller's context */
- op->op_flags |= OPf_SPECIAL;
- }
- }
}
return o;
@@ -8245,7 +9575,7 @@
o->op_type = OP_SSELECT;
o->op_ppaddr = PL_ppaddr[OP_SSELECT];
o = ck_fun(o);
- return fold_constants(o);
+ return fold_constants(op_integerize(op_std_init(o)));
}
}
o = ck_fun(o);
@@ -8292,12 +9622,11 @@
{
dVAR;
OP *firstkid;
+ HV * const hinthv = GvHV(PL_hintgv);
PERL_ARGS_ASSERT_CK_SORT;
- if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
- HV * const hinthv = GvHV(PL_hintgv);
- if (hinthv) {
+ if (hinthv) {
SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
if (svp) {
const I32 sorthints = (I32)SvIV(*svp);
@@ -8306,63 +9635,32 @@
if ((sorthints & HINT_SORT_STABLE) != 0)
o->op_private |= OPpSORT_STABLE;
}
- }
}
- if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
+ if (o->op_flags & OPf_STACKED)
simplify_sort(o);
firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
if (o->op_flags & OPf_STACKED) { /* may have been cleared */
- OP *k = NULL;
OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
LINKLIST(kid);
- if (kid->op_type == OP_SCOPE) {
- k = kid->op_next;
- kid->op_next = 0;
- }
- else if (kid->op_type == OP_LEAVE) {
- if (o->op_type == OP_SORT) {
+ if (kid->op_type == OP_LEAVE)
op_null(kid); /* wipe out leave */
- kid->op_next = kid;
+ /* Prevent execution from escaping out of the sort block. */
+ kid->op_next = 0;
- for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
- if (k->op_next == kid)
- k->op_next = 0;
- /* don't descend into loops */
- else if (k->op_type == OP_ENTERLOOP
- || k->op_type == OP_ENTERITER)
- {
- k = cLOOPx(k)->op_lastop;
- }
- }
- }
- else
- kid->op_next = 0; /* just disconnect the leave */
- k = kLISTOP->op_first;
- }
- CALL_PEEP(k);
-
- kid = firstkid;
- if (o->op_type == OP_SORT) {
- /* provide scalar context for comparison function/block */
- kid = scalar(kid);
- kid->op_next = kid;
- }
- else
- kid->op_next = k;
+ /* provide scalar context for comparison function/block */
+ kid = scalar(firstkid);
+ kid->op_next = kid;
o->op_flags |= OPf_SPECIAL;
}
- else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
- op_null(firstkid);
firstkid = firstkid->op_sibling;
}
/* provide list context for arguments */
- if (o->op_type == OP_SORT)
- list(firstkid);
+ list(firstkid);
return o;
}
@@ -8371,11 +9669,12 @@
S_simplify_sort(pTHX_ OP *o)
{
dVAR;
- register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
+ OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
OP *k;
int descending;
GV *gv;
const char *gvname;
+ bool have_scopeop;
PERL_ARGS_ASSERT_SIMPLIFY_SORT;
@@ -8384,7 +9683,8 @@
GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
kid = kUNOP->op_first; /* get past null */
- if (kid->op_type != OP_SCOPE)
+ if (!(have_scopeop = kid->op_type == OP_SCOPE)
+ && kid->op_type != OP_LEAVE)
return;
kid = kLISTOP->op_last; /* get past scope */
switch(kid->op_type) {
@@ -8391,13 +9691,42 @@
case OP_NCMP:
case OP_I_NCMP:
case OP_SCMP:
+ if (!have_scopeop) goto padkids;
break;
default:
return;
}
k = kid; /* remember this node*/
- if (kBINOP->op_first->op_type != OP_RV2SV)
+ if (kBINOP->op_first->op_type != OP_RV2SV
+ || kBINOP->op_last ->op_type != OP_RV2SV)
+ {
+ /*
+ Warn about my($a) or my($b) in a sort block, *if* $a or $b is
+ then used in a comparison. This catches most, but not
+ all cases. For instance, it catches
+ sort { my($a); $a <=> $b }
+ but not
+ sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
+ (although why you'd do that is anyone's guess).
+ */
+
+ padkids:
+ if (!ckWARN(WARN_SYNTAX)) return;
+ kid = kBINOP->op_first;
+ do {
+ if (kid->op_type == OP_PADSV) {
+ SV * const name = AvARRAY(PL_comppad_name)[kid->op_targ];
+ if (SvCUR(name) == 2 && *SvPVX(name) == '$'
+ && (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b'))
+ /* diag_listed_as: "my %s" used in sort comparison */
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "\"%s %s\" used in sort comparison",
+ SvPAD_STATE(name) ? "state" : "my",
+ SvPVX(name));
+ }
+ } while ((kid = kid->op_sibling));
return;
+ }
kid = kBINOP->op_first; /* get past cmp */
if (kUNOP->op_first->op_type != OP_GV)
return;
@@ -8414,8 +9743,7 @@
return;
kid = k; /* back to cmp */
- if (kBINOP->op_last->op_type != OP_RV2SV)
- return;
+ /* already checked above that it is rv2sv */
kid = kBINOP->op_last; /* down to 2nd arg */
if (kUNOP->op_first->op_type != OP_GV)
return;
@@ -8448,7 +9776,7 @@
Perl_ck_split(pTHX_ OP *o)
{
dVAR;
- register OP *kid;
+ OP *kid;
PERL_ARGS_ASSERT_CK_SPLIT;
@@ -8457,11 +9785,12 @@
kid = cLISTOPo->op_first;
if (kid->op_type != OP_NULL)
- Perl_croak(aTHX_ "panic: ck_split");
+ Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
kid = kid->op_sibling;
op_free(cLISTOPo->op_first);
- cLISTOPo->op_first = kid;
- if (!kid) {
+ if (kid)
+ cLISTOPo->op_first = kid;
+ else {
cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
cLISTOPo->op_last = kid; /* There was only one element previously */
}
@@ -8469,7 +9798,7 @@
if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
OP * const sibl = kid->op_sibling;
kid->op_sibling = 0;
- kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
+ kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0); /* OPf_SPECIAL is used to trigger split " " behavior */
if (cLISTOPo->op_first == cLISTOPo->op_last)
cLISTOPo->op_last = kid;
cLISTOPo->op_first = kid;
@@ -8498,7 +9827,7 @@
scalar(kid);
if (kid->op_sibling)
- return too_many_arguments(o,OP_DESC(o));
+ return too_many_arguments_pv(o,OP_DESC(o), 0);
return o;
}
@@ -8513,11 +9842,13 @@
if (kid && kid->op_type == OP_MATCH) {
if (ckWARN(WARN_SYNTAX)) {
const REGEXP *re = PM_GETRE(kPMOP);
- const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
- const STRLEN len = re ? RX_PRELEN(re) : 6;
+ const SV *msg = re
+ ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
+ SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
+ : newSVpvs_flags( "STRING", SVs_TEMP );
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "/%.*s/ should probably be written as \"%.*s\"",
- (int)len, pmstr, (int)len, pmstr);
+ "/%"SVf"/ should probably be written as \"%"SVf"\"",
+ SVfARG(msg), SVfARG(msg));
}
}
return ck_fun(o);
@@ -8562,7 +9893,29 @@
=cut
*/
+/* shared by toke.c:yylex */
CV *
+Perl_find_lexical_cv(pTHX_ PADOFFSET off)
+{
+ PADNAME *name = PAD_COMPNAME(off);
+ CV *compcv = PL_compcv;
+ while (PadnameOUTER(name)) {
+ assert(PARENT_PAD_INDEX(name));
+ compcv = CvOUTSIDE(PL_compcv);
+ name = PadlistNAMESARRAY(CvPADLIST(compcv))
+ [off = PARENT_PAD_INDEX(name)];
+ }
+ assert(!PadnameIsOUR(name));
+ if (!PadnameIsSTATE(name) && SvMAGICAL(name)) {
+ MAGIC * mg = mg_find(name, PERL_MAGIC_proto);
+ assert(mg);
+ assert(mg->mg_obj);
+ return (CV *)mg->mg_obj;
+ }
+ return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
+}
+
+CV *
Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
{
OP *rvop;
@@ -8595,6 +9948,10 @@
cv = (CV*)SvRV(rv);
gv = NULL;
} break;
+ case OP_PADCV: {
+ cv = find_lexical_cv(rvop->op_targ);
+ gv = NULL;
+ } break;
default: {
return NULL;
} break;
@@ -8680,8 +10037,11 @@
const char *e = NULL;
PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
- Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto");
- proto = SvPV(protosv, proto_len);
+ Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
+ "flags=%lx", (unsigned long) SvFLAGS(protosv));
+ if (SvTYPE(protosv) == SVt_PVCV)
+ proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
+ else proto = SvPV(protosv, proto_len);
proto_end = proto + proto_len;
aop = cUNOPx(entersubop)->op_first;
if (!aop->op_sibling)
@@ -8701,7 +10061,7 @@
o3 = aop;
if (proto >= proto_end)
- return too_many_arguments(entersubop, gv_ename(namegv));
+ return too_many_arguments_sv(entersubop, gv_ename(namegv), 0);
switch (*proto) {
case ';':
@@ -8710,7 +10070,7 @@
continue;
case '_':
/* _ must be at the end */
- if (proto[1] && proto[1] != ';')
+ if (proto[1] && !strchr(";@%", proto[1]))
goto oops;
case '$':
proto++;
@@ -8726,9 +10086,9 @@
proto++;
arg++;
if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
- bad_type(arg,
+ bad_type_sv(arg,
arg == 1 ? "block or sub {}" : "sub {}",
- gv_ename(namegv), o3);
+ gv_ename(namegv), 0, o3);
break;
case '*':
/* '*' allows any scalar type, including bareword */
@@ -8805,10 +10165,17 @@
const char *p = proto;
const char *const end = proto;
contextclass = 0;
- while (*--p != '[') {}
- bad_type(arg, Perl_form(aTHX_ "one of %.*s",
+ while (*--p != '[')
+ /* \[$] accepts any scalar lvalue */
+ if (*p == '$'
+ && Perl_op_lvalue_flags(aTHX_
+ scalar(o3),
+ OP_READ, /* not entersub */
+ OP_LVALUE_NO_CROAK
+ )) goto wrapref;
+ bad_type_sv(arg, Perl_form(aTHX_ "one of %.*s",
(int)(end - p), p),
- gv_ename(namegv), o3);
+ gv_ename(namegv), 0, o3);
} else
goto oops;
break;
@@ -8816,13 +10183,13 @@
if (o3->op_type == OP_RV2GV)
goto wrapref;
if (!contextclass)
- bad_type(arg, "symbol", gv_ename(namegv), o3);
+ bad_type_sv(arg, "symbol", gv_ename(namegv), 0, o3);
break;
case '&':
if (o3->op_type == OP_ENTERSUB)
goto wrapref;
if (!contextclass)
- bad_type(arg, "subroutine entry", gv_ename(namegv),
+ bad_type_sv(arg, "subroutine entry", gv_ename(namegv), 0,
o3);
break;
case '$':
@@ -8831,8 +10198,15 @@
o3->op_type == OP_HELEM ||
o3->op_type == OP_AELEM)
goto wrapref;
- if (!contextclass)
- bad_type(arg, "scalar", gv_ename(namegv), o3);
+ if (!contextclass) {
+ /* \$ accepts any scalar lvalue */
+ if (Perl_op_lvalue_flags(aTHX_
+ scalar(o3),
+ OP_READ, /* not entersub */
+ OP_LVALUE_NO_CROAK
+ )) goto wrapref;
+ bad_type_sv(arg, "scalar", gv_ename(namegv), 0, o3);
+ }
break;
case '@':
if (o3->op_type == OP_RV2AV ||
@@ -8839,7 +10213,7 @@
o3->op_type == OP_PADAV)
goto wrapref;
if (!contextclass)
- bad_type(arg, "array", gv_ename(namegv), o3);
+ bad_type_sv(arg, "array", gv_ename(namegv), 0, o3);
break;
case '%':
if (o3->op_type == OP_RV2HV ||
@@ -8846,7 +10220,7 @@
o3->op_type == OP_PADHV)
goto wrapref;
if (!contextclass)
- bad_type(arg, "hash", gv_ename(namegv), o3);
+ bad_type_sv(arg, "hash", gv_ename(namegv), 0, o3);
break;
wrapref:
{
@@ -8871,9 +10245,12 @@
proto++;
continue;
default:
- oops:
- Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
- gv_ename(namegv), SVfARG(protosv));
+ oops: {
+ SV* const tmpsv = sv_newmortal();
+ gv_efullname3(tmpsv, namegv, NULL);
+ Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
+ SVfARG(tmpsv), SVfARG(protosv));
+ }
}
op_lvalue(aop, OP_ENTERSUB);
@@ -8888,7 +10265,7 @@
}
if (!optional && proto_end > proto &&
(*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
- return too_few_arguments(entersubop, gv_ename(namegv));
+ return too_few_arguments_sv(entersubop, gv_ename(namegv), 0);
return entersubop;
}
@@ -8930,6 +10307,99 @@
return ck_entersub_args_list(entersubop);
}
+OP *
+Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
+{
+ int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
+ OP *aop = cUNOPx(entersubop)->op_first;
+
+ PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
+
+ if (!opnum) {
+ OP *cvop;
+ if (!aop->op_sibling)
+ aop = cUNOPx(aop)->op_first;
+ aop = aop->op_sibling;
+ for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
+ if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
+ aop = aop->op_sibling;
+ }
+ if (aop != cvop)
+ (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
+
+ op_free(entersubop);
+ switch(GvNAME(namegv)[2]) {
+ case 'F': return newSVOP(OP_CONST, 0,
+ newSVpv(CopFILE(PL_curcop),0));
+ case 'L': return newSVOP(
+ OP_CONST, 0,
+ Perl_newSVpvf(aTHX_
+ "%"IVdf, (IV)CopLINE(PL_curcop)
+ )
+ );
+ case 'P': return newSVOP(OP_CONST, 0,
+ (PL_curstash
+ ? newSVhek(HvNAME_HEK(PL_curstash))
+ : &PL_sv_undef
+ )
+ );
+ }
+ assert(0);
+ }
+ else {
+ OP *prev, *cvop;
+ U32 flags;
+#ifdef PERL_MAD
+ bool seenarg = FALSE;
+#endif
+ if (!aop->op_sibling)
+ aop = cUNOPx(aop)->op_first;
+
+ prev = aop;
+ aop = aop->op_sibling;
+ prev->op_sibling = NULL;
+ for (cvop = aop;
+ cvop->op_sibling;
+ prev=cvop, cvop = cvop->op_sibling)
+#ifdef PERL_MAD
+ if (PL_madskills && cvop->op_sibling
+ && cvop->op_type != OP_STUB) seenarg = TRUE
+#endif
+ ;
+ prev->op_sibling = NULL;
+ flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
+ op_free(cvop);
+ if (aop == cvop) aop = NULL;
+ op_free(entersubop);
+
+ if (opnum == OP_ENTEREVAL
+ && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
+ flags |= OPpEVAL_BYTES <<8;
+
+ switch (PL_opargs[opnum] & OA_CLASS_MASK) {
+ case OA_UNOP:
+ case OA_BASEOP_OR_UNOP:
+ case OA_FILESTATOP:
+ return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
+ case OA_BASEOP:
+ if (aop) {
+#ifdef PERL_MAD
+ if (!PL_madskills || seenarg)
+#endif
+ (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
+ op_free(aop);
+ }
+ return opnum == OP_RUNCV
+ ? newPVOP(OP_RUNCV,0,NULL)
+ : newOP(opnum,0);
+ default:
+ return convert(opnum,0,aop);
+ }
+ }
+ assert(0);
+ return entersubop;
+}
+
/*
=for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
@@ -9023,6 +10493,7 @@
SvREFCNT_inc_simple_void_NN(ckobj);
callmg->mg_flags |= MGf_REFCOUNTED;
}
+ callmg->mg_flags |= MGf_COPY;
}
}
@@ -9043,6 +10514,7 @@
cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
+ o->op_private &= ~1;
o->op_private |= OPpENTERSUB_HASTARG;
o->op_private |= (PL_hints & HINT_STRICT_REFS);
if (PERLDB_SUB && PL_curstash != PL_debstash)
@@ -9066,6 +10538,21 @@
Perl_call_checker ckfun;
SV *ckobj;
cv_get_call_checker(cv, &ckfun, &ckobj);
+ if (!namegv) { /* expletive! */
+ /* XXX The call checker API is public. And it guarantees that
+ a GV will be provided with the right name. So we have
+ to create a GV. But it is still not correct, as its
+ stringification will include the package. What we
+ really need is a new call checker API that accepts a
+ GV or string (or GV or CV). */
+ HEK * const hek = CvNAME_HEK(cv);
+ /* After a syntax error in a lexical sub, the cv that
+ rv2cv_op_cv returns may be a nameless stub. */
+ if (!hek) return ck_entersub_args_list(o);;
+ namegv = (GV *)sv_newmortal();
+ gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek),
+ SVf_UTF8 * !!HEK_UTF8(hek));
+ }
return ckfun(aTHX_ o, namegv, ckobj);
}
}
@@ -9075,28 +10562,11 @@
{
PERL_ARGS_ASSERT_CK_SVCONST;
PERL_UNUSED_CONTEXT;
- SvREADONLY_on(cSVOPo->op_sv);
+ if (!SvIsCOW(cSVOPo->op_sv)) SvREADONLY_on(cSVOPo->op_sv);
return o;
}
OP *
-Perl_ck_chdir(pTHX_ OP *o)
-{
- PERL_ARGS_ASSERT_CK_CHDIR;
- if (o->op_flags & OPf_KIDS) {
- SVOP * const kid = (SVOP*)cUNOPo->op_first;
-
- if (kid && kid->op_type == OP_CONST &&
- (kid->op_private & OPpCONST_BARE))
- {
- o->op_flags |= OPf_SPECIAL;
- kid->op_private &= ~OPpCONST_STRICT;
- }
- }
- return ck_fun(o);
-}
-
-OP *
Perl_ck_trunc(pTHX_ OP *o)
{
PERL_ARGS_ASSERT_CK_TRUNC;
@@ -9107,7 +10577,8 @@
if (kid->op_type == OP_NULL)
kid = (SVOP*)kid->op_sibling;
if (kid && kid->op_type == OP_CONST &&
- (kid->op_private & OPpCONST_BARE))
+ (kid->op_private & (OPpCONST_BARE|OPpCONST_FOLDED))
+ == OPpCONST_BARE)
{
o->op_flags |= OPf_SPECIAL;
kid->op_private &= ~OPpCONST_STRICT;
@@ -9117,21 +10588,6 @@
}
OP *
-Perl_ck_unpack(pTHX_ OP *o)
-{
- OP *kid = cLISTOPo->op_first;
-
- PERL_ARGS_ASSERT_CK_UNPACK;
-
- if (kid->op_sibling) {
- kid = kid->op_sibling;
- if (!kid->op_sibling)
- kid->op_sibling = newDEFSVOP();
- }
- return ck_fun(o);
-}
-
-OP *
Perl_ck_substr(pTHX_ OP *o)
{
PERL_ARGS_ASSERT_CK_SUBSTR;
@@ -9150,6 +10606,19 @@
}
OP *
+Perl_ck_tell(pTHX_ OP *o)
+{
+ PERL_ARGS_ASSERT_CK_TELL;
+ o = ck_fun(o);
+ if (o->op_flags & OPf_KIDS) {
+ OP *kid = cLISTOPo->op_first;
+ if (kid->op_type == OP_NULL && kid->op_sibling) kid = kid->op_sibling;
+ if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
+ }
+ return o;
+}
+
+OP *
Perl_ck_each(pTHX_ OP *o)
{
dVAR;
@@ -9188,115 +10657,166 @@
return o->op_type == ref_type ? o : ck_fun(o);
}
-/* caller is supposed to assign the return to the
- container of the rep_op var */
-STATIC OP *
-S_opt_scalarhv(pTHX_ OP *rep_op) {
- dVAR;
- UNOP *unop;
+OP *
+Perl_ck_length(pTHX_ OP *o)
+{
+ PERL_ARGS_ASSERT_CK_LENGTH;
- PERL_ARGS_ASSERT_OPT_SCALARHV;
+ o = ck_fun(o);
- NewOp(1101, unop, 1, UNOP);
- unop->op_type = (OPCODE)OP_BOOLKEYS;
- unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
- unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
- unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
- unop->op_first = rep_op;
- unop->op_next = rep_op->op_next;
- rep_op->op_next = (OP*)unop;
- rep_op->op_flags|=(OPf_REF | OPf_MOD);
- unop->op_sibling = rep_op->op_sibling;
- rep_op->op_sibling = NULL;
- /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
- if (rep_op->op_type == OP_PADHV) {
- rep_op->op_flags &= ~OPf_WANT_SCALAR;
- rep_op->op_flags |= OPf_WANT_LIST;
+ if (ckWARN(WARN_SYNTAX)) {
+ const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
+
+ if (kid) {
+ SV *name = NULL;
+ const bool hash = kid->op_type == OP_PADHV
+ || kid->op_type == OP_RV2HV;
+ switch (kid->op_type) {
+ case OP_PADHV:
+ case OP_PADAV:
+ name = varname(
+ (GV *)PL_compcv, hash ? '%' : '@', kid->op_targ,
+ NULL, 0, 1
+ );
+ break;
+ case OP_RV2HV:
+ case OP_RV2AV:
+ if (cUNOPx(kid)->op_first->op_type != OP_GV) break;
+ {
+ GV *gv = cGVOPx_gv(cUNOPx(kid)->op_first);
+ if (!gv) break;
+ name = varname(gv, hash?'%':'@', 0, NULL, 0, 1);
+ }
+ break;
+ default:
+ return o;
+ }
+ if (name)
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
+ ")\"?)",
+ name, hash ? "keys " : "", name
+ );
+ else if (hash)
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
+ else
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "length() used on @array (did you mean \"scalar(@array)\"?)");
+ }
}
- return (OP*)unop;
-}
-/* Checks if o acts as an in-place operator on an array. oright points to the
- * beginning of the right-hand side. Returns the left-hand side of the
- * assignment if o acts in-place, or NULL otherwise. */
+ return o;
+}
-STATIC OP *
-S_is_inplace_av(pTHX_ OP *o, OP *oright) {
- OP *o2;
- OP *oleft = NULL;
+/* Check for in place reverse and sort assignments like "@a = reverse @a"
+ and modify the optree to make them work inplace */
- PERL_ARGS_ASSERT_IS_INPLACE_AV;
+STATIC void
+S_inplace_aassign(pTHX_ OP *o) {
- if (!oright ||
- (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
- || oright->op_next != o
- || (oright->op_private & OPpLVAL_INTRO)
- )
- return NULL;
+ OP *modop, *modop_pushmark;
+ OP *oright;
+ OP *oleft, *oleft_pushmark;
- /* o2 follows the chain of op_nexts through the LHS of the
- * assign (if any) to the aassign op itself */
- o2 = o->op_next;
- if (!o2 || o2->op_type != OP_NULL)
- return NULL;
- o2 = o2->op_next;
- if (!o2 || o2->op_type != OP_PUSHMARK)
- return NULL;
- o2 = o2->op_next;
- if (o2 && o2->op_type == OP_GV)
- o2 = o2->op_next;
- if (!o2
- || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
- || (o2->op_private & OPpLVAL_INTRO)
+ PERL_ARGS_ASSERT_INPLACE_AASSIGN;
+
+ assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
+
+ assert(cUNOPo->op_first->op_type == OP_NULL);
+ modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
+ assert(modop_pushmark->op_type == OP_PUSHMARK);
+ modop = modop_pushmark->op_sibling;
+
+ if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
+ return;
+
+ /* no other operation except sort/reverse */
+ if (modop->op_sibling)
+ return;
+
+ assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
+ if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return;
+
+ if (modop->op_flags & OPf_STACKED) {
+ /* skip sort subroutine/block */
+ assert(oright->op_type == OP_NULL);
+ oright = oright->op_sibling;
+ }
+
+ assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
+ oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
+ assert(oleft_pushmark->op_type == OP_PUSHMARK);
+ oleft = oleft_pushmark->op_sibling;
+
+ /* Check the lhs is an array */
+ if (!oleft ||
+ (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
+ || oleft->op_sibling
+ || (oleft->op_private & OPpLVAL_INTRO)
)
- return NULL;
- oleft = o2;
- o2 = o2->op_next;
- if (!o2 || o2->op_type != OP_NULL)
- return NULL;
- o2 = o2->op_next;
- if (!o2 || o2->op_type != OP_AASSIGN
- || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
- return NULL;
+ return;
- /* check that the sort is the first arg on RHS of assign */
+ /* Only one thing on the rhs */
+ if (oright->op_sibling)
+ return;
- o2 = cUNOPx(o2)->op_first;
- if (!o2 || o2->op_type != OP_NULL)
- return NULL;
- o2 = cUNOPx(o2)->op_first;
- if (!o2 || o2->op_type != OP_PUSHMARK)
- return NULL;
- if (o2->op_sibling != o)
- return NULL;
-
/* check the array is the same on both sides */
if (oleft->op_type == OP_RV2AV) {
if (oright->op_type != OP_RV2AV
|| !cUNOPx(oright)->op_first
|| cUNOPx(oright)->op_first->op_type != OP_GV
+ || cUNOPx(oleft )->op_first->op_type != OP_GV
|| cGVOPx_gv(cUNOPx(oleft)->op_first) !=
cGVOPx_gv(cUNOPx(oright)->op_first)
)
- return NULL;
+ return;
}
else if (oright->op_type != OP_PADAV
|| oright->op_targ != oleft->op_targ
)
- return NULL;
+ return;
- return oleft;
+ /* This actually is an inplace assignment */
+
+ modop->op_private |= OPpSORT_INPLACE;
+
+ /* transfer MODishness etc from LHS arg to RHS arg */
+ oright->op_flags = oleft->op_flags;
+
+ /* remove the aassign op and the lhs */
+ op_null(o);
+ op_null(oleft_pushmark);
+ if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
+ op_null(cUNOPx(oleft)->op_first);
+ op_null(oleft);
}
+#define MAX_DEFERRED 4
+
+#define DEFER(o) \
+ STMT_START { \
+ if (defer_ix == (MAX_DEFERRED-1)) { \
+ CALL_RPEEP(defer_queue[defer_base]); \
+ defer_base = (defer_base + 1) % MAX_DEFERRED; \
+ defer_ix--; \
+ } \
+ defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o; \
+ } STMT_END
+
/* 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 */
void
-Perl_rpeep(pTHX_ register OP *o)
+Perl_rpeep(pTHX_ OP *o)
{
dVAR;
- register OP* oldop = NULL;
+ OP* oldop = NULL;
+ OP* oldoldop = NULL;
+ OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
+ int defer_base = 0;
+ int defer_ix = -1;
if (!o || o->op_opt)
return;
@@ -9303,9 +10823,15 @@
ENTER;
SAVEOP();
SAVEVPTR(PL_curcop);
- for (; o; o = o->op_next) {
- if (o->op_opt)
+ for (;; o = o->op_next) {
+ if (o && o->op_opt)
+ o = NULL;
+ if (!o) {
+ while (defer_ix >= 0)
+ CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]);
break;
+ }
+
/* By default, this op has now been optimised. A couple of cases below
clear this again. */
o->op_opt = 1;
@@ -9338,7 +10864,7 @@
data. */
firstcop->cop_line = secondcop->cop_line;
#ifdef USE_ITHREADS
- firstcop->cop_stashpv = secondcop->cop_stashpv;
+ firstcop->cop_stashoff = secondcop->cop_stashoff;
firstcop->cop_file = secondcop->cop_file;
#else
firstcop->cop_stash = secondcop->cop_stash;
@@ -9350,7 +10876,7 @@
firstcop->cop_hints_hash = secondcop->cop_hints_hash;
#ifdef USE_ITHREADS
- secondcop->cop_stashpv = NULL;
+ secondcop->cop_stashoff = 0;
secondcop->cop_file = NULL;
#else
secondcop->cop_stash = NULL;
@@ -9368,49 +10894,6 @@
}
break;
- case OP_CONST:
- if (cSVOPo->op_private & OPpCONST_STRICT)
- no_bareword_allowed(o);
-#ifdef USE_ITHREADS
- case OP_HINTSEVAL:
- case OP_METHOD_NAMED:
- /* Relocate sv to the pad for thread safety.
- * Despite being a "constant", the SV is written to,
- * for reference counts, sv_upgrade() etc. */
- if (cSVOP->op_sv) {
- const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
- if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
- /* If op_sv is already a PADTMP then it is being used by
- * some pad, so make a copy. */
- sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
- SvREADONLY_on(PAD_SVl(ix));
- SvREFCNT_dec(cSVOPo->op_sv);
- }
- else if (o->op_type != OP_METHOD_NAMED
- && cSVOPo->op_sv == &PL_sv_undef) {
- /* PL_sv_undef is hack - it's unsafe to store it in the
- AV that is the pad, because av_fetch treats values of
- PL_sv_undef as a "free" AV entry and will merrily
- replace them with a new SV, causing pad_alloc to think
- that this pad slot is free. (When, clearly, it is not)
- */
- SvOK_off(PAD_SVl(ix));
- SvPADTMP_on(PAD_SVl(ix));
- SvREADONLY_on(PAD_SVl(ix));
- }
- else {
- SvREFCNT_dec(PAD_SVl(ix));
- SvPADTMP_on(cSVOPo->op_sv);
- PAD_SETSV(ix, cSVOPo->op_sv);
- /* XXX I don't know how this isn't readonly already. */
- SvREADONLY_on(PAD_SVl(ix));
- }
- cSVOPo->op_sv = NULL;
- o->op_targ = ix;
- }
-#endif
- break;
-
case OP_CONCAT:
if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
if (o->op_next->op_private & OPpTARGET_MY) {
@@ -9455,6 +10938,247 @@
}
break;
+ case OP_PUSHMARK:
+
+ /* Convert a series of PAD ops for my vars plus support into a
+ * single padrange op. Basically
+ *
+ * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
+ *
+ * becomes, depending on circumstances, one of
+ *
+ * padrange ----------------------------------> (list) -> rest
+ * padrange --------------------------------------------> rest
+ *
+ * where all the pad indexes are sequential and of the same type
+ * (INTRO or not).
+ * We convert the pushmark into a padrange op, then skip
+ * any other pad ops, and possibly some trailing ops.
+ * Note that we don't null() the skipped ops, to make it
+ * easier for Deparse to undo this optimisation (and none of
+ * the skipped ops are holding any resourses). It also makes
+ * it easier for find_uninit_var(), as it can just ignore
+ * padrange, and examine the original pad ops.
+ */
+ {
+ OP *p;
+ OP *followop = NULL; /* the op that will follow the padrange op */
+ U8 count = 0;
+ U8 intro = 0;
+ PADOFFSET base = 0; /* init only to stop compiler whining */
+ U8 gimme = 0; /* init only to stop compiler whining */
+ bool defav = 0; /* seen (...) = @_ */
+ bool reuse = 0; /* reuse an existing padrange op */
+
+ /* 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))
+ && GvNAMELEN_get(gv) == 1
+ && *GvNAME_get(gv) == '_'
+ && GvSTASH(gv) == PL_defstash
+ && (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)
+ && o->op_sibling == rv2av /* these two for Deparse */
+ && cUNOPx(rv2av)->op_first == p
+ ) {
+ q = rv2av->op_next;
+ if (q->op_type == OP_NULL)
+ q = q->op_next;
+ if (q->op_type == OP_PUSHMARK) {
+ defav = 1;
+ p = q;
+ }
+ }
+ }
+ if (!defav) {
+ /* To allow Deparse to pessimise this, it needs to be able
+ * to restore the pushmark's original op_next, which it
+ * will assume to be the same as op_sibling. */
+ if (o->op_next != o->op_sibling)
+ break;
+ p = o;
+ }
+
+ /* scan for PAD ops */
+
+ for (p = p->op_next; p; p = p->op_next) {
+ if (p->op_type == OP_NULL)
+ continue;
+
+ if (( p->op_type != OP_PADSV
+ && p->op_type != OP_PADAV
+ && p->op_type != OP_PADHV
+ )
+ /* any private flag other than INTRO? e.g. STATE */
+ || (p->op_private & ~OPpLVAL_INTRO)
+ )
+ break;
+
+ /* let $a[N] potentially be optimised into ALEMFAST_LEX
+ * instead */
+ if ( p->op_type == OP_PADAV
+ && p->op_next
+ && p->op_next->op_type == OP_CONST
+ && p->op_next->op_next
+ && p->op_next->op_next->op_type == OP_AELEM
+ )
+ break;
+
+ /* for 1st padop, note what type it is and the range
+ * start; for the others, check that it's the same type
+ * and that the targs are contiguous */
+ if (count == 0) {
+ intro = (p->op_private & OPpLVAL_INTRO);
+ base = p->op_targ;
+ gimme = (p->op_flags & OPf_WANT);
+ }
+ else {
+ if ((p->op_private & OPpLVAL_INTRO) != intro)
+ break;
+ /* Note that you'd normally expect targs to be
+ * contiguous in my($a,$b,$c), but that's not the case
+ * when external modules start doing things, e.g.
+ i* Function::Parameters */
+ if (p->op_targ != base + count)
+ break;
+ assert(p->op_targ == base + count);
+ /* all the padops should be in the same context */
+ if (gimme != (p->op_flags & OPf_WANT))
+ break;
+ }
+
+ /* for AV, HV, only when we're not flattening */
+ if ( p->op_type != OP_PADSV
+ && gimme != OPf_WANT_VOID
+ && !(p->op_flags & OPf_REF)
+ )
+ break;
+
+ if (count >= OPpPADRANGE_COUNTMASK)
+ break;
+
+ /* there's a biggest base we can fit into a
+ * SAVEt_CLEARPADRANGE in pp_padrange */
+ if (intro && base >
+ (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
+ break;
+
+ /* Success! We've got another valid pad op to optimise away */
+ count++;
+ followop = p->op_next;
+ }
+
+ if (count < 1)
+ break;
+
+ /* pp_padrange in specifically compile-time void context
+ * skips pushing a mark and lexicals; in all other contexts
+ * (including unknown till runtime) it pushes a mark and the
+ * lexicals. We must be very careful then, that the ops we
+ * optimise away would have exactly the same effect as the
+ * padrange.
+ * In particular in void context, we can only optimise to
+ * a padrange if see see the complete sequence
+ * pushmark, pad*v, ...., list, nextstate
+ * which has the net effect of of leaving the stack empty
+ * (for now we leave the nextstate in the execution chain, for
+ * its other side-effects).
+ */
+ assert(followop);
+ if (gimme == OPf_WANT_VOID) {
+ if (followop->op_type == OP_LIST
+ && gimme == (followop->op_flags & OPf_WANT)
+ && ( followop->op_next->op_type == OP_NEXTSTATE
+ || followop->op_next->op_type == OP_DBSTATE))
+ {
+ followop = followop->op_next; /* skip OP_LIST */
+
+ /* consolidate two successive my(...);'s */
+
+ if ( oldoldop
+ && oldoldop->op_type == OP_PADRANGE
+ && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
+ && (oldoldop->op_private & OPpLVAL_INTRO) == intro
+ && !(oldoldop->op_flags & OPf_SPECIAL)
+ ) {
+ U8 old_count;
+ assert(oldoldop->op_next == oldop);
+ assert( oldop->op_type == OP_NEXTSTATE
+ || oldop->op_type == OP_DBSTATE);
+ assert(oldop->op_next == o);
+
+ old_count
+ = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
+ assert(oldoldop->op_targ + old_count == base);
+
+ if (old_count < OPpPADRANGE_COUNTMASK - count) {
+ base = oldoldop->op_targ;
+ count += old_count;
+ reuse = 1;
+ }
+ }
+
+ /* if there's any immediately following singleton
+ * my var's; then swallow them and the associated
+ * nextstates; i.e.
+ * my ($a,$b); my $c; my $d;
+ * is treated as
+ * my ($a,$b,$c,$d);
+ */
+
+ while ( ((p = followop->op_next))
+ && ( p->op_type == OP_PADSV
+ || p->op_type == OP_PADAV
+ || p->op_type == OP_PADHV)
+ && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
+ && (p->op_private & OPpLVAL_INTRO) == intro
+ && p->op_next
+ && ( p->op_next->op_type == OP_NEXTSTATE
+ || p->op_next->op_type == OP_DBSTATE)
+ && count < OPpPADRANGE_COUNTMASK
+ ) {
+ assert(base + count == p->op_targ);
+ count++;
+ followop = p->op_next;
+ }
+ }
+ else
+ break;
+ }
+
+ if (reuse) {
+ assert(oldoldop->op_type == OP_PADRANGE);
+ oldoldop->op_next = followop;
+ oldoldop->op_private = (intro | count);
+ o = oldoldop;
+ oldop = NULL;
+ oldoldop = NULL;
+ }
+ else {
+ /* Convert the pushmark into a padrange.
+ * To make Deparse easier, we guarantee that a padrange was
+ * *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];
+ o->op_targ = base;
+ /* bit 7: INTRO; bit 6..0: count */
+ o->op_private = (intro | count);
+ o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
+ | gimme | (defav ? OPf_SPECIAL : 0));
+ }
+ break;
+ }
+
case OP_PADAV:
case OP_GV:
if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
@@ -9466,9 +11190,7 @@
pop->op_next->op_type == OP_AELEM &&
!(pop->op_next->op_private &
(OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
- (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
- <= 255 &&
- i >= 0)
+ (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && i >= 0)
{
GV *gv;
if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
@@ -9484,10 +11206,10 @@
if (o->op_type == OP_GV) {
gv = cGVOPo_gv;
GvAVn(gv);
+ o->op_type = OP_AELEMFAST;
}
else
- o->op_flags |= OPf_SPECIAL;
- o->op_type = OP_AELEMFAST;
+ o->op_type = OP_AELEMFAST_LEX;
}
break;
}
@@ -9502,17 +11224,6 @@
o->op_ppaddr = PL_ppaddr[OP_GVSV];
}
}
- else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
- GV * const gv = cGVOPo_gv;
- if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
- /* XXX could check prototype here instead of just carping */
- SV * const sv = sv_newmortal();
- gv_efullname3(sv, gv, NULL);
- Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
- "%"SVf"() called too early to check prototype",
- SVfARG(sv));
- }
- }
else if (o->op_next->op_type == OP_READLINE
&& o->op_next->op_next->op_type == OP_CONCAT
&& (o->op_next->op_next->op_flags & OPf_STACKED))
@@ -9531,10 +11242,18 @@
OP *fop;
OP *sop;
+#define HV_OR_SCALARHV(op) \
+ ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
+ ? (op) \
+ : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
+ && ( cUNOPx(op)->op_first->op_type == OP_PADHV \
+ || cUNOPx(op)->op_first->op_type == OP_RV2HV) \
+ ? cUNOPx(op)->op_first \
+ : NULL)
+
case OP_NOT:
- fop = cUNOP->op_first;
- sop = NULL;
- goto stitch_keys;
+ if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
+ fop->op_private |= OPpTRUEBOOL;
break;
case OP_AND:
@@ -9544,14 +11263,15 @@
sop = fop->op_sibling;
while (cLOGOP->op_other->op_type == OP_NULL)
cLOGOP->op_other = cLOGOP->op_other->op_next;
- CALL_RPEEP(cLOGOP->op_other);
+ while (o->op_next && ( o->op_type == o->op_next->op_type
+ || o->op_next->op_type == OP_NULL))
+ o->op_next = o->op_next->op_next;
+ DEFER(cLOGOP->op_other);
- stitch_keys:
o->op_opt = 1;
- if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
- || ( sop &&
- (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
- )
+ fop = HV_OR_SCALARHV(fop);
+ if (sop) sop = HV_OR_SCALARHV(sop);
+ if (fop || sop
){
OP * nop = o;
OP * lop = o;
@@ -9573,29 +11293,38 @@
}
}
}
- if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
- if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
- cLOGOP->op_first = opt_scalarhv(fop);
- if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
- cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
- }
+ if (fop) {
+ if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
+ || o->op_type == OP_AND )
+ fop->op_private |= OPpTRUEBOOL;
+ else if (!(lop->op_flags & OPf_WANT))
+ fop->op_private |= OPpMAYBE_TRUEBOOL;
+ }
+ if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
+ && sop)
+ sop->op_private |= OPpTRUEBOOL;
}
break;
+
+ case OP_COND_EXPR:
+ if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
+ fop->op_private |= OPpTRUEBOOL;
+#undef HV_OR_SCALARHV
+ /* GERONIMO! */
}
-
+
case OP_MAPWHILE:
case OP_GREPWHILE:
case OP_ANDASSIGN:
case OP_ORASSIGN:
case OP_DORASSIGN:
- case OP_COND_EXPR:
case OP_RANGE:
case OP_ONCE:
while (cLOGOP->op_other->op_type == OP_NULL)
cLOGOP->op_other = cLOGOP->op_other->op_next;
- CALL_RPEEP(cLOGOP->op_other);
+ DEFER(cLOGOP->op_other);
break;
case OP_ENTERLOOP:
@@ -9602,13 +11331,14 @@
case OP_ENTERITER:
while (cLOOP->op_redoop->op_type == OP_NULL)
cLOOP->op_redoop = cLOOP->op_redoop->op_next;
- CALL_RPEEP(cLOOP->op_redoop);
while (cLOOP->op_nextop->op_type == OP_NULL)
cLOOP->op_nextop = cLOOP->op_nextop->op_next;
- CALL_RPEEP(cLOOP->op_nextop);
while (cLOOP->op_lastop->op_type == OP_NULL)
cLOOP->op_lastop = cLOOP->op_lastop->op_next;
- CALL_RPEEP(cLOOP->op_lastop);
+ /* a while(1) loop doesn't have an op_next that escapes the
+ * loop, so we have to explicitly follow the op_lastop to
+ * process the rest of the code */
+ DEFER(cLOOP->op_lastop);
break;
case OP_SUBST:
@@ -9617,156 +11347,28 @@
cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
cPMOP->op_pmstashstartu.op_pmreplstart
= cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
- CALL_RPEEP(cPMOP->op_pmstashstartu.op_pmreplstart);
+ DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
break;
- case OP_EXEC:
- if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
- && ckWARN(WARN_SYNTAX))
- {
- if (o->op_next->op_sibling) {
- const OPCODE type = o->op_next->op_sibling->op_type;
- if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
- const line_t oldline = CopLINE(PL_curcop);
- CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
- Perl_warner(aTHX_ packWARN(WARN_EXEC),
- "Statement unlikely to be reached");
- Perl_warner(aTHX_ packWARN(WARN_EXEC),
- "\t(Maybe you meant system() when you said exec()?)\n");
- CopLINE_set(PL_curcop, oldline);
- }
- }
- }
- break;
+ case OP_SORT: {
+ OP *oright;
- case OP_HELEM: {
- UNOP *rop;
- SV *lexname;
- GV **fields;
- SV **svp, *sv;
- const char *key = NULL;
- STRLEN keylen;
-
- if (((BINOP*)o)->op_last->op_type != OP_CONST)
- break;
-
- /* Make the CONST have a shared SV */
- svp = cSVOPx_svp(((BINOP*)o)->op_last);
- if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
- && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
- key = SvPV_const(sv, keylen);
- lexname = newSVpvn_share(key,
- SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
- 0);
- SvREFCNT_dec(sv);
- *svp = lexname;
+ if (o->op_flags & OPf_STACKED) {
+ OP * const kid =
+ cUNOPx(cLISTOP->op_first->op_sibling)->op_first;
+ if (kid->op_type == OP_SCOPE
+ || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE))
+ DEFER(kLISTOP->op_first);
}
- if ((o->op_private & (OPpLVAL_INTRO)))
+ /* check that RHS of sort is a single plain array */
+ oright = cUNOPo->op_first;
+ if (!oright || oright->op_type != OP_PUSHMARK)
break;
- rop = (UNOP*)((BINOP*)o)->op_first;
- if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
+ if (o->op_private & OPpSORT_INPLACE)
break;
- lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
- if (!SvPAD_TYPED(lexname))
- break;
- fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
- if (!fields || !GvHV(*fields))
- break;
- key = SvPV_const(*svp, keylen);
- if (!hv_fetch(GvHV(*fields), key,
- SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
- {
- Perl_croak(aTHX_ "No such class field \"%s\" "
- "in variable %s of type %s",
- key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
- }
- break;
- }
-
- case OP_HSLICE: {
- UNOP *rop;
- SV *lexname;
- GV **fields;
- SV **svp;
- const char *key;
- STRLEN keylen;
- SVOP *first_key_op, *key_op;
-
- if ((o->op_private & (OPpLVAL_INTRO))
- /* I bet there's always a pushmark... */
- || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
- /* hmmm, no optimization if list contains only one key. */
- break;
- rop = (UNOP*)((LISTOP*)o)->op_last;
- if (rop->op_type != OP_RV2HV)
- break;
- if (rop->op_first->op_type == OP_PADSV)
- /* @$hash{qw(keys here)} */
- rop = (UNOP*)rop->op_first;
- else {
- /* @{$hash}{qw(keys here)} */
- if (rop->op_first->op_type == OP_SCOPE
- && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
- {
- rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
- }
- else
- break;
- }
-
- lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
- if (!SvPAD_TYPED(lexname))
- break;
- fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
- if (!fields || !GvHV(*fields))
- break;
- /* Again guessing that the pushmark can be jumped over.... */
- first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
- ->op_first->op_sibling;
- for (key_op = first_key_op; key_op;
- key_op = (SVOP*)key_op->op_sibling) {
- if (key_op->op_type != OP_CONST)
- continue;
- svp = cSVOPx_svp(key_op);
- key = SvPV_const(*svp, keylen);
- if (!hv_fetch(GvHV(*fields), key,
- SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
- {
- Perl_croak(aTHX_ "No such class field \"%s\" "
- "in variable %s of type %s",
- key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
- }
- }
- break;
- }
- case OP_RV2SV:
- case OP_RV2AV:
- case OP_RV2HV:
- if (oldop
- && ( oldop->op_type == OP_AELEM
- || oldop->op_type == OP_PADSV
- || oldop->op_type == OP_RV2SV
- || oldop->op_type == OP_RV2GV
- || oldop->op_type == OP_HELEM
- )
- && (oldop->op_private & OPpDEREF)
- ) {
- o->op_private |= OPpDEREFed;
- }
-
- case OP_SORT: {
- /* will point to RV2AV or PADAV op on LHS/RHS of assign */
- OP *oleft;
- OP *o2;
-
- /* check that RHS of sort is a single plain array */
- OP *oright = cUNOPo->op_first;
- if (!oright || oright->op_type != OP_PUSHMARK)
- break;
-
/* reverse sort ... can be optimised. */
if (!cUNOPo->op_sibling) {
/* Nothing follows us on the list. */
@@ -9786,37 +11388,6 @@
}
}
- /* make @a = sort @a act in-place */
-
- oright = cUNOPx(oright)->op_sibling;
- if (!oright)
- break;
- if (oright->op_type == OP_NULL) { /* skip sort block/sub */
- oright = cUNOPx(oright)->op_sibling;
- }
-
- oleft = is_inplace_av(o, oright);
- if (!oleft)
- break;
-
- /* transfer MODishness etc from LHS arg to RHS arg */
- oright->op_flags = oleft->op_flags;
- o->op_private |= OPpSORT_INPLACE;
-
- /* excise push->gv->rv2av->null->aassign */
- o2 = o->op_next->op_next;
- op_null(o2); /* PUSHMARK */
- o2 = o2->op_next;
- if (o2->op_type == OP_GV) {
- op_null(o2); /* GV */
- o2 = o2->op_next;
- }
- op_null(o2); /* RV2AV or PADAV */
- o2 = o2->op_next->op_next;
- op_null(o2); /* AASSIGN */
-
- o->op_next = o2->op_next;
-
break;
}
@@ -9823,35 +11394,10 @@
case OP_REVERSE: {
OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
OP *gvop = NULL;
- OP *oleft, *oright;
LISTOP *enter, *exlist;
- /* @a = reverse @a */
- if ((oright = cLISTOPo->op_first)
- && (oright->op_type == OP_PUSHMARK)
- && (oright = oright->op_sibling)
- && (oleft = is_inplace_av(o, oright))) {
- OP *o2;
-
- /* transfer MODishness etc from LHS arg to RHS arg */
- oright->op_flags = oleft->op_flags;
- o->op_private |= OPpREVERSE_INPLACE;
-
- /* excise push->gv->rv2av->null->aassign */
- o2 = o->op_next->op_next;
- op_null(o2); /* PUSHMARK */
- o2 = o2->op_next;
- if (o2->op_type == OP_GV) {
- op_null(o2); /* GV */
- o2 = o2->op_next;
- }
- op_null(o2); /* RV2AV or PADAV */
- o2 = o2->op_next->op_next;
- op_null(o2); /* AASSIGN */
-
- o->op_next = o2->op_next;
+ if (o->op_private & OPpSORT_INPLACE)
break;
- }
enter = (LISTOP *) o->op_next;
if (!enter)
@@ -9937,51 +11483,6 @@
break;
}
- case OP_SASSIGN: {
- OP *rv2gv;
- UNOP *refgen, *rv2cv;
- LISTOP *exlist;
-
- if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
- break;
-
- if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
- break;
-
- rv2gv = ((BINOP *)o)->op_last;
- if (!rv2gv || rv2gv->op_type != OP_RV2GV)
- break;
-
- refgen = (UNOP *)((BINOP *)o)->op_first;
-
- if (!refgen || refgen->op_type != OP_REFGEN)
- 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)
- break;
-
- rv2cv = (UNOP*)exlist->op_last;
-
- 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);
-
- o->op_private |= OPpASSIGN_CV_TO_GV;
- rv2gv->op_private |= OPpDONT_INIT_GV;
- rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
-
- break;
- }
-
-
case OP_QR:
case OP_MATCH:
if (!(cPMOP->op_pmflags & PMf_ONCE)) {
@@ -9989,6 +11490,42 @@
}
break;
+ case OP_RUNCV:
+ if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
+ SV *sv;
+ if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
+ else {
+ sv = newRV((SV *)PL_compcv);
+ sv_rvweaken(sv);
+ SvREADONLY_on(sv);
+ }
+ o->op_type = OP_CONST;
+ o->op_ppaddr = PL_ppaddr[OP_CONST];
+ o->op_flags |= OPf_SPECIAL;
+ cSVOPo->op_sv = sv;
+ }
+ break;
+
+ case OP_SASSIGN:
+ if (OP_GIMME(o,0) == G_VOID) {
+ OP *right = cBINOP->op_first;
+ if (right) {
+ OP *left = right->op_sibling;
+ if (left->op_type == OP_SUBSTR
+ && (left->op_private & 7) < 4) {
+ op_null(o);
+ cBINOP->op_first = left;
+ right->op_sibling =
+ cBINOPx(left)->op_first->op_sibling;
+ cBINOPx(left)->op_first->op_sibling = right;
+ left->op_private |= OPpSUBSTR_REPL_FIRST;
+ left->op_flags =
+ (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
+ }
+ }
+ }
+ break;
+
case OP_CUSTOM: {
Perl_cpeep_t cpeep =
XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
@@ -9998,6 +11535,7 @@
}
}
+ oldoldop = oldop;
oldop = o;
}
LEAVE;
@@ -10004,7 +11542,7 @@
}
void
-Perl_peep(pTHX_ register OP *o)
+Perl_peep(pTHX_ OP *o)
{
CALL_RPEEP(o);
}
@@ -10093,6 +11631,291 @@
Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
}
+/*
+=head1 Functions in file op.c
+
+=for apidoc core_prototype
+This function assigns the prototype of the named core function to C<sv>, or
+to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
+NULL if the core function has no prototype. C<code> is a code as returned
+by C<keyword()>. It must not be equal to 0 or -KEY_CORE.
+
+=cut
+*/
+
+SV *
+Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
+ int * const opnum)
+{
+ int i = 0, n = 0, seen_question = 0, defgv = 0;
+ I32 oa;
+#define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
+ char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
+ bool nullret = FALSE;
+
+ PERL_ARGS_ASSERT_CORE_PROTOTYPE;
+
+ assert (code && code != -KEY_CORE);
+
+ if (!sv) sv = sv_newmortal();
+
+#define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
+
+ switch (code < 0 ? -code : code) {
+ case KEY_and : case KEY_chop: case KEY_chomp:
+ case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
+ case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
+ case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
+ case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
+ case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
+ case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
+ case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
+ case KEY_x : case KEY_xor :
+ if (!opnum) return NULL; nullret = TRUE; goto findopnum;
+ case KEY_glob: retsetpvs("_;", OP_GLOB);
+ case KEY_keys: retsetpvs("+", OP_KEYS);
+ case KEY_values: retsetpvs("+", OP_VALUES);
+ case KEY_each: retsetpvs("+", OP_EACH);
+ case KEY_push: retsetpvs("+@", OP_PUSH);
+ case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
+ case KEY_pop: retsetpvs(";+", OP_POP);
+ case KEY_shift: retsetpvs(";+", OP_SHIFT);
+ case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
+ case KEY_splice:
+ retsetpvs("+;$$@", OP_SPLICE);
+ case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
+ retsetpvs("", 0);
+ case KEY_evalbytes:
+ name = "entereval"; break;
+ case KEY_readpipe:
+ name = "backtick";
+ }
+
+#undef retsetpvs
+
+ findopnum:
+ while (i < MAXO) { /* The slow way. */
+ if (strEQ(name, PL_op_name[i])
+ || strEQ(name, PL_op_desc[i]))
+ {
+ if (nullret) { assert(opnum); *opnum = i; return NULL; }
+ goto found;
+ }
+ i++;
+ }
+ return NULL;
+ found:
+ defgv = PL_opargs[i] & OA_DEFGV;
+ oa = PL_opargs[i] >> OASHIFT;
+ while (oa) {
+ if (oa & OA_OPTIONAL && !seen_question && (
+ !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
+ )) {
+ seen_question = 1;
+ str[n++] = ';';
+ }
+ if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
+ && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
+ /* But globs are already references (kinda) */
+ && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
+ ) {
+ str[n++] = '\\';
+ }
+ if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
+ && !scalar_mod_type(NULL, i)) {
+ str[n++] = '[';
+ str[n++] = '$';
+ str[n++] = '@';
+ str[n++] = '%';
+ if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
+ str[n++] = '*';
+ str[n++] = ']';
+ }
+ else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
+ if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
+ str[n-1] = '_'; defgv = 0;
+ }
+ oa = oa >> 4;
+ }
+ if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
+ str[n++] = '\0';
+ sv_setpvn(sv, str, n - 1);
+ if (opnum) *opnum = i;
+ return sv;
+}
+
+OP *
+Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
+ const int opnum)
+{
+ OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
+ OP *o;
+
+ PERL_ARGS_ASSERT_CORESUB_OP;
+
+ switch(opnum) {
+ case 0:
+ return op_append_elem(OP_LINESEQ,
+ argop,
+ newSLICEOP(0,
+ newSVOP(OP_CONST, 0, newSViv(-code % 3)),
+ newOP(OP_CALLER,0)
+ )
+ );
+ case OP_SELECT: /* which represents OP_SSELECT as well */
+ if (code)
+ return newCONDOP(
+ 0,
+ newBINOP(OP_GT, 0,
+ newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
+ newSVOP(OP_CONST, 0, newSVuv(1))
+ ),
+ coresub_op(newSVuv((UV)OP_SSELECT), 0,
+ OP_SSELECT),
+ coresub_op(coreargssv, 0, OP_SELECT)
+ );
+ /* FALL THROUGH */
+ default:
+ switch (PL_opargs[opnum] & OA_CLASS_MASK) {
+ case OA_BASEOP:
+ return op_append_elem(
+ OP_LINESEQ, argop,
+ newOP(opnum,
+ opnum == OP_WANTARRAY || opnum == OP_RUNCV
+ ? OPpOFFBYONE << 8 : 0)
+ );
+ case OA_BASEOP_OR_UNOP:
+ if (opnum == OP_ENTEREVAL) {
+ o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
+ if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
+ }
+ else o = newUNOP(opnum,0,argop);
+ if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
+ else {
+ onearg:
+ if (is_handle_constructor(o, 1))
+ argop->op_private |= OPpCOREARGS_DEREF1;
+ if (scalar_mod_type(NULL, opnum))
+ argop->op_private |= OPpCOREARGS_SCALARMOD;
+ }
+ return o;
+ default:
+ o = convert(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
+ if (is_handle_constructor(o, 2))
+ argop->op_private |= OPpCOREARGS_DEREF2;
+ if (opnum == OP_SUBSTR) {
+ o->op_private |= OPpMAYBE_LVSUB;
+ return o;
+ }
+ else goto onearg;
+ }
+ }
+}
+
+void
+Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
+ SV * const *new_const_svp)
+{
+ const char *hvname;
+ bool is_const = !!CvCONST(old_cv);
+ SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
+
+ PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
+
+ if (is_const && new_const_svp && old_const_sv == *new_const_svp)
+ return;
+ /* They are 2 constant subroutines generated from
+ the same constant. This probably means that
+ they are really the "same" proxy subroutine
+ instantiated in 2 places. Most likely this is
+ when a constant is exported twice. Don't warn.
+ */
+ if (
+ (ckWARN(WARN_REDEFINE)
+ && !(
+ CvGV(old_cv) && GvSTASH(CvGV(old_cv))
+ && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
+ && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
+ strEQ(hvname, "autouse"))
+ )
+ )
+ || (is_const
+ && ckWARN_d(WARN_REDEFINE)
+ && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
+ )
+ )
+ Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
+ is_const
+ ? "Constant subroutine %"SVf" redefined"
+ : "Subroutine %"SVf" redefined",
+ name);
+}
+
+/*
+=head1 Hook manipulation
+
+These functions provide convenient and thread-safe means of manipulating
+hook variables.
+
+=cut
+*/
+
+/*
+=for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
+
+Puts a C function into the chain of check functions for a specified op
+type. This is the preferred way to manipulate the L</PL_check> array.
+I<opcode> specifies which type of op is to be affected. I<new_checker>
+is a pointer to the C function that is to be added to that opcode's
+check chain, and I<old_checker_p> points to the storage location where a
+pointer to the next function in the chain will be stored. The value of
+I<new_pointer> is written into the L</PL_check> array, while the value
+previously stored there is written to I<*old_checker_p>.
+
+L</PL_check> is global to an entire process, and a module wishing to
+hook op checking may find itself invoked more than once per process,
+typically in different threads. To handle that situation, this function
+is idempotent. The location I<*old_checker_p> must initially (once
+per process) contain a null pointer. A C variable of static duration
+(declared at file scope, typically also marked C<static> to give
+it internal linkage) will be implicitly initialised appropriately,
+if it does not have an explicit initialiser. This function will only
+actually modify the check chain if it finds I<*old_checker_p> to be null.
+This function is also thread safe on the small scale. It uses appropriate
+locking to avoid race conditions in accessing L</PL_check>.
+
+When this function is called, the function referenced by I<new_checker>
+must be ready to be called, except for I<*old_checker_p> being unfilled.
+In a threading situation, I<new_checker> may be called immediately,
+even before this function has returned. I<*old_checker_p> will always
+be appropriately set before I<new_checker> is called. If I<new_checker>
+decides not to do anything special with an op that it is given (which
+is the usual case for most uses of op check hooking), it must chain the
+check function referenced by I<*old_checker_p>.
+
+If you want to influence compilation of calls to a specific subroutine,
+then use L</cv_set_call_checker> rather than hooking checking of all
+C<entersub> ops.
+
+=cut
+*/
+
+void
+Perl_wrap_op_checker(pTHX_ Optype opcode,
+ Perl_check_t new_checker, Perl_check_t *old_checker_p)
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
+ if (*old_checker_p) return;
+ OP_CHECK_MUTEX_LOCK;
+ if (!*old_checker_p) {
+ *old_checker_p = PL_check[opcode];
+ PL_check[opcode] = new_checker;
+ }
+ OP_CHECK_MUTEX_UNLOCK;
+}
+
#include "XSUB.h"
/* Efficient sub that returns a constant scalar value. */
@@ -10122,8 +11945,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/op.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/op.h
===================================================================
--- trunk/contrib/perl/op.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/op.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -19,17 +19,11 @@
* op_type The type of the operation.
* op_opt Whether or not the op has been optimised by the
* peephole optimiser.
- *
- * See the comments in S_clear_yystack() for more
- * details on the following three flags:
- *
- * op_latefree tell op_free() to clear this op (and free any kids)
- * but not yet deallocate the struct. This means that
- * the op may be safely op_free()d multiple times
- * op_latefreed an op_latefree op has been op_free()d
- * op_attached this op (sub)tree has been attached to a CV
- *
- * op_spare three spare bits!
+ * op_slabbed allocated via opslab
+ * op_static tell op_free() to skip PerlMemShared_free(), when
+ * !op_slabbed.
+ * op_savefree on savestack via SAVEFREEOP
+ * op_spare Three spare bits
* op_flags Flags common to all operations. See OPf_* below.
* op_private Flags peculiar to a particular operation (BUT,
* by default, set to the number of children until
@@ -59,9 +53,9 @@
PADOFFSET op_targ; \
PERL_BITFIELD16 op_type:9; \
PERL_BITFIELD16 op_opt:1; \
- PERL_BITFIELD16 op_latefree:1; \
- PERL_BITFIELD16 op_latefreed:1; \
- PERL_BITFIELD16 op_attached:1; \
+ PERL_BITFIELD16 op_slabbed:1; \
+ PERL_BITFIELD16 op_savefree:1; \
+ PERL_BITFIELD16 op_static:1; \
PERL_BITFIELD16 op_spare:3; \
U8 op_flags; \
U8 op_private;
@@ -72,11 +66,9 @@
then all the other bit-fields before/after it should change their
types too to let VC pack them into the same 4 byte integer.*/
+/* for efficiency, requires OPf_WANT_VOID == G_VOID etc */
#define OP_GIMME(op,dfl) \
- (((op)->op_flags & OPf_WANT) == OPf_WANT_VOID ? G_VOID : \
- ((op)->op_flags & OPf_WANT) == OPf_WANT_SCALAR ? G_SCALAR : \
- ((op)->op_flags & OPf_WANT) == OPf_WANT_LIST ? G_ARRAY : \
- dfl)
+ (((op)->op_flags & OPf_WANT) ? ((op)->op_flags & OPf_WANT) : dfl)
#define OP_GIMME_REVERSE(flags) ((flags) & G_WANT)
@@ -123,7 +115,7 @@
/* On OP_ENTERSUB || OP_NULL, saw a "do". */
/* On OP_EXISTS, treat av as av, not avhv. */
/* On OP_(ENTER|LEAVE)EVAL, don't clear $@ */
- /* On pushre, rx is used as part of split, e.g. split " " */
+ /* On pushre, rx is used as part of split, e.g. split " " */
/* On regcomp, "use re 'eval'" was in scope */
/* On OP_READLINE, was <$filehandle> */
/* On RV2[ACGHS]V, don't create GV--in
@@ -130,14 +122,12 @@
defined()*/
/* On OP_DBSTATE, indicates breakpoint
* (runtime property) */
- /* On OP_AELEMFAST, indicates pad var */
/* On OP_REQUIRE, was seen as CORE::require */
- /* On OP_ENTERWHEN, there's no condition */
- /* On OP_BREAK, an implicit break */
+ /* On OP_(ENTER|LEAVE)WHEN, there's
+ no condition */
/* On OP_SMARTMATCH, an implicit smartmatch */
/* On OP_ANONHASH and OP_ANONLIST, create a
reference to the new anon hash or array */
- /* On OP_ENTER, store caller context */
/* On OP_HELEM and OP_HSLICE, localization will be followed
by assignment, so do not wipe the target if it is special
(e.g. a glob or a magic SV) */
@@ -146,7 +136,11 @@
that was optimised away, so it should
not be bound via =~ */
/* On OP_CONST, from a constant CV */
- /* On OP_GLOB, use Perl glob function */
+ /* On OP_GLOB, two meanings:
+ - Before ck_glob, called as CORE::glob
+ - After ck_glob, use Perl glob function
+ */
+ /* On OP_PADRANGE, push @_ */
/* old names; don't use in new code, but don't break them, either */
#define OPf_LIST OPf_WANT_LIST
@@ -159,12 +153,19 @@
: G_SCALAR) \
: dowantarray())
-/* NOTE: OP_NEXTSTATE and OP_DBSTATE (i.e. COPs) carry lower
- * bits of PL_hints in op_private */
+/* Lower bits of op_private often carry the number of arguments, as
+ * set by newBINOP, newUNOP and ck_fun */
+/* NOTE: OP_NEXTSTATE and OP_DBSTATE (i.e. COPs) carry NATIVE_HINTS
+ * in op_private */
+
/* Private for lvalues */
#define OPpLVAL_INTRO 128 /* Lvalue must be localized or lvalue sub */
+/* Private for OPs with TARGLEX */
+ /* (lower bits may carry MAXARG) */
+#define OPpTARGET_MY 16 /* Target is PADMY. */
+
/* Private for OP_LEAVE, OP_LEAVESUB, OP_LEAVESUBLV and OP_LEAVEWRITE */
#define OPpREFCOUNTED 64 /* op_targ carries a refcount */
@@ -175,7 +176,7 @@
#define OPpASSIGN_BACKWARDS 64 /* Left & right switched. */
#define OPpASSIGN_CV_TO_GV 128 /* Possible optimisation for constants. */
-/* Private for OP_MATCH and OP_SUBST{,CONST} */
+/* Private for OP_MATCH and OP_SUBST{,CONT} */
#define OPpRUNTIME 64 /* Pattern coming in on the stack */
/* Private for OP_TRANS */
@@ -197,40 +198,55 @@
#define OPpDEREF_AV 32 /* Want ref to AV. */
#define OPpDEREF_HV 64 /* Want ref to HV. */
#define OPpDEREF_SV (32|64) /* Want ref to SV. */
-/* Private for OP_RV2SV, OP_RV2AV, OP_RV2AV */
-#define OPpDEREFed 4 /* prev op was OPpDEREF */
+
/* OP_ENTERSUB only */
#define OPpENTERSUB_DB 16 /* Debug subroutine. */
-#define OPpENTERSUB_HASTARG 32 /* Called from OP tree. */
-#define OPpENTERSUB_NOMOD 64 /* Immune to op_lvalue() for :attrlist. */
- /* OP_ENTERSUB and OP_RV2CV only */
+#define OPpENTERSUB_HASTARG 4 /* Called from OP tree. */
+#define OPpENTERSUB_INARGS 1 /* Lval used as arg to a sub. */
+/* used by OPpDEREF (32|64) */
+/* used by HINT_STRICT_SUBS 2 */
+ /* Mask for OP_ENTERSUB flags, the absence of which must be propagated
+ in dynamic context */
+#define OPpENTERSUB_LVAL_MASK (OPpLVAL_INTRO|OPpENTERSUB_INARGS)
+
+ /* OP_RV2CV only */
#define OPpENTERSUB_AMPER 8 /* Used & form to call. */
#define OPpENTERSUB_NOPAREN 128 /* bare sub call (without parens) */
-#define OPpENTERSUB_INARGS 4 /* Lval used as arg to a sub. */
+#define OPpMAY_RETURN_CONSTANT 1 /* If a constant sub, return the constant */
+
/* OP_GV only */
#define OPpEARLY_CV 32 /* foo() called before sub foo was parsed */
/* OP_?ELEM only */
#define OPpLVAL_DEFER 16 /* Defer creation of array/hash elem */
- /* OP_RV2?V, OP_GVSV, OP_ENTERITER only */
+ /* OP_RV2[SAH]V, OP_GVSV, OP_ENTERITER only */
#define OPpOUR_INTRO 16 /* Variable was in an our() */
- /* OP_RV2[AGH]V, OP_PAD[AH]V, OP_[AH]ELEM */
+ /* OP_RV2[AGH]V, OP_PAD[AH]V, OP_[AH]ELEM, OP_[AH]SLICE OP_AV2ARYLEN,
+ OP_R?KEYS, OP_SUBSTR, OP_POS, OP_VEC */
#define OPpMAYBE_LVSUB 8 /* We might be an lvalue to return */
+ /* OP_RV2HV and OP_PADHV */
+#define OPpTRUEBOOL 32 /* %hash in (%hash || $foo) in
+ void context */
+#define OPpMAYBE_TRUEBOOL 64 /* %hash in (%hash || $foo) where
+ cx is not known till run time */
+
+ /* OP_SUBSTR only */
+#define OPpSUBSTR_REPL_FIRST 16 /* 1st arg is replacement string */
+
/* OP_PADSV only */
#define OPpPAD_STATE 16 /* is a "state" pad */
/* for OP_RV2?V, lower bits carry hints (currently only HINT_STRICT_REFS) */
+ /* OP_PADRANGE only */
+ /* bit 7 is OPpLVAL_INTRO */
+#define OPpPADRANGE_COUNTMASK 127 /* bits 6..0 hold target range, */
+#define OPpPADRANGE_COUNTSHIFT 7 /* 7 bits in total */
+
/* OP_RV2GV only */
#define OPpDONT_INIT_GV 4 /* Call gv_fetchpv with GV_NOINIT */
/* (Therefore will return whatever is currently in the symbol table, not
guaranteed to be a PVGV) */
+#define OPpALLOW_FAKE 16 /* OK to return fake glob */
- /* OP_RV2CV only */
-#define OPpMAY_RETURN_CONSTANT 1 /* If a constant sub, return the constant */
-
-/* Private for OPs with TARGLEX */
- /* (lower bits may carry MAXARG) */
-#define OPpTARGET_MY 16 /* Target is PADMY. */
-
/* Private for OP_ENTERITER and OP_ITER */
#define OPpITER_REVERSED 4 /* for (reverse ...) */
#define OPpITER_DEF 8 /* for $_ or for my $_ */
@@ -240,9 +256,8 @@
#define OPpCONST_SHORTCIRCUIT 4 /* eg the constant 5 in (5 || foo) */
#define OPpCONST_STRICT 8 /* bareword subject to strict 'subs' */
#define OPpCONST_ENTERED 16 /* Has been entered as symbol. */
-#define OPpCONST_ARYBASE 32 /* Was a $[ translated to constant. */
#define OPpCONST_BARE 64 /* Was a bare word (filehandle?). */
-#define OPpCONST_WARNING 128 /* Was a $^W translated to constant. */
+#define OPpCONST_FOLDED 128 /* Result of constant folding */
/* Private for OP_FLIP/FLOP */
#define OPpFLIP_LINENUM 64 /* Range arg potentially a line num. */
@@ -281,7 +296,9 @@
/* Private for OP_FTXXX */
#define OPpFT_ACCESS 2 /* use filetest 'access' */
-#define OPpFT_STACKED 4 /* stacked filetest, as in "-f -x $f" */
+#define OPpFT_STACKED 4 /* stacked filetest, as "-f" in "-f -x $f" */
+#define OPpFT_STACKING 8 /* stacking filetest, as "-x" in "-f -x $f" */
+#define OPpFT_AFTER_t 16 /* previous op was -t */
/* Private for OP_(MAP|GREP)(WHILE|START) */
#define OPpGREP_LEX 2 /* iterate over lexical $_ */
@@ -288,7 +305,25 @@
/* Private for OP_ENTEREVAL */
#define OPpEVAL_HAS_HH 2 /* Does it have a copy of %^H */
+#define OPpEVAL_UNICODE 4
+#define OPpEVAL_BYTES 8
+#define OPpEVAL_COPHH 16 /* Construct %^H from cop hints */
+#define OPpEVAL_RE_REPARSING 32 /* eval_sv(..., G_RE_REPARSING) */
+/* Private for OP_CALLER, OP_WANTARRAY and OP_RUNCV */
+#define OPpOFFBYONE 128 /* Treat caller(1) as caller(2) */
+
+/* Private for OP_COREARGS */
+/* These must not conflict with OPpDONT_INIT_GV or OPpALLOW_FAKE.
+ See pp.c:S_rv2gv. */
+#define OPpCOREARGS_DEREF1 1 /* Arg 1 is a handle constructor */
+#define OPpCOREARGS_DEREF2 2 /* Arg 2 is a handle constructor */
+#define OPpCOREARGS_SCALARMOD 64 /* \$ rather than \[$@%*] */
+#define OPpCOREARGS_PUSHMARK 128 /* Call pp_pushmark */
+
+/* Private for OP_(LAST|REDO|NEXT|GOTO|DUMP) */
+#define OPpPV_IS_UTF8 128 /* label is in UTF8 */
+
struct op {
BASEOP
};
@@ -337,11 +372,12 @@
union {
OP * op_pmreplstart; /* Only used in OP_SUBST */
#ifdef USE_ITHREADS
- char * op_pmstashpv; /* Only used in OP_MATCH, with PMf_ONCE set */
+ PADOFFSET op_pmstashoff; /* Only used in OP_MATCH, with PMf_ONCE set */
#else
HV * op_pmstash;
#endif
} op_pmstashstartu;
+ OP * op_code_list; /* list of (?{}) code blocks */
};
#ifdef USE_ITHREADS
@@ -377,10 +413,7 @@
* OP_MATCH and OP_QR */
#define PMf_ONCE (1<<(PMf_BASE_SHIFT+1))
-/* replacement contains variables */
-#define PMf_MAYBE_CONST (1<<(PMf_BASE_SHIFT+2))
-
-/* PMf_ONCE has matched successfully. Not used under threading. */
+/* PMf_ONCE, i.e. ?pat?, has matched successfully. Not used under threading. */
#define PMf_USED (1<<(PMf_BASE_SHIFT+3))
/* subst replacement is constant */
@@ -400,28 +433,32 @@
/* Return substituted string instead of modifying it. */
#define PMf_NONDESTRUCT (1<<(PMf_BASE_SHIFT+9))
-#if PMf_BASE_SHIFT+9 > 31
+/* the pattern has a CV attached (currently only under qr/...(?{}).../) */
+#define PMf_HAS_CV (1<<(PMf_BASE_SHIFT+10))
+
+/* op_code_list is private; don't free it etc. It may well point to
+ * code within another sub, with different pad etc */
+#define PMf_CODELIST_PRIVATE (1<<(PMf_BASE_SHIFT+11))
+
+/* the PMOP is a QR (we should be able to detect that from the op type,
+ * but the regex compilation API passes just the pm flags, not the op
+ * itself */
+#define PMf_IS_QR (1<<(PMf_BASE_SHIFT+12))
+#define PMf_USE_RE_EVAL (1<<(PMf_BASE_SHIFT+13)) /* use re'eval' in scope */
+
+#if PMf_BASE_SHIFT+13 > 31
# error Too many PMf_ bits used. See above and regnodes.h for any spare in middle
#endif
#ifdef USE_ITHREADS
-# define PmopSTASHPV(o) \
- (((o)->op_pmflags & PMf_ONCE) ? (o)->op_pmstashstartu.op_pmstashpv : NULL)
-# if defined (DEBUGGING) && defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
-# define PmopSTASHPV_set(o,pv) ({ \
- assert((o)->op_pmflags & PMf_ONCE); \
- ((o)->op_pmstashstartu.op_pmstashpv = savesharedpv(pv)); \
- })
-# else
-# define PmopSTASHPV_set(o,pv) \
- ((o)->op_pmstashstartu.op_pmstashpv = savesharedpv(pv))
-# endif
-# define PmopSTASH(o) (PmopSTASHPV(o) \
- ? gv_stashpv((o)->op_pmstashstartu.op_pmstashpv,GV_ADD) : NULL)
-# define PmopSTASH_set(o,hv) PmopSTASHPV_set(o, ((hv) ? HvNAME_get(hv) : NULL))
-# define PmopSTASH_free(o) PerlMemShared_free(PmopSTASHPV(o))
-
+# define PmopSTASH(o) ((o)->op_pmflags & PMf_ONCE \
+ ? PL_stashpad[(o)->op_pmstashstartu.op_pmstashoff] \
+ : NULL)
+# define PmopSTASH_set(o,hv) \
+ (assert_((o)->op_pmflags & PMf_ONCE) \
+ (o)->op_pmstashstartu.op_pmstashoff = \
+ (hv) ? alloccopstash(hv) : 0)
#else
# define PmopSTASH(o) \
(((o)->op_pmflags & PMf_ONCE) ? (o)->op_pmstashstartu.op_pmstash : NULL)
@@ -433,13 +470,10 @@
# else
# define PmopSTASH_set(o,hv) ((o)->op_pmstashstartu.op_pmstash = (hv))
# endif
-# define PmopSTASHPV(o) (PmopSTASH(o) ? HvNAME_get(PmopSTASH(o)) : NULL)
+#endif
+#define PmopSTASHPV(o) (PmopSTASH(o) ? HvNAME_get(PmopSTASH(o)) : NULL)
/* op_pmstashstartu.op_pmstash is not refcounted */
-# define PmopSTASHPV_set(o,pv) PmopSTASH_set((o), gv_stashpv(pv,GV_ADD))
-/* Note that if this becomes non-empty, then S_forget_pmop in op.c will need
- changing */
-# define PmopSTASH_free(o)
-#endif
+#define PmopSTASHPV_set(o,pv) PmopSTASH_set((o), gv_stashpv(pv,GV_ADD))
struct svop {
BASEOP
@@ -514,7 +548,8 @@
# define cGVOPx_gv(o) ((GV*)PAD_SVl(cPADOPx(o)->op_padix))
# define IS_PADGV(v) (v && SvTYPE(v) == SVt_PVGV && isGV_with_GP(v) \
&& GvIN_PAD(v))
-# define IS_PADCONST(v) (v && SvREADONLY(v))
+# define IS_PADCONST(v) \
+ (v && (SvREADONLY(v) || (SvIsCOW(v) && !SvLEN(v))))
# define cSVOPx_sv(v) (cSVOPx(v)->op_sv \
? cSVOPx(v)->op_sv : PAD_SVl((v)->op_targ))
# define cSVOPx_svp(v) (cSVOPx(v)->op_sv \
@@ -538,7 +573,7 @@
# define Nullop ((OP*)NULL)
#endif
-/* Lowest byte-and-a-bit of PL_opargs */
+/* Lowest byte of PL_opargs */
#define OA_MARK 1
#define OA_FOLDCONST 2
#define OA_RETSCALAR 4
@@ -642,7 +677,7 @@
/* no longer used anywhere in core */
#ifndef PERL_CORE
#define cv_ckproto(cv, gv, p) \
- cv_ckproto_len((cv), (gv), (p), (p) ? strlen(p) : 0)
+ cv_ckproto_len_flags((cv), (gv), (p), (p) ? strlen(p) : 0, 0)
#endif
#ifdef PERL_CORE
@@ -653,19 +688,66 @@
#include "reentr.h"
#endif
-#if defined(PL_OP_SLAB_ALLOC)
#define NewOp(m,var,c,type) \
(var = (type *) Perl_Slab_Alloc(aTHX_ c*sizeof(type)))
#define NewOpSz(m,var,size) \
(var = (OP *) Perl_Slab_Alloc(aTHX_ size))
#define FreeOp(p) Perl_Slab_Free(aTHX_ p)
-#else
-#define NewOp(m, var, c, type) \
- (var = (MEM_WRAP_CHECK_(c,type) \
- (type*)PerlMemShared_calloc(c, sizeof(type))))
-#define NewOpSz(m, var, size) \
- (var = (OP*)PerlMemShared_calloc(1, size))
-#define FreeOp(p) PerlMemShared_free(p)
+
+/*
+ * The per-CV op slabs consist of a header (the opslab struct) and a bunch
+ * of space for allocating op slots, each of which consists of two pointers
+ * followed by an op. The first pointer points to the next op slot. The
+ * second points to the slab. At the end of the slab is a null pointer,
+ * so that slot->opslot_next - slot can be used to determine the size
+ * of the op.
+ *
+ * Each CV can have multiple slabs; opslab_next points to the next slab, to
+ * form a chain. All bookkeeping is done on the first slab, which is where
+ * all the op slots point.
+ *
+ * Freed ops are marked as freed and attached to the freed chain
+ * via op_next pointers.
+ *
+ * When there is more than one slab, the second slab in the slab chain is
+ * assumed to be the one with free space available. It is used when allo-
+ * cating an op if there are no freed ops available or big enough.
+ */
+
+#ifdef PERL_CORE
+struct opslot {
+ /* keep opslot_next first */
+ OPSLOT * opslot_next; /* next slot */
+ OPSLAB * opslot_slab; /* owner */
+ OP opslot_op; /* the op itself */
+};
+
+struct opslab {
+ OPSLOT * opslab_first; /* first op in this slab */
+ OPSLAB * opslab_next; /* next slab */
+ OP * opslab_freed; /* chain of freed ops */
+ size_t opslab_refcnt; /* number of ops */
+# ifdef PERL_DEBUG_READONLY_OPS
+ U16 opslab_size; /* size of slab in pointers */
+ bool opslab_readonly;
+# endif
+ OPSLOT opslab_slots; /* slots begin here */
+};
+
+# define OPSLOT_HEADER STRUCT_OFFSET(OPSLOT, opslot_op)
+# define OPSLOT_HEADER_P (OPSLOT_HEADER/sizeof(I32 *))
+# define OpSLOT(o) (assert_(o->op_slabbed) \
+ (OPSLOT *)(((char *)o)-OPSLOT_HEADER))
+# define OpSLAB(o) OpSLOT(o)->opslot_slab
+# define OpslabREFCNT_dec(slab) \
+ (((slab)->opslab_refcnt == 1) \
+ ? opslab_free_nopad(slab) \
+ : (void)--(slab)->opslab_refcnt)
+ /* Variant that does not null out the pads */
+# define OpslabREFCNT_dec_padok(slab) \
+ (((slab)->opslab_refcnt == 1) \
+ ? opslab_free(slab) \
+ : (void)--(slab)->opslab_refcnt)
#endif
struct block_hooks {
@@ -763,6 +845,12 @@
#define RV2CVOPCV_MARK_EARLY 0x00000001
#define RV2CVOPCV_RETURN_NAME_GV 0x00000002
+#define op_lvalue(op,t) Perl_op_lvalue_flags(aTHX_ op,t,0)
+
+/* flags for op_lvalue_flags */
+
+#define OP_LVALUE_NO_CROAK 1
+
/*
=head1 Custom Operators
@@ -955,11 +1043,27 @@
*/
/*
+=head1 Hook manipulation
+*/
+
+#ifdef USE_ITHREADS
+# define OP_CHECK_MUTEX_INIT MUTEX_INIT(&PL_check_mutex)
+# define OP_CHECK_MUTEX_LOCK MUTEX_LOCK(&PL_check_mutex)
+# define OP_CHECK_MUTEX_UNLOCK MUTEX_UNLOCK(&PL_check_mutex)
+# define OP_CHECK_MUTEX_TERM MUTEX_DESTROY(&PL_check_mutex)
+#else
+# define OP_CHECK_MUTEX_INIT NOOP
+# define OP_CHECK_MUTEX_LOCK NOOP
+# define OP_CHECK_MUTEX_UNLOCK NOOP
+# define OP_CHECK_MUTEX_TERM NOOP
+#endif
+
+/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/op.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/op_reg_common.h
===================================================================
--- trunk/contrib/perl/op_reg_common.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/op_reg_common.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -2,7 +2,7 @@
*
* Definitions common to by op.h and regexp.h
*
- * Copyright (C) 2010 by Larry Wall and others
+ * Copyright (C) 2010, 2011 by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
@@ -27,6 +27,7 @@
* RXf_PMf_STD_PMMOD_SHIFT, followed by the p. See STD_PAT_MODS and
* INT_PAT_MODS in regexp.h for the reason contiguity is needed */
/* Make sure to update lib/re.pm when changing these! */
+/* Make sure you keep the pure PMf_ versions below in sync */
#define RXf_PMf_MULTILINE (1 << (RXf_PMf_STD_PMMOD_SHIFT+0)) /* /m */
#define RXf_PMf_SINGLELINE (1 << (RXf_PMf_STD_PMMOD_SHIFT+1)) /* /s */
#define RXf_PMf_FOLD (1 << (RXf_PMf_STD_PMMOD_SHIFT+2)) /* /i */
@@ -36,7 +37,9 @@
/* The character set for the regex is stored in a field of more than one bit
* using an enum, for reasons of compactness and to ensure that the options are
* mutually exclusive */
-/* Make sure to update ext/re/re.pm when changing this! */
+/* Make sure to update ext/re/re.pm and regcomp.sym (as these are used as
+ * offsets for various node types, like POSIXD vs POSIXL, etc) when changing
+ * this! */
typedef enum {
REGEX_DEPENDS_CHARSET = 0,
REGEX_LOCALE_CHARSET,
@@ -48,9 +51,9 @@
#define _RXf_PMf_CHARSET_SHIFT ((RXf_PMf_STD_PMMOD_SHIFT)+5)
#define RXf_PMf_CHARSET (7 << (_RXf_PMf_CHARSET_SHIFT)) /* 3 bits */
-/* embed.pl doesn't yet know how to handle static inline functions, so
- manually decorate them here with gcc-style attributes.
-*/
+/* Manually decorate these functions here with gcc-style attributes just to
+ * avoid making the regex_charset typedef global, which it would need to be for
+ * proto.h to understand it */
PERL_STATIC_INLINE void
set_regex_charset(U32 * const flags, const regex_charset cs)
__attribute__nonnull__(1);
@@ -77,14 +80,28 @@
return (regex_charset) ((flags & RXf_PMf_CHARSET) >> _RXf_PMf_CHARSET_SHIFT);
}
+#define _RXf_PMf_SHIFT_COMPILETIME (RXf_PMf_STD_PMMOD_SHIFT+8)
+
+/*
+ Set in Perl_pmruntime if op_flags & OPf_SPECIAL, i.e. split. Will
+ be used by regex engines to check whether they should set
+ RXf_SKIPWHITE
+*/
+#define RXf_PMf_SPLIT (1<<(RXf_PMf_STD_PMMOD_SHIFT+8))
+
/* Next available bit after the above. Name begins with '_' so won't be
* exported by B */
-#define _RXf_PMf_SHIFT_NEXT (RXf_PMf_STD_PMMOD_SHIFT+8)
+#define _RXf_PMf_SHIFT_NEXT (RXf_PMf_STD_PMMOD_SHIFT+9)
/* Mask of the above bits. These need to be transferred from op_pmflags to
* re->extflags during compilation */
-#define RXf_PMf_COMPILETIME (RXf_PMf_MULTILINE|RXf_PMf_SINGLELINE|RXf_PMf_CHARSET|RXf_PMf_FOLD|RXf_PMf_EXTENDED|RXf_PMf_KEEPCOPY)
+#define RXf_PMf_COMPILETIME (RXf_PMf_MULTILINE|RXf_PMf_SINGLELINE|RXf_PMf_FOLD|RXf_PMf_EXTENDED|RXf_PMf_KEEPCOPY|RXf_PMf_CHARSET)
+#define RXf_PMf_FLAGCOPYMASK (RXf_PMf_MULTILINE|RXf_PMf_SINGLELINE|RXf_PMf_FOLD|RXf_PMf_EXTENDED|RXf_PMf_KEEPCOPY|RXf_PMf_CHARSET|RXf_PMf_SPLIT)
+#if RXf_PMf_COMPILETIME > 255
+# error RXf_PMf_COMPILETIME wont fit in U8 flags field of eval node
+#endif
+
/* These copies need to be numerical or defsubs_h.PL won't know about them. */
#define PMf_MULTILINE 1<<0
#define PMf_SINGLELINE 1<<1
@@ -91,18 +108,18 @@
#define PMf_FOLD 1<<2
#define PMf_EXTENDED 1<<3
#define PMf_KEEPCOPY 1<<4
+#define PMf_CHARSET 7<<5
+#define PMf_SPLIT 1<<8
-#if PMf_MULTILINE != RXf_PMf_MULTILINE || PMf_SINGLELINE != RXf_PMf_SINGLELINE || PMf_FOLD != RXf_PMf_FOLD || PMf_EXTENDED != RXf_PMf_EXTENDED || PMf_KEEPCOPY != RXf_PMf_KEEPCOPY
+#if PMf_MULTILINE != RXf_PMf_MULTILINE || PMf_SINGLELINE != RXf_PMf_SINGLELINE || PMf_FOLD != RXf_PMf_FOLD || PMf_EXTENDED != RXf_PMf_EXTENDED || PMf_KEEPCOPY != RXf_PMf_KEEPCOPY || PMf_SPLIT != RXf_PMf_SPLIT || PMf_CHARSET != RXf_PMf_CHARSET
# error RXf_PMf defines are wrong
#endif
-#define PMf_COMPILETIME RXf_PMf_COMPILETIME
-
/* Error check that haven't left something out of this. This isn't done
* directly in the #define because doing so confuses regcomp.pl.
* (2**n - 1) is n 1 bits, so the below gets the contiguous bits between the
* beginning and ending shifts */
-#if RXf_PMf_COMPILETIME != (((1 << (_RXf_PMf_SHIFT_NEXT))-1) \
+#if RXf_PMf_COMPILETIME != (((1 << (_RXf_PMf_SHIFT_COMPILETIME))-1) \
& (~((1 << RXf_PMf_STD_PMMOD_SHIFT)-1)))
# error RXf_PMf_COMPILETIME is invalid
#endif
Property changes on: trunk/contrib/perl/op_reg_common.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/opcode.h
===================================================================
--- trunk/contrib/perl/opcode.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/opcode.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -18,12 +18,15 @@
#define Perl_pp_scalar Perl_pp_null
#define Perl_pp_padany Perl_unimplemented_op
#define Perl_pp_regcmaybe Perl_pp_null
+#define Perl_pp_transr Perl_pp_trans
#define Perl_pp_chomp Perl_pp_chop
#define Perl_pp_schomp Perl_pp_schop
#define Perl_pp_i_preinc Perl_pp_preinc
-#define Perl_pp_i_predec Perl_pp_predec
+#define Perl_pp_predec Perl_pp_preinc
+#define Perl_pp_i_predec Perl_pp_preinc
#define Perl_pp_i_postinc Perl_pp_postinc
-#define Perl_pp_i_postdec Perl_pp_postdec
+#define Perl_pp_postdec Perl_pp_postinc
+#define Perl_pp_i_postdec Perl_pp_postinc
#define Perl_pp_slt Perl_pp_sle
#define Perl_pp_sgt Perl_pp_sle
#define Perl_pp_sge Perl_pp_sle
@@ -35,6 +38,7 @@
#define Perl_pp_hex Perl_pp_oct
#define Perl_pp_rindex Perl_pp_index
#define Perl_pp_lcfirst Perl_pp_ucfirst
+#define Perl_pp_aelemfast_lex Perl_pp_aelemfast
#define Perl_pp_avalues Perl_pp_akeys
#define Perl_pp_values Perl_do_kv
#define Perl_pp_keys Perl_do_kv
@@ -138,7 +142,6 @@
#define Perl_pp_custom Perl_unimplemented_op
#define Perl_pp_reach Perl_pp_rkeys
#define Perl_pp_rvalues Perl_pp_rkeys
-#define Perl_pp_transr Perl_pp_trans
START_EXTERN_C
#ifndef DOINIT
@@ -181,6 +184,7 @@
"subst",
"substcont",
"trans",
+ "transr",
"sassign",
"aassign",
"chop",
@@ -273,6 +277,7 @@
"quotemeta",
"rv2av",
"aelemfast",
+ "aelemfast_lex",
"aelem",
"aslice",
"aeach",
@@ -286,7 +291,6 @@
"rv2hv",
"helem",
"hslice",
- "boolkeys",
"unpack",
"pack",
"split",
@@ -514,7 +518,14 @@
"reach",
"rkeys",
"rvalues",
- "transr",
+ "coreargs",
+ "runcv",
+ "fc",
+ "padcv",
+ "introcv",
+ "clonecv",
+ "padrange",
+ "freed",
};
#endif
@@ -558,6 +569,7 @@
"substitution (s///)",
"substitution iterator",
"transliteration (tr///)",
+ "transliteration (tr///)",
"scalar assignment",
"list assignment",
"chop",
@@ -650,6 +662,7 @@
"quotemeta",
"array dereference",
"constant array element",
+ "constant lexical array element",
"array element",
"array slice",
"each on array",
@@ -663,7 +676,6 @@
"hash dereference",
"hash element",
"hash slice",
- "boolkeys",
"unpack",
"pack",
"split",
@@ -891,7 +903,14 @@
"each on reference",
"keys on reference",
"values on reference",
- "transliteration (tr///)",
+ "CORE:: subroutine",
+ "__SUB__",
+ "fc",
+ "private subroutine",
+ "private subroutine",
+ "private subroutine",
+ "list of private variables",
+ "freed op",
};
#endif
@@ -949,6 +968,7 @@
Perl_pp_subst,
Perl_pp_substcont,
Perl_pp_trans,
+ Perl_pp_transr, /* implemented by Perl_pp_trans */
Perl_pp_sassign,
Perl_pp_aassign,
Perl_pp_chop,
@@ -961,12 +981,12 @@
Perl_pp_pos,
Perl_pp_preinc,
Perl_pp_i_preinc, /* implemented by Perl_pp_preinc */
- Perl_pp_predec,
- Perl_pp_i_predec, /* implemented by Perl_pp_predec */
+ Perl_pp_predec, /* implemented by Perl_pp_preinc */
+ Perl_pp_i_predec, /* implemented by Perl_pp_preinc */
Perl_pp_postinc,
Perl_pp_i_postinc, /* implemented by Perl_pp_postinc */
- Perl_pp_postdec,
- Perl_pp_i_postdec, /* implemented by Perl_pp_postdec */
+ Perl_pp_postdec, /* implemented by Perl_pp_postinc */
+ Perl_pp_i_postdec, /* implemented by Perl_pp_postinc */
Perl_pp_pow,
Perl_pp_multiply,
Perl_pp_i_multiply,
@@ -1041,6 +1061,7 @@
Perl_pp_quotemeta,
Perl_pp_rv2av,
Perl_pp_aelemfast,
+ Perl_pp_aelemfast_lex, /* implemented by Perl_pp_aelemfast */
Perl_pp_aelem,
Perl_pp_aslice,
Perl_pp_aeach,
@@ -1054,7 +1075,6 @@
Perl_pp_rv2hv, /* implemented by Perl_pp_rv2av */
Perl_pp_helem,
Perl_pp_hslice,
- Perl_pp_boolkeys,
Perl_pp_unpack,
Perl_pp_pack,
Perl_pp_split,
@@ -1282,7 +1302,13 @@
Perl_pp_reach, /* implemented by Perl_pp_rkeys */
Perl_pp_rkeys,
Perl_pp_rvalues, /* implemented by Perl_pp_rkeys */
- Perl_pp_transr, /* implemented by Perl_pp_trans */
+ Perl_pp_coreargs,
+ Perl_pp_runcv,
+ Perl_pp_fc,
+ Perl_pp_padcv,
+ Perl_pp_introcv,
+ Perl_pp_clonecv,
+ Perl_pp_padrange,
}
#endif
#ifdef PERL_PPADDR_INITED
@@ -1337,6 +1363,7 @@
Perl_ck_match, /* subst */
Perl_ck_null, /* substcont */
Perl_ck_match, /* trans */
+ Perl_ck_match, /* transr */
Perl_ck_sassign, /* sassign */
Perl_ck_null, /* aassign */
Perl_ck_spair, /* chop */
@@ -1344,9 +1371,9 @@
Perl_ck_spair, /* chomp */
Perl_ck_null, /* schomp */
Perl_ck_defined, /* defined */
- Perl_ck_lfun, /* undef */
+ Perl_ck_fun, /* undef */
Perl_ck_fun, /* study */
- Perl_ck_lfun, /* pos */
+ Perl_ck_fun, /* pos */
Perl_ck_lfun, /* preinc */
Perl_ck_lfun, /* i_preinc */
Perl_ck_lfun, /* predec */
@@ -1371,14 +1398,14 @@
Perl_ck_fun, /* stringify */
Perl_ck_bitop, /* left_shift */
Perl_ck_bitop, /* right_shift */
- Perl_ck_null, /* lt */
- Perl_ck_null, /* i_lt */
- Perl_ck_null, /* gt */
- Perl_ck_null, /* i_gt */
- Perl_ck_null, /* le */
- Perl_ck_null, /* i_le */
- Perl_ck_null, /* ge */
- Perl_ck_null, /* i_ge */
+ Perl_ck_cmp, /* lt */
+ Perl_ck_cmp, /* i_lt */
+ Perl_ck_cmp, /* gt */
+ Perl_ck_cmp, /* i_gt */
+ Perl_ck_cmp, /* le */
+ Perl_ck_cmp, /* i_le */
+ Perl_ck_cmp, /* ge */
+ Perl_ck_cmp, /* i_ge */
Perl_ck_null, /* eq */
Perl_ck_null, /* i_eq */
Perl_ck_null, /* ne */
@@ -1412,12 +1439,12 @@
Perl_ck_fun, /* hex */
Perl_ck_fun, /* oct */
Perl_ck_fun, /* abs */
- Perl_ck_fun, /* length */
+ Perl_ck_length, /* length */
Perl_ck_substr, /* substr */
Perl_ck_fun, /* vec */
Perl_ck_index, /* index */
Perl_ck_index, /* rindex */
- Perl_ck_fun, /* sprintf */
+ Perl_ck_lfun, /* sprintf */
Perl_ck_fun, /* formline */
Perl_ck_fun, /* ord */
Perl_ck_fun, /* chr */
@@ -1429,6 +1456,7 @@
Perl_ck_fun, /* quotemeta */
Perl_ck_rvconst, /* rv2av */
Perl_ck_null, /* aelemfast */
+ Perl_ck_null, /* aelemfast_lex */
Perl_ck_null, /* aelem */
Perl_ck_null, /* aslice */
Perl_ck_each, /* aeach */
@@ -1442,8 +1470,7 @@
Perl_ck_rvconst, /* rv2hv */
Perl_ck_null, /* helem */
Perl_ck_null, /* hslice */
- Perl_ck_fun, /* boolkeys */
- Perl_ck_unpack, /* unpack */
+ Perl_ck_fun, /* unpack */
Perl_ck_fun, /* pack */
Perl_ck_split, /* split */
Perl_ck_join, /* join */
@@ -1531,8 +1558,8 @@
Perl_ck_fun, /* sysread */
Perl_ck_fun, /* syswrite */
Perl_ck_eof, /* eof */
- Perl_ck_fun, /* tell */
- Perl_ck_fun, /* seek */
+ Perl_ck_tell, /* tell */
+ Perl_ck_tell, /* seek */
Perl_ck_trunc, /* truncate */
Perl_ck_fun, /* fcntl */
Perl_ck_fun, /* ioctl */
@@ -1579,7 +1606,7 @@
Perl_ck_ftst, /* fttty */
Perl_ck_ftst, /* fttext */
Perl_ck_ftst, /* ftbinary */
- Perl_ck_chdir, /* chdir */
+ Perl_ck_trunc, /* chdir */
Perl_ck_fun, /* chown */
Perl_ck_fun, /* chroot */
Perl_ck_fun, /* unlink */
@@ -1670,7 +1697,13 @@
Perl_ck_each, /* reach */
Perl_ck_each, /* rkeys */
Perl_ck_each, /* rvalues */
- Perl_ck_match, /* transr */
+ Perl_ck_null, /* coreargs */
+ Perl_ck_null, /* runcv */
+ Perl_ck_fun, /* fc */
+ Perl_ck_null, /* padcv */
+ Perl_ck_null, /* introcv */
+ Perl_ck_null, /* clonecv */
+ Perl_ck_null, /* padrange */
}
#endif
#ifdef PERL_CHECK_INITED
@@ -1719,6 +1752,7 @@
0x00001544, /* subst */
0x00000344, /* substcont */
0x00001804, /* trans */
+ 0x00001804, /* transr */
0x00000004, /* sassign */
0x00022208, /* aassign */
0x00002b0d, /* chop */
@@ -1726,9 +1760,9 @@
0x00002b1d, /* chomp */
0x00009b9c, /* schomp */
0x00009b84, /* defined */
- 0x00009b04, /* undef */
+ 0x0000fb04, /* undef */
0x00009b84, /* study */
- 0x00009b8c, /* pos */
+ 0x0000fb8c, /* pos */
0x00001164, /* preinc */
0x00001144, /* i_preinc */
0x00001164, /* predec */
@@ -1744,7 +1778,7 @@
0x0001121e, /* i_divide */
0x0001123e, /* modulo */
0x0001121e, /* i_modulo */
- 0x00012209, /* repeat */
+ 0x0001220b, /* repeat */
0x0001123e, /* add */
0x0001121e, /* i_add */
0x0001123e, /* subtract */
@@ -1811,6 +1845,7 @@
0x00009b8e, /* quotemeta */
0x00000148, /* rv2av */
0x00013604, /* aelemfast */
+ 0x00013040, /* aelemfast_lex */
0x00013204, /* aelem */
0x00023401, /* aslice */
0x00003b00, /* aeach */
@@ -1824,9 +1859,8 @@
0x00000148, /* rv2hv */
0x00014204, /* helem */
0x00024401, /* hslice */
- 0x00004b00, /* boolkeys */
- 0x00091400, /* unpack */
- 0x0002140d, /* pack */
+ 0x00091480, /* unpack */
+ 0x0002140f, /* pack */
0x00111408, /* split */
0x0002140d, /* join */
0x00002401, /* list */
@@ -1932,8 +1966,8 @@
0x01116404, /* ssockopt */
0x00006b04, /* getsockname */
0x00006b04, /* getpeername */
- 0x00006c80, /* lstat */
- 0x00006c80, /* stat */
+ 0x0000ec80, /* lstat */
+ 0x0000ec80, /* stat */
0x00006c84, /* ftrread */
0x00006c84, /* ftrwrite */
0x00006c84, /* ftrexec */
@@ -2010,7 +2044,7 @@
0x00009bc0, /* require */
0x00001140, /* dofile */
0x00000604, /* hintseval */
- 0x00001b40, /* entereval */
+ 0x00009bc0, /* entereval */
0x00001100, /* leaveeval */
0x00000340, /* entertry */
0x00000400, /* leavetry */
@@ -2052,7 +2086,13 @@
0x00001b00, /* reach */
0x00001b08, /* rkeys */
0x00001b08, /* rvalues */
- 0x00001804, /* transr */
+ 0x00000600, /* coreargs */
+ 0x00000004, /* runcv */
+ 0x00009b8e, /* fc */
+ 0x00000040, /* padcv */
+ 0x00000040, /* introcv */
+ 0x00000040, /* clonecv */
+ 0x00000040, /* padrange */
};
#endif
Property changes on: trunk/contrib/perl/opcode.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/opnames.h
===================================================================
--- trunk/contrib/perl/opnames.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/opnames.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -50,348 +50,357 @@
OP_SUBST = 33,
OP_SUBSTCONT = 34,
OP_TRANS = 35,
- OP_SASSIGN = 36,
- OP_AASSIGN = 37,
- OP_CHOP = 38,
- OP_SCHOP = 39,
- OP_CHOMP = 40,
- OP_SCHOMP = 41,
- OP_DEFINED = 42,
- OP_UNDEF = 43,
- OP_STUDY = 44,
- OP_POS = 45,
- OP_PREINC = 46,
- OP_I_PREINC = 47,
- OP_PREDEC = 48,
- OP_I_PREDEC = 49,
- OP_POSTINC = 50,
- OP_I_POSTINC = 51,
- OP_POSTDEC = 52,
- OP_I_POSTDEC = 53,
- OP_POW = 54,
- OP_MULTIPLY = 55,
- OP_I_MULTIPLY = 56,
- OP_DIVIDE = 57,
- OP_I_DIVIDE = 58,
- OP_MODULO = 59,
- OP_I_MODULO = 60,
- OP_REPEAT = 61,
- OP_ADD = 62,
- OP_I_ADD = 63,
- OP_SUBTRACT = 64,
- OP_I_SUBTRACT = 65,
- OP_CONCAT = 66,
- OP_STRINGIFY = 67,
- OP_LEFT_SHIFT = 68,
- OP_RIGHT_SHIFT = 69,
- OP_LT = 70,
- OP_I_LT = 71,
- OP_GT = 72,
- OP_I_GT = 73,
- OP_LE = 74,
- OP_I_LE = 75,
- OP_GE = 76,
- OP_I_GE = 77,
- OP_EQ = 78,
- OP_I_EQ = 79,
- OP_NE = 80,
- OP_I_NE = 81,
- OP_NCMP = 82,
- OP_I_NCMP = 83,
- OP_SLT = 84,
- OP_SGT = 85,
- OP_SLE = 86,
- OP_SGE = 87,
- OP_SEQ = 88,
- OP_SNE = 89,
- OP_SCMP = 90,
- OP_BIT_AND = 91,
- OP_BIT_XOR = 92,
- OP_BIT_OR = 93,
- OP_NEGATE = 94,
- OP_I_NEGATE = 95,
- OP_NOT = 96,
- OP_COMPLEMENT = 97,
- OP_SMARTMATCH = 98,
- OP_ATAN2 = 99,
- OP_SIN = 100,
- OP_COS = 101,
- OP_RAND = 102,
- OP_SRAND = 103,
- OP_EXP = 104,
- OP_LOG = 105,
- OP_SQRT = 106,
- OP_INT = 107,
- OP_HEX = 108,
- OP_OCT = 109,
- OP_ABS = 110,
- OP_LENGTH = 111,
- OP_SUBSTR = 112,
- OP_VEC = 113,
- OP_INDEX = 114,
- OP_RINDEX = 115,
- OP_SPRINTF = 116,
- OP_FORMLINE = 117,
- OP_ORD = 118,
- OP_CHR = 119,
- OP_CRYPT = 120,
- OP_UCFIRST = 121,
- OP_LCFIRST = 122,
- OP_UC = 123,
- OP_LC = 124,
- OP_QUOTEMETA = 125,
- OP_RV2AV = 126,
- OP_AELEMFAST = 127,
- OP_AELEM = 128,
- OP_ASLICE = 129,
- OP_AEACH = 130,
- OP_AKEYS = 131,
- OP_AVALUES = 132,
- OP_EACH = 133,
- OP_VALUES = 134,
- OP_KEYS = 135,
- OP_DELETE = 136,
- OP_EXISTS = 137,
- OP_RV2HV = 138,
- OP_HELEM = 139,
- OP_HSLICE = 140,
- OP_BOOLKEYS = 141,
- OP_UNPACK = 142,
- OP_PACK = 143,
- OP_SPLIT = 144,
- OP_JOIN = 145,
- OP_LIST = 146,
- OP_LSLICE = 147,
- OP_ANONLIST = 148,
- OP_ANONHASH = 149,
- OP_SPLICE = 150,
- OP_PUSH = 151,
- OP_POP = 152,
- OP_SHIFT = 153,
- OP_UNSHIFT = 154,
- OP_SORT = 155,
- OP_REVERSE = 156,
- OP_GREPSTART = 157,
- OP_GREPWHILE = 158,
- OP_MAPSTART = 159,
- OP_MAPWHILE = 160,
- OP_RANGE = 161,
- OP_FLIP = 162,
- OP_FLOP = 163,
- OP_AND = 164,
- OP_OR = 165,
- OP_XOR = 166,
- OP_DOR = 167,
- OP_COND_EXPR = 168,
- OP_ANDASSIGN = 169,
- OP_ORASSIGN = 170,
- OP_DORASSIGN = 171,
- OP_METHOD = 172,
- OP_ENTERSUB = 173,
- OP_LEAVESUB = 174,
- OP_LEAVESUBLV = 175,
- OP_CALLER = 176,
- OP_WARN = 177,
- OP_DIE = 178,
- OP_RESET = 179,
- OP_LINESEQ = 180,
- OP_NEXTSTATE = 181,
- OP_DBSTATE = 182,
- OP_UNSTACK = 183,
- OP_ENTER = 184,
- OP_LEAVE = 185,
- OP_SCOPE = 186,
- OP_ENTERITER = 187,
- OP_ITER = 188,
- OP_ENTERLOOP = 189,
- OP_LEAVELOOP = 190,
- OP_RETURN = 191,
- OP_LAST = 192,
- OP_NEXT = 193,
- OP_REDO = 194,
- OP_DUMP = 195,
- OP_GOTO = 196,
- OP_EXIT = 197,
- OP_METHOD_NAMED = 198,
- OP_ENTERGIVEN = 199,
- OP_LEAVEGIVEN = 200,
- OP_ENTERWHEN = 201,
- OP_LEAVEWHEN = 202,
- OP_BREAK = 203,
- OP_CONTINUE = 204,
- OP_OPEN = 205,
- OP_CLOSE = 206,
- OP_PIPE_OP = 207,
- OP_FILENO = 208,
- OP_UMASK = 209,
- OP_BINMODE = 210,
- OP_TIE = 211,
- OP_UNTIE = 212,
- OP_TIED = 213,
- OP_DBMOPEN = 214,
- OP_DBMCLOSE = 215,
- OP_SSELECT = 216,
- OP_SELECT = 217,
- OP_GETC = 218,
- OP_READ = 219,
- OP_ENTERWRITE = 220,
- OP_LEAVEWRITE = 221,
- OP_PRTF = 222,
- OP_PRINT = 223,
- OP_SAY = 224,
- OP_SYSOPEN = 225,
- OP_SYSSEEK = 226,
- OP_SYSREAD = 227,
- OP_SYSWRITE = 228,
- OP_EOF = 229,
- OP_TELL = 230,
- OP_SEEK = 231,
- OP_TRUNCATE = 232,
- OP_FCNTL = 233,
- OP_IOCTL = 234,
- OP_FLOCK = 235,
- OP_SEND = 236,
- OP_RECV = 237,
- OP_SOCKET = 238,
- OP_SOCKPAIR = 239,
- OP_BIND = 240,
- OP_CONNECT = 241,
- OP_LISTEN = 242,
- OP_ACCEPT = 243,
- OP_SHUTDOWN = 244,
- OP_GSOCKOPT = 245,
- OP_SSOCKOPT = 246,
- OP_GETSOCKNAME = 247,
- OP_GETPEERNAME = 248,
- OP_LSTAT = 249,
- OP_STAT = 250,
- OP_FTRREAD = 251,
- OP_FTRWRITE = 252,
- OP_FTREXEC = 253,
- OP_FTEREAD = 254,
- OP_FTEWRITE = 255,
- OP_FTEEXEC = 256,
- OP_FTIS = 257,
- OP_FTSIZE = 258,
- OP_FTMTIME = 259,
- OP_FTATIME = 260,
- OP_FTCTIME = 261,
- OP_FTROWNED = 262,
- OP_FTEOWNED = 263,
- OP_FTZERO = 264,
- OP_FTSOCK = 265,
- OP_FTCHR = 266,
- OP_FTBLK = 267,
- OP_FTFILE = 268,
- OP_FTDIR = 269,
- OP_FTPIPE = 270,
- OP_FTSUID = 271,
- OP_FTSGID = 272,
- OP_FTSVTX = 273,
- OP_FTLINK = 274,
- OP_FTTTY = 275,
- OP_FTTEXT = 276,
- OP_FTBINARY = 277,
- OP_CHDIR = 278,
- OP_CHOWN = 279,
- OP_CHROOT = 280,
- OP_UNLINK = 281,
- OP_CHMOD = 282,
- OP_UTIME = 283,
- OP_RENAME = 284,
- OP_LINK = 285,
- OP_SYMLINK = 286,
- OP_READLINK = 287,
- OP_MKDIR = 288,
- OP_RMDIR = 289,
- OP_OPEN_DIR = 290,
- OP_READDIR = 291,
- OP_TELLDIR = 292,
- OP_SEEKDIR = 293,
- OP_REWINDDIR = 294,
- OP_CLOSEDIR = 295,
- OP_FORK = 296,
- OP_WAIT = 297,
- OP_WAITPID = 298,
- OP_SYSTEM = 299,
- OP_EXEC = 300,
- OP_KILL = 301,
- OP_GETPPID = 302,
- OP_GETPGRP = 303,
- OP_SETPGRP = 304,
- OP_GETPRIORITY = 305,
- OP_SETPRIORITY = 306,
- OP_TIME = 307,
- OP_TMS = 308,
- OP_LOCALTIME = 309,
- OP_GMTIME = 310,
- OP_ALARM = 311,
- OP_SLEEP = 312,
- OP_SHMGET = 313,
- OP_SHMCTL = 314,
- OP_SHMREAD = 315,
- OP_SHMWRITE = 316,
- OP_MSGGET = 317,
- OP_MSGCTL = 318,
- OP_MSGSND = 319,
- OP_MSGRCV = 320,
- OP_SEMOP = 321,
- OP_SEMGET = 322,
- OP_SEMCTL = 323,
- OP_REQUIRE = 324,
- OP_DOFILE = 325,
- OP_HINTSEVAL = 326,
- OP_ENTEREVAL = 327,
- OP_LEAVEEVAL = 328,
- OP_ENTERTRY = 329,
- OP_LEAVETRY = 330,
- OP_GHBYNAME = 331,
- OP_GHBYADDR = 332,
- OP_GHOSTENT = 333,
- OP_GNBYNAME = 334,
- OP_GNBYADDR = 335,
- OP_GNETENT = 336,
- OP_GPBYNAME = 337,
- OP_GPBYNUMBER = 338,
- OP_GPROTOENT = 339,
- OP_GSBYNAME = 340,
- OP_GSBYPORT = 341,
- OP_GSERVENT = 342,
- OP_SHOSTENT = 343,
- OP_SNETENT = 344,
- OP_SPROTOENT = 345,
- OP_SSERVENT = 346,
- OP_EHOSTENT = 347,
- OP_ENETENT = 348,
- OP_EPROTOENT = 349,
- OP_ESERVENT = 350,
- OP_GPWNAM = 351,
- OP_GPWUID = 352,
- OP_GPWENT = 353,
- OP_SPWENT = 354,
- OP_EPWENT = 355,
- OP_GGRNAM = 356,
- OP_GGRGID = 357,
- OP_GGRENT = 358,
- OP_SGRENT = 359,
- OP_EGRENT = 360,
- OP_GETLOGIN = 361,
- OP_SYSCALL = 362,
- OP_LOCK = 363,
- OP_ONCE = 364,
- OP_CUSTOM = 365,
- OP_REACH = 366,
- OP_RKEYS = 367,
- OP_RVALUES = 368,
- OP_TRANSR = 369,
+ OP_TRANSR = 36,
+ OP_SASSIGN = 37,
+ OP_AASSIGN = 38,
+ OP_CHOP = 39,
+ OP_SCHOP = 40,
+ OP_CHOMP = 41,
+ OP_SCHOMP = 42,
+ OP_DEFINED = 43,
+ OP_UNDEF = 44,
+ OP_STUDY = 45,
+ OP_POS = 46,
+ OP_PREINC = 47,
+ OP_I_PREINC = 48,
+ OP_PREDEC = 49,
+ OP_I_PREDEC = 50,
+ OP_POSTINC = 51,
+ OP_I_POSTINC = 52,
+ OP_POSTDEC = 53,
+ OP_I_POSTDEC = 54,
+ OP_POW = 55,
+ OP_MULTIPLY = 56,
+ OP_I_MULTIPLY = 57,
+ OP_DIVIDE = 58,
+ OP_I_DIVIDE = 59,
+ OP_MODULO = 60,
+ OP_I_MODULO = 61,
+ OP_REPEAT = 62,
+ OP_ADD = 63,
+ OP_I_ADD = 64,
+ OP_SUBTRACT = 65,
+ OP_I_SUBTRACT = 66,
+ OP_CONCAT = 67,
+ OP_STRINGIFY = 68,
+ OP_LEFT_SHIFT = 69,
+ OP_RIGHT_SHIFT = 70,
+ OP_LT = 71,
+ OP_I_LT = 72,
+ OP_GT = 73,
+ OP_I_GT = 74,
+ OP_LE = 75,
+ OP_I_LE = 76,
+ OP_GE = 77,
+ OP_I_GE = 78,
+ OP_EQ = 79,
+ OP_I_EQ = 80,
+ OP_NE = 81,
+ OP_I_NE = 82,
+ OP_NCMP = 83,
+ OP_I_NCMP = 84,
+ OP_SLT = 85,
+ OP_SGT = 86,
+ OP_SLE = 87,
+ OP_SGE = 88,
+ OP_SEQ = 89,
+ OP_SNE = 90,
+ OP_SCMP = 91,
+ OP_BIT_AND = 92,
+ OP_BIT_XOR = 93,
+ OP_BIT_OR = 94,
+ OP_NEGATE = 95,
+ OP_I_NEGATE = 96,
+ OP_NOT = 97,
+ OP_COMPLEMENT = 98,
+ OP_SMARTMATCH = 99,
+ OP_ATAN2 = 100,
+ OP_SIN = 101,
+ OP_COS = 102,
+ OP_RAND = 103,
+ OP_SRAND = 104,
+ OP_EXP = 105,
+ OP_LOG = 106,
+ OP_SQRT = 107,
+ OP_INT = 108,
+ OP_HEX = 109,
+ OP_OCT = 110,
+ OP_ABS = 111,
+ OP_LENGTH = 112,
+ OP_SUBSTR = 113,
+ OP_VEC = 114,
+ OP_INDEX = 115,
+ OP_RINDEX = 116,
+ OP_SPRINTF = 117,
+ OP_FORMLINE = 118,
+ OP_ORD = 119,
+ OP_CHR = 120,
+ OP_CRYPT = 121,
+ OP_UCFIRST = 122,
+ OP_LCFIRST = 123,
+ OP_UC = 124,
+ OP_LC = 125,
+ OP_QUOTEMETA = 126,
+ OP_RV2AV = 127,
+ OP_AELEMFAST = 128,
+ OP_AELEMFAST_LEX = 129,
+ OP_AELEM = 130,
+ OP_ASLICE = 131,
+ OP_AEACH = 132,
+ OP_AKEYS = 133,
+ OP_AVALUES = 134,
+ OP_EACH = 135,
+ OP_VALUES = 136,
+ OP_KEYS = 137,
+ OP_DELETE = 138,
+ OP_EXISTS = 139,
+ OP_RV2HV = 140,
+ OP_HELEM = 141,
+ OP_HSLICE = 142,
+ OP_UNPACK = 143,
+ OP_PACK = 144,
+ OP_SPLIT = 145,
+ OP_JOIN = 146,
+ OP_LIST = 147,
+ OP_LSLICE = 148,
+ OP_ANONLIST = 149,
+ OP_ANONHASH = 150,
+ OP_SPLICE = 151,
+ OP_PUSH = 152,
+ OP_POP = 153,
+ OP_SHIFT = 154,
+ OP_UNSHIFT = 155,
+ OP_SORT = 156,
+ OP_REVERSE = 157,
+ OP_GREPSTART = 158,
+ OP_GREPWHILE = 159,
+ OP_MAPSTART = 160,
+ OP_MAPWHILE = 161,
+ OP_RANGE = 162,
+ OP_FLIP = 163,
+ OP_FLOP = 164,
+ OP_AND = 165,
+ OP_OR = 166,
+ OP_XOR = 167,
+ OP_DOR = 168,
+ OP_COND_EXPR = 169,
+ OP_ANDASSIGN = 170,
+ OP_ORASSIGN = 171,
+ OP_DORASSIGN = 172,
+ OP_METHOD = 173,
+ OP_ENTERSUB = 174,
+ OP_LEAVESUB = 175,
+ OP_LEAVESUBLV = 176,
+ OP_CALLER = 177,
+ OP_WARN = 178,
+ OP_DIE = 179,
+ OP_RESET = 180,
+ OP_LINESEQ = 181,
+ OP_NEXTSTATE = 182,
+ OP_DBSTATE = 183,
+ OP_UNSTACK = 184,
+ OP_ENTER = 185,
+ OP_LEAVE = 186,
+ OP_SCOPE = 187,
+ OP_ENTERITER = 188,
+ OP_ITER = 189,
+ OP_ENTERLOOP = 190,
+ OP_LEAVELOOP = 191,
+ OP_RETURN = 192,
+ OP_LAST = 193,
+ OP_NEXT = 194,
+ OP_REDO = 195,
+ OP_DUMP = 196,
+ OP_GOTO = 197,
+ OP_EXIT = 198,
+ OP_METHOD_NAMED = 199,
+ OP_ENTERGIVEN = 200,
+ OP_LEAVEGIVEN = 201,
+ OP_ENTERWHEN = 202,
+ OP_LEAVEWHEN = 203,
+ OP_BREAK = 204,
+ OP_CONTINUE = 205,
+ OP_OPEN = 206,
+ OP_CLOSE = 207,
+ OP_PIPE_OP = 208,
+ OP_FILENO = 209,
+ OP_UMASK = 210,
+ OP_BINMODE = 211,
+ OP_TIE = 212,
+ OP_UNTIE = 213,
+ OP_TIED = 214,
+ OP_DBMOPEN = 215,
+ OP_DBMCLOSE = 216,
+ OP_SSELECT = 217,
+ OP_SELECT = 218,
+ OP_GETC = 219,
+ OP_READ = 220,
+ OP_ENTERWRITE = 221,
+ OP_LEAVEWRITE = 222,
+ OP_PRTF = 223,
+ OP_PRINT = 224,
+ OP_SAY = 225,
+ OP_SYSOPEN = 226,
+ OP_SYSSEEK = 227,
+ OP_SYSREAD = 228,
+ OP_SYSWRITE = 229,
+ OP_EOF = 230,
+ OP_TELL = 231,
+ OP_SEEK = 232,
+ OP_TRUNCATE = 233,
+ OP_FCNTL = 234,
+ OP_IOCTL = 235,
+ OP_FLOCK = 236,
+ OP_SEND = 237,
+ OP_RECV = 238,
+ OP_SOCKET = 239,
+ OP_SOCKPAIR = 240,
+ OP_BIND = 241,
+ OP_CONNECT = 242,
+ OP_LISTEN = 243,
+ OP_ACCEPT = 244,
+ OP_SHUTDOWN = 245,
+ OP_GSOCKOPT = 246,
+ OP_SSOCKOPT = 247,
+ OP_GETSOCKNAME = 248,
+ OP_GETPEERNAME = 249,
+ OP_LSTAT = 250,
+ OP_STAT = 251,
+ OP_FTRREAD = 252,
+ OP_FTRWRITE = 253,
+ OP_FTREXEC = 254,
+ OP_FTEREAD = 255,
+ OP_FTEWRITE = 256,
+ OP_FTEEXEC = 257,
+ OP_FTIS = 258,
+ OP_FTSIZE = 259,
+ OP_FTMTIME = 260,
+ OP_FTATIME = 261,
+ OP_FTCTIME = 262,
+ OP_FTROWNED = 263,
+ OP_FTEOWNED = 264,
+ OP_FTZERO = 265,
+ OP_FTSOCK = 266,
+ OP_FTCHR = 267,
+ OP_FTBLK = 268,
+ OP_FTFILE = 269,
+ OP_FTDIR = 270,
+ OP_FTPIPE = 271,
+ OP_FTSUID = 272,
+ OP_FTSGID = 273,
+ OP_FTSVTX = 274,
+ OP_FTLINK = 275,
+ OP_FTTTY = 276,
+ OP_FTTEXT = 277,
+ OP_FTBINARY = 278,
+ OP_CHDIR = 279,
+ OP_CHOWN = 280,
+ OP_CHROOT = 281,
+ OP_UNLINK = 282,
+ OP_CHMOD = 283,
+ OP_UTIME = 284,
+ OP_RENAME = 285,
+ OP_LINK = 286,
+ OP_SYMLINK = 287,
+ OP_READLINK = 288,
+ OP_MKDIR = 289,
+ OP_RMDIR = 290,
+ OP_OPEN_DIR = 291,
+ OP_READDIR = 292,
+ OP_TELLDIR = 293,
+ OP_SEEKDIR = 294,
+ OP_REWINDDIR = 295,
+ OP_CLOSEDIR = 296,
+ OP_FORK = 297,
+ OP_WAIT = 298,
+ OP_WAITPID = 299,
+ OP_SYSTEM = 300,
+ OP_EXEC = 301,
+ OP_KILL = 302,
+ OP_GETPPID = 303,
+ OP_GETPGRP = 304,
+ OP_SETPGRP = 305,
+ OP_GETPRIORITY = 306,
+ OP_SETPRIORITY = 307,
+ OP_TIME = 308,
+ OP_TMS = 309,
+ OP_LOCALTIME = 310,
+ OP_GMTIME = 311,
+ OP_ALARM = 312,
+ OP_SLEEP = 313,
+ OP_SHMGET = 314,
+ OP_SHMCTL = 315,
+ OP_SHMREAD = 316,
+ OP_SHMWRITE = 317,
+ OP_MSGGET = 318,
+ OP_MSGCTL = 319,
+ OP_MSGSND = 320,
+ OP_MSGRCV = 321,
+ OP_SEMOP = 322,
+ OP_SEMGET = 323,
+ OP_SEMCTL = 324,
+ OP_REQUIRE = 325,
+ OP_DOFILE = 326,
+ OP_HINTSEVAL = 327,
+ OP_ENTEREVAL = 328,
+ OP_LEAVEEVAL = 329,
+ OP_ENTERTRY = 330,
+ OP_LEAVETRY = 331,
+ OP_GHBYNAME = 332,
+ OP_GHBYADDR = 333,
+ OP_GHOSTENT = 334,
+ OP_GNBYNAME = 335,
+ OP_GNBYADDR = 336,
+ OP_GNETENT = 337,
+ OP_GPBYNAME = 338,
+ OP_GPBYNUMBER = 339,
+ OP_GPROTOENT = 340,
+ OP_GSBYNAME = 341,
+ OP_GSBYPORT = 342,
+ OP_GSERVENT = 343,
+ OP_SHOSTENT = 344,
+ OP_SNETENT = 345,
+ OP_SPROTOENT = 346,
+ OP_SSERVENT = 347,
+ OP_EHOSTENT = 348,
+ OP_ENETENT = 349,
+ OP_EPROTOENT = 350,
+ OP_ESERVENT = 351,
+ OP_GPWNAM = 352,
+ OP_GPWUID = 353,
+ OP_GPWENT = 354,
+ OP_SPWENT = 355,
+ OP_EPWENT = 356,
+ OP_GGRNAM = 357,
+ OP_GGRGID = 358,
+ OP_GGRENT = 359,
+ OP_SGRENT = 360,
+ OP_EGRENT = 361,
+ OP_GETLOGIN = 362,
+ OP_SYSCALL = 363,
+ OP_LOCK = 364,
+ OP_ONCE = 365,
+ OP_CUSTOM = 366,
+ OP_REACH = 367,
+ OP_RKEYS = 368,
+ OP_RVALUES = 369,
+ OP_COREARGS = 370,
+ OP_RUNCV = 371,
+ OP_FC = 372,
+ OP_PADCV = 373,
+ OP_INTROCV = 374,
+ OP_CLONECV = 375,
+ OP_PADRANGE = 376,
OP_max
} opcode;
-#define MAXO 370
+#define MAXO 377
+#define OP_FREED MAXO
-/* the OP_IS_(SOCKET|FILETEST) macros are optimized to a simple range
- check because all the member OPs are contiguous in opcode.pl
- <OPS> table. opcode.pl verifies the range contiguity. */
+/* the OP_IS_* macros are optimized to a simple range check because
+ all the member OPs are contiguous in regen/opcodes table.
+ opcode.pl verifies the range contiguity, or generates an OR-equals
+ expression */
#define OP_IS_SOCKET(op) \
((op) >= OP_SEND && (op) <= OP_GETPEERNAME)
@@ -402,4 +411,10 @@
#define OP_IS_FILETEST_ACCESS(op) \
((op) >= OP_FTRREAD && (op) <= OP_FTEEXEC)
+#define OP_IS_NUMCOMPARE(op) \
+ ((op) >= OP_LT && (op) <= OP_I_NCMP)
+
+#define OP_IS_DIRHOP(op) \
+ ((op) >= OP_READDIR && (op) <= OP_CLOSEDIR)
+
/* ex: set ro: */
Property changes on: trunk/contrib/perl/opnames.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/overload.c
===================================================================
--- trunk/contrib/perl/overload.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/overload.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -84,8 +84,7 @@
3,
3,
3,
- 3,
- 7
+ 3
};
static const char * const PL_AMG_names[NofAMmeth] = {
@@ -161,8 +160,7 @@
"(.=", /* concat_ass */
"(~~", /* smart */
"(-X", /* ftest */
- "(qr", /* regexp */
- "DESTROY"
+ "(qr"
};
/* ex: set ro: */
Property changes on: trunk/contrib/perl/overload.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/overload.h
===================================================================
--- trunk/contrib/perl/overload.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/overload.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -82,7 +82,6 @@
smart_amg, /* 0x41 ~~ */
ftest_amg, /* 0x42 -X */
regexp_amg, /* 0x43 qr */
- DESTROY_amg, /* 0x44 DESTROY */
max_amg_code
/* Do not leave a trailing comma here. C9X allows it, C89 doesn't. */
};
Property changes on: trunk/contrib/perl/overload.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/pad.c
===================================================================
--- trunk/contrib/perl/pad.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/pad.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -27,17 +27,15 @@
/*
=head1 Pad Data Structures
-This file contains the functions that create and manipulate scratchpads,
-which are array-of-array data structures attached to a CV (ie a sub)
-and which store lexical variables and opcode temporary and per-thread
-values.
+=for apidoc Amx|PADLIST *|CvPADLIST|CV *cv
-=for apidoc m|AV *|CvPADLIST|CV *cv
-CV's can have CvPADLIST(cv) set to point to an AV.
+CV's can have CvPADLIST(cv) set to point to a PADLIST. This is the CV's
+scratchpad, which stores lexical variables and opcode temporary and
+per-thread values.
-For these purposes "forms" are a kind-of CV, eval""s are too (except they're
+For these purposes "formats" are a kind-of CV; eval""s are too (except they're
not callable at will and are always thrown away after the eval"" is done
-executing). Require'd files are simply evals without any outer lexical
+executing). Require'd files are simply evals without any outer lexical
scope.
XSUBs don't have CvPADLIST set - dXSTARG fetches values from PL_curpad,
@@ -44,34 +42,27 @@
but that is really the callers pad (a slot of which is allocated by
every entersub).
-The CvPADLIST AV has does not have AvREAL set, so REFCNT of component items
-is managed "manual" (mostly in pad.c) rather than normal av.c rules.
-The items in the AV are not SVs as for a normal AV, but other AVs:
+The PADLIST has a C array where pads are stored.
-0'th Entry of the CvPADLIST is an AV which represents the "names" or rather
-the "static type information" for lexicals.
+The 0th entry of the PADLIST is a PADNAMELIST (which is actually just an
+AV, but that may change) which represents the "names" or rather
+the "static type information" for lexicals. The individual elements of a
+PADNAMELIST are PADNAMEs (just SVs; but, again, that may change). Future
+refactorings might stop the PADNAMELIST from being stored in the PADLIST's
+array, so don't rely on it. See L</PadlistNAMES>.
-The CvDEPTH'th entry of CvPADLIST AV is an AV which is the stack frame at that
-depth of recursion into the CV.
-The 0'th slot of a frame AV is an AV which is @_.
-other entries are storage for variables and op targets.
+The CvDEPTH'th entry of a PADLIST is a PAD (an AV) which is the stack frame
+at that depth of recursion into the CV. The 0th slot of a frame AV is an
+AV which is @_. Other entries are storage for variables and op targets.
-During compilation:
-C<PL_comppad_name> is set to the names AV.
-C<PL_comppad> is set to the frame AV for the frame CvDEPTH == 1.
-C<PL_curpad> is set to the body of the frame AV (i.e. AvARRAY(PL_comppad)).
-
-During execution, C<PL_comppad> and C<PL_curpad> refer to the live
-frame of the currently executing sub.
-
-Iterating over the names AV iterates over all possible pad
-items. Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having
+Iterating over the PADNAMELIST iterates over all possible pad
+items. Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having
&PL_sv_undef "names" (see pad_alloc()).
-Only my/our variable (SVs_PADMY/SVs_PADOUR) slots get valid names.
+Only my/our variable (SvPADMY/PADNAME_isOUR) slots get valid names.
The rest are op targets/GVs/constants which are statically allocated
or resolved at compile time. These don't have names by which they
-can be looked up from Perl code at run time through eval"" like
+can be looked up from Perl code at run time through eval"" the way
my/our variables can be. Since they can't be looked up by "name"
but only by their index allocated at compile time (which is usually
in PL_op->op_targ), wasting a name SV for them doesn't make sense.
@@ -94,7 +85,8 @@
duplicate C<our> declarations in the same package can be detected). SvUVX is
sometimes hijacked to store the generation number during compilation.
-If SvFAKE is set on the name SV, then that slot in the frame AV is
+If PADNAME_OUTER (SvFAKE) is set on the
+name SV, then that slot in the frame AV is
a REFCNT'ed reference to a lexical from "outside". In this case,
the name SV does not use xlow and xhigh to store a cop_seq range, since it is
in scope throughout. Instead xhigh stores some flags containing info about
@@ -103,9 +95,10 @@
within the parent's pad where the lexical's value is stored, to make
cloning quicker.
-If the 'name' is '&' the corresponding entry in frame AV
+If the 'name' is '&' the corresponding entry in the PAD
is a CV representing a possible closure.
-(SvFAKE and name of '&' is not a meaningful combination currently but could
+(PADNAME_OUTER and name of '&' is not a
+meaningful combination currently but could
become so if C<my sub foo {}> is implemented.)
Note that formats are treated as anon subs, and are cloned each time
@@ -112,13 +105,32 @@
write is called (if necessary).
The flag SVs_PADSTALE is cleared on lexicals each time the my() is executed,
-and set on scope exit. This allows the 'Variable $x is not available' warning
+and set on scope exit. This allows the
+'Variable $x is not available' warning
to be generated in evals, such as
{ my $x = 1; sub f { eval '$x'} } f();
-For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised'
+For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised'.
+=for apidoc AmxU|PADNAMELIST *|PL_comppad_name
+
+During compilation, this points to the array containing the names part
+of the pad for the currently-compiling code.
+
+=for apidoc AmxU|PAD *|PL_comppad
+
+During compilation, this points to the array containing the values
+part of the pad for the currently-compiling code. (At runtime a CV may
+have many such value arrays; at compile time just one is constructed.)
+At runtime, this points to the array containing the currently-relevant
+values for the pad for the currently-executing code.
+
+=for apidoc AmxU|SV **|PL_curpad
+
+Points directly to the body of the L</PL_comppad> array.
+(I.e., this is C<PAD_ARRAY(PL_comppad)>.)
+
=cut
*/
@@ -138,6 +150,17 @@
#define PARENT_FAKELEX_FLAGS_set(sv,val) \
STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
+/*
+=for apidoc mx|void|pad_peg|const char *s
+
+When PERL_MAD is enabled, this is a small no-op function that gets called
+at the start of each pad-related function. It can be breakpointed to
+track all pad operations. The parameter is a string indicating the type
+of pad operation being performed.
+
+=cut
+*/
+
#ifdef PERL_MAD
void pad_peg(const char* s) {
static int pegcnt; /* XXX not threadsafe */
@@ -150,14 +173,55 @@
#endif
/*
-=for apidoc pad_new
+This is basically sv_eq_flags() in sv.c, but we avoid the magic
+and bytes checking.
+*/
-Create a new compiling padlist, saving and updating the various global
-vars at the same time as creating the pad itself. The following flags
-can be OR'ed together:
+static bool
+sv_eq_pvn_flags(pTHX_ const SV *sv, const char* pv, const STRLEN pvlen, const U32 flags) {
+ if ( (SvUTF8(sv) & SVf_UTF8 ) != (flags & SVf_UTF8) ) {
+ const char *pv1 = SvPVX_const(sv);
+ STRLEN cur1 = SvCUR(sv);
+ const char *pv2 = pv;
+ STRLEN cur2 = pvlen;
+ if (PL_encoding) {
+ SV* svrecode = NULL;
+ if (SvUTF8(sv)) {
+ svrecode = newSVpvn(pv2, cur2);
+ sv_recode_to_utf8(svrecode, PL_encoding);
+ pv2 = SvPV_const(svrecode, cur2);
+ }
+ else {
+ svrecode = newSVpvn(pv1, cur1);
+ sv_recode_to_utf8(svrecode, PL_encoding);
+ pv1 = SvPV_const(svrecode, cur1);
+ }
+ SvREFCNT_dec_NN(svrecode);
+ }
+ if (flags & SVf_UTF8)
+ return (bytes_cmp_utf8(
+ (const U8*)pv1, cur1,
+ (const U8*)pv2, cur2) == 0);
+ else
+ return (bytes_cmp_utf8(
+ (const U8*)pv2, cur2,
+ (const U8*)pv1, cur1) == 0);
+ }
+ else
+ return ((SvPVX_const(sv) == pv)
+ || memEQ(SvPVX_const(sv), pv, pvlen));
+}
+
+/*
+=for apidoc Am|PADLIST *|pad_new|int flags
+
+Create a new padlist, updating the global variables for the
+currently-compiling padlist to point to the new padlist. The following
+flags can be OR'ed together:
+
padnew_CLONE this pad is for a cloned CV
- padnew_SAVE save old globals
+ padnew_SAVE save old globals on the save stack
padnew_SAVESUB also save extra stuff for start of sub
=cut
@@ -167,8 +231,9 @@
Perl_pad_new(pTHX_ int flags)
{
dVAR;
- AV *padlist, *padname, *pad;
- SV **ary;
+ PADLIST *padlist;
+ PAD *padname, *pad;
+ PAD **ary;
ASSERT_CURPAD_LEGAL("pad_new");
@@ -182,8 +247,8 @@
if (flags & padnew_SAVE) {
SAVECOMPPAD();
- SAVESPTR(PL_comppad_name);
if (! (flags & padnew_CLONE)) {
+ SAVESPTR(PL_comppad_name);
SAVEI32(PL_padix);
SAVEI32(PL_comppad_name_fill);
SAVEI32(PL_min_intro_pending);
@@ -199,8 +264,7 @@
/* ... create new pad ... */
- padlist = newAV();
- padname = newAV();
+ Newxz(padlist, 1, PADLIST);
pad = newAV();
if (flags & padnew_CLONE) {
@@ -212,31 +276,31 @@
AV * const a0 = newAV(); /* will be @_ */
av_store(pad, 0, MUTABLE_SV(a0));
AvREIFY_only(a0);
+
+ padname = (PAD *)SvREFCNT_inc_simple_NN(PL_comppad_name);
}
else {
av_store(pad, 0, NULL);
+ padname = newAV();
}
- AvREAL_off(padlist);
/* Most subroutines never recurse, hence only need 2 entries in the padlist
array - names, and depth=1. The default for av_store() is to allocate
0..3, and even an explicit call to av_extend() with <3 will be rounded
up, so we inline the allocation of the array here. */
- Newx(ary, 2, SV*);
- AvFILLp(padlist) = 1;
- AvMAX(padlist) = 1;
- AvALLOC(padlist) = ary;
- AvARRAY(padlist) = ary;
- ary[0] = MUTABLE_SV(padname);
- ary[1] = MUTABLE_SV(pad);
+ Newx(ary, 2, PAD *);
+ PadlistMAX(padlist) = 1;
+ PadlistARRAY(padlist) = ary;
+ ary[0] = padname;
+ ary[1] = pad;
/* ... then update state variables */
- PL_comppad_name = padname;
PL_comppad = pad;
PL_curpad = AvARRAY(pad);
if (! (flags & padnew_CLONE)) {
+ PL_comppad_name = padname;
PL_comppad_name_fill = 0;
PL_min_intro_pending = 0;
PL_padix = 0;
@@ -273,6 +337,7 @@
{
dVAR;
const PADLIST *padlist = CvPADLIST(cv);
+ bool const slabbed = !!CvSLABBED(cv);
PERL_ARGS_ASSERT_CV_UNDEF;
@@ -281,14 +346,12 @@
PTR2UV(cv), PTR2UV(PL_comppad))
);
-#ifdef USE_ITHREADS
- if (CvFILE(cv) && !CvISXSUB(cv)) {
- /* for XSUBs CvFILE point directly to static memory; __FILE__ */
+ if (CvFILE(cv) && CvDYNFILE(cv)) {
Safefree(CvFILE(cv));
}
CvFILE(cv) = NULL;
-#endif
+ CvSLABBED_off(cv);
if (!CvISXSUB(cv) && CvROOT(cv)) {
if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
Perl_croak(aTHX_ "Can't undef active subroutine");
@@ -296,19 +359,36 @@
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;
+ }
+#ifdef DEBUGGING
+ else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
+#endif
SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
- CvGV_set(cv, NULL);
+ sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
+ if (CvNAMED(cv)) CvNAME_HEK_set(cv, NULL);
+ else CvGV_set(cv, NULL);
/* This statement and the subsequence if block was pad_undef(). */
pad_peg("pad_undef");
- if (padlist && !SvIS_FREED(padlist) /* may be during global destruction */
- ) {
+ if (padlist) {
I32 ix;
/* Free the padlist associated with a CV.
@@ -331,9 +411,9 @@
if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
CV * const outercv = CvOUTSIDE(cv);
const U32 seq = CvOUTSIDE_SEQ(cv);
- AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
+ PAD * const comppad_name = PadlistARRAY(padlist)[0];
SV ** const namepad = AvARRAY(comppad_name);
- AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
+ PAD * const comppad = PadlistARRAY(padlist)[1];
SV ** const curpad = AvARRAY(comppad);
for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
SV * const namesv = namepad[ix];
@@ -343,12 +423,11 @@
CV * const innercv = MUTABLE_CV(curpad[ix]);
U32 inner_rc = SvREFCNT(innercv);
assert(inner_rc);
- namepad[ix] = NULL;
- SvREFCNT_dec(namesv);
+ assert(SvTYPE(innercv) != SVt_PVFM);
if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
curpad[ix] = NULL;
- SvREFCNT_dec(innercv);
+ SvREFCNT_dec_NN(innercv);
inner_rc--;
}
@@ -370,24 +449,25 @@
}
}
- ix = AvFILLp(padlist);
+ ix = PadlistMAX(padlist);
while (ix > 0) {
- SV* const sv = AvARRAY(padlist)[ix--];
+ PAD * const sv = PadlistARRAY(padlist)[ix--];
if (sv) {
- if (sv == (const SV *)PL_comppad) {
+ if (sv == PL_comppad) {
PL_comppad = NULL;
PL_curpad = NULL;
}
- SvREFCNT_dec(sv);
+ SvREFCNT_dec_NN(sv);
}
}
{
- SV *const sv = AvARRAY(padlist)[0];
- if (sv == (const SV *)PL_comppad_name)
+ PAD * const sv = PadlistARRAY(padlist)[0];
+ if (sv == PL_comppad_name && SvREFCNT(sv) == 1)
PL_comppad_name = NULL;
SvREFCNT_dec(sv);
}
- SvREFCNT_dec(MUTABLE_SV(CvPADLIST(cv)));
+ if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist));
+ Safefree(padlist);
CvPADLIST(cv) = NULL;
}
@@ -406,20 +486,76 @@
CvXSUB(cv) = NULL;
}
/* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
- * ref status of CvOUTSIDE and CvGV */
- CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC);
+ * ref status of CvOUTSIDE and CvGV, and ANON, which pp_entersub uses
+ * to choose an error message */
+ CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON);
}
+/*
+=for apidoc cv_forget_slab
+
+When a CV has a reference count on its slab (CvSLABBED), it is responsible
+for making sure it is freed. (Hence, no two CVs should ever have a
+reference count on the same slab.) The CV only needs to reference the slab
+during compilation. Once it is compiled and CvROOT attached, it has
+finished its job, so it can forget the slab.
+
+=cut
+*/
+
+void
+Perl_cv_forget_slab(pTHX_ CV *cv)
+{
+ const bool slabbed = !!CvSLABBED(cv);
+ OPSLAB *slab = NULL;
+
+ PERL_ARGS_ASSERT_CV_FORGET_SLAB;
+
+ if (!slabbed) return;
+
+ CvSLABBED_off(cv);
+
+ if (CvROOT(cv)) slab = OpSLAB(CvROOT(cv));
+ else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
+#ifdef DEBUGGING
+ else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
+#endif
+
+ if (slab) {
+#ifdef PERL_DEBUG_READONLY_OPS
+ const size_t refcnt = slab->opslab_refcnt;
+#endif
+ OpslabREFCNT_dec(slab);
+#ifdef PERL_DEBUG_READONLY_OPS
+ if (refcnt > 1) Slab_to_ro(slab);
+#endif
+ }
+}
+
+/*
+=for apidoc m|PADOFFSET|pad_alloc_name|SV *namesv|U32 flags|HV *typestash|HV *ourstash
+
+Allocates a place in the currently-compiling
+pad (via L<perlapi/pad_alloc>) and
+then stores a name for that entry. I<namesv> is adopted and becomes the
+name entry; it must already contain the name string and be sufficiently
+upgraded. I<typestash> and I<ourstash> and the C<padadd_STATE> flag get
+added to I<namesv>. None of the other
+processing of L<perlapi/pad_add_name_pvn>
+is done. Returns the offset of the allocated pad slot.
+
+=cut
+*/
+
static PADOFFSET
-S_pad_add_name_sv(pTHX_ SV *namesv, const U32 flags, HV *typestash,
- HV *ourstash)
+S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash)
{
dVAR;
const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
- PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
+ PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
- ASSERT_CURPAD_ACTIVE("pad_add_name");
+ ASSERT_CURPAD_ACTIVE("pad_alloc_name");
if (typestash) {
assert(SvTYPE(namesv) == SVt_PVMG);
@@ -440,49 +576,66 @@
}
/*
-=for apidoc pad_add_name
+=for apidoc Am|PADOFFSET|pad_add_name_pvn|const char *namepv|STRLEN namelen|U32 flags|HV *typestash|HV *ourstash
-Create a new name and associated PADMY SV in the current pad; return the
-offset.
-If C<typestash> is valid, the name is for a typed lexical; set the
-name's stash to that value.
-If C<ourstash> is valid, it's an our lexical, set the name's
-SvOURSTASH to that value
+Allocates a place in the currently-compiling pad for a named lexical
+variable. Stores the name and other metadata in the name part of the
+pad, and makes preparations to manage the variable's lexical scoping.
+Returns the offset of the allocated pad slot.
-If fake, it means we're cloning an existing entry
+I<namepv>/I<namelen> specify the variable's name, including leading sigil.
+If I<typestash> is non-null, the name is for a typed lexical, and this
+identifies the type. If I<ourstash> is non-null, it's a lexical reference
+to a package variable, and this identifies the package. The following
+flags can be OR'ed together:
+ padadd_OUR redundantly specifies if it's a package var
+ padadd_STATE variable will retain value persistently
+ padadd_NO_DUP_CHECK skip check for lexical shadowing
+
=cut
*/
PADOFFSET
-Perl_pad_add_name(pTHX_ const char *name, const STRLEN len, const U32 flags,
- HV *typestash, HV *ourstash)
+Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
+ U32 flags, HV *typestash, HV *ourstash)
{
dVAR;
PADOFFSET offset;
SV *namesv;
+ bool is_utf8;
- PERL_ARGS_ASSERT_PAD_ADD_NAME;
+ PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
- if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK))
- Perl_croak(aTHX_ "panic: pad_add_name illegal flag bits 0x%" UVxf,
+ if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK|padadd_UTF8_NAME))
+ Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
(UV)flags);
namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
+
+ if ((is_utf8 = ((flags & padadd_UTF8_NAME) != 0))) {
+ namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
+ }
- /* Until we're using the length for real, cross check that we're being told
- the truth. */
- PERL_UNUSED_ARG(len);
- assert(strlen(name) == len);
+ sv_setpvn(namesv, namepv, namelen);
- sv_setpv(namesv, name);
+ if (is_utf8) {
+ flags |= padadd_UTF8_NAME;
+ SvUTF8_on(namesv);
+ }
+ else
+ flags &= ~padadd_UTF8_NAME;
if ((flags & padadd_NO_DUP_CHECK) == 0) {
+ ENTER;
+ SAVEFREESV(namesv); /* in case of fatal warnings */
/* check for duplicate declaration */
pad_check_dup(namesv, flags & padadd_OUR, ourstash);
+ SvREFCNT_inc_simple_void_NN(namesv);
+ LEAVE;
}
- offset = pad_add_name_sv(namesv, flags, typestash, ourstash);
+ offset = pad_alloc_name(namesv, flags & ~padadd_UTF8_NAME, typestash, ourstash);
/* not yet introduced */
COP_SEQ_RANGE_LOW_set(namesv, PERL_PADSEQ_INTRO);
@@ -494,38 +647,80 @@
/* if it's not a simple scalar, replace with an AV or HV */
assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
assert(SvREFCNT(PL_curpad[offset]) == 1);
- if (*name == '@')
+ if (namelen != 0 && *namepv == '@')
sv_upgrade(PL_curpad[offset], SVt_PVAV);
- else if (*name == '%')
+ else if (namelen != 0 && *namepv == '%')
sv_upgrade(PL_curpad[offset], SVt_PVHV);
+ else if (namelen != 0 && *namepv == '&')
+ sv_upgrade(PL_curpad[offset], SVt_PVCV);
assert(SvPADMY(PL_curpad[offset]));
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
"Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
- (long)offset, name, PTR2UV(PL_curpad[offset])));
+ (long)offset, SvPVX(namesv),
+ PTR2UV(PL_curpad[offset])));
return offset;
}
+/*
+=for apidoc Am|PADOFFSET|pad_add_name_pv|const char *name|U32 flags|HV *typestash|HV *ourstash
+Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
+instead of a string/length pair.
+=cut
+*/
+PADOFFSET
+Perl_pad_add_name_pv(pTHX_ const char *name,
+ const U32 flags, HV *typestash, HV *ourstash)
+{
+ PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
+ return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
+}
+
/*
-=for apidoc pad_alloc
+=for apidoc Am|PADOFFSET|pad_add_name_sv|SV *name|U32 flags|HV *typestash|HV *ourstash
-Allocate a new my or tmp pad entry. For a my, simply push a null SV onto
-the end of PL_comppad, but for a tmp, scan the pad from PL_padix upwards
-for a slot which has no name and no active value.
+Exactly like L</pad_add_name_pvn>, but takes the name string in the form
+of an SV instead of a string/length pair.
=cut
*/
+PADOFFSET
+Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
+{
+ char *namepv;
+ STRLEN namelen;
+ PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
+ namepv = SvPV(name, namelen);
+ if (SvUTF8(name))
+ flags |= padadd_UTF8_NAME;
+ return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
+}
+
+/*
+=for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype
+
+Allocates a place in the currently-compiling pad,
+returning the offset of the allocated pad slot.
+No name is initially attached to the pad slot.
+I<tmptype> is a set of flags indicating the kind of pad entry required,
+which will be set in the value SV for the allocated pad entry:
+
+ SVs_PADMY named lexical variable ("my", "our", "state")
+ SVs_PADTMP unnamed temporary store
+
+I<optype> should be an opcode indicating the type of operation that the
+pad entry is to support. This doesn't affect operational semantics,
+but is used for debugging.
+
+=cut
+*/
+
/* XXX DAPM integrate alloc(), add_name() and add_anon(),
* or at least rationalise ??? */
-/* And flag whether the incoming name is UTF8 or 8 bit?
- Could do this either with the +ve/-ve hack of the HV code, or expanding
- the flag bits. Either way, this makes proper Unicode safe pad support.
- NWC
-*/
PADOFFSET
Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
@@ -538,14 +733,19 @@
ASSERT_CURPAD_ACTIVE("pad_alloc");
if (AvARRAY(PL_comppad) != PL_curpad)
- Perl_croak(aTHX_ "panic: pad_alloc");
+ Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
+ AvARRAY(PL_comppad), PL_curpad);
if (PL_pad_reset_pending)
pad_reset();
if (tmptype & SVs_PADMY) {
+ /* For a my, simply push a null SV onto the end of PL_comppad. */
sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
retval = AvFILLp(PL_comppad);
}
else {
+ /* For a tmp, scan the pad from PL_padix upwards
+ * for a slot which has no name and no active value.
+ */
SV * const * const names = AvARRAY(PL_comppad_name);
const SSize_t names_fill = AvFILLp(PL_comppad_name);
for (;;) {
@@ -580,15 +780,25 @@
}
/*
-=for apidoc pad_add_anon
+=for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
-Add an anon code entry to the current compiling pad
+Allocates a place in the currently-compiling pad (via L</pad_alloc>)
+for an anonymous function that is lexically scoped inside the
+currently-compiling function.
+The function I<func> is linked into the pad, and its C<CvOUTSIDE> link
+to the outer scope is weakened to avoid a reference loop.
+One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>.
+
+I<optype> should be an opcode indicating the type of operation that the
+pad entry is to support. This doesn't affect operational semantics,
+but is used for debugging.
+
=cut
*/
PADOFFSET
-Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type)
+Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
{
dVAR;
PADOFFSET ix;
@@ -602,38 +812,45 @@
* PERL_PADSEQ_INTRO */
COP_SEQ_RANGE_LOW_set(name, 0);
COP_SEQ_RANGE_HIGH_set(name, 0);
- ix = pad_alloc(op_type, SVs_PADMY);
+ ix = pad_alloc(optype, SVs_PADMY);
av_store(PL_comppad_name, ix, name);
/* XXX DAPM use PL_curpad[] ? */
- av_store(PL_comppad, ix, sv);
- SvPADMY_on(sv);
+ if (SvTYPE(func) == SVt_PVCV || !CvOUTSIDE(func))
+ av_store(PL_comppad, ix, (SV*)func);
+ else {
+ SV *rv = newRV_noinc((SV *)func);
+ sv_rvweaken(rv);
+ assert (SvTYPE(func) == SVt_PVFM);
+ av_store(PL_comppad, ix, rv);
+ }
+ SvPADMY_on((SV*)func);
/* to avoid ref loops, we never have parent + child referencing each
* other simultaneously */
- if (CvOUTSIDE((const CV *)sv)) {
- assert(!CvWEAKOUTSIDE((const CV *)sv));
- CvWEAKOUTSIDE_on(MUTABLE_CV(sv));
- SvREFCNT_dec(CvOUTSIDE(MUTABLE_CV(sv)));
+ if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) {
+ assert(!CvWEAKOUTSIDE(func));
+ CvWEAKOUTSIDE_on(func);
+ SvREFCNT_dec_NN(CvOUTSIDE(func));
}
return ix;
}
-
-
/*
=for apidoc pad_check_dup
Check for duplicate declarations: report any of:
+
* a my in the current scope with the same name;
- * an our (anywhere in the pad) with the same name and the same stash
- as C<ourstash>
-C<is_our> indicates that the name to check is an 'our' declaration
+ * an our (anywhere in the pad) with the same name and the
+ same stash as C<ourstash>
+C<is_our> indicates that the name to check is an 'our' declaration.
+
=cut
*/
STATIC void
-S_pad_check_dup(pTHX_ SV *name, const U32 flags, const HV *ourstash)
+S_pad_check_dup(pTHX_ SV *name, U32 flags, const HV *ourstash)
{
dVAR;
SV **svp;
@@ -665,9 +882,11 @@
{
if (is_our && (SvPAD_OUR(sv)))
break; /* "our" masking "our" */
+ /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */
Perl_warner(aTHX_ packWARN(WARN_MISC),
- "\"%s\" variable %"SVf" masks earlier declaration in same %s",
+ "\"%s\" %s %"SVf" masks earlier declaration in same %s",
(is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
+ *SvPVX(sv) == '&' ? "subroutine" : "variable",
sv,
(COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
? "scope" : "statement"));
@@ -701,19 +920,22 @@
/*
-=for apidoc pad_findmy
+=for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
-Given a lexical name, try to find its offset, first in the current pad,
-or failing that, in the pads of any lexically enclosing subs (including
-the complications introduced by eval). If the name is found in an outer pad,
-then a fake entry is added to the current pad.
-Returns the offset in the current pad, or NOT_IN_PAD on failure.
+Given the name of a lexical variable, find its position in the
+currently-compiling pad.
+I<namepv>/I<namelen> specify the variable's name, including leading sigil.
+I<flags> is reserved and must be zero.
+If it is not in the current pad but appears in the pad of any lexically
+enclosing scope, then a pseudo-entry for it is added in the current pad.
+Returns the offset in the current pad,
+or C<NOT_IN_PAD> if no such lexical is in scope.
=cut
*/
PADOFFSET
-Perl_pad_findmy(pTHX_ const char *name, STRLEN len, U32 flags)
+Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
{
dVAR;
SV *out_sv;
@@ -722,27 +944,26 @@
const AV *nameav;
SV **name_svp;
- PERL_ARGS_ASSERT_PAD_FINDMY;
+ PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
- pad_peg("pad_findmy");
+ pad_peg("pad_findmy_pvn");
- if (flags)
- Perl_croak(aTHX_ "panic: pad_findmy illegal flag bits 0x%" UVxf,
+ if (flags & ~padadd_UTF8_NAME)
+ Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
(UV)flags);
- /* Yes, it is a bug (read work in progress) that we're not really using this
- length parameter, and instead relying on strlen() later on. But I'm not
- comfortable about changing the pad API piecemeal to use and rely on
- lengths. This only exists to avoid an "unused parameter" warning. */
- if (len < 2)
- return NOT_IN_PAD;
+ if (flags & padadd_UTF8_NAME) {
+ bool is_utf8 = TRUE;
+ namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
- /* But until we're using the length for real, cross check that we're being
- told the truth. */
- assert(strlen(name) == len);
+ if (is_utf8)
+ flags |= padadd_UTF8_NAME;
+ else
+ flags &= ~padadd_UTF8_NAME;
+ }
- offset = pad_findlex(name, PL_compcv, PL_cop_seqmax, 1,
- NULL, &out_sv, &out_flags);
+ offset = pad_findlex(namepv, namelen, flags,
+ PL_compcv, PL_cop_seqmax, 1, NULL, &out_sv, &out_flags);
if ((PADOFFSET)offset != NOT_IN_PAD)
return offset;
@@ -750,7 +971,7 @@
* our $foo = 0 unless defined $foo;
* to not give a warning. (Yes, this is a hack) */
- nameav = MUTABLE_AV(AvARRAY(CvPADLIST(PL_compcv))[0]);
+ nameav = PadlistARRAY(CvPADLIST(PL_compcv))[0];
name_svp = AvARRAY(nameav);
for (offset = AvFILLp(nameav); offset > 0; offset--) {
const SV * const namesv = name_svp[offset];
@@ -757,7 +978,9 @@
if (namesv && namesv != &PL_sv_undef
&& !SvFAKE(namesv)
&& (SvPAD_OUR(namesv))
- && strEQ(SvPVX_const(namesv), name)
+ && SvCUR(namesv) == namelen
+ && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
+ flags & padadd_UTF8_NAME ? SVf_UTF8 : 0 )
&& COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO
)
return offset;
@@ -766,25 +989,74 @@
}
/*
- * Returns the offset of a lexical $_, if there is one, at run time.
- * Used by the UNDERBAR XS macro.
- */
+=for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
+Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
+instead of a string/length pair.
+
+=cut
+*/
+
PADOFFSET
+Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
+{
+ PERL_ARGS_ASSERT_PAD_FINDMY_PV;
+ return pad_findmy_pvn(name, strlen(name), flags);
+}
+
+/*
+=for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
+
+Exactly like L</pad_findmy_pvn>, but takes the name string in the form
+of an SV instead of a string/length pair.
+
+=cut
+*/
+
+PADOFFSET
+Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
+{
+ char *namepv;
+ STRLEN namelen;
+ PERL_ARGS_ASSERT_PAD_FINDMY_SV;
+ namepv = SvPV(name, namelen);
+ if (SvUTF8(name))
+ flags |= padadd_UTF8_NAME;
+ return pad_findmy_pvn(namepv, namelen, flags);
+}
+
+/*
+=for apidoc Amp|PADOFFSET|find_rundefsvoffset
+
+Find the position of the lexical C<$_> in the pad of the
+currently-executing function. Returns the offset in the current pad,
+or C<NOT_IN_PAD> if there is no lexical C<$_> in scope (in which case
+the global one should be used instead).
+L</find_rundefsv> is likely to be more convenient.
+
+=cut
+*/
+
+PADOFFSET
Perl_find_rundefsvoffset(pTHX)
{
dVAR;
SV *out_sv;
int out_flags;
- return pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1,
+ return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
NULL, &out_sv, &out_flags);
}
/*
- * Returns a lexical $_, if there is one, at run time ; or the global one
- * otherwise.
- */
+=for apidoc Am|SV *|find_rundefsv
+Find and return the variable that is named C<$_> in the lexical scope
+of the currently-executing function. This may be a lexical C<$_>,
+or will otherwise be the global one.
+
+=cut
+*/
+
SV *
Perl_find_rundefsv(pTHX)
{
@@ -792,18 +1064,35 @@
int flags;
PADOFFSET po;
- po = pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1,
+ po = pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
NULL, &namesv, &flags);
- if (po == NOT_IN_PAD
- || (SvFLAGS(namesv) & (SVpad_NAME|SVpad_OUR)) == (SVpad_NAME|SVpad_OUR))
+ if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
return DEFSV;
return PAD_SVl(po);
}
+SV *
+Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
+{
+ SV *namesv;
+ int flags;
+ PADOFFSET po;
+
+ PERL_ARGS_ASSERT_FIND_RUNDEFSV2;
+
+ po = pad_findlex("$_", 2, 0, cv, seq, 1,
+ NULL, &namesv, &flags);
+
+ if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
+ return DEFSV;
+
+ return AvARRAY(PadlistARRAY(CvPADLIST(cv))[CvDEPTH(cv)])[po];
+}
+
/*
-=for apidoc pad_findlex
+=for apidoc m|PADOFFSET|pad_findlex|const char *namepv|STRLEN namelen|U32 flags|const CV* cv|U32 seq|int warn|SV** out_capture|SV** out_name_sv|int *out_flags
Find a named lexical anywhere in a chain of nested pads. Add fake entries
in the inner pads if it's found in an outer one.
@@ -830,38 +1119,58 @@
#define CvCOMPILED(cv) CvROOT(cv)
/* the CV does late binding of its lexicals */
-#define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM)
+#define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM)
+static void
+S_unavailable(pTHX_ SV *namesv)
+{
+ /* diag_listed_as: Variable "%s" is not available */
+ Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
+ "%se \"%"SVf"\" is not available",
+ *SvPVX_const(namesv) == '&'
+ ? "Subroutin"
+ : "Variabl",
+ namesv);
+}
STATIC PADOFFSET
-S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn,
- SV** out_capture, SV** out_name_sv, int *out_flags)
+S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
+ int warn, SV** out_capture, SV** out_name_sv, int *out_flags)
{
dVAR;
I32 offset, new_offset;
SV *new_capture;
SV **new_capturep;
- const AV * const padlist = CvPADLIST(cv);
+ const PADLIST * const padlist = CvPADLIST(cv);
+ const bool staleok = !!(flags & padadd_STALEOK);
PERL_ARGS_ASSERT_PAD_FINDLEX;
+ if (flags & ~(padadd_UTF8_NAME|padadd_STALEOK))
+ Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
+ (UV)flags);
+ flags &= ~ padadd_STALEOK; /* one-shot flag */
+
*out_flags = 0;
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
- "Pad findlex cv=0x%"UVxf" searching \"%s\" seq=%d%s\n",
- PTR2UV(cv), name, (int)seq, out_capture ? " capturing" : "" ));
+ "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
+ PTR2UV(cv), (int)namelen, namepv, (int)seq,
+ out_capture ? " capturing" : "" ));
/* first, search this pad */
if (padlist) { /* not an undef CV */
I32 fake_offset = 0;
- const AV * const nameav = MUTABLE_AV(AvARRAY(padlist)[0]);
+ const AV * const nameav = PadlistARRAY(padlist)[0];
SV * const * const name_svp = AvARRAY(nameav);
for (offset = AvFILLp(nameav); offset > 0; offset--) {
const SV * const namesv = name_svp[offset];
if (namesv && namesv != &PL_sv_undef
- && strEQ(SvPVX_const(namesv), name))
+ && SvCUR(namesv) == namelen
+ && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
+ flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))
{
if (SvFAKE(namesv)) {
fake_offset = offset; /* in case we don't find a real one */
@@ -945,8 +1254,11 @@
: *out_flags & PAD_FAKELEX_ANON)
{
if (warn)
- Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
- "Variable \"%s\" is not available", name);
+ S_unavailable(aTHX_
+ newSVpvn_flags(namepv, namelen,
+ SVs_TEMP |
+ (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
+
*out_capture = NULL;
}
@@ -958,7 +1270,10 @@
&& warn && ckWARN(WARN_CLOSURE)) {
newwarn = 0;
Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
- "Variable \"%s\" will not stay shared", name);
+ "Variable \"%"SVf"\" will not stay shared",
+ newSVpvn_flags(namepv, namelen,
+ SVs_TEMP |
+ (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
}
if (fake_offset && CvANON(cv)
@@ -970,7 +1285,7 @@
"Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
PTR2UV(cv)));
n = *out_name_sv;
- (void) pad_findlex(name, CvOUTSIDE(cv),
+ (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
CvOUTSIDE_SEQ(cv),
newwarn, out_capture, out_name_sv, out_flags);
*out_name_sv = n;
@@ -977,25 +1292,30 @@
return offset;
}
- *out_capture = AvARRAY(MUTABLE_AV(AvARRAY(padlist)[
- CvDEPTH(cv) ? CvDEPTH(cv) : 1]))[offset];
+ *out_capture = AvARRAY(PadlistARRAY(padlist)[
+ CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
"Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
PTR2UV(cv), PTR2UV(*out_capture)));
if (SvPADSTALE(*out_capture)
+ && (!CvDEPTH(cv) || !staleok)
&& !SvPAD_STATE(name_svp[offset]))
{
- Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
- "Variable \"%s\" is not available", name);
+ S_unavailable(aTHX_
+ newSVpvn_flags(namepv, namelen,
+ SVs_TEMP |
+ (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
*out_capture = NULL;
}
}
if (!*out_capture) {
- if (*name == '@')
+ if (namelen != 0 && *namepv == '@')
*out_capture = sv_2mortal(MUTABLE_SV(newAV()));
- else if (*name == '%')
+ else if (namelen != 0 && *namepv == '%')
*out_capture = sv_2mortal(MUTABLE_SV(newHV()));
+ else if (namelen != 0 && *namepv == '&')
+ *out_capture = sv_2mortal(newSV_type(SVt_PVCV));
else
*out_capture = sv_newmortal();
}
@@ -1015,7 +1335,9 @@
new_capturep = out_capture ? out_capture :
CvLATE(cv) ? NULL : &new_capture;
- offset = pad_findlex(name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
+ offset = pad_findlex(namepv, namelen,
+ flags | padadd_STALEOK*(new_capturep == &new_capture),
+ CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
new_capturep, out_name_sv, out_flags);
if ((PADOFFSET)offset == NOT_IN_PAD)
return NOT_IN_PAD;
@@ -1035,12 +1357,12 @@
SV *new_namesv = newSVsv(*out_name_sv);
AV * const ocomppad_name = PL_comppad_name;
PAD * const ocomppad = PL_comppad;
- PL_comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
- PL_comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
+ PL_comppad_name = PadlistARRAY(padlist)[0];
+ PL_comppad = PadlistARRAY(padlist)[1];
PL_curpad = AvARRAY(PL_comppad);
new_offset
- = pad_add_name_sv(new_namesv,
+ = pad_alloc_name(new_namesv,
(SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
SvPAD_TYPED(*out_name_sv)
? SvSTASH(*out_name_sv) : NULL,
@@ -1066,6 +1388,8 @@
else {
/* immediate creation - capture outer value right now */
av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
+ /* But also note the offset, as newMYSUB needs it */
+ PARENT_PAD_INDEX_set(new_namesv, offset);
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
"Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
@@ -1080,18 +1404,17 @@
return new_offset;
}
+#ifdef DEBUGGING
-#ifdef DEBUGGING
/*
-=for apidoc pad_sv
+=for apidoc Am|SV *|pad_sv|PADOFFSET po
-Get the value at offset po in the current pad.
+Get the value at offset I<po> in the current (compiling or executing) pad.
Use macro PAD_SV instead of calling this function directly.
=cut
*/
-
SV *
Perl_pad_sv(pTHX_ PADOFFSET po)
{
@@ -1107,11 +1430,10 @@
return PL_curpad[po];
}
-
/*
-=for apidoc pad_setsv
+=for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
-Set the entry at offset po in the current pad to sv.
+Set the value at offset I<po> in the current (compiling or executing) pad.
Use the macro PAD_SETSV() rather than calling this function directly.
=cut
@@ -1132,14 +1454,13 @@
);
PL_curpad[po] = sv;
}
-#endif
+#endif /* DEBUGGING */
-
/*
-=for apidoc pad_block_start
+=for apidoc m|void|pad_block_start|int full
-Update the pad compilation state variables on entry to a new block
+Update the pad compilation state variables on entry to a new block.
=cut
*/
@@ -1170,11 +1491,12 @@
PL_pad_reset_pending = FALSE;
}
-
/*
-=for apidoc intro_my
+=for apidoc m|U32|intro_my
-"Introduce" my variables to visible status.
+"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.
=cut
*/
@@ -1221,7 +1543,7 @@
}
/*
-=for apidoc pad_leavemy
+=for apidoc m|void|pad_leavemy
Cleanup at end of scope during compilation: set the max seq number for
lexicals in this scope and warn of any lexicals that never got introduced.
@@ -1229,11 +1551,12 @@
=cut
*/
-void
+OP *
Perl_pad_leavemy(pTHX)
{
dVAR;
I32 off;
+ OP *o = NULL;
SV * const * const svp = AvARRAY(PL_comppad_name);
PL_pad_reset_pending = FALSE;
@@ -1250,7 +1573,7 @@
}
/* "Deintroduce" my variables that are leaving with this scope. */
for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
- const SV * const sv = svp[off];
+ SV * const sv = svp[off];
if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
&& COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
{
@@ -1261,6 +1584,12 @@
(unsigned long)COP_SEQ_RANGE_LOW(sv),
(unsigned long)COP_SEQ_RANGE_HIGH(sv))
);
+ if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
+ && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
+ OP *kid = newOP(OP_INTROCV, 0);
+ kid->op_targ = off;
+ o = op_prepend_elem(OP_LINESEQ, kid, o);
+ }
}
}
PL_cop_seqmax++;
@@ -1268,11 +1597,11 @@
PL_cop_seqmax++;
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
"Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
+ return o;
}
-
/*
-=for apidoc pad_swipe
+=for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
Abandon the tmp in the current pad at offset po and replace with a
new one.
@@ -1288,9 +1617,11 @@
if (!PL_curpad)
return;
if (AvARRAY(PL_comppad) != PL_curpad)
- Perl_croak(aTHX_ "panic: pad_swipe curpad");
- if (!po)
- Perl_croak(aTHX_ "panic: pad_swipe po");
+ Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
+ AvARRAY(PL_comppad), PL_curpad);
+ if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
+ Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
+ (long)po, (long)AvFILLp(PL_comppad));
DEBUG_X(PerlIO_printf(Perl_debug_log,
"Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
@@ -1314,9 +1645,8 @@
PL_padix = po - 1;
}
-
/*
-=for apidoc pad_reset
+=for apidoc m|void|pad_reset
Mark all the current temporaries for reuse
@@ -1335,7 +1665,8 @@
dVAR;
#ifdef USE_BROKEN_PAD_RESET
if (AvARRAY(PL_comppad) != PL_curpad)
- Perl_croak(aTHX_ "panic: pad_reset curpad");
+ Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
+ AvARRAY(PL_comppad), PL_curpad);
DEBUG_X(PerlIO_printf(Perl_debug_log,
"Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
@@ -1344,8 +1675,8 @@
)
);
- if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
- register I32 po;
+ if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */
+ I32 po;
for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
SvPADTMP_off(PL_curpad[po]);
@@ -1356,15 +1687,18 @@
PL_pad_reset_pending = FALSE;
}
-
/*
-=for apidoc pad_tidy
+=for apidoc Amx|void|pad_tidy|padtidy_type type
-Tidy up a pad after we've finished compiling it:
- * remove most stuff from the pads of anonsub prototypes;
- * give it a @_;
- * mark tmps as such.
+Tidy up a pad at the end of compilation of the code to which it belongs.
+Jobs performed here are: remove most stuff from the pads of anonsub
+prototypes; give it a @_; mark temporaries as such. I<type> indicates
+the kind of subroutine:
+ padtidy_SUB ordinary subroutine
+ padtidy_SUBCLONE prototype for lexical closure
+ padtidy_FORMAT format
+
=cut
*/
@@ -1380,13 +1714,21 @@
ASSERT_CURPAD_ACTIVE("pad_tidy");
- /* If this CV has had any 'eval-capable' ops planted in it
- * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
- * anon prototypes in the chain of CVs should be marked as cloneable,
- * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
- * the right CvOUTSIDE.
- * If running with -d, *any* sub may potentially have an eval
- * executed within it.
+ /* If this CV has had any 'eval-capable' ops planted in it:
+ * i.e. it contains any of:
+ *
+ * * eval '...',
+ * * //ee,
+ * * use re 'eval'; /$var/
+ * * /(?{..})/),
+ *
+ * Then any anon prototypes in the chain of CVs should be marked as
+ * cloneable, so that for example the eval's CV in
+ *
+ * sub { eval '$x' }
+ *
+ * gets the right CvOUTSIDE. If running with -d, *any* sub may
+ * potentially have an eval executed within it.
*/
if (PL_cv_has_eval || PL_perldb) {
@@ -1399,6 +1741,7 @@
"Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
CvCLONE_on(cv);
}
+ CvHASEVAL_on(cv);
}
}
@@ -1468,9 +1811,8 @@
PL_curpad = AvARRAY(PL_comppad);
}
-
/*
-=for apidoc pad_free
+=for apidoc m|void|pad_free|PADOFFSET po
Free the SV at offset po in the current pad.
@@ -1482,11 +1824,13 @@
Perl_pad_free(pTHX_ PADOFFSET po)
{
dVAR;
+ SV *sv;
ASSERT_CURPAD_LEGAL("pad_free");
if (!PL_curpad)
return;
if (AvARRAY(PL_comppad) != PL_curpad)
- Perl_croak(aTHX_ "panic: pad_free curpad");
+ Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
+ AvARRAY(PL_comppad), PL_curpad);
if (!po)
Perl_croak(aTHX_ "panic: pad_free po");
@@ -1495,17 +1839,17 @@
PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
);
- if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
- SvPADTMP_off(PL_curpad[po]);
- }
+
+ sv = PL_curpad[po];
+ if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
+ SvFLAGS(sv) &= ~SVs_PADTMP;
+
if ((I32)po < PL_padix)
PL_padix = po - 1;
}
-
-
/*
-=for apidoc do_dump_pad
+=for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
Dump the contents of a padlist
@@ -1527,8 +1871,8 @@
if (!padlist) {
return;
}
- pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
- pad = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 1, FALSE));
+ pad_name = *PadlistARRAY(padlist);
+ pad = PadlistARRAY(padlist)[1];
pname = AvARRAY(pad_name);
ppad = AvARRAY(pad);
Perl_dump_indent(aTHX_ level, file,
@@ -1575,10 +1919,10 @@
}
}
+#ifdef DEBUGGING
-
/*
-=for apidoc cv_dump
+=for apidoc m|void|cv_dump|CV *cv|const char *title
dump the contents of a CV
@@ -1585,13 +1929,12 @@
=cut
*/
-#ifdef DEBUGGING
STATIC void
S_cv_dump(pTHX_ const CV *cv, const char *title)
{
dVAR;
const CV * const outside = CvOUTSIDE(cv);
- AV* const padlist = CvPADLIST(cv);
+ PADLIST* const padlist = CvPADLIST(cv);
PERL_ARGS_ASSERT_CV_DUMP;
@@ -1615,90 +1958,92 @@
" PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
do_dump_pad(1, Perl_debug_log, padlist, 1);
}
+
#endif /* DEBUGGING */
-
-
-
-
/*
-=for apidoc cv_clone
+=for apidoc Am|CV *|cv_clone|CV *proto
-Clone a CV: make a new CV which points to the same code etc, but which
-has a newly-created pad built by copying the prototype pad and capturing
-any outer lexicals.
+Clone a CV, making a lexical closure. I<proto> supplies the prototype
+of the function: its code, pad structure, and other attributes.
+The prototype is combined with a capture of outer lexicals to which the
+code refers, which are taken from the currently-executing instance of
+the immediately surrounding code.
=cut
*/
-CV *
-Perl_cv_clone(pTHX_ CV *proto)
+static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside);
+
+static void
+S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv)
{
dVAR;
I32 ix;
- AV* const protopadlist = CvPADLIST(proto);
- const AV *const protopad_name = (const AV *)*av_fetch(protopadlist, 0, FALSE);
- const AV *const protopad = (const AV *)*av_fetch(protopadlist, 1, FALSE);
+ PADLIST* const protopadlist = CvPADLIST(proto);
+ PAD *const protopad_name = *PadlistARRAY(protopadlist);
+ const PAD *const protopad = PadlistARRAY(protopadlist)[1];
SV** const pname = AvARRAY(protopad_name);
SV** const ppad = AvARRAY(protopad);
const I32 fname = AvFILLp(protopad_name);
const I32 fpad = AvFILLp(protopad);
- CV* cv;
SV** outpad;
- CV* outside;
long depth;
+ bool subclones = FALSE;
- PERL_ARGS_ASSERT_CV_CLONE;
-
assert(!CvUNIQUE(proto));
- /* Since cloneable anon subs can be nested, CvOUTSIDE may point
+ /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
+ * reliable. The currently-running sub is always the one we need to
+ * close over.
+ * For my subs, the currently-running sub may not be the one we want.
+ * We have to check whether it is a clone of CvOUTSIDE.
+ * Note that in general for formats, CvOUTSIDE != find_runcv.
+ * Since formats may be nested inside closures, CvOUTSIDE may point
* to a prototype; we instead want the cloned parent who called us.
- * Note that in general for formats, CvOUTSIDE != find_runcv */
+ */
- outside = CvOUTSIDE(proto);
- if (outside && CvCLONE(outside) && ! CvCLONED(outside))
+ if (!outside) {
+ if (CvWEAKOUTSIDE(proto))
outside = find_runcv(NULL);
- depth = CvDEPTH(outside);
- assert(depth || SvTYPE(proto) == SVt_PVFM);
+ else {
+ outside = CvOUTSIDE(proto);
+ if ((CvCLONE(outside) && ! CvCLONED(outside))
+ || !CvPADLIST(outside)
+ || PadlistNAMES(CvPADLIST(outside))
+ != protopadlist->xpadl_outid) {
+ outside = find_runcv_where(
+ FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
+ );
+ /* outside could be null */
+ }
+ }
+ }
+ depth = outside ? CvDEPTH(outside) : 0;
if (!depth)
depth = 1;
- assert(CvPADLIST(outside));
ENTER;
SAVESPTR(PL_compcv);
+ PL_compcv = cv;
+ if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
- cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
- CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC);
- CvCLONED_on(cv);
+ if (CvHASEVAL(cv))
+ CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
-#ifdef USE_ITHREADS
- CvFILE(cv) = CvISXSUB(proto) ? CvFILE(proto)
- : savepv(CvFILE(proto));
-#else
- CvFILE(cv) = CvFILE(proto);
-#endif
- CvGV_set(cv,CvGV(proto));
- CvSTASH_set(cv, CvSTASH(proto));
- OP_REFCNT_LOCK;
- CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
- OP_REFCNT_UNLOCK;
- CvSTART(cv) = CvSTART(proto);
- CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
- CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
-
- if (SvPOK(proto))
- sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
-
+ SAVESPTR(PL_comppad_name);
+ PL_comppad_name = protopad_name;
CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
av_fill(PL_comppad, fpad);
- for (ix = fname; ix > 0; ix--)
- av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
PL_curpad = AvARRAY(PL_comppad);
- outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
+ outpad = outside && CvPADLIST(outside)
+ ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
+ : NULL;
+ if (outpad)
+ CvPADLIST(cv)->xpadl_outid = PadlistNAMES(CvPADLIST(outside));
for (ix = fpad; ix > 0; ix--) {
SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
@@ -1705,14 +2050,12 @@
SV *sv = NULL;
if (namesv && namesv != &PL_sv_undef) { /* lexical */
if (SvFAKE(namesv)) { /* lexical from outside? */
- sv = outpad[PARENT_PAD_INDEX(namesv)];
- assert(sv);
- /* formats may have an inactive parent,
- while my $x if $false can leave an active var marked as
- stale. And state vars are always available */
- if (SvPADSTALE(sv) && !SvPAD_STATE(namesv)) {
- Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
- "Variable \"%s\" is not available", SvPVX_const(namesv));
+ /* formats may have an inactive, or even undefined, parent;
+ but state vars are always available. */
+ if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
+ || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv)
+ && (!outside || !CvDEPTH(outside))) ) {
+ S_unavailable(aTHX_ namesv);
sv = NULL;
}
else
@@ -1721,7 +2064,33 @@
if (!sv) {
const char sigil = SvPVX_const(namesv)[0];
if (sigil == '&')
- sv = SvREFCNT_inc(ppad[ix]);
+ /* If there are state subs, we need to clone them, too.
+ But they may need to close over variables we have
+ not cloned yet. So we will have to do a second
+ pass. Furthermore, there may be state subs clos-
+ ing over other state subs’ entries, so we have
+ to put a stub here and then clone into it on the
+ second pass. */
+ if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) {
+ assert(SvTYPE(ppad[ix]) == SVt_PVCV);
+ subclones = 1;
+ sv = newSV_type(SVt_PVCV);
+ }
+ else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
+ {
+ /* my sub */
+ /* Just provide a stub, but name it. It will be
+ upgrade to the real thing on scope entry. */
+ sv = newSV_type(SVt_PVCV);
+ CvNAME_HEK_set(
+ sv,
+ share_hek(SvPVX_const(namesv)+1,
+ SvCUR(namesv) - 1
+ * (SvUTF8(namesv) ? -1 : 1),
+ 0)
+ );
+ }
+ else sv = SvREFCNT_inc(ppad[ix]);
else if (sigil == '@')
sv = MUTABLE_SV(newAV());
else if (sigil == '%')
@@ -1730,7 +2099,7 @@
sv = newSV(0);
SvPADMY_on(sv);
/* reset the 'assign only once' flag on each state var */
- if (SvPAD_STATE(namesv))
+ if (sigil != '&' && SvPAD_STATE(namesv))
SvPADSTALE_on(sv);
}
}
@@ -1744,15 +2113,57 @@
PL_curpad[ix] = sv;
}
+ if (subclones)
+ for (ix = fpad; ix > 0; ix--) {
+ SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
+ if (namesv && namesv != &PL_sv_undef && !SvFAKE(namesv)
+ && SvPVX_const(namesv)[0] == '&' && SvPAD_STATE(namesv))
+ S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv);
+ }
+
+ if (newcv) SvREFCNT_inc_simple_void_NN(cv);
+ LEAVE;
+}
+
+static CV *
+S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside)
+{
+ dVAR;
+ const bool newcv = !cv;
+
+ assert(!CvUNIQUE(proto));
+
+ if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
+ CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
+ |CVf_SLABBED);
+ CvCLONED_on(cv);
+
+ CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
+ : CvFILE(proto);
+ if (CvNAMED(proto))
+ CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
+ else CvGV_set(cv,CvGV(proto));
+ CvSTASH_set(cv, CvSTASH(proto));
+ OP_REFCNT_LOCK;
+ CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
+ OP_REFCNT_UNLOCK;
+ CvSTART(cv) = CvSTART(proto);
+ CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
+
+ if (SvPOK(proto))
+ sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
+ if (SvMAGIC(proto))
+ mg_copy((SV *)proto, (SV *)cv, 0, 0);
+
+ if (CvPADLIST(proto)) S_cv_clone_pad(aTHX_ proto, cv, outside, newcv);
+
DEBUG_Xv(
PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
- cv_dump(outside, "Outside");
+ if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
cv_dump(proto, "Proto");
cv_dump(cv, "To");
);
- LEAVE;
-
if (CvCONST(cv)) {
/* Constant sub () { $x } closing over $x - see lib/constant.pm:
* The prototype was marked as a candiate for const-ization,
@@ -1761,7 +2172,10 @@
*/
SV* const const_sv = op_const_sv(CvSTART(cv), cv);
if (const_sv) {
- SvREFCNT_dec(cv);
+ 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 {
@@ -1772,9 +2186,26 @@
return cv;
}
+CV *
+Perl_cv_clone(pTHX_ CV *proto)
+{
+ PERL_ARGS_ASSERT_CV_CLONE;
+ if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
+ return S_cv_clone(aTHX_ proto, NULL, NULL);
+}
+
+/* Called only by pp_clonecv */
+CV *
+Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
+{
+ PERL_ARGS_ASSERT_CV_CLONE_INTO;
+ cv_undef(target);
+ return S_cv_clone(aTHX_ proto, target, NULL);
+}
+
/*
-=for apidoc pad_fixup_inner_anons
+=for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
For any anon CVs in the pad, change CvOUTSIDE of that CV from
old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
@@ -1788,8 +2219,8 @@
{
dVAR;
I32 ix;
- AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
- AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
+ AV * const comppad_name = PadlistARRAY(padlist)[0];
+ AV * const comppad = PadlistARRAY(padlist)[1];
SV ** const namepad = AvARRAY(comppad_name);
SV ** const curpad = AvARRAY(comppad);
@@ -1798,20 +2229,40 @@
for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
const SV * const namesv = namepad[ix];
- if (namesv && namesv != &PL_sv_undef
+ if (namesv && namesv != &PL_sv_undef && !SvPAD_STATE(namesv)
&& *SvPVX_const(namesv) == '&')
{
- CV * const innercv = MUTABLE_CV(curpad[ix]);
- assert(CvWEAKOUTSIDE(innercv));
- assert(CvOUTSIDE(innercv) == old_cv);
- CvOUTSIDE(innercv) = new_cv;
+ if (SvTYPE(curpad[ix]) == SVt_PVCV) {
+ MAGIC * const mg =
+ SvMAGICAL(curpad[ix])
+ ? mg_find(curpad[ix], PERL_MAGIC_proto)
+ : NULL;
+ CV * const innercv = MUTABLE_CV(mg ? mg->mg_obj : curpad[ix]);
+ if (CvOUTSIDE(innercv) == old_cv) {
+ if (!CvWEAKOUTSIDE(innercv)) {
+ SvREFCNT_dec(old_cv);
+ SvREFCNT_inc_simple_void_NN(new_cv);
+ }
+ CvOUTSIDE(innercv) = new_cv;
+ }
+ }
+ else { /* format reference */
+ SV * const rv = curpad[ix];
+ CV *innercv;
+ if (!SvOK(rv)) continue;
+ assert(SvROK(rv));
+ assert(SvWEAKREF(rv));
+ innercv = (CV *)SvRV(rv);
+ assert(!CvWEAKOUTSIDE(innercv));
+ SvREFCNT_dec(CvOUTSIDE(innercv));
+ CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
+ }
}
}
}
-
/*
-=for apidoc pad_push
+=for apidoc m|void|pad_push|PADLIST *padlist|int depth
Push a new pad frame onto the padlist, unless there's already a pad at
this depth, in which case don't bother creating a new one. Then give
@@ -1827,8 +2278,8 @@
PERL_ARGS_ASSERT_PAD_PUSH;
- if (depth > AvFILLp(padlist)) {
- SV** const svp = AvARRAY(padlist);
+ if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
+ PAD** const svp = PadlistARRAY(padlist);
AV* const newpad = newAV();
SV** const oldpad = AvARRAY(svp[depth-1]);
I32 ix = AvFILLp((const AV *)svp[1]);
@@ -1872,12 +2323,20 @@
av_store(newpad, 0, MUTABLE_SV(av));
AvREIFY_only(av);
- av_store(padlist, depth, MUTABLE_SV(newpad));
- AvFILLp(padlist) = depth;
+ padlist_store(padlist, depth, newpad);
}
}
+/*
+=for apidoc Am|HV *|pad_compname_type|PADOFFSET po
+Looks up the type of the lexical variable at position I<po> in the
+currently-compiling pad. If the variable is typed, the stash of the
+class to which it is typed is returned. If not, C<NULL> is returned.
+
+=cut
+*/
+
HV *
Perl_pad_compname_type(pTHX_ const PADOFFSET po)
{
@@ -1893,58 +2352,63 @@
# define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
-AV *
-Perl_padlist_dup(pTHX_ AV *const srcpad, CLONE_PARAMS *const param)
+/*
+=for apidoc padlist_dup
+
+Duplicates a pad.
+
+=cut
+*/
+
+PADLIST *
+Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
{
- AV *dstpad;
+ PADLIST *dstpad;
+ bool cloneall;
+ PADOFFSET max;
+
PERL_ARGS_ASSERT_PADLIST_DUP;
if (!srcpad)
return NULL;
- assert(!AvREAL(srcpad));
+ cloneall = param->flags & CLONEf_COPY_STACKS
+ || SvREFCNT(PadlistARRAY(srcpad)[1]) > 1;
+ assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
- if (param->flags & CLONEf_COPY_STACKS
- || SvREFCNT(AvARRAY(srcpad)[1]) > 1) {
- /* XXX padlists are real, but pretend to be not */
- AvREAL_on(srcpad);
- dstpad = av_dup_inc(srcpad, param);
- AvREAL_off(srcpad);
- AvREAL_off(dstpad);
- assert (SvREFCNT(AvARRAY(srcpad)[1]) == 1);
+ max = cloneall ? PadlistMAX(srcpad) : 1;
+
+ Newx(dstpad, 1, PADLIST);
+ ptr_table_store(PL_ptr_table, srcpad, dstpad);
+ PadlistMAX(dstpad) = max;
+ Newx(PadlistARRAY(dstpad), max + 1, PAD *);
+
+ if (cloneall) {
+ PADOFFSET depth;
+ for (depth = 0; depth <= max; ++depth)
+ PadlistARRAY(dstpad)[depth] =
+ av_dup_inc(PadlistARRAY(srcpad)[depth], param);
} else {
/* CvDEPTH() on our subroutine will be set to 0, so there's no need
to build anything other than the first level of pads. */
-
- I32 ix = AvFILLp((const AV *)AvARRAY(srcpad)[1]);
+ I32 ix = AvFILLp(PadlistARRAY(srcpad)[1]);
AV *pad1;
- const I32 names_fill = AvFILLp((const AV *)(AvARRAY(srcpad)[0]));
- const AV *const srcpad1 = (const AV *) AvARRAY(srcpad)[1];
+ const I32 names_fill = AvFILLp(PadlistARRAY(srcpad)[0]);
+ const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
SV **oldpad = AvARRAY(srcpad1);
SV **names;
SV **pad1a;
AV *args;
- /* look for it in the table first.
- I *think* that it shouldn't be possible to find it there.
- Well, except for how Perl_sv_compile_2op() "works" :-( */
- dstpad = (AV*)ptr_table_fetch(PL_ptr_table, srcpad);
- if (dstpad)
- return dstpad;
+ PadlistARRAY(dstpad)[0] =
+ av_dup_inc(PadlistARRAY(srcpad)[0], param);
+ names = AvARRAY(PadlistARRAY(dstpad)[0]);
- dstpad = newAV();
- ptr_table_store(PL_ptr_table, srcpad, dstpad);
- AvREAL_off(dstpad);
- av_extend(dstpad, 1);
- AvARRAY(dstpad)[0] = MUTABLE_SV(av_dup_inc(AvARRAY(srcpad)[0], param));
- names = AvARRAY(AvARRAY(dstpad)[0]);
-
pad1 = newAV();
av_extend(pad1, ix);
- AvARRAY(dstpad)[1] = MUTABLE_SV(pad1);
+ PadlistARRAY(dstpad)[1] = pad1;
pad1a = AvARRAY(pad1);
- AvFILLp(dstpad) = 1;
if (ix > -1) {
AvFILLp(pad1) = ix;
@@ -2010,14 +2474,38 @@
return dstpad;
}
-#endif
+#endif /* USE_ITHREADS */
+PAD **
+Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
+{
+ dVAR;
+ PAD **ary;
+ SSize_t const oldmax = PadlistMAX(padlist);
+
+ PERL_ARGS_ASSERT_PADLIST_STORE;
+
+ assert(key >= 0);
+
+ if (key > PadlistMAX(padlist)) {
+ av_extend_guts(NULL,key,&PadlistMAX(padlist),
+ (SV ***)&PadlistARRAY(padlist),
+ (SV ***)&PadlistARRAY(padlist));
+ Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
+ PAD *);
+ }
+ ary = PadlistARRAY(padlist);
+ SvREFCNT_dec(ary[key]);
+ ary[key] = val;
+ return &ary[key];
+}
+
/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/pad.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/pad.h
===================================================================
--- trunk/contrib/perl/pad.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/pad.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -1,6 +1,7 @@
/* pad.h
*
- * Copyright (C) 2002, 2003, 2005, 2006, 2007, 2008 by Larry Wall and others
+ * Copyright (C) 2002, 2003, 2005, 2006, 2007, 2008,
+ * 2009, 2010, 2011 by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
@@ -10,16 +11,11 @@
* variables, op targets and constants.
*/
+/*
+=head1 Pad Data Structures
+*/
-
-/* a padlist is currently just an AV; but that might change,
- * so hide the type. Ditto a pad. */
-
-typedef AV PADLIST;
-typedef AV PAD;
-
-
/* offsets within a pad */
#if PTRSIZE == 4
@@ -31,6 +27,14 @@
#endif
#define NOT_IN_PAD ((PADOFFSET) -1)
+
+struct padlist {
+ SSize_t xpadl_max; /* max index for which array has space */
+ PAD ** xpadl_alloc; /* pointer to beginning of array of AVs */
+ PADNAMELIST*xpadl_outid; /* Padnamelist of outer pad; used as ID */
+};
+
+
/* a value that PL_cop_seqmax is guaranteed never to be,
* flagging that a lexical is being introduced, or has not yet left scope
*/
@@ -118,16 +122,15 @@
padtidy_FORMAT /* or a format */
} padtidy_type;
-#ifdef PERL_CORE
+/* flags for pad_add_name_pvn. */
-/* flags for pad_add_name. SVf_UTF8 will also be valid in the future. */
+#define padadd_OUR 0x01 /* our declaration. */
+#define padadd_STATE 0x02 /* state declaration. */
+#define padadd_NO_DUP_CHECK 0x04 /* skip warning on dups. */
+#define padadd_STALEOK 0x08 /* allow stale lexical in active
+ * sub, but only one level up */
+#define padadd_UTF8_NAME SVf_UTF8 /* name is UTF-8 encoded. */
-# define padadd_OUR 0x01 /* our declaration. */
-# define padadd_STATE 0x02 /* state declaration. */
-# define padadd_NO_DUP_CHECK 0x04 /* skip warning on dups. */
-
-#endif
-
/* ASSERT_CURPAD_LEGAL and ASSERT_CURPAD_ACTIVE respectively determine
* whether PL_comppad and PL_curpad are consistent and whether they have
* active values */
@@ -171,9 +174,68 @@
save PL_comppad and PL_curpad
+=for apidoc Amx|PAD **|PadlistARRAY|PADLIST padlist
+The C array of a padlist, containing the pads. Only subscript it with
+numbers >= 1, as the 0th entry is not guaranteed to remain usable.
+=for apidoc Amx|SSize_t|PadlistMAX|PADLIST padlist
+The index of the last pad in the padlist.
+=for apidoc Amx|PADNAMELIST *|PadlistNAMES|PADLIST padlist
+The names associated with pad entries.
+=for apidoc Amx|PADNAME **|PadlistNAMESARRAY|PADLIST padlist
+The C array of pad names.
+
+=for apidoc Amx|SSize_t|PadlistNAMESMAX|PADLIST padlist
+The index of the last pad name.
+
+=for apidoc Amx|U32|PadlistREFCNT|PADLIST padlist
+The reference count of the padlist. Currently this is always 1.
+
+=for apidoc Amx|PADNAME **|PadnamelistARRAY|PADNAMELIST pnl
+The C array of pad names.
+
+=for apidoc Amx|SSize_t|PadnamelistMAX|PADNAMELIST pnl
+The index of the last pad name.
+
+=for apidoc Amx|SV **|PadARRAY|PAD pad
+The C array of pad entries.
+
+=for apidoc Amx|SSize_t|PadMAX|PAD pad
+The index of the last pad entry.
+
+=for apidoc Amx|char *|PadnamePV|PADNAME pn
+The name stored in the pad name struct. This returns NULL for a target or
+GV slot.
+
+=for apidoc Amx|STRLEN|PadnameLEN|PADNAME pn
+The length of the name.
+
+=for apidoc Amx|bool|PadnameUTF8|PADNAME pn
+Whether PadnamePV is in UTF8.
+
+=for apidoc Amx|SV *|PadnameSV|PADNAME pn
+Returns the pad name as an SV. This is currently just C<pn>. It will
+begin returning a new mortal SV if pad names ever stop being SVs.
+
+=for apidoc m|bool|PadnameIsOUR|PADNAME pn
+Whether this is an "our" variable.
+
+=for apidoc m|HV *|PadnameOURSTASH
+The stash in which this "our" variable was declared.
+
+=for apidoc m|bool|PadnameOUTER|PADNAME pn
+Whether this entry belongs to an outer pad.
+
+=for apidoc m|bool|PadnameIsSTATE|PADNAME pn
+Whether this is a "state" variable.
+
+=for apidoc m|HV *|PadnameTYPE|PADNAME pn
+The stash associated with a typed lexical. This returns the %Foo:: hash
+for C<my Foo $bar>.
+
+
=for apidoc m|SV *|PAD_SETSV |PADOFFSET po|SV* sv
Set the slot at offset C<po> in the current pad to C<sv>
@@ -214,6 +276,30 @@
=cut
*/
+#define PadlistARRAY(pl) (pl)->xpadl_alloc
+#define PadlistMAX(pl) (pl)->xpadl_max
+#define PadlistNAMES(pl) (*PadlistARRAY(pl))
+#define PadlistNAMESARRAY(pl) PadnamelistARRAY(PadlistNAMES(pl))
+#define PadlistNAMESMAX(pl) PadnamelistMAX(PadlistNAMES(pl))
+#define PadlistREFCNT(pl) 1 /* reserved for future use */
+
+#define PadnamelistARRAY(pnl) AvARRAY(pnl)
+#define PadnamelistMAX(pnl) AvFILLp(pnl)
+
+#define PadARRAY(pad) AvARRAY(pad)
+#define PadMAX(pad) AvFILLp(pad)
+
+#define PadnamePV(pn) (SvPOKp(pn) ? SvPVX(pn) : NULL)
+#define PadnameLEN(pn) SvCUR(pn)
+#define PadnameUTF8(pn) !!SvUTF8(pn)
+#define PadnameSV(pn) pn
+#define PadnameIsOUR(pn) !!SvPAD_OUR(pn)
+#define PadnameOURSTASH(pn) SvOURSTASH(pn)
+#define PadnameOUTER(pn) !!SvFAKE(pn)
+#define PadnameIsSTATE(pn) !!SvPAD_STATE(pn)
+#define PadnameTYPE(pn) (SvPAD_TYPED(pn) ? SvSTASH(pn) : NULL)
+
+
#ifdef DEBUGGING
# define PAD_SV(po) pad_sv(po)
# define PAD_SETSV(po,sv) pad_setsv(po,sv)
@@ -225,12 +311,13 @@
#define PAD_SVl(po) (PL_curpad[po])
#define PAD_BASE_SV(padlist, po) \
- (AvARRAY(padlist)[1]) \
- ? AvARRAY(MUTABLE_AV((AvARRAY(padlist)[1])))[po] : NULL;
+ (PadlistARRAY(padlist)[1]) \
+ ? AvARRAY(MUTABLE_AV((PadlistARRAY(padlist)[1])))[po] \
+ : NULL;
#define PAD_SET_CUR_NOSAVE(padlist,nth) \
- PL_comppad = (PAD*) (AvARRAY(padlist)[nth]); \
+ PL_comppad = (PAD*) (PadlistARRAY(padlist)[nth]); \
PL_curpad = AvARRAY(PL_comppad); \
DEBUG_Xv(PerlIO_printf(Perl_debug_log, \
"Pad 0x%"UVxf"[0x%"UVxf"] set_cur depth=%d\n", \
@@ -307,10 +394,10 @@
*/
+#define PAD_COMPNAME(po) PAD_COMPNAME_SV(po)
#define PAD_COMPNAME_SV(po) (*av_fetch(PL_comppad_name, (po), FALSE))
#define PAD_COMPNAME_FLAGS(po) SvFLAGS(PAD_COMPNAME_SV(po))
-#define PAD_COMPNAME_FLAGS_isOUR(po) \
- ((PAD_COMPNAME_FLAGS(po) & (SVpad_NAME|SVpad_OUR)) == (SVpad_NAME|SVpad_OUR))
+#define PAD_COMPNAME_FLAGS_isOUR(po) SvPAD_OUR(PAD_COMPNAME_SV(po))
#define PAD_COMPNAME_PV(po) SvPV_nolen(PAD_COMPNAME_SV(po))
#define PAD_COMPNAME_TYPE(po) pad_compname_type(po)
@@ -324,9 +411,6 @@
/*
-=for apidoc m|void|PAD_DUP|PADLIST dstpad|PADLIST srcpad|CLONE_PARAMS* param
-Clone a padlist.
-
=for apidoc m|void|PAD_CLONE_VARS|PerlInterpreter *proto_perl|CLONE_PARAMS* param
Clone the state variables associated with running and compiling pads.
@@ -333,18 +417,6 @@
=cut
*/
-
-#define PAD_DUP(dstpad, srcpad, param) \
- if ((srcpad) && !AvREAL(srcpad)) { \
- /* XXX padlists are real, but pretend to be not */ \
- AvREAL_on(srcpad); \
- (dstpad) = av_dup_inc((srcpad), param); \
- AvREAL_off(srcpad); \
- AvREAL_off(dstpad); \
- } \
- else \
- (dstpad) = av_dup_inc((srcpad), param);
-
/* NB - we set PL_comppad to null unless it points at a value that
* has already been dup'ed, ie it points to part of an active padlist.
* Otherwise PL_comppad ends up being a leaked scalar in code like
@@ -354,7 +426,7 @@
* sub's CV or padlist. */
#define PAD_CLONE_VARS(proto_perl, param) \
- PL_comppad = MUTABLE_AV(ptr_table_fetch(PL_ptr_table, proto_perl->Icomppad)); \
+ PL_comppad = av_dup(proto_perl->Icomppad, param); \
PL_curpad = PL_comppad ? AvARRAY(PL_comppad) : NULL; \
PL_comppad_name = av_dup(proto_perl->Icomppad_name, param); \
PL_comppad_name_fill = proto_perl->Icomppad_name_fill; \
@@ -367,11 +439,35 @@
PL_cop_seqmax = proto_perl->Icop_seqmax;
/*
+=for apidoc Am|PADOFFSET|pad_add_name_pvs|const char *name|U32 flags|HV *typestash|HV *ourstash
+
+Exactly like L</pad_add_name_pvn>, but takes a literal string instead
+of a string/length pair.
+
+=cut
+*/
+
+#define pad_add_name_pvs(name,flags,typestash,ourstash) \
+ Perl_pad_add_name_pvn(aTHX_ STR_WITH_LEN(name), flags, typestash, ourstash)
+
+/*
+=for apidoc Am|PADOFFSET|pad_findmy_pvs|const char *name|U32 flags
+
+Exactly like L</pad_findmy_pvn>, but takes a literal string instead
+of a string/length pair.
+
+=cut
+*/
+
+#define pad_findmy_pvs(name,flags) \
+ Perl_pad_findmy_pvn(aTHX_ STR_WITH_LEN(name), flags)
+
+/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/pad.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/parser.h
===================================================================
--- trunk/contrib/perl/parser.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/parser.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -1,12 +1,12 @@
/* parser.h
*
- * Copyright (c) 2006, 2007, Larry Wall and others
+ * Copyright (c) 2006, 2007, 2009, 2010, 2011 Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*
* This file defines the layout of the parser object used by the parser
- * and lexer (perly.c, toke,c).
+ * and lexer (perly.c, toke.c).
*/
#define YYEMPTY (-2)
@@ -21,6 +21,17 @@
#endif
} yy_stack_frame;
+/* Fields that need to be shared with (i.e., visible to) inner lex-
+ ing scopes. */
+typedef struct yy_lexshared {
+ struct yy_lexshared *ls_prev;
+ SV *ls_linestr; /* mirrors PL_parser->linestr */
+ char *ls_bufptr; /* mirrors PL_parser->bufptr */
+ char *re_eval_start; /* start of "(?{..." text */
+ SV *re_eval_str; /* "(?{...})" text */
+ line_t herelines; /* number of lines in here-doc */
+} LEXSHARED;
+
typedef struct yy_parser {
/* parser state */
@@ -52,7 +63,7 @@
OP *lex_op; /* extra info to pass back on op */
SV *lex_repl; /* runtime replacement from s/// */
U16 lex_inwhat; /* what kind of quoting are we in */
- OPCODE last_lop_op; /* last list operator */
+ OPCODE last_lop_op; /* last named list or unary operator */
I32 lex_starts; /* how many interps done on level */
SV *lex_stuff; /* runtime pattern from m// or s/// */
I32 multi_start; /* 1st line of multi-line string */
@@ -59,19 +70,26 @@
I32 multi_end; /* last line of multi-line string */
char multi_open; /* delimiter of said string */
char multi_close; /* delimiter of said string */
- char pending_ident; /* pending identifier lookup */
bool preambled;
+ bool lex_re_reparsing; /* we're doing G_RE_REPARSING */
I32 lex_allbrackets;/* (), [], {}, ?: bracket count */
SUBLEXINFO sublex_info;
+ LEXSHARED *lex_shared;
SV *linestr; /* current chunk of src text */
- char *bufptr;
- char *oldbufptr;
- char *oldoldbufptr;
+ char *bufptr; /* carries the cursor (current parsing
+ position) from one invocation of yylex
+ to the next */
+ char *oldbufptr; /* in yylex, beginning of current token */
+ char *oldoldbufptr; /* in yylex, beginning of previous token */
char *bufend;
char *linestart; /* beginning of most recently read line */
char *last_uni; /* position of last named-unary op */
char *last_lop; /* position of last list operator */
- line_t copline; /* current line number */
+ /* copline is used to pass a specific line number to newSTATEOP. It
+ is a one-time line number, as newSTATEOP invalidates it (sets it to
+ NOLINE) after using it. The purpose of this is to report line num-
+ bers in multiline constructs using the number of the first line. */
+ line_t copline;
U16 in_my; /* we're compiling a "my"/"our" declaration */
U8 lex_state; /* next token is determined */
U8 error_count; /* how many compile errors so far, max 10 */
@@ -78,6 +96,7 @@
HV *in_my_stash; /* declared class of this "my" declaration */
PerlIO *rsfp; /* current source file pointer */
AV *rsfp_filters; /* holds chain of active source filters */
+ U8 form_lex_state; /* remember lex_state when parsing fmt */
#ifdef PERL_MAD
SV *endwhite;
@@ -105,15 +124,25 @@
COP *saved_curcop; /* the previous PL_curcop */
char tokenbuf[256];
- bool in_pod; /* lexer is within a =pod section */
U8 lex_fakeeof; /* precedence at which to fake EOF */
+ U8 lex_flags;
+ PERL_BITFIELD16 in_pod:1; /* lexer is within a =pod section */
+ PERL_BITFIELD16 filtered:1; /* source filters in evalbytes */
} yy_parser;
/* flags for lexer API */
#define LEX_STUFF_UTF8 0x00000001
#define LEX_KEEP_PREVIOUS 0x00000002
+
#ifdef PERL_CORE
# define LEX_START_SAME_FILTER 0x00000001
+# define LEX_IGNORE_UTF8_HINTS 0x00000002
+# define LEX_EVALBYTES 0x00000004
+# define LEX_START_COPIED 0x00000008
+# define LEX_DONT_CLOSE_RSFP 0x00000010
+# define LEX_START_FLAGS \
+ (LEX_START_SAME_FILTER|LEX_START_COPIED \
+ |LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES|LEX_DONT_CLOSE_RSFP)
#endif
/* flags for parser API */
@@ -139,8 +168,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/parser.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/patchlevel.h
===================================================================
--- trunk/contrib/perl/patchlevel.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/patchlevel.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -14,8 +14,8 @@
* exactly on the third column */
#define PERL_REVISION 5 /* age */
-#define PERL_VERSION 14 /* epoch */
-#define PERL_SUBVERSION 2 /* generation */
+#define PERL_VERSION 18 /* epoch */
+#define PERL_SUBVERSION 1 /* generation */
/* The following numbers describe the earliest compatible version of
Perl ("compatibility" here being defined as sufficient binary/API
@@ -35,7 +35,7 @@
changing them should not be necessary.
*/
#define PERL_API_REVISION 5
-#define PERL_API_VERSION 14
+#define PERL_API_VERSION 18
#define PERL_API_SUBVERSION 0
/*
XXX Note: The selection of non-default Configure options, such
Property changes on: trunk/contrib/perl/patchlevel.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.4
\ No newline at end of property
Modified: trunk/contrib/perl/perl.c
===================================================================
--- trunk/contrib/perl/perl.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/perl.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -2,7 +2,7 @@
/* perl.c
*
* Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
- * 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+ * 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
* by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
@@ -13,7 +13,7 @@
/*
* A ship then new they built for him
* of mithril and of elven-glass
- * --from Bilbo's song of E\xE4rendil
+ * --from Bilbo's song of Eärendil
*
* [p.236 of _The Lord of the Rings_, II/i: "Many Meetings"]
*/
@@ -24,7 +24,7 @@
* function of the interpreter; that can be found in perlmain.c
*/
-#ifdef PERL_IS_MINIPERL
+#if defined(PERL_IS_MINIPERL) && !defined(USE_SITECUSTOMIZE)
# define USE_SITECUSTOMIZE
#endif
@@ -38,15 +38,15 @@
#include "nwutil.h"
#endif
-/* XXX If this causes problems, set i_unistd=undef in the hint file. */
-#ifdef I_UNISTD
-#include <unistd.h>
+#ifdef USE_KERN_PROC_PATHNAME
+# include <sys/sysctl.h>
#endif
+#ifdef USE_NSGETEXECUTABLEPATH
+# include <mach-o/dyld.h>
+#endif
+
#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
-# ifdef I_SYS_WAIT
-# include <sys/wait.h>
-# endif
# ifdef I_SYSUIO
# include <sys/uio.h>
# endif
@@ -58,10 +58,6 @@
#endif
-#ifdef __BEOS__
-# define HZ 1000000
-#endif
-
#ifndef HZ
# ifdef CLK_TCK
# define HZ CLK_TCK
@@ -77,11 +73,9 @@
static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
-/* Drop everything. Heck, don't even try to call it */
-# define validate_suid(validarg, scriptname, fdscript, suidscript, linestr_sv, rsfp) NOOP
+# define validate_suid(rsfp) NOOP
#else
-/* Drop almost everything */
-# define validate_suid(validarg, scriptname, fdscript, suidscript, linestr_sv, rsfp) S_validate_suid(aTHX_ rsfp)
+# define validate_suid(rsfp) S_validate_suid(aTHX_ rsfp)
#endif
#define CALL_BODY_SUB(myop) \
@@ -92,7 +86,7 @@
#define CALL_LIST_BODY(cv) \
PUSHMARK(PL_stack_sp); \
- call_sv(MUTABLE_SV((cv)), G_EVAL|G_DISCARD);
+ call_sv(MUTABLE_SV((cv)), G_EVAL|G_DISCARD|G_VOID);
static void
S_init_tls_and_interp(PerlInterpreter *my_perl)
@@ -105,6 +99,7 @@
ALLOC_THREAD_KEY;
PERL_SET_THX(my_perl);
OP_REFCNT_INIT;
+ OP_CHECK_MUTEX_INIT;
HINTS_REFCNT_INIT;
MUTEX_INIT(&PL_dollarzero_mutex);
MUTEX_INIT(&PL_my_ctx_mutex);
@@ -243,32 +238,10 @@
#endif
PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
- /* set read-only and try to insure than we wont see REFCNT==0
- very often */
+ init_constants();
- SvREADONLY_on(&PL_sv_undef);
- SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
-
- sv_setpv(&PL_sv_no,PL_No);
- /* value lookup in void context - happens to have the side effect
- of caching the numeric forms. However, as &PL_sv_no doesn't contain
- a string that is a valid numer, we have to turn the public flags by
- hand: */
- SvNV(&PL_sv_no);
- SvIV(&PL_sv_no);
- SvIOK_on(&PL_sv_no);
- SvNOK_on(&PL_sv_no);
- SvREADONLY_on(&PL_sv_no);
- SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
-
- sv_setpv(&PL_sv_yes,PL_Yes);
- SvNV(&PL_sv_yes);
- SvIV(&PL_sv_yes);
- SvREADONLY_on(&PL_sv_yes);
- SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
-
SvREADONLY_on(&PL_sv_placeholder);
- SvREFCNT(&PL_sv_placeholder) = (~(U32)0)/2;
+ SvREFCNT(&PL_sv_placeholder) = SvREFCNT_IMMORTAL;
PL_sighandlerp = (Sighandler_t) Perl_sighandler;
#ifdef PERL_USES_PL_PIDSTATUS
@@ -308,10 +281,24 @@
else all hell breaks loose in S_find_uninit_var(). */
Perl_av_create_and_push(aTHX_ &PL_regex_padav, newSVpvs(""));
PL_regex_pad = AvARRAY(PL_regex_padav);
+ Newxz(PL_stashpad, PL_stashpadmax, HV *);
#endif
#ifdef USE_REENTRANT_API
Perl_reentrant_init(aTHX);
#endif
+#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
+ /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
+ * This MUST be done before any hash stores or fetches take place.
+ * If you set PL_hash_seed (and presumably also PL_hash_seed_set)
+ * yourself, it is your responsibility to provide a good random seed!
+ * You can also define PERL_HASH_SEED in compile time, see hv.h.
+ *
+ * XXX: fix this comment */
+ if (PL_hash_seed_set == FALSE) {
+ Perl_get_hash_seed(aTHX_ PL_hash_seed);
+ PL_hash_seed_set= TRUE;
+ }
+#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
/* Note that strtab is a rather special HV. Assumptions are made
about not iterating on it, and not adding tie magic to it.
@@ -334,10 +321,9 @@
/* Use sysconf(_SC_CLK_TCK) if available, if not
* available or if the sysconf() fails, use the HZ.
- * BeOS has those, but returns the wrong value.
* The HZ if not originally defined has been by now
* been defined as CLK_TCK, if available. */
-#if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK) && !defined(__BEOS__)
+#if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK)
PL_clocktick = sysconf(_SC_CLK_TCK);
if (PL_clocktick <= 0)
#endif
@@ -532,6 +518,7 @@
#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
pid_t child;
#endif
+ int i;
PERL_ARGS_ASSERT_PERL_DESTRUCT;
#ifndef MULTIPLICITY
@@ -544,13 +531,18 @@
PERL_WAIT_FOR_CHILDREN;
destruct_level = PL_perl_destruct_level;
-#ifdef DEBUGGING
+#if defined(DEBUGGING) || defined(PERL_TRACK_MEMPOOL)
{
const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
if (s) {
- const int i = atoi(s);
- if (destruct_level < i)
- destruct_level = i;
+ const int i = atoi(s);
+#ifdef DEBUGGING
+ if (destruct_level < i) destruct_level = i;
+#endif
+#ifdef PERL_TRACK_MEMPOOL
+ /* RT #114496, for perl_free */
+ PL_perl_destruct_level = i;
+#endif
}
}
#endif
@@ -562,7 +554,7 @@
JMPENV_PUSH(x);
PERL_UNUSED_VAR(x);
if (PL_endav && !PL_minus_c) {
- PL_phase = PERL_PHASE_END;
+ PERL_SET_PHASE(PERL_PHASE_END);
call_list(PL_scopestack_ix, PL_endav);
}
JMPENV_POP;
@@ -737,10 +729,10 @@
/* We must account for everything. */
/* Destroy the main CV and syntax tree */
- /* Do this now, because destroying ops can cause new SVs to be generated
- in Perl_pad_swipe, and when running with -DDEBUG_LEAKING_SCALARS they
- PL_curcop to point to a valid op from which the filename structure
- member is copied. */
+ /* Set PL_curcop now, because destroying ops can cause new SVs
+ to be generated in Perl_pad_swipe, and when running with
+ -DDEBUG_LEAKING_SCALARS they expect PL_curcop to point to a valid
+ op from which the filename structure member is copied. */
PL_curcop = &PL_compiling;
if (PL_main_root) {
/* ensure comppad/curpad to refer to main's pad */
@@ -757,7 +749,7 @@
* destruct_level > 0 */
SvREFCNT_dec(PL_main_cv);
PL_main_cv = NULL;
- PL_phase = PERL_PHASE_DESTRUCT;
+ PERL_SET_PHASE(PERL_PHASE_DESTRUCT);
/* Tell PerlIO we are about to tear things apart in case
we have layers which are using resources that should
@@ -766,15 +758,12 @@
PerlIO_destruct(aTHX);
- if (PL_sv_objcount) {
- /*
- * Try to destruct global references. We do this first so that the
- * destructors and destructees still exist. Some sv's might remain.
- * Non-referenced objects are on their own.
- */
- sv_clean_objs();
- PL_sv_objcount = 0;
- }
+ /*
+ * Try to destruct global references. We do this first so that the
+ * destructors and destructees still exist. Some sv's might remain.
+ * Non-referenced objects are on their own.
+ */
+ sv_clean_objs();
/* unhook hooks which will soon be, or use, destroyed data */
SvREFCNT_dec(PL_warnhook);
@@ -829,7 +818,6 @@
#endif
CopFILE_free(&PL_compiling);
- CopSTASH_free(&PL_compiling);
/* The exit() function will do everything that needs doing. */
return STATUS_EXIT;
@@ -841,11 +829,18 @@
* REGEXPs in the parent interpreter
* we need to manually ReREFCNT_dec for the clones
*/
- SvREFCNT_dec(PL_regex_padav);
- PL_regex_padav = NULL;
- PL_regex_pad = NULL;
+ {
+ I32 i = AvFILLp(PL_regex_padav);
+ SV **ary = AvARRAY(PL_regex_padav);
+
+ for (; i; i--) {
+ SvREFCNT_dec(ary[i]);
+ ary[i] = &PL_sv_undef;
+ }
+ }
#endif
+
SvREFCNT_dec(MUTABLE_SV(PL_stashcache));
PL_stashcache = NULL;
@@ -870,7 +865,9 @@
PL_minus_F = FALSE;
PL_doswitches = FALSE;
PL_dowarn = G_WARN_OFF;
- PL_sawampersand = FALSE; /* must save all match strings */
+#ifdef PERL_SAWAMPERSAND
+ PL_sawampersand = 0; /* must save all match strings */
+#endif
PL_unsafe = FALSE;
Safefree(PL_inplace);
@@ -905,14 +902,6 @@
/* defgv, aka *_ should be taken care of elsewhere */
- /* clean up after study() */
- SvREFCNT_dec(PL_lastscream);
- PL_lastscream = NULL;
- Safefree(PL_screamfirst);
- PL_screamfirst = 0;
- Safefree(PL_screamnext);
- PL_screamnext = 0;
-
/* float buffer */
Safefree(PL_efloatbuf);
PL_efloatbuf = NULL;
@@ -989,19 +978,11 @@
PL_numeric_radix_sv = NULL;
#endif
- /* clear utf8 character classes */
- SvREFCNT_dec(PL_utf8_alnum);
- SvREFCNT_dec(PL_utf8_ascii);
- SvREFCNT_dec(PL_utf8_alpha);
- SvREFCNT_dec(PL_utf8_space);
- SvREFCNT_dec(PL_utf8_cntrl);
- SvREFCNT_dec(PL_utf8_graph);
- SvREFCNT_dec(PL_utf8_digit);
- SvREFCNT_dec(PL_utf8_upper);
- SvREFCNT_dec(PL_utf8_lower);
- SvREFCNT_dec(PL_utf8_print);
- SvREFCNT_dec(PL_utf8_punct);
- SvREFCNT_dec(PL_utf8_xdigit);
+ /* clear character classes */
+ for (i = 0; i < POSIX_SWASH_COUNT; i++) {
+ SvREFCNT_dec(PL_utf8_swash_ptrs[i]);
+ PL_utf8_swash_ptrs[i] = NULL;
+ }
SvREFCNT_dec(PL_utf8_mark);
SvREFCNT_dec(PL_utf8_toupper);
SvREFCNT_dec(PL_utf8_totitle);
@@ -1010,18 +991,6 @@
SvREFCNT_dec(PL_utf8_idstart);
SvREFCNT_dec(PL_utf8_idcont);
SvREFCNT_dec(PL_utf8_foldclosures);
- PL_utf8_alnum = NULL;
- PL_utf8_ascii = NULL;
- PL_utf8_alpha = NULL;
- PL_utf8_space = NULL;
- PL_utf8_cntrl = NULL;
- PL_utf8_graph = NULL;
- PL_utf8_digit = NULL;
- PL_utf8_upper = NULL;
- PL_utf8_lower = NULL;
- PL_utf8_print = NULL;
- PL_utf8_punct = NULL;
- PL_utf8_xdigit = NULL;
PL_utf8_mark = NULL;
PL_utf8_toupper = NULL;
PL_utf8_totitle = NULL;
@@ -1030,7 +999,17 @@
PL_utf8_idstart = NULL;
PL_utf8_idcont = NULL;
PL_utf8_foldclosures = NULL;
+ for (i = 0; i < POSIX_CC_COUNT; i++) {
+ SvREFCNT_dec(PL_Posix_ptrs[i]);
+ PL_Posix_ptrs[i] = NULL;
+ SvREFCNT_dec(PL_L1Posix_ptrs[i]);
+ PL_L1Posix_ptrs[i] = NULL;
+
+ SvREFCNT_dec(PL_XPosix_ptrs[i]);
+ PL_XPosix_ptrs[i] = NULL;
+ }
+
if (!specialWARN(PL_compiling.cop_warnings))
PerlMemShared_free(PL_compiling.cop_warnings);
PL_compiling.cop_warnings = NULL;
@@ -1037,7 +1016,6 @@
cophh_free(CopHINTHASH_get(&PL_compiling));
CopHINTHASH_set(&PL_compiling, cophh_new_empty());
CopFILE_free(&PL_compiling);
- CopSTASH_free(&PL_compiling);
/* Prepare to destruct main symbol table. */
@@ -1073,6 +1051,12 @@
(long)cxstack_ix + 1);
}
+#ifdef USE_ITHREADS
+ SvREFCNT_dec(PL_regex_padav);
+ PL_regex_padav = NULL;
+ PL_regex_pad = NULL;
+#endif
+
#ifdef PERL_IMPLICIT_CONTEXT
/* the entries in this list are allocated via SV PVX's, so get freed
* in sv_clean_all */
@@ -1085,6 +1069,10 @@
while (sv_clean_all() > 2)
;
+#ifdef USE_ITHREADS
+ Safefree(PL_stashpad); /* must come after sv_clean_all */
+#endif
+
AvREAL_off(PL_fdpid); /* no surviving entries */
SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
PL_fdpid = NULL;
@@ -1163,12 +1151,12 @@
if (PL_sv_count != 0) {
SV* sva;
SV* sv;
- register SV* svend;
+ SV* svend;
for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
svend = &sva[SvREFCNT(sva)];
for (sv = sva + 1; sv < svend; ++sv) {
- if (SvTYPE(sv) != SVTYPEMASK) {
+ if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
" flags=0x%"UVxf
" refcnt=%"UVuf pTHX__FORMAT "\n"
@@ -1216,12 +1204,6 @@
#endif
PL_sv_count = 0;
-#ifdef PERL_DEBUG_READONLY_OPS
- free(PL_slabs);
- PL_slabs = NULL;
- PL_slab_count = 0;
-#endif
-
#if defined(PERLIO_LAYERS)
/* No more IO - including error messages ! */
PerlIO_cleanup(aTHX);
@@ -1236,9 +1218,6 @@
Safefree(PL_origfilename);
PL_origfilename = NULL;
- Safefree(PL_reg_start_tmp);
- PL_reg_start_tmp = (char**)NULL;
- PL_reg_start_tmpl = 0;
Safefree(PL_reg_curpm);
Safefree(PL_reg_poscache);
free_tied_hv_pool();
@@ -1253,10 +1232,9 @@
PL_psig_pend = (int*)NULL;
Safefree(psig_save);
}
- PL_formfeed = NULL;
nuke_stacks();
- PL_tainting = FALSE;
- PL_taint_warn = FALSE;
+ TAINTING_set(FALSE);
+ TAINT_WARN_set(FALSE);
PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
PL_debug = 0;
@@ -1323,8 +1301,7 @@
* Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero
* value as we're probably hunting memory leaks then
*/
- const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
- if (!s || atoi(s) == 0) {
+ if (PL_perl_destruct_level == 0) {
const U32 old_debug = PL_debug;
/* Emulate the PerlHost behaviour of free()ing all memory allocated in this
thread at thread exit. */
@@ -1397,55 +1374,82 @@
++PL_exitlistlen;
}
-#ifdef HAS_PROCSELFEXE
-/* This is a function so that we don't hold on to MAXPATHLEN
- bytes of stack longer than necessary
- */
STATIC void
-S_procself_val(pTHX_ SV *sv, const char *arg0)
-{
- char buf[MAXPATHLEN];
- int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
-
- /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
- includes a spurious NUL which will cause $^X to fail in system
- or backticks (this will prevent extensions from being built and
- many tests from working). readlink is not meant to add a NUL.
- Normal readlink works fine.
- */
- if (len > 0 && buf[len-1] == '\0') {
- len--;
- }
-
- /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
- returning the text "unknown" from the readlink rather than the path
- to the executable (or returning an error from the readlink). Any valid
- path has a '/' in it somewhere, so use that to validate the result.
- See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
- */
- if (len > 0 && memchr(buf, '/', len)) {
- sv_setpvn(sv,buf,len);
- }
- else {
- sv_setpv(sv,arg0);
- }
-}
-#endif /* HAS_PROCSELFEXE */
-
-STATIC void
S_set_caret_X(pTHX) {
dVAR;
GV* tmpgv = gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL, SVt_PV); /* $^X */
if (tmpgv) {
-#ifdef HAS_PROCSELFEXE
- S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
+ SV *const caret_x = GvSV(tmpgv);
+#if defined(OS2)
+ sv_setpv(caret_x, os2_execname(aTHX));
#else
-#ifdef OS2
- sv_setpv(GvSVn(tmpgv), os2_execname(aTHX));
-#else
- sv_setpv(GvSVn(tmpgv),PL_origargv[0]);
+# ifdef USE_KERN_PROC_PATHNAME
+ size_t size = 0;
+ int mib[4];
+ mib[0] = CTL_KERN;
+ mib[1] = KERN_PROC;
+ mib[2] = KERN_PROC_PATHNAME;
+ mib[3] = -1;
+
+ if (sysctl(mib, 4, NULL, &size, NULL, 0) == 0
+ && size > 0 && size < MAXPATHLEN * MAXPATHLEN) {
+ sv_grow(caret_x, size);
+
+ if (sysctl(mib, 4, SvPVX(caret_x), &size, NULL, 0) == 0
+ && size > 2) {
+ SvPOK_only(caret_x);
+ SvCUR_set(caret_x, size - 1);
+ SvTAINT(caret_x);
+ return;
+ }
+ }
+# elif defined(USE_NSGETEXECUTABLEPATH)
+ char buf[1];
+ uint32_t size = sizeof(buf);
+
+ _NSGetExecutablePath(buf, &size);
+ if (size < MAXPATHLEN * MAXPATHLEN) {
+ sv_grow(caret_x, size);
+ if (_NSGetExecutablePath(SvPVX(caret_x), &size) == 0) {
+ char *const tidied = realpath(SvPVX(caret_x), NULL);
+ if (tidied) {
+ sv_setpv(caret_x, tidied);
+ free(tidied);
+ } else {
+ SvPOK_only(caret_x);
+ SvCUR_set(caret_x, size);
+ }
+ return;
+ }
+ }
+# elif defined(HAS_PROCSELFEXE)
+ char buf[MAXPATHLEN];
+ int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
+
+ /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
+ includes a spurious NUL which will cause $^X to fail in system
+ or backticks (this will prevent extensions from being built and
+ many tests from working). readlink is not meant to add a NUL.
+ Normal readlink works fine.
+ */
+ if (len > 0 && buf[len-1] == '\0') {
+ len--;
+ }
+
+ /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
+ returning the text "unknown" from the readlink rather than the path
+ to the executable (or returning an error from the readlink). Any
+ valid path has a '/' in it somewhere, so use that to validate the
+ result. See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
+ */
+ if (len > 0 && memchr(buf, '/', len)) {
+ sv_setpvn(caret_x, buf, len);
+ return;
+ }
+# endif
+ /* Fallback to this: */
+ sv_setpv(caret_x, PL_origargv[0]);
#endif
-#endif
}
}
@@ -1457,6 +1461,12 @@
=cut
*/
+#define SET_CURSTASH(newstash) \
+ if (PL_curstash != newstash) { \
+ SvREFCNT_dec(PL_curstash); \
+ PL_curstash = (HV *)SvREFCNT_inc(newstash); \
+ }
+
int
perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
{
@@ -1469,23 +1479,26 @@
#ifndef MULTIPLICITY
PERL_UNUSED_ARG(my_perl);
#endif
-
-#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
- /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
- * This MUST be done before any hash stores or fetches take place.
- * If you set PL_rehash_seed (and presumably also PL_rehash_seed_set)
- * yourself, it is your responsibility to provide a good random seed!
- * You can also define PERL_HASH_SEED in compile time, see hv.h. */
- if (!PL_rehash_seed_set)
- PL_rehash_seed = get_hash_seed();
+#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) || defined(USE_HASH_SEED_DEBUG)
{
- const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
+ const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
- if (s && (atoi(s) == 1))
- PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n", PL_rehash_seed);
+ if (s && (atoi(s) == 1)) {
+ unsigned char *seed= PERL_HASH_SEED;
+ unsigned char *seed_end= PERL_HASH_SEED + PERL_HASH_SEED_BYTES;
+ PerlIO_printf(Perl_debug_log, "HASH_FUNCTION = %s HASH_SEED = 0x", PERL_HASH_FUNC);
+ while (seed < seed_end) {
+ PerlIO_printf(Perl_debug_log, "%02x", *seed++);
+ }
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+ PerlIO_printf(Perl_debug_log, " PERTURB_KEYS = %d (%s)",
+ PL_HASH_RAND_BITS_ENABLED,
+ PL_HASH_RAND_BITS_ENABLED == 0 ? "NO" : PL_HASH_RAND_BITS_ENABLED == 1 ? "RANDOM" : "DETERMINISTIC");
+#endif
+ PerlIO_printf(Perl_debug_log, "\n");
+ }
}
#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
-
PL_origargc = argc;
PL_origargv = argv;
@@ -1587,7 +1600,7 @@
PL_do_undump = FALSE;
cxstack_ix = -1; /* start label stack again */
init_ids();
- assert (!PL_tainted);
+ assert (!TAINT_get);
TAINT;
S_set_caret_X(aTHX);
TAINT_NOT;
@@ -1615,7 +1628,7 @@
call_list(oldscope, PL_unitcheckav);
}
if (PL_checkav) {
- PL_phase = PERL_PHASE_CHECK;
+ PERL_SET_PHASE(PERL_PHASE_CHECK);
call_list(oldscope, PL_checkav);
}
ret = 0;
@@ -1628,12 +1641,12 @@
while (PL_scopestack_ix > oldscope)
LEAVE;
FREETMPS;
- PL_curstash = PL_defstash;
+ SET_CURSTASH(PL_defstash);
if (PL_unitcheckav) {
call_list(oldscope, PL_unitcheckav);
}
if (PL_checkav) {
- PL_phase = PERL_PHASE_CHECK;
+ PERL_SET_PHASE(PERL_PHASE_CHECK);
call_list(oldscope, PL_checkav);
}
ret = STATUS_EXIT;
@@ -1663,7 +1676,7 @@
#endif
const int entries = 3 + local_patch_count;
int i;
- static char non_bincompat_options[] =
+ static const char non_bincompat_options[] =
# ifdef DEBUGGING
" DEBUGGING"
# endif
@@ -1670,6 +1683,9 @@
# ifdef NO_MATHOMS
" NO_MATHOMS"
# endif
+# ifdef NO_HASH_SEED
+ " NO_HASH_SEED"
+# endif
# ifdef PERL_DISABLE_PMC
" PERL_DISABLE_PMC"
# endif
@@ -1679,6 +1695,30 @@
# ifdef PERL_EXTERNAL_GLOB
" PERL_EXTERNAL_GLOB"
# endif
+# ifdef PERL_HASH_FUNC_SIPHASH
+ " PERL_HASH_FUNC_SIPHASH"
+# endif
+# ifdef PERL_HASH_FUNC_SDBM
+ " PERL_HASH_FUNC_SDBM"
+# endif
+# ifdef PERL_HASH_FUNC_DJB2
+ " PERL_HASH_FUNC_DJB2"
+# endif
+# ifdef PERL_HASH_FUNC_SUPERFAST
+ " PERL_HASH_FUNC_SUPERFAST"
+# endif
+# ifdef PERL_HASH_FUNC_MURMUR3
+ " PERL_HASH_FUNC_MURMUR3"
+# endif
+# ifdef PERL_HASH_FUNC_ONE_AT_A_TIME
+ " PERL_HASH_FUNC_ONE_AT_A_TIME"
+# endif
+# ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_HARD
+ " PERL_HASH_FUNC_ONE_AT_A_TIME_HARD"
+# endif
+# ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_OLD
+ " PERL_HASH_FUNC_ONE_AT_A_TIME_OLD"
+# endif
# ifdef PERL_IS_MINIPERL
" PERL_IS_MINIPERL"
# endif
@@ -1691,9 +1731,24 @@
# ifdef PERL_MEM_LOG_NOIMPL
" PERL_MEM_LOG_NOIMPL"
# endif
+# ifdef PERL_NEW_COPY_ON_WRITE
+ " PERL_NEW_COPY_ON_WRITE"
+# endif
+# ifdef PERL_PERTURB_KEYS_DETERMINISTIC
+ " PERL_PERTURB_KEYS_DETERMINISTIC"
+# endif
+# ifdef PERL_PERTURB_KEYS_DISABLED
+ " PERL_PERTURB_KEYS_DISABLED"
+# endif
+# ifdef PERL_PERTURB_KEYS_RANDOM
+ " PERL_PERTURB_KEYS_RANDOM"
+# endif
# ifdef PERL_PRESERVE_IVUV
" PERL_PRESERVE_IVUV"
# endif
+# ifdef PERL_RELOCATABLE_INCPUSH
+ " PERL_RELOCATABLE_INCPUSH"
+# endif
# ifdef PERL_USE_DEVEL
" PERL_USE_DEVEL"
# endif
@@ -1700,6 +1755,9 @@
# ifdef PERL_USE_SAFE_PUTENV
" PERL_USE_SAFE_PUTENV"
# endif
+# ifdef UNLINK_ALL_VERSIONS
+ " UNLINK_ALL_VERSIONS"
+# endif
# ifdef USE_ATTRIBUTES_FOR_PERLIO
" USE_ATTRIBUTES_FOR_PERLIO"
# endif
@@ -1706,6 +1764,15 @@
# ifdef USE_FAST_STDIO
" USE_FAST_STDIO"
# endif
+# ifdef USE_HASH_SEED_EXPLICIT
+ " USE_HASH_SEED_EXPLICIT"
+# endif
+# ifdef USE_LOCALE
+ " USE_LOCALE"
+# endif
+# ifdef USE_LOCALE_CTYPE
+ " USE_LOCALE_CTYPE"
+# endif
# ifdef USE_PERL_ATOF
" USE_PERL_ATOF"
# endif
@@ -1761,20 +1828,18 @@
char **argv = PL_origargv;
const char *scriptname = NULL;
VOL bool dosearch = FALSE;
- register char c;
+ char c;
bool doextract = FALSE;
const char *cddir = NULL;
#ifdef USE_SITECUSTOMIZE
bool minus_f = FALSE;
#endif
- SV *linestr_sv = newSV_type(SVt_PVIV);
+ SV *linestr_sv = NULL;
bool add_read_e_script = FALSE;
+ U32 lex_start_flags = 0;
- PL_phase = PERL_PHASE_START;
+ PERL_SET_PHASE(PERL_PHASE_START);
- SvGROW(linestr_sv, 80);
- sv_setpvs(linestr_sv,"");
-
init_main_stash();
{
@@ -1815,17 +1880,31 @@
break;
case 't':
+#if SILENT_NO_TAINT_SUPPORT
+ /* silently ignore */
+#elif NO_TAINT_SUPPORT
+ Perl_croak_nocontext("This perl was compiled without taint support. "
+ "Cowardly refusing to run with -t or -T flags");
+#else
CHECK_MALLOC_TOO_LATE_FOR('t');
- if( !PL_tainting ) {
- PL_taint_warn = TRUE;
- PL_tainting = TRUE;
+ if( !TAINTING_get ) {
+ TAINT_WARN_set(TRUE);
+ TAINTING_set(TRUE);
}
+#endif
s++;
goto reswitch;
case 'T':
+#if SILENT_NO_TAINT_SUPPORT
+ /* silently ignore */
+#elif NO_TAINT_SUPPORT
+ Perl_croak_nocontext("This perl was compiled without taint support. "
+ "Cowardly refusing to run with -t or -T flags");
+#else
CHECK_MALLOC_TOO_LATE_FOR('T');
- PL_tainting = TRUE;
- PL_taint_warn = FALSE;
+ TAINTING_set(TRUE);
+ TAINT_WARN_set(FALSE);
+#endif
s++;
goto reswitch;
@@ -1905,15 +1984,12 @@
argc--,argv++;
goto switch_end;
}
- /* catch use of gnu style long options */
- if (strEQ(s, "version")) {
- s = (char *)"v";
- goto reswitch;
- }
- if (strEQ(s, "help")) {
- s = (char *)"h";
- goto reswitch;
- }
+ /* catch use of gnu style long options.
+ Both of these exit immediately. */
+ if (strEQ(s, "version"))
+ minus_v();
+ if (strEQ(s, "help"))
+ usage();
s--;
/* FALL THROUGH */
default:
@@ -1929,7 +2005,7 @@
if (
#ifndef SECURE_INTERNAL_GETENV
- !PL_tainting &&
+ !TAINTING_get &&
#endif
(s = PerlEnv_getenv("PERL5OPT")))
{
@@ -1936,9 +2012,16 @@
while (isSPACE(*s))
s++;
if (*s == '-' && *(s+1) == 'T') {
+#if SILENT_NO_TAINT_SUPPORT
+ /* silently ignore */
+#elif NO_TAINT_SUPPORT
+ Perl_croak_nocontext("This perl was compiled without taint support. "
+ "Cowardly refusing to run with -t or -T flags");
+#else
CHECK_MALLOC_TOO_LATE_FOR('T');
- PL_tainting = TRUE;
- PL_taint_warn = FALSE;
+ TAINTING_set(TRUE);
+ TAINT_WARN_set(FALSE);
+#endif
}
else {
char *popt_copy = NULL;
@@ -1968,10 +2051,17 @@
}
}
if (*d == 't') {
- if( !PL_tainting ) {
- PL_taint_warn = TRUE;
- PL_tainting = TRUE;
+#if SILENT_NO_TAINT_SUPPORT
+ /* silently ignore */
+#elif NO_TAINT_SUPPORT
+ Perl_croak_nocontext("This perl was compiled without taint support. "
+ "Cowardly refusing to run with -t or -T flags");
+#else
+ if( !TAINTING_get) {
+ TAINT_WARN_set(TRUE);
+ TAINTING_set(TRUE);
}
+#endif
} else {
moreswitches(d);
}
@@ -1980,10 +2070,19 @@
}
}
+ /* Set $^X early so that it can be used for relocatable paths in @INC */
+ /* and for SITELIB_EXP in USE_SITECUSTOMIZE */
+ assert (!TAINT_get);
+ TAINT;
+ S_set_caret_X(aTHX);
+ TAINT_NOT;
+
#if defined(USE_SITECUSTOMIZE)
if (!minus_f) {
/* The games with local $! are to avoid setting errno if there is no
- sitecustomize script. */
+ sitecustomize script. "q%c...%c", 0, ..., 0 becomes "q\0...\0",
+ ie a q() operator with a NUL byte as a the delimiter. This avoids
+ problems with pathnames containing (say) ' */
# ifdef PERL_IS_MINIPERL
AV *const inc = GvAV(PL_incgv);
SV **const inc0 = inc ? av_fetch(inc, 0, FALSE) : NULL;
@@ -1991,14 +2090,26 @@
if (inc0) {
(void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
Perl_newSVpvf(aTHX_
- "BEGIN { do {local $!; -f '%"SVf"/buildcustomize.pl'} && do '%"SVf"/buildcustomize.pl' }", *inc0, *inc0));
+ "BEGIN { do {local $!; -f q%c%"SVf"/buildcustomize.pl%c} && do q%c%"SVf"/buildcustomize.pl%c }",
+ 0, *inc0, 0,
+ 0, *inc0, 0));
}
# else
/* SITELIB_EXP is a function call on Win32. */
- const char *const sitelib = SITELIB_EXP;
- (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
- Perl_newSVpvf(aTHX_
- "BEGIN { do {local $!; -f '%s/sitecustomize.pl'} && do '%s/sitecustomize.pl' }", sitelib, sitelib));
+ const char *const raw_sitelib = SITELIB_EXP;
+ if (raw_sitelib) {
+ /* process .../.. if PERL_RELOCATABLE_INC is defined */
+ SV *sitelib_sv = mayberelocate(raw_sitelib, strlen(raw_sitelib),
+ INCPUSH_CAN_RELOCATE);
+ const char *const sitelib = SvPVX(sitelib_sv);
+ (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
+ Perl_newSVpvf(aTHX_
+ "BEGIN { do {local $!; -f q%c%s/sitecustomize.pl%c} && do q%c%s/sitecustomize.pl%c }",
+ 0, sitelib, 0,
+ 0, sitelib, 0));
+ assert (SvREFCNT(sitelib_sv) == 1);
+ SvREFCNT_dec(sitelib_sv);
+ }
# endif
}
#endif
@@ -2017,20 +2128,19 @@
scriptname = "-";
}
- /* Set $^X early so that it can be used for relocatable paths in @INC */
- assert (!PL_tainted);
- TAINT;
- S_set_caret_X(aTHX);
- TAINT_NOT;
+ assert (!TAINT_get);
init_perllib();
{
bool suidscript = FALSE;
- open_script(scriptname, dosearch, &suidscript, &rsfp);
+ rsfp = open_script(scriptname, dosearch, &suidscript);
+ if (!rsfp) {
+ rsfp = PerlIO_stdin();
+ lex_start_flags = LEX_DONT_CLOSE_RSFP;
+ }
- validate_suid(validarg, scriptname, fdscript, suidscript,
- linestr_sv, rsfp);
+ validate_suid(rsfp);
#ifndef PERL_MICRO
# if defined(SIGCHLD) || defined(SIGCLD)
@@ -2055,6 +2165,8 @@
forbid_setid('x', suidscript);
/* Hence you can't get here if suidscript is true */
+ linestr_sv = newSV_type(SVt_PV);
+ lex_start_flags |= LEX_START_COPIED;
find_beginning(linestr_sv, rsfp);
if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
Perl_croak(aTHX_ "Can't chdir to %s",cddir);
@@ -2076,7 +2188,7 @@
if (xsinit)
(*xsinit)(aTHX); /* in case linked C routines want magical variables */
#ifndef PERL_MICRO
-#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC) || defined(SYMBIAN)
+#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(SYMBIAN)
init_os_extras();
#endif
#endif
@@ -2159,7 +2271,8 @@
#ifdef PERL_MAD
{
const char *s;
- if ((s = PerlEnv_getenv("PERL_XMLDUMP"))) {
+ if (!TAINTING_get &&
+ (s = PerlEnv_getenv("PERL_XMLDUMP"))) {
PL_madskills = 1;
PL_minus_c = 1;
if (!s || !s[0])
@@ -2182,7 +2295,9 @@
}
#endif
- lex_start(linestr_sv, rsfp, 0);
+ lex_start(linestr_sv, rsfp, lex_start_flags);
+ SvREFCNT_dec(linestr_sv);
+
PL_subname = newSVpvs("main");
if (add_read_e_script)
@@ -2200,7 +2315,7 @@
}
}
CopLINE_set(PL_curcop, 0);
- PL_curstash = PL_defstash;
+ SET_CURSTASH(PL_defstash);
if (PL_e_script) {
SvREFCNT_dec(PL_e_script);
PL_e_script = NULL;
@@ -2271,10 +2386,10 @@
while (PL_scopestack_ix > oldscope)
LEAVE;
FREETMPS;
- PL_curstash = PL_defstash;
+ SET_CURSTASH(PL_defstash);
if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
PL_endav && !PL_minus_c) {
- PL_phase = PERL_PHASE_END;
+ PERL_SET_PHASE(PERL_PHASE_END);
call_list(oldscope, PL_endav);
}
#ifdef MYMALLOC
@@ -2288,7 +2403,7 @@
POPSTACK_TO(PL_mainstack);
goto redo_body;
}
- PerlIO_printf(Perl_error_log, "panic: restartop\n");
+ PerlIO_printf(Perl_error_log, "panic: restartop in perl_run\n");
FREETMPS;
ret = 1;
break;
@@ -2302,8 +2417,9 @@
S_run_body(pTHX_ I32 oldscope)
{
dVAR;
- DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
- PL_sawampersand ? "Enabling" : "Omitting"));
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support (0x%x).\n",
+ PL_sawampersand ? "Enabling" : "Omitting",
+ (unsigned int)(PL_sawampersand)));
if (!PL_restartop) {
#ifdef PERL_MAD
@@ -2326,17 +2442,18 @@
if (PERLDB_SINGLE && PL_DBsingle)
sv_setiv(PL_DBsingle, 1);
if (PL_initav) {
- PL_phase = PERL_PHASE_INIT;
+ PERL_SET_PHASE(PERL_PHASE_INIT);
call_list(oldscope, PL_initav);
}
#ifdef PERL_DEBUG_READONLY_OPS
- Perl_pending_Slabs_to_ro(aTHX);
+ if (PL_main_root && PL_main_root->op_slabbed)
+ Slab_to_ro(OpSLAB(PL_main_root));
#endif
}
/* do it */
- PL_phase = PERL_PHASE_RUN;
+ PERL_SET_PHASE(PERL_PHASE_RUN);
if (PL_restartop) {
PL_restartjmpenv = NULL;
@@ -2350,7 +2467,7 @@
CALLRUNOPS(aTHX);
}
my_exit(0);
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
}
/*
@@ -2384,11 +2501,14 @@
=for apidoc p||get_av
-Returns the AV of the specified Perl array. C<flags> are passed to
-C<gv_fetchpv>. If C<GV_ADD> is set and the
+Returns the AV of the specified Perl global or package array with the given
+name (so it won't work on lexical variables). C<flags> are passed
+to C<gv_fetchpv>. If C<GV_ADD> is set and the
Perl variable does not exist then it will be created. If C<flags> is zero
and the variable does not exist then NULL is returned.
+Perl equivalent: C<@{"$name"}>.
+
=cut
*/
@@ -2455,17 +2575,14 @@
Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
{
GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV);
+
+ PERL_ARGS_ASSERT_GET_CVN_FLAGS;
+
/* XXX this is probably not what they think they're getting.
* It has the same effect as "sub name;", i.e. just a forward
* declaration! */
-
- PERL_ARGS_ASSERT_GET_CVN_FLAGS;
-
if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) {
- SV *const sv = newSVpvn_flags(name, len, flags & SVf_UTF8);
- return newSUB(start_subparse(FALSE, 0),
- newSVOP(OP_CONST, 0, sv),
- NULL, NULL);
+ return newSTUB(gv,0);
}
if (gv)
return GvCVu(gv);
@@ -2490,13 +2607,16 @@
=for apidoc p||call_argv
-Performs a callback to the specified Perl sub. See L<perlcall>.
+Performs a callback to the specified named and package-scoped Perl subroutine
+with C<argv> (a NULL-terminated array of strings) as arguments. See L<perlcall>.
+Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>.
+
=cut
*/
I32
-Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
+Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv)
/* See G_* flags in cop.h */
/* null terminated arg list */
@@ -2596,7 +2716,6 @@
}
Zero(&myop, 1, LOGOP);
- myop.op_next = NULL;
if (!(flags & G_NOARGS))
myop.op_flags |= OPf_STACKED;
myop.op_flags |= OP_GIMME_REVERSE(flags);
@@ -2615,11 +2734,11 @@
* curstash may be meaningless. */
&& (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash)
&& !(flags & G_NODEBUG))
- PL_op->op_private |= OPpENTERSUB_DB;
+ myop.op_private |= OPpENTERSUB_DB;
if (flags & G_METHOD) {
Zero(&method_op, 1, UNOP);
- method_op.op_next = PL_op;
+ method_op.op_next = (OP*)&myop;
method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
method_op.op_type = OP_METHOD;
myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
@@ -2655,11 +2774,11 @@
/* FALL THROUGH */
case 2:
/* my_exit() was called */
- PL_curstash = PL_defstash;
+ SET_CURSTASH(PL_defstash);
FREETMPS;
JMPENV_POP;
my_exit_jump();
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
case 3:
if (PL_restartop) {
PL_restartjmpenv = NULL;
@@ -2726,18 +2845,20 @@
SAVEOP();
PL_op = (OP*)&myop;
- Zero(PL_op, 1, UNOP);
+ Zero(&myop, 1, UNOP);
EXTEND(PL_stack_sp, 1);
*++PL_stack_sp = sv;
if (!(flags & G_NOARGS))
myop.op_flags = OPf_STACKED;
- myop.op_next = NULL;
myop.op_type = OP_ENTEREVAL;
myop.op_flags |= OP_GIMME_REVERSE(flags);
if (flags & G_KEEPERR)
myop.op_flags |= OPf_SPECIAL;
+ if (flags & G_RE_REPARSING)
+ myop.op_private = (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING);
+
/* fail now; otherwise we could fail after the JMPENV_PUSH but
* before a PUSHEVAL, which corrupts the stack after a croak */
TAINT_PROPER("eval_sv()");
@@ -2762,11 +2883,11 @@
/* FALL THROUGH */
case 2:
/* my_exit() was called */
- PL_curstash = PL_defstash;
+ SET_CURSTASH(PL_defstash);
FREETMPS;
JMPENV_POP;
my_exit_jump();
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
case 3:
if (PL_restartop) {
PL_restartjmpenv = NULL;
@@ -2808,7 +2929,6 @@
Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
{
dVAR;
- dSP;
SV* sv = newSVpv(p, 0);
PERL_ARGS_ASSERT_EVAL_PV;
@@ -2816,12 +2936,18 @@
eval_sv(sv, G_SCALAR);
SvREFCNT_dec(sv);
- SPAGAIN;
- sv = POPs;
- PUTBACK;
+ {
+ dSP;
+ sv = POPs;
+ PUTBACK;
+ }
- if (croak_on_error && SvTRUE(ERRSV)) {
- Perl_croak(aTHX_ "%s", SvPVx_nolen_const(ERRSV));
+ /* just check empty string or undef? */
+ if (croak_on_error) {
+ SV * const errsv = ERRSV;
+ if(SvTRUE_NN(errsv))
+ /* replace with croak_sv? */
+ Perl_croak_nocontext("%s", SvPV_nolen_const(errsv));
}
return sv;
@@ -2858,7 +2984,7 @@
}
STATIC void
-S_usage(pTHX_ const char *name) /* XXX move this out into a module ? */
+S_usage(pTHX) /* XXX move this out into a module ? */
{
/* This message really ought to be max 23 lines.
* Removed -h because the user already knows that option. Others? */
@@ -2901,13 +3027,12 @@
const char * const *p = usage_msg;
PerlIO *out = PerlIO_stdout();
- PERL_ARGS_ASSERT_USAGE;
-
PerlIO_printf(out,
"\nUsage: %s [switches] [--] [programfile] [arguments]\n",
- name);
+ PL_origargv[0]);
while (*p)
PerlIO_puts(out, *p++);
+ my_exit(0);
}
/* convert a string of -D options (or digits) into an int.
@@ -2934,6 +3059,7 @@
" H Hash dump -- usurps values()\n"
" X Scratchpad allocation\n"
" D Cleaning up\n"
+ " S Op slab allocation\n"
" T Tokenising\n"
" R Include reference counts of dumped variables (eg when using -Ds)\n",
" J Do not s,t,P-debug (Jump over) opcodes within package DB\n"
@@ -2953,7 +3079,7 @@
/* if adding extra options, remember to update DEBUG_MASK */
static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMB";
- for (; isALNUM(**s); (*s)++) {
+ for (; isWORDCHAR(**s); (*s)++) {
const char * const d = strchr(debopts,**s);
if (d)
i |= 1 << (d - debopts);
@@ -2964,7 +3090,7 @@
}
else if (isDIGIT(**s)) {
i = atoi(*s);
- for (; isALNUM(**s); (*s)++) ;
+ for (; isWORDCHAR(**s); (*s)++) ;
}
else if (givehelp) {
const char *const *p = usage_msgd;
@@ -3058,7 +3184,7 @@
s++;
/* -dt indicates to the debugger that threads will be used */
- if (*s == 't' && !isALNUM(s[1])) {
+ if (*s == 't' && !isWORDCHAR(s[1])) {
++s;
my_setenv("PERL5DB_THREADED", "1");
}
@@ -3081,7 +3207,7 @@
end = s + strlen(s);
/* We now allow -d:Module=Foo,Bar and -d:-Module */
- while(isALNUM(*s) || *s==':') ++s;
+ while(isWORDCHAR(*s) || *s==':') ++s;
if (*s != '=')
sv_catpvn(sv, start, end - start);
else {
@@ -3109,13 +3235,12 @@
if (ckWARN_d(WARN_DEBUGGING))
Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
"Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
- for (s++; isALNUM(*s); s++) ;
+ for (s++; isWORDCHAR(*s); s++) ;
#endif
return s;
}
case 'h':
- usage(PL_origargv[0]);
- my_exit(0);
+ usage();
case 'i':
Safefree(PL_inplace);
#if defined(__CYGWIN__) /* do backup extension automagically */
@@ -3203,7 +3328,7 @@
sv = newSVpvn(use,4);
start = s;
/* We allow -M'Module qw(Foo Bar)' */
- while(isALNUM(*s) || *s==':') {
+ while(isWORDCHAR(*s) || *s==':') {
if( *s++ == ':' ) {
if( *s == ':' )
s++;
@@ -3254,14 +3379,17 @@
s++;
return s;
case 't':
- if (!PL_tainting)
- TOO_LATE_FOR('t');
+ case 'T':
+#if SILENT_NO_TAINT_SUPPORT
+ /* silently ignore */
+#elif NO_TAINT_SUPPORT
+ Perl_croak_nocontext("This perl was compiled without taint support. "
+ "Cowardly refusing to run with -t or -T flags");
+#else
+ if (!TAINTING_get)
+ TOO_LATE_FOR(*s);
+#endif
s++;
- return s;
- case 'T':
- if (!PL_tainting)
- TOO_LATE_FOR('T');
- s++;
return s;
case 'u':
PL_do_undump = TRUE;
@@ -3272,6 +3400,65 @@
s++;
return s;
case 'v':
+ minus_v();
+ case 'w':
+ if (! (PL_dowarn & G_WARN_ALL_MASK)) {
+ PL_dowarn |= G_WARN_ON;
+ }
+ s++;
+ return s;
+ case 'W':
+ PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
+ if (!specialWARN(PL_compiling.cop_warnings))
+ PerlMemShared_free(PL_compiling.cop_warnings);
+ PL_compiling.cop_warnings = pWARN_ALL ;
+ s++;
+ return s;
+ case 'X':
+ PL_dowarn = G_WARN_ALL_OFF;
+ if (!specialWARN(PL_compiling.cop_warnings))
+ PerlMemShared_free(PL_compiling.cop_warnings);
+ PL_compiling.cop_warnings = pWARN_NONE ;
+ s++;
+ return s;
+ case '*':
+ case ' ':
+ while( *s == ' ' )
+ ++s;
+ if (s[0] == '-') /* Additional switches on #! line. */
+ return s+1;
+ break;
+ case '-':
+ case 0:
+#if defined(WIN32) || !defined(PERL_STRICT_CR)
+ case '\r':
+#endif
+ case '\n':
+ case '\t':
+ break;
+#ifdef ALTERNATE_SHEBANG
+ case 'S': /* OS/2 needs -S on "extproc" line. */
+ break;
+#endif
+ case 'e': case 'f': case 'x': case 'E':
+#ifndef ALTERNATE_SHEBANG
+ case 'S':
+#endif
+ case 'V':
+ Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
+ default:
+ Perl_croak(aTHX_
+ "Unrecognized switch: -%.1s (-h will show valid options)",s
+ );
+ }
+ return NULL;
+}
+
+
+STATIC void
+S_minus_v(pTHX)
+{
+ PerlIO * PIO_stdout;
if (!sv_derived_from(PL_patchlevel, "version"))
upg_version(PL_patchlevel, TRUE);
#if !defined(DGUX)
@@ -3283,16 +3470,22 @@
# else
SV *num = newSVpvs(PERL_PATCHNUM);
# endif
-
- if (sv_len(num)>=sv_len(level) && strnEQ(SvPV_nolen(num),SvPV_nolen(level),sv_len(level))) {
- SvREFCNT_dec(level);
- level= num;
- } else {
- Perl_sv_catpvf(aTHX_ level, " (%"SVf")", num);
- SvREFCNT_dec(num);
+ {
+ STRLEN level_len, num_len;
+ char * level_str, * num_str;
+ num_str = SvPV(num, num_len);
+ level_str = SvPV(level, level_len);
+ if (num_len>=level_len && strnEQ(num_str,level_str,level_len)) {
+ SvREFCNT_dec(level);
+ level= num;
+ } else {
+ Perl_sv_catpvf(aTHX_ level, " (%"SVf")", num);
+ SvREFCNT_dec(num);
+ }
}
#endif
- PerlIO_printf(PerlIO_stdout(),
+ PIO_stdout = PerlIO_stdout();
+ PerlIO_printf(PIO_stdout,
"\nThis is perl " STRINGIFY(PERL_REVISION)
", version " STRINGIFY(PERL_VERSION)
", subversion " STRINGIFY(PERL_SUBVERSION)
@@ -3301,20 +3494,21 @@
SvREFCNT_dec(level);
}
#else /* DGUX */
+ PIO_stdout = PerlIO_stdout();
/* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
- PerlIO_printf(PerlIO_stdout(),
+ PerlIO_printf(PIO_stdout,
Perl_form(aTHX_ "\nThis is perl, %"SVf"\n",
SVfARG(vstringify(PL_patchlevel))));
- PerlIO_printf(PerlIO_stdout(),
+ PerlIO_printf(PIO_stdout,
Perl_form(aTHX_ " built under %s at %s %s\n",
OSNAME, __DATE__, __TIME__));
- PerlIO_printf(PerlIO_stdout(),
+ PerlIO_printf(PIO_stdout,
Perl_form(aTHX_ " OS Specific Release: %s\n",
OSVERS));
#endif /* !DGUX */
#if defined(LOCAL_PATCH_COUNT)
if (LOCAL_PATCH_COUNT > 0)
- PerlIO_printf(PerlIO_stdout(),
+ PerlIO_printf(PIO_stdout,
"\n(with %d registered patch%s, "
"see perl -V for more detail)",
LOCAL_PATCH_COUNT,
@@ -3321,67 +3515,48 @@
(LOCAL_PATCH_COUNT!=1) ? "es" : "");
#endif
- PerlIO_printf(PerlIO_stdout(),
- "\n\nCopyright 1987-2011, Larry Wall\n");
+ PerlIO_printf(PIO_stdout,
+ "\n\nCopyright 1987-2013, Larry Wall\n");
#ifdef MSDOS
- PerlIO_printf(PerlIO_stdout(),
+ PerlIO_printf(PIO_stdout,
"\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
#endif
#ifdef DJGPP
- PerlIO_printf(PerlIO_stdout(),
+ PerlIO_printf(PIO_stdout,
"djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
"djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
#endif
#ifdef OS2
- PerlIO_printf(PerlIO_stdout(),
+ PerlIO_printf(PIO_stdout,
"\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
"Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
#endif
-#ifdef atarist
- PerlIO_printf(PerlIO_stdout(),
- "atariST series port, ++jrb bammi at cadence.com\n");
-#endif
-#ifdef __BEOS__
- PerlIO_printf(PerlIO_stdout(),
- "BeOS port Copyright Tom Spindler, 1997-1999\n");
-#endif
-#ifdef MPE
- PerlIO_printf(PerlIO_stdout(),
- "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
-#endif
#ifdef OEMVS
- PerlIO_printf(PerlIO_stdout(),
+ PerlIO_printf(PIO_stdout,
"MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
#endif
#ifdef __VOS__
- PerlIO_printf(PerlIO_stdout(),
- "Stratus VOS port by Paul.Green at stratus.com, 1997-2002\n");
+ PerlIO_printf(PIO_stdout,
+ "Stratus OpenVOS port by Paul.Green at stratus.com, 1997-2013\n");
#endif
-#ifdef __OPEN_VM
- PerlIO_printf(PerlIO_stdout(),
- "VM/ESA port by Neale Ferguson, 1998-1999\n");
-#endif
#ifdef POSIX_BC
- PerlIO_printf(PerlIO_stdout(),
+ PerlIO_printf(PIO_stdout,
"BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
#endif
-#ifdef EPOC
- PerlIO_printf(PerlIO_stdout(),
- "EPOC port by Olaf Flebbe, 1999-2002\n");
-#endif
#ifdef UNDER_CE
- PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
- PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
+ PerlIO_printf(PIO_stdout,
+ "WINCE port by Rainer Keuchel, 2001-2002\n"
+ "Built on " __DATE__ " " __TIME__ "\n\n");
wce_hitreturn();
#endif
#ifdef __SYMBIAN32__
- PerlIO_printf(PerlIO_stdout(),
+ PerlIO_printf(PIO_stdout,
"Symbian port by Nokia, 2004-2005\n");
#endif
#ifdef BINARY_BUILD_NOTICE
BINARY_BUILD_NOTICE;
#endif
- PerlIO_printf(PerlIO_stdout(),
+ PerlIO_printf(PIO_stdout,
"\n\
Perl may be copied only under the terms of either the Artistic License or the\n\
GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
@@ -3389,49 +3564,6 @@
this system using \"man perl\" or \"perldoc perl\". If you have access to the\n\
Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
my_exit(0);
- case 'w':
- if (! (PL_dowarn & G_WARN_ALL_MASK)) {
- PL_dowarn |= G_WARN_ON;
- }
- s++;
- return s;
- case 'W':
- PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
- if (!specialWARN(PL_compiling.cop_warnings))
- PerlMemShared_free(PL_compiling.cop_warnings);
- PL_compiling.cop_warnings = pWARN_ALL ;
- s++;
- return s;
- case 'X':
- PL_dowarn = G_WARN_ALL_OFF;
- if (!specialWARN(PL_compiling.cop_warnings))
- PerlMemShared_free(PL_compiling.cop_warnings);
- PL_compiling.cop_warnings = pWARN_NONE ;
- s++;
- return s;
- case '*':
- case ' ':
- while( *s == ' ' )
- ++s;
- if (s[0] == '-') /* Additional switches on #! line. */
- return s+1;
- break;
- case '-':
- case 0:
-#if defined(WIN32) || !defined(PERL_STRICT_CR)
- case '\r':
-#endif
- case '\n':
- case '\t':
- break;
-#ifdef ALTERNATE_SHEBANG
- case 'S': /* OS/2 needs -S on "extproc" line. */
- break;
-#endif
- default:
- Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
- }
- return NULL;
}
/* compliments of Tom Christiansen */
@@ -3439,6 +3571,10 @@
/* unexec() can be found in the Gnu emacs distribution */
/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
+#ifdef VMS
+#include <lib$routines.h>
+#endif
+
void
Perl_my_unexec(pTHX)
{
@@ -3457,7 +3593,6 @@
PerlProc_exit(status);
#else
# ifdef VMS
-# include <lib$routines.h>
lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
# elif defined(WIN32) || defined(__CYGWIN__)
Perl_croak(aTHX_ "dump is not supported");
@@ -3473,14 +3608,14 @@
{
dVAR;
#ifdef MULTIPLICITY
-# define PERLVAR(var,type)
-# define PERLVARA(var,n,type)
+# define PERLVAR(prefix,var,type)
+# define PERLVARA(prefix,var,n,type)
# if defined(PERL_IMPLICIT_CONTEXT)
-# define PERLVARI(var,type,init) aTHX->var = init;
-# define PERLVARIC(var,type,init) aTHX->var = init;
+# define PERLVARI(prefix,var,type,init) aTHX->prefix##var = init;
+# define PERLVARIC(prefix,var,type,init) aTHX->prefix##var = init;
# else
-# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
-# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
+# define PERLVARI(prefix,var,type,init) PERL_GET_INTERP->var = init;
+# define PERLVARIC(prefix,var,type,init) PERL_GET_INTERP->var = init;
# endif
# include "intrpvar.h"
# undef PERLVAR
@@ -3488,10 +3623,10 @@
# undef PERLVARI
# undef PERLVARIC
#else
-# define PERLVAR(var,type)
-# define PERLVARA(var,n,type)
-# define PERLVARI(var,type,init) PL_##var = init;
-# define PERLVARIC(var,type,init) PL_##var = init;
+# define PERLVAR(prefix,var,type)
+# define PERLVARA(prefix,var,n,type)
+# define PERLVARI(prefix,var,type,init) PL_##var = init;
+# define PERLVARIC(prefix,var,type,init) PL_##var = init;
# include "intrpvar.h"
# undef PERLVAR
# undef PERLVARA
@@ -3511,7 +3646,7 @@
dVAR;
GV *gv;
- PL_curstash = PL_defstash = newHV();
+ PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(newHV());
/* We know that the string "main" will be in the global shared string
table, so it's a small saving to use it rather than allocate another
8 bytes. */
@@ -3544,7 +3679,7 @@
#endif
sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
CLEAR_ERRSV();
- PL_curstash = PL_defstash;
+ SET_CURSTASH(PL_defstash);
CopSTASH_set(&PL_compiling, PL_defstash);
PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI,
@@ -3553,12 +3688,13 @@
sv_setpvs(get_sv("/", GV_ADD), "\n");
}
-STATIC int
-S_open_script(pTHX_ const char *scriptname, bool dosearch,
- bool *suidscript, PerlIO **rsfpp)
+STATIC PerlIO *
+S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
{
int fdscript = -1;
+ PerlIO *rsfp = NULL;
dVAR;
+ Stat_t tmpstatbuf;
PERL_ARGS_ASSERT_OPEN_SCRIPT;
@@ -3607,16 +3743,11 @@
if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
scriptname = (char *)"";
if (fdscript >= 0) {
- *rsfpp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
-# if defined(HAS_FCNTL) && defined(F_SETFD)
- if (*rsfpp)
- /* ensure close-on-exec */
- fcntl(PerlIO_fileno(*rsfpp),F_SETFD,1);
-# endif
+ rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
}
else if (!*scriptname) {
forbid_setid(0, *suidscript);
- *rsfpp = PerlIO_stdin();
+ return NULL;
}
else {
#ifdef FAKE_BIT_BUCKET
@@ -3651,7 +3782,7 @@
#endif
}
#endif
- *rsfpp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
+ rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
#ifdef FAKE_BIT_BUCKET
if (memEQ(scriptname, FAKE_BIT_BUCKET_PREFIX,
sizeof(FAKE_BIT_BUCKET_PREFIX) - 1)
@@ -3660,13 +3791,8 @@
}
scriptname = BIT_BUCKET;
#endif
-# if defined(HAS_FCNTL) && defined(F_SETFD)
- if (*rsfpp)
- /* ensure close-on-exec */
- fcntl(PerlIO_fileno(*rsfpp),F_SETFD,1);
-# endif
}
- if (!*rsfpp) {
+ if (!rsfp) {
/* PSz 16 Sep 03 Keep neat error message */
if (PL_e_script)
Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno));
@@ -3674,7 +3800,18 @@
Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
CopFILE(PL_curcop), Strerror(errno));
}
- return fdscript;
+#if defined(HAS_FCNTL) && defined(F_SETFD)
+ /* ensure close-on-exec */
+ fcntl(PerlIO_fileno(rsfp), F_SETFD, 1);
+#endif
+
+ if (PerlLIO_fstat(PerlIO_fileno(rsfp), &tmpstatbuf) >= 0
+ && S_ISDIR(tmpstatbuf.st_mode))
+ Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
+ CopFILE(PL_curcop),
+ strerror(EISDIR));
+
+ return rsfp;
}
/* Mention
@@ -3691,15 +3828,20 @@
STATIC void
S_validate_suid(pTHX_ PerlIO *rsfp)
{
+ const UV my_uid = PerlProc_getuid();
+ const UV my_euid = PerlProc_geteuid();
+ const UV my_gid = PerlProc_getgid();
+ const UV my_egid = PerlProc_getegid();
+
PERL_ARGS_ASSERT_VALIDATE_SUID;
- if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
+ if (my_euid != my_uid || my_egid != my_gid) { /* (suidperl doesn't exist, in fact) */
dVAR;
PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf); /* may be either wrapped or real suid */
- if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
+ if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
||
- (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
+ (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
)
if (!PL_do_undump)
Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
@@ -3714,7 +3856,7 @@
{
dVAR;
const char *s;
- register const char *s2;
+ const char *s2;
PERL_ARGS_ASSERT_FIND_BEGINNING;
@@ -3742,18 +3884,19 @@
STATIC void
S_init_ids(pTHX)
{
+ /* no need to do anything here any more if we don't
+ * do tainting. */
+#if !NO_TAINT_SUPPORT
dVAR;
- PL_uid = PerlProc_getuid();
- PL_euid = PerlProc_geteuid();
- PL_gid = PerlProc_getgid();
- PL_egid = PerlProc_getegid();
-#ifdef VMS
- PL_uid |= PL_gid << 16;
- PL_euid |= PL_egid << 16;
+ const UV my_uid = PerlProc_getuid();
+ const UV my_euid = PerlProc_geteuid();
+ const UV my_gid = PerlProc_getgid();
+ const UV my_egid = PerlProc_getegid();
+
+ /* Should not happen: */
+ CHECK_MALLOC_TAINT(my_uid && (my_euid != my_uid || my_egid != my_gid));
+ TAINTING_set( TAINTING_get | (my_uid && (my_euid != my_uid || my_egid != my_gid)) );
#endif
- /* Should not happen: */
- CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
- PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
/* BUG */
/* PSz 27 Feb 04
* Should go by suidscript, not uid!=euid: why disallow
@@ -3819,9 +3962,9 @@
}
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
- if (PL_euid != PL_uid)
+ if (PerlProc_getuid() != PerlProc_geteuid())
Perl_croak(aTHX_ "No %s allowed while running setuid", message);
- if (PL_egid != PL_gid)
+ if (PerlProc_getgid() != PerlProc_getegid())
Perl_croak(aTHX_ "No %s allowed while running setgid", message);
#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
if (suidscript)
@@ -3840,6 +3983,8 @@
It might have entries, and if we just turn off AvREAL(), they will
"leak" until global destruction. */
av_clear(args);
+ if (SvTIED_mg((const SV *)args, PERL_MAGIC_tied))
+ Perl_croak(aTHX_ "Cannot set tied @DB::args");
}
AvREIFY_only(PL_dbargs);
}
@@ -3850,7 +3995,7 @@
dVAR;
HV * const ostash = PL_curstash;
- PL_curstash = PL_debstash;
+ PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash);
Perl_init_dbargs(aTHX);
PL_DBgv = gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV);
@@ -3865,6 +4010,7 @@
PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
if (!SvIOK(PL_DBsignal))
sv_setiv(PL_DBsignal, 0);
+ SvREFCNT_dec(PL_curstash);
PL_curstash = ostash;
}
@@ -4028,11 +4174,11 @@
GvMULTI_on(tmpgv);
GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
- PL_statname = newSV(0); /* last filename we did stat on */
+ PL_statname = newSVpvs(""); /* last filename we did stat on */
}
void
-Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
+Perl_init_argv_symbols(pTHX_ int argc, char **argv)
{
dVAR;
@@ -4072,10 +4218,15 @@
(void)sv_utf8_decode(sv);
}
}
+
+ if (PL_inplace && (!PL_argvgv || AvFILL(GvAV(PL_argvgv)) == -1))
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
+ "-i used with no filenames on the command line, "
+ "reading from STDIN");
}
STATIC void
-S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
+S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env)
{
dVAR;
GV* tmpgv;
@@ -4082,9 +4233,9 @@
PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
- PL_toptarget = newSV_type(SVt_PVFM);
+ PL_toptarget = newSV_type(SVt_PVIV);
sv_setpvs(PL_toptarget, "");
- PL_bodytarget = newSV_type(SVt_PVFM);
+ PL_bodytarget = newSV_type(SVt_PVIV);
sv_setpvs(PL_bodytarget, "");
PL_formtarget = PL_bodytarget;
@@ -4143,14 +4294,6 @@
#endif /* !PERL_MICRO */
}
TAINT_NOT;
- if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
- SvREADONLY_off(GvSV(tmpgv));
- sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
- SvREADONLY_on(GvSV(tmpgv));
- }
-#ifdef THREADS_HAVE_PIDS
- PL_ppid = (IV)getppid();
-#endif
/* touch @F array to prevent spurious warnings 20020415 MJD */
if (PL_minus_a) {
@@ -4170,7 +4313,7 @@
STRLEN len;
#endif
- if (!PL_tainting) {
+ if (!TAINTING_get) {
#ifndef VMS
perl5lib = PerlEnv_getenv("PERL5LIB");
/*
@@ -4286,7 +4429,7 @@
|INCPUSH_CAN_RELOCATE);
#endif
- if (!PL_tainting) {
+ if (!TAINTING_get) {
#ifndef VMS
/*
* It isn't possible to delete an environment variable with
@@ -4343,11 +4486,11 @@
#endif
#endif /* !PERL_IS_MINIPERL */
- if (!PL_tainting)
+ if (!TAINTING_get)
S_incpush(aTHX_ STR_WITH_LEN("."), 0);
}
-#if defined(DOSISH) || defined(EPOC) || defined(__SYMBIAN32__)
+#if defined(DOSISH) || defined(__SYMBIAN32__)
# define PERLLIB_SEP ';'
#else
# if defined(VMS)
@@ -4384,59 +4527,25 @@
}
#endif
-STATIC void
-S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags)
+STATIC SV *
+S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags)
{
- dVAR;
-#ifndef PERL_IS_MINIPERL
- const U8 using_sub_dirs
- = (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS
- |INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
- const U8 add_versioned_sub_dirs
- = (U8)flags & INCPUSH_ADD_VERSIONED_SUB_DIRS;
- const U8 add_archonly_sub_dirs
- = (U8)flags & INCPUSH_ADD_ARCHONLY_SUB_DIRS;
-#ifdef PERL_INC_VERSION_LIST
- const U8 addoldvers = (U8)flags & INCPUSH_ADD_OLD_VERS;
-#endif
-#endif
const U8 canrelocate = (U8)flags & INCPUSH_CAN_RELOCATE;
- const U8 unshift = (U8)flags & INCPUSH_UNSHIFT;
- const U8 push_basedir = (flags & INCPUSH_NOT_BASEDIR) ? 0 : 1;
- AV *const inc = GvAVn(PL_incgv);
+ SV *libdir;
- PERL_ARGS_ASSERT_INCPUSH;
+ PERL_ARGS_ASSERT_MAYBERELOCATE;
assert(len > 0);
- /* Could remove this vestigial extra block, if we don't mind a lot of
- re-indenting diff noise. */
- {
- SV *libdir;
- /* Change 20189146be79a0596543441fa369c6bf7f85103f, to fix RT#6665,
- arranged to unshift #! line -I onto the front of @INC. However,
- -I can add version and architecture specific libraries, and they
- need to go first. The old code assumed that it was always
- pushing. Hence to make it work, need to push the architecture
- (etc) libraries onto a temporary array, then "unshift" that onto
- the front of @INC. */
-#ifndef PERL_IS_MINIPERL
- AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL;
-#endif
+ /* I am not convinced that this is valid when PERLLIB_MANGLE is
+ defined to so something (in os2/os2.c), but the code has been
+ this way, ignoring any possible changed of length, since
+ 760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave
+ it be. */
+ libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len);
- if (len) {
- /* I am not convinced that this is valid when PERLLIB_MANGLE is
- defined to so something (in os2/os2.c), but the code has been
- this way, ignoring any possible changed of length, since
- 760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave
- it be. */
- libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len);
- } else {
- libdir = newSVpv(PERLLIB_MANGLE(dir, 0), 0);
- }
-
#ifdef VMS
+ {
char *unix;
- STRLEN len;
if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
len = strlen(unix);
@@ -4446,7 +4555,8 @@
else
PerlIO_printf(Perl_error_log,
"Failed to unixify @INC element \"%s\"\n",
- SvPV(libdir,len));
+ SvPV_nolen_const(libdir));
+ }
#endif
/* Do the if() outside the #ifdef to avoid warnings about an unused
@@ -4538,8 +4648,9 @@
SvREFCNT_dec(libdir);
/* And this is the new libdir. */
libdir = tempsv;
- if (PL_tainting &&
- (PL_uid != PL_euid || PL_gid != PL_egid)) {
+ if (TAINTING_get &&
+ (PerlProc_getuid() != PerlProc_geteuid() ||
+ PerlProc_getgid() != PerlProc_getegid())) {
/* Need to taint relocated paths if running set ID */
SvTAINTED_on(libdir);
}
@@ -4548,19 +4659,57 @@
}
#endif
}
+ return libdir;
+}
+
+STATIC void
+S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags)
+{
+ dVAR;
#ifndef PERL_IS_MINIPERL
+ const U8 using_sub_dirs
+ = (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS
+ |INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
+ const U8 add_versioned_sub_dirs
+ = (U8)flags & INCPUSH_ADD_VERSIONED_SUB_DIRS;
+ const U8 add_archonly_sub_dirs
+ = (U8)flags & INCPUSH_ADD_ARCHONLY_SUB_DIRS;
+#ifdef PERL_INC_VERSION_LIST
+ const U8 addoldvers = (U8)flags & INCPUSH_ADD_OLD_VERS;
+#endif
+#endif
+ const U8 unshift = (U8)flags & INCPUSH_UNSHIFT;
+ const U8 push_basedir = (flags & INCPUSH_NOT_BASEDIR) ? 0 : 1;
+ AV *const inc = GvAVn(PL_incgv);
+
+ PERL_ARGS_ASSERT_INCPUSH;
+ assert(len > 0);
+
+ /* Could remove this vestigial extra block, if we don't mind a lot of
+ re-indenting diff noise. */
+ {
+ SV *const libdir = mayberelocate(dir, len, flags);
+ /* Change 20189146be79a0596543441fa369c6bf7f85103f, to fix RT#6665,
+ arranged to unshift #! line -I onto the front of @INC. However,
+ -I can add version and architecture specific libraries, and they
+ need to go first. The old code assumed that it was always
+ pushing. Hence to make it work, need to push the architecture
+ (etc) libraries onto a temporary array, then "unshift" that onto
+ the front of @INC. */
+#ifndef PERL_IS_MINIPERL
+ AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL;
+
/*
* BEFORE pushing libdir onto @INC we may first push version- and
* archname-specific sub-directories.
*/
if (using_sub_dirs) {
- SV *subdir;
+ SV *subdir = newSVsv(libdir);
#ifdef PERL_INC_VERSION_LIST
/* Configure terminates PERL_INC_VERSION_LIST with a NULL */
const char * const incverlist[] = { PERL_INC_VERSION_LIST };
const char * const *incver;
#endif
- subdir = newSVsv(libdir);
if (add_versioned_sub_dirs) {
/* .../version/archname if -d .../version/archname */
@@ -4744,12 +4893,12 @@
while (PL_scopestack_ix > oldscope)
LEAVE;
FREETMPS;
- PL_curstash = PL_defstash;
+ SET_CURSTASH(PL_defstash);
PL_curcop = &PL_compiling;
CopLINE_set(PL_curcop, oldline);
JMPENV_POP;
my_exit_jump();
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
case 3:
if (PL_restartop) {
PL_curcop = &PL_compiling;
@@ -4756,7 +4905,7 @@
CopLINE_set(PL_curcop, oldline);
JMPENV_JUMP(3);
}
- PerlIO_printf(Perl_error_log, "panic: restartop\n");
+ PerlIO_printf(Perl_error_log, "panic: restartop in call_list\n");
FREETMPS;
break;
}
@@ -4909,8 +5058,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/perl.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.4
\ No newline at end of property
Modified: trunk/contrib/perl/perl.h
===================================================================
--- trunk/contrib/perl/perl.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/perl.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -48,15 +48,6 @@
* repeated in makedef.pl, so be certain to update
* both places when editing. */
-#ifdef PERL_IMPLICIT_SYS
-/* PERL_IMPLICIT_SYS implies PerlMemShared != PerlMem
- so use slab allocator to avoid lots of MUTEX overhead
- */
-# ifndef PL_OP_SLAB_ALLOC
-# define PL_OP_SLAB_ALLOC
-# endif
-#endif
-
#ifdef USE_ITHREADS
# if !defined(MULTIPLICITY)
# define MULTIPLICITY
@@ -100,8 +91,8 @@
/* Any stack-challenged places. The limit varies (and often
* is configurable), but using more than a kilobyte of stack
* is usually dubious in these systems. */
-#if defined(EPOC) || defined(__SYMBIAN32__)
-/* EPOC/Symbian: need to work around the SDK features. *
+#if defined(__SYMBIAN32__)
+/* Symbian: need to work around the SDK features. *
* On WINS: MS VC5 generates calls to _chkstk, *
* if a "large" stack frame is allocated. *
* gcc on MARM does not generate calls like these. */
@@ -166,7 +157,7 @@
# endif
#endif
-#define pVAR register struct perl_vars* my_vars PERL_UNUSED_DECL
+#define pVAR struct perl_vars* my_vars PERL_UNUSED_DECL
#ifdef PERL_GLOBAL_STRUCT
# define dVAR pVAR = (struct perl_vars*)PERL_GET_VARS()
@@ -179,8 +170,9 @@
# define MULTIPLICITY
# endif
# define tTHX PerlInterpreter*
-# define pTHX register tTHX my_perl PERL_UNUSED_DECL
+# define pTHX tTHX my_perl PERL_UNUSED_DECL
# define aTHX my_perl
+# define aTHXa(a) aTHX = (tTHX)a
# ifdef PERL_GLOBAL_STRUCT
# define dTHXa(a) dVAR; pTHX = (tTHX)a
# else
@@ -354,10 +346,15 @@
#endif
#define NOOP /*EMPTY*/(void)0
-#if !defined(HASATTRIBUTE_UNUSED) && defined(__cplusplus)
-#define dNOOP /*EMPTY*/(void)0 /* Older g++ has no __attribute((unused))__ */
+/* cea2e8a9dd23747f accidentally lost the comment originally from the first
+ check in of thread.h, explaining why we need dNOOP at all: */
+/* Rats: if dTHR is just blank then the subsequent ";" throws an error */
+/* Declaring a *function*, instead of a variable, ensures that we don't rely
+ on being able to suppress "unused" warnings. */
+#ifdef __cplusplus
+#define dNOOP (void)0
#else
-#define dNOOP extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL
+#define dNOOP extern int Perl___notused(void)
#endif
#ifndef pTHX
@@ -368,6 +365,7 @@
# define pTHX_
# define aTHX
# define aTHX_
+# define aTHXa(a) NOOP
# define dTHXa(a) dNOOP
# define dTHX dNOOP
# define pTHX_1 1
@@ -396,7 +394,7 @@
#endif
#ifndef pTHXx
-# define pTHXx register PerlInterpreter *my_perl
+# define pTHXx PerlInterpreter *my_perl
# define pTHXx_ pTHXx,
# define aTHXx my_perl
# define aTHXx_ aTHXx,
@@ -444,7 +442,7 @@
# ifdef __GNUC__
# define stringify_immed(s) #s
# define stringify(s) stringify_immed(s)
-register struct op *Perl_op asm(stringify(OP_IN_REGISTER));
+struct op *Perl_op asm(stringify(OP_IN_REGISTER));
# endif
#endif
@@ -490,9 +488,6 @@
# endif
#endif
-#define WITH_THX(s) STMT_START { dTHX; s; } STMT_END
-#define WITH_THR(s) WITH_THX(s)
-
#ifndef BYTEORDER /* Should never happen -- byteorder is in config.h */
# define BYTEORDER 0x1234
#endif
@@ -517,15 +512,15 @@
*/
/* define this once if either system, instead of cluttering up the src */
-#if defined(MSDOS) || defined(atarist) || defined(WIN32) || defined(NETWARE)
+#if defined(MSDOS) || defined(WIN32) || defined(NETWARE)
#define DOSISH 1
#endif
-#if defined(__STDC__) || defined(_AIX) || defined(__stdc__) || defined(__cplusplus) || defined(EPOC) || defined(NETWARE) || defined(__SYMBIAN32__)
+#if defined(__STDC__) || defined(_AIX) || defined(__stdc__) || defined(__cplusplus) || defined(NETWARE) || defined(__SYMBIAN32__)
# define STANDARD_C 1
#endif
-#if defined(__cplusplus) || defined(WIN32) || defined(__sgi) || defined(__EMX__) || defined(__DGUX) || defined(EPOC) || defined(__QNX__) || defined(NETWARE) || defined(PERL_MICRO)
+#if defined(__cplusplus) || defined(WIN32) || defined(__sgi) || defined(__EMX__) || defined(__DGUX) || defined(__QNX__) || defined(NETWARE) || defined(PERL_MICRO)
# define DONT_DECLARE_STD 1
#endif
@@ -535,12 +530,55 @@
# define VOL
#endif
-#define TAINT (PL_tainted = TRUE)
-#define TAINT_NOT (PL_tainted = FALSE)
-#define TAINT_IF(c) if (c) { PL_tainted = TRUE; }
-#define TAINT_ENV() if (PL_tainting) { taint_env(); }
-#define TAINT_PROPER(s) if (PL_tainting) { taint_proper(NULL, s); }
+/* By compiling a perl with -DNO_TAINT_SUPPORT or -DSILENT_NO_TAINT_SUPPORT,
+ * you get a perl without taint support, but doubtlessly with a lesser
+ * degree of support. Do not do so unless you know exactly what it means
+ * technically, have a good reason to do so, and know exactly how the
+ * perl will be used. perls with -DSILENT_NO_TAINT_SUPPORT are considered
+ * a potential security risk due to flat out ignoring the security-relevant
+ * taint flags. This being said, a perl without taint support compiled in
+ * has marginal run-time performance benefits.
+ * SILENT_NO_TAINT_SUPPORT implies NO_TAINT_SUPPORT.
+ * SILENT_NO_TAINT_SUPPORT is the same as NO_TAINT_SUPPORT except it
+ * silently ignores -t/-T instead of throwing an exception.
+ *
+ * DANGER! Using NO_TAINT_SUPPORT or SILENT_NO_TAINT_SUPPORT
+ * voids your nonexistent warranty!
+ */
+#if SILENT_NO_TAINT_SUPPORT && !defined(NO_TAINT_SUPPORT)
+# define NO_TAINT_SUPPORT 1
+#endif
+/* NO_TAINT_SUPPORT can be set to transform virtually all taint-related
+ * operations into no-ops for a very modest speed-up. Enable only if you
+ * know what you're doing: tests and CPAN modules' tests are bound to fail.
+ */
+#if NO_TAINT_SUPPORT
+# define TAINT NOOP
+# define TAINT_NOT NOOP
+# define TAINT_IF(c) NOOP
+# define TAINT_ENV() NOOP
+# define TAINT_PROPER(s) NOOP
+# define TAINT_set(s) NOOP
+# define TAINT_get 0
+# define TAINTING_get 0
+# define TAINTING_set(s) NOOP
+# define TAINT_WARN_get 0
+# define TAINT_WARN_set(s) NOOP
+#else
+# define TAINT (PL_tainted = TRUE)
+# define TAINT_NOT (PL_tainted = FALSE)
+# define TAINT_IF(c) if (UNLIKELY(c)) { PL_tainted = TRUE; }
+# define TAINT_ENV() if (UNLIKELY(PL_tainting)) { taint_env(); }
+# define TAINT_PROPER(s) if (UNLIKELY(PL_tainting)) { taint_proper(NULL, s); }
+# define TAINT_set(s) (PL_tainted = (s))
+# define TAINT_get (PL_tainted)
+# define TAINTING_get (PL_tainting)
+# define TAINTING_set(s) (PL_tainting = (s))
+# define TAINT_WARN_get (PL_taint_warn)
+# define TAINT_WARN_set(s) (PL_taint_warn = (s))
+#endif
+
/* flags used internally only within pp_subst and pp_substcont */
#ifdef PERL_CORE
# define SUBST_TAINT_STR 1 /* string tainted */
@@ -736,6 +774,8 @@
# define U64_CONST(x) ((U64)x##UL)
# elif QUADKIND == QUAD_IS_LONG_LONG
# define U64_CONST(x) ((U64)x##ULL)
+# elif QUADKIND == QUAD_IS___INT64
+# define U64_CONST(x) ((U64)x##UI64)
# else /* best guess we can make */
# define U64_CONST(x) ((U64)x##UL)
# endif
@@ -972,21 +1012,10 @@
#define PERL_USES_PL_PIDSTATUS
#endif
-#if !defined(OS2) && !defined(WIN32) && !defined(DJGPP) && !defined(EPOC) && !defined(__SYMBIAN32__)
+#if !defined(OS2) && !defined(WIN32) && !defined(DJGPP) && !defined(__SYMBIAN32__)
#define PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION
#endif
-/* Cannot include embed.h here on Win32 as win32.h has not
- yet been included and defines some config variables e.g. HAVE_INTERP_INTERN
- */
-#if !defined(PERL_FOR_X2P) && !(defined(WIN32)||defined(VMS))
-# include "embed.h"
-# ifndef PERL_MAD
-# undef op_getmad
-# define op_getmad(arg,pegop,slot) NOOP
-# endif
-#endif
-
#define MEM_SIZE Size_t
/* Round all values passed to malloc up, by default to a multiple of
@@ -1188,7 +1217,7 @@
# define S_IFIFO _S_IFIFO
#endif
-/* The stat macros for Amdahl UTS, Unisoft System V/88 (and derivatives
+/* The stat macros for Unisoft System V/88 (and derivatives
like UTekV) are broken, sometimes giving false positives. Undefine
them here and let the code below set them to proper values.
@@ -1197,7 +1226,7 @@
This header file bug is corrected in gcc-2.5.8 and later versions.
--Kaveh Ghazi (ghazi at noc.rutgers.edu) 10/3/94. */
-#if defined(uts) || (defined(m88k) && defined(ghs))
+#if defined(m88k) && defined(ghs)
# undef S_ISDIR
# undef S_ISCHR
# undef S_ISBLK
@@ -1242,7 +1271,7 @@
# define _SOCKADDR_LEN
#endif
-#if defined(HAS_SOCKET) && !defined(VMS) && !defined(WIN32) /* VMS/WIN32 handle sockets via vmsish.h/win32.h */
+#if defined(HAS_SOCKET) && !defined(WIN32) /* WIN32 handles sockets via win32.h */
# include <sys/socket.h>
# if defined(USE_SOCKS) && defined(I_SOCKS)
# if !defined(INCLUDE_PROTOTYPES)
@@ -1368,11 +1397,20 @@
#ifdef PERL_CORE
# define DEFSV (0 + GvSVn(PL_defgv))
+# define DEFSV_set(sv) \
+ (SvREFCNT_dec(GvSV(PL_defgv)), GvSV(PL_defgv) = SvREFCNT_inc(sv))
+# define SAVE_DEFSV \
+ ( \
+ save_gp(PL_defgv, 0), \
+ GvINTRO_off(PL_defgv), \
+ SAVEGENERICSV(GvSV(PL_defgv)), \
+ GvSV(PL_defgv) = NULL \
+ )
#else
# define DEFSV GvSVn(PL_defgv)
+# define DEFSV_set(sv) (GvSV(PL_defgv) = (sv))
+# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
#endif
-#define DEFSV_set(sv) (GvSV(PL_defgv) = (sv))
-#define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
#define ERRHV GvHV(PL_errgv) /* XXX unused, here for compatibility */
@@ -1385,13 +1423,13 @@
#endif
#ifdef HAS_STRERROR
+#ifndef DONT_DECLARE_STD
# ifdef VMS
char *strerror (int,...);
# else
-#ifndef DONT_DECLARE_STD
char *strerror (int);
+# endif
#endif
-# endif
# ifndef Strerror
# define Strerror strerror
# endif
@@ -1603,15 +1641,15 @@
# define S_IRWXO (S_IROTH|S_IWOTH|S_IXOTH)
#endif
-/* BeOS 5.0 and Haiku R1 seem to define S_IREAD and S_IWRITE in <posix/fcntl.h>
+/* Haiku R1 seems to define S_IREAD and S_IWRITE in <posix/fcntl.h>
* which would get included through <sys/file.h >, but that is 3000
* lines in the future. --jhi */
-#if !defined(S_IREAD) && !(defined(__BEOS__) || defined(__HAIKU__))
+#if !defined(S_IREAD) && !defined(__HAIKU__)
# define S_IREAD S_IRUSR
#endif
-#if !defined(S_IWRITE) && !(defined(__BEOS__) || defined(__HAIKU__))
+#if !defined(S_IWRITE) && !defined(__HAIKU__)
# define S_IWRITE S_IWUSR
#endif
@@ -1631,10 +1669,6 @@
#undef UV
#endif
-#ifdef SPRINTF_E_BUG
-# define sprintf UTS_sprintf_wrap
-#endif
-
/* For the times when you want the return value of sprintf, and you want it
to be the length. Can't have a thread variable passed in, because C89 has
no varargs macros.
@@ -1675,7 +1709,7 @@
#if defined(HAS_VSNPRINTF) && defined(HAS_C99_VARIADIC_MACROS) && !(defined(DEBUGGING) && !defined(PERL_USE_GCC_BRACE_GROUPS)) && !defined(PERL_GCC_PEDANTIC)
# ifdef PERL_USE_GCC_BRACE_GROUPS
-# define my_vsnprintf(buffer, len, ...) ({ int __len__ = vsnprintf(buffer, len, __VA_ARGS__); if ((len) > 0 && (Size_t)__len__ >= (len)) Perl_croak_nocontext("panic: vsnprintf buffer overflow"); __len__; })
+# define my_vsnprintf(buffer, len, ...) ({ int __len__ = vsnprintf(buffer, len, __VA_ARGS__); if ((len) > 0 && (Size_t)__len__ >= (Size_t)(len)) Perl_croak_nocontext("panic: vsnprintf buffer overflow"); __len__; })
# define PERL_MY_VSNPRINTF_GUARDED
# else
# define my_vsnprintf(buffer, len, ...) vsnprintf(buffer, len, __VA_ARGS__)
@@ -1697,13 +1731,6 @@
# define my_strlcpy Perl_my_strlcpy
#endif
-/* Configure gets this right but the UTS compiler gets it wrong.
- -- Hal Morris <hom00 at utsglobal.com> */
-#ifdef UTS
-# undef UVTYPE
-# define UVTYPE unsigned
-#endif
-
/*
The IV type is supposed to be long enough to hold any integral
value or a pointer.
@@ -1769,11 +1796,6 @@
# undef PERL_NEED_MY_BETOH64
#endif
-#if defined(uts) || defined(UTS)
-# undef UV_MAX
-# define UV_MAX (4294967295u)
-#endif
-
#define IV_DIG (BIT_DIGITS(IVSIZE * 8))
#define UV_DIG (BIT_DIGITS(UVSIZE * 8))
@@ -2418,14 +2440,18 @@
typedef struct pvop PVOP;
typedef struct loop LOOP;
+#ifdef PERL_CORE
+typedef struct opslab OPSLAB;
+typedef struct opslot OPSLOT;
+#endif
+
typedef struct block_hooks BHK;
typedef struct custom_op XOP;
typedef struct interpreter PerlInterpreter;
-/* Amdahl's <ksync.h> has struct sv */
/* SGI's <sys/sema.h> has struct sv */
-#if defined(UTS) || defined(__sgi)
+#if defined(__sgi)
# define STRUCT_SV perl_sv
#else
# define STRUCT_SV sv
@@ -2461,6 +2487,29 @@
typedef struct ptr_tbl PTR_TBL_t;
typedef struct clone_params CLONE_PARAMS;
+/* a pad or name pad is currently just an AV; but that might change,
+ * so hide the type. */
+typedef struct padlist PADLIST;
+typedef AV PAD;
+typedef AV PADNAMELIST;
+typedef SV PADNAME;
+
+/* XXX for 5.18, disable the COW by default
+ * #if !defined(PERL_OLD_COPY_ON_WRITE) && !defined(PERL_NEW_COPY_ON_WRITE) && !defined(PERL_NO_COW)
+ * # define PERL_NEW_COPY_ON_WRITE
+ * #endif
+ */
+
+#if defined(PERL_OLD_COPY_ON_WRITE) || defined(PERL_NEW_COPY_ON_WRITE)
+# if defined(PERL_OLD_COPY_ON_WRITE) && defined(PERL_NEW_COPY_ON_WRITE)
+# error PERL_OLD_COPY_ON_WRITE and PERL_NEW_COPY_ON_WRITE are exclusive
+# else
+# define PERL_ANY_COW
+# endif
+#else
+# define PERL_SAWAMPERSAND
+#endif
+
#include "handy.h"
#if defined(USE_LARGE_FILES) && !defined(NO_64_BIT_RAWIO)
@@ -2567,11 +2616,6 @@
# include "iperlsys.h"
#endif
-#if defined(__OPEN_VM)
-# include "vmesa/vmesaish.h"
-# define ISHISH "vmesa"
-#endif
-
#ifdef DOSISH
# if defined(OS2)
# include "os2ish.h"
@@ -2583,11 +2627,6 @@
#if defined(VMS)
# include "vmsish.h"
-# include "embed.h"
-# ifndef PERL_MAD
-# undef op_getmad
-# define op_getmad(arg,pegop,slot) NOOP
-# endif
# define ISHISH "vms"
#endif
@@ -2596,11 +2635,6 @@
# define ISHISH "plan9"
#endif
-#if defined(MPE)
-# include "mpeix/mpeixish.h"
-# define ISHISH "mpeix"
-#endif
-
#if defined(__VOS__)
# ifdef __GNUC__
# include "./vos/vosish.h"
@@ -2610,18 +2644,8 @@
# define ISHISH "vos"
#endif
-#if defined(EPOC)
-# include "epocish.h"
-# define ISHISH "epoc"
-#endif
-
#ifdef __SYMBIAN32__
# include "symbian/symbianish.h"
-# include "embed.h"
-# ifndef PERL_MAD
-# undef op_getmad
-# define op_getmad(arg,pegop,slot) NOOP
-# endif
# define ISHISH "symbian"
#endif
@@ -2629,9 +2653,6 @@
#if defined(__HAIKU__)
# include "haiku/haikuish.h"
# define ISHISH "haiku"
-#elif defined(__BEOS__)
-# include "beos/beosish.h"
-# define ISHISH "beos"
#endif
#ifndef ISHISH
@@ -2735,12 +2756,12 @@
#endif
/*
-=for apidoc Am|void|PERL_SYS_INIT|int argc|char** argv
+=for apidoc Am|void|PERL_SYS_INIT|int *argc|char*** argv
Provides system-specific tune up of the C runtime environment necessary to
run Perl interpreters. This should be called only once, before creating
any Perl interpreters.
-=for apidoc Am|void|PERL_SYS_INIT3|int argc|char** argv|char** env
+=for apidoc Am|void|PERL_SYS_INIT3|int *argc|char*** argv|char*** env
Provides system-specific tune up of the C runtime environment necessary to
run Perl interpreters. This should be called only once, before creating
any Perl interpreters.
@@ -2778,11 +2799,7 @@
# define MAXPATHLEN (PATH_MAX+1)
# endif
# else
-# ifdef _POSIX_PATH_MAX
-# define MAXPATHLEN _POSIX_PATH_MAX
-# else
-# define MAXPATHLEN 1024 /* Err on the large side. */
-# endif
+# define MAXPATHLEN 1024 /* Err on the large side. */
# endif
#endif
@@ -3210,6 +3227,18 @@
#define SVfARG(p) ((void*)(p))
+#ifndef HEKf
+# define HEKf "2p"
+#endif
+
+/* Not ideal, but we cannot easily include a number in an already-numeric
+ * format sequence. */
+#ifndef HEKf256
+# define HEKf256 "3p"
+#endif
+
+#define HEKfARG(p) ((void*)(p))
+
#ifdef PERL_CORE
/* not used; but needed for backward compatibility with XS code? - RMB */
# undef VDf
@@ -3283,9 +3312,9 @@
appropriate to call return. In either case, include the lint directive.
*/
#ifdef HASATTRIBUTE_NORETURN
-# define NORETURN_FUNCTION_END /* NOTREACHED */
+# define NORETURN_FUNCTION_END assert(0); /* NOTREACHED */
#else
-# define NORETURN_FUNCTION_END /* NOTREACHED */ return 0
+# define NORETURN_FUNCTION_END assert(0); /* NOTREACHED */ return 0
#endif
/* Some OS warn on NULL format to printf */
@@ -3470,8 +3499,7 @@
U8 super_state; /* lexer state to save */
U16 sub_inwhat; /* "lex_inwhat" to use */
OP *sub_op; /* "lex_op" to use */
- char *super_bufptr; /* PL_parser->bufptr that was */
- char *super_bufend; /* PL_parser->bufend that was */
+ SV *repl; /* replacement of s/// or y/// */
};
#include "parser.h"
@@ -3496,10 +3524,6 @@
struct ptr_tbl_ent *tbl_arena_end;
};
-#if defined(iAPX286) || defined(M_I286) || defined(I80286)
-# define I286
-#endif
-
#if defined(htonl) && !defined(HAS_HTONL)
#define HAS_HTONL
#endif
@@ -3625,7 +3649,7 @@
#endif
#ifndef __cplusplus
-#if !(defined(UNDER_CE) || defined(SYMBIAN))
+#if !(defined(WIN32) || defined(UNDER_CE) || defined(SYMBIAN))
Uid_t getuid (void);
Uid_t geteuid (void);
Gid_t getgid (void);
@@ -3664,7 +3688,7 @@
#define DEBUG_H_FLAG 0x00002000 /* 8192 */
#define DEBUG_X_FLAG 0x00004000 /* 16384 */
#define DEBUG_D_FLAG 0x00008000 /* 32768 */
-/* 0x00010000 is unused, used to be S */
+#define DEBUG_S_FLAG 0x00010000 /* 65536 */
#define DEBUG_T_FLAG 0x00020000 /* 131072 */
#define DEBUG_R_FLAG 0x00040000 /* 262144 */
#define DEBUG_J_FLAG 0x00080000 /* 524288 */
@@ -3674,7 +3698,7 @@
#define DEBUG_q_FLAG 0x00800000 /*8388608 */
#define DEBUG_M_FLAG 0x01000000 /*16777216*/
#define DEBUG_B_FLAG 0x02000000 /*33554432*/
-#define DEBUG_MASK 0x03FEEFFF /* mask of all the standard flags */
+#define DEBUG_MASK 0x03FFEFFF /* mask of all the standard flags */
#define DEBUG_DB_RECURSE_FLAG 0x40000000
#define DEBUG_TOP_FLAG 0x80000000 /* XXX what's this for ??? Signal
@@ -3696,6 +3720,7 @@
# define DEBUG_H_TEST_ (PL_debug & DEBUG_H_FLAG)
# define DEBUG_X_TEST_ (PL_debug & DEBUG_X_FLAG)
# define DEBUG_D_TEST_ (PL_debug & DEBUG_D_FLAG)
+# define DEBUG_S_TEST_ (PL_debug & DEBUG_S_FLAG)
# define DEBUG_T_TEST_ (PL_debug & DEBUG_T_FLAG)
# define DEBUG_R_TEST_ (PL_debug & DEBUG_R_FLAG)
# define DEBUG_J_TEST_ (PL_debug & DEBUG_J_FLAG)
@@ -3727,6 +3752,7 @@
# define DEBUG_H_TEST DEBUG_H_TEST_
# define DEBUG_X_TEST DEBUG_X_TEST_
# define DEBUG_D_TEST DEBUG_D_TEST_
+# define DEBUG_S_TEST DEBUG_S_TEST_
# define DEBUG_T_TEST DEBUG_T_TEST_
# define DEBUG_R_TEST DEBUG_R_TEST_
# define DEBUG_J_TEST DEBUG_J_TEST_
@@ -3778,6 +3804,7 @@
# define DEBUG_Uv(a) DEBUG__(DEBUG_Uv_TEST, a)
# define DEBUG_Pv(a) DEBUG__(DEBUG_Pv_TEST, a)
+# define DEBUG_S(a) DEBUG__(DEBUG_S_TEST, a)
# define DEBUG_T(a) DEBUG__(DEBUG_T_TEST, a)
# define DEBUG_R(a) DEBUG__(DEBUG_R_TEST, a)
# define DEBUG_v(a) DEBUG__(DEBUG_v_TEST, a)
@@ -3805,6 +3832,7 @@
# define DEBUG_H_TEST (0)
# define DEBUG_X_TEST (0)
# define DEBUG_D_TEST (0)
+# define DEBUG_S_TEST (0)
# define DEBUG_T_TEST (0)
# define DEBUG_R_TEST (0)
# define DEBUG_J_TEST (0)
@@ -3836,6 +3864,7 @@
# define DEBUG_H(a)
# define DEBUG_X(a)
# define DEBUG_D(a)
+# define DEBUG_S(a)
# define DEBUG_T(a)
# define DEBUG_R(a)
# define DEBUG_v(a)
@@ -3856,63 +3885,6 @@
where, (long)PL_scopestack_ix, (long)PL_savestack_ix, \
__FILE__, __LINE__));
-
-
-
-/* These constants should be used in preference to raw characters
- * when using magic. Note that some perl guts still assume
- * certain character properties of these constants, namely that
- * isUPPER() and toLOWER() may do useful mappings.
- *
- * Update the magic_names table in dump.c when adding/amending these
- */
-
-#define PERL_MAGIC_sv '\0' /* Special scalar variable */
-#define PERL_MAGIC_overload 'A' /* %OVERLOAD hash */
-#define PERL_MAGIC_overload_elem 'a' /* %OVERLOAD hash element */
-#define PERL_MAGIC_overload_table 'c' /* Holds overload table (AMT) on stash */
-#define PERL_MAGIC_bm 'B' /* Boyer-Moore (fast string search) */
-#define PERL_MAGIC_regdata 'D' /* Regex match position data
- (@+ and @- vars) */
-#define PERL_MAGIC_regdatum 'd' /* Regex match position data element */
-#define PERL_MAGIC_env 'E' /* %ENV hash */
-#define PERL_MAGIC_envelem 'e' /* %ENV hash element */
-#define PERL_MAGIC_fm 'f' /* Formline ('compiled' format) */
-#define PERL_MAGIC_regex_global 'g' /* m//g target / study()ed string */
-#define PERL_MAGIC_hints 'H' /* %^H hash */
-#define PERL_MAGIC_hintselem 'h' /* %^H hash element */
-#define PERL_MAGIC_isa 'I' /* @ISA array */
-#define PERL_MAGIC_isaelem 'i' /* @ISA array element */
-#define PERL_MAGIC_nkeys 'k' /* scalar(keys()) lvalue */
-#define PERL_MAGIC_dbfile 'L' /* Debugger %_<filename */
-#define PERL_MAGIC_dbline 'l' /* Debugger %_<filename element */
-#define PERL_MAGIC_shared 'N' /* Shared between threads */
-#define PERL_MAGIC_shared_scalar 'n' /* Shared between threads */
-#define PERL_MAGIC_collxfrm 'o' /* Locale transformation */
-#define PERL_MAGIC_tied 'P' /* Tied array or hash */
-#define PERL_MAGIC_tiedelem 'p' /* Tied array or hash element */
-#define PERL_MAGIC_tiedscalar 'q' /* Tied scalar or handle */
-#define PERL_MAGIC_qr 'r' /* precompiled qr// regex */
-#define PERL_MAGIC_sig 'S' /* %SIG hash */
-#define PERL_MAGIC_sigelem 's' /* %SIG hash element */
-#define PERL_MAGIC_taint 't' /* Taintedness */
-#define PERL_MAGIC_uvar 'U' /* Available for use by extensions */
-#define PERL_MAGIC_uvar_elem 'u' /* Reserved for use by extensions */
-#define PERL_MAGIC_vec 'v' /* vec() lvalue */
-#define PERL_MAGIC_vstring 'V' /* SV was vstring literal */
-#define PERL_MAGIC_utf8 'w' /* Cached UTF-8 information */
-#define PERL_MAGIC_substr 'x' /* substr() lvalue */
-#define PERL_MAGIC_defelem 'y' /* Shadow "foreach" iterator variable /
- smart parameter vivification */
-#define PERL_MAGIC_arylen '#' /* Array length ($#ary) */
-#define PERL_MAGIC_pos '.' /* pos() lvalue */
-#define PERL_MAGIC_backref '<' /* for weak ref data */
-#define PERL_MAGIC_symtab ':' /* extra data for symbol tables */
-#define PERL_MAGIC_rhash '%' /* extra data for restricted hashes */
-#define PERL_MAGIC_arylen_p '@' /* to move arylen out of XPVAV */
-#define PERL_MAGIC_ext '~' /* Available for use by extensions */
-#define PERL_MAGIC_checkcall ']' /* inlining/mutation of call to this CV */
-
#if defined(DEBUGGING) && defined(I_ASSERT)
# include <assert.h>
#endif
@@ -3929,6 +3901,11 @@
#ifndef assert
# define assert(what) Perl_assert(what)
#endif
+#ifdef DEBUGGING
+# define assert_(what) assert(what),
+#else
+# define assert_(what)
+#endif
struct ufuncs {
I32 (*uf_val)(pTHX_ IV, SV*);
@@ -3970,7 +3947,7 @@
/* All of these are in stdlib.h or time.h for ANSI C */
Time_t time();
struct tm *gmtime(), *localtime();
-#if defined(OEMVS) || defined(__OPEN_VM)
+#if defined(OEMVS)
char *(strchr)(), *(strrchr)();
char *(strcpy)(), *(strcat)();
#else
@@ -4061,7 +4038,7 @@
# ifndef getenv
char *getenv (const char*);
# endif /* !getenv */
-# if !defined(HAS_LSEEK_PROTO) && !defined(EPOC) && !defined(__hpux)
+# if !defined(HAS_LSEEK_PROTO) && !defined(__hpux)
# ifdef _FILE_OFFSET_BITS
# if _FILE_OFFSET_BITS == 64
Off_t lseek (int,Off_t,int);
@@ -4069,9 +4046,11 @@
# endif
# endif
# endif /* !DONT_DECLARE_STD */
-#ifndef getlogin
+# ifndef WIN32
+# ifndef getlogin
char *getlogin (void);
-#endif
+# endif
+# endif /* !WIN32 */
#endif /* !__cplusplus */
/* Fixme on VMS. This needs to be a run-time, not build time options */
@@ -4257,11 +4236,25 @@
# endif
#endif
+#define PERL_PATCHLEVEL_H_IMPLICIT
+#include "patchlevel.h"
+#undef PERL_PATCHLEVEL_H_IMPLICIT
+
+#define PERL_VERSION_STRING STRINGIFY(PERL_REVISION) "." \
+ STRINGIFY(PERL_VERSION) "." \
+ STRINGIFY(PERL_SUBVERSION)
+
+#define PERL_API_VERSION_STRING STRINGIFY(PERL_API_REVISION) "." \
+ STRINGIFY(PERL_API_VERSION) "." \
+ STRINGIFY(PERL_API_SUBVERSION)
+
START_EXTERN_C
/* handy constants */
EXTCONST char PL_warn_uninit[]
INIT("Use of uninitialized value%s%s%s");
+EXTCONST char PL_warn_uninit_sv[]
+ INIT("Use of uninitialized value%"SVf"%s%s");
EXTCONST char PL_warn_nosemi[]
INIT("Semicolon seems to be missing");
EXTCONST char PL_warn_reserved[]
@@ -4284,7 +4277,7 @@
INIT("Modification of non-creatable hash value attempted, subscript \"%"SVf"\"");
EXTCONST char PL_no_modify[]
INIT("Modification of a read-only value attempted");
-EXTCONST char PL_no_mem[]
+EXTCONST char PL_no_mem[sizeof("Out of memory!\n")]
INIT("Out of memory!\n");
EXTCONST char PL_no_security[]
INIT("Insecure dependency in %s%s");
@@ -4301,6 +4294,19 @@
EXTCONST char PL_memory_wrap[]
INIT("panic: memory wrap");
+EXTCONST char PL_Yes[]
+ INIT("1");
+EXTCONST char PL_No[]
+ INIT("");
+EXTCONST char PL_hexdigit[]
+ INIT("0123456789abcdef0123456789ABCDEF");
+
+/* This is constant on most architectures, a global on OS/2 */
+#ifndef OS2
+EXTCONST char PL_sh_path[]
+ INIT(SH_PATH); /* full path of shell */
+#endif
+
#ifdef CSH
EXTCONST char PL_cshname[]
INIT(CSH);
@@ -4307,15 +4313,34 @@
# define PL_cshlen (sizeof(CSH "") - 1)
#endif
+/* These are baked at compile time into any shared perl library.
+ In future releases this will allow us in main() to sanity test the
+ library we're linking against. */
+
+EXTCONST U8 PL_revision
+ INIT(PERL_REVISION);
+EXTCONST U8 PL_version
+ INIT(PERL_VERSION);
+EXTCONST U8 PL_subversion
+ INIT(PERL_SUBVERSION);
+
EXTCONST char PL_uuemap[65]
INIT("`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_");
#ifdef DOINIT
EXTCONST char PL_uudmap[256] =
-#include "uudmap.h"
+# ifdef PERL_MICRO
+# include "uuudmap.h"
+# else
+# include "uudmap.h"
+# endif
;
EXTCONST char PL_bitcount[256] =
-# include "bitcount.h"
+# ifdef PERL_MICRO
+# include "ubitcount.h"
+#else
+# include "bitcount.h"
+# endif
;
EXTCONST char* const PL_sig_name[] = { SIG_NAME };
EXTCONST int PL_sig_num[] = { SIG_NUM };
@@ -4489,8 +4514,10 @@
248-32, 249-32, 250-32, 251-32, 252-32, 253-32, 254-32, 255
};
#else /* ! DOINIT */
+#ifndef EBCDIC
EXTCONST unsigned char PL_fold[];
EXTCONST unsigned char PL_fold_latin1[];
+#endif
EXTCONST unsigned char PL_mod_latin1_uc[];
EXTCONST unsigned char PL_latin1_lc[];
#endif
@@ -4612,7 +4639,9 @@
EXTCONST unsigned char PL_freq[];
#endif
-#ifdef DEBUGGING
+/* Although only used for debugging, these constants must be available in
+ * non-debugging builds too, since they're used in ext/re/re_exec.c,
+ * which has DEBUGGING enabled always */
#ifdef DOINIT
EXTCONST char* const PL_block_type[] = {
"NULL",
@@ -4631,7 +4660,6 @@
#else
EXTCONST char* PL_block_type[];
#endif
-#endif
/* These are all the compile time options that affect binary compatibility.
Other compile time options that are binary compatible are in perl.c
@@ -4649,6 +4677,15 @@
# ifdef FAKE_THREADS
" FAKE_THREADS"
# endif
+# ifdef FCRYPT
+ " FCRYPT"
+# endif
+# ifdef HAS_TIMES
+ " HAS_TIMES"
+# endif
+# ifdef HAVE_INTERP_INTERN
+ " HAVE_INTERP_INTERN"
+# endif
# ifdef MULTIPLICITY
" MULTIPLICITY"
# endif
@@ -4655,6 +4692,9 @@
# ifdef MYMALLOC
" MYMALLOC"
# endif
+# ifdef PERLIO_LAYERS
+ " PERLIO_LAYERS"
+# endif
# ifdef PERL_DEBUG_READONLY_OPS
" PERL_DEBUG_READONLY_OPS"
# endif
@@ -4670,6 +4710,9 @@
# ifdef PERL_MAD
" PERL_MAD"
# endif
+# ifdef PERL_MICRO
+ " PERL_MICRO"
+# endif
# ifdef PERL_NEED_APPCTX
" PERL_NEED_APPCTX"
# endif
@@ -4679,9 +4722,15 @@
# ifdef PERL_OLD_COPY_ON_WRITE
" PERL_OLD_COPY_ON_WRITE"
# endif
+# ifdef PERL_NEW_COPY_ON_WRITE
+ " PERL_NEW_COPY_ON_WRITE"
+# endif
# ifdef PERL_POISON
" PERL_POISON"
# endif
+# ifdef PERL_SAWAMPERSAND
+ " PERL_SAWAMPERSAND"
+# endif
# ifdef PERL_TRACK_MEMPOOL
" PERL_TRACK_MEMPOOL"
# endif
@@ -4688,12 +4737,6 @@
# ifdef PERL_USES_PL_PIDSTATUS
" PERL_USES_PL_PIDSTATUS"
# endif
-# ifdef PL_OP_SLAB_ALLOC
- " PL_OP_SLAB_ALLOC"
-# endif
-# ifdef THREADS_HAVE_PIDS
- " THREADS_HAVE_PIDS"
-# endif
# ifdef USE_64_BIT_ALL
" USE_64_BIT_ALL"
# endif
@@ -4709,6 +4752,12 @@
# ifdef USE_LARGE_FILES
" USE_LARGE_FILES"
# endif
+# ifdef USE_LOCALE_COLLATE
+ " USE_LOCALE_COLLATE"
+# endif
+# ifdef USE_LOCALE_NUMERIC
+ " USE_LOCALE_NUMERIC"
+# endif
# ifdef USE_LONG_DOUBLE
" USE_LONG_DOUBLE"
# endif
@@ -4727,17 +4776,23 @@
# ifdef VMS_DO_SOCKETS
" VMS_DO_SOCKETS"
# endif
+# ifdef VMS_SHORTEN_LONG_SYMBOLS
+ " VMS_SHORTEN_LONG_SYMBOLS"
+# endif
# ifdef VMS_WE_ARE_CASE_SENSITIVE
" VMS_SYMBOL_CASE_AS_IS"
# endif
-# ifdef VMS_SHORTEN_LONG_SYMBOLS
- " VMS_SHORTEN_LONG_SYMBOLS"
-# endif
"";
#else
EXTCONST char PL_bincompat_options[];
#endif
+#ifndef PERL_SET_PHASE
+# define PERL_SET_PHASE(new_phase) \
+ PHASE_CHANGE_PROBE(PL_phase_names[new_phase], PL_phase_names[PL_phase]); \
+ PL_phase = new_phase;
+#endif
+
/* The interpreter phases. If these ever change, PL_phase_names right below will
* need to be updated accordingly. */
enum perl_phase {
@@ -4769,6 +4824,8 @@
* instead of using the newer PL_phase, which provides everything PL_dirty
* provided, and more. */
# define PL_dirty (PL_phase == PERL_PHASE_DESTRUCT)
+
+# define PL_amagic_generation PL_na
#endif /* !PERL_CORE */
END_EXTERN_C
@@ -4803,44 +4860,6 @@
/* update exp_name[] in toke.c if adding to this enum */
} expectation;
-enum { /* pass one of these to get_vtbl */
- want_vtbl_sv,
- want_vtbl_env,
- want_vtbl_envelem,
- want_vtbl_sig,
- want_vtbl_sigelem,
- want_vtbl_pack,
- want_vtbl_packelem,
- want_vtbl_dbline,
- want_vtbl_isa,
- want_vtbl_isaelem,
- want_vtbl_arylen,
- want_vtbl_glob,
- want_vtbl_mglob,
- want_vtbl_nkeys,
- want_vtbl_taint,
- want_vtbl_substr,
- want_vtbl_vec,
- want_vtbl_pos,
- want_vtbl_bm,
- want_vtbl_fm,
- want_vtbl_uvar,
- want_vtbl_defelem,
- want_vtbl_regexp,
- want_vtbl_collxfrm,
- want_vtbl_amagic,
- want_vtbl_amagicelem,
- want_vtbl_regdata,
- want_vtbl_regdatum,
- want_vtbl_backref,
- want_vtbl_utf8,
- want_vtbl_symtab,
- want_vtbl_arylen_p,
- want_vtbl_hintselem,
- want_vtbl_hints
-};
-
-
/* Hints are now stored in a dedicated U32, so the bottom 8 bits are no longer
special and there is no need for HINT_PRIVATE_MASK for COPs
However, bitops store HINT_INTEGER in their op_private. */
@@ -4848,10 +4867,12 @@
#define HINT_STRICT_REFS 0x00000002 /* strict pragma */
#define HINT_LOCALE 0x00000004 /* locale pragma */
#define HINT_BYTES 0x00000008 /* bytes pragma */
-#define HINT_ARYBASE 0x00000010 /* $[ is non-zero */
- /* Note: 20,40,80 used for NATIVE_HINTS */
- /* currently defined by vms/vmsish.h */
+#define HINT_LOCALE_NOT_CHARS 0x00000010 /* locale ':not_characters' pragma */
+#define HINT_EXPLICIT_STRICT_REFS 0x00000020 /* strict.pm */
+#define HINT_EXPLICIT_STRICT_SUBS 0x00000040 /* strict.pm */
+#define HINT_EXPLICIT_STRICT_VARS 0x00000080 /* strict.pm */
+
#define HINT_BLOCK_SCOPE 0x00000100
#define HINT_STRICT_SUBS 0x00000200 /* strict pragma */
#define HINT_STRICT_VARS 0x00000400 /* strict pragma */
@@ -4877,6 +4898,14 @@
#define HINT_RE_FLAGS 0x02000000 /* re '/xism' pragma */
+#define HINT_FEATURE_MASK 0x1c000000 /* 3 bits for feature bundles */
+
+ /* Note: Used for NATIVE_HINTS, currently
+ defined by vms/vmsish.h:
+ 0x40000000
+ 0x80000000
+ */
+
/* The following are stored in $^H{sort}, not in PL_hints */
#define HINT_SORT_SORT_BITS 0x000000FF /* allow 256 different ones */
#define HINT_SORT_QUICKSORT 0x00000001
@@ -4883,6 +4912,17 @@
#define HINT_SORT_MERGESORT 0x00000002
#define HINT_SORT_STABLE 0x00000100 /* sort styles (currently one) */
+/* flags for PL_sawampersand */
+
+#define SAWAMPERSAND_LEFT 1 /* saw $` */
+#define SAWAMPERSAND_MIDDLE 2 /* saw $& */
+#define SAWAMPERSAND_RIGHT 4 /* saw $' */
+
+#ifndef PERL_SAWAMPERSAND
+# define PL_sawampersand \
+ (SAWAMPERSAND_LEFT|SAWAMPERSAND_MIDDLE|SAWAMPERSAND_RIGHT)
+#endif
+
/* Various states of the input record separator SV (rs) */
#define RsSNARF(sv) (! SvOK(sv))
#define RsSIMPLE(sv) (SvOK(sv) && (! SvPOK(sv) || SvCUR(sv)))
@@ -4925,13 +4965,6 @@
typedef void (*ATEXIT_t) (pTHX_ void*);
typedef void (*XSUBADDR_t) (pTHX_ CV *);
-/* Set up PERLVAR macros for populating structs */
-#define PERLVAR(var,type) type var;
-#define PERLVARA(var,n,type) type var[n];
-#define PERLVARI(var,type,init) type var;
-#define PERLVARIC(var,type,init) type var;
-#define PERLVARISC(var,init) const char var[sizeof(init)];
-
typedef OP* (*Perl_ppaddr_t)(pTHX);
typedef OP* (*Perl_check_t) (pTHX_ OP*);
typedef void(*Perl_ophook_t)(pTHX_ OP*);
@@ -4938,6 +4971,8 @@
typedef int (*Perl_keyword_plugin_t)(pTHX_ char*, STRLEN, OP**);
typedef void(*Perl_cpeep_t)(pTHX_ OP *, OP *);
+typedef void(*globhook_t)(pTHX);
+
#define KEYWORD_PLUGIN_DECLINE 0
#define KEYWORD_PLUGIN_STMT 1
#define KEYWORD_PLUGIN_EXPR 2
@@ -4958,41 +4993,14 @@
# define FAKE_DEFAULT_SIGNAL_HANDLERS
#endif
-#define PERL_PATCHLEVEL_H_IMPLICIT
-#include "patchlevel.h"
-#undef PERL_PATCHLEVEL_H_IMPLICIT
+#if !defined(MULTIPLICITY)
-#define PERL_VERSION_STRING STRINGIFY(PERL_REVISION) "." \
- STRINGIFY(PERL_VERSION) "." \
- STRINGIFY(PERL_SUBVERSION)
-
-#define PERL_API_VERSION_STRING STRINGIFY(PERL_API_REVISION) "." \
- STRINGIFY(PERL_API_VERSION) "." \
- STRINGIFY(PERL_API_SUBVERSION)
-
-#ifdef PERL_GLOBAL_STRUCT
-struct perl_vars {
-# include "perlvars.h"
+struct interpreter {
+ char broiled;
};
-# ifdef PERL_CORE
-# ifndef PERL_GLOBAL_STRUCT_PRIVATE
-EXT struct perl_vars PL_Vars;
-EXT struct perl_vars *PL_VarsPtr INIT(&PL_Vars);
-# undef PERL_GET_VARS
-# define PERL_GET_VARS() PL_VarsPtr
-# endif /* !PERL_GLOBAL_STRUCT_PRIVATE */
-# else /* PERL_CORE */
-# if !defined(__GNUC__) || !defined(WIN32)
-EXT
-# endif /* WIN32 */
-struct perl_vars *PL_VarsPtr;
-# define PL_Vars (*((PL_VarsPtr) \
- ? PL_VarsPtr : (PL_VarsPtr = Perl_GetVars(aTHX))))
-# endif /* PERL_CORE */
-#endif /* PERL_GLOBAL_STRUCT */
+#else
-#if defined(MULTIPLICITY)
/* If we have multiple interpreters define a struct
holding variables which must be per-interpreter
If we don't have threads anything that would have
@@ -4999,23 +5007,72 @@
be per-thread is per-interpreter.
*/
+/* 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;
+
struct interpreter {
# include "intrpvar.h"
};
-#else
-struct interpreter {
- char broiled;
+EXTCONST U16 PL_interp_size
+ INIT(sizeof(struct interpreter));
+
+# define PERL_INTERPRETER_SIZE_UPTO_MEMBER(member) \
+ STRUCT_OFFSET(struct interpreter, member) + \
+ sizeof(((struct interpreter*)0)->member)
+
+/* This will be useful for subsequent releases, because this has to be the
+ same in your libperl as in main(), else you have a mismatch and must abort.
+*/
+EXTCONST U16 PL_interp_size_5_18_0
+ INIT(PERL_INTERPRETER_SIZE_UPTO_MEMBER(PERL_LAST_5_18_0_INTERP_MEMBER));
+
+
+# ifdef PERL_GLOBAL_STRUCT
+/* MULTIPLICITY is automatically defined when PERL_GLOBAL_STRUCT is defined,
+ hence it's safe and sane to nest this within #ifdef MULTIPLICITY */
+
+struct perl_vars {
+# include "perlvars.h"
};
-#endif /* MULTIPLICITY */
+EXTCONST U16 PL_global_struct_size
+ INIT(sizeof(struct perl_vars));
+
+# ifdef PERL_CORE
+# ifndef PERL_GLOBAL_STRUCT_PRIVATE
+EXT struct perl_vars PL_Vars;
+EXT struct perl_vars *PL_VarsPtr INIT(&PL_Vars);
+# undef PERL_GET_VARS
+# define PERL_GET_VARS() PL_VarsPtr
+# endif /* !PERL_GLOBAL_STRUCT_PRIVATE */
+# else /* PERL_CORE */
+# if !defined(__GNUC__) || !defined(WIN32)
+EXT
+# endif /* WIN32 */
+struct perl_vars *PL_VarsPtr;
+# define PL_Vars (*((PL_VarsPtr) \
+ ? PL_VarsPtr : (PL_VarsPtr = Perl_GetVars(aTHX))))
+# endif /* PERL_CORE */
+# endif /* PERL_GLOBAL_STRUCT */
+
/* Done with PERLVAR macros for now ... */
-#undef PERLVAR
-#undef PERLVARA
-#undef PERLVARI
-#undef PERLVARIC
-#undef PERLVARISC
+# undef PERLVAR
+# undef PERLVARA
+# undef PERLVARI
+# undef PERLVARIC
+#endif /* MULTIPLICITY */
+
struct tempsym; /* defined in pp_pack.c */
#include "thread.h"
@@ -5028,6 +5085,24 @@
# define PERL_CALLCONV
# endif
#endif
+#ifndef PERL_CALLCONV_NO_RET
+# define PERL_CALLCONV_NO_RET PERL_CALLCONV
+#endif
+
+/* PERL_STATIC_NO_RET is supposed to be equivalent to STATIC on builds that
+ dont have a noreturn as a declaration specifier
+*/
+#ifndef PERL_STATIC_NO_RET
+# define PERL_STATIC_NO_RET STATIC
+#endif
+/* PERL_STATIC_NO_RET is supposed to be equivalent to PERL_STATIC_INLINE on
+ builds that dont have a noreturn as a declaration specifier
+*/
+#ifndef PERL_STATIC_INLINE_NO_RET
+# define PERL_STATIC_INLINE_NO_RET PERL_STATIC_INLINE
+#endif
+
+
#undef PERL_CKDEF
#undef PERL_PPDEF
#define PERL_CKDEF(s) PERL_CALLCONV OP *s (pTHX_ OP *o);
@@ -5059,11 +5134,10 @@
* these include variables that would have been their struct-s
*/
-#define PERLVAR(var,type) EXT type PL_##var;
-#define PERLVARA(var,n,type) EXT type PL_##var[n];
-#define PERLVARI(var,type,init) EXT type PL_##var INIT(init);
-#define PERLVARIC(var,type,init) EXTCONST type PL_##var INIT(init);
-#define PERLVARISC(var,init) EXTCONST char PL_##var[sizeof(init)] INIT(init);
+#define PERLVAR(prefix,var,type) EXT type PL_##var;
+#define PERLVARA(prefix,var,n,type) EXT type PL_##var[n];
+#define PERLVARI(prefix,var,type,init) EXT type PL_##var INIT(init);
+#define PERLVARIC(prefix,var,type,init) EXTCONST type PL_##var INIT(init);
#if !defined(MULTIPLICITY)
START_EXTERN_C
@@ -5076,13 +5150,13 @@
# undef PL_na
#endif
-#if defined(WIN32)
-/* Now all the config stuff is setup we can include embed.h */
-# include "embed.h"
-# ifndef PERL_MAD
-# undef op_getmad
-# define op_getmad(arg,pegop,slot) NOOP
-# endif
+/* Now all the config stuff is setup we can include embed.h
+ In particular, need the relevant *ish file included already, as it may
+ define HAVE_INTERP_INTERN */
+#include "embed.h"
+#ifndef PERL_MAD
+# undef op_getmad
+# define op_getmad(arg,pegop,slot) NOOP
#endif
#ifndef PERL_GLOBAL_STRUCT
@@ -5100,6 +5174,14 @@
START_EXTERN_C
+/* dummy variables that hold pointers to both runops functions, thus forcing
+ * them *both* to get linked in (useful for Peek.xs, debugging etc) */
+
+EXTCONST runops_proc_t PL_runops_std
+ INIT(Perl_runops_standard);
+EXTCONST runops_proc_t PL_runops_dbg
+ INIT(Perl_runops_debug);
+
/* PERL_GLOBAL_STRUCT_PRIVATE wants to keep global data like the
* magic vtables const, but this is incompatible with SWIG which
* does want to modify the vtables. */
@@ -5109,461 +5191,86 @@
# define EXT_MGVTBL EXT MGVTBL
#endif
+#define PERL_MAGIC_READONLY_ACCEPTABLE 0x40
+#define PERL_MAGIC_VALUE_MAGIC 0x80
+#define PERL_MAGIC_VTABLE_MASK 0x3F
+#define PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(t) \
+ (PL_magic_data[(U8)(t)] & PERL_MAGIC_READONLY_ACCEPTABLE)
+#define PERL_MAGIC_TYPE_IS_VALUE_MAGIC(t) \
+ (PL_magic_data[(U8)(t)] & PERL_MAGIC_VALUE_MAGIC)
+
+#include "mg_vtable.h"
+
#ifdef DOINIT
-# define MGVTBL_SET(var,a,b,c,d,e,f,g,h) EXT_MGVTBL var = {a,b,c,d,e,f,g,h}
-/* Like MGVTBL_SET but with the get magic having a const MG* */
-# define MGVTBL_SET_CONST_MAGIC_GET(var,a,b,c,d,e,f,g,h) EXT_MGVTBL var \
- = {(int (*)(pTHX_ SV *, MAGIC *))a,b,c,d,e,f,g,h}
+EXTCONST U8 PL_magic_data[256] =
+# ifdef PERL_MICRO
+# include "umg_data.h"
+# else
+# include "mg_data.h"
+# endif
+;
#else
-# define MGVTBL_SET(var,a,b,c,d,e,f,g,h) EXT_MGVTBL var
-# define MGVTBL_SET_CONST_MAGIC_GET(var,a,b,c,d,e,f,g,h) EXT_MGVTBL var
+EXTCONST U8 PL_magic_data[256];
#endif
-/* These all need to be 0, not NULL, as NULL can be (void*)0, which is a
- * pointer to data, whereas we're assigning pointers to functions, which are
- * not the same beast. ANSI doesn't allow the assignment from one to the other.
- * (although most, but not all, compilers are prepared to do it)
- */
+#ifdef DOINIT
+ /* NL BD IV NV PV PI PN MG RX GV LV AV HV CV FM IO */
+EXTCONST bool
+PL_valid_types_IVX[] = { 0, 0, 1, 0, 0, 1, 1, 1, 0, 1, 1, 0, 0, 0, 0, 0 };
+EXTCONST bool
+PL_valid_types_NVX[] = { 0, 0, 0, 1, 0, 0, 1, 1, 0, 1, 1, 0, 0, 0, 0, 0 };
+EXTCONST bool
+PL_valid_types_PVX[] = { 0, 0, 0, 0, 1, 1, 1, 1, 0, 1, 1, 0, 0, 1, 1, 1 };
+EXTCONST bool
+PL_valid_types_RV[] = { 0, 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 1 };
+EXTCONST bool
+PL_valid_types_IV_set[] = { 0, 0, 1, 0, 0, 1, 1, 1, 1, 1, 1, 0, 0, 0, 1, 1 };
+EXTCONST bool
+PL_valid_types_NV_set[] = { 0, 0, 0, 1, 0, 0, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0 };
-/* args are:
- vtable
- get
- set
- len
- clear
- free
- copy
- dup
- local
-*/
+#else
-MGVTBL_SET(
- PL_vtbl_sv,
- Perl_magic_get,
- Perl_magic_set,
- Perl_magic_len,
- 0,
- 0,
- 0,
- 0,
- 0
-);
+EXTCONST bool PL_valid_types_IVX[];
+EXTCONST bool PL_valid_types_NVX[];
+EXTCONST bool PL_valid_types_PVX[];
+EXTCONST bool PL_valid_types_RV[];
+EXTCONST bool PL_valid_types_IV_set[];
+EXTCONST bool PL_valid_types_NV_set[];
-MGVTBL_SET(
- PL_vtbl_env,
- 0,
- Perl_magic_set_all_env,
- 0,
- Perl_magic_clear_all_env,
- 0,
- 0,
- 0,
- 0
-);
-
-MGVTBL_SET(
- PL_vtbl_envelem,
- 0,
- Perl_magic_setenv,
- 0,
- Perl_magic_clearenv,
- 0,
- 0,
- 0,
- 0
-);
-
-MGVTBL_SET(
- PL_vtbl_sig,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0
-);
-
-#ifdef PERL_MICRO
-MGVTBL_SET(
- PL_vtbl_sigelem,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0
-);
-
-#else
-MGVTBL_SET(
- PL_vtbl_sigelem,
- Perl_magic_getsig,
- Perl_magic_setsig,
- 0,
- Perl_magic_clearsig,
- 0,
- 0,
- 0,
- 0
-);
#endif
-MGVTBL_SET(
- PL_vtbl_pack,
- 0,
- 0,
- Perl_magic_sizepack,
- Perl_magic_wipepack,
- 0,
- 0,
- 0,
- 0
-);
+#ifndef PERL_NO_INLINE_FUNCTIONS
+/* Static inline funcs that depend on includes and declarations above.
+ Some of these reference functions in the perl object files, and some
+ compilers aren't smart enough to eliminate unused static inline
+ functions, so including this file in source code can cause link errors
+ even if the source code uses none of the functions. Hence including these
+ can be be suppressed by setting PERL_NO_INLINE_FUNCTIONS. Doing this will
+ (obviously) result in unworkable XS code, but allows simple probing code
+ to continue to work, because it permits tests to include the perl headers
+ for definitions without creating a link dependency on the perl library
+ (which may not exist yet).
+*/
-MGVTBL_SET(
- PL_vtbl_packelem,
- Perl_magic_getpack,
- Perl_magic_setpack,
- 0,
- Perl_magic_clearpack,
- 0,
- 0,
- 0,
- 0
-);
-
-MGVTBL_SET(
- PL_vtbl_dbline,
- 0,
- Perl_magic_setdbline,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0
-);
-
-MGVTBL_SET(
- PL_vtbl_isa,
- 0,
- Perl_magic_setisa,
- 0,
- Perl_magic_clearisa,
- 0,
- 0,
- 0,
- 0
-);
-
-MGVTBL_SET(
- PL_vtbl_isaelem,
- 0,
- Perl_magic_setisa,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0
-);
-
-MGVTBL_SET_CONST_MAGIC_GET(
- PL_vtbl_arylen,
- Perl_magic_getarylen,
- Perl_magic_setarylen,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0
-);
-
-MGVTBL_SET(
- PL_vtbl_arylen_p,
- 0,
- 0,
- 0,
- 0,
- Perl_magic_freearylen_p,
- 0,
- 0,
- 0
-);
-
-MGVTBL_SET(
- PL_vtbl_mglob,
- 0,
- Perl_magic_setmglob,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0
-);
-
-MGVTBL_SET(
- PL_vtbl_nkeys,
- Perl_magic_getnkeys,
- Perl_magic_setnkeys,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0
-);
-
-MGVTBL_SET(
- PL_vtbl_taint,
- Perl_magic_gettaint,
- Perl_magic_settaint,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0
-);
-
-MGVTBL_SET(
- PL_vtbl_substr,
- Perl_magic_getsubstr,
- Perl_magic_setsubstr,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0
-);
-
-MGVTBL_SET(
- PL_vtbl_vec,
- Perl_magic_getvec,
- Perl_magic_setvec,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0
-);
-
-MGVTBL_SET(
- PL_vtbl_pos,
- Perl_magic_getpos,
- Perl_magic_setpos,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0
-);
-
-MGVTBL_SET(
- PL_vtbl_bm,
- 0,
- Perl_magic_setregexp,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0
-);
-
-MGVTBL_SET(
- PL_vtbl_fm,
- 0,
- Perl_magic_setregexp,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0
-);
-
-MGVTBL_SET(
- PL_vtbl_uvar,
- Perl_magic_getuvar,
- Perl_magic_setuvar,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0
-);
-
-MGVTBL_SET(
- PL_vtbl_defelem,
- Perl_magic_getdefelem,
- Perl_magic_setdefelem,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0
-);
-
-MGVTBL_SET(
- PL_vtbl_regexp,
- 0,
- Perl_magic_setregexp,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0
-);
-
-MGVTBL_SET(
- PL_vtbl_regdata,
- 0,
- 0,
- Perl_magic_regdata_cnt,
- 0,
- 0,
- 0,
- 0,
- 0
-);
-
-MGVTBL_SET(
- PL_vtbl_regdatum,
- Perl_magic_regdatum_get,
- Perl_magic_regdatum_set,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0
-);
-
-MGVTBL_SET(
- PL_vtbl_amagic,
- 0,
- Perl_magic_setamagic,
- 0,
- 0,
- Perl_magic_setamagic,
- 0,
- 0,
- 0
-);
-
-MGVTBL_SET(
- PL_vtbl_amagicelem,
- 0,
- Perl_magic_setamagic,
- 0,
- 0,
- Perl_magic_setamagic,
- 0,
- 0,
- 0
-);
-
-MGVTBL_SET(
- PL_vtbl_backref,
- 0,
- 0,
- 0,
- 0,
- Perl_magic_killbackrefs,
- 0,
- 0,
- 0
-);
-
-MGVTBL_SET(
- PL_vtbl_ovrld,
- 0,
- 0,
- 0,
- 0,
- Perl_magic_freeovrld,
- 0,
- 0,
- 0
-);
-
-MGVTBL_SET(
- PL_vtbl_utf8,
- 0,
- Perl_magic_setutf8,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0
-);
-#ifdef USE_LOCALE_COLLATE
-MGVTBL_SET(
- PL_vtbl_collxfrm,
- 0,
- Perl_magic_setcollxfrm,
- 0,
- 0,
- 0,
- 0,
- 0,
- 0
-);
+# include "inline.h"
#endif
-MGVTBL_SET(
- PL_vtbl_hintselem,
- 0,
- Perl_magic_sethint,
- 0,
- Perl_magic_clearhint,
- 0,
- 0,
- 0,
- 0
-);
-
-MGVTBL_SET(
- PL_vtbl_hints,
- 0,
- 0,
- 0,
- Perl_magic_clearhints,
- 0,
- 0,
- 0,
- 0
-);
-
#include "overload.h"
END_EXTERN_C
struct am_table {
- U32 flags;
+ U8 flags;
+ U8 fallback;
+ U16 spare;
U32 was_ok_sub;
- long was_ok_am;
- long fallback;
CV* table[NofAMmeth];
};
struct am_table_short {
- U32 flags;
+ U8 flags;
+ U8 fallback;
+ U16 spare;
U32 was_ok_sub;
- long was_ok_am;
};
typedef struct am_table AMT;
typedef struct am_table_short AMTS;
@@ -5573,13 +5280,9 @@
#define AMGfallYES 3
#define AMTf_AMAGIC 1
-#define AMTf_OVERLOADED 2
#define AMT_AMAGIC(amt) ((amt)->flags & AMTf_AMAGIC)
#define AMT_AMAGIC_on(amt) ((amt)->flags |= AMTf_AMAGIC)
#define AMT_AMAGIC_off(amt) ((amt)->flags &= ~AMTf_AMAGIC)
-#define AMT_OVERLOADED(amt) ((amt)->flags & AMTf_OVERLOADED)
-#define AMT_OVERLOADED_on(amt) ((amt)->flags |= AMTf_OVERLOADED)
-#define AMT_OVERLOADED_off(amt) ((amt)->flags &= ~AMTf_OVERLOADED)
#define StashHANDLER(stash,meth) gv_handler((stash),CAT2(meth,_amg))
@@ -5657,11 +5360,23 @@
#define SET_NUMERIC_LOCAL() \
set_numeric_local();
+/* Returns non-zero If the plain locale pragma without a parameter is in effect
+ */
#define IN_LOCALE_RUNTIME (CopHINTS_get(PL_curcop) & HINT_LOCALE)
+
+/* Returns non-zero If either form of the locale pragma is in effect */
+#define IN_SOME_LOCALE_FORM_RUNTIME \
+ (CopHINTS_get(PL_curcop) & (HINT_LOCALE|HINT_LOCALE_NOT_CHARS))
+
#define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE)
+#define IN_SOME_LOCALE_FORM_COMPILETIME \
+ (PL_hints & (HINT_LOCALE|HINT_LOCALE_NOT_CHARS))
#define IN_LOCALE \
(IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME)
+#define IN_SOME_LOCALE_FORM \
+ (IN_PERL_COMPILETIME ? IN_SOME_LOCALE_FORM_COMPILETIME \
+ : IN_SOME_LOCALE_FORM_RUNTIME)
#define STORE_NUMERIC_LOCAL_SET_STANDARD() \
bool was_local = PL_numeric_local && IN_LOCALE; \
@@ -5690,10 +5405,12 @@
#define RESTORE_NUMERIC_STANDARD() /**/
#define Atof my_atof
#define IN_LOCALE_RUNTIME 0
+#define IN_LOCALE_COMPILETIME 0
#endif /* !USE_LOCALE_NUMERIC */
-#if !defined(Strtol) && defined(USE_64_BIT_INT) && defined(IV_IS_QUAD) && QUADKIND == QUAD_IS_LONG_LONG
+#if !defined(Strtol) && defined(USE_64_BIT_INT) && defined(IV_IS_QUAD) && \
+ (QUADKIND == QUAD_IS_LONG_LONG || QUADKIND == QUAD_IS___INT64)
# ifdef __hpux
# define strtoll __strtoll /* secret handshake */
# endif
@@ -5715,7 +5432,8 @@
/* It would be more fashionable to use Strtol() to define atol()
* (as is done for Atoul(), see below) but for backward compatibility
* we just assume atol(). */
-# if defined(USE_64_BIT_INT) && defined(IV_IS_QUAD) && QUADKIND == QUAD_IS_LONG_LONG && defined(HAS_ATOLL)
+# if defined(USE_64_BIT_INT) && defined(IV_IS_QUAD) && defined(HAS_ATOLL) && \
+ (QUADKIND == QUAD_IS_LONG_LONG || QUADKIND == QUAD_IS___INT64)
# ifdef WIN64
# define atoll _atoi64 /* secret handshake */
# endif
@@ -5725,7 +5443,8 @@
# endif
#endif
-#if !defined(Strtoul) && defined(USE_64_BIT_INT) && defined(UV_IS_QUAD) && QUADKIND == QUAD_IS_LONG_LONG
+#if !defined(Strtoul) && defined(USE_64_BIT_INT) && defined(UV_IS_QUAD) && \
+ (QUADKIND == QUAD_IS_LONG_LONG || QUADKIND == QUAD_IS___INT64)
# ifdef __hpux
# define strtoull __strtoull /* secret handshake */
# endif
@@ -5881,10 +5600,12 @@
* the interpreter goes away.) */
# define MY_CXT_INIT \
my_cxt_t *my_cxtp = \
- (my_cxt_t*)Perl_my_cxt_init(aTHX_ MY_CXT_INIT_ARG, sizeof(my_cxt_t))
+ (my_cxt_t*)Perl_my_cxt_init(aTHX_ MY_CXT_INIT_ARG, sizeof(my_cxt_t)); \
+ PERL_UNUSED_VAR(my_cxtp)
# define MY_CXT_INIT_INTERP(my_perl) \
my_cxt_t *my_cxtp = \
- (my_cxt_t*)Perl_my_cxt_init(my_perl, MY_CXT_INIT_ARG, sizeof(my_cxt_t))
+ (my_cxt_t*)Perl_my_cxt_init(my_perl, MY_CXT_INIT_ARG, sizeof(my_cxt_t)); \
+ PERL_UNUSED_VAR(my_cxtp)
/* This declaration should be used within all functions that use the
* interpreter-local data. */
@@ -5901,7 +5622,7 @@
/* This macro must be used to access members of the my_cxt_t structure.
- * e.g. MYCXT.some_data */
+ * e.g. MY_CXT.some_data */
# define MY_CXT (*my_cxtp)
/* Judicious use of these macros can reduce the number of times dMY_CXT
@@ -5967,10 +5688,9 @@
#if O_TEXT != O_BINARY
/* If you have different O_TEXT and O_BINARY and you are a CLRF shop,
* that is, you are somehow DOSish. */
-# if defined(__BEOS__) || defined(__HAIKU__) || defined(__VOS__) || \
- defined(__CYGWIN__)
- /* BeOS/Haiku has O_TEXT != O_BINARY but O_TEXT and O_BINARY have no effect;
- * BeOS/Haiku is always UNIXoid (LF), not DOSish (CRLF). */
+# if defined(__HAIKU__) || defined(__VOS__) || defined(__CYGWIN__)
+ /* Haiku has O_TEXT != O_BINARY but O_TEXT and O_BINARY have no effect;
+ * Haiku is always UNIXoid (LF), not DOSish (CRLF). */
/* VOS has O_TEXT != O_BINARY, and they have effect,
* but VOS always uses LF, never CRLF. */
/* If you have O_TEXT different from your O_BINARY but you still are
@@ -6005,6 +5725,8 @@
#define PERL_SCAN_ALLOW_UNDERSCORES 0x01 /* grok_??? accept _ in numbers */
#define PERL_SCAN_DISALLOW_PREFIX 0x02 /* grok_??? reject 0x in hex etc */
#define PERL_SCAN_SILENT_ILLDIGIT 0x04 /* grok_??? not warn about illegal digits */
+#define PERL_SCAN_SILENT_NON_PORTABLE 0x08 /* grok_??? not warn about very large
+ numbers which are <= UV_MAX */
/* Output flags: */
#define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 /* should this merge with above? */
@@ -6022,15 +5744,7 @@
/* ISO 6429 NEL - C1 control NExt Line */
/* See http://www.unicode.org/unicode/reports/tr13/ */
-#ifdef EBCDIC /* In EBCDIC NEL is just an alias for LF */
-# if '^' == 95 /* CP 1047: MVS OpenEdition - OS/390 - z/OS */
-# define NEXT_LINE_CHAR 0x15
-# else /* CDRA */
-# define NEXT_LINE_CHAR 0x25
-# endif
-#else
-# define NEXT_LINE_CHAR 0x85
-#endif
+#define NEXT_LINE_CHAR NEXT_LINE_NATIVE
/* The UTF-8 bytes of the Unicode LS and PS, U+2028 and U+2029 */
#define UNICODE_LINE_SEPA_0 0xE2
@@ -6147,14 +5861,6 @@
#define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE
#define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE|PERL_PV_ESCAPE_NONASCII
-#ifdef PERL_CORE
-# define FEATURE_IS_ENABLED(name) \
- ((0 != (PL_hints & HINT_LOCALIZE_HH)) \
- && Perl_feature_is_enabled(aTHX_ STR_WITH_LEN(name)))
-/* The longest string we pass in. */
-# define MAX_FEATURE_LEN (sizeof("unicode_strings")-1)
-#endif
-
/*
(KEEP THIS LAST IN perl.h!)
@@ -6211,8 +5917,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/perl.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/perlapi.c
===================================================================
--- trunk/contrib/perl/perlapi.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/perlapi.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -34,21 +34,18 @@
START_EXTERN_C
#undef PERLVARI
-#define PERLVARI(v,t,i) PERLVAR(v,t)
+#define PERLVARI(p,v,t,i) PERLVAR(p,v,t)
#undef PERLVAR
#undef PERLVARA
-#define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
+#define PERLVAR(p,v,t) t* Perl_##p##v##_ptr(pTHX) \
{ dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
-#define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
+#define PERLVARA(p,v,n,t) PL_##v##_t* Perl_##p##v##_ptr(pTHX) \
{ dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
#undef PERLVARIC
-#undef PERLVARISC
-#define PERLVARIC(v,t,i) \
- const t* Perl_##v##_ptr(pTHX) \
+#define PERLVARIC(p,v,t,i) \
+ const t* Perl_##p##v##_ptr(pTHX) \
{ PERL_UNUSED_CONTEXT; return (const t *)&(PL_##v); }
-#define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX) \
- { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
#include "perlvars.h"
#undef PERLVAR
@@ -55,7 +52,6 @@
#undef PERLVARA
#undef PERLVARI
#undef PERLVARIC
-#undef PERLVARISC
END_EXTERN_C
Property changes on: trunk/contrib/perl/perlapi.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/perlapi.h
===================================================================
--- trunk/contrib/perl/perlapi.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/perlapi.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -28,14 +28,11 @@
#undef PERLVARA
#undef PERLVARI
#undef PERLVARIC
-#undef PERLVARISC
-#define PERLVAR(v,t) EXTERN_C t* Perl_##v##_ptr(pTHX);
-#define PERLVARA(v,n,t) typedef t PL_##v##_t[n]; \
- EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
-#define PERLVARI(v,t,i) PERLVAR(v,t)
-#define PERLVARIC(v,t,i) PERLVAR(v, const t)
-#define PERLVARISC(v,i) typedef const char PL_##v##_t[sizeof(i)]; \
- EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
+#define PERLVAR(p,v,t) EXTERN_C t* Perl_##p##v##_ptr(pTHX);
+#define PERLVARA(p,v,n,t) typedef t PL_##v##_t[n]; \
+ EXTERN_C PL_##v##_t* Perl_##p##v##_ptr(pTHX);
+#define PERLVARI(p,v,t,i) PERLVAR(p,v,t)
+#define PERLVARIC(p,v,t,i) PERLVAR(p,v, const t)
#include "perlvars.h"
@@ -43,7 +40,6 @@
#undef PERLVARA
#undef PERLVARI
#undef PERLVARIC
-#undef PERLVARISC
END_EXTERN_C
@@ -66,11 +62,10 @@
#undef PERLVARA
#undef PERLVARI
#undef PERLVARIC
-#define PERLVAR(v,t) (void*)Perl_##v##_ptr,
-#define PERLVARA(v,n,t) PERLVAR(v,t)
-#define PERLVARI(v,t,i) PERLVAR(v,t)
-#define PERLVARIC(v,t,i) PERLVAR(v,t)
-#define PERLVARISC(v,i) PERLVAR(v,char)
+#define PERLVAR(p,v,t) (void*)Perl_##p##v##_ptr,
+#define PERLVARA(p,v,n,t) PERLVAR(p,v,t)
+#define PERLVARI(p,v,t,i) PERLVAR(p,v,t)
+#define PERLVARIC(p,v,t,i) PERLVAR(p,v,t)
/* In Tru64 (__DEC && __osf__) the cc option -std1 causes that one
* cannot cast between void pointers and function pointers without
@@ -95,7 +90,6 @@
#undef PERLVARA
#undef PERLVARI
#undef PERLVARIC
-#undef PERLVARISC
};
#endif /* DOINIT */
@@ -105,16 +99,12 @@
#else /* !PERL_CORE */
-#undef PL_No
-#define PL_No (*Perl_GNo_ptr(NULL))
-#undef PL_Yes
-#define PL_Yes (*Perl_GYes_ptr(NULL))
#undef PL_appctx
#define PL_appctx (*Perl_Gappctx_ptr(NULL))
-#undef PL_charclass
-#define PL_charclass (*Perl_Gcharclass_ptr(NULL))
#undef PL_check
#define PL_check (*Perl_Gcheck_ptr(NULL))
+#undef PL_check_mutex
+#define PL_check_mutex (*Perl_Gcheck_mutex_ptr(NULL))
#undef PL_csighandlerp
#define PL_csighandlerp (*Perl_Gcsighandlerp_ptr(NULL))
#undef PL_curinterp
@@ -125,16 +115,12 @@
#define PL_dollarzero_mutex (*Perl_Gdollarzero_mutex_ptr(NULL))
#undef PL_fold_locale
#define PL_fold_locale (*Perl_Gfold_locale_ptr(NULL))
-#undef PL_global_struct_size
-#define PL_global_struct_size (*Perl_Gglobal_struct_size_ptr(NULL))
-#undef PL_hexdigit
-#define PL_hexdigit (*Perl_Ghexdigit_ptr(NULL))
+#undef PL_hash_seed
+#define PL_hash_seed (*Perl_Ghash_seed_ptr(NULL))
+#undef PL_hash_seed_set
+#define PL_hash_seed_set (*Perl_Ghash_seed_set_ptr(NULL))
#undef PL_hints_mutex
#define PL_hints_mutex (*Perl_Ghints_mutex_ptr(NULL))
-#undef PL_interp_size
-#define PL_interp_size (*Perl_Ginterp_size_ptr(NULL))
-#undef PL_interp_size_5_10_0
-#define PL_interp_size_5_10_0 (*Perl_Ginterp_size_5_10_0_ptr(NULL))
#undef PL_keyword_plugin
#define PL_keyword_plugin (*Perl_Gkeyword_plugin_ptr(NULL))
#undef PL_malloc_mutex
@@ -151,8 +137,6 @@
#define PL_op_seq (*Perl_Gop_seq_ptr(NULL))
#undef PL_op_sequence
#define PL_op_sequence (*Perl_Gop_sequence_ptr(NULL))
-#undef PL_patleave
-#define PL_patleave (*Perl_Gpatleave_ptr(NULL))
#undef PL_perlio_debug_fd
#define PL_perlio_debug_fd (*Perl_Gperlio_debug_fd_ptr(NULL))
#undef PL_perlio_fd_refcnt
@@ -163,12 +147,6 @@
#define PL_perlio_mutex (*Perl_Gperlio_mutex_ptr(NULL))
#undef PL_ppaddr
#define PL_ppaddr (*Perl_Gppaddr_ptr(NULL))
-#undef PL_revision
-#define PL_revision (*Perl_Grevision_ptr(NULL))
-#undef PL_runops_dbg
-#define PL_runops_dbg (*Perl_Grunops_dbg_ptr(NULL))
-#undef PL_runops_std
-#define PL_runops_std (*Perl_Grunops_std_ptr(NULL))
#undef PL_sh_path
#define PL_sh_path (*Perl_Gsh_path_ptr(NULL))
#undef PL_sig_defaulting
@@ -181,8 +159,6 @@
#define PL_sig_trapped (*Perl_Gsig_trapped_ptr(NULL))
#undef PL_sigfpe_saved
#define PL_sigfpe_saved (*Perl_Gsigfpe_saved_ptr(NULL))
-#undef PL_subversion
-#define PL_subversion (*Perl_Gsubversion_ptr(NULL))
#undef PL_sv_placeholder
#define PL_sv_placeholder (*Perl_Gsv_placeholder_ptr(NULL))
#undef PL_thr_key
@@ -191,8 +167,6 @@
#define PL_timesbase (*Perl_Gtimesbase_ptr(NULL))
#undef PL_use_safe_putenv
#define PL_use_safe_putenv (*Perl_Guse_safe_putenv_ptr(NULL))
-#undef PL_version
-#define PL_version (*Perl_Gversion_ptr(NULL))
#undef PL_veto_cleanup
#define PL_veto_cleanup (*Perl_Gveto_cleanup_ptr(NULL))
#undef PL_watch_pvx
Property changes on: trunk/contrib/perl/perlapi.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/perlio.c
===================================================================
--- trunk/contrib/perl/perlio.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/perlio.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -1,7 +1,7 @@
/*
* perlio.c
* Copyright (c) 1996-2006, Nick Ing-Simmons
- * Copyright (c) 2006, 2007, 2008 Larry Wall and others
+ * Copyright (c) 2006, 2007, 2008, 2009, 2010, 2011 Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public License
* or the Artistic License, as specified in the README file.
@@ -70,6 +70,10 @@
int mkstemp(char*);
#endif
+#ifdef VMS
+#include <rms.h>
+#endif
+
#define PerlIO_lockcnt(f) (((PerlIOl*)(f))->head->flags)
/* Call the callback or PerlIOBase, and return failure. */
@@ -137,17 +141,6 @@
* This used to be contents of do_binmode in doio.c
*/
#ifdef DOSISH
-# if defined(atarist)
- PERL_UNUSED_ARG(iotype);
- if (!fflush(fp)) {
- if (mode & O_BINARY)
- ((FILE *) fp)->_flag |= _IOBIN;
- else
- ((FILE *) fp)->_flag &= ~_IOBIN;
- return 1;
- }
- return 0;
-# else
dTHX;
PERL_UNUSED_ARG(iotype);
#ifdef NETWARE
@@ -155,28 +148,10 @@
#else
if (PerlLIO_setmode(fileno(fp), mode) != -1) {
#endif
-# if defined(WIN32) && defined(__BORLANDC__)
- /*
- * The translation mode of the stream is maintained independent
-of
- * the translation mode of the fd in the Borland RTL (heavy
- * digging through their runtime sources reveal). User has to
-set
- * the mode explicitly for the stream (though they don't
-document
- * this anywhere). GSAR 97-5-24
- */
- fseek(fp, 0L, 0);
- if (mode & O_BINARY)
- fp->flags |= _F_BIN;
- else
- fp->flags &= ~_F_BIN;
-# endif
return 1;
}
else
return 0;
-# endif
#else
# if defined(USEMYBINMODE)
dTHX;
@@ -468,17 +443,6 @@
#include "perliol.h"
-/*
- * We _MUST_ have <unistd.h> if we are using lseek() and may have large
- * files
- */
-#ifdef I_UNISTD
-#include <unistd.h>
-#endif
-#ifdef HAS_MMAP
-#include <sys/mman.h>
-#endif
-
void
PerlIO_debug(const char *fmt, ...)
{
@@ -486,7 +450,9 @@
dSYS;
va_start(ap, fmt);
if (!PL_perlio_debug_fd) {
- if (!PL_tainting && PL_uid == PL_euid && PL_gid == PL_egid) {
+ if (!TAINTING_get &&
+ PerlProc_getuid() == PerlProc_geteuid() &&
+ PerlProc_getgid() == PerlProc_getegid()) {
const char * const s = PerlEnv_getenv("PERLIO_DEBUG");
if (s && *s)
PL_perlio_debug_fd
@@ -500,7 +466,6 @@
}
}
if (PL_perlio_debug_fd > 0) {
- dTHX;
#ifdef USE_ITHREADS
const char * const s = CopFILE(PL_curcop);
/* Use fixed buffer as sv_catpvf etc. needs SVs */
@@ -846,7 +811,8 @@
len = strlen(name);
for (i = 0; i < PL_known_layers->cur; i++) {
PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
- if (memEQ(f->name, name, len) && f->name[len] == 0) {
+ const STRLEN this_len = strlen(f->name);
+ if (this_len == len && memEQ(f->name, name, len)) {
PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f);
return f;
}
@@ -1040,7 +1006,7 @@
}
do {
e++;
- } while (isALNUM(*e));
+ } while (isWORDCHAR(*e));
llen = e - s;
if (*e == '(') {
int nesting = 1;
@@ -1189,7 +1155,7 @@
{
dVAR;
if (!PL_def_layerlist) {
- const char * const s = (PL_tainting) ? NULL : PerlEnv_getenv("PERLIO");
+ const char * const s = TAINTING_get ? NULL : PerlEnv_getenv("PERLIO");
PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
PL_def_layerlist = PerlIO_list_alloc(aTHX);
PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
@@ -1203,9 +1169,6 @@
PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
-#ifdef HAS_MMAP
- PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_mmap));
-#endif
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));
@@ -1543,6 +1506,7 @@
/* This isn't supposed to happen, since PerlIO::scalar is core,
* but could happen anyway in smaller installs or with PAR */
if (!f)
+ /* diag_listed_as: Unknown PerlIO layer "%s" */
Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
return f;
}
@@ -2192,7 +2156,7 @@
SSize_t avail = PerlIO_get_cnt(f);
SSize_t take = 0;
if (avail > 0)
- take = ((SSize_t)count < avail) ? (SSize_t)count : avail;
+ take = (((SSize_t) count >= 0) && ((SSize_t)count < avail)) ? (SSize_t)count : avail;
if (take > 0) {
STDCHAR *ptr = PerlIO_get_ptr(f);
Copy(ptr, buf, take, STDCHAR);
@@ -2373,10 +2337,7 @@
#ifdef USE_ITHREADS
MUTEX_UNLOCK(&PL_perlio_mutex);
#endif
- /* Can't use PerlIO to write as it allocates memory */
- PerlLIO_write(PerlIO_fileno(Perl_error_log),
- PL_no_mem, strlen(PL_no_mem));
- my_exit(1);
+ croak_no_mem();
}
PL_perlio_fd_refcnt_size = new_max;
@@ -2431,7 +2392,6 @@
int
PerlIOUnix_refcnt_dec(int fd)
{
- dTHX;
int cnt = 0;
if (fd >= 0) {
dVAR;
@@ -2440,12 +2400,12 @@
#endif
if (fd >= PL_perlio_fd_refcnt_size) {
/* diag_listed_as: refcnt_dec: fd %d%s */
- Perl_croak(aTHX_ "refcnt_dec: fd %d >= refcnt_size %d\n",
+ Perl_croak_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n",
fd, PL_perlio_fd_refcnt_size);
}
if (PL_perlio_fd_refcnt[fd] <= 0) {
/* diag_listed_as: refcnt_dec: fd %d%s */
- Perl_croak(aTHX_ "refcnt_dec: fd %d: %d <= 0\n",
+ Perl_croak_nocontext("refcnt_dec: fd %d: %d <= 0\n",
fd, PL_perlio_fd_refcnt[fd]);
}
cnt = --PL_perlio_fd_refcnt[fd];
@@ -2455,7 +2415,7 @@
#endif
} else {
/* diag_listed_as: refcnt_dec: fd %d%s */
- Perl_croak(aTHX_ "refcnt_dec: fd %d < 0\n", fd);
+ Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd);
}
return cnt;
}
@@ -2587,8 +2547,10 @@
SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
PerlIO_lockcnt(f)++;
PERL_ASYNC_CHECK();
- if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) )
+ if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) {
+ LEAVE;
return 0;
+ }
/* we've just run some perl-level code that could have done
* anything, including closing the file or clearing this layer.
* If so, free any lower layers that have already been
@@ -2600,6 +2562,7 @@
*f = l->next;
Safefree(l);
}
+ LEAVE;
return 1;
}
@@ -2648,10 +2611,15 @@
oflags &= ~O_BINARY;
mode++;
}
- /*
- * Always open in binary mode
- */
- oflags |= O_BINARY;
+ else {
+#ifdef PERLIO_USING_CRLF
+ /*
+ * If neither "t" nor "b" was specified, open the file
+ * in O_BINARY mode.
+ */
+ oflags |= O_BINARY;
+#endif
+ }
if (*mode || oflags == -1) {
SETERRNO(EINVAL, LIB_INVARG);
oflags = -1;
@@ -3241,9 +3209,7 @@
f->_file = -1;
return 1;
# elif defined(WIN32)
-# if defined(__BORLANDC__)
- f->fd = PerlLIO_dup(fileno(f));
-# elif defined(UNDER_CE)
+# if defined(UNDER_CE)
/* WIN_CE does not have access to FILE internals, it hardly has FILE
structure at all
*/
@@ -3828,12 +3794,14 @@
while ((l = *p)) {
if (l->tab == &PerlIO_stdio) {
PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
- if (s->stdio == f) {
- dTHX;
+ if (s->stdio == f) { /* not in a loop */
const int fd = fileno(f);
if (fd >= 0)
PerlIOUnix_refcnt_dec(fd);
- PerlIO_pop(aTHX_ p);
+ {
+ dTHX;
+ PerlIO_pop(aTHX_ p);
+ }
return;
}
}
@@ -3922,7 +3890,6 @@
PerlLIO_setmode(fd, O_BINARY);
#endif
#ifdef VMS
-#include <rms.h>
/* Enable line buffering with record-oriented regular files
* so we don't introduce an extraneous record boundary when
* the buffer fills up.
@@ -4125,7 +4092,7 @@
*/
b->posn -= b->bufsiz;
}
- if (avail > (SSize_t) count) {
+ if ((SSize_t) count >= 0 && avail > (SSize_t) count) {
/*
* If we have space for more than count, just move count
*/
@@ -4175,7 +4142,7 @@
}
while (count > 0) {
SSize_t avail = b->bufsiz - (b->ptr - b->buf);
- if ((SSize_t) count < avail)
+ if ((SSize_t) count >= 0 && (SSize_t) count < avail)
avail = count;
if (flushptr > buf && flushptr <= buf + avail)
avail = flushptr - buf;
@@ -4450,7 +4417,7 @@
{
SSize_t avail = PerlIO_get_cnt(f);
SSize_t got = 0;
- if ((SSize_t)count < avail)
+ if ((SSize_t) count >= 0 && (SSize_t)count < avail)
avail = count;
if (avail > 0)
got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
@@ -4610,6 +4577,8 @@
}
}
}
+ if (count > 0)
+ unread += PerlIOBase_unread(aTHX_ f, (const STDCHAR *) vbuf + unread, count);
return unread;
}
}
@@ -4848,298 +4817,7 @@
PerlIOCrlf_set_ptrcnt,
};
-#ifdef HAS_MMAP
-/*--------------------------------------------------------------------------------------*/
-/*
- * mmap as "buffer" layer
- */
-
-typedef struct {
- PerlIOBuf base; /* PerlIOBuf stuff */
- Mmap_t mptr; /* Mapped address */
- Size_t len; /* mapped length */
- STDCHAR *bbuf; /* malloced buffer if map fails */
-} PerlIOMmap;
-
-IV
-PerlIOMmap_map(pTHX_ PerlIO *f)
-{
- dVAR;
- PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
- const IV flags = PerlIOBase(f)->flags;
- IV code = 0;
- if (m->len)
- abort();
- if (flags & PERLIO_F_CANREAD) {
- PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
- const int fd = PerlIO_fileno(f);
- Stat_t st;
- code = Fstat(fd, &st);
- if (code == 0 && S_ISREG(st.st_mode)) {
- SSize_t len = st.st_size - b->posn;
- if (len > 0) {
- Off_t posn;
- if (PL_mmap_page_size <= 0)
- Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
- PL_mmap_page_size);
- if (b->posn < 0) {
- /*
- * This is a hack - should never happen - open should
- * have set it !
- */
- b->posn = PerlIO_tell(PerlIONext(f));
- }
- posn = (b->posn / PL_mmap_page_size) * PL_mmap_page_size;
- len = st.st_size - posn;
- m->mptr = (Mmap_t)mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
- if (m->mptr && m->mptr != (Mmap_t) - 1) {
-#if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
- madvise(m->mptr, len, MADV_SEQUENTIAL);
-#endif
-#if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
- madvise(m->mptr, len, MADV_WILLNEED);
-#endif
- PerlIOBase(f)->flags =
- (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
- b->end = ((STDCHAR *) m->mptr) + len;
- b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
- b->ptr = b->buf;
- m->len = len;
- }
- else {
- b->buf = NULL;
- }
- }
- else {
- PerlIOBase(f)->flags =
- flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
- b->buf = NULL;
- b->ptr = b->end = b->ptr;
- code = -1;
- }
- }
- }
- return code;
-}
-
-IV
-PerlIOMmap_unmap(pTHX_ PerlIO *f)
-{
- PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
- IV code = 0;
- if (m->len) {
- PerlIOBuf * const b = &m->base;
- if (b->buf) {
- /* The munmap address argument is tricky: depending on the
- * standard it is either "void *" or "caddr_t" (which is
- * usually "char *" (signed or unsigned). If we cast it
- * to "void *", those that have it caddr_t and an uptight
- * C++ compiler, will freak out. But casting it as char*
- * should work. Maybe. (Using Mmap_t figured out by
- * Configure doesn't always work, apparently.) */
- code = munmap((char*)m->mptr, m->len);
- b->buf = NULL;
- m->len = 0;
- m->mptr = NULL;
- if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
- code = -1;
- }
- b->ptr = b->end = b->buf;
- PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
- }
- return code;
-}
-
-STDCHAR *
-PerlIOMmap_get_base(pTHX_ PerlIO *f)
-{
- PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
- PerlIOBuf * const b = &m->base;
- if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
- /*
- * Already have a readbuffer in progress
- */
- return b->buf;
- }
- if (b->buf) {
- /*
- * We have a write buffer or flushed PerlIOBuf read buffer
- */
- m->bbuf = b->buf; /* save it in case we need it again */
- b->buf = NULL; /* Clear to trigger below */
- }
- if (!b->buf) {
- PerlIOMmap_map(aTHX_ f); /* Try and map it */
- if (!b->buf) {
- /*
- * Map did not work - recover PerlIOBuf buffer if we have one
- */
- b->buf = m->bbuf;
- }
- }
- b->ptr = b->end = b->buf;
- if (b->buf)
- return b->buf;
- return PerlIOBuf_get_base(aTHX_ f);
-}
-
-SSize_t
-PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
-{
- PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
- PerlIOBuf * const b = &m->base;
- if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
- PerlIO_flush(f);
- if (b->ptr && (b->ptr - count) >= b->buf
- && memEQ(b->ptr - count, vbuf, count)) {
- b->ptr -= count;
- PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
- return count;
- }
- if (m->len) {
- /*
- * Loose the unwritable mapped buffer
- */
- PerlIO_flush(f);
- /*
- * If flush took the "buffer" see if we have one from before
- */
- if (!b->buf && m->bbuf)
- b->buf = m->bbuf;
- if (!b->buf) {
- PerlIOBuf_get_base(aTHX_ f);
- m->bbuf = b->buf;
- }
- }
- return PerlIOBuf_unread(aTHX_ f, vbuf, count);
-}
-
-SSize_t
-PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
-{
- PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
- PerlIOBuf * const b = &m->base;
-
- if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
- /*
- * No, or wrong sort of, buffer
- */
- if (m->len) {
- if (PerlIOMmap_unmap(aTHX_ f) != 0)
- return 0;
- }
- /*
- * If unmap took the "buffer" see if we have one from before
- */
- if (!b->buf && m->bbuf)
- b->buf = m->bbuf;
- if (!b->buf) {
- PerlIOBuf_get_base(aTHX_ f);
- m->bbuf = b->buf;
- }
- }
- return PerlIOBuf_write(aTHX_ f, vbuf, count);
-}
-
-IV
-PerlIOMmap_flush(pTHX_ PerlIO *f)
-{
- PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
- PerlIOBuf * const b = &m->base;
- IV code = PerlIOBuf_flush(aTHX_ f);
- /*
- * Now we are "synced" at PerlIOBuf level
- */
- if (b->buf) {
- if (m->len) {
- /*
- * Unmap the buffer
- */
- if (PerlIOMmap_unmap(aTHX_ f) != 0)
- code = -1;
- }
- else {
- /*
- * We seem to have a PerlIOBuf buffer which was not mapped
- * remember it in case we need one later
- */
- m->bbuf = b->buf;
- }
- }
- return code;
-}
-
-IV
-PerlIOMmap_fill(pTHX_ PerlIO *f)
-{
- PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
- IV code = PerlIO_flush(f);
- if (code == 0 && !b->buf) {
- code = PerlIOMmap_map(aTHX_ f);
- }
- if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
- code = PerlIOBuf_fill(aTHX_ f);
- }
- return code;
-}
-
-IV
-PerlIOMmap_close(pTHX_ PerlIO *f)
-{
- PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
- PerlIOBuf * const b = &m->base;
- IV code = PerlIO_flush(f);
- if (m->bbuf) {
- b->buf = m->bbuf;
- m->bbuf = NULL;
- b->ptr = b->end = b->buf;
- }
- if (PerlIOBuf_close(aTHX_ f) != 0)
- code = -1;
- return code;
-}
-
PerlIO *
-PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
-{
- return PerlIOBase_dup(aTHX_ f, o, param, flags);
-}
-
-
-PERLIO_FUNCS_DECL(PerlIO_mmap) = {
- sizeof(PerlIO_funcs),
- "mmap",
- sizeof(PerlIOMmap),
- PERLIO_K_BUFFERED|PERLIO_K_RAW,
- PerlIOBuf_pushed,
- PerlIOBuf_popped,
- PerlIOBuf_open,
- PerlIOBase_binmode, /* binmode */
- NULL,
- PerlIOBase_fileno,
- PerlIOMmap_dup,
- PerlIOBuf_read,
- PerlIOMmap_unread,
- PerlIOMmap_write,
- PerlIOBuf_seek,
- PerlIOBuf_tell,
- PerlIOBuf_close,
- PerlIOMmap_flush,
- PerlIOMmap_fill,
- PerlIOBase_eof,
- PerlIOBase_error,
- PerlIOBase_clearerr,
- PerlIOBase_setlinebuf,
- PerlIOMmap_get_base,
- PerlIOBuf_bufsiz,
- PerlIOBuf_get_ptr,
- PerlIOBuf_get_cnt,
- PerlIOBuf_set_ptrcnt,
-};
-
-#endif /* HAS_MMAP */
-
-PerlIO *
Perl_PerlIO_stdin(pTHX)
{
dVAR;
@@ -5174,8 +4852,8 @@
char *
PerlIO_getname(PerlIO *f, char *buf)
{
+#ifdef VMS
dTHX;
-#ifdef VMS
char *name = NULL;
bool exported = FALSE;
FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
@@ -5191,7 +4869,7 @@
#else
PERL_UNUSED_ARG(f);
PERL_UNUSED_ARG(buf);
- Perl_croak(aTHX_ "Don't know how to get file name");
+ Perl_croak_nocontext("Don't know how to get file name");
return NULL;
#endif
}
@@ -5331,7 +5009,9 @@
PerlIO *
PerlIO_tmpfile(void)
{
+#ifndef WIN32
dTHX;
+#endif
PerlIO *f = NULL;
#ifdef WIN32
const int fd = win32_tmpfd();
@@ -5341,7 +5021,7 @@
# if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
int fd = -1;
char tempname[] = "/tmp/PerlIO_XXXXXX";
- const char * const tmpdir = PL_tainting ? NULL : PerlEnv_getenv("TMPDIR");
+ const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
SV * sv = NULL;
/*
* I have no idea how portable mkstemp() is ... NI-S
@@ -5421,9 +5101,9 @@
int
PerlIO_setpos(PerlIO *f, SV *pos)
{
- dTHX;
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);
@@ -5535,8 +5215,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/perlio.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/perlio.h
===================================================================
--- trunk/contrib/perl/perlio.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/perlio.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -64,11 +64,6 @@
*/
#include <stdio.h>
-#ifdef __BEOS__
-int fseeko(FILE *stream, off_t offset, int whence);
-off_t ftello(FILE *stream);
-#endif
-
#if defined(USE_64_BIT_STDIO) && defined(HAS_FTELLO) && !defined(USE_FTELL64)
#define ftell ftello
#endif
@@ -392,8 +387,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/perlio.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/perliol.h
===================================================================
--- trunk/contrib/perl/perliol.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/perliol.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -113,9 +113,6 @@
EXTPERLIO PerlIO_funcs PerlIO_byte;
EXTPERLIO PerlIO_funcs PerlIO_raw;
EXTPERLIO PerlIO_funcs PerlIO_pending;
-#ifdef HAS_MMAP
-EXTPERLIO PerlIO_funcs PerlIO_mmap;
-#endif
#ifdef WIN32
EXTPERLIO PerlIO_funcs PerlIO_win32;
#endif
@@ -223,17 +220,6 @@
PERL_EXPORT_C SSize_t PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count);
PERL_EXPORT_C SSize_t PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count);
-/* Mmap */
-PERL_EXPORT_C IV PerlIOMmap_close(pTHX_ PerlIO *f);
-PERL_EXPORT_C PerlIO * PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags);
-PERL_EXPORT_C IV PerlIOMmap_fill(pTHX_ PerlIO *f);
-PERL_EXPORT_C IV PerlIOMmap_flush(pTHX_ PerlIO *f);
-PERL_EXPORT_C STDCHAR * PerlIOMmap_get_base(pTHX_ PerlIO *f);
-PERL_EXPORT_C IV PerlIOMmap_map(pTHX_ PerlIO *f);
-PERL_EXPORT_C IV PerlIOMmap_unmap(pTHX_ PerlIO *f);
-PERL_EXPORT_C SSize_t PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count);
-PERL_EXPORT_C SSize_t PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count);
-
/* Pending */
PERL_EXPORT_C IV PerlIOPending_close(pTHX_ PerlIO *f);
PERL_EXPORT_C IV PerlIOPending_fill(pTHX_ PerlIO *f);
@@ -293,8 +279,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/perliol.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/perlsdio.h
===================================================================
--- trunk/contrib/perl/perlsdio.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/perlsdio.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -157,8 +157,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/perlsdio.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/perlsfio.h
===================================================================
--- trunk/contrib/perl/perlsfio.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/perlsfio.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -77,8 +77,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/perlsfio.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/perlvars.h
===================================================================
--- trunk/contrib/perl/perlvars.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/perlvars.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -10,6 +10,11 @@
/*
=head1 Global Variables
+
+These variables are global to an entire process. They are shared between
+all interpreters and all threads in a process.
+
+=cut
*/
/* Don't forget to re-run regen/embed.pl to propagate changes! */
@@ -24,110 +29,124 @@
* the appropriate export list for win32. */
/* global state */
-PERLVAR(Gcurinterp, PerlInterpreter *)
+#if defined(USE_ITHREADS)
+PERLVAR(G, op_mutex, perl_mutex) /* Mutex for op refcounting */
+#endif
+PERLVAR(G, curinterp, PerlInterpreter *)
/* currently running interpreter
* (initial parent interpreter under
* useithreads) */
#if defined(USE_ITHREADS)
-PERLVAR(Gthr_key, perl_key) /* key to retrieve per-thread struct */
+PERLVAR(G, thr_key, perl_key) /* key to retrieve per-thread struct */
#endif
-/* constants (these are not literals to facilitate pointer comparisons)
- * (PERLVARISC really does create variables, despite its looks) */
-PERLVARISC(GYes, "1")
-PERLVARISC(GNo, "")
-PERLVARISC(Ghexdigit, "0123456789abcdef0123456789ABCDEF")
-PERLVARISC(Gpatleave, "\\.^$@dDwWsSbB+*?|()-nrtfeaxc0123456789[{]}")
-
/* XXX does anyone even use this? */
-PERLVARI(Gdo_undump, bool, FALSE) /* -u or dump seen? */
+PERLVARI(G, do_undump, bool, FALSE) /* -u or dump seen? */
-#if defined(MYMALLOC) && defined(USE_ITHREADS)
-PERLVAR(Gmalloc_mutex, perl_mutex) /* Mutex for malloc */
+#ifndef PERL_USE_SAFE_PUTENV
+PERLVARI(G, use_safe_putenv, bool, TRUE)
#endif
-#if defined(USE_ITHREADS)
-PERLVAR(Gop_mutex, perl_mutex) /* Mutex for op refcounting */
+#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS)||defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
+PERLVARI(G, sig_handlers_initted, int, 0)
#endif
-
-#ifdef USE_ITHREADS
-PERLVAR(Gdollarzero_mutex, perl_mutex) /* Modifying $0 */
+#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
+PERLVARA(G, sig_ignoring, SIG_SIZE, int)
+ /* which signals we are ignoring */
#endif
+#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
+PERLVARA(G, sig_defaulting, SIG_SIZE, int)
+#endif
-
-/* This is constant on most architectures, a global on OS/2 */
-#ifdef OS2
-# define PERL___C
-#else
-# define PERL___C const
+/* XXX signals are process-wide anyway, so we
+ * ignore the implications of this for threading */
+#ifndef HAS_SIGACTION
+PERLVARI(G, sig_trapped, int, 0)
#endif
-PERLVARI(Gsh_path, PERL___C char *, SH_PATH) /* full path of shell */
-#undef PERL___C
#ifndef PERL_MICRO
/* If Perl has to ignore SIGPFE, this is its saved state.
* See perl.h macros PERL_FPU_INIT and PERL_FPU_{PRE,POST}_EXEC. */
-PERLVAR(Gsigfpe_saved, Sighandler_t)
+PERLVAR(G, sigfpe_saved, Sighandler_t)
+PERLVARI(G, csighandlerp, Sighandler_t, Perl_csighandler)
+ /* Pointer to C-level sighandler */
#endif
-/* Restricted hashes placeholder value.
- * The contents are never used, only the address. */
-PERLVAR(Gsv_placeholder, SV)
-
-#ifndef PERL_MICRO
-PERLVARI(Gcsighandlerp, Sighandler_t, Perl_csighandler) /* Pointer to C-level sighandler */
+/* This is constant on most architectures, a global on OS/2 */
+#ifdef OS2
+PERLVARI(G, sh_path, char *, SH_PATH) /* full path of shell */
#endif
-#ifndef PERL_USE_SAFE_PUTENV
-PERLVARI(Guse_safe_putenv, int, 1)
-#endif
+#ifdef USE_PERLIO
-#ifdef USE_PERLIO
-PERLVARI(Gperlio_fd_refcnt, int*, 0) /* Pointer to array of fd refcounts. */
-PERLVARI(Gperlio_fd_refcnt_size, int, 0) /* Size of the array */
-PERLVARI(Gperlio_debug_fd, int, 0) /* the fd to write perlio debug into, 0 means not set yet */
+# if defined(USE_ITHREADS)
+PERLVAR(G, perlio_mutex, perl_mutex) /* Mutex for perlio fd refcounts */
+# endif
+
+PERLVARI(G, perlio_fd_refcnt, int *, 0) /* Pointer to array of fd refcounts. */
+PERLVARI(G, perlio_fd_refcnt_size, int, 0) /* Size of the array */
+PERLVARI(G, perlio_debug_fd, int, 0) /* the fd to write perlio debug into, 0 means not set yet */
#endif
#ifdef HAS_MMAP
-PERLVARI(Gmmap_page_size, IV, 0)
+PERLVARI(G, mmap_page_size, IV, 0)
#endif
-#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS)||defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
-PERLVARI(Gsig_handlers_initted, int, 0)
+#if defined(USE_ITHREADS)
+PERLVAR(G, hints_mutex, perl_mutex) /* Mutex for refcounted he refcounting */
#endif
-#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
-PERLVARA(Gsig_ignoring, SIG_SIZE, int) /* which signals we are ignoring */
-#endif
-#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
-PERLVARA(Gsig_defaulting, SIG_SIZE, int)
-#endif
-/* XXX signals are process-wide anyway, so we
- * ignore the implications of this for threading */
-#ifndef HAS_SIGACTION
-PERLVARI(Gsig_trapped, int, 0)
+#ifdef DEBUGGING
+PERLVAR(G, watch_pvx, char *)
#endif
-#ifdef DEBUGGING
-PERLVAR(Gwatch_pvx, char*)
+/*
+=for apidoc AmU|Perl_check_t *|PL_check
+
+Array, indexed by opcode, of functions that will be called for the "check"
+phase of optree building during compilation of Perl code. For most (but
+not all) types of op, once the op has been initially built and populated
+with child ops it will be filtered through the check function referenced
+by the appropriate element of this array. The new op is passed in as the
+sole argument to the check function, and the check function returns the
+completed op. The check function may (as the name suggests) check the op
+for validity and signal errors. It may also initialise or modify parts of
+the ops, or perform more radical surgery such as adding or removing child
+ops, or even throw the op away and return a different op in its place.
+
+This array of function pointers is a convenient place to hook into the
+compilation process. An XS module can put its own custom check function
+in place of any of the standard ones, to influence the compilation of a
+particular type of op. However, a custom check function must never fully
+replace a standard check function (or even a custom check function from
+another module). A module modifying checking must instead B<wrap> the
+preexisting check function. A custom check function must be selective
+about when to apply its custom behaviour. In the usual case where
+it decides not to do anything special with an op, it must chain the
+preexisting op function. Check functions are thus linked in a chain,
+with the core's base checker at the end.
+
+For thread safety, modules should not write directly to this array.
+Instead, use the function L</wrap_op_checker>.
+
+=cut
+*/
+
+#if defined(USE_ITHREADS)
+PERLVAR(G, check_mutex, perl_mutex) /* Mutex for PL_check */
#endif
-
#ifdef PERL_GLOBAL_STRUCT
-PERLVAR(Gppaddr, Perl_ppaddr_t*) /* or opcode.h */
-PERLVAR(Gcheck, Perl_check_t *) /* or opcode.h */
-PERLVARA(Gfold_locale, 256, unsigned char) /* or perl.h */
-PERLVARA(Gcharclass, 256, U32)
+PERLVAR(G, ppaddr, Perl_ppaddr_t *) /* or opcode.h */
+PERLVAR(G, check, Perl_check_t *) /* or opcode.h */
+PERLVARA(G, fold_locale, 256, unsigned char) /* or perl.h */
#endif
#ifdef PERL_NEED_APPCTX
-PERLVAR(Gappctx, void*) /* the application context */
+PERLVAR(G, appctx, void*) /* the application context */
#endif
-PERLVAR(Gop_sequence, HV*) /* dump.c */
-PERLVARI(Gop_seq, UV, 0) /* dump.c */
-
#if defined(HAS_TIMES) && defined(PERL_NEED_TIMESBASE)
-PERLVAR(Gtimesbase, struct tms)
+PERLVAR(G, timesbase, struct tms)
#endif
/* allocate a unique index to every module that calls MY_CXT_INIT */
@@ -134,56 +153,15 @@
#ifdef PERL_IMPLICIT_CONTEXT
# ifdef USE_ITHREADS
-PERLVAR(Gmy_ctx_mutex, perl_mutex)
+PERLVAR(G, my_ctx_mutex, perl_mutex)
# endif
-PERLVARI(Gmy_cxt_index, int, 0)
+PERLVARI(G, my_cxt_index, int, 0)
#endif
-#if defined(USE_ITHREADS)
-PERLVAR(Ghints_mutex, perl_mutex) /* Mutex for refcounted he refcounting */
-#endif
-
-#if defined(USE_ITHREADS)
-PERLVAR(Gperlio_mutex, perl_mutex) /* Mutex for perlio fd refcounts */
-#endif
-
/* this is currently set without MUTEX protection, so keep it a type which
* can be set atomically (ie not a bit field) */
-PERLVARI(Gveto_cleanup, int, FALSE) /* exit without cleanup */
+PERLVARI(G, veto_cleanup, int, FALSE) /* exit without cleanup */
-/* dummy variables that hold pointers to both runops functions, thus forcing
- * them *both* to get linked in (useful for Peek.xs, debugging etc) */
-
-PERLVARI(Grunops_std, runops_proc_t, Perl_runops_standard)
-PERLVARI(Grunops_dbg, runops_proc_t, Perl_runops_debug)
-
-
-/* These are baked at compile time into any shared perl library.
- In future 5.10.x releases this will allow us in main() to sanity test the
- library we're linking against. */
-
-PERLVARI(Grevision, U8, PERL_REVISION)
-PERLVARI(Gversion, U8, PERL_VERSION)
-PERLVARI(Gsubversion, U8, PERL_SUBVERSION)
-
-#if defined(MULTIPLICITY)
-# define PERL_INTERPRETER_SIZE_UPTO_MEMBER(member) \
- STRUCT_OFFSET(struct interpreter, member) + \
- sizeof(((struct interpreter*)0)->member)
-
-/* These might be useful. */
-PERLVARI(Ginterp_size, U16, sizeof(struct interpreter))
-#if defined(PERL_GLOBAL_STRUCT)
-PERLVARI(Gglobal_struct_size, U16, sizeof(struct perl_vars))
-#endif
-
-/* This will be useful for subsequent releases, because this has to be the
- same in your libperl as in main(), else you have a mismatch and must abort.
-*/
-PERLVARI(Ginterp_size_5_10_0, U16,
- PERL_INTERPRETER_SIZE_UPTO_MEMBER(PERL_LAST_5_10_0_INTERP_MEMBER))
-#endif
-
/*
=for apidoc AmUx|Perl_keyword_plugin_t|PL_keyword_plugin
@@ -237,4 +215,22 @@
=cut
*/
-PERLVARI(Gkeyword_plugin, Perl_keyword_plugin_t, Perl_keyword_plugin_standard)
+PERLVARI(G, keyword_plugin, Perl_keyword_plugin_t, Perl_keyword_plugin_standard)
+
+PERLVAR(G, op_sequence, HV *) /* dump.c */
+PERLVARI(G, op_seq, UV, 0) /* dump.c */
+
+#ifdef USE_ITHREADS
+PERLVAR(G, dollarzero_mutex, perl_mutex) /* Modifying $0 */
+#endif
+
+/* Restricted hashes placeholder value.
+ * The contents are never used, only the address. */
+PERLVAR(G, sv_placeholder, SV)
+
+#if defined(MYMALLOC) && defined(USE_ITHREADS)
+PERLVAR(G, malloc_mutex, perl_mutex) /* Mutex for malloc */
+#endif
+
+PERLVARI(G, hash_seed_set, bool, FALSE) /* perl.c */
+PERLVARA(G, hash_seed, PERL_HASH_SEED_BYTES, unsigned char) /* perl.c and hv.h */
Property changes on: trunk/contrib/perl/perlvars.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/perly.c
===================================================================
--- trunk/contrib/perl/perly.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/perly.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -1,6 +1,7 @@
/* perly.c
*
- * Copyright (c) 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
+ * Copyright (c) 2004, 2005, 2006, 2007, 2008,
+ * 2009, 2010, 2011 by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
@@ -37,6 +38,9 @@
/* YYINITDEPTH -- initial size of the parser's stacks. */
#define YYINITDEPTH 200
+#ifdef YYDEBUG
+# undef YYDEBUG
+#endif
#ifdef DEBUGGING
# define YYDEBUG 1
#else
@@ -43,6 +47,10 @@
# define YYDEBUG 0
#endif
+#ifndef YY_NULL
+# define YY_NULL 0
+#endif
+
/* contains all the parser state tables; auto-generated from perly.y */
#include "perly.tab"
@@ -135,11 +143,6 @@
);
break;
#ifndef PERL_IN_MADLY_C
- case toketype_p_tkval:
- PerlIO_printf(Perl_debug_log, " %8.8s",
- ps->val.pval ? ps->val.pval : "(NULL)");
- break;
-
case toketype_i_tkval:
#endif
case toketype_ival:
@@ -203,96 +206,11 @@
YYDPRINTF ((Perl_debug_log, "clearing the parse stack\n"));
- /* Freeing ops on the stack, and the op_latefree / op_latefreed /
- * op_attached flags:
- *
- * When we pop tokens off the stack during error recovery, or when
- * we pop all the tokens off the stack after a die during a shift or
- * reduce (i.e. Perl_croak somewhere in yylex() or in one of the
- * newFOO() functions), then it's possible that some of these tokens are
- * of type opval, pointing to an OP. All these ops are orphans; each is
- * its own miniature subtree that has not yet been attached to a
- * larger tree. In this case, we should clearly free the op (making
- * sure, for each op we free that we have PL_comppad pointing to the
- * right place for freeing any SVs attached to the op in threaded
- * builds.
- *
- * However, there is a particular problem if we die in newFOO() called
- * by a reducing action; e.g.
- *
- * foo : bar baz boz
- * { $$ = newFOO($1,$2,$3) }
- *
- * where
- * OP *newFOO { ....; if (...) croak; .... }
- *
- * In this case, when we come to clean bar baz and boz off the stack,
- * we don't know whether newFOO() has already:
- * * freed them
- * * left them as is
- * * attached them to part of a larger tree
- * * attached them to PL_compcv
- * * attached them to PL_compcv then freed it (as in BEGIN {die } )
- *
- * To get round this problem, we set the flag op_latefree on every op
- * that gets pushed onto the parser stack. If op_free() sees this
- * flag, it clears the op and frees any children,, but *doesn't* free
- * the op itself; instead it sets the op_latefreed flag. This means
- * that we can safely call op_free() multiple times on each stack op.
- * So, when clearing the stack, we first, for each op that was being
- * reduced, call op_free with op_latefree=1. This ensures that all ops
- * hanging off these op are freed, but the reducing ops themselves are
- * just undefed. Then we set op_latefreed=0 on *all* ops on the stack
- * and free them. A little thought should convince you that this
- * two-part approach to the reducing ops should handle the first three
- * cases above safely.
- *
- * In the case of attaching to PL_compcv (currently just newATTRSUB
- * does this), then we set the op_attached flag on the op that has
- * been so attached, then avoid doing the final op_free during
- * cleanup, on the assumption that it will happen (or has already
- * happened) when PL_compcv is freed.
- *
- * Note this is fairly fragile mechanism. A more robust approach
- * would be to use two of these flag bits as 2-bit reference count
- * field for each op, indicating whether it is pointed to from:
- * * a parent op
- * * the parser stack
- * * a CV
- * but this would involve reworking all code (core and external) that
- * manipulate op trees.
- *
- * XXX DAPM 17/1/07 I've decided its too fragile for now, and so have
- * disabled it */
-
-#define DISABLE_STACK_FREE
-
-
-#ifdef DISABLE_STACK_FREE
for (i=0; i< parser->yylen; i++) {
SvREFCNT_dec(ps[-i].compcv);
}
ps -= parser->yylen;
-#else
- /* clear any reducing ops (1st pass) */
- for (i=0; i< parser->yylen; i++) {
- LEAVE_SCOPE(ps[-i].savestack_ix);
- if (yy_type_tab[yystos[ps[-i].state]] == toketype_opval
- && ps[-i].val.opval) {
- if ( ! (ps[-i].val.opval->op_attached
- && !ps[-i].val.opval->op_latefreed))
- {
- if (ps[-i].compcv != PL_compcv) {
- PL_compcv = ps[-i].compcv;
- PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1);
- }
- op_free(ps[-i].val.opval);
- }
- }
- }
-#endif
-
/* now free whole the stack, including the just-reduced ops */
while (ps > parser->stack) {
@@ -305,11 +223,7 @@
PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1);
}
YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
-#ifndef DISABLE_STACK_FREE
- ps->val.opval->op_latefree = 0;
- if (!(ps->val.opval->op_attached && !ps->val.opval->op_latefreed))
-#endif
- op_free(ps->val.opval);
+ op_free(ps->val.opval);
}
SvREFCNT_dec(ps->compcv);
ps--;
@@ -331,15 +245,15 @@
#endif
{
dVAR;
- register int yystate;
- register int yyn;
+ int yystate;
+ int yyn;
int yyresult;
/* Lookahead token as an internal (translated) token number. */
int yytoken = 0;
- register yy_parser *parser; /* the parser object */
- register yy_stack_frame *ps; /* current parser stack frame */
+ yy_parser *parser; /* the parser object */
+ yy_stack_frame *ps; /* current parser stack frame */
#define YYPOPSTACK parser->ps = --ps
#define YYPUSHSTACK parser->ps = ++ps
@@ -387,13 +301,6 @@
YYDPRINTF ((Perl_debug_log, "Entering state %d\n", yystate));
-#ifndef DISABLE_STACK_FREE
- if (yy_type_tab[yystos[yystate]] == toketype_opval && ps->val.opval) {
- ps->val.opval->op_latefree = 1;
- ps->val.opval->op_latefreed = 0;
- }
-#endif
-
parser->yylen = 0;
{
@@ -550,20 +457,9 @@
}
- /* any just-reduced ops with the op_latefreed flag cleared need to be
- * freed; the rest need the flag resetting */
{
int i;
for (i=0; i< parser->yylen; i++) {
-#ifndef DISABLE_STACK_FREE
- if (yy_type_tab[yystos[ps[-i].state]] == toketype_opval
- && ps[-i].val.opval)
- {
- ps[-i].val.opval->op_latefree = 0;
- if (ps[-i].val.opval->op_latefreed)
- op_free(ps[-i].val.opval);
- }
-#endif
SvREFCNT_dec(ps[-i].compcv);
}
}
@@ -624,7 +520,6 @@
PL_compcv = ps->compcv;
PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1);
}
- ps->val.opval->op_latefree = 0;
op_free(ps->val.opval);
}
SvREFCNT_dec(ps->compcv);
@@ -634,8 +529,6 @@
}
YYDSYMPRINTF ("Error: discarding", yytoken, &parser->yylval);
- if (yy_type_tab[yytoken] == toketype_opval)
- op_free(parser->yylval.opval);
parser->yychar = YYEMPTY;
}
@@ -674,7 +567,6 @@
PL_compcv = ps->compcv;
PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1);
}
- ps->val.opval->op_latefree = 0;
op_free(ps->val.opval);
}
SvREFCNT_dec(ps->compcv);
@@ -728,8 +620,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/perly.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/perly.h
===================================================================
--- trunk/contrib/perl/perly.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/perly.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -5,27 +5,24 @@
*/
#ifdef PERL_CORE
-/* A Bison parser, made by GNU Bison 2.3. */
+/* A Bison parser, made by GNU Bison 2.6.1. */
-/* Skeleton interface for Bison's Yacc-like parsers in C
-
- Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002, 2003, 2004, 2005, 2006
- Free Software Foundation, Inc.
-
- This program is free software; you can redistribute it and/or modify
+/* Bison interface for Yacc-like parsers in C
+
+ Copyright (C) 1984, 1989-1990, 2000-2012 Free Software Foundation, Inc.
+
+ This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2, or (at your option)
- any later version.
-
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
-
+
You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 51 Franklin Street, Fifth Floor,
- Boston, MA 02110-1301, USA. */
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
/* As a special exception, you may create a larger work that contains
part or all of the Bison parser skeleton and distribute that work
@@ -36,10 +33,18 @@
special exception, which will cause the skeleton and the resulting
Bison output files to be licensed under the GNU General Public
License without this special exception.
-
+
This special exception was added by the Free Software Foundation in
version 2.2 of Bison. */
+/* Enabling traces. */
+#ifndef YYDEBUG
+# define YYDEBUG 0
+#endif
+#if YYDEBUG
+extern int yydebug;
+#endif
+
/* Tokens. */
#ifndef YYTOKENTYPE
# define YYTOKENTYPE
@@ -59,73 +64,76 @@
PMFUNC = 268,
PRIVATEREF = 269,
QWLIST = 270,
- FUNC0SUB = 271,
- UNIOPSUB = 272,
- LSTOPSUB = 273,
- PLUGEXPR = 274,
- PLUGSTMT = 275,
- LABEL = 276,
- FORMAT = 277,
- SUB = 278,
- ANONSUB = 279,
- PACKAGE = 280,
- USE = 281,
- WHILE = 282,
- UNTIL = 283,
- IF = 284,
- UNLESS = 285,
- ELSE = 286,
- ELSIF = 287,
- CONTINUE = 288,
- FOR = 289,
- GIVEN = 290,
- WHEN = 291,
- DEFAULT = 292,
- LOOPEX = 293,
- DOTDOT = 294,
- YADAYADA = 295,
- FUNC0 = 296,
- FUNC1 = 297,
- FUNC = 298,
- UNIOP = 299,
- LSTOP = 300,
- RELOP = 301,
- EQOP = 302,
- MULOP = 303,
- ADDOP = 304,
- DOLSHARP = 305,
- DO = 306,
- HASHBRACK = 307,
- NOAMP = 308,
- LOCAL = 309,
- MY = 310,
- MYSUB = 311,
+ FUNC0OP = 271,
+ FUNC0SUB = 272,
+ UNIOPSUB = 273,
+ LSTOPSUB = 274,
+ PLUGEXPR = 275,
+ PLUGSTMT = 276,
+ LABEL = 277,
+ FORMAT = 278,
+ SUB = 279,
+ ANONSUB = 280,
+ PACKAGE = 281,
+ USE = 282,
+ WHILE = 283,
+ UNTIL = 284,
+ IF = 285,
+ UNLESS = 286,
+ ELSE = 287,
+ ELSIF = 288,
+ CONTINUE = 289,
+ FOR = 290,
+ GIVEN = 291,
+ WHEN = 292,
+ DEFAULT = 293,
+ LOOPEX = 294,
+ DOTDOT = 295,
+ YADAYADA = 296,
+ FUNC0 = 297,
+ FUNC1 = 298,
+ FUNC = 299,
+ UNIOP = 300,
+ LSTOP = 301,
+ RELOP = 302,
+ EQOP = 303,
+ MULOP = 304,
+ ADDOP = 305,
+ DOLSHARP = 306,
+ DO = 307,
+ HASHBRACK = 308,
+ NOAMP = 309,
+ LOCAL = 310,
+ MY = 311,
REQUIRE = 312,
COLONATTR = 313,
- PREC_LOW = 314,
- DOROP = 315,
- OROP = 316,
- ANDOP = 317,
- NOTOP = 318,
- ASSIGNOP = 319,
- DORDOR = 320,
- OROR = 321,
- ANDAND = 322,
- BITOROP = 323,
- BITANDOP = 324,
- SHIFTOP = 325,
- MATCHOP = 326,
- REFGEN = 327,
- UMINUS = 328,
- POWOP = 329,
- POSTDEC = 330,
- POSTINC = 331,
- PREDEC = 332,
- PREINC = 333,
- ARROW = 334,
- PEG = 335
+ FORMLBRACK = 314,
+ FORMRBRACK = 315,
+ PREC_LOW = 316,
+ DOROP = 317,
+ OROP = 318,
+ ANDOP = 319,
+ NOTOP = 320,
+ ASSIGNOP = 321,
+ DORDOR = 322,
+ OROR = 323,
+ ANDAND = 324,
+ BITOROP = 325,
+ BITANDOP = 326,
+ SHIFTOP = 327,
+ MATCHOP = 328,
+ REFGEN = 329,
+ UMINUS = 330,
+ POWOP = 331,
+ POSTDEC = 332,
+ POSTINC = 333,
+ PREDEC = 334,
+ PREINC = 335,
+ ARROW = 336,
+ PEG = 337
};
#endif
+
/* Tokens. */
#define GRAMPROG 258
#define GRAMEXPR 259
@@ -140,79 +148,103 @@
#define PMFUNC 268
#define PRIVATEREF 269
#define QWLIST 270
-#define FUNC0SUB 271
-#define UNIOPSUB 272
-#define LSTOPSUB 273
-#define PLUGEXPR 274
-#define PLUGSTMT 275
-#define LABEL 276
-#define FORMAT 277
-#define SUB 278
-#define ANONSUB 279
-#define PACKAGE 280
-#define USE 281
-#define WHILE 282
-#define UNTIL 283
-#define IF 284
-#define UNLESS 285
-#define ELSE 286
-#define ELSIF 287
-#define CONTINUE 288
-#define FOR 289
-#define GIVEN 290
-#define WHEN 291
-#define DEFAULT 292
-#define LOOPEX 293
-#define DOTDOT 294
-#define YADAYADA 295
-#define FUNC0 296
-#define FUNC1 297
-#define FUNC 298
-#define UNIOP 299
-#define LSTOP 300
-#define RELOP 301
-#define EQOP 302
-#define MULOP 303
-#define ADDOP 304
-#define DOLSHARP 305
-#define DO 306
-#define HASHBRACK 307
-#define NOAMP 308
-#define LOCAL 309
-#define MY 310
-#define MYSUB 311
+#define FUNC0OP 271
+#define FUNC0SUB 272
+#define UNIOPSUB 273
+#define LSTOPSUB 274
+#define PLUGEXPR 275
+#define PLUGSTMT 276
+#define LABEL 277
+#define FORMAT 278
+#define SUB 279
+#define ANONSUB 280
+#define PACKAGE 281
+#define USE 282
+#define WHILE 283
+#define UNTIL 284
+#define IF 285
+#define UNLESS 286
+#define ELSE 287
+#define ELSIF 288
+#define CONTINUE 289
+#define FOR 290
+#define GIVEN 291
+#define WHEN 292
+#define DEFAULT 293
+#define LOOPEX 294
+#define DOTDOT 295
+#define YADAYADA 296
+#define FUNC0 297
+#define FUNC1 298
+#define FUNC 299
+#define UNIOP 300
+#define LSTOP 301
+#define RELOP 302
+#define EQOP 303
+#define MULOP 304
+#define ADDOP 305
+#define DOLSHARP 306
+#define DO 307
+#define HASHBRACK 308
+#define NOAMP 309
+#define LOCAL 310
+#define MY 311
#define REQUIRE 312
#define COLONATTR 313
-#define PREC_LOW 314
-#define DOROP 315
-#define OROP 316
-#define ANDOP 317
-#define NOTOP 318
-#define ASSIGNOP 319
-#define DORDOR 320
-#define OROR 321
-#define ANDAND 322
-#define BITOROP 323
-#define BITANDOP 324
-#define SHIFTOP 325
-#define MATCHOP 326
-#define REFGEN 327
-#define UMINUS 328
-#define POWOP 329
-#define POSTDEC 330
-#define POSTINC 331
-#define PREDEC 332
-#define PREINC 333
-#define ARROW 334
-#define PEG 335
+#define FORMLBRACK 314
+#define FORMRBRACK 315
+#define PREC_LOW 316
+#define DOROP 317
+#define OROP 318
+#define ANDOP 319
+#define NOTOP 320
+#define ASSIGNOP 321
+#define DORDOR 322
+#define OROR 323
+#define ANDAND 324
+#define BITOROP 325
+#define BITANDOP 326
+#define SHIFTOP 327
+#define MATCHOP 328
+#define REFGEN 329
+#define UMINUS 330
+#define POWOP 331
+#define POSTDEC 332
+#define POSTINC 333
+#define PREDEC 334
+#define PREINC 335
+#define ARROW 336
+#define PEG 337
-
-
+#ifdef PERL_IN_TOKE_C
+static bool
+S_is_opval_token(int type) {
+ switch (type) {
+ case FUNC0OP:
+ case FUNC0SUB:
+ case FUNCMETH:
+ case LSTOPSUB:
+ case METHOD:
+ case PLUGEXPR:
+ case PLUGSTMT:
+ case PMFUNC:
+ case PRIVATEREF:
+ case QWLIST:
+ case THING:
+ case UNIOPSUB:
+ case WORD:
+ return 1;
+ }
+ return 0;
+}
+#endif /* PERL_IN_TOKE_C */
#endif /* PERL_CORE */
#if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED
typedef union YYSTYPE
{
+/* Line 2049 of yacc.c */
+
I32 ival; /* __DEFAULT__ (marker for regen_perly.pl;
must always be 1st union member) */
char *pval;
@@ -228,18 +260,32 @@
#ifdef PERL_MAD
TOKEN* tkval;
#endif
-}
-/* Line 1489 of yacc.c. */
- YYSTYPE;
+
+
+/* Line 2049 of yacc.c */
+} YYSTYPE;
+# define YYSTYPE_IS_TRIVIAL 1
# define yystype YYSTYPE /* obsolescent; will be withdrawn */
# define YYSTYPE_IS_DECLARED 1
-# define YYSTYPE_IS_TRIVIAL 1
#endif
+#ifdef YYPARSE_PARAM
+#if defined __STDC__ || defined __cplusplus
+int yyparse (void *YYPARSE_PARAM);
+#else
+int yyparse ();
+#endif
+#else /* ! YYPARSE_PARAM */
+#if defined __STDC__ || defined __cplusplus
+int yyparse (void);
+#else
+int yyparse ();
+#endif
+#endif /* ! YYPARSE_PARAM */
/* Generated from:
- * bd41fc813e5d2d23ff7edef2ab1ef88bbb054176476b7d989db7522dce1c9328 perly.y
- * dc72db91baa0a3c17a6c95718e5ad70e9ac7b75919df1317df7fe6c3f1649239 regen_perly.pl
+ * 28c2c7738eefc00762e227af0363c729186c992e9127e0c935684cccbf3a3b4f perly.y
+ * 5c9d2a0262457fe9b70073fc8ad6c188f812f38ad57712b7e2f53daa01b297cc regen_perly.pl
* ex: set ro: */
Property changes on: trunk/contrib/perl/perly.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/pp.c
===================================================================
--- trunk/contrib/perl/pp.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/pp.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -29,6 +29,7 @@
#include "keywords.h"
#include "reentr.h"
+#include "regcharclass.h"
/* XXX I can't imagine anyone who doesn't have this actually _needs_
it, since pid_t is an integral type.
@@ -71,14 +72,19 @@
if (PL_op->op_flags & OPf_REF) {
PUSHs(TARG);
RETURN;
- } else if (LVRET) {
+ } else if (PL_op->op_private & OPpMAYBE_LVSUB) {
+ const I32 flags = is_lvalue_sub();
+ if (flags && !(flags & OPpENTERSUB_INARGS)) {
if (GIMME == G_SCALAR)
+ /* diag_listed_as: Can't return %s to lvalue scalar context */
Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
PUSHs(TARG);
RETURN;
+ }
}
gimme = GIMME_V;
if (gimme == G_ARRAY) {
+ /* XXX see also S_pushav in pp_hot.c */
const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
EXTEND(SP, maxarg);
if (SvMAGICAL(TARG)) {
@@ -114,15 +120,24 @@
SAVECLEARSV(PAD_SVl(PL_op->op_targ));
if (PL_op->op_flags & OPf_REF)
RETURN;
- else if (LVRET) {
+ else if (PL_op->op_private & OPpMAYBE_LVSUB) {
+ const I32 flags = is_lvalue_sub();
+ if (flags && !(flags & OPpENTERSUB_INARGS)) {
if (GIMME == G_SCALAR)
+ /* diag_listed_as: Can't return %s to lvalue scalar context */
Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
RETURN;
+ }
}
gimme = GIMME_V;
if (gimme == G_ARRAY) {
RETURNOP(Perl_do_kv(aTHX));
}
+ else if ((PL_op->op_private & OPpTRUEBOOL
+ || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
+ && block_gimme() == G_VOID ))
+ && (!SvRMAGICAL(TARG) || !mg_find(TARG, PERL_MAGIC_tied)))
+ SETs(HvUSEDKEYS(TARG) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
else if (gimme == G_SCALAR) {
SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
SETs(sv);
@@ -130,53 +145,102 @@
RETURN;
}
+PP(pp_padcv)
+{
+ dVAR; dSP; dTARGET;
+ assert(SvTYPE(TARG) == SVt_PVCV);
+ XPUSHs(TARG);
+ RETURN;
+}
+
+PP(pp_introcv)
+{
+ dVAR; dTARGET;
+ SvPADSTALE_off(TARG);
+ return NORMAL;
+}
+
+PP(pp_clonecv)
+{
+ dVAR; dTARGET;
+ MAGIC * const mg =
+ mg_find(PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG],
+ PERL_MAGIC_proto);
+ assert(SvTYPE(TARG) == SVt_PVCV);
+ assert(mg);
+ assert(mg->mg_obj);
+ if (CvISXSUB(mg->mg_obj)) { /* constant */
+ /* XXX Should we clone it here? */
+ /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV
+ to introcv and remove the SvPADSTALE_off. */
+ SAVEPADSVANDMORTALIZE(ARGTARG);
+ PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(mg->mg_obj);
+ }
+ else {
+ if (CvROOT(mg->mg_obj)) {
+ assert(CvCLONE(mg->mg_obj));
+ assert(!CvCLONED(mg->mg_obj));
+ }
+ cv_clone_into((CV *)mg->mg_obj,(CV *)TARG);
+ SAVECLEARSV(PAD_SVl(ARGTARG));
+ }
+ return NORMAL;
+}
+
/* Translations. */
static const char S_no_symref_sv[] =
"Can't use string (\"%" SVf32 "\"%s) as %s ref while \"strict refs\" in use";
-PP(pp_rv2gv)
+/* In some cases this function inspects PL_op. If this function is called
+ for new op types, more bool parameters may need to be added in place of
+ the checks.
+
+ When noinit is true, the absence of a gv will cause a retval of undef.
+ This is unrelated to the cv-to-gv assignment case.
+*/
+
+static SV *
+S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
+ const bool noinit)
{
- dVAR; dSP; dTOPss;
-
+ dVAR;
if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
if (SvROK(sv)) {
- wasref:
if (SvAMAGIC(sv)) {
sv = amagic_deref_call(sv, to_gv_amg);
- SPAGAIN;
}
+ wasref:
sv = SvRV(sv);
if (SvTYPE(sv) == SVt_PVIO) {
GV * const gv = MUTABLE_GV(sv_newmortal());
- gv_init(gv, 0, "", 0, 0);
+ gv_init(gv, 0, "__ANONIO__", 10, 0);
GvIOp(gv) = MUTABLE_IO(sv);
SvREFCNT_inc_void_NN(sv);
sv = MUTABLE_SV(gv);
}
else if (!isGV_with_GP(sv))
- DIE(aTHX_ "Not a GLOB reference");
+ return (SV *)Perl_die(aTHX_ "Not a GLOB reference");
}
else {
if (!isGV_with_GP(sv)) {
- if (!SvOK(sv) && sv != &PL_sv_undef) {
+ if (!SvOK(sv)) {
/* If this is a 'my' scalar and flag is set then vivify
* NI-S 1999/05/07
*/
- if (SvREADONLY(sv))
- Perl_croak_no_modify(aTHX);
- if (PL_op->op_private & OPpDEREF) {
+ if (vivify_sv && sv != &PL_sv_undef) {
GV *gv;
+ if (SvREADONLY(sv))
+ Perl_croak_no_modify();
if (cUNOP->op_targ) {
- STRLEN len;
SV * const namesv = PAD_SV(cUNOP->op_targ);
- const char * const name = SvPV(namesv, len);
gv = MUTABLE_GV(newSV(0));
- gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
+ gv_init_sv(gv, CopSTASH(PL_curcop), namesv, 0);
}
else {
const char * const name = CopSTASHPV(PL_curcop);
- gv = newGVgen(name);
+ gv = newGVgen_flags(name,
+ HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 );
}
prepare_SV_for_RV(sv);
SvRV_set(sv, MUTABLE_SV(gv));
@@ -184,47 +248,60 @@
SvSETMAGIC(sv);
goto wasref;
}
- if (PL_op->op_flags & OPf_REF ||
- PL_op->op_private & HINT_STRICT_REFS)
- DIE(aTHX_ PL_no_usym, "a symbol");
+ if (PL_op->op_flags & OPf_REF || strict)
+ return (SV *)Perl_die(aTHX_ PL_no_usym, "a symbol");
if (ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
- RETSETUNDEF;
+ return &PL_sv_undef;
}
- if ((PL_op->op_flags & OPf_SPECIAL) &&
- !(PL_op->op_flags & OPf_MOD))
+ if (noinit)
{
- SV * const temp = MUTABLE_SV(gv_fetchsv(sv, 0, SVt_PVGV));
- if (!temp
- && (!is_gv_magical_sv(sv,0)
- || !(sv = MUTABLE_SV(gv_fetchsv(sv, GV_ADD,
- SVt_PVGV))))) {
- RETSETUNDEF;
- }
- sv = temp;
+ if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
+ sv, GV_ADDMG, SVt_PVGV
+ ))))
+ return &PL_sv_undef;
}
else {
- if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(aTHX_ S_no_symref_sv, sv, (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""), "a symbol");
+ if (strict)
+ return
+ (SV *)Perl_die(aTHX_
+ S_no_symref_sv,
+ sv,
+ (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
+ "a symbol"
+ );
if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
== OPpDONT_INIT_GV) {
/* We are the target of a coderef assignment. Return
the scalar unchanged, and let pp_sasssign deal with
things. */
- RETURN;
+ return sv;
}
- sv = MUTABLE_SV(gv_fetchsv(sv, GV_ADD, SVt_PVGV));
+ sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
}
/* FAKE globs in the symbol table cause weird bugs (#77810) */
- if (sv) SvFAKE_off(sv);
+ SvFAKE_off(sv);
}
}
- if (sv && SvFAKE(sv)) {
+ if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
SV *newsv = sv_newmortal();
sv_setsv_flags(newsv, sv, 0);
SvFAKE_off(newsv);
sv = newsv;
}
+ return sv;
+}
+
+PP(pp_rv2gv)
+{
+ dVAR; dSP; dTOPss;
+
+ sv = S_rv2gv(aTHX_
+ sv, PL_op->op_private & OPpDEREF,
+ PL_op->op_private & HINT_STRICT_REFS,
+ ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
+ || PL_op->op_type == OP_READLINE
+ );
if (PL_op->op_private & OPpLVAL_INTRO)
save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
SETs(sv);
@@ -243,14 +320,14 @@
if (PL_op->op_private & HINT_STRICT_REFS) {
if (SvOK(sv))
- Perl_die(aTHX_ S_no_symref_sv, sv, (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""), what);
+ Perl_die(aTHX_ S_no_symref_sv, sv,
+ (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
else
Perl_die(aTHX_ PL_no_usym, what);
}
if (!SvOK(sv)) {
if (
- PL_op->op_flags & OPf_REF &&
- PL_op->op_next->op_type != OP_BOOLKEYS
+ PL_op->op_flags & OPf_REF
)
Perl_die(aTHX_ PL_no_usym, what);
if (ckWARN(WARN_UNINITIALIZED))
@@ -265,10 +342,7 @@
if ((PL_op->op_flags & OPf_SPECIAL) &&
!(PL_op->op_flags & OPf_MOD))
{
- gv = gv_fetchsv(sv, 0, type);
- if (!gv
- && (!is_gv_magical_sv(sv,0)
- || !(gv = gv_fetchsv(sv, GV_ADD, type))))
+ if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
{
**spp = &PL_sv_undef;
return NULL;
@@ -275,7 +349,7 @@
}
}
else {
- gv = gv_fetchsv(sv, GV_ADD, type);
+ gv = gv_fetchsv_nomg(sv, GV_ADD, type);
}
return gv;
}
@@ -285,12 +359,10 @@
dVAR; dSP; dTOPss;
GV *gv = NULL;
- if (!(PL_op->op_private & OPpDEREFed))
- SvGETMAGIC(sv);
+ SvGETMAGIC(sv);
if (SvROK(sv)) {
if (SvAMAGIC(sv)) {
sv = amagic_deref_call(sv, to_sv_amg);
- SPAGAIN;
}
sv = SvRV(sv);
@@ -324,7 +396,7 @@
Perl_croak(aTHX_ "%s", PL_no_localize_ref);
}
else if (PL_op->op_private & OPpDEREF)
- vivify_ref(sv, PL_op->op_private & OPpDEREF);
+ sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
}
SETs(sv);
RETURN;
@@ -343,9 +415,7 @@
}
SETs(*sv);
} else {
- SETs(sv_2mortal(newSViv(
- AvFILL(MUTABLE_AV(av)) + CopARYBASE_get(PL_curcop)
- )));
+ SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
}
RETURN;
}
@@ -355,7 +425,7 @@
dVAR; dSP; dPOPss;
if (PL_op->op_flags & OPf_MOD || LVRET) {
- SV * const ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
+ SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
LvTYPE(ret) = '.';
LvTARG(ret) = SvREFCNT_inc_simple(sv);
@@ -370,7 +440,7 @@
I32 i = mg->mg_len;
if (DO_UTF8(sv))
sv_pos_b2u(sv, &i);
- PUSHi(i + CopARYBASE_get(PL_curcop));
+ PUSHi(i);
RETURN;
}
}
@@ -384,8 +454,9 @@
GV *gv;
HV *stash_unused;
const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
- ? 0
- : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
+ ? GV_ADDMG
+ : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
+ == OPpMAY_RETURN_CONSTANT)
? GV_ADD|GV_NOEXPAND
: GV_ADD;
/* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
@@ -392,16 +463,7 @@
/* (But not in defined().) */
CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
- if (cv) {
- if (CvCLONE(cv))
- cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
- if ((PL_op->op_private & OPpLVAL_INTRO)) {
- if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
- cv = GvCV(gv);
- if (!CvLVALUE(cv))
- DIE(aTHX_ "Can't modify non-lvalue subroutine call");
- }
- }
+ if (cv) NOOP;
else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
cv = MUTABLE_CV(gv);
}
@@ -419,93 +481,29 @@
GV *gv;
SV *ret = &PL_sv_undef;
+ if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
const char * s = SvPVX_const(TOPs);
if (strnEQ(s, "CORE::", 6)) {
const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
- if (code < 0) { /* Overridable. */
-#define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
- int i = 0, n = 0, seen_question = 0, defgv = 0;
- I32 oa;
- char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
-
- if (code == -KEY_chop || code == -KEY_chomp
- || code == -KEY_exec || code == -KEY_system)
- goto set;
- if (code == -KEY_mkdir) {
- ret = newSVpvs_flags("_;$", SVs_TEMP);
- goto set;
- }
- if (code == -KEY_keys || code == -KEY_values || code == -KEY_each) {
- ret = newSVpvs_flags("+", SVs_TEMP);
- goto set;
- }
- if (code == -KEY_push || code == -KEY_unshift) {
- ret = newSVpvs_flags("+@", SVs_TEMP);
- goto set;
- }
- if (code == -KEY_pop || code == -KEY_shift) {
- ret = newSVpvs_flags(";+", SVs_TEMP);
- goto set;
- }
- if (code == -KEY_splice) {
- ret = newSVpvs_flags("+;$$@", SVs_TEMP);
- goto set;
- }
- if (code == -KEY_tied || code == -KEY_untie) {
- ret = newSVpvs_flags("\\[$@%*]", SVs_TEMP);
- goto set;
- }
- if (code == -KEY_tie) {
- ret = newSVpvs_flags("\\[$@%*]$@", SVs_TEMP);
- goto set;
- }
- if (code == -KEY_readpipe) {
- s = "CORE::backtick";
- }
- while (i < MAXO) { /* The slow way. */
- if (strEQ(s + 6, PL_op_name[i])
- || strEQ(s + 6, PL_op_desc[i]))
- {
- goto found;
- }
- i++;
- }
- goto nonesuch; /* Should not happen... */
- found:
- defgv = PL_opargs[i] & OA_DEFGV;
- oa = PL_opargs[i] >> OASHIFT;
- while (oa) {
- if (oa & OA_OPTIONAL && !seen_question && !defgv) {
- seen_question = 1;
- str[n++] = ';';
- }
- if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
- && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
- /* But globs are already references (kinda) */
- && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
- ) {
- str[n++] = '\\';
- }
- str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
- oa = oa >> 4;
- }
- if (defgv && str[n - 1] == '$')
- str[n - 1] = '_';
- str[n++] = '\0';
- ret = newSVpvn_flags(str, n - 1, SVs_TEMP);
+ if (!code || code == -KEY_CORE)
+ DIE(aTHX_ "Can't find an opnumber for \"%"SVf"\"",
+ SVfARG(newSVpvn_flags(
+ s+6, SvCUR(TOPs)-6,
+ (SvFLAGS(TOPs) & SVf_UTF8)|SVs_TEMP
+ )));
+ {
+ SV * const sv = core_prototype(NULL, s + 6, code, NULL);
+ if (sv) ret = sv;
}
- else if (code) /* Non-Overridable */
- goto set;
- else { /* None such */
- nonesuch:
- DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
- }
+ goto set;
}
}
cv = sv_2cv(TOPs, &stash, &gv, 0);
if (cv && SvPOK(cv))
- ret = newSVpvn_flags(SvPVX_const(cv), SvCUR(cv), SVs_TEMP);
+ ret = newSVpvn_flags(
+ CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
+ );
set:
SETs(ret);
RETURN;
@@ -585,7 +583,6 @@
PP(pp_ref)
{
dVAR; dSP; dTARGET;
- const char *pv;
SV * const sv = POPs;
if (sv)
@@ -594,8 +591,8 @@
if (!sv || !SvROK(sv))
RETPUSHNO;
- pv = sv_reftype(SvRV(sv),TRUE);
- PUSHp(pv, strlen(pv));
+ (void)sv_ref(TARG,SvRV(sv),TRUE);
+ PUSHTARG;
RETURN;
}
@@ -605,6 +602,7 @@
HV *stash;
if (MAXARG == 1)
+ curstash:
stash = CopSTASH(PL_curcop);
else {
SV * const ssv = POPs;
@@ -611,13 +609,14 @@
STRLEN len;
const char *ptr;
- if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
+ if (!ssv) goto curstash;
+ if (!SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
Perl_croak(aTHX_ "Attempt to bless into a reference");
ptr = SvPV_const(ssv,len);
if (len == 0)
Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
"Explicit blessing to '' (assuming package main)");
- stash = gv_stashpvn(ptr, len, GV_ADD);
+ stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
}
(void)sv_bless(TOPs, stash);
@@ -629,7 +628,8 @@
dVAR; dSP;
SV *sv = POPs;
- const char * const elem = SvPV_nolen_const(sv);
+ STRLEN len;
+ const char * const elem = SvPV_const(sv, len);
GV * const gv = MUTABLE_GV(POPs);
SV * tmpRef = NULL;
@@ -639,41 +639,46 @@
const char * const second_letter = elem + 1;
switch (*elem) {
case 'A':
- if (strEQ(second_letter, "RRAY"))
+ if (len == 5 && strEQ(second_letter, "RRAY"))
+ {
tmpRef = MUTABLE_SV(GvAV(gv));
+ if (tmpRef && !AvREAL((const AV *)tmpRef)
+ && AvREIFY((const AV *)tmpRef))
+ av_reify(MUTABLE_AV(tmpRef));
+ }
break;
case 'C':
- if (strEQ(second_letter, "ODE"))
+ if (len == 4 && strEQ(second_letter, "ODE"))
tmpRef = MUTABLE_SV(GvCVu(gv));
break;
case 'F':
- if (strEQ(second_letter, "ILEHANDLE")) {
+ if (len == 10 && strEQ(second_letter, "ILEHANDLE")) {
/* finally deprecated in 5.8.0 */
deprecate("*glob{FILEHANDLE}");
tmpRef = MUTABLE_SV(GvIOp(gv));
}
else
- if (strEQ(second_letter, "ORMAT"))
+ if (len == 6 && strEQ(second_letter, "ORMAT"))
tmpRef = MUTABLE_SV(GvFORM(gv));
break;
case 'G':
- if (strEQ(second_letter, "LOB"))
+ if (len == 4 && strEQ(second_letter, "LOB"))
tmpRef = MUTABLE_SV(gv);
break;
case 'H':
- if (strEQ(second_letter, "ASH"))
+ if (len == 4 && strEQ(second_letter, "ASH"))
tmpRef = MUTABLE_SV(GvHV(gv));
break;
case 'I':
- if (*second_letter == 'O' && !elem[2])
+ if (*second_letter == 'O' && !elem[2] && len == 2)
tmpRef = MUTABLE_SV(GvIOp(gv));
break;
case 'N':
- if (strEQ(second_letter, "AME"))
+ if (len == 4 && strEQ(second_letter, "AME"))
sv = newSVhek(GvNAME_HEK(gv));
break;
case 'P':
- if (strEQ(second_letter, "ACKAGE")) {
+ if (len == 7 && strEQ(second_letter, "ACKAGE")) {
const HV * const stash = GvSTASH(gv);
const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
@@ -680,7 +685,7 @@
}
break;
case 'S':
- if (strEQ(second_letter, "CALAR"))
+ if (len == 6 && strEQ(second_letter, "CALAR"))
tmpRef = GvSVn(gv);
break;
}
@@ -700,72 +705,16 @@
PP(pp_study)
{
dVAR; dSP; dPOPss;
- register unsigned char *s;
- register I32 pos;
- register I32 ch;
- register I32 *sfirst;
- register I32 *snext;
STRLEN len;
- if (sv == PL_lastscream) {
- if (SvSCREAM(sv))
- RETPUSHYES;
- }
- s = (unsigned char*)(SvPV(sv, len));
- pos = len;
- if (pos <= 0 || !SvPOK(sv) || SvUTF8(sv)) {
- /* No point in studying a zero length string, and not safe to study
- anything that doesn't appear to be a simple scalar (and hence might
- change between now and when the regexp engine runs without our set
- magic ever running) such as a reference to an object with overloaded
- stringification. */
+ (void)SvPV(sv, len);
+ if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
+ /* Historically, study was skipped in these cases. */
RETPUSHNO;
}
- if (PL_lastscream) {
- SvSCREAM_off(PL_lastscream);
- SvREFCNT_dec(PL_lastscream);
- }
- PL_lastscream = SvREFCNT_inc_simple(sv);
-
- s = (unsigned char*)(SvPV(sv, len));
- pos = len;
- if (pos <= 0)
- RETPUSHNO;
- if (pos > PL_maxscream) {
- if (PL_maxscream < 0) {
- PL_maxscream = pos + 80;
- Newx(PL_screamfirst, 256, I32);
- Newx(PL_screamnext, PL_maxscream, I32);
- }
- else {
- PL_maxscream = pos + pos / 4;
- Renew(PL_screamnext, PL_maxscream, I32);
- }
- }
-
- sfirst = PL_screamfirst;
- snext = PL_screamnext;
-
- if (!sfirst || !snext)
- DIE(aTHX_ "do_study: out of memory");
-
- for (ch = 256; ch; --ch)
- *sfirst++ = -1;
- sfirst -= 256;
-
- while (--pos >= 0) {
- register const I32 ch = s[pos];
- if (sfirst[ch] >= 0)
- snext[pos] = sfirst[ch] - pos;
- else
- snext[pos] = -pos;
- sfirst[ch] = pos;
- }
-
- SvSCREAM_on(sv);
- /* piggyback on m//g magic */
- sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
+ /* Make study a no-op. It's no longer useful and its existence
+ complicates matters elsewhere. */
RETPUSHYES;
}
@@ -782,13 +731,17 @@
sv = DEFSV;
EXTEND(SP,1);
}
- TARG = sv_newmortal();
if(PL_op->op_type == OP_TRANSR) {
- SV * const newsv = newSVsv(sv);
+ STRLEN len;
+ const char * const pv = SvPV(sv,len);
+ SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
do_trans(newsv);
- mPUSHs(newsv);
+ PUSHs(newsv);
}
- else PUSHi(do_trans(sv));
+ else {
+ TARG = sv_newmortal();
+ PUSHi(do_trans(sv));
+ }
RETURN;
}
@@ -826,13 +779,11 @@
return;
}
else if (SvREADONLY(sv)) {
- if (SvFAKE(sv)) {
- /* SV is copy-on-write */
- sv_force_normal_flags(sv, 0);
- }
- if (SvREADONLY(sv))
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
}
+ else if (SvIsCOW(sv)) {
+ sv_force_normal_flags(sv, 0);
+ }
if (PL_encoding) {
if (!SvUTF8(sv)) {
@@ -915,7 +866,7 @@
SvIVX(retval) += rs_charlen;
}
}
- s = SvPV_force_nolen(sv);
+ s = SvPV_force_nomg_nolen(sv);
SvCUR_set(sv, len);
*SvEND(sv) = '\0';
SvNIOK_off(sv);
@@ -1014,24 +965,35 @@
break;
case SVt_PVCV:
if (cv_const_sv((const CV *)sv))
- Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
- CvANON((const CV *)sv) ? "(anonymous)"
- : GvENAME(CvGV((const CV *)sv)));
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
+ "Constant subroutine %"SVf" undefined",
+ SVfARG(CvANON((const CV *)sv)
+ ? newSVpvs_flags("(anonymous)", SVs_TEMP)
+ : sv_2mortal(newSVhek(
+ CvNAMED(sv)
+ ? CvNAME_HEK((CV *)sv)
+ : GvENAME_HEK(CvGV((const CV *)sv))
+ ))
+ ));
/* FALLTHROUGH */
case SVt_PVFM:
{
/* let user-undef'd sub keep its identity */
GV* const gv = CvGV((const CV *)sv);
+ HEK * const hek = CvNAME_HEK((CV *)sv);
+ if (hek) share_hek_hek(hek);
cv_undef(MUTABLE_CV(sv));
- CvGV_set(MUTABLE_CV(sv), gv);
+ if (gv) CvGV_set(MUTABLE_CV(sv), gv);
+ else if (hek) {
+ SvANY((CV *)sv)->xcv_gv_u.xcv_hek = hek;
+ CvNAMED_on(sv);
+ }
}
break;
case SVt_PVGV:
- if (SvFAKE(sv)) {
- SvSetMagicSV(sv, &PL_sv_undef);
- break;
- }
- else if (isGV_with_GP(sv)) {
+ assert(isGV_with_GP(sv));
+ assert(!SvFAKE(sv));
+ {
GP *gp;
HV *stash;
@@ -1069,7 +1031,6 @@
break;
}
- /* FALL THROUGH */
default:
if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
SvPV_free(sv);
@@ -1083,68 +1044,33 @@
RETPUSHUNDEF;
}
-PP(pp_predec)
-{
- dVAR; dSP;
- if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
- Perl_croak_no_modify(aTHX);
- if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
- && SvIVX(TOPs) != IV_MIN)
- {
- SvIV_set(TOPs, SvIVX(TOPs) - 1);
- SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
- }
- else
- sv_dec(TOPs);
- SvSETMAGIC(TOPs);
- return NORMAL;
-}
-
PP(pp_postinc)
{
dVAR; dSP; dTARGET;
- if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
- Perl_croak_no_modify(aTHX);
+ const bool inc =
+ PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
+ if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
+ Perl_croak_no_modify();
if (SvROK(TOPs))
TARG = sv_newmortal();
sv_setsv(TARG, TOPs);
- if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
- && SvIVX(TOPs) != IV_MAX)
+ if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
+ && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
{
- SvIV_set(TOPs, SvIVX(TOPs) + 1);
+ SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
}
- else
+ else if (inc)
sv_inc_nomg(TOPs);
+ else sv_dec_nomg(TOPs);
SvSETMAGIC(TOPs);
/* special case for undef: see thread at 2003-03/msg00536.html in archive */
- if (!SvOK(TARG))
+ if (inc && !SvOK(TARG))
sv_setiv(TARG, 0);
SETs(TARG);
return NORMAL;
}
-PP(pp_postdec)
-{
- dVAR; dSP; dTARGET;
- if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
- Perl_croak_no_modify(aTHX);
- if (SvROK(TOPs))
- TARG = sv_newmortal();
- sv_setsv(TARG, TOPs);
- if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
- && SvIVX(TOPs) != IV_MIN)
- {
- SvIV_set(TOPs, SvIVX(TOPs) - 1);
- SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
- }
- else
- sv_dec_nomg(TOPs);
- SvSETMAGIC(TOPs);
- SETs(TARG);
- return NORMAL;
-}
-
/* Ordinary operators. */
PP(pp_pow)
@@ -1160,11 +1086,7 @@
/* For integer to integer power, we do the calculation by hand wherever
we're sure it is safe; otherwise we call pow() and try to convert to
integer afterwards. */
- {
- SvIV_please_nomg(svr);
- if (SvIOK(svr)) {
- SvIV_please_nomg(svl);
- if (SvIOK(svl)) {
+ if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
UV power;
bool baseuok;
UV baseuv;
@@ -1222,8 +1144,8 @@
SvIV_please_nomg(svr);
RETURN;
} else {
- register unsigned int highbit = 8 * sizeof(UV);
- register unsigned int diff = 8 * sizeof(UV);
+ unsigned int highbit = 8 * sizeof(UV);
+ unsigned int diff = 8 * sizeof(UV);
while (diff >>= 1) {
highbit -= diff;
if (baseuv >> highbit) {
@@ -1234,8 +1156,8 @@
if (power * highbit <= 8 * sizeof(UV)) {
/* result will definitely fit in UV, so use UV math
on same algorithm as above */
- register UV result = 1;
- register UV base = baseuv;
+ UV result = 1;
+ UV base = baseuv;
const bool odd_power = cBOOL(power & 1);
if (odd_power) {
result *= base;
@@ -1262,8 +1184,6 @@
RETURN;
}
}
- }
- }
}
float_it:
#endif
@@ -1327,14 +1247,12 @@
svr = TOPs;
svl = TOPm1s;
#ifdef PERL_PRESERVE_IVUV
- SvIV_please_nomg(svr);
- if (SvIOK(svr)) {
+ if (SvIV_please_nomg(svr)) {
/* Unless the left argument is integer in range we are going to have to
use NV maths. Hence only attempt to coerce the right argument if
we know the left is integer. */
/* Left operand is defined, so is it IV? */
- SvIV_please_nomg(svl);
- if (SvIOK(svl)) {
+ if (SvIV_please_nomg(svl)) {
bool auvok = SvUOK(svl);
bool buvok = SvUOK(svr);
const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
@@ -1472,10 +1390,7 @@
#endif
#ifdef PERL_TRY_UV_DIVIDE
- SvIV_please_nomg(svr);
- if (SvIOK(svr)) {
- SvIV_please_nomg(svl);
- if (SvIOK(svl)) {
+ if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
bool left_non_neg = SvUOK(svl);
bool right_non_neg = SvUOK(svr);
UV left;
@@ -1550,8 +1465,7 @@
RETURN;
} /* tried integer divide but it was not an integer result */
} /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
- } /* left wasn't SvIOK */
- } /* right wasn't SvIOK */
+ } /* one operand wasn't SvIOK */
#endif /* PERL_TRY_UV_DIVIDE */
{
NV right = SvNV_nomg(svr);
@@ -1583,8 +1497,7 @@
NV dleft = 0.0;
SV * const svr = TOPs;
SV * const svl = TOPm1s;
- SvIV_please_nomg(svr);
- if (SvIOK(svr)) {
+ if (SvIV_please_nomg(svr)) {
right_neg = !SvUOK(svr);
if (!right_neg) {
right = SvUVX(svr);
@@ -1614,9 +1527,7 @@
/* At this point use_double is only true if right is out of range for
a UV. In range NV has been rounded down to nearest UV and
use_double false. */
- SvIV_please_nomg(svl);
- if (!use_double && SvIOK(svl)) {
- if (SvIOK(svl)) {
+ if (!use_double && SvIV_please_nomg(svl)) {
left_neg = !SvUOK(svl);
if (!left_neg) {
left = SvUVX(svl);
@@ -1629,7 +1540,6 @@
left = -aiv;
}
}
- }
}
else {
dleft = SvNV_nomg(svl);
@@ -1702,7 +1612,7 @@
PP(pp_repeat)
{
dVAR; dSP; dATARGET;
- register IV count;
+ IV count;
SV *sv;
if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
@@ -1742,7 +1652,7 @@
if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
dMARK;
- static const char oom_list_extend[] = "Out of memory during list extend";
+ static const char* const oom_list_extend = "Out of memory during list extend";
const I32 items = SP - MARK;
const I32 max = items * count;
@@ -1749,7 +1659,7 @@
MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
/* Did the max computation overflow? */
if (items > 0 && max > 0 && (max < items || max < count))
- Perl_croak(aTHX_ oom_list_extend);
+ Perl_croak(aTHX_ "%s", oom_list_extend);
MEXTEND(MARK, max);
if (count > 1) {
while (SP > MARK) {
@@ -1794,7 +1704,7 @@
SV * const tmpstr = POPs;
STRLEN len;
bool isutf;
- static const char oom_string_extend[] =
+ static const char* const oom_string_extend =
"Out of memory during string extend";
if (TARG != tmpstr)
@@ -1807,7 +1717,7 @@
else {
const STRLEN max = (UV)count * len;
if (len > MEM_SIZE_MAX / count)
- Perl_croak(aTHX_ oom_string_extend);
+ Perl_croak(aTHX_ "%s", oom_string_extend);
MEM_WRAP_CHECK_1(max, char, oom_string_extend);
SvGROW(TARG, max + 1);
repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
@@ -1844,12 +1754,11 @@
#ifdef PERL_PRESERVE_IVUV
/* See comments in pp_add (in pp_hot.c) about Overflow, and how
"bad things" happen if you rely on signed integers wrapping. */
- SvIV_please_nomg(svr);
- if (SvIOK(svr)) {
+ if (SvIV_please_nomg(svr)) {
/* Unless the left argument is integer in range we are going to have to
use NV maths. Hence only attempt to coerce the right argument if
we know the left is integer. */
- register UV auv = 0;
+ UV auv = 0;
bool auvok = FALSE;
bool a_valid = 0;
@@ -1859,12 +1768,11 @@
/* left operand is undef, treat as zero. */
} else {
/* Left operand is defined, so is it IV? */
- SvIV_please_nomg(svl);
- if (SvIOK(svl)) {
+ if (SvIV_please_nomg(svl)) {
if ((auvok = SvUOK(svl)))
auv = SvUVX(svl);
else {
- register const IV aiv = SvIVX(svl);
+ const IV aiv = SvIVX(svl);
if (aiv >= 0) {
auv = aiv;
auvok = 1; /* Now acting as a sign flag. */
@@ -1878,13 +1786,13 @@
if (a_valid) {
bool result_good = 0;
UV result;
- register UV buv;
+ UV buv;
bool buvok = SvUOK(svr);
if (buvok)
buv = SvUVX(svr);
else {
- register const IV biv = SvIVX(svr);
+ const IV biv = SvIVX(svr);
if (biv >= 0) {
buv = biv;
buvok = 1;
@@ -1998,518 +1906,174 @@
PP(pp_lt)
{
dVAR; dSP;
+ SV *left, *right;
+
tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
-#ifdef PERL_PRESERVE_IVUV
- SvIV_please_nomg(TOPs);
- if (SvIOK(TOPs)) {
- SvIV_please_nomg(TOPm1s);
- if (SvIOK(TOPm1s)) {
- bool auvok = SvUOK(TOPm1s);
- bool buvok = SvUOK(TOPs);
-
- if (!auvok && !buvok) { /* ## IV < IV ## */
- const IV aiv = SvIVX(TOPm1s);
- const IV biv = SvIVX(TOPs);
-
- SP--;
- SETs(boolSV(aiv < biv));
- RETURN;
- }
- if (auvok && buvok) { /* ## UV < UV ## */
- const UV auv = SvUVX(TOPm1s);
- const UV buv = SvUVX(TOPs);
-
- SP--;
- SETs(boolSV(auv < buv));
- RETURN;
- }
- if (auvok) { /* ## UV < IV ## */
- UV auv;
- const IV biv = SvIVX(TOPs);
- SP--;
- if (biv < 0) {
- /* As (a) is a UV, it's >=0, so it cannot be < */
- SETs(&PL_sv_no);
- RETURN;
- }
- auv = SvUVX(TOPs);
- SETs(boolSV(auv < (UV)biv));
- RETURN;
- }
- { /* ## IV < UV ## */
- const IV aiv = SvIVX(TOPm1s);
- UV buv;
-
- if (aiv < 0) {
- /* As (b) is a UV, it's >=0, so it must be < */
- SP--;
- SETs(&PL_sv_yes);
- RETURN;
- }
- buv = SvUVX(TOPs);
- SP--;
- SETs(boolSV((UV)aiv < buv));
- RETURN;
- }
- }
- }
-#endif
-#ifndef NV_PRESERVES_UV
-#ifdef PERL_PRESERVE_IVUV
- else
-#endif
- if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
- SP--;
- SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
- RETURN;
- }
-#endif
- {
-#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
- dPOPTOPnnrl_nomg;
- if (Perl_isnan(left) || Perl_isnan(right))
- RETSETNO;
- SETs(boolSV(left < right));
-#else
- dPOPnv_nomg;
- SETs(boolSV(SvNV_nomg(TOPs) < value));
-#endif
- RETURN;
- }
+ right = POPs;
+ left = TOPs;
+ SETs(boolSV(
+ (SvIOK_notUV(left) && SvIOK_notUV(right))
+ ? (SvIVX(left) < SvIVX(right))
+ : (do_ncmp(left, right) == -1)
+ ));
+ RETURN;
}
PP(pp_gt)
{
dVAR; dSP;
+ SV *left, *right;
+
tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
-#ifdef PERL_PRESERVE_IVUV
- SvIV_please_nomg(TOPs);
- if (SvIOK(TOPs)) {
- SvIV_please_nomg(TOPm1s);
- if (SvIOK(TOPm1s)) {
- bool auvok = SvUOK(TOPm1s);
- bool buvok = SvUOK(TOPs);
-
- if (!auvok && !buvok) { /* ## IV > IV ## */
- const IV aiv = SvIVX(TOPm1s);
- const IV biv = SvIVX(TOPs);
-
- SP--;
- SETs(boolSV(aiv > biv));
- RETURN;
- }
- if (auvok && buvok) { /* ## UV > UV ## */
- const UV auv = SvUVX(TOPm1s);
- const UV buv = SvUVX(TOPs);
-
- SP--;
- SETs(boolSV(auv > buv));
- RETURN;
- }
- if (auvok) { /* ## UV > IV ## */
- UV auv;
- const IV biv = SvIVX(TOPs);
-
- SP--;
- if (biv < 0) {
- /* As (a) is a UV, it's >=0, so it must be > */
- SETs(&PL_sv_yes);
- RETURN;
- }
- auv = SvUVX(TOPs);
- SETs(boolSV(auv > (UV)biv));
- RETURN;
- }
- { /* ## IV > UV ## */
- const IV aiv = SvIVX(TOPm1s);
- UV buv;
-
- if (aiv < 0) {
- /* As (b) is a UV, it's >=0, so it cannot be > */
- SP--;
- SETs(&PL_sv_no);
- RETURN;
- }
- buv = SvUVX(TOPs);
- SP--;
- SETs(boolSV((UV)aiv > buv));
- RETURN;
- }
- }
- }
-#endif
-#ifndef NV_PRESERVES_UV
-#ifdef PERL_PRESERVE_IVUV
- else
-#endif
- if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
- SP--;
- SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
- RETURN;
- }
-#endif
- {
-#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
- dPOPTOPnnrl_nomg;
- if (Perl_isnan(left) || Perl_isnan(right))
- RETSETNO;
- SETs(boolSV(left > right));
-#else
- dPOPnv_nomg;
- SETs(boolSV(SvNV_nomg(TOPs) > value));
-#endif
- RETURN;
- }
+ right = POPs;
+ left = TOPs;
+ SETs(boolSV(
+ (SvIOK_notUV(left) && SvIOK_notUV(right))
+ ? (SvIVX(left) > SvIVX(right))
+ : (do_ncmp(left, right) == 1)
+ ));
+ RETURN;
}
PP(pp_le)
{
dVAR; dSP;
+ SV *left, *right;
+
tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
-#ifdef PERL_PRESERVE_IVUV
- SvIV_please_nomg(TOPs);
- if (SvIOK(TOPs)) {
- SvIV_please_nomg(TOPm1s);
- if (SvIOK(TOPm1s)) {
- bool auvok = SvUOK(TOPm1s);
- bool buvok = SvUOK(TOPs);
-
- if (!auvok && !buvok) { /* ## IV <= IV ## */
- const IV aiv = SvIVX(TOPm1s);
- const IV biv = SvIVX(TOPs);
-
- SP--;
- SETs(boolSV(aiv <= biv));
- RETURN;
- }
- if (auvok && buvok) { /* ## UV <= UV ## */
- UV auv = SvUVX(TOPm1s);
- UV buv = SvUVX(TOPs);
-
- SP--;
- SETs(boolSV(auv <= buv));
- RETURN;
- }
- if (auvok) { /* ## UV <= IV ## */
- UV auv;
- const IV biv = SvIVX(TOPs);
+ right = POPs;
+ left = TOPs;
+ SETs(boolSV(
+ (SvIOK_notUV(left) && SvIOK_notUV(right))
+ ? (SvIVX(left) <= SvIVX(right))
+ : (do_ncmp(left, right) <= 0)
+ ));
+ RETURN;
+}
- SP--;
- if (biv < 0) {
- /* As (a) is a UV, it's >=0, so a cannot be <= */
- SETs(&PL_sv_no);
- RETURN;
- }
- auv = SvUVX(TOPs);
- SETs(boolSV(auv <= (UV)biv));
- RETURN;
- }
- { /* ## IV <= UV ## */
- const IV aiv = SvIVX(TOPm1s);
- UV buv;
+PP(pp_ge)
+{
+ dVAR; dSP;
+ SV *left, *right;
- if (aiv < 0) {
- /* As (b) is a UV, it's >=0, so a must be <= */
- SP--;
- SETs(&PL_sv_yes);
- RETURN;
- }
- buv = SvUVX(TOPs);
- SP--;
- SETs(boolSV((UV)aiv <= buv));
- RETURN;
- }
- }
- }
-#endif
-#ifndef NV_PRESERVES_UV
-#ifdef PERL_PRESERVE_IVUV
- else
-#endif
- if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
- SP--;
- SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
- RETURN;
- }
-#endif
- {
-#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
- dPOPTOPnnrl_nomg;
- if (Perl_isnan(left) || Perl_isnan(right))
- RETSETNO;
- SETs(boolSV(left <= right));
-#else
- dPOPnv_nomg;
- SETs(boolSV(SvNV_nomg(TOPs) <= value));
-#endif
- RETURN;
- }
+ tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
+ right = POPs;
+ left = TOPs;
+ SETs(boolSV(
+ (SvIOK_notUV(left) && SvIOK_notUV(right))
+ ? (SvIVX(left) >= SvIVX(right))
+ : ( (do_ncmp(left, right) & 2) == 0)
+ ));
+ RETURN;
}
-PP(pp_ge)
+PP(pp_ne)
{
dVAR; dSP;
- tryAMAGICbin_MG(ge_amg,AMGf_set|AMGf_numeric);
-#ifdef PERL_PRESERVE_IVUV
- SvIV_please_nomg(TOPs);
- if (SvIOK(TOPs)) {
- SvIV_please_nomg(TOPm1s);
- if (SvIOK(TOPm1s)) {
- bool auvok = SvUOK(TOPm1s);
- bool buvok = SvUOK(TOPs);
-
- if (!auvok && !buvok) { /* ## IV >= IV ## */
- const IV aiv = SvIVX(TOPm1s);
- const IV biv = SvIVX(TOPs);
+ SV *left, *right;
- SP--;
- SETs(boolSV(aiv >= biv));
- RETURN;
- }
- if (auvok && buvok) { /* ## UV >= UV ## */
- const UV auv = SvUVX(TOPm1s);
- const UV buv = SvUVX(TOPs);
+ tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
+ right = POPs;
+ left = TOPs;
+ SETs(boolSV(
+ (SvIOK_notUV(left) && SvIOK_notUV(right))
+ ? (SvIVX(left) != SvIVX(right))
+ : (do_ncmp(left, right) != 0)
+ ));
+ RETURN;
+}
- SP--;
- SETs(boolSV(auv >= buv));
- RETURN;
- }
- if (auvok) { /* ## UV >= IV ## */
- UV auv;
- const IV biv = SvIVX(TOPs);
+/* compare left and right SVs. Returns:
+ * -1: <
+ * 0: ==
+ * 1: >
+ * 2: left or right was a NaN
+ */
+I32
+Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
+{
+ dVAR;
- SP--;
- if (biv < 0) {
- /* As (a) is a UV, it's >=0, so it must be >= */
- SETs(&PL_sv_yes);
- RETURN;
+ PERL_ARGS_ASSERT_DO_NCMP;
+#ifdef PERL_PRESERVE_IVUV
+ /* Fortunately it seems NaN isn't IOK */
+ if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
+ if (!SvUOK(left)) {
+ const IV leftiv = SvIVX(left);
+ if (!SvUOK(right)) {
+ /* ## IV <=> IV ## */
+ const IV rightiv = SvIVX(right);
+ return (leftiv > rightiv) - (leftiv < rightiv);
}
- auv = SvUVX(TOPs);
- SETs(boolSV(auv >= (UV)biv));
- RETURN;
- }
- { /* ## IV >= UV ## */
- const IV aiv = SvIVX(TOPm1s);
- UV buv;
-
- if (aiv < 0) {
- /* As (b) is a UV, it's >=0, so a cannot be >= */
- SP--;
- SETs(&PL_sv_no);
- RETURN;
+ /* ## IV <=> UV ## */
+ if (leftiv < 0)
+ /* As (b) is a UV, it's >=0, so it must be < */
+ return -1;
+ {
+ const UV rightuv = SvUVX(right);
+ return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
}
- buv = SvUVX(TOPs);
- SP--;
- SETs(boolSV((UV)aiv >= buv));
- RETURN;
}
- }
- }
-#endif
-#ifndef NV_PRESERVES_UV
-#ifdef PERL_PRESERVE_IVUV
- else
-#endif
- if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
- SP--;
- SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
- RETURN;
- }
-#endif
- {
-#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
- dPOPTOPnnrl_nomg;
- if (Perl_isnan(left) || Perl_isnan(right))
- RETSETNO;
- SETs(boolSV(left >= right));
-#else
- dPOPnv_nomg;
- SETs(boolSV(SvNV_nomg(TOPs) >= value));
-#endif
- RETURN;
- }
-}
-PP(pp_ne)
-{
- dVAR; dSP;
- tryAMAGICbin_MG(ne_amg,AMGf_set|AMGf_numeric);
-#ifndef NV_PRESERVES_UV
- if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
- SP--;
- SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
- RETURN;
- }
-#endif
-#ifdef PERL_PRESERVE_IVUV
- SvIV_please_nomg(TOPs);
- if (SvIOK(TOPs)) {
- SvIV_please_nomg(TOPm1s);
- if (SvIOK(TOPm1s)) {
- const bool auvok = SvUOK(TOPm1s);
- const bool buvok = SvUOK(TOPs);
-
- if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
- /* Casting IV to UV before comparison isn't going to matter
- on 2s complement. On 1s complement or sign&magnitude
- (if we have any of them) it could make negative zero
- differ from normal zero. As I understand it. (Need to
- check - is negative zero implementation defined behaviour
- anyway?). NWC */
- const UV buv = SvUVX(POPs);
- const UV auv = SvUVX(TOPs);
-
- SETs(boolSV(auv != buv));
- RETURN;
+ if (SvUOK(right)) {
+ /* ## UV <=> UV ## */
+ const UV leftuv = SvUVX(left);
+ const UV rightuv = SvUVX(right);
+ return (leftuv > rightuv) - (leftuv < rightuv);
}
- { /* ## Mixed IV,UV ## */
- IV iv;
- UV uv;
-
- /* != is commutative so swap if needed (save code) */
- if (auvok) {
- /* swap. top of stack (b) is the iv */
- iv = SvIVX(TOPs);
- SP--;
- if (iv < 0) {
- /* As (a) is a UV, it's >0, so it cannot be == */
- SETs(&PL_sv_yes);
- RETURN;
- }
- uv = SvUVX(TOPs);
- } else {
- iv = SvIVX(TOPm1s);
- SP--;
- if (iv < 0) {
- /* As (b) is a UV, it's >0, so it cannot be == */
- SETs(&PL_sv_yes);
- RETURN;
- }
- uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
+ /* ## UV <=> IV ## */
+ {
+ const IV rightiv = SvIVX(right);
+ if (rightiv < 0)
+ /* As (a) is a UV, it's >=0, so it cannot be < */
+ return 1;
+ {
+ const UV leftuv = SvUVX(left);
+ return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
}
- SETs(boolSV((UV)iv != uv));
- RETURN;
}
- }
+ assert(0); /* NOTREACHED */
}
#endif
{
+ NV const rnv = SvNV_nomg(right);
+ NV const lnv = SvNV_nomg(left);
+
#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
- dPOPTOPnnrl_nomg;
- if (Perl_isnan(left) || Perl_isnan(right))
- RETSETYES;
- SETs(boolSV(left != right));
+ if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
+ return 2;
+ }
+ return (lnv > rnv) - (lnv < rnv);
#else
- dPOPnv_nomg;
- SETs(boolSV(SvNV_nomg(TOPs) != value));
+ if (lnv < rnv)
+ return -1;
+ if (lnv > rnv)
+ return 1;
+ if (lnv == rnv)
+ return 0;
+ return 2;
#endif
- RETURN;
}
}
+
PP(pp_ncmp)
{
- dVAR; dSP; dTARGET;
+ dVAR; dSP;
+ SV *left, *right;
+ I32 value;
tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
-#ifndef NV_PRESERVES_UV
- if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
- const UV right = PTR2UV(SvRV(POPs));
- const UV left = PTR2UV(SvRV(TOPs));
- SETi((left > right) - (left < right));
- RETURN;
+ right = POPs;
+ left = TOPs;
+ value = do_ncmp(left, right);
+ if (value == 2) {
+ SETs(&PL_sv_undef);
}
-#endif
-#ifdef PERL_PRESERVE_IVUV
- /* Fortunately it seems NaN isn't IOK */
- SvIV_please_nomg(TOPs);
- if (SvIOK(TOPs)) {
- SvIV_please_nomg(TOPm1s);
- if (SvIOK(TOPm1s)) {
- const bool leftuvok = SvUOK(TOPm1s);
- const bool rightuvok = SvUOK(TOPs);
- I32 value;
- if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
- const IV leftiv = SvIVX(TOPm1s);
- const IV rightiv = SvIVX(TOPs);
-
- if (leftiv > rightiv)
- value = 1;
- else if (leftiv < rightiv)
- value = -1;
- else
- value = 0;
- } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
- const UV leftuv = SvUVX(TOPm1s);
- const UV rightuv = SvUVX(TOPs);
-
- if (leftuv > rightuv)
- value = 1;
- else if (leftuv < rightuv)
- value = -1;
- else
- value = 0;
- } else if (leftuvok) { /* ## UV <=> IV ## */
- const IV rightiv = SvIVX(TOPs);
- if (rightiv < 0) {
- /* As (a) is a UV, it's >=0, so it cannot be < */
- value = 1;
- } else {
- const UV leftuv = SvUVX(TOPm1s);
- if (leftuv > (UV)rightiv) {
- value = 1;
- } else if (leftuv < (UV)rightiv) {
- value = -1;
- } else {
- value = 0;
- }
- }
- } else { /* ## IV <=> UV ## */
- const IV leftiv = SvIVX(TOPm1s);
- if (leftiv < 0) {
- /* As (b) is a UV, it's >=0, so it must be < */
- value = -1;
- } else {
- const UV rightuv = SvUVX(TOPs);
- if ((UV)leftiv > rightuv) {
- value = 1;
- } else if ((UV)leftiv < rightuv) {
- value = -1;
- } else {
- value = 0;
- }
- }
- }
- SP--;
- SETi(value);
- RETURN;
- }
+ else {
+ dTARGET;
+ SETi(value);
}
-#endif
- {
- dPOPTOPnnrl_nomg;
- I32 value;
-
-#ifdef Perl_isnan
- if (Perl_isnan(left) || Perl_isnan(right)) {
- SETs(&PL_sv_undef);
- RETURN;
- }
- value = (left > right) - (left < right);
-#else
- if (left == right)
- value = 0;
- else if (left < right)
- value = -1;
- else if (left > right)
- value = 1;
- else {
- SETs(&PL_sv_undef);
- RETURN;
- }
-#endif
- SETi(value);
- RETURN;
- }
+ RETURN;
}
PP(pp_sle)
@@ -2603,7 +2167,7 @@
const UV u = SvUV_nomg(left) & SvUV_nomg(right);
SETu(u);
}
- if (left_ro_nonnum) SvNIOK_off(left);
+ if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
if (right_ro_nonnum) SvNIOK_off(right);
}
else {
@@ -2637,7 +2201,7 @@
const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
SETu(result);
}
- if (left_ro_nonnum) SvNIOK_off(left);
+ if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
if (right_ro_nonnum) SvNIOK_off(right);
}
else {
@@ -2648,25 +2212,45 @@
}
}
+PERL_STATIC_INLINE bool
+S_negate_string(pTHX)
+{
+ dTARGET; dSP;
+ STRLEN len;
+ const char *s;
+ SV * const sv = TOPs;
+ if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
+ return FALSE;
+ s = SvPV_nomg_const(sv, len);
+ if (isIDFIRST(*s)) {
+ sv_setpvs(TARG, "-");
+ sv_catsv(TARG, sv);
+ }
+ else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
+ sv_setsv_nomg(TARG, sv);
+ *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
+ }
+ else return FALSE;
+ SETTARG; PUTBACK;
+ return TRUE;
+}
+
PP(pp_negate)
{
dVAR; dSP; dTARGET;
tryAMAGICun_MG(neg_amg, AMGf_numeric);
+ if (S_negate_string(aTHX)) return NORMAL;
{
SV * const sv = TOPs;
- const int flags = SvFLAGS(sv);
- if( !SvNIOK( sv ) && looks_like_number( sv ) ){
- SvIV_please( sv );
- }
-
- if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
- /* It's publicly an integer, or privately an integer-not-float */
+ if (SvIOK(sv)) {
+ /* It's publicly an integer */
oops_its_an_int:
if (SvIsUV(sv)) {
if (SvIVX(sv) == IV_MIN) {
/* 2s complement assumption. */
- SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
+ SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
+ IV_MIN */
RETURN;
}
else if (SvUVX(sv) <= IV_MAX) {
@@ -2685,38 +2269,10 @@
}
#endif
}
- if (SvNIOKp(sv))
+ if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
SETn(-SvNV_nomg(sv));
- else if (SvPOKp(sv)) {
- STRLEN len;
- const char * const s = SvPV_nomg_const(sv, len);
- if (isIDFIRST(*s)) {
- sv_setpvs(TARG, "-");
- sv_catsv(TARG, sv);
- }
- else if (*s == '+' || *s == '-') {
- sv_setsv_nomg(TARG, sv);
- *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
- }
- else if (DO_UTF8(sv)) {
- SvIV_please_nomg(sv);
- if (SvIOK(sv))
- goto oops_its_an_int;
- if (SvNOK(sv))
- sv_setnv(TARG, -SvNV_nomg(sv));
- else {
- sv_setpvs(TARG, "-");
- sv_catsv(TARG, sv);
- }
- }
- else {
- SvIV_please_nomg(sv);
- if (SvIOK(sv))
+ else if (SvPOKp(sv) && SvIV_please_nomg(sv))
goto oops_its_an_int;
- sv_setnv(TARG, -SvNV_nomg(sv));
- }
- SETTARG;
- }
else
SETn(-SvNV_nomg(sv));
}
@@ -2748,8 +2304,8 @@
}
}
else {
- register U8 *tmps;
- register I32 anum;
+ U8 *tmps;
+ I32 anum;
STRLEN len;
(void)SvPV_nomg_const(sv,len); /* force check for uninit var */
@@ -2814,7 +2370,7 @@
}
#ifdef LIBERAL
{
- register long *tmpl;
+ long *tmpl;
for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
*tmps = ~*tmps;
tmpl = (long*)tmps;
@@ -2866,7 +2422,7 @@
}
}
-#if defined(__GLIBC__) && IVSIZE == 8
+#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
STATIC
PP(pp_i_modulo_0)
#else
@@ -2889,7 +2445,7 @@
}
}
-#if defined(__GLIBC__) && IVSIZE == 8
+#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
STATIC
PP(pp_i_modulo_1)
@@ -3067,6 +2623,7 @@
{
dVAR; dSP; dTARGET;
tryAMAGICun_MG(neg_amg, 0);
+ if (S_negate_string(aTHX)) return NORMAL;
{
SV * const sv = TOPs;
IV const i = SvIV_nomg(sv);
@@ -3125,6 +2682,7 @@
if (neg_report) {
if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
SET_NUMERIC_STANDARD();
+ /* diag_listed_as: Can't take log of %g */
DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
}
}
@@ -3150,27 +2708,64 @@
PP(pp_rand)
{
- dVAR; dSP; dTARGET;
- NV value;
- if (MAXARG < 1)
- value = 1.0;
- else
- value = POPn;
- if (value == 0.0)
- value = 1.0;
+ dVAR;
if (!PL_srand_called) {
(void)seedDrand01((Rand_seed_t)seed());
PL_srand_called = TRUE;
}
- value *= Drand01();
- XPUSHn(value);
- RETURN;
+ {
+ dSP;
+ NV value;
+ EXTEND(SP, 1);
+
+ if (MAXARG < 1)
+ value = 1.0;
+ else {
+ SV * const sv = POPs;
+ if(!sv)
+ value = 1.0;
+ else
+ value = SvNV(sv);
+ }
+ /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
+ if (value == 0.0)
+ value = 1.0;
+ {
+ dTARGET;
+ PUSHs(TARG);
+ PUTBACK;
+ value *= Drand01();
+ sv_setnv_mg(TARG, value);
+ }
+ }
+ return NORMAL;
}
PP(pp_srand)
{
dVAR; dSP; dTARGET;
- const UV anum = (MAXARG < 1) ? seed() : POPu;
+ UV anum;
+
+ if (MAXARG >= 1 && (TOPs || POPs)) {
+ SV *top;
+ char *pv;
+ STRLEN len;
+ int flags;
+
+ top = POPs;
+ pv = SvPV(top, len);
+ flags = grok_number(pv, len, &anum);
+
+ if (!(flags & IS_NUMBER_IN_UV)) {
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
+ "Integer overflow in srand");
+ anum = UV_MAX;
+ }
+ }
+ else {
+ anum = seed();
+ }
+
(void)seedDrand01((Rand_seed_t)anum);
PL_srand_called = TRUE;
if (anum)
@@ -3318,35 +2913,16 @@
dVAR; dSP; dTARGET;
SV * const sv = TOPs;
- if (SvGAMAGIC(sv)) {
- /* For an overloaded or magic scalar, we can't know in advance if
- it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as
- it likes to cache the length. Maybe that should be a documented
- feature of it.
- */
- STRLEN len;
- const char *const p
- = sv_2pv_flags(sv, &len,
- SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
-
- if (!p) {
- if (!SvPADTMP(TARG)) {
- sv_setsv(TARG, &PL_sv_undef);
- SETTARG;
- }
- SETs(&PL_sv_undef);
- }
- else if (DO_UTF8(sv)) {
- SETi(utf8_length((U8*)p, (U8*)p + len));
- }
+ SvGETMAGIC(sv);
+ if (SvOK(sv)) {
+ if (!IN_BYTES)
+ SETi(sv_len_utf8_nomg(sv));
else
+ {
+ STRLEN len;
+ (void)SvPV_nomg_const(sv,len);
SETi(len);
- } else if (SvOK(sv)) {
- /* Neither magic nor overloaded. */
- if (DO_UTF8(sv))
- SETi(sv_len_utf8(sv));
- else
- SETi(sv_len(sv));
+ }
} else {
if (!SvPADTMP(TARG)) {
sv_setsv_nomg(TARG, &PL_sv_undef);
@@ -3357,92 +2933,29 @@
RETURN;
}
-PP(pp_substr)
+/* Returns false if substring is completely outside original string.
+ No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
+ always be true for an explicit 0.
+*/
+bool
+Perl_translate_substr_offsets(pTHX_ STRLEN curlen, IV pos1_iv,
+ bool pos1_is_uv, IV len_iv,
+ bool len_is_uv, STRLEN *posp,
+ STRLEN *lenp)
{
- dVAR; dSP; dTARGET;
- SV *sv;
- STRLEN curlen;
- STRLEN utf8_curlen;
- SV * pos_sv;
- IV pos1_iv;
- int pos1_is_uv;
- IV pos2_iv;
+ IV pos2_iv;
int pos2_is_uv;
- SV * len_sv;
- IV len_iv = 0;
- int len_is_uv = 1;
- const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
- const char *tmps;
- const IV arybase = CopARYBASE_get(PL_curcop);
- SV *repl_sv = NULL;
- const char *repl = NULL;
- STRLEN repl_len;
- const int num_args = PL_op->op_private & 7;
- bool repl_need_utf8_upgrade = FALSE;
- bool repl_is_utf8 = FALSE;
- if (num_args > 2) {
- if (num_args > 3) {
- repl_sv = POPs;
- repl = SvPV_const(repl_sv, repl_len);
- repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
- }
- len_sv = POPs;
- len_iv = SvIV(len_sv);
- len_is_uv = SvIOK_UV(len_sv);
- }
- pos_sv = POPs;
- pos1_iv = SvIV(pos_sv);
- pos1_is_uv = SvIOK_UV(pos_sv);
- sv = POPs;
- PUTBACK;
- if (repl_sv) {
- if (repl_is_utf8) {
- if (!DO_UTF8(sv))
- sv_utf8_upgrade(sv);
- }
- else if (DO_UTF8(sv))
- repl_need_utf8_upgrade = TRUE;
- }
- tmps = SvPV_const(sv, curlen);
- if (DO_UTF8(sv)) {
- utf8_curlen = sv_len_utf8(sv);
- if (utf8_curlen == curlen)
- utf8_curlen = 0;
- else
- curlen = utf8_curlen;
- }
- else
- utf8_curlen = 0;
+ PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
- if ( (pos1_is_uv && arybase < 0) || (pos1_iv >= arybase) ) { /* pos >= $[ */
- UV pos1_uv = pos1_iv-arybase;
- /* Overflow can occur when $[ < 0 */
- if (arybase < 0 && pos1_uv < (UV)pos1_iv)
- goto bound_fail;
- pos1_iv = pos1_uv;
- pos1_is_uv = 1;
+ if (!pos1_is_uv && pos1_iv < 0 && curlen) {
+ pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
+ pos1_iv += curlen;
}
- else if (pos1_is_uv ? (UV)pos1_iv > 0 : pos1_iv > 0) {
- goto bound_fail; /* $[=3; substr($_,2,...) */
- }
- else { /* pos < $[ */
- if (pos1_iv == 0) { /* $[=1; substr($_,0,...) */
- pos1_iv = curlen;
- pos1_is_uv = 1;
- } else {
- if (curlen) {
- pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
- pos1_iv += curlen;
- }
- }
- }
- if (pos1_is_uv || pos1_iv > 0) {
- if ((UV)pos1_iv > curlen)
- goto bound_fail;
- }
+ if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
+ return FALSE;
- if (num_args > 2) {
+ if (len_iv || len_is_uv) {
if (!len_is_uv && len_iv < 0) {
pos2_iv = curlen + len_iv;
if (curlen)
@@ -3469,7 +2982,7 @@
if (!pos2_is_uv && pos2_iv < 0) {
if (!pos1_is_uv && pos1_iv < 0)
- goto bound_fail;
+ return FALSE;
pos2_iv = 0;
}
else if (!pos1_is_uv && pos1_iv < 0)
@@ -3480,53 +2993,123 @@
if ((UV)pos2_iv > curlen)
pos2_iv = curlen;
- {
- /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
- const STRLEN pos = (STRLEN)( (UV)pos1_iv );
- const STRLEN len = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
- STRLEN byte_len = len;
- STRLEN byte_pos = utf8_curlen
- ? sv_pos_u2b_flags(sv, pos, &byte_len, SV_CONST_RETURN) : pos;
+ /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
+ *posp = (STRLEN)( (UV)pos1_iv );
+ *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
- if (lvalue && !repl) {
- SV * ret;
+ return TRUE;
+}
- if (!SvGMAGICAL(sv)) {
- if (SvROK(sv)) {
- SvPV_force_nolen(sv);
- Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
- "Attempt to use reference as lvalue in substr");
- }
- if (isGV_with_GP(sv))
- SvPV_force_nolen(sv);
- else if (SvOK(sv)) /* is it defined ? */
- (void)SvPOK_only_UTF8(sv);
- else
- sv_setpvs(sv, ""); /* avoid lexical reincarnation */
- }
+PP(pp_substr)
+{
+ dVAR; dSP; dTARGET;
+ SV *sv;
+ STRLEN curlen;
+ STRLEN utf8_curlen;
+ SV * pos_sv;
+ IV pos1_iv;
+ int pos1_is_uv;
+ SV * len_sv;
+ IV len_iv = 0;
+ int len_is_uv = 0;
+ I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
+ const bool rvalue = (GIMME_V != G_VOID);
+ const char *tmps;
+ SV *repl_sv = NULL;
+ const char *repl = NULL;
+ STRLEN repl_len;
+ int num_args = PL_op->op_private & 7;
+ bool repl_need_utf8_upgrade = FALSE;
- ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
- sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
- LvTYPE(ret) = 'x';
- LvTARG(ret) = SvREFCNT_inc_simple(sv);
- LvTARGOFF(ret) = pos;
- LvTARGLEN(ret) = len;
+ if (num_args > 2) {
+ if (num_args > 3) {
+ if(!(repl_sv = POPs)) num_args--;
+ }
+ if ((len_sv = POPs)) {
+ len_iv = SvIV(len_sv);
+ len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
+ }
+ else num_args--;
+ }
+ pos_sv = POPs;
+ pos1_iv = SvIV(pos_sv);
+ pos1_is_uv = SvIOK_UV(pos_sv);
+ sv = POPs;
+ if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
+ assert(!repl_sv);
+ repl_sv = POPs;
+ }
+ PUTBACK;
+ if (lvalue && !repl_sv) {
+ SV * ret;
+ ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
+ sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
+ LvTYPE(ret) = 'x';
+ LvTARG(ret) = SvREFCNT_inc_simple(sv);
+ LvTARGOFF(ret) =
+ pos1_is_uv || pos1_iv >= 0
+ ? (STRLEN)(UV)pos1_iv
+ : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
+ LvTARGLEN(ret) =
+ len_is_uv || len_iv > 0
+ ? (STRLEN)(UV)len_iv
+ : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
- SPAGAIN;
- PUSHs(ret); /* avoid SvSETMAGIC here */
- RETURN;
+ SPAGAIN;
+ PUSHs(ret); /* avoid SvSETMAGIC here */
+ RETURN;
+ }
+ if (repl_sv) {
+ repl = SvPV_const(repl_sv, repl_len);
+ SvGETMAGIC(sv);
+ if (SvROK(sv))
+ Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
+ "Attempt to use reference as lvalue in substr"
+ );
+ tmps = SvPV_force_nomg(sv, curlen);
+ if (DO_UTF8(repl_sv) && repl_len) {
+ if (!DO_UTF8(sv)) {
+ sv_utf8_upgrade_nomg(sv);
+ curlen = SvCUR(sv);
+ }
}
+ else if (DO_UTF8(sv))
+ repl_need_utf8_upgrade = TRUE;
+ }
+ else tmps = SvPV_const(sv, curlen);
+ if (DO_UTF8(sv)) {
+ utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
+ if (utf8_curlen == curlen)
+ utf8_curlen = 0;
+ else
+ curlen = utf8_curlen;
+ }
+ else
+ utf8_curlen = 0;
- SvTAINTED_off(TARG); /* decontaminate */
- SvUTF8_off(TARG); /* decontaminate */
+ {
+ STRLEN pos, len, byte_len, byte_pos;
+ if (!translate_substr_offsets(
+ curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
+ )) goto bound_fail;
+
+ byte_len = len;
+ byte_pos = utf8_curlen
+ ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
+
tmps += byte_pos;
- sv_setpvn(TARG, tmps, byte_len);
+
+ if (rvalue) {
+ SvTAINTED_off(TARG); /* decontaminate */
+ SvUTF8_off(TARG); /* decontaminate */
+ sv_setpvn(TARG, tmps, byte_len);
#ifdef USE_LOCALE_COLLATE
- sv_unmagic(TARG, PERL_MAGIC_collxfrm);
+ sv_unmagic(TARG, PERL_MAGIC_collxfrm);
#endif
- if (utf8_curlen)
- SvUTF8_on(TARG);
+ if (utf8_curlen)
+ SvUTF8_on(TARG);
+ }
if (repl) {
SV* repl_sv_copy = NULL;
@@ -3535,23 +3118,22 @@
repl_sv_copy = newSVsv(repl_sv);
sv_utf8_upgrade(repl_sv_copy);
repl = SvPV_const(repl_sv_copy, repl_len);
- repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
}
if (!SvOK(sv))
sv_setpvs(sv, "");
sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
- if (repl_is_utf8)
- SvUTF8_on(sv);
SvREFCNT_dec(repl_sv_copy);
}
}
SPAGAIN;
- SvSETMAGIC(TARG);
- PUSHs(TARG);
+ if (rvalue) {
+ SvSETMAGIC(TARG);
+ PUSHs(TARG);
+ }
RETURN;
bound_fail:
- if (lvalue || repl)
+ if (repl)
Perl_croak(aTHX_ "substr outside of string");
Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
RETPUSHUNDEF;
@@ -3560,9 +3142,9 @@
PP(pp_vec)
{
dVAR; dSP;
- register const IV size = POPi;
- register const IV offset = POPi;
- register SV * const src = POPs;
+ const IV size = POPi;
+ const IV offset = POPi;
+ SV * const src = POPs;
const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
SV * ret;
@@ -3597,16 +3179,13 @@
I32 retval;
const char *big_p;
const char *little_p;
- const I32 arybase = CopARYBASE_get(PL_curcop);
bool big_utf8;
bool little_utf8;
const bool is_index = PL_op->op_type == OP_INDEX;
+ const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
- if (MAXARG >= 3) {
- /* arybase is in characters, like offset, so combine prior to the
- UTF-8 to bytes calculation. */
- offset = POPi - arybase;
- }
+ if (threeargs)
+ offset = POPi;
little = POPs;
big = POPs;
big_p = SvPV_const(big, biglen);
@@ -3676,7 +3255,7 @@
little_p = SvPVX(little);
}
- if (MAXARG < 3)
+ if (!threeargs)
offset = is_index ? 0 : biglen;
else {
if (big_utf8 && offset > 0)
@@ -3701,7 +3280,7 @@
}
SvREFCNT_dec(temp);
fail:
- PUSHi(retval + arybase);
+ PUSHi(retval);
RETURN;
}
@@ -3742,18 +3321,26 @@
dVAR; dSP; dTARGET;
char *tmps;
UV value;
+ SV *top = POPs;
- if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
+ SvGETMAGIC(top);
+ if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
+ && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
||
- (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
- if (IN_BYTES) {
- value = POPu; /* chr(-1) eq chr(0xff), etc. */
- } else {
- (void) POPs; /* Ignore the argument value. */
+ ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
+ && SvNV_nomg(top) < 0.0))) {
+ if (ckWARN(WARN_UTF8)) {
+ if (SvGMAGICAL(top)) {
+ SV *top2 = sv_newmortal();
+ sv_setsv_nomg(top2, top);
+ top = top2;
+ }
+ Perl_warner(aTHX_ packWARN(WARN_UTF8),
+ "Invalid negative number (%"SVf") in chr", top);
+ }
value = UNICODE_REPLACEMENT;
- }
} else {
- value = POPu;
+ value = SvUV_nomg(top);
}
SvUPGRADE(TARG,SVt_PV);
@@ -3779,8 +3366,10 @@
if (PL_encoding && !IN_BYTES) {
sv_recode_to_utf8(TARG, PL_encoding);
tmps = SvPVX(TARG);
- if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
- UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
+ if (SvCUR(TARG) == 0
+ || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
+ || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
+ {
SvGROW(TARG, 2);
tmps = SvPVX(TARG);
SvCUR_set(TARG, 1);
@@ -3846,17 +3435,9 @@
/* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
* most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
-/* Below are several macros that generate code */
/* Generates code to store a unicode codepoint c that is known to occupy
- * exactly two UTF-8 and UTF-EBCDIC bytes; it is stored into p and p+1. */
-#define STORE_UNI_TO_UTF8_TWO_BYTE(p, c) \
- STMT_START { \
- *(p) = UTF8_TWO_BYTE_HI(c); \
- *((p)+1) = UTF8_TWO_BYTE_LO(c); \
- } STMT_END
-
-/* Like STORE_UNI_TO_UTF8_TWO_BYTE, but advances p to point to the next
- * available byte after the two bytes */
+ * exactly two UTF-8 and UTF-EBCDIC bytes; it is stored into p and p+1,
+ * and p is advanced to point to the next available byte after the two bytes */
#define CAT_UNI_TO_UTF8_TWO_BYTE(p, c) \
STMT_START { \
*(p)++ = UTF8_TWO_BYTE_HI(c); \
@@ -3863,46 +3444,6 @@
*((p)++) = UTF8_TWO_BYTE_LO(c); \
} STMT_END
-/* Generates code to store the upper case of latin1 character l which is known
- * to have its upper case be non-latin1 into the two bytes p and p+1. There
- * are only two characters that fit this description, and this macro knows
- * about them, and that the upper case values fit into two UTF-8 or UTF-EBCDIC
- * bytes */
-#define STORE_NON_LATIN1_UC(p, l) \
-STMT_START { \
- if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
- STORE_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); \
- } else { /* Must be the following letter */ \
- STORE_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU); \
- } \
-} STMT_END
-
-/* Like STORE_NON_LATIN1_UC, but advances p to point to the next available byte
- * after the character stored */
-#define CAT_NON_LATIN1_UC(p, l) \
-STMT_START { \
- if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
- CAT_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); \
- } else { \
- CAT_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU); \
- } \
-} STMT_END
-
-/* Generates code to add the two UTF-8 bytes (probably u) that are the upper
- * case of l into p and p+1. u must be the result of toUPPER_LATIN1_MOD(l),
- * and must require two bytes to store it. Advances p to point to the next
- * available position */
-#define CAT_TWO_BYTE_UNI_UPPER_MOD(p, l, u) \
-STMT_START { \
- if ((u) != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
- CAT_UNI_TO_UTF8_TWO_BYTE((p), (u)); /* not special, just save it */ \
- } else if (l == LATIN_SMALL_LETTER_SHARP_S) { \
- *(p)++ = 'S'; *(p)++ = 'S'; /* upper case is 'SS' */ \
- } else {/* else is one of the other two special cases */ \
- CAT_NON_LATIN1_UC((p), (l)); \
- } \
-} STMT_END
-
PP(pp_ucfirst)
{
/* Actually is both lcfirst() and ucfirst(). Only the first character
@@ -3928,6 +3469,7 @@
STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
* lowercased) character stored in tmpbuf. May be either
* UTF-8 or not, but in either case is the number of bytes */
+ bool tainted = FALSE;
SvGETMAGIC(source);
if (SvOK(source)) {
@@ -3950,107 +3492,28 @@
if (! slen) { /* If empty */
need = 1; /* still need a trailing NUL */
+ ulen = 0;
}
else if (DO_UTF8(source)) { /* Is the source utf8? */
doing_utf8 = TRUE;
-
-/* TODO: This is #ifdefd out because it has hard-coded the standard mappings,
- * and doesn't allow for the user to specify their own. When code is added to
- * detect if there is a user-defined mapping in force here, and if so to use
- * that, then the code below can be compiled. The detection would be a good
- * thing anyway, as currently the user-defined mappings only work on utf8
- * strings, and thus depend on the chosen internal storage method, which is a
- * bad thing */
-#ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
- if (UTF8_IS_INVARIANT(*s)) {
-
- /* An invariant source character is either ASCII or, in EBCDIC, an
- * ASCII equivalent or a caseless C1 control. In both these cases,
- * the lower and upper cases of any character are also invariants
- * (and title case is the same as upper case). So it is safe to
- * use the simple case change macros which avoid the overhead of
- * the general functions. Note that if perl were to be extended to
- * do locale handling in UTF-8 strings, this wouldn't be true in,
- * for example, Lithuanian or Turkic. */
- *tmpbuf = (op_type == OP_LCFIRST) ? toLOWER(*s) : toUPPER(*s);
- tculen = ulen = 1;
- need = slen + 1;
+ ulen = UTF8SKIP(s);
+ if (op_type == OP_UCFIRST) {
+ _to_utf8_title_flags(s, tmpbuf, &tculen,
+ cBOOL(IN_LOCALE_RUNTIME), &tainted);
}
- else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
- U8 chr;
-
- /* Similarly, if the source character isn't invariant but is in the
- * latin1 range (or EBCDIC equivalent thereof), we have the case
- * changes compiled into perl, and can avoid the overhead of the
- * general functions. In this range, the characters are stored as
- * two UTF-8 bytes, and it so happens that any changed-case version
- * is also two bytes (in both ASCIIish and EBCDIC machines). */
- tculen = ulen = 2;
- need = slen + 1;
-
- /* Convert the two source bytes to a single Unicode code point
- * value, change case and save for below */
- chr = TWO_BYTE_UTF8_TO_UNI(*s, *(s+1));
- if (op_type == OP_LCFIRST) { /* lower casing is easy */
- U8 lower = toLOWER_LATIN1(chr);
- STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, lower);
- }
- else { /* ucfirst */
- U8 upper = toUPPER_LATIN1_MOD(chr);
-
- /* Most of the latin1 range characters are well-behaved. Their
- * title and upper cases are the same, and are also in the
- * latin1 range. The macro above returns their upper (hence
- * title) case, and all that need be done is to save the result
- * for below. However, several characters are problematic, and
- * have to be handled specially. The MOD in the macro name
- * above means that these tricky characters all get mapped to
- * the single character LATIN_SMALL_LETTER_Y_WITH_DIAERESIS.
- * This mapping saves some tests for the majority of the
- * characters */
-
- if (upper != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
-
- /* Not tricky. Just save it. */
- STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, upper);
- }
- else if (chr == LATIN_SMALL_LETTER_SHARP_S) {
-
- /* This one is tricky because it is two characters long,
- * though the UTF-8 is still two bytes, so the stored
- * length doesn't change */
- *tmpbuf = 'S'; /* The UTF-8 is 'Ss' */
- *(tmpbuf + 1) = 's';
- }
- else {
-
- /* The other two have their title and upper cases the same,
- * but are tricky because the changed-case characters
- * aren't in the latin1 range. They, however, do fit into
- * two UTF-8 bytes */
- STORE_NON_LATIN1_UC(tmpbuf, chr);
- }
- }
+ else {
+ _to_utf8_lower_flags(s, tmpbuf, &tculen,
+ cBOOL(IN_LOCALE_RUNTIME), &tainted);
}
- else {
-#endif /* end of dont want to break user-defined casing */
- /* Here, can't short-cut the general case */
-
- utf8_to_uvchr(s, &ulen);
- if (op_type == OP_UCFIRST) toTITLE_utf8(s, tmpbuf, &tculen);
- else toLOWER_utf8(s, tmpbuf, &tculen);
-
- /* we can't do in-place if the length changes. */
- if (ulen != tculen) inplace = FALSE;
- need = slen + 1 - ulen + tculen;
-#ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
- }
-#endif
+ /* we can't do in-place if the length changes. */
+ if (ulen != tculen) inplace = FALSE;
+ need = slen + 1 - ulen + tculen;
}
else { /* Non-zero length, non-UTF-8, Need to consider locale and if
* latin1 is treated as caseless. Note that a locale takes
* precedence */
+ ulen = 1; /* Original character is 1 byte */
tculen = 1; /* Most characters will require one byte, but this will
* need to be overridden for the tricky ones */
need = slen + 1;
@@ -4073,44 +3536,42 @@
* native function does */
}
else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
- *tmpbuf = toUPPER_LATIN1_MOD(*s);
+ UV title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
+ if (tculen > 1) {
+ assert(tculen == 2);
- /* tmpbuf now has the correct title case for all latin1 characters
- * except for the several ones that have tricky handling. All
- * of these are mapped by the MOD to the letter below. */
- if (*tmpbuf == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
-
- /* The length is going to change, with all three of these, so
- * can't replace just the first character */
- inplace = FALSE;
-
- /* We use the original to distinguish between these tricky
- * cases */
- if (*s == LATIN_SMALL_LETTER_SHARP_S) {
- /* Two character title case 'Ss', but can remain non-UTF-8 */
- need = slen + 2;
- *tmpbuf = 'S';
- *(tmpbuf + 1) = 's'; /* Assert: length(tmpbuf) >= 2 */
- tculen = 2;
+ /* If the result is an upper Latin1-range character, it can
+ * still be represented in one byte, which is its ordinal */
+ if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
+ *tmpbuf = (U8) title_ord;
+ tculen = 1;
}
else {
+ /* Otherwise it became more than one ASCII character (in
+ * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
+ * beyond Latin1, so the number of bytes changed, so can't
+ * replace just the first character in place. */
+ inplace = FALSE;
- /* The other two tricky ones have their title case outside
- * latin1. It is the same as their upper case. */
- doing_utf8 = TRUE;
- STORE_NON_LATIN1_UC(tmpbuf, *s);
+ /* If the result won't fit in a byte, the entire result
+ * will have to be in UTF-8. Assume worst case sizing in
+ * conversion. (all latin1 characters occupy at most two
+ * bytes in utf8) */
+ if (title_ord > 255) {
+ doing_utf8 = TRUE;
+ convert_source_to_utf8 = TRUE;
+ need = slen * 2 + 1;
- /* The UTF-8 and UTF-EBCDIC lengths of both these characters
- * and their upper cases is 2. */
- tculen = ulen = 2;
-
- /* The entire result will have to be in UTF-8. Assume worst
- * case sizing in conversion. (all latin1 characters occupy
- * at most two bytes in utf8) */
- convert_source_to_utf8 = TRUE;
- need = slen * 2 + 1;
+ /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
+ * (both) characters whose title case is above 255 is
+ * 2. */
+ ulen = 2;
+ }
+ else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
+ need = slen + 1 + 1;
+ }
}
- } /* End of is one of the three special chars */
+ }
} /* End of use Unicode (Latin1) semantics */
} /* End of changing the case of the first character */
@@ -4175,6 +3636,11 @@
Copy(tmpbuf, d, tculen, U8);
SvCUR_set(dest, need - 1);
}
+
+ if (tainted) {
+ TAINT;
+ SvTAINTED_on(dest);
+ }
}
else { /* Neither source nor dest are in or need to be UTF-8 */
if (slen) {
@@ -4280,6 +3746,7 @@
if (DO_UTF8(source)) {
const U8 *const send = s + len;
U8 tmpbuf[UTF8_MAXBYTES+1];
+ bool tainted = FALSE;
/* All occurrences of these are to be moved to follow any other marks.
* This is context-dependent. We may not be passed enough context to
@@ -4294,7 +3761,11 @@
bool in_iota_subscript = FALSE;
while (s < send) {
- if (in_iota_subscript && ! is_utf8_mark(s)) {
+ STRLEN u;
+ STRLEN ulen;
+ UV uv;
+ if (in_iota_subscript && ! _is_utf8_mark(s)) {
+
/* A non-mark. Time to output the iota subscript */
#define GREEK_CAPITAL_LETTER_IOTA 0x0399
#define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
@@ -4301,63 +3772,37 @@
CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
in_iota_subscript = FALSE;
- }
+ }
+ /* Then handle the current character. Get the changed case value
+ * and copy it to the output buffer */
-/* See comments at the first instance in this file of this ifdef */
-#ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
+ u = UTF8SKIP(s);
+ uv = _to_utf8_upper_flags(s, tmpbuf, &ulen,
+ cBOOL(IN_LOCALE_RUNTIME), &tainted);
+ if (uv == GREEK_CAPITAL_LETTER_IOTA
+ && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
+ {
+ in_iota_subscript = TRUE;
+ }
+ else {
+ if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
+ /* If the eventually required minimum size outgrows the
+ * available space, we need to grow. */
+ const UV o = d - (U8*)SvPVX_const(dest);
- /* If the UTF-8 character is invariant, then it is in the range
- * known by the standard macro; result is only one byte long */
- if (UTF8_IS_INVARIANT(*s)) {
- *d++ = toUPPER(*s);
- s++;
- }
- else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
-
- /* Likewise, if it fits in a byte, its case change is in our
- * table */
- U8 orig = TWO_BYTE_UTF8_TO_UNI(*s, *s++);
- U8 upper = toUPPER_LATIN1_MOD(orig);
- CAT_TWO_BYTE_UNI_UPPER_MOD(d, orig, upper);
- s++;
- }
- else {
-#else
- {
-#endif
-
- /* Otherwise, need the general UTF-8 case. Get the changed
- * case value and copy it to the output buffer */
-
- const STRLEN u = UTF8SKIP(s);
- STRLEN ulen;
-
- const UV uv = toUPPER_utf8(s, tmpbuf, &ulen);
- if (uv == GREEK_CAPITAL_LETTER_IOTA
- && utf8_to_uvchr(s, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
- {
- in_iota_subscript = TRUE;
- }
- else {
- if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
- /* If the eventually required minimum size outgrows
- * the available space, we need to grow. */
- const UV o = d - (U8*)SvPVX_const(dest);
-
- /* If someone uppercases one million U+03B0s we
- * SvGROW() one million times. Or we could try
- * guessing how much to allocate without allocating too
- * much. Such is life. See corresponding comment in
- * lc code for another option */
- SvGROW(dest, min);
- d = (U8*)SvPVX(dest) + o;
- }
- Copy(tmpbuf, d, ulen, U8);
- d += ulen;
- }
- s += u;
- }
+ /* If someone uppercases one million U+03B0s we SvGROW()
+ * one million times. Or we could try guessing how much to
+ * allocate without allocating too much. Such is life.
+ * See corresponding comment in lc code for another option
+ * */
+ SvGROW(dest, min);
+ d = (U8*)SvPVX(dest) + o;
+ }
+ Copy(tmpbuf, d, ulen, U8);
+ d += ulen;
+ }
+ s += u;
}
if (in_iota_subscript) {
CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
@@ -4364,7 +3809,12 @@
}
SvUTF8_on(dest);
*d = '\0';
+
SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
+ if (tainted) {
+ TAINT;
+ SvTAINTED_on(dest);
+ }
}
else { /* Not UTF-8 */
if (len) {
@@ -4387,7 +3837,9 @@
else {
for (; s < send; d++, s++) {
*d = toUPPER_LATIN1_MOD(*s);
- if (*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) continue;
+ if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
+ continue;
+ }
/* The mainstream case is the tight loop above. To avoid
* extra tests in that, all three characters that require
@@ -4448,23 +3900,13 @@
(send -s) * 2 + 1);
d = (U8*)SvPVX(dest) + len;
- /* And append the current character's upper case in UTF-8 */
- CAT_NON_LATIN1_UC(d, *s);
-
/* Now process the remainder of the source, converting to
* upper and UTF-8. If a resulting byte is invariant in
* UTF-8, output it as-is, otherwise convert to UTF-8 and
* append it to the output. */
-
- s++;
for (; s < send; s++) {
- U8 upper = toUPPER_LATIN1_MOD(*s);
- if UTF8_IS_INVARIANT(upper) {
- *d++ = upper;
- }
- else {
- CAT_TWO_BYTE_UNI_UPPER_MOD(d, *s, upper);
- }
+ (void) _to_upper_title_latin1(*s, d, &len, 'S');
+ d += len;
}
/* Here have processed the whole source; no need to continue
@@ -4543,139 +3985,47 @@
if (DO_UTF8(source)) {
const U8 *const send = s + len;
U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
+ bool tainted = FALSE;
while (s < send) {
-/* See comments at the first instance in this file of this ifdef */
-#ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
- if (UTF8_IS_INVARIANT(*s)) {
+ const STRLEN u = UTF8SKIP(s);
+ STRLEN ulen;
- /* Invariant characters use the standard mappings compiled in.
- */
- *d++ = toLOWER(*s);
- s++;
- }
- else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
+ _to_utf8_lower_flags(s, tmpbuf, &ulen,
+ cBOOL(IN_LOCALE_RUNTIME), &tainted);
- /* As do the ones in the Latin1 range */
- U8 lower = toLOWER_LATIN1(TWO_BYTE_UTF8_TO_UNI(*s, *s++));
- CAT_UNI_TO_UTF8_TWO_BYTE(d, lower);
- s++;
- }
- else {
-#endif
- /* Here, is utf8 not in Latin-1 range, have to go out and get
- * the mappings from the tables. */
+ /* Here is where we would do context-sensitive actions. See the
+ * commit message for this comment for why there isn't any */
- const STRLEN u = UTF8SKIP(s);
- STRLEN ulen;
+ if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
-#ifndef CONTEXT_DEPENDENT_CASING
- toLOWER_utf8(s, tmpbuf, &ulen);
-#else
-/* This is ifdefd out because it needs more work and thought. It isn't clear
- * that we should do it.
- * A minor objection is that this is based on a hard-coded rule from the
- * Unicode standard, and may change, but this is not very likely at all.
- * mktables should check and warn if it does.
- * More importantly, if the sigma occurs at the end of the string, we don't
- * have enough context to know whether it is part of a larger string or going
- * to be or not. It may be that we are passed a subset of the context, via
- * a \U...\E, for example, and we could conceivably know the larger context if
- * code were changed to pass that in. But, if the string passed in is an
- * intermediate result, and the user concatenates two strings together
- * after we have made a final sigma, that would be wrong. If the final sigma
- * occurs in the middle of the string we are working on, then we know that it
- * should be a final sigma, but otherwise we can't be sure. */
+ /* If the eventually required minimum size outgrows the
+ * available space, we need to grow. */
+ const UV o = d - (U8*)SvPVX_const(dest);
- const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
+ /* If someone lowercases one million U+0130s we SvGROW() one
+ * million times. Or we could try guessing how much to
+ * allocate without allocating too much. Such is life.
+ * Another option would be to grow an extra byte or two more
+ * each time we need to grow, which would cut down the million
+ * to 500K, with little waste */
+ SvGROW(dest, min);
+ d = (U8*)SvPVX(dest) + o;
+ }
- /* If the lower case is a small sigma, it may be that we need
- * to change it to a final sigma. This happens at the end of
- * a word that contains more than just this character, and only
- * when we started with a capital sigma. */
- if (uv == UNICODE_GREEK_SMALL_LETTER_SIGMA &&
- s > send - len && /* Makes sure not the first letter */
- utf8_to_uvchr(s, 0) == UNICODE_GREEK_CAPITAL_LETTER_SIGMA
- ) {
-
- /* We use the algorithm in:
- * http://www.unicode.org/versions/Unicode5.0.0/ch03.pdf (C
- * is a CAPITAL SIGMA): If C is preceded by a sequence
- * consisting of a cased letter and a case-ignorable
- * sequence, and C is not followed by a sequence consisting
- * of a case ignorable sequence and then a cased letter,
- * then when lowercasing C, C becomes a final sigma */
-
- /* To determine if this is the end of a word, need to peek
- * ahead. Look at the next character */
- const U8 *peek = s + u;
-
- /* Skip any case ignorable characters */
- while (peek < send && is_utf8_case_ignorable(peek)) {
- peek += UTF8SKIP(peek);
- }
-
- /* If we reached the end of the string without finding any
- * non-case ignorable characters, or if the next such one
- * is not-cased, then we have met the conditions for it
- * being a final sigma with regards to peek ahead, and so
- * must do peek behind for the remaining conditions. (We
- * know there is stuff behind to look at since we tested
- * above that this isn't the first letter) */
- if (peek >= send || ! is_utf8_cased(peek)) {
- peek = utf8_hop(s, -1);
-
- /* Here are at the beginning of the first character
- * before the original upper case sigma. Keep backing
- * up, skipping any case ignorable characters */
- while (is_utf8_case_ignorable(peek)) {
- peek = utf8_hop(peek, -1);
- }
-
- /* Here peek points to the first byte of the closest
- * non-case-ignorable character before the capital
- * sigma. If it is cased, then by the Unicode
- * algorithm, we should use a small final sigma instead
- * of what we have */
- if (is_utf8_cased(peek)) {
- STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf,
- UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA);
- }
- }
- }
- else { /* Not a context sensitive mapping */
-#endif /* End of commented out context sensitive */
- if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
-
- /* If the eventually required minimum size outgrows
- * the available space, we need to grow. */
- const UV o = d - (U8*)SvPVX_const(dest);
-
- /* If someone lowercases one million U+0130s we
- * SvGROW() one million times. Or we could try
- * guessing how much to allocate without allocating too
- * much. Such is life. Another option would be to
- * grow an extra byte or two more each time we need to
- * grow, which would cut down the million to 500K, with
- * little waste */
- SvGROW(dest, min);
- d = (U8*)SvPVX(dest) + o;
- }
-#ifdef CONTEXT_DEPENDENT_CASING
- }
-#endif
- /* Copy the newly lowercased letter to the output buffer we're
- * building */
- Copy(tmpbuf, d, ulen, U8);
- d += ulen;
- s += u;
-#ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
- }
-#endif
+ /* Copy the newly lowercased letter to the output buffer we're
+ * building */
+ Copy(tmpbuf, d, ulen, U8);
+ d += ulen;
+ s += u;
} /* End of looping through the source string */
SvUTF8_on(dest);
*d = '\0';
SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
+ if (tainted) {
+ TAINT;
+ SvTAINTED_on(dest);
+ }
} else { /* Not utf8 */
if (len) {
const U8 *const send = s + len;
@@ -4716,36 +4066,61 @@
dVAR; dSP; dTARGET;
SV * const sv = TOPs;
STRLEN len;
- register const char *s = SvPV_const(sv,len);
+ const char *s = SvPV_const(sv,len);
SvUTF8_off(TARG); /* decontaminate */
if (len) {
- register char *d;
+ char *d;
SvUPGRADE(TARG, SVt_PV);
SvGROW(TARG, (len * 2) + 1);
d = SvPVX(TARG);
if (DO_UTF8(sv)) {
while (len) {
- if (UTF8_IS_CONTINUED(*s)) {
- STRLEN ulen = UTF8SKIP(s);
- if (ulen > len)
- ulen = len;
- len -= ulen;
- while (ulen--)
- *d++ = *s++;
+ STRLEN ulen = UTF8SKIP(s);
+ bool to_quote = FALSE;
+
+ if (UTF8_IS_INVARIANT(*s)) {
+ if (_isQUOTEMETA(*s)) {
+ to_quote = TRUE;
+ }
}
- else {
- if (!isALNUM(*s))
- *d++ = '\\';
+ else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
+
+ /* In locale, we quote all non-ASCII Latin1 chars.
+ * Otherwise use the quoting rules */
+ if (IN_LOCALE_RUNTIME
+ || _isQUOTEMETA(TWO_BYTE_UTF8_TO_UNI(*s, *(s + 1))))
+ {
+ to_quote = TRUE;
+ }
+ }
+ else if (is_QUOTEMETA_high(s)) {
+ to_quote = TRUE;
+ }
+
+ if (to_quote) {
+ *d++ = '\\';
+ }
+ if (ulen > len)
+ ulen = len;
+ len -= ulen;
+ while (ulen--)
*d++ = *s++;
- len--;
- }
}
SvUTF8_on(TARG);
}
+ else if (IN_UNI_8_BIT) {
+ while (len--) {
+ if (_isQUOTEMETA(*s))
+ *d++ = '\\';
+ *d++ = *s++;
+ }
+ }
else {
+ /* For non UNI_8_BIT (and hence in locale) just quote all \W
+ * including everything above ASCII */
while (len--) {
- if (!isALNUM(*s))
+ if (!isWORDCHAR_A(*s))
*d++ = '\\';
*d++ = *s++;
}
@@ -4760,16 +4135,168 @@
RETURN;
}
+PP(pp_fc)
+{
+ dVAR;
+ dTARGET;
+ dSP;
+ SV *source = TOPs;
+ STRLEN len;
+ STRLEN min;
+ SV *dest;
+ const U8 *s;
+ const U8 *send;
+ U8 *d;
+ U8 tmpbuf[UTF8_MAXBYTES * UTF8_MAX_FOLD_CHAR_EXPAND + 1];
+ const bool full_folding = TRUE;
+ const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
+ | ( IN_LOCALE_RUNTIME ? FOLD_FLAGS_LOCALE : 0 );
+
+ /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
+ * You are welcome(?) -Hugmeir
+ */
+
+ SvGETMAGIC(source);
+
+ dest = TARG;
+
+ if (SvOK(source)) {
+ s = (const U8*)SvPV_nomg_const(source, len);
+ } else {
+ if (ckWARN(WARN_UNINITIALIZED))
+ report_uninit(source);
+ s = (const U8*)"";
+ len = 0;
+ }
+
+ min = len + 1;
+
+ SvUPGRADE(dest, SVt_PV);
+ d = (U8*)SvGROW(dest, min);
+ (void)SvPOK_only(dest);
+
+ SETs(dest);
+
+ send = s + len;
+ if (DO_UTF8(source)) { /* UTF-8 flagged string. */
+ bool tainted = FALSE;
+ while (s < send) {
+ const STRLEN u = UTF8SKIP(s);
+ STRLEN ulen;
+
+ _to_utf8_fold_flags(s, tmpbuf, &ulen, flags, &tainted);
+
+ if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
+ const UV o = d - (U8*)SvPVX_const(dest);
+ SvGROW(dest, min);
+ d = (U8*)SvPVX(dest) + o;
+ }
+
+ Copy(tmpbuf, d, ulen, U8);
+ d += ulen;
+ s += u;
+ }
+ SvUTF8_on(dest);
+ if (tainted) {
+ TAINT;
+ SvTAINTED_on(dest);
+ }
+ } /* Unflagged string */
+ else if (len) {
+ /* For locale, bytes, and nothing, the behavior is supposed to be the
+ * same as lc().
+ */
+ if ( IN_LOCALE_RUNTIME ) { /* Under locale */
+ TAINT;
+ SvTAINTED_on(dest);
+ for (; s < send; d++, s++)
+ *d = toLOWER_LC(*s);
+ }
+ else if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
+ for (; s < send; d++, s++)
+ *d = toLOWER(*s);
+ }
+ else {
+ /* For ASCII and the Latin-1 range, there's only two troublesome
+ * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
+ * casefolding becomes 'ss', and \x{B5} (\N{MICRO SIGN}), which
+ * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
+ * For the rest, the casefold is their lowercase. */
+ for (; s < send; d++, s++) {
+ if (*s == MICRO_SIGN) {
+ /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
+ * which is outside of the latin-1 range. There's a couple
+ * of ways to deal with this -- khw discusses them in
+ * pp_lc/uc, so go there :) What we do here is upgrade what
+ * we had already casefolded, then enter an inner loop that
+ * appends the rest of the characters as UTF-8. */
+ len = d - (U8*)SvPVX_const(dest);
+ SvCUR_set(dest, len);
+ len = sv_utf8_upgrade_flags_grow(dest,
+ SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
+ /* The max expansion for latin1
+ * chars is 1 byte becomes 2 */
+ (send -s) * 2 + 1);
+ d = (U8*)SvPVX(dest) + len;
+
+ CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_SMALL_LETTER_MU);
+ s++;
+ for (; s < send; s++) {
+ STRLEN ulen;
+ UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
+ if UNI_IS_INVARIANT(fc) {
+ if (full_folding
+ && *s == LATIN_SMALL_LETTER_SHARP_S)
+ {
+ *d++ = 's';
+ *d++ = 's';
+ }
+ else
+ *d++ = (U8)fc;
+ }
+ else {
+ Copy(tmpbuf, d, ulen, U8);
+ d += ulen;
+ }
+ }
+ break;
+ }
+ else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
+ /* Under full casefolding, LATIN SMALL LETTER SHARP S
+ * becomes "ss", which may require growing the SV. */
+ if (SvLEN(dest) < ++min) {
+ const UV o = d - (U8*)SvPVX_const(dest);
+ SvGROW(dest, min);
+ d = (U8*)SvPVX(dest) + o;
+ }
+ *(d)++ = 's';
+ *d = 's';
+ }
+ else { /* If it's not one of those two, the fold is their lower
+ case */
+ *d = toLOWER_LATIN1(*s);
+ }
+ }
+ }
+ }
+ *d = '\0';
+ SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
+
+ if (SvTAINTED(source))
+ SvTAINT(dest);
+ SvSETMAGIC(dest);
+ RETURN;
+}
+
/* Arrays. */
PP(pp_aslice)
{
dVAR; dSP; dMARK; dORIGMARK;
- register AV *const av = MUTABLE_AV(POPs);
- register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
+ AV *const av = MUTABLE_AV(POPs);
+ const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
if (SvTYPE(av) == SVt_PVAV) {
- const I32 arybase = CopARYBASE_get(PL_curcop);
const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
bool can_preserve = FALSE;
@@ -4781,7 +4308,7 @@
}
if (lval && localizing) {
- register SV **svp;
+ SV **svp;
I32 max = -1;
for (svp = MARK + 1; svp <= SP; svp++) {
const I32 elem = SvIV(*svp);
@@ -4793,12 +4320,10 @@
}
while (++MARK <= SP) {
- register SV **svp;
+ SV **svp;
I32 elem = SvIV(*MARK);
bool preeminent = TRUE;
- if (elem > 0)
- elem -= arybase;
if (localizing && can_preserve) {
/* If we can determine whether the element exist,
* Try to preserve the existenceness of a tied array
@@ -4862,7 +4387,9 @@
return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
}
else {
- return (SvTYPE(sv) == SVt_PVHV) ? Perl_pp_each(aTHX) : Perl_pp_aeach(aTHX);
+ return (SvTYPE(sv) == SVt_PVHV)
+ ? Perl_pp_each(aTHX)
+ : Perl_pp_aeach(aTHX);
}
}
@@ -4884,7 +4411,7 @@
}
EXTEND(SP, 2);
- mPUSHi(CopARYBASE_get(PL_curcop) + current);
+ mPUSHi(current);
if (gimme == G_ARRAY) {
SV **const element = av_fetch(array, current, 0);
PUSHs(element ? *element : &PL_sv_undef);
@@ -4907,13 +4434,12 @@
}
else if (gimme == G_ARRAY) {
IV n = Perl_av_len(aTHX_ array);
- IV i = CopARYBASE_get(PL_curcop);
+ IV i;
EXTEND(SP, n + 1);
if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
- n += i;
- for (; i <= n; i++) {
+ for (i = 0; i <= n; i++) {
mPUSHi(i);
}
}
@@ -4969,18 +4495,20 @@
const I32 gimme = GIMME_V;
const MAGIC *mg;
HV *stash;
+ const bool sliced = !!(PL_op->op_private & OPpSLICE);
+ SV *unsliced_keysv = sliced ? NULL : POPs;
+ SV * const osv = POPs;
+ SV **mark = sliced ? PL_stack_base + POPMARK : &unsliced_keysv-1;
+ dORIGMARK;
+ const bool tied = SvRMAGICAL(osv)
+ && mg_find((const SV *)osv, PERL_MAGIC_tied);
+ const bool can_preserve = SvCANEXISTDELETE(osv);
+ const U32 type = SvTYPE(osv);
+ SV ** const end = sliced ? SP : &unsliced_keysv;
- if (PL_op->op_private & OPpSLICE) {
- dMARK; dORIGMARK;
- SV * const osv = POPs;
- const bool tied = SvRMAGICAL(osv)
- && mg_find((const SV *)osv, PERL_MAGIC_tied);
- const bool can_preserve = SvCANEXISTDELETE(osv)
- || mg_find((const SV *)osv, PERL_MAGIC_env);
- const U32 type = SvTYPE(osv);
- if (type == SVt_PVHV) { /* hash element */
+ if (type == SVt_PVHV) { /* hash element */
HV * const hv = MUTABLE_HV(osv);
- while (++MARK <= SP) {
+ while (++MARK <= end) {
SV * const keysv = *MARK;
SV *sv = NULL;
bool preeminent = TRUE;
@@ -4998,6 +4526,7 @@
SvREFCNT_inc_simple_void(sv); /* De-mortalize */
}
if (preeminent) {
+ if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
if (tied) {
*MARK = sv_mortalcopy(sv);
@@ -5010,11 +4539,11 @@
*MARK = &PL_sv_undef;
}
}
- }
- else if (type == SVt_PVAV) { /* array element */
+ }
+ else if (type == SVt_PVAV) { /* array element */
if (PL_op->op_flags & OPf_SPECIAL) {
AV * const av = MUTABLE_AV(osv);
- while (++MARK <= SP) {
+ while (++MARK <= end) {
I32 idx = SvIV(*MARK);
SV *sv = NULL;
bool preeminent = TRUE;
@@ -5045,9 +4574,12 @@
}
}
}
- }
- else
+ else
+ DIE(aTHX_ "panic: avhv_delete no longer supported");
+ }
+ else
DIE(aTHX_ "Not a HASH reference");
+ if (sliced) {
if (gimme == G_VOID)
SP = ORIGMARK;
else if (gimme == G_SCALAR) {
@@ -5059,81 +4591,8 @@
SP = MARK;
}
}
- else {
- SV * const keysv = POPs;
- SV * const osv = POPs;
- const bool tied = SvRMAGICAL(osv)
- && mg_find((const SV *)osv, PERL_MAGIC_tied);
- const bool can_preserve = SvCANEXISTDELETE(osv)
- || mg_find((const SV *)osv, PERL_MAGIC_env);
- const U32 type = SvTYPE(osv);
- SV *sv = NULL;
- if (type == SVt_PVHV) {
- HV * const hv = MUTABLE_HV(osv);
- bool preeminent = TRUE;
- if (can_preserve)
- preeminent = hv_exists_ent(hv, keysv, 0);
- if (tied) {
- HE *he = hv_fetch_ent(hv, keysv, 1, 0);
- if (he)
- sv = HeVAL(he);
- else
- preeminent = FALSE;
- }
- else {
- sv = hv_delete_ent(hv, keysv, 0, 0);
- SvREFCNT_inc_simple_void(sv); /* De-mortalize */
- }
- if (preeminent) {
- save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
- if (tied) {
- SV *nsv = sv_mortalcopy(sv);
- mg_clear(sv);
- sv = nsv;
- }
- }
- else
- SAVEHDELETE(hv, keysv);
- }
- else if (type == SVt_PVAV) {
- if (PL_op->op_flags & OPf_SPECIAL) {
- AV * const av = MUTABLE_AV(osv);
- I32 idx = SvIV(keysv);
- bool preeminent = TRUE;
- if (can_preserve)
- preeminent = av_exists(av, idx);
- if (tied) {
- SV **svp = av_fetch(av, idx, 1);
- if (svp)
- sv = *svp;
- else
- preeminent = FALSE;
- }
- else {
- sv = av_delete(av, idx, 0);
- SvREFCNT_inc_simple_void(sv); /* De-mortalize */
- }
- if (preeminent) {
- save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
- if (tied) {
- SV *nsv = sv_mortalcopy(sv);
- mg_clear(sv);
- sv = nsv;
- }
- }
- else
- SAVEADELETE(av, idx);
- }
- else
- DIE(aTHX_ "panic: avhv_delete no longer supported");
- }
- else
- DIE(aTHX_ "Not a HASH reference");
- if (!sv)
- sv = &PL_sv_undef;
- if (gimme != G_VOID)
- PUSHs(sv);
- }
+ else if (gimme != G_VOID)
+ PUSHs(unsliced_keysv);
RETURN;
}
@@ -5242,8 +4701,8 @@
PP(pp_hslice)
{
dVAR; dSP; dMARK; dORIGMARK;
- register HV * const hv = MUTABLE_HV(POPs);
- register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
+ HV * const hv = MUTABLE_HV(POPs);
+ const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
bool can_preserve = FALSE;
@@ -5251,7 +4710,7 @@
MAGIC *mg;
HV *stash;
- if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
+ if (SvCANEXISTDELETE(hv))
can_preserve = TRUE;
}
@@ -5273,7 +4732,7 @@
svp = he ? &HeVAL(he) : NULL;
if (lval) {
- if (!svp || *svp == &PL_sv_undef) {
+ if (!svp || !*svp || *svp == &PL_sv_undef) {
DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
}
if (localizing) {
@@ -5286,7 +4745,7 @@
SAVEHDELETE(hv, keysv);
}
}
- *MARK = svp ? *svp : &PL_sv_undef;
+ *MARK = svp && *svp ? *svp : &PL_sv_undef;
}
if (GIMME != G_ARRAY) {
MARK = ORIGMARK;
@@ -5318,19 +4777,16 @@
SV ** const lastrelem = PL_stack_sp;
SV ** const lastlelem = PL_stack_base + POPMARK;
SV ** const firstlelem = PL_stack_base + POPMARK + 1;
- register SV ** const firstrelem = lastlelem + 1;
- const I32 arybase = CopARYBASE_get(PL_curcop);
+ SV ** const firstrelem = lastlelem + 1;
I32 is_something_there = FALSE;
- register const I32 max = lastrelem - lastlelem;
- register SV **lelem;
+ const I32 max = lastrelem - lastlelem;
+ SV **lelem;
if (GIMME != G_ARRAY) {
I32 ix = SvIV(*lastlelem);
if (ix < 0)
ix += max;
- else
- ix -= arybase;
if (ix < 0 || ix >= max)
*firstlelem = &PL_sv_undef;
else
@@ -5348,8 +4804,6 @@
I32 ix = SvIV(*lelem);
if (ix < 0)
ix += max;
- else
- ix -= arybase;
if (ix < 0 || ix >= max)
*lelem = &PL_sv_undef;
else {
@@ -5379,20 +4833,30 @@
PP(pp_anonhash)
{
dVAR; dSP; dMARK; dORIGMARK;
- HV* const hv = newHV();
+ HV* const hv = (HV *)sv_2mortal((SV *)newHV());
while (MARK < SP) {
- SV * const key = *++MARK;
- SV * const val = newSV(0);
+ SV * const key =
+ (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
+ SV *val;
if (MARK < SP)
- sv_setsv(val, *++MARK);
+ {
+ MARK++;
+ SvGETMAGIC(*MARK);
+ val = newSV(0);
+ sv_setsv(val, *MARK);
+ }
else
+ {
Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
+ val = newSV(0);
+ }
(void)hv_store_ent(hv,key,val,0);
}
SP = ORIGMARK;
- mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
- ? newRV_noinc(MUTABLE_SV(hv)) : MUTABLE_SV(hv));
+ if (PL_op->op_flags & OPf_SPECIAL)
+ mXPUSHs(newRV_inc(MUTABLE_SV(hv)));
+ else XPUSHs(MUTABLE_SV(hv));
RETURN;
}
@@ -5429,12 +4893,13 @@
PP(pp_splice)
{
dVAR; dSP; dMARK; dORIGMARK;
- register AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
- register SV **src;
- register SV **dst;
- register I32 i;
- register I32 offset;
- register I32 length;
+ int num_args = (SP - MARK);
+ AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
+ SV **src;
+ SV **dst;
+ I32 i;
+ I32 offset;
+ I32 length;
I32 newlen;
I32 after;
I32 diff;
@@ -5452,8 +4917,6 @@
offset = i = SvIV(*MARK);
if (offset < 0)
offset += AvFILLp(ary) + 1;
- else
- offset -= CopARYBASE_get(PL_curcop);
if (offset < 0)
DIE(aTHX_ PL_no_aelem, i);
if (++MARK < SP) {
@@ -5472,7 +4935,8 @@
length = AvMAX(ary) + 1;
}
if (offset > AvFILLp(ary) + 1) {
- Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
+ if (num_args > 2)
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
offset = AvFILLp(ary) + 1;
}
after = AvFILLp(ary) + 1 - (offset + length);
@@ -5632,7 +5096,7 @@
PP(pp_push)
{
dVAR; dSP; dMARK; dORIGMARK; dTARGET;
- register AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
+ AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
if (mg) {
@@ -5645,11 +5109,14 @@
SPAGAIN;
}
else {
+ if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
PL_delaymagic = DM_DELAY;
for (++MARK; MARK <= SP; MARK++) {
- SV * const sv = newSV(0);
+ SV *sv;
+ if (*MARK) SvGETMAGIC(*MARK);
+ sv = newSV(0);
if (*MARK)
- sv_setsv(sv, *MARK);
+ sv_setsv_nomg(sv, *MARK);
av_store(ary, AvFILLp(ary)+1, sv);
}
if (PL_delaymagic & DM_ARRAY_ISA)
@@ -5682,7 +5149,7 @@
PP(pp_unshift)
{
dVAR; dSP; dMARK; dORIGMARK; dTARGET;
- register AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
+ AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
if (mg) {
@@ -5695,7 +5162,7 @@
SPAGAIN;
}
else {
- register I32 i = 0;
+ I32 i = 0;
av_unshift(ary, SP - MARK);
while (MARK < SP) {
SV * const sv = newSVsv(*++MARK);
@@ -5727,7 +5194,7 @@
if (SvMAGICAL(av)) {
I32 i, j;
- register SV *tmp = sv_newmortal();
+ SV *tmp = sv_newmortal();
/* For SvCANEXISTDELETE */
HV *stash;
const MAGIC *mg;
@@ -5734,12 +5201,12 @@
bool can_preserve = SvCANEXISTDELETE(av);
for (i = 0, j = av_len(av); i < j; ++i, --j) {
- register SV *begin, *end;
+ SV *begin, *end;
if (can_preserve) {
if (!av_exists(av, i)) {
if (av_exists(av, j)) {
- register SV *sv = av_delete(av, j, 0);
+ SV *sv = av_delete(av, j, 0);
begin = *av_fetch(av, i, TRUE);
sv_setsv_mg(begin, sv);
}
@@ -5746,7 +5213,7 @@
continue;
}
else if (!av_exists(av, j)) {
- register SV *sv = av_delete(av, i, 0);
+ SV *sv = av_delete(av, i, 0);
end = *av_fetch(av, j, TRUE);
sv_setsv_mg(end, sv);
continue;
@@ -5767,7 +5234,7 @@
SV **end = begin + AvFILLp(av);
while (begin < end) {
- register SV * const tmp = *begin;
+ SV * const tmp = *begin;
*begin++ = *end;
*end-- = tmp;
}
@@ -5778,7 +5245,7 @@
SV **oldsp = SP;
MARK++;
while (MARK < SP) {
- register SV * const tmp = *MARK;
+ SV * const tmp = *MARK;
*MARK++ = *SP;
*SP-- = tmp;
}
@@ -5787,9 +5254,9 @@
}
}
else {
- register char *up;
- register char *down;
- register I32 tmp;
+ char *up;
+ char *down;
+ I32 tmp;
dTARGET;
STRLEN len;
@@ -5813,7 +5280,7 @@
continue;
}
else {
- if (!utf8_to_uvchr(s, 0))
+ if (!utf8_to_uvchr_buf(s, send, 0))
break;
up = (char*)s;
s += UTF8SKIP(s);
@@ -5846,18 +5313,20 @@
{
dVAR; dSP; dTARG;
AV *ary;
- register IV limit = POPi; /* note, negative is forever */
+ IV limit = POPi; /* note, negative is forever */
SV * const sv = POPs;
STRLEN len;
- register const char *s = SvPV_const(sv, len);
+ const char *s = SvPV_const(sv, len);
const bool do_utf8 = DO_UTF8(sv);
const char *strend = s + len;
- register PMOP *pm;
- register REGEXP *rx;
- register SV *dstr;
- register const char *m;
+ PMOP *pm;
+ REGEXP *rx;
+ SV *dstr;
+ const char *m;
I32 iters = 0;
- const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
+ const STRLEN slen = do_utf8
+ ? utf8_length((U8*)s, (U8*)strend)
+ : (STRLEN)(strend - s);
I32 maxiters = slen + 10;
I32 trailing_empty = 0;
const char *orig;
@@ -5877,11 +5346,11 @@
pm = (PMOP*)POPs;
#endif
if (!pm || !s)
- DIE(aTHX_ "panic: pp_split");
+ DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
rx = PM_GETRE(pm);
TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
- (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
+ (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
RX_MATCH_UTF8_set(rx, do_utf8);
@@ -5896,7 +5365,7 @@
#endif
else
ary = NULL;
- if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
+ if (ary) {
realarray = 1;
PUTBACK;
av_extend(ary,0);
@@ -5912,7 +5381,7 @@
AvREAL_on(ary);
AvREIFY_off(ary);
for (i = AvFILLp(ary); i >= 0; i--)
- AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
+ AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
}
/* temporarily switch stacks */
SAVESWITCHSTACK(PL_curstack, ary);
@@ -5923,7 +5392,7 @@
orig = s;
if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
if (do_utf8) {
- while (*s == ' ' || is_utf8_space((U8*)s))
+ while (isSPACE_utf8(s))
s += UTF8SKIP(s);
}
else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
@@ -5948,9 +5417,9 @@
m = s;
/* this one uses 'm' and is a negative test */
if (do_utf8) {
- while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
+ while (m < strend && ! isSPACE_utf8(m) ) {
const int t = UTF8SKIP(m);
- /* is_utf8_space returns FALSE for malform utf8 */
+ /* isSPACE_utf8 returns FALSE for malform utf8 */
if (strend - m < t)
m = strend;
else
@@ -5957,7 +5426,8 @@
m += t;
}
}
- else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
+ else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
+ {
while (m < strend && !isSPACE_LC(*m))
++m;
} else {
@@ -5987,10 +5457,11 @@
/* this one uses 's' and is a positive test */
if (do_utf8) {
- while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
+ while (s < strend && isSPACE_utf8(s) )
s += UTF8SKIP(s);
}
- else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
+ else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
+ {
while (s < strend && isSPACE_LC(*s))
++s;
} else {
@@ -6102,7 +5573,7 @@
trailing_empty = 0;
} else {
dstr = newSVpvn_flags(s, m-s,
- (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
+ (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
XPUSHs(dstr);
}
/* The rx->minlen is in characters but we want to step
@@ -6126,7 +5597,7 @@
trailing_empty = 0;
} else {
dstr = newSVpvn_flags(s, m-s,
- (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
+ (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
XPUSHs(dstr);
}
/* The rx->minlen is in characters but we want to step
@@ -6144,19 +5615,15 @@
{
I32 rex_return;
PUTBACK;
- rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
- sv, NULL, 0);
+ rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
+ sv, NULL, 0);
SPAGAIN;
if (rex_return == 0)
break;
TAINT_IF(RX_MATCH_TAINTED(rx));
- if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
- m = s;
- s = orig;
- orig = RX_SUBBEG(rx);
- s = orig + (m - s);
- strend = s + (strend - m);
- }
+ /* we never pass the REXEC_COPY_STR flag, so it should
+ * never get copied */
+ assert(!RX_MATCH_COPIED(rx));
m = RX_OFFS(rx)[0].start + orig;
if (gimme_scalar) {
@@ -6294,9 +5761,9 @@
dSP;
dTOPss;
SV *retsv = sv;
- assert(SvTYPE(retsv) != SVt_PVCV);
SvLOCK(sv);
- if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV) {
+ if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
+ || SvTYPE(retsv) == SVt_PVCV) {
retsv = refto(retsv);
}
SETs(retsv);
@@ -6323,32 +5790,170 @@
DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
}
-PP(pp_boolkeys)
+/* For sorting out arguments passed to a &CORE:: subroutine */
+PP(pp_coreargs)
{
- dVAR;
dSP;
- HV * const hv = (HV*)POPs;
-
- if (SvTYPE(hv) != SVt_PVHV) { XPUSHs(&PL_sv_no); RETURN; }
+ int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
+ int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
+ AV * const at_ = GvAV(PL_defgv);
+ SV **svp = at_ ? AvARRAY(at_) : NULL;
+ I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
+ I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
+ bool seen_question = 0;
+ const char *err = NULL;
+ const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
- if (SvRMAGICAL(hv)) {
- MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
- if (mg) {
- XPUSHs(magic_scalarpack(hv, mg));
+ /* Count how many args there are first, to get some idea how far to
+ extend the stack. */
+ while (oa) {
+ if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
+ maxargs++;
+ if (oa & OA_OPTIONAL) seen_question = 1;
+ if (!seen_question) minargs++;
+ oa >>= 4;
+ }
+
+ if(numargs < minargs) err = "Not enough";
+ else if(numargs > maxargs) err = "Too many";
+ if (err)
+ /* diag_listed_as: Too many arguments for %s */
+ Perl_croak(aTHX_
+ "%s arguments for %s", err,
+ opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
+ );
+
+ /* Reset the stack pointer. Without this, we end up returning our own
+ arguments in list context, in addition to the values we are supposed
+ to return. nextstate usually does this on sub entry, but we need
+ to run the next op with the caller's hints, so we cannot have a
+ nextstate. */
+ SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
+
+ if(!maxargs) RETURN;
+
+ /* We do this here, rather than with a separate pushmark op, as it has
+ to come in between two things this function does (stack reset and
+ arg pushing). This seems the easiest way to do it. */
+ if (pushmark) {
+ PUTBACK;
+ (void)Perl_pp_pushmark(aTHX);
+ }
+
+ EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
+ PUTBACK; /* The code below can die in various places. */
+
+ oa = PL_opargs[opnum] >> OASHIFT;
+ for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
+ whicharg++;
+ switch (oa & 7) {
+ case OA_SCALAR:
+ try_defsv:
+ if (!numargs && defgv && whicharg == minargs + 1) {
+ PUSHs(find_rundefsv2(
+ find_runcv_where(FIND_RUNCV_level_eq, 1, NULL),
+ cxstack[cxstack_ix].blk_oldcop->cop_seq
+ ));
+ }
+ else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
+ break;
+ case OA_LIST:
+ while (numargs--) {
+ PUSHs(svp && *svp ? *svp : &PL_sv_undef);
+ svp++;
+ }
RETURN;
- }
+ case OA_HVREF:
+ if (!svp || !*svp || !SvROK(*svp)
+ || SvTYPE(SvRV(*svp)) != SVt_PVHV)
+ DIE(aTHX_
+ /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
+ "Type of arg %d to &CORE::%s must be hash reference",
+ whicharg, OP_DESC(PL_op->op_next)
+ );
+ PUSHs(SvRV(*svp));
+ break;
+ case OA_FILEREF:
+ if (!numargs) PUSHs(NULL);
+ else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
+ /* no magic here, as the prototype will have added an extra
+ refgen and we just want what was there before that */
+ PUSHs(SvRV(*svp));
+ else {
+ const bool constr = PL_op->op_private & whicharg;
+ PUSHs(S_rv2gv(aTHX_
+ svp && *svp ? *svp : &PL_sv_undef,
+ constr, CopHINTS_get(PL_curcop) & HINT_STRICT_REFS,
+ !constr
+ ));
+ }
+ break;
+ case OA_SCALARREF:
+ if (!numargs) goto try_defsv;
+ else {
+ const bool wantscalar =
+ PL_op->op_private & OPpCOREARGS_SCALARMOD;
+ if (!svp || !*svp || !SvROK(*svp)
+ /* We have to permit globrefs even for the \$ proto, as
+ *foo is indistinguishable from ${\*foo}, and the proto-
+ type permits the latter. */
+ || SvTYPE(SvRV(*svp)) > (
+ wantscalar ? SVt_PVLV
+ : opnum == OP_LOCK || opnum == OP_UNDEF
+ ? SVt_PVCV
+ : SVt_PVHV
+ )
+ )
+ DIE(aTHX_
+ /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
+ "Type of arg %d to &CORE::%s must be %s",
+ whicharg, PL_op_name[opnum],
+ wantscalar
+ ? "scalar reference"
+ : opnum == OP_LOCK || opnum == OP_UNDEF
+ ? "reference to one of [$@%&*]"
+ : "reference to one of [$@%*]"
+ );
+ PUSHs(SvRV(*svp));
+ if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv
+ && cxstack[cxstack_ix].cx_type & CXp_HASARGS) {
+ /* Undo @_ localisation, so that sub exit does not undo
+ part of our undeffing. */
+ PERL_CONTEXT *cx = &cxstack[cxstack_ix];
+ POP_SAVEARRAY();
+ cx->cx_type &= ~ CXp_HASARGS;
+ assert(!AvREAL(cx->blk_sub.argarray));
+ }
+ }
+ break;
+ default:
+ DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
+ }
+ oa = oa >> 4;
}
- XPUSHs(boolSV(HvKEYS(hv) != 0));
RETURN;
}
+PP(pp_runcv)
+{
+ dSP;
+ CV *cv;
+ if (PL_op->op_private & OPpOFFBYONE) {
+ cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
+ }
+ else cv = find_runcv(NULL);
+ XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
+ RETURN;
+}
+
+
/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/pp.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/pp.h
===================================================================
--- trunk/contrib/perl/pp.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/pp.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -67,7 +67,7 @@
#define dSP SV **sp = PL_stack_sp
#define djSP dSP
-#define dMARK register SV **mark = PL_stack_base + POPMARK
+#define dMARK SV **mark = PL_stack_base + POPMARK
#define dORIGMARK const I32 origmark = (I32)(mark - PL_stack_base)
#define ORIGMARK (PL_stack_base + origmark)
@@ -97,10 +97,11 @@
Pops an SV off the stack.
=for apidoc Amn|char*|POPp
-Pops a string off the stack. Deprecated. New code should use POPpx.
+Pops a string off the stack.
=for apidoc Amn|char*|POPpx
-Pops a string off the stack.
+Pops a string off the stack. Identical to POPp. There are two names for
+historical reasons.
=for apidoc Amn|char*|POPpbytex
Pops a string off the stack which must consist of bytes i.e. characters < 256.
@@ -123,7 +124,7 @@
#define RETURNX(x) return (x, PUTBACK, NORMAL)
#define POPs (*sp--)
-#define POPp (SvPVx(POPs, PL_na)) /* deprecated */
+#define POPp POPpx
#define POPpx (SvPVx_nolen(POPs))
#define POPpconstx (SvPVx_nolen_const(POPs))
#define POPpbytex (SvPVbytex_nolen(POPs))
@@ -140,7 +141,7 @@
#define TOPs (*sp)
#define TOPm1s (*(sp-1))
#define TOPp1s (*(sp+1))
-#define TOPp (SvPV(TOPs, PL_na)) /* deprecated */
+#define TOPp TOPpx
#define TOPpx (SvPV_nolen(TOPs))
#define TOPn (SvNV(TOPs))
#define TOPi ((IV)SvIV(TOPs))
@@ -277,16 +278,15 @@
=cut
*/
-#define EXTEND(p,n) STMT_START { if (PL_stack_max - p < (int)(n)) { \
- sp = stack_grow(sp,p, (int) (n)); \
- } } STMT_END
+#define EXTEND(p,n) (void)(UNLIKELY(PL_stack_max - p < (int)(n)) && \
+ (sp = stack_grow(sp,p, (int) (n))))
/* Same thing, but update mark register too. */
-#define MEXTEND(p,n) STMT_START {if (PL_stack_max - p < (int)(n)) { \
- const int markoff = mark - PL_stack_base; \
- sp = stack_grow(sp,p,(int) (n)); \
- mark = PL_stack_base + markoff; \
- } } STMT_END
+#define MEXTEND(p,n) STMT_START {if (UNLIKELY(PL_stack_max - p < (int)(n))) {\
+ const int markoff = mark - PL_stack_base; \
+ sp = stack_grow(sp,p,(int) (n)); \
+ mark = PL_stack_base + markoff; \
+ } } STMT_END
#define PUSHs(s) (*++sp = (s))
#define PUSHTARG STMT_START { SvSETMAGIC(TARG); PUSHs(TARG); } STMT_END
@@ -295,7 +295,7 @@
#define PUSHi(i) STMT_START { sv_setiv(TARG, (IV)(i)); PUSHTARG; } STMT_END
#define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END
-#define XPUSHs(s) STMT_START { EXTEND(sp,1); (*++sp = (s)); } STMT_END
+#define XPUSHs(s) (EXTEND(sp,1), *++sp = (s))
#define XPUSHTARG STMT_START { SvSETMAGIC(TARG); XPUSHs(TARG); } STMT_END
#define XPUSHp(p,l) STMT_START { sv_setpvn(TARG, (p), (l)); XPUSHTARG; } STMT_END
#define XPUSHn(n) STMT_START { sv_setnv(TARG, (NV)(n)); XPUSHTARG; } STMT_END
@@ -345,15 +345,7 @@
#define dPOPXiirl(X) IV right = POPi; IV left = CAT2(X,i)
#define USE_LEFT(sv) \
- (SvOK(sv) || SvGMAGICAL(sv) || !(PL_op->op_flags & OPf_STACKED))
-#define dPOPXnnrl_ul(X) \
- NV right = POPn; \
- SV *leftsv = CAT2(X,s); \
- NV left = USE_LEFT(leftsv) ? SvNV(leftsv) : 0.0
-#define dPOPXiirl_ul(X) \
- IV right = POPi; \
- SV *leftsv = CAT2(X,s); \
- IV left = USE_LEFT(leftsv) ? SvIV(leftsv) : 0
+ (SvOK(sv) || !(PL_op->op_flags & OPf_STACKED))
#define dPOPXiirl_ul_nomg(X) \
IV right = (sp--, SvIV_nomg(TOPp1s)); \
SV *leftsv = CAT2(X,s); \
@@ -361,17 +353,13 @@
#define dPOPPOPssrl dPOPXssrl(POP)
#define dPOPPOPnnrl dPOPXnnrl(POP)
-#define dPOPPOPnnrl_ul dPOPXnnrl_ul(POP)
#define dPOPPOPiirl dPOPXiirl(POP)
-#define dPOPPOPiirl_ul dPOPXiirl_ul(POP)
#define dPOPTOPssrl dPOPXssrl(TOP)
#define dPOPTOPnnrl dPOPXnnrl(TOP)
-#define dPOPTOPnnrl_ul dPOPXnnrl_ul(TOP)
#define dPOPTOPnnrl_nomg \
NV right = SvNV_nomg(TOPs); NV left = (sp--, SvNV_nomg(TOPs))
#define dPOPTOPiirl dPOPXiirl(TOP)
-#define dPOPTOPiirl_ul dPOPXiirl_ul(TOP)
#define dPOPTOPiirl_ul_nomg dPOPXiirl_ul_nomg(TOP)
#define dPOPTOPiirl_nomg \
IV right = SvIV_nomg(TOPs); IV left = (sp--, SvIV_nomg(TOPs))
@@ -400,7 +388,7 @@
#define EXTEND_MORTAL(n) \
STMT_START { \
- if (PL_tmps_ix + (n) >= PL_tmps_max) \
+ if (UNLIKELY(PL_tmps_ix + (n) >= PL_tmps_max)) \
tmps_grow(n); \
} STMT_END
@@ -410,6 +398,7 @@
#define AMGf_unary 8
#define AMGf_numeric 0x10 /* for Perl_try_amagic_bin */
#define AMGf_set 0x20 /* for Perl_try_amagic_bin */
+#define AMGf_want_list 0x40
/* do SvGETMAGIC on the stack args before checking for overload */
@@ -431,25 +420,45 @@
/* No longer used in core. Use AMG_CALLunary instead */
#define AMG_CALLun(sv,meth) AMG_CALLunary(sv, CAT2(meth,_amg))
-#define tryAMAGICunTARGET(meth, shift, jump) \
+#define tryAMAGICunTARGETlist(meth, jump) \
STMT_START { \
- dATARGET; \
dSP; \
SV *tmpsv; \
- SV *arg= sp[shift]; \
+ SV *arg= *sp; \
+ int gimme = GIMME_V; \
if (SvAMAGIC(arg) && \
(tmpsv = amagic_call(arg, &PL_sv_undef, meth, \
- AMGf_noright | AMGf_unary))) { \
+ AMGf_want_list | AMGf_noright \
+ |AMGf_unary))) { \
SPAGAIN; \
- sp += shift; \
- sv_setsv(TARG, tmpsv); \
- if (opASSIGN) \
- sp--; \
- SETTARG; \
+ if (gimme == G_VOID) { \
+ (void)POPs; /* XXX ??? */ \
+ } \
+ else if (gimme == G_ARRAY) { \
+ int i; \
+ I32 len; \
+ assert(SvTYPE(tmpsv) == SVt_PVAV); \
+ len = av_len((AV *)tmpsv) + 1; \
+ (void)POPs; /* get rid of the arg */ \
+ EXTEND(sp, len); \
+ for (i = 0; i < len; ++i) \
+ PUSHs(av_shift((AV *)tmpsv)); \
+ } \
+ else { /* AMGf_want_scalar */ \
+ dATARGET; /* just use the arg's location */ \
+ sv_setsv(TARG, tmpsv); \
+ if (opASSIGN) \
+ sp--; \
+ SETTARG; \
+ } \
PUTBACK; \
if (jump) { \
+ OP *jump_o = NORMAL->op_next; \
+ while (jump_o->op_type == OP_NULL) \
+ jump_o = jump_o->op_next; \
+ assert(jump_o->op_type == OP_ENTERSUB); \
PL_markstack_ptr--; \
- return NORMAL->op_next->op_next; \
+ return jump_o->op_next; \
} \
return NORMAL; \
} \
@@ -484,8 +493,8 @@
#define SvCANEXISTDELETE(sv) \
(!SvRMAGICAL(sv) \
- || ((mg = mg_find((const SV *) sv, PERL_MAGIC_tied)) \
- && (stash = SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(sv), mg)))) \
+ || !(mg = mg_find((const SV *) sv, PERL_MAGIC_tied)) \
+ || ( (stash = SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(sv), mg)))) \
&& gv_fetchmethod_autoload(stash, "EXISTS", TRUE) \
&& gv_fetchmethod_autoload(stash, "DELETE", TRUE) \
) \
@@ -492,6 +501,7 @@
)
#ifdef PERL_CORE
+
/* These are just for Perl_tied_method(), which is not part of the public API.
Use 0x04 rather than the next available bit, to help the compiler if the
architecture can generate more efficient instructions. */
@@ -498,6 +508,24 @@
# define TIED_METHOD_MORTALIZE_NOT_NEEDED 0x04
# define TIED_METHOD_ARGUMENTS_ON_STACK 0x08
# define TIED_METHOD_SAY 0x10
+
+/* Used in various places that need to dereference a glob or globref */
+# define MAYBE_DEREF_GV_flags(sv,phlags) \
+ ( \
+ (void)(phlags & SV_GMAGIC && (SvGETMAGIC(sv),0)), \
+ isGV_with_GP(sv) \
+ ? (GV *)(sv) \
+ : SvROK(sv) && SvTYPE(SvRV(sv)) <= SVt_PVLV && \
+ (SvGETMAGIC(SvRV(sv)), isGV_with_GP(SvRV(sv))) \
+ ? (GV *)SvRV(sv) \
+ : NULL \
+ )
+# define MAYBE_DEREF_GV(sv) MAYBE_DEREF_GV_flags(sv,SV_GMAGIC)
+# define MAYBE_DEREF_GV_nomg(sv) MAYBE_DEREF_GV_flags(sv,0)
+
+# define FIND_RUNCV_padid_eq 1
+# define FIND_RUNCV_level_eq 2
+
#endif
/*
@@ -504,8 +532,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/pp.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/pp_ctl.c
===================================================================
--- trunk/contrib/perl/pp_ctl.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/pp_ctl.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -43,13 +43,20 @@
dVAR;
dSP;
I32 cxix;
+ const PERL_CONTEXT *cx;
EXTEND(SP, 1);
- cxix = dopoptosub(cxstack_ix);
- if (cxix < 0)
+ if (PL_op->op_private & OPpOFFBYONE) {
+ if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF;
+ }
+ else {
+ cxix = dopoptosub(cxstack_ix);
+ if (cxix < 0)
RETPUSHUNDEF;
+ cx = &cxstack[cxix];
+ }
- switch (cxstack[cxix].blk_gimme) {
+ switch (cx->blk_gimme) {
case G_ARRAY:
RETPUSHYES;
case G_SCALAR:
@@ -62,9 +69,6 @@
PP(pp_regcreset)
{
dVAR;
- /* XXXX Should store the old value to allow for tie/overload - and
- restore in regcomp, where marked with XXXX. */
- PL_reginterp_cnt = 0;
TAINT_NOT;
return NORMAL;
}
@@ -73,202 +77,131 @@
{
dVAR;
dSP;
- register PMOP *pm = (PMOP*)cLOGOP->op_other;
- SV *tmpstr;
+ PMOP *pm = (PMOP*)cLOGOP->op_other;
+ SV **args;
+ int nargs;
REGEXP *re = NULL;
+ REGEXP *new_re;
+ const regexp_engine *eng;
+ bool is_bare_re= FALSE;
+ if (PL_op->op_flags & OPf_STACKED) {
+ dMARK;
+ nargs = SP - MARK;
+ args = ++MARK;
+ }
+ else {
+ nargs = 1;
+ args = SP;
+ }
+
/* prevent recompiling under /o and ithreads. */
#if defined(USE_ITHREADS)
if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
- if (PL_op->op_flags & OPf_STACKED) {
- dMARK;
- SP = MARK;
- }
- else
- (void)POPs;
+ SP = args-1;
RETURN;
}
#endif
-#define tryAMAGICregexp(rx) \
- STMT_START { \
- SvGETMAGIC(rx); \
- if (SvROK(rx) && SvAMAGIC(rx)) { \
- SV *sv = AMG_CALLunary(rx, regexp_amg); \
- if (sv) { \
- if (SvROK(sv)) \
- sv = SvRV(sv); \
- if (SvTYPE(sv) != SVt_REGEXP) \
- Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \
- rx = sv; \
- } \
- } \
- } STMT_END
-
+ re = PM_GETRE(pm);
+ assert (re != (REGEXP*) &PL_sv_undef);
+ eng = re ? RX_ENGINE(re) : current_re_engine();
- if (PL_op->op_flags & OPf_STACKED) {
- /* multiple args; concatenate them */
- dMARK; dORIGMARK;
- tmpstr = PAD_SV(ARGTARG);
- sv_setpvs(tmpstr, "");
- while (++MARK <= SP) {
- SV *msv = *MARK;
- SV *sv;
+ /*
+ In the below logic: these are basically the same - check if this regcomp is part of a split.
- tryAMAGICregexp(msv);
+ (PL_op->op_pmflags & PMf_split )
+ (PL_op->op_next->op_type == OP_PUSHRE)
- if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) &&
- (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign)))
- {
- sv_setsv(tmpstr, sv);
- continue;
- }
- sv_catsv_nomg(tmpstr, msv);
- }
- SvSETMAGIC(tmpstr);
- SP = ORIGMARK;
- }
- else {
- tmpstr = POPs;
- tryAMAGICregexp(tmpstr);
- }
+ We could add a new mask for this and copy the PMf_split, if we did
+ some bit definition fiddling first.
-#undef tryAMAGICregexp
+ For now we leave this
+ */
- if (SvROK(tmpstr)) {
- SV * const sv = SvRV(tmpstr);
- if (SvTYPE(sv) == SVt_REGEXP)
- re = (REGEXP*) sv;
- }
- else if (SvTYPE(tmpstr) == SVt_REGEXP)
- re = (REGEXP*) tmpstr;
+ new_re = (eng->op_comp
+ ? eng->op_comp
+ : &Perl_re_op_compile
+ )(aTHX_ args, nargs, pm->op_code_list, eng, re,
+ &is_bare_re,
+ (pm->op_pmflags & RXf_PMf_FLAGCOPYMASK),
+ pm->op_pmflags |
+ (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0));
- if (re) {
- /* The match's LHS's get-magic might need to access this op's reg-
- exp (as is sometimes the case with $'; see bug 70764). So we
- must call get-magic now before we replace the regexp. Hopeful-
- ly this hack can be replaced with the approach described at
- http://www.nntp.perl.org/group/perl.perl5.porters/2007/03
- /msg122415.html some day. */
- if(pm->op_type == OP_MATCH) {
- SV *lhs;
- const bool was_tainted = PL_tainted;
- if (pm->op_flags & OPf_STACKED)
- lhs = TOPs;
- else if (pm->op_private & OPpTARGET_MY)
- lhs = PAD_SV(pm->op_targ);
- else lhs = DEFSV;
- SvGETMAGIC(lhs);
- /* Restore the previous value of PL_tainted (which may have been
- modified by get-magic), to avoid incorrectly setting the
- RXf_TAINTED flag further down. */
- PL_tainted = was_tainted;
+ if (pm->op_pmflags & PMf_HAS_CV)
+ ReANY(new_re)->qr_anoncv
+ = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ));
+
+ if (is_bare_re) {
+ REGEXP *tmp;
+ /* The match's LHS's get-magic might need to access this op's regexp
+ (e.g. $' =~ /$re/ while foo; see bug 70764). So we must call
+ get-magic now before we replace the regexp. Hopefully this hack can
+ be replaced with the approach described at
+ http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html
+ some day. */
+ if (pm->op_type == OP_MATCH) {
+ SV *lhs;
+ const bool was_tainted = TAINT_get;
+ if (pm->op_flags & OPf_STACKED)
+ lhs = args[-1];
+ else if (pm->op_private & OPpTARGET_MY)
+ lhs = PAD_SV(pm->op_targ);
+ else lhs = DEFSV;
+ SvGETMAGIC(lhs);
+ /* Restore the previous value of PL_tainted (which may have been
+ modified by get-magic), to avoid incorrectly setting the
+ RXf_TAINTED flag with RX_TAINT_on further down. */
+ TAINT_set(was_tainted);
+#if NO_TAINT_SUPPORT
+ PERL_UNUSED_VAR(was_tainted);
+#endif
}
+ tmp = reg_temp_copy(NULL, new_re);
+ ReREFCNT_dec(new_re);
+ new_re = tmp;
+ }
- re = reg_temp_copy(NULL, re);
- ReREFCNT_dec(PM_GETRE(pm));
- PM_SETRE(pm, re);
+ if (re != new_re) {
+ ReREFCNT_dec(re);
+ PM_SETRE(pm, new_re);
}
- else {
- STRLEN len = 0;
- const char *t = SvOK(tmpstr) ? SvPV_nomg_const(tmpstr, len) : "";
- re = PM_GETRE(pm);
- assert (re != (REGEXP*) &PL_sv_undef);
- /* Check against the last compiled regexp. */
- if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
- memNE(RX_PRECOMP(re), t, len))
- {
- const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
- U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
- if (re) {
- ReREFCNT_dec(re);
-#ifdef USE_ITHREADS
- PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
-#else
- PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
-#endif
- } else if (PL_curcop->cop_hints_hash) {
- SV *ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
- if (ptr && SvIOK(ptr) && SvIV(ptr))
- eng = INT2PTR(regexp_engine*,SvIV(ptr));
- }
-
- if (PL_op->op_flags & OPf_SPECIAL)
- PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
-
- if (DO_UTF8(tmpstr)) {
- assert (SvUTF8(tmpstr));
- } else if (SvUTF8(tmpstr)) {
- /* Not doing UTF-8, despite what the SV says. Is this only if
- we're trapped in use 'bytes'? */
- /* Make a copy of the octet sequence, but without the flag on,
- as the compiler now honours the SvUTF8 flag on tmpstr. */
- STRLEN len;
- const char *const p = SvPV(tmpstr, len);
- tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
- }
- else if (SvAMAGIC(tmpstr)) {
- /* make a copy to avoid extra stringifies */
- tmpstr = newSVpvn_flags(t, len, SVs_TEMP | SvUTF8(tmpstr));
- }
-
- /* If it is gmagical, create a mortal copy, but without calling
- get-magic, as we have already done that. */
- if(SvGMAGICAL(tmpstr)) {
- SV *mortalcopy = sv_newmortal();
- sv_setsv_flags(mortalcopy, tmpstr, 0);
- tmpstr = mortalcopy;
- }
-
- if (eng)
- PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
- else
- PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
-
- PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
- inside tie/overload accessors. */
- }
- }
-
- re = PM_GETRE(pm);
-
#ifndef INCOMPLETE_TAINTS
- if (PL_tainting) {
- if (PL_tainted) {
- SvTAINTED_on((SV*)re);
- RX_EXTFLAGS(re) |= RXf_TAINTED;
- }
+ if (TAINTING_get && TAINT_get) {
+ SvTAINTED_on((SV*)new_re);
+ RX_TAINT_on(new_re);
}
#endif
- if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
- pm = PL_curpm;
-
-
#if !defined(USE_ITHREADS)
/* can't change the optree at runtime either */
/* PMf_KEEP is handled differently under threads to avoid these problems */
+ if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
+ pm = PL_curpm;
if (pm->op_pmflags & PMf_KEEP) {
pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
cLOGOP->op_first->op_next = PL_op->op_next;
}
#endif
+
+ SP = args-1;
RETURN;
}
+
PP(pp_substcont)
{
dVAR;
dSP;
- register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
- register PMOP * const pm = (PMOP*) cLOGOP->op_other;
- register SV * const dstr = cx->sb_dstr;
- register char *s = cx->sb_s;
- register char *m = cx->sb_m;
+ PERL_CONTEXT *cx = &cxstack[cxstack_ix];
+ PMOP * const pm = (PMOP*) cLOGOP->op_other;
+ SV * const dstr = cx->sb_dstr;
+ char *s = cx->sb_s;
+ char *m = cx->sb_m;
char *orig = cx->sb_orig;
- register REGEXP * const rx = cx->sb_rx;
+ REGEXP * const rx = cx->sb_rx;
SV *nsv = NULL;
REGEXP *old = PM_GETRE(pm);
@@ -301,48 +234,50 @@
if (CxONCE(cx) || s < orig ||
!CALLREGEXEC(rx, s, cx->sb_strend, orig,
(s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
- ((cx->sb_rflags & REXEC_COPY_STR)
- ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
- : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
+ (REXEC_IGNOREPOS|REXEC_NOT_FIRST)))
{
- SV * const targ = cx->sb_targ;
+ SV *targ = cx->sb_targ;
assert(cx->sb_strend >= s);
if(cx->sb_strend > s) {
if (DO_UTF8(dstr) && !SvUTF8(targ))
- sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
+ sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
else
- sv_catpvn(dstr, s, cx->sb_strend - s);
+ sv_catpvn_nomg(dstr, s, cx->sb_strend - s);
}
if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
cx->sb_rxtainted |= SUBST_TAINT_PAT;
-#ifdef PERL_OLD_COPY_ON_WRITE
- if (SvIsCOW(targ)) {
- sv_force_normal_flags(targ, SV_COW_DROP_PV);
- } else
-#endif
- {
- SvPV_free(targ);
+ if (pm->op_pmflags & PMf_NONDESTRUCT) {
+ PUSHs(dstr);
+ /* From here on down we're using the copy, and leaving the
+ original untouched. */
+ targ = dstr;
}
- SvPV_set(targ, SvPVX(dstr));
- SvCUR_set(targ, SvCUR(dstr));
- SvLEN_set(targ, SvLEN(dstr));
- if (DO_UTF8(dstr))
- SvUTF8_on(targ);
- SvPV_set(dstr, NULL);
+ else {
+ if (SvIsCOW(targ)) {
+ sv_force_normal_flags(targ, SV_COW_DROP_PV);
+ } else
+ {
+ SvPV_free(targ);
+ }
+ SvPV_set(targ, SvPVX(dstr));
+ SvCUR_set(targ, SvCUR(dstr));
+ SvLEN_set(targ, SvLEN(dstr));
+ if (DO_UTF8(dstr))
+ SvUTF8_on(targ);
+ SvPV_set(dstr, NULL);
- if (pm->op_pmflags & PMf_NONDESTRUCT)
- PUSHs(targ);
- else
+ PL_tainted = 0;
mPUSHi(saviters - 1);
- (void)SvPOK_only_UTF8(targ);
+ (void)SvPOK_only_UTF8(targ);
+ }
/* update the taint state of various various variables in
* preparation for final exit.
* See "how taint works" above pp_subst() */
- if (PL_tainting) {
+ if (TAINTING_get) {
if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
== (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
@@ -354,8 +289,10 @@
)
SvTAINTED_on(TOPs); /* taint return value */
/* needed for mg_set below */
- PL_tainted = cBOOL(cx->sb_rxtainted &
- (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
+ TAINT_set(
+ cBOOL(cx->sb_rxtainted &
+ (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
+ );
SvTAINT(TARG);
}
/* PL_tainted must be correctly set for this mg_set */
@@ -363,8 +300,9 @@
TAINT_NOT;
LEAVE_SCOPE(cx->sb_oldsave);
POPSUBST(cx);
+ PERL_ASYNC_CHECK();
RETURNOP(pm->op_next);
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
}
cx->sb_iters = saviters;
}
@@ -371,6 +309,7 @@
if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
m = s;
s = orig;
+ assert(!RX_SUBOFFSET(rx));
cx->sb_orig = orig = RX_SUBBEG(rx);
s = orig + (m - s);
cx->sb_strend = s + (cx->sb_strend - m);
@@ -378,13 +317,14 @@
cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
if (m > s) {
if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
- sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
+ sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
else
- sv_catpvn(dstr, s, m-s);
+ sv_catpvn_nomg(dstr, s, m-s);
}
cx->sb_s = RX_OFFS(rx)[0].end + orig;
{ /* Update the pos() information. */
- SV * const sv = cx->sb_targ;
+ SV * const sv
+ = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
MAGIC *mg;
SvUPGRADE(sv, SVt_PVMG);
if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
@@ -402,7 +342,7 @@
/* update the taint state of various various variables in preparation
* for calling the code block.
* See "how taint works" above pp_subst() */
- if (PL_tainting) {
+ if (TAINTING_get) {
if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
cx->sb_rxtainted |= SUBST_TAINT_PAT;
@@ -414,7 +354,8 @@
if (cx->sb_iters > 1 && (cx->sb_rxtainted &
(SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
- SvTAINTED_on(cx->sb_targ);
+ SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
+ ? cx->sb_dstr : cx->sb_targ);
TAINT_NOT;
}
rxres_save(&cx->sb_rxres, rx);
@@ -432,10 +373,10 @@
PERL_UNUSED_CONTEXT;
if (!p || p[1] < RX_NPARENS(rx)) {
-#ifdef PERL_OLD_COPY_ON_WRITE
- i = 7 + RX_NPARENS(rx) * 2;
+#ifdef PERL_ANY_COW
+ i = 7 + (RX_NPARENS(rx)+1) * 2;
#else
- i = 6 + RX_NPARENS(rx) * 2;
+ i = 6 + (RX_NPARENS(rx)+1) * 2;
#endif
if (!p)
Newx(p, i, UV);
@@ -444,18 +385,20 @@
*rsp = (void*)p;
}
+ /* what (if anything) to free on croak */
*p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
RX_MATCH_COPIED_off(rx);
+ *p++ = RX_NPARENS(rx);
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
*p++ = PTR2UV(RX_SAVED_COPY(rx));
RX_SAVED_COPY(rx) = NULL;
#endif
- *p++ = RX_NPARENS(rx);
-
*p++ = PTR2UV(RX_SUBBEG(rx));
*p++ = (UV)RX_SUBLEN(rx);
+ *p++ = (UV)RX_SUBOFFSET(rx);
+ *p++ = (UV)RX_SUBCOFFSET(rx);
for (i = 0; i <= RX_NPARENS(rx); ++i) {
*p++ = (UV)RX_OFFS(rx)[i].start;
*p++ = (UV)RX_OFFS(rx)[i].end;
@@ -474,8 +417,9 @@
RX_MATCH_COPY_FREE(rx);
RX_MATCH_COPIED_set(rx, *p);
*p++ = 0;
+ RX_NPARENS(rx) = *p++;
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
if (RX_SAVED_COPY(rx))
SvREFCNT_dec (RX_SAVED_COPY(rx));
RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
@@ -482,10 +426,10 @@
*p++ = 0;
#endif
- RX_NPARENS(rx) = *p++;
-
RX_SUBBEG(rx) = INT2PTR(char*,*p++);
RX_SUBLEN(rx) = (I32)(*p++);
+ RX_SUBOFFSET(rx) = (I32)*p++;
+ RX_SUBCOFFSET(rx) = (I32)*p++;
for (i = 0; i <= RX_NPARENS(rx); ++i) {
RX_OFFS(rx)[i].start = (I32)(*p++);
RX_OFFS(rx)[i].end = (I32)(*p++);
@@ -501,78 +445,78 @@
PERL_UNUSED_CONTEXT;
if (p) {
+ void *tmp = INT2PTR(char*,*p);
#ifdef PERL_POISON
- void *tmp = INT2PTR(char*,*p);
- Safefree(tmp);
- if (*p)
- PoisonFree(*p, 1, sizeof(*p));
+#ifdef PERL_ANY_COW
+ U32 i = 9 + p[1] * 2;
#else
- Safefree(INT2PTR(char*,*p));
+ U32 i = 8 + p[1] * 2;
#endif
-#ifdef PERL_OLD_COPY_ON_WRITE
- if (p[1]) {
- SvREFCNT_dec (INT2PTR(SV*,p[1]));
- }
#endif
+
+#ifdef PERL_ANY_COW
+ SvREFCNT_dec (INT2PTR(SV*,p[2]));
+#endif
+#ifdef PERL_POISON
+ PoisonFree(p, i, sizeof(UV));
+#endif
+
+ Safefree(tmp);
Safefree(p);
*rsp = NULL;
}
}
+#define FORM_NUM_BLANK (1<<30)
+#define FORM_NUM_POINT (1<<29)
+
PP(pp_formline)
{
dVAR; dSP; dMARK; dORIGMARK;
- register SV * const tmpForm = *++MARK;
- register U32 *fpc;
- register char *t;
- const char *f;
- register I32 arg;
- register SV *sv = NULL;
- const char *item = NULL;
- I32 itemsize = 0;
- I32 fieldsize = 0;
- I32 lines = 0;
- bool chopspace = (strchr(PL_chopset, ' ') != NULL);
- const char *chophere = NULL;
- char *linemark = NULL;
+ SV * const tmpForm = *++MARK;
+ SV *formsv; /* contains text of original format */
+ U32 *fpc; /* format ops program counter */
+ char *t; /* current append position in target string */
+ const char *f; /* current position in format string */
+ I32 arg;
+ SV *sv = NULL; /* current item */
+ const char *item = NULL;/* string value of current item */
+ I32 itemsize = 0; /* length of current item, possibly truncated */
+ I32 fieldsize = 0; /* width of current field */
+ I32 lines = 0; /* number of lines that have been output */
+ bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
+ const char *chophere = NULL; /* where to chop current item */
+ STRLEN linemark = 0; /* pos of start of line in output */
NV value;
- bool gotsome = FALSE;
+ bool gotsome = FALSE; /* seen at least one non-blank item on this line */
STRLEN len;
- const STRLEN fudge = SvPOKp(tmpForm)
- ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
+ STRLEN linemax; /* estimate of output size in bytes */
bool item_is_utf8 = FALSE;
bool targ_is_utf8 = FALSE;
- SV * nsv = NULL;
const char *fmt;
MAGIC *mg = NULL;
+ U8 *source; /* source of bytes to append */
+ STRLEN to_copy; /* how may bytes to append */
+ char trans; /* what chars to translate */
- if (SvTYPE(tmpForm) >= SVt_PVMG) {
- /* This might, of course, still return NULL. */
- mg = mg_find(tmpForm, PERL_MAGIC_fm);
- } else {
- sv_upgrade(tmpForm, SVt_PVMG);
- }
+ mg = doparseform(tmpForm);
- if(!mg) {
- if (SvREADONLY(tmpForm)) {
- SvREADONLY_off(tmpForm);
- mg = doparseform(tmpForm);
- SvREADONLY_on(tmpForm);
- }
- else
- mg = doparseform(tmpForm);
- assert(mg);
- }
fpc = (U32*)mg->mg_ptr;
+ /* the actual string the format was compiled from.
+ * with overload etc, this may not match tmpForm */
+ formsv = mg->mg_obj;
+
SvPV_force(PL_formtarget, len);
- if (SvTAINTED(tmpForm))
+ if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
SvTAINTED_on(PL_formtarget);
if (DO_UTF8(PL_formtarget))
targ_is_utf8 = TRUE;
- t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
+ linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
+ t = SvGROW(PL_formtarget, len + linemax + 1);
+ /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
t += len;
- f = SvPV_const(tmpForm, len);
+ f = SvPV_const(formsv, len);
for (;;) {
DEBUG_f( {
@@ -606,31 +550,18 @@
} );
switch (*fpc++) {
case FF_LINEMARK:
- linemark = t;
+ linemark = t - SvPVX(PL_formtarget);
lines++;
gotsome = FALSE;
break;
case FF_LITERAL:
- arg = *fpc++;
- if (targ_is_utf8 && !SvUTF8(tmpForm)) {
- SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
- *t = '\0';
- sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
- t = SvEND(PL_formtarget);
- f += arg;
- break;
- }
- if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
- SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
- *t = '\0';
- sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1);
- t = SvEND(PL_formtarget);
- targ_is_utf8 = TRUE;
- }
- while (arg--)
- *t++ = *f++;
- break;
+ to_copy = *fpc++;
+ source = (U8 *)f;
+ f += to_copy;
+ trans = '~';
+ item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
+ goto append;
case FF_SKIP:
f += *fpc++;
@@ -801,69 +732,17 @@
break;
case FF_ITEM:
- {
- const char *s = item;
- arg = itemsize;
- if (item_is_utf8) {
- if (!targ_is_utf8) {
- SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
- *t = '\0';
- sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC,
- fudge + 1);
- t = SvEND(PL_formtarget);
- targ_is_utf8 = TRUE;
- }
- while (arg--) {
- if (UTF8_IS_CONTINUED(*s)) {
- STRLEN skip = UTF8SKIP(s);
- switch (skip) {
- default:
- Move(s,t,skip,char);
- s += skip;
- t += skip;
- break;
- case 7: *t++ = *s++;
- case 6: *t++ = *s++;
- case 5: *t++ = *s++;
- case 4: *t++ = *s++;
- case 3: *t++ = *s++;
- case 2: *t++ = *s++;
- case 1: *t++ = *s++;
- }
- }
- else {
- if ( !((*t++ = *s++) & ~31) )
- t[-1] = ' ';
- }
- }
- break;
- }
- if (targ_is_utf8 && !item_is_utf8) {
- SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
- *t = '\0';
- sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
- for (; t < SvEND(PL_formtarget); t++) {
-#ifdef EBCDIC
- const int ch = *t;
- if (iscntrl(ch))
-#else
- if (!(*t & ~31))
-#endif
- *t = ' ';
- }
- break;
- }
- while (arg--) {
-#ifdef EBCDIC
- const int ch = *t++ = *s++;
- if (iscntrl(ch))
-#else
- if ( !((*t++ = *s++) & ~31) )
-#endif
- t[-1] = ' ';
- }
- break;
+ to_copy = itemsize;
+ source = (U8 *)item;
+ trans = 1;
+ if (item_is_utf8) {
+ /* convert to_copy from chars to bytes */
+ U8 *s = source;
+ while (to_copy--)
+ s += UTF8SKIP(s);
+ to_copy = s - source;
}
+ goto append;
case FF_CHOP:
{
@@ -883,73 +762,102 @@
{
const bool oneline = fpc[-1] == FF_LINESNGL;
const char *s = item = SvPV_const(sv, len);
+ const char *const send = s + len;
+
item_is_utf8 = DO_UTF8(sv);
- itemsize = len;
- if (itemsize) {
- STRLEN to_copy = itemsize;
- const char *const send = s + len;
- const U8 *source = (const U8 *) s;
- U8 *tmp = NULL;
-
- gotsome = TRUE;
- chophere = s + itemsize;
- while (s < send) {
- if (*s++ == '\n') {
- if (oneline) {
- to_copy = s - SvPVX_const(sv) - 1;
- chophere = s;
- break;
- } else {
- if (s == send) {
- itemsize--;
- to_copy--;
- } else
- lines++;
- }
+ if (!len)
+ break;
+ trans = 0;
+ gotsome = TRUE;
+ chophere = s + len;
+ source = (U8 *) s;
+ to_copy = len;
+ while (s < send) {
+ if (*s++ == '\n') {
+ if (oneline) {
+ to_copy = s - SvPVX_const(sv) - 1;
+ chophere = s;
+ break;
+ } else {
+ if (s == send) {
+ to_copy--;
+ } else
+ lines++;
}
}
- if (targ_is_utf8 && !item_is_utf8) {
- source = tmp = bytes_to_utf8(source, &to_copy);
- SvCUR_set(PL_formtarget,
- t - SvPVX_const(PL_formtarget));
- } else {
- if (item_is_utf8 && !targ_is_utf8) {
- /* Upgrade targ to UTF8, and then we reduce it to
- a problem we have a simple solution for. */
- SvCUR_set(PL_formtarget,
- t - SvPVX_const(PL_formtarget));
- targ_is_utf8 = TRUE;
- /* Don't need get magic. */
- sv_utf8_upgrade_nomg(PL_formtarget);
- } else {
- SvCUR_set(PL_formtarget,
- t - SvPVX_const(PL_formtarget));
- }
+ }
+ }
- /* Easy. They agree. */
- assert (item_is_utf8 == targ_is_utf8);
+ append:
+ /* append to_copy bytes from source to PL_formstring.
+ * item_is_utf8 implies source is utf8.
+ * if trans, translate certain characters during the copy */
+ {
+ U8 *tmp = NULL;
+ STRLEN grow = 0;
+
+ SvCUR_set(PL_formtarget,
+ t - SvPVX_const(PL_formtarget));
+
+ if (targ_is_utf8 && !item_is_utf8) {
+ source = tmp = bytes_to_utf8(source, &to_copy);
+ } else {
+ if (item_is_utf8 && !targ_is_utf8) {
+ U8 *s;
+ /* Upgrade targ to UTF8, and then we reduce it to
+ a problem we have a simple solution for.
+ Don't need get magic. */
+ sv_utf8_upgrade_nomg(PL_formtarget);
+ targ_is_utf8 = TRUE;
+ /* re-calculate linemark */
+ s = (U8*)SvPVX(PL_formtarget);
+ /* the bytes we initially allocated to append the
+ * whole line may have been gobbled up during the
+ * upgrade, so allocate a whole new line's worth
+ * for safety */
+ grow = linemax;
+ while (linemark--)
+ s += UTF8SKIP(s);
+ linemark = s - (U8*)SvPVX(PL_formtarget);
}
- SvGROW(PL_formtarget,
- SvCUR(PL_formtarget) + to_copy + fudge + 1);
- t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
+ /* Easy. They agree. */
+ assert (item_is_utf8 == targ_is_utf8);
+ }
+ if (!trans)
+ /* @* and ^* are the only things that can exceed
+ * the linemax, so grow by the output size, plus
+ * a whole new form's worth in case of any further
+ * output */
+ grow = linemax + to_copy;
+ if (grow)
+ SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
+ t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
- Copy(source, t, to_copy, char);
- t += to_copy;
- SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
- if (item_is_utf8) {
- if (SvGMAGICAL(sv)) {
- /* Mustn't call sv_pos_b2u() as it does a second
- mg_get(). Is this a bug? Do we need a _flags()
- variant? */
- itemsize = utf8_length(source, source + itemsize);
- } else {
- sv_pos_b2u(sv, &itemsize);
- }
- assert(!tmp);
- } else if (tmp) {
- Safefree(tmp);
+ Copy(source, t, to_copy, char);
+ if (trans) {
+ /* blank out ~ or control chars, depending on trans.
+ * works on bytes not chars, so relies on not
+ * matching utf8 continuation bytes */
+ U8 *s = (U8*)t;
+ U8 *send = s + to_copy;
+ while (s < send) {
+ const int ch = *s;
+ if (trans == '~' ? (ch == '~') :
+#ifdef EBCDIC
+ iscntrl(ch)
+#else
+ (!(ch & ~31))
+#endif
+ )
+ *s = ' ';
+ s++;
}
}
+
+ t += to_copy;
+ SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
+ if (tmp)
+ Safefree(tmp);
break;
}
@@ -957,11 +865,11 @@
arg = *fpc++;
#if defined(USE_LONG_DOUBLE)
fmt = (const char *)
- ((arg & 256) ?
+ ((arg & FORM_NUM_POINT) ?
"%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
#else
fmt = (const char *)
- ((arg & 256) ?
+ ((arg & FORM_NUM_POINT) ?
"%#0*.*f" : "%0*.*f");
#endif
goto ff_dec;
@@ -969,15 +877,15 @@
arg = *fpc++;
#if defined(USE_LONG_DOUBLE)
fmt = (const char *)
- ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
+ ((arg & FORM_NUM_POINT) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
#else
fmt = (const char *)
- ((arg & 256) ? "%#*.*f" : "%*.*f");
+ ((arg & FORM_NUM_POINT) ? "%#*.*f" : "%*.*f");
#endif
ff_dec:
/* If the field is marked with ^ and the value is undefined,
blank it out. */
- if ((arg & 512) && !SvOK(sv)) {
+ if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
arg = fieldsize;
while (arg--)
*t++ = ' ';
@@ -995,7 +903,8 @@
/* Formats aren't yet marked for locales, so assume "yes". */
{
STORE_NUMERIC_STANDARD_SET_LOCAL();
- my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
+ arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
+ my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg, value);
RESTORE_NUMERIC_STANDARD();
}
t += fieldsize;
@@ -1003,7 +912,7 @@
case FF_NEWLINE:
f++;
- while (t-- > linemark && *t == ' ') ;
+ while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
t++;
*t++ = '\n';
break;
@@ -1012,18 +921,12 @@
arg = *fpc++;
if (gotsome) {
if (arg) { /* repeat until fields exhausted? */
- *t = '\0';
- SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
- lines += FmLINES(PL_formtarget);
- if (targ_is_utf8)
- SvUTF8_on(PL_formtarget);
- FmLINES(PL_formtarget) = lines;
- SP = ORIGMARK;
- RETURNOP(cLISTOP->op_first);
+ fpc--;
+ goto end;
}
}
else {
- t = linemark;
+ t = SvPVX(PL_formtarget) + linemark;
lines--;
}
break;
@@ -1056,6 +959,8 @@
break;
}
case FF_END:
+ end:
+ assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
*t = '\0';
SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
if (targ_is_utf8)
@@ -1062,7 +967,10 @@
SvUTF8_on(PL_formtarget);
FmLINES(PL_formtarget) += lines;
SP = ORIGMARK;
- RETPUSHYES;
+ if (fpc[-1] == FF_BLANK)
+ RETURNOP(cLISTOP->op_first);
+ else
+ RETPUSHYES;
}
}
}
@@ -1329,13 +1237,13 @@
SvGETMAGIC(right);
if (RANGE_IS_NUMERIC(left,right)) {
- register IV i, j;
+ IV i, j;
IV max;
- if ((SvOK(left) && SvNV(left) < IV_MIN) ||
- (SvOK(right) && SvNV(right) > IV_MAX))
+ if ((SvOK(left) && SvNV_nomg(left) < IV_MIN) ||
+ (SvOK(right) && SvNV_nomg(right) > IV_MAX))
DIE(aTHX_ "Range iterator outside integer range");
- i = SvIV(left);
- max = SvIV(right);
+ i = SvIV_nomg(left);
+ max = SvIV_nomg(right);
if (max >= i) {
j = max - i + 1;
EXTEND_MORTAL(j);
@@ -1349,12 +1257,11 @@
}
}
else {
- SV * const final = sv_mortalcopy(right);
- STRLEN len;
- const char * const tmps = SvPV_const(final, len);
+ STRLEN len, llen;
+ const char * const lpv = SvPV_nomg_const(left, llen);
+ const char * const tmps = SvPV_nomg_const(right, len);
- SV *sv = sv_mortalcopy(left);
- SvPV_force_nolen(sv);
+ SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
XPUSHs(sv);
if (strEQ(SvPVX_const(sv),tmps))
@@ -1411,15 +1318,15 @@
};
STATIC I32
-S_dopoptolabel(pTHX_ const char *label)
+S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
{
dVAR;
- register I32 i;
+ I32 i;
PERL_ARGS_ASSERT_DOPOPTOLABEL;
for (i = cxstack_ix; i >= 0; i--) {
- register const PERL_CONTEXT * const cx = &cxstack[i];
+ const PERL_CONTEXT * const cx = &cxstack[i];
switch (CxTYPE(cx)) {
case CXt_SUBST:
case CXt_SUB:
@@ -1426,6 +1333,7 @@
case CXt_FORMAT:
case CXt_EVAL:
case CXt_NULL:
+ /* diag_listed_as: Exiting subroutine via %s */
Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
context_name[CxTYPE(cx)], OP_NAME(PL_op));
if (CxTYPE(cx) == CXt_NULL)
@@ -1436,8 +1344,20 @@
case CXt_LOOP_FOR:
case CXt_LOOP_PLAIN:
{
- const char *cx_label = CxLABEL(cx);
- if (!cx_label || strNE(label, cx_label) ) {
+ STRLEN cx_label_len = 0;
+ U32 cx_label_flags = 0;
+ const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
+ if (!cx_label || !(
+ ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
+ (flags & SVf_UTF8)
+ ? (bytes_cmp_utf8(
+ (const U8*)cx_label, cx_label_len,
+ (const U8*)label, len) == 0)
+ : (bytes_cmp_utf8(
+ (const U8*)label, len,
+ (const U8*)cx_label, cx_label_len) == 0)
+ : (len == cx_label_len && ((cx_label == label)
+ || memEQ(cx_label, label, len))) )) {
DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
(long)i, cx_label));
continue;
@@ -1477,7 +1397,7 @@
return G_ARRAY;
default:
Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
return 0;
}
}
@@ -1495,6 +1415,20 @@
return 0;
}
+/* only used by PUSHSUB */
+I32
+Perl_was_lvalue_sub(pTHX)
+{
+ dVAR;
+ const I32 cxix = dopoptosub(cxstack_ix-1);
+ assert(cxix >= 0); /* We should only be called from inside subs */
+
+ if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
+ return CxLVAL(cxstack + cxix);
+ else
+ return 0;
+}
+
STATIC I32
S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
{
@@ -1504,12 +1438,18 @@
PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
for (i = startingblock; i >= 0; i--) {
- register const PERL_CONTEXT * const cx = &cxstk[i];
+ const PERL_CONTEXT * const cx = &cxstk[i];
switch (CxTYPE(cx)) {
default:
continue;
+ case CXt_SUB:
+ /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
+ * twice; the first for the normal foo() call, and the second
+ * for a faked up re-entry into the sub to execute the
+ * code block. Hide this faked entry from the world. */
+ if (cx->cx_type & CXp_SUB_RE_FAKE)
+ continue;
case CXt_EVAL:
- case CXt_SUB:
case CXt_FORMAT:
DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
return i;
@@ -1524,7 +1464,7 @@
dVAR;
I32 i;
for (i = startingblock; i >= 0; i--) {
- register const PERL_CONTEXT *cx = &cxstack[i];
+ const PERL_CONTEXT *cx = &cxstack[i];
switch (CxTYPE(cx)) {
default:
continue;
@@ -1542,7 +1482,7 @@
dVAR;
I32 i;
for (i = startingblock; i >= 0; i--) {
- register const PERL_CONTEXT * const cx = &cxstack[i];
+ const PERL_CONTEXT * const cx = &cxstack[i];
switch (CxTYPE(cx)) {
case CXt_SUBST:
case CXt_SUB:
@@ -1549,6 +1489,7 @@
case CXt_FORMAT:
case CXt_EVAL:
case CXt_NULL:
+ /* diag_listed_as: Exiting subroutine via %s */
Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
context_name[CxTYPE(cx)], OP_NAME(PL_op));
if ((CxTYPE(cx)) == CXt_NULL)
@@ -1571,7 +1512,7 @@
dVAR;
I32 i;
for (i = startingblock; i >= 0; i--) {
- register const PERL_CONTEXT *cx = &cxstack[i];
+ const PERL_CONTEXT *cx = &cxstack[i];
switch (CxTYPE(cx)) {
default:
continue;
@@ -1599,7 +1540,7 @@
dVAR;
I32 i;
for (i = startingblock; i >= 0; i--) {
- register const PERL_CONTEXT *cx = &cxstack[i];
+ const PERL_CONTEXT *cx = &cxstack[i];
switch (CxTYPE(cx)) {
default:
continue;
@@ -1617,9 +1558,12 @@
dVAR;
I32 optype;
+ if (!PL_curstackinfo) /* can happen if die during thread cloning */
+ return;
+
while (cxstack_ix > cxix) {
SV *sv;
- register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
+ PERL_CONTEXT *cx = &cxstack[cxstack_ix];
DEBUG_CX("UNWIND"); \
/* Note: we don't need to restore the base context info till the end. */
switch (CxTYPE(cx)) {
@@ -1659,8 +1603,8 @@
if (PL_in_eval) {
if (PL_in_eval & EVAL_KEEPERR) {
- Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
- SvPV_nolen_const(err));
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
+ SVfARG(err));
}
else
sv_catsv(ERRSV, err);
@@ -1719,6 +1663,11 @@
sv_setsv(ERRSV, exceptsv);
}
+ if (in_eval & EVAL_KEEPERR) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
+ SVfARG(exceptsv));
+ }
+
while ((cxix = dopoptoeval(cxstack_ix)) < 0
&& PL_curstackinfo->si_prev)
{
@@ -1729,7 +1678,7 @@
if (cxix >= 0) {
I32 optype;
SV *namesv;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
SV **newsp;
COP *oldcop;
JMPENV *restartjmpenv;
@@ -1765,34 +1714,30 @@
PL_curcop = oldcop;
if (optype == OP_REQUIRE) {
- const char* const msg = SvPVx_nolen_const(exceptsv);
(void)hv_store(GvHVn(PL_incgv),
- SvPVX_const(namesv), SvCUR(namesv),
+ SvPVX_const(namesv),
+ SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
&PL_sv_undef, 0);
/* note that unlike pp_entereval, pp_require isn't
* supposed to trap errors. So now that we've popped the
* EVAL that pp_require pushed, and processed the error
* message, rethrow the error */
- Perl_croak(aTHX_ "%sCompilation failed in require",
- *msg ? msg : "Unknown error\n");
+ Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
+ SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n",
+ SVs_TEMP)));
}
- if (in_eval & EVAL_KEEPERR) {
- Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
- SvPV_nolen_const(exceptsv));
- }
- else {
+ if (!(in_eval & EVAL_KEEPERR))
sv_setsv(ERRSV, exceptsv);
- }
PL_restartjmpenv = restartjmpenv;
PL_restartop = restartop;
JMPENV_JUMP(3);
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
}
}
write_to_stderr(exceptsv);
my_failure_exit();
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
}
PP(pp_xor)
@@ -1826,9 +1771,9 @@
const PERL_CONTEXT *
Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
{
- register I32 cxix = dopoptosub(cxstack_ix);
- register const PERL_CONTEXT *cx;
- register const PERL_CONTEXT *ccstack = cxstack;
+ I32 cxix = dopoptosub(cxstack_ix);
+ const PERL_CONTEXT *cx;
+ const PERL_CONTEXT *ccstack = cxstack;
const PERL_SI *top_si = PL_curstackinfo;
for (;;) {
@@ -1868,16 +1813,20 @@
{
dVAR;
dSP;
- register const PERL_CONTEXT *cx;
+ const PERL_CONTEXT *cx;
const PERL_CONTEXT *dbcx;
I32 gimme;
- const char *stashname;
+ const HEK *stash_hek;
I32 count = 0;
+ bool has_arg = MAXARG && TOPs;
- if (MAXARG)
+ if (MAXARG) {
+ if (has_arg)
count = POPi;
+ else (void)POPs;
+ }
- cx = caller_cx(count, &dbcx);
+ cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
if (!cx) {
if (GIMME != G_ARRAY) {
EXTEND(SP, 1);
@@ -1886,14 +1835,18 @@
RETURN;
}
- stashname = CopSTASHPV(cx->blk_oldcop);
+ DEBUG_CX("CALLER");
+ assert(CopSTASH(cx->blk_oldcop));
+ stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
+ ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
+ : NULL;
if (GIMME != G_ARRAY) {
EXTEND(SP, 1);
- if (!stashname)
+ if (!stash_hek)
PUSHs(&PL_sv_undef);
else {
dTARGET;
- sv_setpv(TARG, stashname);
+ sv_sethek(TARG, stash_hek);
PUSHs(TARG);
}
RETURN;
@@ -1901,18 +1854,21 @@
EXTEND(SP, 11);
- if (!stashname)
+ if (!stash_hek)
PUSHs(&PL_sv_undef);
- else
- mPUSHs(newSVpv(stashname, 0));
+ else {
+ dTARGET;
+ sv_sethek(TARG, stash_hek);
+ PUSHTARG;
+ }
mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
mPUSHi((I32)CopLINE(cx->blk_oldcop));
- if (!MAXARG)
+ if (!has_arg)
RETURN;
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
GV * const cvgv = CvGV(dbcx->blk_sub.cv);
/* So is ccstack[dbcxix]. */
- if (isGV(cvgv)) {
+ if (cvgv && isGV(cvgv)) {
SV * const sv = newSV(0);
gv_efullname3(sv, cvgv, NULL);
mPUSHs(sv);
@@ -1935,7 +1891,9 @@
if (CxTYPE(cx) == CXt_EVAL) {
/* eval STRING */
if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
- PUSHs(cx->blk_eval.cur_text);
+ PUSHs(newSVpvn_flags(SvPVX(cx->blk_eval.cur_text),
+ SvCUR(cx->blk_eval.cur_text)-2,
+ SvUTF8(cx->blk_eval.cur_text)|SVs_TEMP));
PUSHs(&PL_sv_no);
}
/* require */
@@ -1959,8 +1917,7 @@
AV * const ary = cx->blk_sub.argarray;
const int off = AvARRAY(ary) - AvALLOC(ary);
- if (!PL_dbargs || AvREAL(PL_dbargs))
- Perl_init_dbargs(aTHX);
+ Perl_init_dbargs(aTHX);
if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
av_extend(PL_dbargs, AvFILLp(ary) + off);
@@ -1967,17 +1924,15 @@
Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
}
- /* XXX only hints propagated via op_private are currently
- * visible (others are not easily accessible, since they
- * use the global PL_hints) */
mPUSHi(CopHINTS_get(cx->blk_oldcop));
{
SV * mask ;
STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
- if (old_warnings == pWARN_NONE ||
- (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
+ if (old_warnings == pWARN_NONE)
mask = newSVpvn(WARN_NONEstring, WARNsize) ;
+ else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
+ mask = &PL_sv_undef ;
else if (old_warnings == pWARN_ALL ||
(old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
/* Get the bit mask for $warnings::Bits{all}, because
@@ -2006,8 +1961,13 @@
{
dVAR;
dSP;
- const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
- sv_reset(tmps, CopSTASH(PL_curcop));
+ const char * tmps;
+ STRLEN len = 0;
+ if (MAXARG < 1 || (!TOPs && !POPs))
+ tmps = NULL, len = 0;
+ else
+ tmps = SvPVx_const(POPs, len);
+ sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
PUSHs(&PL_sv_yes);
RETURN;
}
@@ -2028,13 +1988,16 @@
|| SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
{
dSP;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
const I32 gimme = G_ARRAY;
U8 hasargs;
GV * const gv = PL_DBgv;
- register CV * const cv = GvCV(gv);
+ CV * cv = NULL;
- if (!cv)
+ if (gv && isGV_with_GP(gv))
+ cv = GvCV(gv);
+
+ if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
DIE(aTHX_ "No DB::DB routine defined");
if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
@@ -2051,10 +2014,8 @@
SPAGAIN;
if (CvISXSUB(cv)) {
- CvDEPTH(cv)++;
PUSHMARK(SP);
(void)(*CvXSUB(cv))(aTHX_ cv);
- CvDEPTH(cv)--;
FREETMPS;
LEAVE;
return NORMAL;
@@ -2064,8 +2025,12 @@
PUSHSUB_DB(cx);
cx->blk_sub.retop = PL_op->op_next;
CvDEPTH(cv)++;
+ if (CvDEPTH(cv) >= 2) {
+ PERL_STACK_OVERFLOW_CHECK();
+ pad_push(CvPADLIST(cv), CvDEPTH(cv));
+ }
SAVECOMPPAD();
- PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
+ PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
RETURNOP(CvSTART(cv));
}
}
@@ -2073,10 +2038,89 @@
return NORMAL;
}
+STATIC SV **
+S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags)
+{
+ bool padtmp = 0;
+ PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE;
+
+ if (flags & SVs_PADTMP) {
+ flags &= ~SVs_PADTMP;
+ padtmp = 1;
+ }
+ if (gimme == G_SCALAR) {
+ if (MARK < SP)
+ *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP)))
+ ? *SP : sv_mortalcopy(*SP);
+ else {
+ /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
+ MARK = newsp;
+ MEXTEND(MARK, 1);
+ *++MARK = &PL_sv_undef;
+ return MARK;
+ }
+ }
+ else if (gimme == G_ARRAY) {
+ /* in case LEAVE wipes old return values */
+ while (++MARK <= SP) {
+ if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK)))
+ *++newsp = *MARK;
+ else {
+ *++newsp = sv_mortalcopy(*MARK);
+ TAINT_NOT; /* Each item is independent */
+ }
+ }
+ /* When this function was called with MARK == newsp, we reach this
+ * point with SP == newsp. */
+ }
+
+ return newsp;
+}
+
+PP(pp_enter)
+{
+ dVAR; dSP;
+ PERL_CONTEXT *cx;
+ I32 gimme = GIMME_V;
+
+ ENTER_with_name("block");
+
+ SAVETMPS;
+ PUSHBLOCK(cx, CXt_BLOCK, SP);
+
+ RETURN;
+}
+
+PP(pp_leave)
+{
+ dVAR; dSP;
+ PERL_CONTEXT *cx;
+ SV **newsp;
+ PMOP *newpm;
+ I32 gimme;
+
+ if (PL_op->op_flags & OPf_SPECIAL) {
+ cx = &cxstack[cxstack_ix];
+ cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
+ }
+
+ POPBLOCK(cx,newpm);
+
+ gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
+
+ TAINT_NOT;
+ SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
+ PL_curpm = newpm; /* Don't pop $1 et al till now */
+
+ LEAVE_with_name("block");
+
+ RETURN;
+}
+
PP(pp_enteriter)
{
dVAR; dSP; dMARK;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
void *itervar; /* location of the iteration variable */
U8 cxtype = CXt_LOOP_FOR;
@@ -2126,27 +2170,28 @@
assumptions */
assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
#ifdef NV_PRESERVES_UV
- if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
- (SvNV(sv) > (NV)IV_MAX)))
+ if ((SvOK(sv) && ((SvNV_nomg(sv) < (NV)IV_MIN) ||
+ (SvNV_nomg(sv) > (NV)IV_MAX)))
||
- (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
- (SvNV(right) < (NV)IV_MIN))))
+ (SvOK(right) && ((SvNV_nomg(right) > (NV)IV_MAX) ||
+ (SvNV_nomg(right) < (NV)IV_MIN))))
#else
- if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
+ if ((SvOK(sv) && ((SvNV_nomg(sv) <= (NV)IV_MIN)
||
- ((SvNV(sv) > 0) &&
- ((SvUV(sv) > (UV)IV_MAX) ||
- (SvNV(sv) > (NV)UV_MAX)))))
+ ((SvNV_nomg(sv) > 0) &&
+ ((SvUV_nomg(sv) > (UV)IV_MAX) ||
+ (SvNV_nomg(sv) > (NV)UV_MAX)))))
||
- (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
+ (SvOK(right) && ((SvNV_nomg(right) <= (NV)IV_MIN)
||
- ((SvNV(right) > 0) &&
- ((SvUV(right) > (UV)IV_MAX) ||
- (SvNV(right) > (NV)UV_MAX))))))
+ ((SvNV_nomg(right) > 0) &&
+ ((SvUV_nomg(right) > (UV)IV_MAX) ||
+ (SvNV_nomg(right) > (NV)UV_MAX))
+ ))))
#endif
DIE(aTHX_ "Range iterator outside integer range");
- cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
- cx->blk_loop.state_u.lazyiv.end = SvIV(right);
+ cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
+ cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
#ifdef DEBUGGING
/* for correct -Dstv display */
cx->blk_oldsp = sp - PL_stack_base;
@@ -2198,7 +2243,7 @@
PP(pp_enterloop)
{
dVAR; dSP;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
ENTER_with_name("loop1");
@@ -2214,7 +2259,7 @@
PP(pp_leaveloop)
{
dVAR; dSP;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
PMOP *newpm;
@@ -2226,21 +2271,7 @@
newsp = PL_stack_base + cx->blk_loop.resetsp;
TAINT_NOT;
- if (gimme == G_VOID)
- NOOP;
- else if (gimme == G_SCALAR) {
- if (mark < SP)
- *++newsp = sv_mortalcopy(*SP);
- else
- *++newsp = &PL_sv_undef;
- }
- else {
- while (mark < SP) {
- *++newsp = sv_mortalcopy(*++mark);
- TAINT_NOT; /* Each item is independent */
- }
- }
- SP = newsp;
+ SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0);
PUTBACK;
POPLOOP(cx); /* Stack values are safe: release loop vars ... */
@@ -2252,12 +2283,123 @@
return NORMAL;
}
+STATIC void
+S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
+ PERL_CONTEXT *cx, PMOP *newpm)
+{
+ const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
+ if (gimme == G_SCALAR) {
+ if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */
+ SV *sv;
+ const char *what = NULL;
+ if (MARK < SP) {
+ assert(MARK+1 == SP);
+ if ((SvPADTMP(TOPs) ||
+ (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
+ == SVf_READONLY
+ ) &&
+ !SvSMAGICAL(TOPs)) {
+ what =
+ SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
+ : "a readonly value" : "a temporary";
+ }
+ else goto copy_sv;
+ }
+ else {
+ /* sub:lvalue{} will take us here. */
+ what = "undef";
+ }
+ LEAVE;
+ cxstack_ix--;
+ POPSUB(cx,sv);
+ PL_curpm = newpm;
+ LEAVESUB(sv);
+ Perl_croak(aTHX_
+ "Can't return %s from lvalue subroutine", what
+ );
+ }
+ if (MARK < SP) {
+ copy_sv:
+ if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
+ if (!SvPADTMP(*SP)) {
+ *++newsp = SvREFCNT_inc(*SP);
+ FREETMPS;
+ sv_2mortal(*newsp);
+ }
+ else {
+ /* FREETMPS could clobber it */
+ SV *sv = SvREFCNT_inc(*SP);
+ FREETMPS;
+ *++newsp = sv_mortalcopy(sv);
+ SvREFCNT_dec(sv);
+ }
+ }
+ else
+ *++newsp =
+ SvPADTMP(*SP)
+ ? sv_mortalcopy(*SP)
+ : !SvTEMP(*SP)
+ ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
+ : *SP;
+ }
+ else {
+ EXTEND(newsp,1);
+ *++newsp = &PL_sv_undef;
+ }
+ if (CxLVAL(cx) & OPpDEREF) {
+ SvGETMAGIC(TOPs);
+ if (!SvOK(TOPs)) {
+ TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
+ }
+ }
+ }
+ else if (gimme == G_ARRAY) {
+ assert (!(CxLVAL(cx) & OPpDEREF));
+ if (ref || !CxLVAL(cx))
+ while (++MARK <= SP)
+ *++newsp =
+ SvFLAGS(*MARK) & SVs_PADTMP
+ ? sv_mortalcopy(*MARK)
+ : SvTEMP(*MARK)
+ ? *MARK
+ : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
+ else while (++MARK <= SP) {
+ if (*MARK != &PL_sv_undef
+ && (SvPADTMP(*MARK)
+ || (SvFLAGS(*MARK) & (SVf_READONLY|SVf_FAKE))
+ == SVf_READONLY
+ )
+ ) {
+ SV *sv;
+ /* Might be flattened array after $#array = */
+ PUTBACK;
+ LEAVE;
+ cxstack_ix--;
+ POPSUB(cx,sv);
+ PL_curpm = newpm;
+ LEAVESUB(sv);
+ /* diag_listed_as: Can't return %s from lvalue subroutine */
+ Perl_croak(aTHX_
+ "Can't return a %s from lvalue subroutine",
+ SvREADONLY(TOPs) ? "readonly value" : "temporary");
+ }
+ else
+ *++newsp =
+ SvTEMP(*MARK)
+ ? *MARK
+ : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
+ }
+ }
+ PL_stack_sp = newsp;
+}
+
PP(pp_return)
{
dVAR; dSP; dMARK;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
bool popsub2 = FALSE;
bool clear_errsv = FALSE;
+ bool lval = FALSE;
I32 gimme;
SV **newsp;
PMOP *newpm;
@@ -2298,6 +2440,7 @@
switch (CxTYPE(cx)) {
case CXt_SUB:
popsub2 = TRUE;
+ lval = !!CvLVALUE(cx->blk_sub.cv);
retop = cx->blk_sub.retop;
cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
break;
@@ -2314,7 +2457,8 @@
{
/* Unassume the success we assumed earlier. */
(void)hv_delete(GvHVn(PL_incgv),
- SvPVX_const(namesv), SvCUR(namesv),
+ SvPVX_const(namesv),
+ SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
G_DISCARD);
DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
}
@@ -2324,15 +2468,18 @@
retop = cx->blk_sub.retop;
break;
default:
- DIE(aTHX_ "panic: return");
+ DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
}
TAINT_NOT;
- if (gimme == G_SCALAR) {
+ if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
+ else {
+ if (gimme == G_SCALAR) {
if (MARK < SP) {
if (popsub2) {
if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
- if (SvTEMP(TOPs)) {
+ if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
+ && !SvMAGICAL(TOPs)) {
*++newsp = SvREFCNT_inc(*SP);
FREETMPS;
sv_2mortal(*newsp);
@@ -2344,8 +2491,12 @@
SvREFCNT_dec(sv);
}
}
+ else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1
+ && !SvMAGICAL(*SP)) {
+ *++newsp = *SP;
+ }
else
- *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
+ *++newsp = sv_mortalcopy(*SP);
}
else
*++newsp = sv_mortalcopy(*SP);
@@ -2352,15 +2503,17 @@
}
else
*++newsp = &PL_sv_undef;
- }
- else if (gimme == G_ARRAY) {
+ }
+ else if (gimme == G_ARRAY) {
while (++MARK <= SP) {
- *++newsp = (popsub2 && SvTEMP(*MARK))
+ *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
+ && !SvGMAGICAL(*MARK)
? *MARK : sv_mortalcopy(*MARK);
TAINT_NOT; /* Each item is independent */
}
+ }
+ PL_stack_sp = newsp;
}
- PL_stack_sp = newsp;
LEAVE;
/* Stack values are safe: */
@@ -2379,34 +2532,91 @@
return retop;
}
-PP(pp_last)
+/* This duplicates parts of pp_leavesub, so that it can share code with
+ * pp_return */
+PP(pp_leavesublv)
{
dVAR; dSP;
- I32 cxix;
- register PERL_CONTEXT *cx;
- I32 pop2 = 0;
- I32 gimme;
- I32 optype;
- OP *nextop = NULL;
SV **newsp;
PMOP *newpm;
- SV **mark;
- SV *sv = NULL;
+ I32 gimme;
+ PERL_CONTEXT *cx;
+ SV *sv;
+ if (CxMULTICALL(&cxstack[cxstack_ix]))
+ return 0;
+ POPBLOCK(cx,newpm);
+ cxstack_ix++; /* temporarily protect top context */
+
+ TAINT_NOT;
+
+ S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
+
+ LEAVE;
+ cxstack_ix--;
+ POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
+ PL_curpm = newpm; /* ... and pop $1 et al */
+
+ LEAVESUB(sv);
+ return cx->blk_sub.retop;
+}
+
+static I32
+S_unwind_loop(pTHX_ const char * const opname)
+{
+ dVAR;
+ I32 cxix;
if (PL_op->op_flags & OPf_SPECIAL) {
cxix = dopoptoloop(cxstack_ix);
if (cxix < 0)
- DIE(aTHX_ "Can't \"last\" outside a loop block");
+ /* diag_listed_as: Can't "last" outside a loop block */
+ Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname);
}
else {
- cxix = dopoptolabel(cPVOP->op_pv);
+ dSP;
+ STRLEN label_len;
+ const char * const label =
+ PL_op->op_flags & OPf_STACKED
+ ? SvPV(TOPs,label_len)
+ : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
+ const U32 label_flags =
+ PL_op->op_flags & OPf_STACKED
+ ? SvUTF8(POPs)
+ : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
+ PUTBACK;
+ cxix = dopoptolabel(label, label_len, label_flags);
if (cxix < 0)
- DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
+ /* diag_listed_as: Label not found for "last %s" */
+ Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"",
+ opname,
+ SVfARG(PL_op->op_flags & OPf_STACKED
+ && !SvGMAGICAL(TOPp1s)
+ ? TOPp1s
+ : newSVpvn_flags(label,
+ label_len,
+ label_flags | SVs_TEMP)));
}
if (cxix < cxstack_ix)
dounwind(cxix);
+ return cxix;
+}
+PP(pp_last)
+{
+ dVAR;
+ PERL_CONTEXT *cx;
+ I32 pop2 = 0;
+ I32 gimme;
+ I32 optype;
+ OP *nextop = NULL;
+ SV **newsp;
+ PMOP *newpm;
+ SV **mark;
+ SV *sv = NULL;
+
+ S_unwind_loop(aTHX_ "last");
+
POPBLOCK(cx,newpm);
cxstack_ix++; /* temporarily protect top context */
mark = newsp;
@@ -2432,26 +2642,12 @@
nextop = cx->blk_sub.retop;
break;
default:
- DIE(aTHX_ "panic: last");
+ DIE(aTHX_ "panic: last, type=%u", (unsigned) CxTYPE(cx));
}
TAINT_NOT;
- if (gimme == G_SCALAR) {
- if (MARK < SP)
- *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
- ? *SP : sv_mortalcopy(*SP);
- else
- *++newsp = &PL_sv_undef;
- }
- else if (gimme == G_ARRAY) {
- while (++MARK <= SP) {
- *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
- ? *MARK : sv_mortalcopy(*MARK);
- TAINT_NOT; /* Each item is independent */
- }
- }
- SP = newsp;
- PUTBACK;
+ PL_stack_sp = adjust_stack_on_leave(newsp, PL_stack_sp, MARK, gimme,
+ pop2 == CXt_SUB ? SVs_TEMP : 0);
LEAVE;
cxstack_ix--;
@@ -2479,30 +2675,18 @@
PP(pp_next)
{
dVAR;
- I32 cxix;
- register PERL_CONTEXT *cx;
- I32 inner;
+ PERL_CONTEXT *cx;
+ const I32 inner = PL_scopestack_ix;
- if (PL_op->op_flags & OPf_SPECIAL) {
- cxix = dopoptoloop(cxstack_ix);
- if (cxix < 0)
- DIE(aTHX_ "Can't \"next\" outside a loop block");
- }
- else {
- cxix = dopoptolabel(cPVOP->op_pv);
- if (cxix < 0)
- DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
- }
- if (cxix < cxstack_ix)
- dounwind(cxix);
+ S_unwind_loop(aTHX_ "next");
/* clear off anything above the scope we're re-entering, but
* save the rest until after a possible continue block */
- inner = PL_scopestack_ix;
TOPBLOCK(cx);
if (PL_scopestack_ix < inner)
leave_scope(PL_scopestack[PL_scopestack_ix]);
PL_curcop = cx->blk_oldcop;
+ PERL_ASYNC_CHECK();
return (cx)->blk_loop.my_op->op_nextop;
}
@@ -2509,25 +2693,11 @@
PP(pp_redo)
{
dVAR;
- I32 cxix;
- register PERL_CONTEXT *cx;
+ const I32 cxix = S_unwind_loop(aTHX_ "redo");
+ PERL_CONTEXT *cx;
I32 oldsave;
- OP* redo_op;
+ OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
- if (PL_op->op_flags & OPf_SPECIAL) {
- cxix = dopoptoloop(cxstack_ix);
- if (cxix < 0)
- DIE(aTHX_ "Can't \"redo\" outside a loop block");
- }
- else {
- cxix = dopoptolabel(cPVOP->op_pv);
- if (cxix < 0)
- DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
- }
- if (cxix < cxstack_ix)
- dounwind(cxix);
-
- redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
if (redo_op->op_type == OP_ENTER) {
/* pop one less context to avoid $x being freed in while (my $x..) */
cxstack_ix++;
@@ -2540,20 +2710,21 @@
LEAVE_SCOPE(oldsave);
FREETMPS;
PL_curcop = cx->blk_oldcop;
+ PERL_ASYNC_CHECK();
return redo_op;
}
STATIC OP *
-S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
+S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
{
dVAR;
OP **ops = opstack;
- static const char too_deep[] = "Target of goto is too deeply nested";
+ static const char* const too_deep = "Target of goto is too deeply nested";
PERL_ARGS_ASSERT_DOFINDLABEL;
if (ops >= oplimit)
- Perl_croak(aTHX_ too_deep);
+ Perl_croak(aTHX_ "%s", too_deep);
if (o->op_type == OP_LEAVE ||
o->op_type == OP_SCOPE ||
o->op_type == OP_LEAVELOOP ||
@@ -2562,7 +2733,7 @@
{
*ops++ = cUNOPo->op_first;
if (ops >= oplimit)
- Perl_croak(aTHX_ too_deep);
+ Perl_croak(aTHX_ "%s", too_deep);
}
*ops = 0;
if (o->op_flags & OPf_KIDS) {
@@ -2570,8 +2741,21 @@
/* First try all the kids at this level, since that's likeliest. */
for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
- const char *kid_label = CopLABEL(kCOP);
- if (kid_label && strEQ(kid_label, label))
+ STRLEN kid_label_len;
+ U32 kid_label_flags;
+ const char *kid_label = CopLABEL_len_flags(kCOP,
+ &kid_label_len, &kid_label_flags);
+ if (kid_label && (
+ ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
+ (flags & SVf_UTF8)
+ ? (bytes_cmp_utf8(
+ (const U8*)kid_label, kid_label_len,
+ (const U8*)label, len) == 0)
+ : (bytes_cmp_utf8(
+ (const U8*)label, len,
+ (const U8*)kid_label, kid_label_len) == 0)
+ : ( len == kid_label_len && ((kid_label == label)
+ || memEQ(kid_label, label, len)))))
return kid;
}
}
@@ -2587,7 +2771,7 @@
else
*ops++ = kid;
}
- if ((o = dofindlabel(kid, label, ops, oplimit)))
+ if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
return o;
}
}
@@ -2600,25 +2784,26 @@
dVAR; dSP;
OP *retop = NULL;
I32 ix;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
#define GOTO_DEPTH 64
OP *enterops[GOTO_DEPTH];
const char *label = NULL;
+ STRLEN label_len = 0;
+ U32 label_flags = 0;
const bool do_dump = (PL_op->op_type == OP_DUMP);
- static const char must_have_label[] = "goto must have label";
+ static const char* const must_have_label = "goto must have label";
if (PL_op->op_flags & OPf_STACKED) {
SV * const sv = POPs;
+ SvGETMAGIC(sv);
/* This egregious kludge implements goto &subroutine */
if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
I32 cxix;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
CV *cv = MUTABLE_CV(SvRV(sv));
- SV** mark;
- I32 items = 0;
+ AV *arg = GvAV(PL_defgv);
I32 oldsave;
- bool reified = 0;
retry:
if (!CvROOT(cv) && !CvXSUB(cv)) {
@@ -2629,8 +2814,9 @@
/* autoloaded stub? */
if (cv != GvCV(gv) && (cv = GvCV(gv)))
goto retry;
- autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
- GvNAMELEN(gv), FALSE);
+ autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
+ GvNAMELEN(gv),
+ GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
if (autogv && (cv = GvCV(autogv)))
goto retry;
tmpstr = sv_newmortal();
@@ -2644,49 +2830,45 @@
SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
FREETMPS;
cxix = dopoptosub(cxstack_ix);
- if (cxix < 0)
- DIE(aTHX_ "Can't goto subroutine outside a subroutine");
- if (cxix < cxstack_ix)
+ if (cxix < cxstack_ix) {
+ if (cxix < 0) {
+ SvREFCNT_dec(cv);
+ DIE(aTHX_ "Can't goto subroutine outside a subroutine");
+ }
dounwind(cxix);
+ }
TOPBLOCK(cx);
SPAGAIN;
/* ban goto in eval: see <20050521150056.GC20213 at iabyn.com> */
if (CxTYPE(cx) == CXt_EVAL) {
+ SvREFCNT_dec(cv);
if (CxREALEVAL(cx))
+ /* diag_listed_as: Can't goto subroutine from an eval-%s */
DIE(aTHX_ "Can't goto subroutine from an eval-string");
else
+ /* diag_listed_as: Can't goto subroutine from an eval-%s */
DIE(aTHX_ "Can't goto subroutine from an eval-block");
}
else if (CxMULTICALL(cx))
+ {
+ SvREFCNT_dec(cv);
DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
+ }
if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
- /* put @_ back onto stack */
AV* av = cx->blk_sub.argarray;
- items = AvFILLp(av) + 1;
- EXTEND(SP, items+1); /* @_ could have been extended. */
- Copy(AvARRAY(av), SP + 1, items, SV*);
- SvREFCNT_dec(GvAV(PL_defgv));
- GvAV(PL_defgv) = cx->blk_sub.savearray;
- CLEAR_ARGARRAY(av);
- /* abandon @_ if it got reified */
- if (AvREAL(av)) {
- reified = 1;
+ /* abandon the original @_ if it got reified or if it is
+ the same as the current @_ */
+ if (AvREAL(av) || av == arg) {
SvREFCNT_dec(av);
av = newAV();
- av_extend(av, items-1);
AvREIFY_only(av);
PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
}
+ else CLEAR_ARGARRAY(av);
}
- else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
- AV* const av = GvAV(PL_defgv);
- items = AvFILLp(av) + 1;
- EXTEND(SP, items+1); /* @_ could have been extended. */
- Copy(AvARRAY(av), SP + 1, items, SV*);
- }
- mark = SP;
- SP += items;
+ /* We donate this refcount later to the callee’s pad. */
+ SvREFCNT_inc_simple_void(arg);
if (CxTYPE(cx) == CXt_SUB &&
!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
SvREFCNT_dec(cx->blk_sub.cv);
@@ -2693,6 +2875,20 @@
oldsave = PL_scopestack[PL_scopestack_ix - 1];
LEAVE_SCOPE(oldsave);
+ /* A destructor called during LEAVE_SCOPE could have undefined
+ * our precious cv. See bug #99850. */
+ if (!CvROOT(cv) && !CvXSUB(cv)) {
+ const GV * const gv = CvGV(cv);
+ SvREFCNT_dec(arg);
+ if (gv) {
+ SV * const tmpstr = sv_newmortal();
+ gv_efullname3(tmpstr, gv, NULL);
+ DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
+ SVfARG(tmpstr));
+ }
+ DIE(aTHX_ "Goto undefined subroutine");
+ }
+
/* Now do some callish stuff. */
SAVETMPS;
SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
@@ -2700,11 +2896,29 @@
OP* const retop = cx->blk_sub.retop;
SV **newsp;
I32 gimme;
- if (reified) {
+ const SSize_t items = AvFILLp(arg) + 1;
+ SV** mark;
+
+ PERL_UNUSED_VAR(newsp);
+ PERL_UNUSED_VAR(gimme);
+
+ /* put GvAV(defgv) back onto stack */
+ EXTEND(SP, items+1); /* @_ could have been extended. */
+ Copy(AvARRAY(arg), SP + 1, items, SV*);
+ mark = SP;
+ SP += items;
+ if (AvREAL(arg)) {
I32 index;
for (index=0; index<items; index++)
- sv_2mortal(SP[-index]);
+ SvREFCNT_inc_void(sv_2mortal(SP[-index]));
}
+ SvREFCNT_dec(arg);
+ if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
+ /* Restore old @_ */
+ arg = GvAV(PL_defgv);
+ GvAV(PL_defgv) = cx->blk_sub.savearray;
+ SvREFCNT_dec(arg);
+ }
/* XS subs don't have a CxSUB, so pop it */
POPBLOCK(cx, PL_curpm);
@@ -2713,15 +2927,11 @@
PUTBACK;
(void)(*CvXSUB(cv))(aTHX_ cv);
LEAVE;
+ PERL_ASYNC_CHECK();
return retop;
}
else {
- AV* const padlist = CvPADLIST(cv);
- if (CxTYPE(cx) == CXt_EVAL) {
- PL_in_eval = CxOLD_IN_EVAL(cx);
- PL_eval_root = cx->blk_eval.old_eval_root;
- cx->cx_type = CXt_SUB;
- }
+ PADLIST * const padlist = CvPADLIST(cv);
cx->blk_sub.cv = cv;
cx->blk_sub.olddepth = CvDEPTH(cv);
@@ -2733,45 +2943,31 @@
sub_crush_depth(cv);
pad_push(padlist, CvDEPTH(cv));
}
+ PL_curcop = cx->blk_oldcop;
SAVECOMPPAD();
PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
if (CxHASARGS(cx))
{
- AV *const av = MUTABLE_AV(PAD_SVl(0));
-
- cx->blk_sub.savearray = GvAV(PL_defgv);
- GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
CX_CURPAD_SAVE(cx->blk_sub);
- cx->blk_sub.argarray = av;
- if (items >= AvMAX(av) + 1) {
- SV **ary = AvALLOC(av);
- if (AvARRAY(av) != ary) {
- AvMAX(av) += AvARRAY(av) - AvALLOC(av);
- AvARRAY(av) = ary;
- }
- if (items >= AvMAX(av) + 1) {
- AvMAX(av) = items - 1;
- Renew(ary,items+1,SV*);
- AvALLOC(av) = ary;
- AvARRAY(av) = ary;
- }
+ /* cx->blk_sub.argarray has no reference count, so we
+ need something to hang on to our argument array so
+ that cx->blk_sub.argarray does not end up pointing
+ to freed memory as the result of undef *_. So put
+ it in the callee’s pad, donating our refer-
+ ence count. */
+ SvREFCNT_dec(PAD_SVl(0));
+ PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg);
+
+ /* GvAV(PL_defgv) might have been modified on scope
+ exit, so restore it. */
+ if (arg != GvAV(PL_defgv)) {
+ AV * const av = GvAV(PL_defgv);
+ GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
+ SvREFCNT_dec(av);
}
- ++mark;
- Copy(mark,AvARRAY(av),items,SV*);
- AvFILLp(av) = items - 1;
- assert(!AvREAL(av));
- if (reified) {
- /* transfer 'ownership' of refcnts to new @_ */
- AvREAL_on(av);
- AvREIFY_off(av);
- }
- while (items--) {
- if (*mark)
- SvTEMP_off(*mark);
- mark++;
- }
}
+ else SvREFCNT_dec(arg);
if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
Perl_get_db_sub(aTHX_ NULL, cv);
if (PERLDB_GOTO) {
@@ -2783,25 +2979,25 @@
}
}
}
+ PERL_ASYNC_CHECK();
RETURNOP(CvSTART(cv));
}
}
else {
- label = SvPV_nolen_const(sv);
- if (!(do_dump || *label))
- DIE(aTHX_ must_have_label);
+ label = SvPV_nomg_const(sv, label_len);
+ label_flags = SvUTF8(sv);
}
}
- else if (PL_op->op_flags & OPf_SPECIAL) {
- if (! do_dump)
- DIE(aTHX_ must_have_label);
+ else if (!(PL_op->op_flags & OPf_SPECIAL)) {
+ label = cPVOP->op_pv;
+ label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
+ label_len = strlen(label);
}
- else
- label = cPVOP->op_pv;
+ if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
PERL_ASYNC_CHECK();
- if (label && *label) {
+ if (label_len) {
OP *gotoprobe = NULL;
bool leaving_eval = FALSE;
bool in_block = FALSE;
@@ -2852,12 +3048,13 @@
DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
default:
if (ix)
- DIE(aTHX_ "panic: goto");
+ DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
+ CxTYPE(cx), (long) ix);
gotoprobe = PL_main_root;
break;
}
if (gotoprobe) {
- retop = dofindlabel(gotoprobe, label,
+ retop = dofindlabel(gotoprobe, label, label_len, label_flags,
enterops, enterops + GOTO_DEPTH);
if (retop)
break;
@@ -2865,7 +3062,8 @@
gotoprobe->op_sibling->op_type == OP_UNSTACK &&
gotoprobe->op_sibling->op_sibling) {
retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
- label, enterops, enterops + GOTO_DEPTH);
+ label, label_len, label_flags, enterops,
+ enterops + GOTO_DEPTH);
if (retop)
break;
}
@@ -2873,7 +3071,9 @@
PL_lastgotoprobe = gotoprobe;
}
if (!retop)
- DIE(aTHX_ "Can't find label %s", label);
+ DIE(aTHX_ "Can't find label %"SVf,
+ SVfARG(newSVpvn_flags(label, label_len,
+ SVs_TEMP | label_flags)));
/* if we're leaving an eval, check before we pop any frames
that we're not going to punt, otherwise the error
@@ -2935,6 +3135,7 @@
PL_do_undump = FALSE;
}
+ PERL_ASYNC_CHECK();
RETURNOP(retop);
}
@@ -2946,6 +3147,9 @@
if (MAXARG < 1)
anum = 0;
+ else if (!TOPs) {
+ anum = 0; (void)POPs;
+ }
else {
anum = SvIVx(POPs);
#ifdef VMS
@@ -3042,7 +3246,7 @@
JMPENV_POP;
PL_op = oldop;
JMPENV_JUMP(ret);
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
}
JMPENV_POP;
PL_op = oldop;
@@ -3049,143 +3253,7 @@
return NULL;
}
-/* James Bond: Do you expect me to talk?
- Auric Goldfinger: No, Mr. Bond. I expect you to die.
- This code is an ugly hack, doesn't work with lexicals in subroutines that are
- called more than once, and is only used by regcomp.c, for (?{}) blocks.
-
- Currently it is not used outside the core code. Best if it stays that way.
-
- Hence it's now deprecated, and will be removed.
-*/
-OP *
-Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
-/* sv Text to convert to OP tree. */
-/* startop op_free() this to undo. */
-/* code Short string id of the caller. */
-{
- PERL_ARGS_ASSERT_SV_COMPILE_2OP;
- return Perl_sv_compile_2op_is_broken(aTHX_ sv, startop, code, padp);
-}
-
-/* Don't use this. It will go away without warning once the regexp engine is
- refactored not to use it. */
-OP *
-Perl_sv_compile_2op_is_broken(pTHX_ SV *sv, OP **startop, const char *code,
- PAD **padp)
-{
- dVAR; dSP; /* Make POPBLOCK work. */
- PERL_CONTEXT *cx;
- SV **newsp;
- I32 gimme = G_VOID;
- I32 optype;
- OP dummy;
- char tbuf[TYPE_DIGITS(long) + 12 + 10];
- char *tmpbuf = tbuf;
- char *safestr;
- int runtime;
- CV* runcv = NULL; /* initialise to avoid compiler warnings */
- STRLEN len;
- bool need_catch;
-
- PERL_ARGS_ASSERT_SV_COMPILE_2OP_IS_BROKEN;
-
- ENTER_with_name("eval");
- lex_start(sv, NULL, LEX_START_SAME_FILTER);
- SAVETMPS;
- /* switch to eval mode */
-
- if (IN_PERL_COMPILETIME) {
- SAVECOPSTASH_FREE(&PL_compiling);
- CopSTASH_set(&PL_compiling, PL_curstash);
- }
- if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
- SV * const sv = sv_newmortal();
- Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
- code, (unsigned long)++PL_evalseq,
- CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
- tmpbuf = SvPVX(sv);
- len = SvCUR(sv);
- }
- else
- len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
- (unsigned long)++PL_evalseq);
- SAVECOPFILE_FREE(&PL_compiling);
- CopFILE_set(&PL_compiling, tmpbuf+2);
- SAVECOPLINE(&PL_compiling);
- CopLINE_set(&PL_compiling, 1);
- /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
- deleting the eval's FILEGV from the stash before gv_check() runs
- (i.e. before run-time proper). To work around the coredump that
- ensues, we always turn GvMULTI_on for any globals that were
- introduced within evals. See force_ident(). GSAR 96-10-12 */
- safestr = savepvn(tmpbuf, len);
- SAVEDELETE(PL_defstash, safestr, len);
- SAVEHINTS();
-#ifdef OP_IN_REGISTER
- PL_opsave = op;
-#else
- SAVEVPTR(PL_op);
-#endif
-
- /* we get here either during compilation, or via pp_regcomp at runtime */
- runtime = IN_PERL_RUNTIME;
- if (runtime)
- {
- runcv = find_runcv(NULL);
-
- /* At run time, we have to fetch the hints from PL_curcop. */
- PL_hints = PL_curcop->cop_hints;
- if (PL_hints & HINT_LOCALIZE_HH) {
- /* SAVEHINTS created a new HV in PL_hintgv, which we
- need to GC */
- SvREFCNT_dec(GvHV(PL_hintgv));
- GvHV(PL_hintgv) =
- refcounted_he_chain_2hv(PL_curcop->cop_hints_hash, 0);
- hv_magic(GvHV(PL_hintgv), NULL, PERL_MAGIC_hints);
- }
- SAVECOMPILEWARNINGS();
- PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
- cophh_free(CopHINTHASH_get(&PL_compiling));
- /* XXX Does this need to avoid copying a label? */
- PL_compiling.cop_hints_hash
- = cophh_copy(PL_curcop->cop_hints_hash);
- }
-
- PL_op = &dummy;
- PL_op->op_type = OP_ENTEREVAL;
- PL_op->op_flags = 0; /* Avoid uninit warning. */
- PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
- PUSHEVAL(cx, 0);
- need_catch = CATCH_GET;
- CATCH_SET(TRUE);
-
- if (runtime)
- (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
- else
- (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
- CATCH_SET(need_catch);
- POPBLOCK(cx,PL_curpm);
- POPEVAL(cx);
-
- (*startop)->op_type = OP_NULL;
- (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
- /* XXX DAPM do this properly one year */
- *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
- LEAVE_with_name("eval");
- if (IN_PERL_COMPILETIME)
- CopHINTS_set(&PL_compiling, PL_hints);
-#ifdef OP_IN_REGISTER
- op = PL_opsave;
-#endif
- PERL_UNUSED_VAR(newsp);
- PERL_UNUSED_VAR(optype);
-
- return PL_eval_start;
-}
-
-
/*
=for apidoc find_runcv
@@ -3201,8 +3269,16 @@
CV*
Perl_find_runcv(pTHX_ U32 *db_seqp)
{
+ return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
+}
+
+/* If this becomes part of the API, it might need a better name. */
+CV *
+Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
+{
dVAR;
PERL_SI *si;
+ int level = 0;
if (db_seqp)
*db_seqp = PL_curcop->cop_seq;
@@ -3210,20 +3286,36 @@
I32 ix;
for (ix = si->si_cxix; ix >= 0; ix--) {
const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
+ CV *cv = NULL;
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
- CV * const cv = cx->blk_sub.cv;
+ cv = cx->blk_sub.cv;
/* skip DB:: code */
if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
*db_seqp = cx->blk_oldcop->cop_seq;
continue;
}
- return cv;
+ if (cx->cx_type & CXp_SUB_RE)
+ continue;
}
else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
- return PL_compcv;
+ cv = cx->blk_eval.cv;
+ if (cv) {
+ switch (cond) {
+ case FIND_RUNCV_padid_eq:
+ if (!CvPADLIST(cv)
+ || PadlistNAMES(CvPADLIST(cv)) != INT2PTR(PADNAMELIST *, arg))
+ continue;
+ return cv;
+ case FIND_RUNCV_level_eq:
+ if (level++ != arg) continue;
+ /* GERONIMO! */
+ default:
+ return cv;
+ }
+ }
}
}
- return PL_main_cv;
+ return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
}
@@ -3249,7 +3341,7 @@
default:
JMPENV_POP;
JMPENV_JUMP(ret);
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
}
JMPENV_POP;
return ret;
@@ -3256,52 +3348,62 @@
}
-/* Compile a require/do, an eval '', or a /(?{...})/.
- * In the last case, startop is non-null, and contains the address of
- * a pointer that should be set to the just-compiled code.
+/* Compile a require/do or an eval ''.
+ *
* outside is the lexically enclosing CV (if any) that invoked us.
+ * seq is the current COP scope value.
+ * hh is the saved hints hash, if any.
+ *
* Returns a bool indicating whether the compile was successful; if so,
- * PL_eval_start contains the first op of the compiled ocde; otherwise,
- * pushes undef (also croaks if startop != NULL).
+ * PL_eval_start contains the first op of the compiled code; otherwise,
+ * pushes undef.
+ *
+ * This function is called from two places: pp_require and pp_entereval.
+ * These can be distinguished by whether PL_op is entereval.
*/
STATIC bool
-S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
+S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
{
dVAR; dSP;
OP * const saveop = PL_op;
- bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
+ bool clear_hints = saveop->op_type != OP_ENTEREVAL;
+ COP * const oldcurcop = PL_curcop;
+ bool in_require = (saveop->op_type == OP_REQUIRE);
int yystatus;
+ CV *evalcv;
PL_in_eval = (in_require
? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
- : EVAL_INEVAL);
+ : (EVAL_INEVAL |
+ ((PL_op->op_private & OPpEVAL_RE_REPARSING)
+ ? EVAL_RE_REPARSING : 0)));
PUSHMARK(SP);
- SAVESPTR(PL_compcv);
- PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
- CvEVAL_on(PL_compcv);
+ evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
+ CvEVAL_on(evalcv);
assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
- cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
+ cxstack[cxstack_ix].blk_eval.cv = evalcv;
+ cxstack[cxstack_ix].blk_gimme = gimme;
- CvOUTSIDE_SEQ(PL_compcv) = seq;
- CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
+ CvOUTSIDE_SEQ(evalcv) = seq;
+ CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
/* set up a scratch pad */
- CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
+ CvPADLIST(evalcv) = pad_new(padnew_SAVE);
PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
if (!PL_madskills)
- SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
+ SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
/* make sure we compile in the right package */
if (CopSTASH_ne(PL_curcop, PL_curstash)) {
- SAVESPTR(PL_curstash);
- PL_curstash = CopSTASH(PL_curcop);
+ SAVEGENERICSV(PL_curstash);
+ PL_curstash = (HV *)SvREFCNT_inc_simple(CopSTASH(PL_curcop));
}
/* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
SAVESPTR(PL_beginav);
@@ -3316,16 +3418,68 @@
PL_madskills = 0;
#endif
+ ENTER_with_name("evalcomp");
+ SAVESPTR(PL_compcv);
+ PL_compcv = evalcv;
+
/* try to compile it */
PL_eval_root = NULL;
PL_curcop = &PL_compiling;
- CopARYBASE_set(PL_curcop, 0);
- if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
+ if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
PL_in_eval |= EVAL_KEEPERR;
else
CLEAR_ERRSV();
+ SAVEHINTS();
+ if (clear_hints) {
+ PL_hints = 0;
+ hv_clear(GvHV(PL_hintgv));
+ }
+ else {
+ PL_hints = saveop->op_private & OPpEVAL_COPHH
+ ? oldcurcop->cop_hints : saveop->op_targ;
+
+ /* making 'use re eval' not be in scope when compiling the
+ * qr/mabye_has_runtime_code_block/ ensures that we don't get
+ * infinite recursion when S_has_runtime_code() gives a false
+ * positive: the second time round, HINT_RE_EVAL isn't set so we
+ * don't bother calling S_has_runtime_code() */
+ if (PL_in_eval & EVAL_RE_REPARSING)
+ PL_hints &= ~HINT_RE_EVAL;
+
+ if (hh) {
+ /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
+ SvREFCNT_dec(GvHV(PL_hintgv));
+ GvHV(PL_hintgv) = hh;
+ }
+ }
+ SAVECOMPILEWARNINGS();
+ if (clear_hints) {
+ if (PL_dowarn & G_WARN_ALL_ON)
+ PL_compiling.cop_warnings = pWARN_ALL ;
+ else if (PL_dowarn & G_WARN_ALL_OFF)
+ PL_compiling.cop_warnings = pWARN_NONE ;
+ else
+ PL_compiling.cop_warnings = pWARN_STD ;
+ }
+ else {
+ PL_compiling.cop_warnings =
+ DUP_WARNINGS(oldcurcop->cop_warnings);
+ cophh_free(CopHINTHASH_get(&PL_compiling));
+ if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
+ /* The label, if present, is the first entry on the chain. So rather
+ than writing a blank label in front of it (which involves an
+ allocation), just use the next entry in the chain. */
+ PL_compiling.cop_hints_hash
+ = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
+ /* Check the assumption that this removed the label. */
+ assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
+ }
+ else
+ PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
+ }
+
CALL_BLOCK_HOOKS(bhk_eval, saveop);
/* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
@@ -3335,11 +3489,13 @@
if (yystatus || PL_parser->error_count || !PL_eval_root) {
SV **newsp; /* Used by POPBLOCK. */
- PERL_CONTEXT *cx = NULL;
+ PERL_CONTEXT *cx;
I32 optype; /* Used by POPEVAL. */
- SV *namesv = NULL;
- const char *msg;
+ SV *namesv;
+ SV *errsv = NULL;
+ cx = NULL;
+ namesv = NULL;
PERL_UNUSED_VAR(newsp);
PERL_UNUSED_VAR(optype);
@@ -3352,16 +3508,14 @@
PL_eval_root = NULL;
}
SP = PL_stack_base + POPMARK; /* pop original mark */
- if (!startop) {
- POPBLOCK(cx,PL_curpm);
- POPEVAL(cx);
- namesv = cx->blk_eval.old_namesv;
- }
+ POPBLOCK(cx,PL_curpm);
+ POPEVAL(cx);
+ namesv = cx->blk_eval.old_namesv;
+ /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
+ LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
}
- if (yystatus != 3)
- LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
- msg = SvPVx_nolen_const(ERRSV);
+ errsv = ERRSV;
if (in_require) {
if (!cx) {
/* If cx is still NULL, it means that we didn't go in the
@@ -3371,47 +3525,34 @@
namesv = cx->blk_eval.old_namesv;
}
(void)hv_store(GvHVn(PL_incgv),
- SvPVX_const(namesv), SvCUR(namesv),
+ SvPVX_const(namesv),
+ SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
&PL_sv_undef, 0);
- Perl_croak(aTHX_ "%sCompilation failed in require",
- *msg ? msg : "Unknown error\n");
+ Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
+ SVfARG(errsv
+ ? errsv
+ : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
}
- else if (startop) {
- if (yystatus != 3) {
- POPBLOCK(cx,PL_curpm);
- POPEVAL(cx);
- }
- Perl_croak(aTHX_ "%sCompilation failed in regexp",
- (*msg ? msg : "Unknown error\n"));
- }
else {
- if (!*msg) {
- sv_setpvs(ERRSV, "Compilation error");
+ if (!*(SvPV_nolen_const(errsv))) {
+ sv_setpvs(errsv, "Compilation error");
}
}
- PUSHs(&PL_sv_undef);
+ if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
PUTBACK;
return FALSE;
}
+ else
+ LEAVE_with_name("evalcomp");
+
CopLINE_set(&PL_compiling, 0);
- if (startop) {
- *startop = PL_eval_root;
- } else
- SAVEFREEOP(PL_eval_root);
+ SAVEFREEOP(PL_eval_root);
+ cv_forget_slab(evalcv);
- /* Set the context for this new optree.
- * Propagate the context from the eval(). */
- if ((gimme & G_WANT) == G_VOID)
- scalarvoid(PL_eval_root);
- else if ((gimme & G_WANT) == G_ARRAY)
- list(PL_eval_root);
- else
- scalar(PL_eval_root);
-
DEBUG_x(dump_eval());
/* Register with debugger: */
- if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
+ if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
CV * const cv = get_cvs("DB::postponed", 0);
if (cv) {
dSP;
@@ -3430,7 +3571,7 @@
/* compiled okay, so do it */
- CvDEPTH(PL_compcv) = 1;
+ CvDEPTH(evalcv) = 1;
SP = PL_stack_base + POPMARK; /* pop original mark */
PL_op = saveop; /* The caller may need it. */
PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
@@ -3453,7 +3594,7 @@
}
#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
- return PerlIO_openn(aTHX_ NULL, PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
+ return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
#else
return PerlIO_open(p, PERL_SCRIPT_MODE);
#endif
@@ -3487,7 +3628,7 @@
PP(pp_require)
{
dVAR; dSP;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
SV *sv;
const char *name;
STRLEN len;
@@ -3495,6 +3636,9 @@
STRLEN unixlen;
#ifdef VMS
int vms_unixname = 0;
+ char *unixnamebuf;
+ char *unixdir;
+ char *unixdirbuf;
#endif
const char *tryname = NULL;
SV *namesv = NULL;
@@ -3507,11 +3651,12 @@
SV *hook_sv = NULL;
SV *encoding;
OP *op;
+ int saved_errno;
sv = POPs;
if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
sv = sv_2mortal(new_version(sv));
- if (!sv_derived_from(PL_patchlevel, "version"))
+ if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
upg_version(PL_patchlevel, TRUE);
if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
if ( vcmp(sv,PL_patchlevel) <= 0 )
@@ -3579,7 +3724,9 @@
* To prevent this, the key must be stored in UNIX format if the VMS
* name can be translated to UNIX.
*/
- if ((unixname = tounixspec(name, NULL)) != NULL) {
+
+ if ((unixnamebuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1))))
+ && (unixname = tounixspec(name, unixnamebuf)) != NULL) {
unixlen = strlen(unixname);
vms_unixname = 1;
}
@@ -3604,6 +3751,8 @@
}
}
+ LOADING_FILE_PROBE(unixname);
+
/* prepare to compile file */
if (path_is_absolute(name)) {
@@ -3611,7 +3760,7 @@
tryname = name;
tryrsfp = doopen_pm(sv);
}
- if (!tryrsfp) {
+ if (!tryrsfp && !(errno == EACCES && path_is_absolute(name))) {
AV * const ar = GvAVn(PL_incgv);
I32 i;
#ifdef VMS
@@ -3754,8 +3903,8 @@
}
#ifdef VMS
- char *unixdir;
- if ((unixdir = tounixpath(dir, NULL)) == NULL)
+ if (((unixdirbuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))) == NULL)
+ || ((unixdir = tounixpath(dir, unixdirbuf)) == NULL))
continue;
sv_setpv(namesv, unixdir);
sv_catpv(namesv, unixname);
@@ -3783,7 +3932,12 @@
memcpy(tmp, dir, dirlen);
tmp +=dirlen;
- *tmp++ = '/';
+
+ /* Avoid '<dir>//<file>' */
+ if (!dirlen || *(tmp-1) != '/') {
+ *tmp++ = '/';
+ }
+
/* name came from an SV, so it will have a '\0' at the
end that we can copy as part of this memcpy(). */
memcpy(tmp, name, len + 1);
@@ -3799,49 +3953,70 @@
if (tryrsfp) {
if (tryname[0] == '.' && tryname[1] == '/') {
++tryname;
- while (*++tryname == '/');
+ while (*++tryname == '/') {}
}
break;
}
- else if (errno == EMFILE)
- /* no point in trying other paths if out of handles */
- break;
+ else if (errno == EMFILE || errno == EACCES) {
+ /* no point in trying other paths if out of handles;
+ * on the other hand, if we couldn't open one of the
+ * files, then going on with the search could lead to
+ * unexpected results; see perl #113422
+ */
+ break;
+ }
}
}
}
}
}
+ saved_errno = errno; /* sv_2mortal can realloc things */
sv_2mortal(namesv);
if (!tryrsfp) {
if (PL_op->op_type == OP_REQUIRE) {
- if(errno == EMFILE) {
+ if(saved_errno == EMFILE || saved_errno == EACCES) {
/* diag_listed_as: Can't locate %s */
- DIE(aTHX_ "Can't locate %s: %s", name, Strerror(errno));
+ DIE(aTHX_ "Can't locate %s: %s", name, Strerror(saved_errno));
} else {
if (namesv) { /* did we lookup @INC? */
AV * const ar = GvAVn(PL_incgv);
I32 i;
+ SV *const msg = newSVpvs_flags("", SVs_TEMP);
SV *const inc = newSVpvs_flags("", SVs_TEMP);
for (i = 0; i <= AvFILL(ar); i++) {
sv_catpvs(inc, " ");
sv_catsv(inc, *av_fetch(ar, i, TRUE));
}
+ if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
+ const char *c, *e = name + len - 3;
+ sv_catpv(msg, " (you may need to install the ");
+ for (c = name; c < e; c++) {
+ if (*c == '/') {
+ sv_catpvn(msg, "::", 2);
+ }
+ else {
+ sv_catpvn(msg, c, 1);
+ }
+ }
+ sv_catpv(msg, " module)");
+ }
+ else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
+ sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
+ }
+ else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
+ sv_catpv(msg, " (did you run h2ph?)");
+ }
/* diag_listed_as: Can't locate %s */
DIE(aTHX_
- "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")",
- name,
- (memEQ(name + len - 2, ".h", 3)
- ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""),
- (memEQ(name + len - 3, ".ph", 4)
- ? " (did you run h2ph?)" : ""),
- inc
- );
+ "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
+ name, msg, inc);
}
}
DIE(aTHX_ "Can't locate %s", name);
}
+ CLEAR_ERRSV();
RETPUSHUNDEF;
}
else
@@ -3866,18 +4041,6 @@
CopFILE_set(&PL_compiling, tryname);
lex_start(NULL, tryrsfp, 0);
- SAVEHINTS();
- PL_hints = 0;
- hv_clear(GvHV(PL_hintgv));
-
- SAVECOMPILEWARNINGS();
- if (PL_dowarn & G_WARN_ALL_ON)
- PL_compiling.cop_warnings = pWARN_ALL ;
- else if (PL_dowarn & G_WARN_ALL_OFF)
- PL_compiling.cop_warnings = pWARN_NONE ;
- else
- PL_compiling.cop_warnings = pWARN_STD ;
-
if (filter_sub || filter_cache) {
/* We can use the SvPV of the filter PVIO itself as our cache, rather
than hanging another SV from it. In turn, filter_add() optionally
@@ -3903,7 +4066,7 @@
encoding = PL_encoding;
PL_encoding = NULL;
- if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
+ if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
op = DOCATCH(PL_eval_start);
else
op = PL_op->op_next;
@@ -3911,6 +4074,8 @@
/* Restore encoding. */
PL_encoding = encoding;
+ LOADED_FILE_PROBE(unixname);
+
return op;
}
@@ -3930,7 +4095,7 @@
PP(pp_entereval)
{
dVAR; dSP;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
SV *sv;
const I32 gimme = GIMME_V;
const U32 was = PL_breakable_sub_gen;
@@ -3939,12 +4104,20 @@
char *tmpbuf = tbuf;
STRLEN len;
CV* runcv;
- U32 seq;
+ U32 seq, lex_flags = 0;
HV *saved_hh = NULL;
+ const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
if (PL_op->op_private & OPpEVAL_HAS_HH) {
saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
}
+ else if (PL_hints & HINT_LOCALIZE_HH || (
+ PL_op->op_private & OPpEVAL_COPHH
+ && PL_curcop->cop_hints & HINT_LOCALIZE_HH
+ )) {
+ saved_hh = cop_hints_2hv(PL_curcop, 0);
+ hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
+ }
sv = POPs;
if (!SvPOK(sv)) {
/* make sure we've got a plain PV (no overload etc) before testing
@@ -3954,13 +4127,29 @@
const char * const p = SvPV_const(sv, len);
sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
+ lex_flags |= LEX_START_COPIED;
+
+ if (bytes && SvUTF8(sv))
+ SvPVbyte_force(sv, len);
}
+ else if (bytes && SvUTF8(sv)) {
+ /* Don't modify someone else's scalar */
+ STRLEN len;
+ sv = newSVsv(sv);
+ (void)sv_2mortal(sv);
+ SvPVbyte_force(sv,len);
+ lex_flags |= LEX_START_COPIED;
+ }
TAINT_IF(SvTAINTED(sv));
TAINT_PROPER("eval");
ENTER_with_name("eval");
- lex_start(sv, NULL, LEX_START_SAME_FILTER);
+ lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
+ ? LEX_IGNORE_UTF8_HINTS
+ : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
+ )
+ );
SAVETMPS;
/* switch to eval mode */
@@ -3979,32 +4168,6 @@
CopFILE_set(&PL_compiling, tmpbuf+2);
SAVECOPLINE(&PL_compiling);
CopLINE_set(&PL_compiling, 1);
- /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
- deleting the eval's FILEGV from the stash before gv_check() runs
- (i.e. before run-time proper). To work around the coredump that
- ensues, we always turn GvMULTI_on for any globals that were
- introduced within evals. See force_ident(). GSAR 96-10-12 */
- SAVEHINTS();
- PL_hints = PL_op->op_targ;
- if (saved_hh) {
- /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
- SvREFCNT_dec(GvHV(PL_hintgv));
- GvHV(PL_hintgv) = saved_hh;
- }
- SAVECOMPILEWARNINGS();
- PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
- cophh_free(CopHINTHASH_get(&PL_compiling));
- if (Perl_fetch_cop_label(aTHX_ PL_curcop, NULL, NULL)) {
- /* The label, if present, is the first entry on the chain. So rather
- than writing a blank label in front of it (which involves an
- allocation), just use the next entry in the chain. */
- PL_compiling.cop_hints_hash
- = cophh_copy(PL_curcop->cop_hints_hash->refcounted_he_next);
- /* Check the assumption that this removed the label. */
- assert(Perl_fetch_cop_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
- }
- else
- PL_compiling.cop_hints_hash = cophh_copy(PL_curcop->cop_hints_hash);
/* special case: an eval '' executed within the DB package gets lexically
* placed in the first non-DB CV rather than the current CV - this
* allows the debugger to execute code, find lexicals etc, in the
@@ -4021,6 +4184,11 @@
if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
else {
+ /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
+ deleting the eval's FILEGV from the stash before gv_check() runs
+ (i.e. before run-time proper). To work around the coredump that
+ ensues, we always turn GvMULTI_on for any globals that were
+ introduced within evals. See force_ident(). GSAR 96-10-12 */
char *const safestr = savepvn(tmpbuf, len);
SAVEDELETE(PL_defstash, safestr, len);
saved_delete = TRUE;
@@ -4028,7 +4196,7 @@
PUTBACK;
- if (doeval(gimme, NULL, runcv, seq)) {
+ if (doeval(gimme, runcv, seq, saved_hh)) {
if (was != PL_breakable_sub_gen /* Some subs defined here. */
? (PERLDB_LINE || PERLDB_SAVESRC)
: PERLDB_SAVESRC_NOSUBS) {
@@ -4055,15 +4223,15 @@
PP(pp_leaveeval)
{
dVAR; dSP;
- register SV **mark;
SV **newsp;
PMOP *newpm;
I32 gimme;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
OP *retop;
const U8 save_flags = PL_op -> op_flags;
I32 optype;
SV *namesv;
+ CV *evalcv;
PERL_ASYNC_CHECK();
POPBLOCK(cx,newpm);
@@ -4070,39 +4238,17 @@
POPEVAL(cx);
namesv = cx->blk_eval.old_namesv;
retop = cx->blk_eval.retop;
+ evalcv = cx->blk_eval.cv;
TAINT_NOT;
- if (gimme == G_VOID)
- MARK = newsp;
- else if (gimme == G_SCALAR) {
- MARK = newsp + 1;
- if (MARK <= SP) {
- if (SvFLAGS(TOPs) & SVs_TEMP)
- *MARK = TOPs;
- else
- *MARK = sv_mortalcopy(TOPs);
- }
- else {
- MEXTEND(mark,0);
- *MARK = &PL_sv_undef;
- }
- SP = MARK;
- }
- else {
- /* in case LEAVE wipes old return values */
- for (mark = newsp + 1; mark <= SP; mark++) {
- if (!(SvFLAGS(*mark) & SVs_TEMP)) {
- *mark = sv_mortalcopy(*mark);
- TAINT_NOT; /* Each item is independent */
- }
- }
- }
+ SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp,
+ gimme, SVs_TEMP);
PL_curpm = newpm; /* Don't pop $1 et al till now */
#ifdef DEBUGGING
- assert(CvDEPTH(PL_compcv) == 1);
+ assert(CvDEPTH(evalcv) == 1);
#endif
- CvDEPTH(PL_compcv) = 0;
+ CvDEPTH(evalcv) = 0;
if (optype == OP_REQUIRE &&
!(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
@@ -4109,7 +4255,8 @@
{
/* Unassume the success we assumed earlier. */
(void)hv_delete(GvHVn(PL_incgv),
- SvPVX_const(namesv), SvCUR(namesv),
+ SvPVX_const(namesv),
+ SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
G_DISCARD);
retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
SVfARG(namesv));
@@ -4133,7 +4280,7 @@
SV **newsp;
PMOP *newpm;
I32 gimme;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
I32 optype;
POPBLOCK(cx,newpm);
@@ -4184,7 +4331,7 @@
SV **newsp;
PMOP *newpm;
I32 gimme;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
I32 optype;
PERL_ASYNC_CHECK();
@@ -4193,33 +4340,7 @@
PERL_UNUSED_VAR(optype);
TAINT_NOT;
- if (gimme == G_VOID)
- SP = newsp;
- else if (gimme == G_SCALAR) {
- register SV **mark;
- MARK = newsp + 1;
- if (MARK <= SP) {
- if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
- *MARK = TOPs;
- else
- *MARK = sv_mortalcopy(TOPs);
- }
- else {
- MEXTEND(mark,0);
- *MARK = &PL_sv_undef;
- }
- SP = MARK;
- }
- else {
- /* in case LEAVE wipes old return values */
- register SV **mark;
- for (mark = newsp + 1; mark <= SP; mark++) {
- if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
- *mark = sv_mortalcopy(*mark);
- TAINT_NOT; /* Each item is independent */
- }
- }
- }
+ SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
PL_curpm = newpm; /* Don't pop $1 et al till now */
LEAVE_with_name("eval_scope");
@@ -4230,13 +4351,21 @@
PP(pp_entergiven)
{
dVAR; dSP;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
ENTER_with_name("given");
SAVETMPS;
- sv_setsv(PAD_SV(PL_op->op_targ), POPs);
+ if (PL_op->op_targ) {
+ SAVEPADSVANDMORTALIZE(PL_op->op_targ);
+ SvREFCNT_dec(PAD_SVl(PL_op->op_targ));
+ PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs);
+ }
+ else {
+ SAVE_DEFSV;
+ DEFSV_set(POPs);
+ }
PUSHBLOCK(cx, CXt_GIVEN, SP);
PUSHGIVEN(cx);
@@ -4247,7 +4376,7 @@
PP(pp_leavegiven)
{
dVAR; dSP;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
PMOP *newpm;
@@ -4257,33 +4386,7 @@
assert(CxTYPE(cx) == CXt_GIVEN);
TAINT_NOT;
- if (gimme == G_VOID)
- SP = newsp;
- else if (gimme == G_SCALAR) {
- register SV **mark;
- MARK = newsp + 1;
- if (MARK <= SP) {
- if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
- *MARK = TOPs;
- else
- *MARK = sv_mortalcopy(TOPs);
- }
- else {
- MEXTEND(mark,0);
- *MARK = &PL_sv_undef;
- }
- SP = MARK;
- }
- else {
- /* in case LEAVE wipes old return values */
- register SV **mark;
- for (mark = newsp + 1; mark <= SP; mark++) {
- if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
- *mark = sv_mortalcopy(*mark);
- TAINT_NOT; /* Each item is independent */
- }
- }
- }
+ SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
PL_curpm = newpm; /* Don't pop $1 et al till now */
LEAVE_with_name("given");
@@ -4339,7 +4442,7 @@
PP(pp_smartmatch)
{
DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
- return do_smartmatch(NULL, NULL);
+ return do_smartmatch(NULL, NULL, 0);
}
/* This version of do_smartmatch() implements the
@@ -4346,7 +4449,7 @@
* table of smart matches that is found in perlsyn.
*/
STATIC OP *
-S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
+S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
{
dVAR;
dSP;
@@ -4358,7 +4461,7 @@
/* Take care only to invoke mg_get() once for each argument.
* Currently we do this by copying the SV if it's magical. */
if (d) {
- if (SvGMAGICAL(d))
+ if (!copied && SvGMAGICAL(d))
d = sv_mortalcopy(d);
}
else
@@ -4374,7 +4477,7 @@
DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
- tmpsv = amagic_call(d, e, smart_amg, 0);
+ tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
if (tmpsv) {
SPAGAIN;
(void)POPs;
@@ -4669,7 +4772,7 @@
PUTBACK;
DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
- (void) do_smartmatch(seen_this, seen_other);
+ (void) do_smartmatch(seen_this, seen_other, 0);
SPAGAIN;
DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
@@ -4731,7 +4834,7 @@
PUTBACK;
/* infinite recursion isn't supposed to happen here */
DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
- (void) do_smartmatch(NULL, NULL);
+ (void) do_smartmatch(NULL, NULL, 1);
SPAGAIN;
DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
if (SvTRUEx(POPs))
@@ -4821,7 +4924,7 @@
PP(pp_enterwhen)
{
dVAR; dSP;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
/* This is essentially an optimization: if the match
@@ -4833,7 +4936,7 @@
if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
RETURNOP(cLOGOP->op_other->op_next);
- ENTER_with_name("eval");
+ ENTER_with_name("when");
SAVETMPS;
PUSHBLOCK(cx, CXt_WHEN, SP);
@@ -4845,43 +4948,76 @@
PP(pp_leavewhen)
{
dVAR; dSP;
- register PERL_CONTEXT *cx;
+ I32 cxix;
+ PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
PMOP *newpm;
+ cxix = dopoptogiven(cxstack_ix);
+ if (cxix < 0)
+ /* diag_listed_as: Can't "when" outside a topicalizer */
+ DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
+ PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
+
POPBLOCK(cx,newpm);
assert(CxTYPE(cx) == CXt_WHEN);
- SP = newsp;
- PUTBACK;
-
+ TAINT_NOT;
+ SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
PL_curpm = newpm; /* pop $1 et al */
- LEAVE_with_name("eval");
- return NORMAL;
+ LEAVE_with_name("when");
+
+ if (cxix < cxstack_ix)
+ dounwind(cxix);
+
+ cx = &cxstack[cxix];
+
+ if (CxFOREACH(cx)) {
+ /* clear off anything above the scope we're re-entering */
+ I32 inner = PL_scopestack_ix;
+
+ TOPBLOCK(cx);
+ if (PL_scopestack_ix < inner)
+ leave_scope(PL_scopestack[PL_scopestack_ix]);
+ PL_curcop = cx->blk_oldcop;
+
+ PERL_ASYNC_CHECK();
+ return cx->blk_loop.my_op->op_nextop;
+ }
+ else {
+ PERL_ASYNC_CHECK();
+ RETURNOP(cx->blk_givwhen.leave_op);
+ }
}
PP(pp_continue)
{
- dVAR;
+ dVAR; dSP;
I32 cxix;
- register PERL_CONTEXT *cx;
- I32 inner;
+ PERL_CONTEXT *cx;
+ I32 gimme;
+ SV **newsp;
+ PMOP *newpm;
+
+ PERL_UNUSED_VAR(gimme);
cxix = dopoptowhen(cxstack_ix);
if (cxix < 0)
DIE(aTHX_ "Can't \"continue\" outside a when block");
+
if (cxix < cxstack_ix)
dounwind(cxix);
- /* clear off anything above the scope we're re-entering */
- inner = PL_scopestack_ix;
- TOPBLOCK(cx);
- if (PL_scopestack_ix < inner)
- leave_scope(PL_scopestack[PL_scopestack_ix]);
- PL_curcop = cx->blk_oldcop;
- return cx->blk_givwhen.leave_op;
+ POPBLOCK(cx,newpm);
+ assert(CxTYPE(cx) == CXt_WHEN);
+
+ SP = newsp;
+ PL_curpm = newpm; /* pop $1 et al */
+
+ LEAVE_with_name("when");
+ RETURNOP(cx->blk_givwhen.leave_op->op_next);
}
PP(pp_break)
@@ -4888,35 +5024,23 @@
{
dVAR;
I32 cxix;
- register PERL_CONTEXT *cx;
- I32 inner;
- dSP;
+ PERL_CONTEXT *cx;
cxix = dopoptogiven(cxstack_ix);
- if (cxix < 0) {
- if (PL_op->op_flags & OPf_SPECIAL)
- DIE(aTHX_ "Can't use when() outside a topicalizer");
- else
- DIE(aTHX_ "Can't \"break\" outside a given block");
- }
- if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
+ if (cxix < 0)
+ DIE(aTHX_ "Can't \"break\" outside a given block");
+
+ cx = &cxstack[cxix];
+ if (CxFOREACH(cx))
DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
if (cxix < cxstack_ix)
dounwind(cxix);
-
- /* clear off anything above the scope we're re-entering */
- inner = PL_scopestack_ix;
+
+ /* Restore the sp at the time we entered the given block */
TOPBLOCK(cx);
- if (PL_scopestack_ix < inner)
- leave_scope(PL_scopestack[PL_scopestack_ix]);
- PL_curcop = cx->blk_oldcop;
- if (CxFOREACH(cx))
- return (cx)->blk_loop.my_op->op_nextop;
- else
- /* RETURNOP calls PUTBACK which restores the old old sp */
- RETURNOP(cx->blk_givwhen.leave_op);
+ return cx->blk_givwhen.leave_op;
}
static MAGIC *
@@ -4923,21 +5047,22 @@
S_doparseform(pTHX_ SV *sv)
{
STRLEN len;
- register char *s = SvPV_force(sv, len);
- register char * const send = s + len;
- register char *base = NULL;
- register I32 skipspaces = 0;
- bool noblank = FALSE;
- bool repeat = FALSE;
- bool postspace = FALSE;
+ char *s = SvPV(sv, len);
+ char *send;
+ char *base = NULL; /* start of current field */
+ I32 skipspaces = 0; /* number of contiguous spaces seen */
+ bool noblank = FALSE; /* ~ or ~~ seen on this line */
+ bool repeat = FALSE; /* ~~ seen on this line */
+ bool postspace = FALSE; /* a text field may need right padding */
U32 *fops;
- register U32 *fpc;
- U32 *linepc = NULL;
- register I32 arg;
- bool ischop;
- bool unchopnum = FALSE;
+ U32 *fpc;
+ U32 *linepc = NULL; /* position of last FF_LINEMARK */
+ I32 arg;
+ bool ischop; /* it's a ^ rather than a @ */
+ bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
- MAGIC *mg;
+ MAGIC *mg = NULL;
+ SV *sv_copy;
PERL_ARGS_ASSERT_DOPARSEFORM;
@@ -4944,6 +5069,40 @@
if (len == 0)
Perl_croak(aTHX_ "Null picture in formline");
+ if (SvTYPE(sv) >= SVt_PVMG) {
+ /* This might, of course, still return NULL. */
+ mg = mg_find(sv, PERL_MAGIC_fm);
+ } else {
+ sv_upgrade(sv, SVt_PVMG);
+ }
+
+ if (mg) {
+ /* still the same as previously-compiled string? */
+ SV *old = mg->mg_obj;
+ if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
+ && len == SvCUR(old)
+ && strnEQ(SvPVX(old), SvPVX(sv), len)
+ ) {
+ DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
+ return mg;
+ }
+
+ DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
+ Safefree(mg->mg_ptr);
+ mg->mg_ptr = NULL;
+ SvREFCNT_dec(old);
+ mg->mg_obj = NULL;
+ }
+ else {
+ DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
+ mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
+ }
+
+ sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
+ s = SvPV(sv_copy, len); /* work on the copy, not the original */
+ send = s + len;
+
+
/* estimate the buffer size needed */
for (base = s; s <= send; s++) {
if (*s == '\n' || *s == '@' || *s == '^')
@@ -4971,10 +5130,10 @@
case '~':
if (*s == '~') {
repeat = TRUE;
- *s = ' ';
+ skipspaces++;
+ s++;
}
noblank = TRUE;
- s[-1] = ' ';
/* FALL THROUGH */
case ' ': case '\t':
skipspaces++;
@@ -4992,7 +5151,7 @@
if (postspace)
*fpc++ = FF_SPACE;
*fpc++ = FF_LITERAL;
- *fpc++ = (U16)arg;
+ *fpc++ = (U32)arg;
}
postspace = FALSE;
if (s <= send)
@@ -4999,7 +5158,7 @@
skipspaces--;
if (skipspaces) {
*fpc++ = FF_SKIP;
- *fpc++ = (U16)skipspaces;
+ *fpc++ = (U32)skipspaces;
}
skipspaces = 0;
if (s <= send)
@@ -5010,7 +5169,7 @@
arg = fpc - linepc + 1;
else
arg = 0;
- *fpc++ = (U16)arg;
+ *fpc++ = (U32)arg;
}
if (s < send) {
linepc = fpc;
@@ -5033,12 +5192,12 @@
arg = (s - base) - 1;
if (arg) {
*fpc++ = FF_LITERAL;
- *fpc++ = (U16)arg;
+ *fpc++ = (U32)arg;
}
base = s - 1;
*fpc++ = FF_FETCH;
- if (*s == '*') {
+ if (*s == '*') { /* @* or ^* */
s++;
*fpc++ = 2; /* skip the @* or ^* */
if (ischop) {
@@ -5047,8 +5206,8 @@
} else
*fpc++ = FF_LINEGLOB;
}
- else if (*s == '#' || (*s == '.' && s[1] == '#')) {
- arg = ischop ? 512 : 0;
+ else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
+ arg = ischop ? FORM_NUM_BLANK : 0;
base = s - 1;
while (*s == '#')
s++;
@@ -5056,15 +5215,15 @@
const char * const f = ++s;
while (*s == '#')
s++;
- arg |= 256 + (s - f);
+ arg |= FORM_NUM_POINT + (s - f);
}
*fpc++ = s - base; /* fieldsize for FETCH */
*fpc++ = FF_DECIMAL;
- *fpc++ = (U16)arg;
+ *fpc++ = (U32)arg;
unchopnum |= ! ischop;
}
else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
- arg = ischop ? 512 : 0;
+ arg = ischop ? FORM_NUM_BLANK : 0;
base = s - 1;
s++; /* skip the '0' first */
while (*s == '#')
@@ -5073,14 +5232,14 @@
const char * const f = ++s;
while (*s == '#')
s++;
- arg |= 256 + (s - f);
+ arg |= FORM_NUM_POINT + (s - f);
}
*fpc++ = s - base; /* fieldsize for FETCH */
*fpc++ = FF_0DECIMAL;
- *fpc++ = (U16)arg;
+ *fpc++ = (U32)arg;
unchopnum |= ! ischop;
}
- else {
+ else { /* text field */
I32 prespace = 0;
bool ismore = FALSE;
@@ -5107,7 +5266,7 @@
*fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
if (prespace)
- *fpc++ = (U16)prespace;
+ *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
*fpc++ = FF_ITEM;
if (ismore)
*fpc++ = FF_MORE;
@@ -5124,16 +5283,10 @@
assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
arg = fpc - fops;
- /* If we pass the length in to sv_magicext() it will copy the buffer for us.
- We don't need that, so by setting the length on return we "donate" the
- buffer to the magic, avoiding an allocation. We could realloc() the
- buffer to the exact size used, but that feels like it's not worth it
- (particularly if the rumours are true and some realloc() implementations
- don't shrink blocks). However, set the true length used in mg_len so that
- mg_dup only allocates and copies what's actually needed. */
- mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm,
- (const char *const) fops, 0);
+ mg->mg_ptr = (char *) fops;
mg->mg_len = arg * sizeof(U32);
+ mg->mg_obj = sv_copy;
+ mg->mg_flags |= MGf_REFCOUNTED;
if (unchopnum && repeat)
Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
@@ -5151,9 +5304,9 @@
bool res = FALSE;
int intsize = fldsize - (value < 0 ? 1 : 0);
- if (frcsize & 256)
+ if (frcsize & FORM_NUM_POINT)
intsize--;
- frcsize &= 255;
+ frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
intsize -= frcsize;
while (intsize--) pwr *= 10.0;
@@ -5184,6 +5337,7 @@
char *prune_from = NULL;
bool read_from_cache = FALSE;
STRLEN umaxlen;
+ SV *err = NULL;
PERL_ARGS_ASSERT_RUN_USER_FILTER;
@@ -5240,7 +5394,6 @@
I'm going to use a mortal in case the upstream filter croaks. */
upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
? sv_newmortal() : buf_sv;
- SvTEMP_off(upstream);
SvUPGRADE(upstream, SVt_PV);
if (filter_has_file) {
@@ -5252,14 +5405,11 @@
int count;
ENTER_with_name("call_filter_sub");
- save_gp(PL_defgv, 0);
- GvINTRO_off(PL_defgv);
- SAVEGENERICSV(GvSV(PL_defgv));
+ SAVE_DEFSV;
SAVETMPS;
EXTEND(SP, 2);
DEFSV_set(upstream);
- SvREFCNT_inc_simple_void_NN(upstream);
PUSHMARK(SP);
mPUSHi(0);
if (filter_state) {
@@ -5266,7 +5416,7 @@
PUSHs(filter_state);
}
PUTBACK;
- count = call_sv(filter_sub, G_SCALAR);
+ count = call_sv(filter_sub, G_SCALAR|G_EVAL);
SPAGAIN;
if (count > 0) {
@@ -5274,6 +5424,11 @@
if (SvOK(out)) {
status = SvIV(out);
}
+ else {
+ SV * const errsv = ERRSV;
+ if (SvTRUE_NN(errsv))
+ err = newSVsv(errsv);
+ }
}
PUTBACK;
@@ -5281,7 +5436,8 @@
LEAVE_with_name("call_filter_sub");
}
- if(SvOK(upstream)) {
+ if (SvIsCOW(upstream)) sv_force_normal(upstream);
+ if(!err && SvOK(upstream)) {
got_p = SvPV(upstream, got_len);
if (umaxlen) {
if (got_len > umaxlen) {
@@ -5295,7 +5451,7 @@
}
}
}
- if (prune_from) {
+ if (!err && prune_from) {
/* Oh. Too long. Stuff some in our cache. */
STRLEN cached_len = got_p + got_len - prune_from;
SV *const cache = datasv;
@@ -5324,7 +5480,8 @@
have touched the SV upstream, so it may be undefined. If we naively
concatenate it then we get a warning about use of uninitialised value.
*/
- if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
+ if (!err && upstream != buf_sv &&
+ (SvOK(upstream) || SvGMAGICAL(upstream))) {
sv_catsv(buf_sv, upstream);
}
@@ -5340,6 +5497,10 @@
}
filter_del(S_run_user_filter);
}
+
+ if (err)
+ croak_sv(err);
+
if (status == 0 && read_from_cache) {
/* If we read some data from the cache (and by getting here it implies
that we emptied the cache) then we aren't yet at EOF, and mustn't
@@ -5379,8 +5540,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/pp_ctl.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.4
\ No newline at end of property
Modified: trunk/contrib/perl/pp_hot.c
===================================================================
--- trunk/contrib/perl/pp_hot.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/pp_hot.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -74,6 +74,7 @@
return NORMAL;
}
+/* This is sometimes called directly by pp_coreargs and pp_grepstart. */
PP(pp_pushmark)
{
dVAR;
@@ -84,9 +85,12 @@
PP(pp_stringify)
{
dVAR; dSP; dTARGET;
- sv_copypv(TARG,TOPs);
- SETTARG;
- RETURN;
+ SV * const sv = TOPs;
+ SETs(TARG);
+ sv_copypv(TARG, sv);
+ SvSETMAGIC(TARG);
+ /* no PUTBACK, SETs doesn't inc/dec SP */
+ return NORMAL;
}
PP(pp_gv)
@@ -98,31 +102,43 @@
PP(pp_and)
{
- dVAR; dSP;
+ dVAR;
PERL_ASYNC_CHECK();
- if (!SvTRUE(TOPs))
- RETURN;
- else {
- if (PL_op->op_type == OP_AND)
- --SP;
- RETURNOP(cLOGOP->op_other);
+ {
+ /* SP is not used to remove a variable that is saved across the
+ sv_2bool_flags call in SvTRUE_NN, if a RISC/CISC or low/high machine
+ register or load/store vs direct mem ops macro is introduced, this
+ should be a define block between direct PL_stack_sp and dSP operations,
+ presently, using PL_stack_sp is bias towards CISC cpus */
+ SV * const sv = *PL_stack_sp;
+ if (!SvTRUE_NN(sv))
+ return NORMAL;
+ else {
+ if (PL_op->op_type == OP_AND)
+ --PL_stack_sp;
+ return cLOGOP->op_other;
+ }
}
}
PP(pp_sassign)
{
- dVAR; dSP; dPOPTOPssrl;
+ dVAR; dSP;
+ /* sassign keeps its args in the optree traditionally backwards.
+ So we pop them differently.
+ */
+ SV *left = POPs; SV *right = TOPs;
if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
SV * const temp = left;
left = right; right = temp;
}
- if (PL_tainting && PL_tainted && !SvTAINTED(left))
+ if (TAINTING_get && TAINT_get && !SvTAINTED(right))
TAINT_NOT;
if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
- SV * const cv = SvRV(left);
+ SV * const cv = SvRV(right);
const U32 cv_type = SvTYPE(cv);
- const bool is_gv = isGV_with_GP(right);
+ const bool is_gv = isGV_with_GP(left);
const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
if (!got_coderef) {
@@ -129,12 +145,12 @@
assert(SvROK(cv));
}
- /* Can do the optimisation if right (LVALUE) is not a typeglob,
- left (RVALUE) is a reference to something, and we're in void
+ /* Can do the optimisation if left (LVALUE) is not a typeglob,
+ right (RVALUE) is a reference to something, and we're in void
context. */
if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
/* Is the target symbol table currently empty? */
- GV * const gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV);
+ GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
/* Good. Create a new proxy constant subroutine in the target.
The gv becomes a(nother) reference to the constant. */
@@ -144,7 +160,7 @@
SvPCS_IMPORTED_on(gv);
SvRV_set(gv, value);
SvREFCNT_inc_simple_void(value);
- SETs(right);
+ SETs(left);
RETURN;
}
}
@@ -152,7 +168,7 @@
/* Need to fix things up. */
if (!is_gv) {
/* Need to fix GV. */
- right = MUTABLE_SV(gv_fetchsv(right, GV_ADD, SVt_PVGV));
+ left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
}
if (!got_coderef) {
@@ -166,9 +182,9 @@
all sorts of fun as the reference to our new sub is
donated to the GV that we're about to assign to.
*/
- SvRV_set(left, MUTABLE_SV(newCONSTSUB(GvSTASH(right), NULL,
+ SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
SvRV(cv))));
- SvREFCNT_dec(cv);
+ SvREFCNT_dec_NN(cv);
LEAVE_with_name("sassign_coderef");
} else {
/* What can happen for the corner case *{"BONK"} = \&{"BONK"};
@@ -191,14 +207,21 @@
assert(CvFLAGS(source) & CVf_CONST);
SvREFCNT_inc_void(source);
- SvREFCNT_dec(upgraded);
- SvRV_set(left, MUTABLE_SV(source));
+ SvREFCNT_dec_NN(upgraded);
+ SvRV_set(right, MUTABLE_SV(source));
}
}
}
- SvSetMagicSV(right, left);
- SETs(right);
+ if (
+ SvTEMP(left) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
+ (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
+ )
+ Perl_warner(aTHX_
+ packWARN(WARN_MISC), "Useless assignment to a temporary"
+ );
+ SvSetMagicSV(left, right);
+ SETs(left);
RETURN;
}
@@ -261,8 +284,8 @@
report_uninit(right);
sv_setpvs(left, "");
}
- lbyte = (SvROK(left) && SvTYPE(SvRV(left)) == SVt_REGEXP)
- ? !DO_UTF8(SvRV(left)) : !DO_UTF8(left);
+ SvPV_force_nomg_nolen(left);
+ lbyte = !DO_UTF8(left);
if (IN_BYTES)
SvUTF8_off(TARG);
}
@@ -294,29 +317,118 @@
}
}
+/* push the elements of av onto the stack.
+ * XXX Note that padav has similar code but without the mg_get().
+ * I suspect that the mg_get is no longer needed, but while padav
+ * differs, it can't share this function */
+
+STATIC void
+S_pushav(pTHX_ AV* const av)
+{
+ dSP;
+ const I32 maxarg = AvFILL(av) + 1;
+ EXTEND(SP, maxarg);
+ if (SvRMAGICAL(av)) {
+ U32 i;
+ for (i=0; i < (U32)maxarg; i++) {
+ SV ** const svp = av_fetch(av, i, FALSE);
+ /* See note in pp_helem, and bug id #27839 */
+ SP[i+1] = svp
+ ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
+ : &PL_sv_undef;
+ }
+ }
+ else {
+ Copy(AvARRAY(av), SP+1, maxarg, SV*);
+ }
+ SP += maxarg;
+ PUTBACK;
+}
+
+
+/* ($lex1, at lex2,...) or my ($lex1, at lex2,...) */
+
+PP(pp_padrange)
+{
+ dVAR; dSP;
+ PADOFFSET base = PL_op->op_targ;
+ int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
+ int i;
+ if (PL_op->op_flags & OPf_SPECIAL) {
+ /* fake the RHS of my ($x,$y,..) = @_ */
+ PUSHMARK(SP);
+ S_pushav(aTHX_ GvAVn(PL_defgv));
+ SPAGAIN;
+ }
+
+ /* note, this is only skipped for compile-time-known void cxt */
+ if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
+ EXTEND(SP, count);
+ PUSHMARK(SP);
+ for (i = 0; i <count; i++)
+ *++SP = PAD_SV(base+i);
+ }
+ if (PL_op->op_private & OPpLVAL_INTRO) {
+ SV **svp = &(PAD_SVl(base));
+ const UV payload = (UV)(
+ (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
+ | (count << SAVE_TIGHT_SHIFT)
+ | SAVEt_CLEARPADRANGE);
+ assert(OPpPADRANGE_COUNTMASK + 1 == (1 <<OPpPADRANGE_COUNTSHIFT));
+ assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) == base);
+ {
+ dSS_ADD;
+ SS_ADD_UV(payload);
+ SS_ADD_END(1);
+ }
+
+ for (i = 0; i <count; i++)
+ SvPADSTALE_off(*svp++); /* mark lexical as active */
+ }
+ RETURN;
+}
+
+
PP(pp_padsv)
{
- dVAR; dSP; dTARGET;
- XPUSHs(TARG);
- if (PL_op->op_flags & OPf_MOD) {
- if (PL_op->op_private & OPpLVAL_INTRO)
- if (!(PL_op->op_private & OPpPAD_STATE))
- SAVECLEARSV(PAD_SVl(PL_op->op_targ));
- if (PL_op->op_private & OPpDEREF) {
- PUTBACK;
- vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
- SPAGAIN;
+ dVAR; dSP;
+ EXTEND(SP, 1);
+ {
+ OP * const op = PL_op;
+ /* access PL_curpad once */
+ SV ** const padentry = &(PAD_SVl(op->op_targ));
+ {
+ dTARG;
+ TARG = *padentry;
+ PUSHs(TARG);
+ PUTBACK; /* no pop/push after this, TOPs ok */
}
+ if (op->op_flags & OPf_MOD) {
+ if (op->op_private & OPpLVAL_INTRO)
+ if (!(op->op_private & OPpPAD_STATE))
+ save_clearsv(padentry);
+ if (op->op_private & OPpDEREF) {
+ /* TOPs is equivalent to TARG here. Using TOPs (SP) rather
+ than TARG reduces the scope of TARG, so it does not
+ span the call to save_clearsv, resulting in smaller
+ machine code. */
+ TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
+ }
+ }
+ return op->op_next;
}
- RETURN;
}
PP(pp_readline)
{
dVAR;
- dSP; SvGETMAGIC(TOPs);
- tryAMAGICunTARGET(iter_amg, 0, 0);
- PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
+ dSP;
+ if (TOPs) {
+ SvGETMAGIC(TOPs);
+ tryAMAGICunTARGETlist(iter_amg, 0);
+ PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
+ }
+ else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
if (!isGV_with_GP(PL_last_in_gv)) {
if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
@@ -334,90 +446,35 @@
PP(pp_eq)
{
dVAR; dSP;
+ SV *left, *right;
+
tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
-#ifndef NV_PRESERVES_UV
- if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
- SP--;
- SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
- RETURN;
- }
-#endif
-#ifdef PERL_PRESERVE_IVUV
- SvIV_please_nomg(TOPs);
- if (SvIOK(TOPs)) {
- /* Unless the left argument is integer in range we are going
- to have to use NV maths. Hence only attempt to coerce the
- right argument if we know the left is integer. */
- SvIV_please_nomg(TOPm1s);
- if (SvIOK(TOPm1s)) {
- const bool auvok = SvUOK(TOPm1s);
- const bool buvok = SvUOK(TOPs);
-
- if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
- /* Casting IV to UV before comparison isn't going to matter
- on 2s complement. On 1s complement or sign&magnitude
- (if we have any of them) it could to make negative zero
- differ from normal zero. As I understand it. (Need to
- check - is negative zero implementation defined behaviour
- anyway?). NWC */
- const UV buv = SvUVX(POPs);
- const UV auv = SvUVX(TOPs);
-
- SETs(boolSV(auv == buv));
- RETURN;
- }
- { /* ## Mixed IV,UV ## */
- SV *ivp, *uvp;
- IV iv;
-
- /* == is commutative so doesn't matter which is left or right */
- if (auvok) {
- /* top of stack (b) is the iv */
- ivp = *SP;
- uvp = *--SP;
- } else {
- uvp = *SP;
- ivp = *--SP;
- }
- iv = SvIVX(ivp);
- if (iv < 0)
- /* As uv is a UV, it's >0, so it cannot be == */
- SETs(&PL_sv_no);
- else
- /* we know iv is >= 0 */
- SETs(boolSV((UV)iv == SvUVX(uvp)));
- RETURN;
- }
- }
- }
-#endif
- {
-#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
- dPOPTOPnnrl_nomg;
- if (Perl_isnan(left) || Perl_isnan(right))
- RETSETNO;
- SETs(boolSV(left == right));
-#else
- dPOPnv_nomg;
- SETs(boolSV(SvNV_nomg(TOPs) == value));
-#endif
- RETURN;
- }
+ right = POPs;
+ left = TOPs;
+ SETs(boolSV(
+ (SvIOK_notUV(left) && SvIOK_notUV(right))
+ ? (SvIVX(left) == SvIVX(right))
+ : ( do_ncmp(left, right) == 0)
+ ));
+ RETURN;
}
PP(pp_preinc)
{
dVAR; dSP;
- if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
- Perl_croak_no_modify(aTHX);
- if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
- && SvIVX(TOPs) != IV_MAX)
+ const bool inc =
+ PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC;
+ if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
+ Perl_croak_no_modify();
+ if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
+ && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
{
- SvIV_set(TOPs, SvIVX(TOPs) + 1);
+ SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
}
else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
- sv_inc(TOPs);
+ if (inc) sv_inc(TOPs);
+ else sv_dec(TOPs);
SvSETMAGIC(TOPs);
return NORMAL;
}
@@ -438,7 +495,7 @@
PP(pp_defined)
{
dVAR; dSP;
- register SV* sv;
+ SV* sv;
bool defined;
const int op_type = PL_op->op_type;
const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
@@ -548,13 +605,11 @@
unsigned code below is actually shorter than the old code. :-)
*/
- SvIV_please_nomg(svr);
-
- if (SvIOK(svr)) {
+ if (SvIV_please_nomg(svr)) {
/* Unless the left argument is integer in range we are going to have to
use NV maths. Hence only attempt to coerce the right argument if
we know the left is integer. */
- register UV auv = 0;
+ UV auv = 0;
bool auvok = FALSE;
bool a_valid = 0;
@@ -566,12 +621,11 @@
lots of code to speed up what is probably a rarish case. */
} else {
/* Left operand is defined, so is it IV? */
- SvIV_please_nomg(svl);
- if (SvIOK(svl)) {
+ if (SvIV_please_nomg(svl)) {
if ((auvok = SvUOK(svl)))
auv = SvUVX(svl);
else {
- register const IV aiv = SvIVX(svl);
+ const IV aiv = SvIVX(svl);
if (aiv >= 0) {
auv = aiv;
auvok = 1; /* Now acting as a sign flag. */
@@ -585,13 +639,13 @@
if (a_valid) {
bool result_good = 0;
UV result;
- register UV buv;
+ UV buv;
bool buvok = SvUOK(svr);
if (buvok)
buv = SvUVX(svr);
else {
- register const IV biv = SvIVX(svr);
+ const IV biv = SvIVX(svr);
if (biv >= 0) {
buv = biv;
buvok = 1;
@@ -664,7 +718,7 @@
PP(pp_aelemfast)
{
dVAR; dSP;
- AV * const av = PL_op->op_flags & OPf_SPECIAL
+ AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
const U32 lval = PL_op->op_flags & OPf_MOD;
SV** const svp = av_fetch(av, PL_op->op_private, lval);
@@ -710,7 +764,7 @@
PP(pp_print)
{
dVAR; dSP; dMARK; dORIGMARK;
- register PerlIO *fp;
+ PerlIO *fp;
MAGIC *mg;
GV * const gv
= (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
@@ -810,44 +864,20 @@
const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
- if (!(PL_op->op_private & OPpDEREFed))
- SvGETMAGIC(sv);
+ SvGETMAGIC(sv);
if (SvROK(sv)) {
if (SvAMAGIC(sv)) {
sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
- SPAGAIN;
}
sv = SvRV(sv);
if (SvTYPE(sv) != type)
+ /* diag_listed_as: Not an ARRAY reference */
DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
- if (PL_op->op_flags & OPf_REF) {
- SETs(sv);
- RETURN;
- }
- else if (LVRET) {
- if (gimme != G_ARRAY)
- goto croak_cant_return;
- SETs(sv);
- RETURN;
- }
else if (PL_op->op_flags & OPf_MOD
&& PL_op->op_private & OPpLVAL_INTRO)
Perl_croak(aTHX_ "%s", PL_no_localize_ref);
}
- else {
- if (SvTYPE(sv) == type) {
- if (PL_op->op_flags & OPf_REF) {
- SETs(sv);
- RETURN;
- }
- else if (LVRET) {
- if (gimme != G_ARRAY)
- goto croak_cant_return;
- SETs(sv);
- RETURN;
- }
- }
- else {
+ else if (SvTYPE(sv) != type) {
GV *gv;
if (!isGV_with_GP(sv)) {
@@ -862,17 +892,19 @@
sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
if (PL_op->op_private & OPpLVAL_INTRO)
sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
- if (PL_op->op_flags & OPf_REF) {
+ }
+ if (PL_op->op_flags & OPf_REF) {
SETs(sv);
RETURN;
- }
- else if (LVRET) {
+ }
+ else if (PL_op->op_private & OPpMAYBE_LVSUB) {
+ const I32 flags = is_lvalue_sub();
+ if (flags && !(flags & OPpENTERSUB_INARGS)) {
if (gimme != G_ARRAY)
goto croak_cant_return;
SETs(sv);
RETURN;
- }
- }
+ }
}
if (is_pp_rv2av) {
@@ -881,23 +913,10 @@
(until such time as we get tools that can do blame annotation across
whitespace changes. */
if (gimme == G_ARRAY) {
- const I32 maxarg = AvFILL(av) + 1;
- (void)POPs; /* XXXX May be optimized away? */
- EXTEND(SP, maxarg);
- if (SvRMAGICAL(av)) {
- U32 i;
- for (i=0; i < (U32)maxarg; i++) {
- SV ** const svp = av_fetch(av, i, FALSE);
- /* See note in pp_helem, and bug id #27839 */
- SP[i+1] = svp
- ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
- : &PL_sv_undef;
- }
- }
- else {
- Copy(AvARRAY(av), SP+1, maxarg, SV*);
- }
- SP += maxarg;
+ SP--;
+ PUTBACK;
+ S_pushav(aTHX_ av);
+ SPAGAIN;
}
else if (gimme == G_SCALAR) {
dTARGET;
@@ -910,6 +929,11 @@
*PL_stack_sp = sv;
return Perl_do_kv(aTHX);
}
+ else if ((PL_op->op_private & OPpTRUEBOOL
+ || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
+ && block_gimme() == G_VOID ))
+ && (!SvRMAGICAL(sv) || !mg_find(sv, PERL_MAGIC_tied)))
+ SETs(HvUSEDKEYS(sv) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
else if (gimme == G_SCALAR) {
dTARGET;
TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
@@ -926,22 +950,19 @@
}
STATIC void
-S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
+S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
{
dVAR;
PERL_ARGS_ASSERT_DO_ODDBALL;
- if (*relem) {
- SV *tmpstr;
- const HE *didstore;
-
+ if (*oddkey) {
if (ckWARN(WARN_MISC)) {
const char *err;
- if (relem == firstrelem &&
- SvROK(*relem) &&
- (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
- SvTYPE(SvRV(*relem)) == SVt_PVHV))
+ if (oddkey == firstkey &&
+ SvROK(*oddkey) &&
+ (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
+ SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
{
err = "Reference found where even-sized list expected";
}
@@ -950,15 +971,6 @@
Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
}
- tmpstr = newSV(0);
- didstore = hv_store_ent(hash,*relem,tmpstr,0);
- if (SvMAGICAL(hash)) {
- if (SvSMAGICAL(tmpstr))
- mg_set(tmpstr);
- if (!didstore)
- sv_2mortal(tmpstr);
- }
- TAINT_NOT;
}
}
@@ -970,21 +982,22 @@
SV **firstrelem = PL_stack_base + POPMARK + 1;
SV **firstlelem = lastrelem + 1;
- register SV **relem;
- register SV **lelem;
+ SV **relem;
+ SV **lelem;
- register SV *sv;
- register AV *ary;
+ SV *sv;
+ AV *ary;
I32 gimme;
HV *hash;
I32 i;
int magic;
- int duplicates = 0;
- SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
+ U32 lval = 0;
PL_delaymagic = DM_DELAY; /* catch simultaneous items */
gimme = GIMME_V;
+ if (gimme == G_ARRAY)
+ lval = PL_op->op_flags & OPf_MOD || LVRET;
/* If there's a common identifier on both sides we have to take
* special care that assigning the identifier on the left doesn't
@@ -999,7 +1012,7 @@
|| SvMAGICAL(sv)
|| ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
|| (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
- || (SvTYPE(sv) == SVt_PVHV && HvKEYS((HV*)sv) != 0)
+ || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0)
)
) {
EXTEND_MORTAL(lastrelem - firstrelem + 1);
@@ -1014,9 +1027,11 @@
Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
(void*)sv);
}
- /* Specifically *not* sv_mortalcopy(), as that will steal TEMPs,
- and we need a second copy of a temp here. */
- *relem = sv_2mortal(newSVsv(sv));
+ /* Not newSVsv(), as it does not allow copy-on-write,
+ resulting in wasteful copies. We need a second copy of
+ a temp here, hence the SV_NOSTEAL. */
+ *relem = sv_mortalcopy_flags(sv,SV_GMAGIC|SV_DO_COW_SVSETSV
+ |SV_NOSTEAL);
}
}
}
@@ -1033,6 +1048,8 @@
case SVt_PVAV:
ary = MUTABLE_AV(sv);
magic = SvMAGICAL(ary) != 0;
+ ENTER;
+ SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
av_clear(ary);
av_extend(ary, lastrelem - relem);
i = 0;
@@ -1039,46 +1056,67 @@
while (relem <= lastrelem) { /* gobble up all the rest */
SV **didstore;
assert(*relem);
+ SvGETMAGIC(*relem); /* before newSV, in case it dies */
sv = newSV(0);
- sv_setsv(sv, *relem);
+ sv_setsv_nomg(sv, *relem);
*(relem++) = sv;
didstore = av_store(ary,i++,sv);
if (magic) {
+ if (!didstore)
+ sv_2mortal(sv);
if (SvSMAGICAL(sv))
mg_set(sv);
- if (!didstore)
- sv_2mortal(sv);
}
TAINT_NOT;
}
if (PL_delaymagic & DM_ARRAY_ISA)
SvSETMAGIC(MUTABLE_SV(ary));
+ LEAVE;
break;
case SVt_PVHV: { /* normal hash */
SV *tmpstr;
+ int odd;
+ int duplicates = 0;
SV** topelem = relem;
+ SV **firsthashrelem = relem;
hash = MUTABLE_HV(sv);
magic = SvMAGICAL(hash) != 0;
+
+ odd = ((lastrelem - firsthashrelem)&1)? 0 : 1;
+ if ( odd ) {
+ do_oddball(lastrelem, firsthashrelem);
+ /* we have firstlelem to reuse, it's not needed anymore
+ */
+ *(lastrelem+1) = &PL_sv_undef;
+ }
+
+ ENTER;
+ SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
hv_clear(hash);
- firsthashrelem = relem;
-
- while (relem < lastrelem) { /* gobble up all the rest */
+ while (relem < lastrelem+odd) { /* gobble up all the rest */
HE *didstore;
- sv = *relem ? *relem : &PL_sv_no;
+ assert(*relem);
+ /* Copy the key if aassign is called in lvalue context,
+ to avoid having the next op modify our rhs. Copy
+ it also if it is gmagical, lest it make the
+ hv_store_ent call below croak, leaking the value. */
+ sv = lval || SvGMAGICAL(*relem)
+ ? sv_mortalcopy(*relem)
+ : *relem;
relem++;
- tmpstr = newSV(0);
- if (*relem)
- sv_setsv(tmpstr,*relem); /* value */
- relem++;
- if (gimme != G_VOID) {
+ assert(*relem);
+ SvGETMAGIC(*relem);
+ tmpstr = newSV(0);
+ sv_setsv_nomg(tmpstr,*relem++); /* value */
+ if (gimme == G_ARRAY) {
if (hv_exists_ent(hash, sv, 0))
/* key overwrites an existing entry */
duplicates += 2;
- else
- if (gimme == G_ARRAY) {
+ else {
/* copy element back: possibly to an earlier
- * stack location if we encountered dups earlier */
+ * stack location if we encountered dups earlier,
+ * possibly to a later stack location if odd */
*topelem++ = sv;
*topelem++ = tmpstr;
}
@@ -1085,17 +1123,28 @@
}
didstore = hv_store_ent(hash,sv,tmpstr,0);
if (magic) {
- if (SvSMAGICAL(tmpstr))
- mg_set(tmpstr);
- if (!didstore)
- sv_2mortal(tmpstr);
- }
+ if (!didstore) sv_2mortal(tmpstr);
+ SvSETMAGIC(tmpstr);
+ }
TAINT_NOT;
}
- if (relem == lastrelem) {
- do_oddball(hash, relem, firstrelem);
- relem++;
- }
+ LEAVE;
+ if (duplicates && gimme == G_ARRAY) {
+ /* at this point we have removed the duplicate key/value
+ * pairs from the stack, but the remaining values may be
+ * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
+ * the (a 2), but the stack now probably contains
+ * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
+ * obliterates the earlier key. So refresh all values. */
+ lastrelem -= duplicates;
+ relem = firsthashrelem;
+ while (relem < lastrelem+odd) {
+ HE *he;
+ he = hv_fetch_ent(hash, *relem++, 0, 0);
+ *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
+ }
+ }
+ if (odd && gimme == G_ARRAY) lastrelem++;
}
break;
default:
@@ -1105,6 +1154,14 @@
break;
}
if (relem <= lastrelem) {
+ if (
+ SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
+ (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
+ )
+ Perl_warner(aTHX_
+ packWARN(WARN_MISC),
+ "Useless assignment to a temporary"
+ );
sv_setsv(sv, *relem);
*(relem++) = sv;
}
@@ -1115,71 +1172,83 @@
}
}
if (PL_delaymagic & ~DM_DELAY) {
+ /* Will be used to set PL_tainting below */
+ UV tmp_uid = PerlProc_getuid();
+ UV tmp_euid = PerlProc_geteuid();
+ UV tmp_gid = PerlProc_getgid();
+ UV tmp_egid = PerlProc_getegid();
+
if (PL_delaymagic & DM_UID) {
#ifdef HAS_SETRESUID
- (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
- (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
+ (void)setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
+ (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
(Uid_t)-1);
#else
# ifdef HAS_SETREUID
- (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
- (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
+ (void)setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
+ (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1);
# else
# ifdef HAS_SETRUID
if ((PL_delaymagic & DM_UID) == DM_RUID) {
- (void)setruid(PL_uid);
+ (void)setruid(PL_delaymagic_uid);
PL_delaymagic &= ~DM_RUID;
}
# endif /* HAS_SETRUID */
# ifdef HAS_SETEUID
if ((PL_delaymagic & DM_UID) == DM_EUID) {
- (void)seteuid(PL_euid);
+ (void)seteuid(PL_delaymagic_euid);
PL_delaymagic &= ~DM_EUID;
}
# endif /* HAS_SETEUID */
if (PL_delaymagic & DM_UID) {
- if (PL_uid != PL_euid)
+ if (PL_delaymagic_uid != PL_delaymagic_euid)
DIE(aTHX_ "No setreuid available");
- (void)PerlProc_setuid(PL_uid);
+ (void)PerlProc_setuid(PL_delaymagic_uid);
}
# endif /* HAS_SETREUID */
#endif /* HAS_SETRESUID */
- PL_uid = PerlProc_getuid();
- PL_euid = PerlProc_geteuid();
+ tmp_uid = PerlProc_getuid();
+ tmp_euid = PerlProc_geteuid();
}
if (PL_delaymagic & DM_GID) {
#ifdef HAS_SETRESGID
- (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
- (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
+ (void)setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
+ (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
(Gid_t)-1);
#else
# ifdef HAS_SETREGID
- (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
- (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
+ (void)setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
+ (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1);
# else
# ifdef HAS_SETRGID
if ((PL_delaymagic & DM_GID) == DM_RGID) {
- (void)setrgid(PL_gid);
+ (void)setrgid(PL_delaymagic_gid);
PL_delaymagic &= ~DM_RGID;
}
# endif /* HAS_SETRGID */
# ifdef HAS_SETEGID
if ((PL_delaymagic & DM_GID) == DM_EGID) {
- (void)setegid(PL_egid);
+ (void)setegid(PL_delaymagic_egid);
PL_delaymagic &= ~DM_EGID;
}
# endif /* HAS_SETEGID */
if (PL_delaymagic & DM_GID) {
- if (PL_gid != PL_egid)
+ if (PL_delaymagic_gid != PL_delaymagic_egid)
DIE(aTHX_ "No setregid available");
- (void)PerlProc_setgid(PL_gid);
+ (void)PerlProc_setgid(PL_delaymagic_gid);
}
# endif /* HAS_SETREGID */
#endif /* HAS_SETRESGID */
- PL_gid = PerlProc_getgid();
- PL_egid = PerlProc_getegid();
+ tmp_gid = PerlProc_getgid();
+ tmp_egid = PerlProc_getegid();
}
- PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
+ TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
+#ifdef NO_TAINT_SUPPORT
+ PERL_UNUSED_VAR(tmp_uid);
+ PERL_UNUSED_VAR(tmp_euid);
+ PERL_UNUSED_VAR(tmp_gid);
+ PERL_UNUSED_VAR(tmp_egid);
+#endif
}
PL_delaymagic = 0;
@@ -1188,35 +1257,19 @@
else if (gimme == G_SCALAR) {
dTARGET;
SP = firstrelem;
- SETi(lastrelem - firstrelem + 1 - duplicates);
+ SETi(lastrelem - firstrelem + 1);
}
else {
- if (ary)
+ if (ary || hash)
+ /* note that in this case *firstlelem may have been overwritten
+ by sv_undef in the odd hash case */
SP = lastrelem;
- else if (hash) {
- if (duplicates) {
- /* at this point we have removed the duplicate key/value
- * pairs from the stack, but the remaining values may be
- * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
- * the (a 2), but the stack now probably contains
- * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
- * obliterates the earlier key. So refresh all values. */
- lastrelem -= duplicates;
- relem = firsthashrelem;
- while (relem < lastrelem) {
- HE *he;
- sv = *relem++;
- he = hv_fetch_ent(hash, sv, 0, 0);
- *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
- }
- }
- SP = lastrelem;
- }
- else
+ else {
SP = firstrelem + (lastlelem - firstlelem);
- lelem = firstlelem + (relem - firstrelem);
- while (relem <= SP)
- *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
+ lelem = firstlelem + (relem - firstrelem);
+ while (relem <= SP)
+ *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
+ }
}
RETURN;
@@ -1225,10 +1278,12 @@
PP(pp_qr)
{
dVAR; dSP;
- register PMOP * const pm = cPMOP;
+ PMOP * const pm = cPMOP;
REGEXP * rx = PM_GETRE(pm);
SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
SV * const rv = sv_newmortal();
+ CV **cvp;
+ CV *cv;
SvUPGRADE(rv, SVt_IV);
/* For a subroutine describing itself as "This is a hacky workaround" I'm
@@ -1240,13 +1295,19 @@
SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
SvROK_on(rv);
+ cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
+ if ((cv = *cvp) && CvCLONE(*cvp)) {
+ *cvp = cv_clone(cv);
+ SvREFCNT_dec_NN(cv);
+ }
+
if (pkg) {
HV *const stash = gv_stashsv(pkg, GV_ADD);
- SvREFCNT_dec(pkg);
+ SvREFCNT_dec_NN(pkg);
(void)sv_bless(rv, stash);
}
- if (RX_EXTFLAGS(rx) & RXf_TAINTED) {
+ if (RX_ISTAINTED(rx)) {
SvTAINTED_on(rv);
SvTAINTED_on(SvRV(rv));
}
@@ -1257,15 +1318,15 @@
PP(pp_match)
{
dVAR; dSP; dTARG;
- register PMOP *pm = cPMOP;
+ PMOP *pm = cPMOP;
PMOP *dynpm = pm;
- register const char *t;
- register const char *s;
+ const char *t;
+ const char *s;
const char *strend;
I32 global;
U8 r_flags = REXEC_CHECKED;
const char *truebase; /* Start of string */
- register REGEXP *rx = PM_GETRE(pm);
+ REGEXP *rx = PM_GETRE(pm);
bool rxtainted;
const I32 gimme = GIMME;
STRLEN len;
@@ -1287,18 +1348,21 @@
PUTBACK; /* EVAL blocks need stack_sp. */
/* Skip get-magic if this is a qr// clone, because regcomp has
already done it. */
- s = ((struct regexp *)SvANY(rx))->mother_re
+ s = ReANY(rx)->mother_re
? SvPV_nomg_const(TARG, len)
: SvPV_const(TARG, len);
if (!s)
DIE(aTHX_ "panic: pp_match");
strend = s + len;
- rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
- (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
+ rxtainted = (RX_ISTAINTED(rx) ||
+ (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
TAINT_NOT;
RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
+ /* We need to know this in case we fail out early - pos() must be reset */
+ global = dynpm->op_pmflags & PMf_GLOBAL;
+
/* PMdf_USED is set after a ?? matches once */
if (
#ifdef USE_ITHREADS
@@ -1307,27 +1371,27 @@
pm->op_pmflags & PMf_USED
#endif
) {
- failure:
- if (gimme == G_ARRAY)
- RETURN;
- RETPUSHNO;
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
+ goto nope;
}
-
-
- /* empty pattern special-cased to use last successful pattern if possible */
- if (!RX_PRELEN(rx) && PL_curpm) {
+ /* empty pattern special-cased to use last successful pattern if
+ possible, except for qr// */
+ if (!ReANY(rx)->mother_re && !RX_PRELEN(rx)
+ && PL_curpm) {
pm = PL_curpm;
rx = PM_GETRE(pm);
}
- if (RX_MINLEN(rx) > (I32)len)
- goto failure;
+ if (RX_MINLEN(rx) > (I32)len) {
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match\n"));
+ goto nope;
+ }
truebase = t = s;
/* XXXX What part of this is needed with true \G-support? */
- if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
+ if (global) {
RX_OFFS(rx)[0].start = -1;
if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
@@ -1346,23 +1410,29 @@
}
}
}
- /* XXX: comment out !global get safe $1 vars after a
- match, BUT be aware that this leads to dramatic slowdowns on
- /g matches against large strings. So far a solution to this problem
- appears to be quite tricky.
- Test for the unsafe vars are TODO for now. */
- if ( (!global && RX_NPARENS(rx))
- || SvTEMP(TARG) || SvAMAGIC(TARG) || PL_sawampersand
- || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
- r_flags |= REXEC_COPY_STR;
- if (SvSCREAM(TARG))
- r_flags |= REXEC_SCREAM;
+#ifdef PERL_SAWAMPERSAND
+ if ( RX_NPARENS(rx)
+ || PL_sawampersand
+ || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
+ )
+#endif
+ {
+ r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
+ /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
+ * only on the first iteration. Therefore we need to copy $' as well
+ * as $&, to make the rest of the string available for captures in
+ * subsequent iterations */
+ if (! (global && gimme == G_ARRAY))
+ r_flags |= REXEC_COPY_SKIP_POST;
+ };
play_it_again:
if (global && RX_OFFS(rx)[0].start != -1) {
t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
- if ((s + RX_MINLEN(rx)) > strend || s < truebase)
+ if ((s + RX_MINLEN(rx)) > strend || s < truebase) {
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "Regex match can't succeed, so not even tried\n"));
goto nope;
+ }
if (update_minmatch++)
minmatch = had_zerolen;
}
@@ -1374,31 +1444,26 @@
if (!s)
goto nope;
+#ifdef PERL_SAWAMPERSAND
if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
&& !PL_sawampersand
&& !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
- && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
- || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
- && (r_flags & REXEC_SCREAM)))
&& !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
goto yup;
+#endif
}
- if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
- minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
- {
- PL_curpm = pm;
- if (dynpm->op_pmflags & PMf_ONCE) {
+ if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
+ minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
+ goto ret_no;
+
+ PL_curpm = pm;
+ if (dynpm->op_pmflags & PMf_ONCE) {
#ifdef USE_ITHREADS
- SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
+ SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
#else
- dynpm->op_pmflags |= PMf_USED;
+ dynpm->op_pmflags |= PMf_USED;
#endif
- }
- goto gotcha;
}
- else
- goto ret_no;
- /*NOTREACHED*/
gotcha:
if (rxtainted)
@@ -1418,7 +1483,10 @@
s = RX_OFFS(rx)[i].start + truebase;
if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
len < 0 || len > strend - s)
- DIE(aTHX_ "panic: pp_match start/end pointers");
+ DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
+ "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
+ (long) i, (long) RX_OFFS(rx)[i].start,
+ (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
sv_setpvn(*SP, s, len);
if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
SvUTF8_on(*SP);
@@ -1484,7 +1552,9 @@
RETPUSHYES;
}
+#ifdef PERL_SAWAMPERSAND
yup: /* Confirmed by INTUIT */
+#endif
if (rxtainted)
RX_MATCH_TAINTED_on(rx);
TAINT_IF(RX_MATCH_TAINTED(rx));
@@ -1503,6 +1573,8 @@
if (global) {
/* FIXME - should rx->subbeg be const char *? */
RX_SUBBEG(rx) = (char *) truebase;
+ RX_SUBOFFSET(rx) = 0;
+ RX_SUBCOFFSET(rx) = 0;
RX_OFFS(rx)[0].start = s - truebase;
if (RX_MATCH_UTF8(rx)) {
char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
@@ -1514,10 +1586,13 @@
RX_SUBLEN(rx) = strend - truebase;
goto gotcha;
}
- if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
+#ifdef PERL_SAWAMPERSAND
+ if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
+#endif
+ {
I32 off;
-#ifdef PERL_OLD_COPY_ON_WRITE
- if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
+#ifdef PERL_ANY_COW
+ if (SvCANCOW(TARG)) {
if (DEBUG_C_TEST) {
PerlIO_printf(Perl_debug_log,
"Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
@@ -1533,22 +1608,26 @@
{
RX_SUBBEG(rx) = savepvn(t, strend - t);
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
RX_SAVED_COPY(rx) = NULL;
#endif
}
RX_SUBLEN(rx) = strend - t;
+ RX_SUBOFFSET(rx) = 0;
+ RX_SUBCOFFSET(rx) = 0;
RX_MATCH_COPIED_on(rx);
off = RX_OFFS(rx)[0].start = s - t;
RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
}
+#ifdef PERL_SAWAMPERSAND
else { /* startp/endp are used by @- @+. */
RX_OFFS(rx)[0].start = s - truebase;
RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
}
- /* including RX_NPARENS(rx) in the below code seems highly suspicious.
- -dmq */
- RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
+#endif
+ /* match via INTUIT shouldn't have any captures. Let @-, @+, $^N know */
+ assert(!RX_NPARENS(rx));
+ RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0;
LEAVE_SCOPE(oldsave);
RETPUSHYES;
@@ -1571,12 +1650,12 @@
Perl_do_readline(pTHX)
{
dVAR; dSP; dTARGETSTACKED;
- register SV *sv;
+ SV *sv;
STRLEN tmplen = 0;
STRLEN offset;
PerlIO *fp;
- register IO * const io = GvIO(PL_last_in_gv);
- register const I32 type = PL_op->op_type;
+ IO * const io = GvIO(PL_last_in_gv);
+ const I32 type = PL_op->op_type;
const I32 gimme = GIMME_V;
if (io) {
@@ -1601,6 +1680,7 @@
if (av_len(GvAVn(PL_last_in_gv)) < 0) {
IoFLAGS(io) &= ~IOf_START;
do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
+ SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
sv_setpvs(GvSVn(PL_last_in_gv), "-");
SvSETMAGIC(GvSV(PL_last_in_gv));
fp = IoIFP(io);
@@ -1626,7 +1706,7 @@
&& ckWARN2(WARN_GLOB, WARN_CLOSED))
{
if (type == OP_GLOB)
- Perl_warner(aTHX_ packWARN(WARN_GLOB),
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_GLOB),
"glob failed (can't start child: %s)",
Strerror(errno));
else
@@ -1649,16 +1729,16 @@
mg_get(sv);
if (SvROK(sv)) {
if (type == OP_RCATLINE)
- SvPV_force_nolen(sv);
+ SvPV_force_nomg_nolen(sv);
else
sv_unref(sv);
}
else if (isGV_with_GP(sv)) {
- SvPV_force_nolen(sv);
+ SvPV_force_nomg_nolen(sv);
}
SvUPGRADE(sv, SVt_PV);
tmplen = SvLEN(sv); /* remember if already alloced */
- if (!tmplen && !SvREADONLY(sv)) {
+ if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
/* try short-buffering it. Please update t/op/readline.t
* if you change the growth length.
*/
@@ -1667,7 +1747,7 @@
offset = 0;
if (type == OP_RCATLINE && SvOK(sv)) {
if (!SvPOK(sv)) {
- SvPV_force_nolen(sv);
+ SvPV_force_nomg_nolen(sv);
}
offset = SvCUR(sv);
}
@@ -1739,7 +1819,7 @@
}
}
for (t1 = SvPVX_const(sv); *t1; t1++)
- if (!isALPHA(*t1) && !isDIGIT(*t1) &&
+ if (!isALPHANUMERIC(*t1) &&
strchr("$&*(){}[]'\";\\|?<>~`", *t1))
break;
if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
@@ -1776,31 +1856,6 @@
}
}
-PP(pp_enter)
-{
- dVAR; dSP;
- register PERL_CONTEXT *cx;
- I32 gimme = OP_GIMME(PL_op, -1);
-
- if (gimme == -1) {
- if (cxstack_ix >= 0) {
- /* If this flag is set, we're just inside a return, so we should
- * store the caller's context */
- gimme = (PL_op->op_flags & OPf_SPECIAL)
- ? block_gimme()
- : cxstack[cxstack_ix].blk_gimme;
- } else
- gimme = G_SCALAR;
- }
-
- ENTER_with_name("block");
-
- SAVETMPS;
- PUSHBLOCK(cx, CXt_BLOCK, SP);
-
- RETURN;
-}
-
PP(pp_helem)
{
dVAR; dSP;
@@ -1811,7 +1866,6 @@
const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
SV *sv;
- const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
bool preeminent = TRUE;
@@ -1826,14 +1880,14 @@
* Try to preserve the existenceness of a tied hash
* element by using EXISTS and DELETE if possible.
* Fallback to FETCH and STORE otherwise. */
- if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
+ if (SvCANEXISTDELETE(hv))
preeminent = hv_exists_ent(hv, keysv, 0);
}
- he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
+ he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
svp = he ? &HeVAL(he) : NULL;
if (lval) {
- if (!svp || *svp == &PL_sv_undef) {
+ if (!svp || !*svp || *svp == &PL_sv_undef) {
SV* lv;
SV* key2;
if (!defer) {
@@ -1843,7 +1897,7 @@
sv_upgrade(lv, SVt_PVLV);
LvTYPE(lv) = 'y';
sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
- SvREFCNT_dec(key2); /* sv_magic() increments refcount */
+ SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */
LvTARG(lv) = SvREFCNT_inc_simple(hv);
LvTARGLEN(lv) = 1;
PUSHs(lv);
@@ -1858,10 +1912,12 @@
else
SAVEHDELETE(hv, keysv);
}
- else if (PL_op->op_private & OPpDEREF)
- vivify_ref(*svp, PL_op->op_private & OPpDEREF);
+ else if (PL_op->op_private & OPpDEREF) {
+ PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
+ RETURN;
+ }
}
- sv = (svp ? *svp : &PL_sv_undef);
+ sv = (svp && *svp ? *svp : &PL_sv_undef);
/* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
* was to make C<local $tied{foo} = $tied{foo}> possible.
* However, it seems no longer to be needed for that purpose, and
@@ -1880,111 +1936,61 @@
RETURN;
}
-PP(pp_leave)
-{
- dVAR; dSP;
- register PERL_CONTEXT *cx;
- SV **newsp;
- PMOP *newpm;
- I32 gimme;
-
- if (PL_op->op_flags & OPf_SPECIAL) {
- cx = &cxstack[cxstack_ix];
- cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
- }
-
- POPBLOCK(cx,newpm);
-
- gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
-
- TAINT_NOT;
- if (gimme == G_VOID)
- SP = newsp;
- else if (gimme == G_SCALAR) {
- register SV **mark;
- MARK = newsp + 1;
- if (MARK <= SP) {
- if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
- *MARK = TOPs;
- else
- *MARK = sv_mortalcopy(TOPs);
- } else {
- MEXTEND(mark,0);
- *MARK = &PL_sv_undef;
- }
- SP = MARK;
- }
- else if (gimme == G_ARRAY) {
- /* in case LEAVE wipes old return values */
- register SV **mark;
- for (mark = newsp + 1; mark <= SP; mark++) {
- if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
- *mark = sv_mortalcopy(*mark);
- TAINT_NOT; /* Each item is independent */
- }
- }
- }
- PL_curpm = newpm; /* Don't pop $1 et al till now */
-
- LEAVE_with_name("block");
-
- RETURN;
-}
-
PP(pp_iter)
{
dVAR; dSP;
- register PERL_CONTEXT *cx;
- SV *sv, *oldsv;
+ PERL_CONTEXT *cx;
+ SV *oldsv;
SV **itersvp;
- AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
- bool av_is_stack = FALSE;
EXTEND(SP, 1);
cx = &cxstack[cxstack_ix];
- if (!CxTYPE_is_LOOP(cx))
- DIE(aTHX_ "panic: pp_iter");
+ itersvp = CxITERVAR(cx);
- itersvp = CxITERVAR(cx);
- if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
- /* string increment */
- SV* cur = cx->blk_loop.state_u.lazysv.cur;
- SV *end = cx->blk_loop.state_u.lazysv.end;
- /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
- It has SvPVX of "" and SvCUR of 0, which is what we want. */
- STRLEN maxlen = 0;
- const char *max = SvPV_const(end, maxlen);
- if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
- if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
- /* safe to reuse old SV */
- sv_setsv(*itersvp, cur);
- }
- else
- {
- /* we need a fresh SV every time so that loop body sees a
- * completely new SV for closures/references to work as
- * they used to */
- oldsv = *itersvp;
- *itersvp = newSVsv(cur);
- SvREFCNT_dec(oldsv);
- }
- if (strEQ(SvPVX_const(cur), max))
- sv_setiv(cur, 0); /* terminate next time */
- else
- sv_inc(cur);
- RETPUSHYES;
- }
- RETPUSHNO;
+ switch (CxTYPE(cx)) {
+
+ case CXt_LOOP_LAZYSV: /* string increment */
+ {
+ SV* cur = cx->blk_loop.state_u.lazysv.cur;
+ SV *end = cx->blk_loop.state_u.lazysv.end;
+ /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
+ It has SvPVX of "" and SvCUR of 0, which is what we want. */
+ STRLEN maxlen = 0;
+ const char *max = SvPV_const(end, maxlen);
+ if (SvNIOK(cur) || SvCUR(cur) > maxlen)
+ RETPUSHNO;
+
+ oldsv = *itersvp;
+ if (SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv)) {
+ /* safe to reuse old SV */
+ sv_setsv(oldsv, cur);
+ }
+ else
+ {
+ /* we need a fresh SV every time so that loop body sees a
+ * completely new SV for closures/references to work as
+ * they used to */
+ *itersvp = newSVsv(cur);
+ SvREFCNT_dec_NN(oldsv);
+ }
+ if (strEQ(SvPVX_const(cur), max))
+ sv_setiv(cur, 0); /* terminate next time */
+ else
+ sv_inc(cur);
+ break;
}
- else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
- /* integer increment */
- if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
+
+ case CXt_LOOP_LAZYIV: /* integer increment */
+ {
+ IV cur = cx->blk_loop.state_u.lazyiv.cur;
+ if (cur > cx->blk_loop.state_u.lazyiv.end)
RETPUSHNO;
+ oldsv = *itersvp;
/* don't risk potential race */
- if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
+ if (SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv)) {
/* safe to reuse old SV */
- sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
+ sv_setiv(oldsv, cur);
}
else
{
@@ -1991,81 +1997,79 @@
/* we need a fresh SV every time so that loop body sees a
* completely new SV for closures/references to work as they
* used to */
- oldsv = *itersvp;
- *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
- SvREFCNT_dec(oldsv);
+ *itersvp = newSViv(cur);
+ SvREFCNT_dec_NN(oldsv);
}
- /* Handle end of range at IV_MAX */
- if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
- (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
- {
- cx->blk_loop.state_u.lazyiv.cur++;
- cx->blk_loop.state_u.lazyiv.end++;
- }
-
- RETPUSHYES;
+ if (cur == IV_MAX) {
+ /* Handle end of range at IV_MAX */
+ cx->blk_loop.state_u.lazyiv.end = IV_MIN;
+ } else
+ ++cx->blk_loop.state_u.lazyiv.cur;
+ break;
}
- /* iterate array */
- assert(CxTYPE(cx) == CXt_LOOP_FOR);
- av = cx->blk_loop.state_u.ary.ary;
- if (!av) {
- av_is_stack = TRUE;
- av = PL_curstack;
- }
- if (PL_op->op_private & OPpITER_REVERSED) {
- if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
- ? cx->blk_loop.resetsp + 1 : 0))
- RETPUSHNO;
+ case CXt_LOOP_FOR: /* iterate array */
+ {
- if (SvMAGICAL(av) || AvREIFY(av)) {
- SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
- sv = svp ? *svp : NULL;
- }
- else {
- sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
- }
- }
- else {
- if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
- AvFILL(av)))
- RETPUSHNO;
+ AV *av = cx->blk_loop.state_u.ary.ary;
+ SV *sv;
+ bool av_is_stack = FALSE;
+ IV ix;
- if (SvMAGICAL(av) || AvREIFY(av)) {
- SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
- sv = svp ? *svp : NULL;
- }
- else {
- sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
- }
- }
+ if (!av) {
+ av_is_stack = TRUE;
+ av = PL_curstack;
+ }
+ if (PL_op->op_private & OPpITER_REVERSED) {
+ ix = --cx->blk_loop.state_u.ary.ix;
+ if (ix <= (av_is_stack ? cx->blk_loop.resetsp : -1))
+ RETPUSHNO;
+ }
+ else {
+ ix = ++cx->blk_loop.state_u.ary.ix;
+ if (ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av)))
+ RETPUSHNO;
+ }
- if (sv && SvIS_FREED(sv)) {
- *itersvp = NULL;
- Perl_croak(aTHX_ "Use of freed value in iteration");
+ if (SvMAGICAL(av) || AvREIFY(av)) {
+ SV * const * const svp = av_fetch(av, ix, FALSE);
+ sv = svp ? *svp : NULL;
+ }
+ else {
+ sv = AvARRAY(av)[ix];
+ }
+
+ if (sv) {
+ if (SvIS_FREED(sv)) {
+ *itersvp = NULL;
+ Perl_croak(aTHX_ "Use of freed value in iteration");
+ }
+ SvTEMP_off(sv);
+ SvREFCNT_inc_simple_void_NN(sv);
+ }
+ else
+ sv = &PL_sv_undef;
+
+ if (!av_is_stack && sv == &PL_sv_undef) {
+ SV *lv = newSV_type(SVt_PVLV);
+ LvTYPE(lv) = 'y';
+ sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
+ LvTARG(lv) = SvREFCNT_inc_simple(av);
+ LvTARGOFF(lv) = ix;
+ LvTARGLEN(lv) = (STRLEN)UV_MAX;
+ sv = lv;
+ }
+
+ oldsv = *itersvp;
+ *itersvp = sv;
+ SvREFCNT_dec(oldsv);
+ break;
}
- if (sv) {
- SvTEMP_off(sv);
- SvREFCNT_inc_simple_void_NN(sv);
+ default:
+ DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
}
- else
- sv = &PL_sv_undef;
- if (!av_is_stack && sv == &PL_sv_undef) {
- SV *lv = newSV_type(SVt_PVLV);
- LvTYPE(lv) = 'y';
- sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
- LvTARG(lv) = SvREFCNT_inc_simple(av);
- LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
- LvTARGLEN(lv) = (STRLEN)UV_MAX;
- sv = lv;
- }
-
- oldsv = *itersvp;
- *itersvp = sv;
- SvREFCNT_dec(oldsv);
-
RETPUSHYES;
}
@@ -2072,21 +2076,25 @@
/*
A description of how taint works in pattern matching and substitution.
-While the pattern is being assembled/concatenated and them compiled,
-PL_tainted will get set if any component of the pattern is tainted, e.g.
-/.*$tainted/. At the end of pattern compilation, the RXf_TAINTED flag
-is set on the pattern if PL_tainted is set.
+This is all conditional on NO_TAINT_SUPPORT not being defined. Under
+NO_TAINT_SUPPORT, taint-related operations should become no-ops.
+While the pattern is being assembled/concatenated and then compiled,
+PL_tainted will get set (via TAINT_set) if any component of the pattern
+is tainted, e.g. /.*$tainted/. At the end of pattern compilation,
+the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
+TAINT_get).
+
When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
the pattern is marked as tainted. This means that subsequent usage, such
-as /x$r/, will set PL_tainted, and thus RXf_TAINTED, on the new pattern too.
+as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
+on the new pattern too.
-During execution of a pattern, locale-variant ops such as ALNUML set the
-local flag RF_tainted. At the end of execution, the engine sets the
-RXf_TAINTED_SEEN on the pattern if RF_tainted got set, or clears it
-otherwise.
+At the start of execution of a pattern, the RXf_TAINTED_SEEN flag on the
+regex is cleared; during execution, locale-variant ops such as POSIXL may
+set RXf_TAINTED_SEEN.
-In addition, RXf_TAINTED_SEEN is used post-execution by the get magic code
+RXf_TAINTED_SEEN is used post-execution by the get magic code
of $1 et al to indicate whether the returned value should be tainted.
It is the responsibility of the caller of the pattern (i.e. pp_match,
pp_subst etc) to set this flag for any other circumstances where $1 needs
@@ -2139,34 +2147,34 @@
PP(pp_subst)
{
dVAR; dSP; dTARG;
- register PMOP *pm = cPMOP;
+ PMOP *pm = cPMOP;
PMOP *rpm = pm;
- register char *s;
+ char *s;
char *strend;
- register char *m;
+ char *m;
const char *c;
- register char *d;
+ char *d;
STRLEN clen;
I32 iters = 0;
I32 maxiters;
- register I32 i;
+ I32 i;
bool once;
U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
See "how taint works" above */
char *orig;
U8 r_flags;
- register REGEXP *rx = PM_GETRE(pm);
+ REGEXP *rx = PM_GETRE(pm);
STRLEN len;
int force_on_match = 0;
const I32 oldsave = PL_savestack_ix;
STRLEN slen;
- bool doutf8 = FALSE;
-#ifdef PERL_OLD_COPY_ON_WRITE
+ bool doutf8 = FALSE; /* whether replacement is in utf8 */
+#ifdef PERL_ANY_COW
bool is_cow;
#endif
SV *nsv = NULL;
/* known replacement string? */
- register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
+ SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
PERL_ASYNC_CHECK();
@@ -2179,12 +2187,8 @@
EXTEND(SP,1);
}
- /* In non-destructive replacement mode, duplicate target scalar so it
- * remains unchanged. */
- if (rpm->op_pmflags & PMf_NONDESTRUCT)
- TARG = sv_2mortal(newSVsv(TARG));
-
-#ifdef PERL_OLD_COPY_ON_WRITE
+ SvGETMAGIC(TARG); /* must come before cow check */
+#ifdef PERL_ANY_COW
/* Awooga. Awooga. "bool" types that are actually char are dangerous,
because they make integers such as 256 "false". */
is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
@@ -2192,20 +2196,19 @@
if (SvIsCOW(TARG))
sv_force_normal_flags(TARG,0);
#endif
- if (
-#ifdef PERL_OLD_COPY_ON_WRITE
- !is_cow &&
+ if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
+#ifdef PERL_ANY_COW
+ && !is_cow
#endif
- (SvREADONLY(TARG)
- || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
- || SvTYPE(TARG) > SVt_PVLV)
- && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
- Perl_croak_no_modify(aTHX);
+ && (SvREADONLY(TARG)
+ || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
+ || SvTYPE(TARG) > SVt_PVLV)
+ && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
+ Perl_croak_no_modify();
PUTBACK;
- setup_match:
- s = SvPV_mutable(TARG, len);
- if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
+ s = SvPV_nomg(TARG, len);
+ if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
force_on_match = 1;
/* only replace once? */
@@ -2212,10 +2215,10 @@
once = !(rpm->op_pmflags & PMf_GLOBAL);
/* See "how taint works" above */
- if (PL_tainting) {
+ if (TAINTING_get) {
rxtainted = (
(SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
- | ((RX_EXTFLAGS(rx) & RXf_TAINTED) ? SUBST_TAINT_PAT : 0)
+ | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0)
| ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
| ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
? SUBST_TAINT_BOOLRET : 0));
@@ -2226,7 +2229,7 @@
force_it:
if (!pm || !s)
- DIE(aTHX_ "panic: pp_subst");
+ DIE(aTHX_ "panic: pp_subst, pm=%p, s=%p", pm, s);
strend = s + len;
slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
@@ -2234,16 +2237,23 @@
position, once with zero-length,
second time with non-zero. */
- if (!RX_PRELEN(rx) && PL_curpm) {
+ if (!RX_PRELEN(rx) && PL_curpm
+ && !ReANY(rx)->mother_re) {
pm = PL_curpm;
rx = PM_GETRE(pm);
}
- r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
- || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
- ? REXEC_COPY_STR : 0;
- if (SvSCREAM(TARG))
- r_flags |= REXEC_SCREAM;
+#ifdef PERL_SAWAMPERSAND
+ r_flags = ( RX_NPARENS(rx)
+ || PL_sawampersand
+ || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
+ )
+ ? REXEC_COPY_STR
+ : 0;
+#else
+ r_flags = REXEC_COPY_STR;
+#endif
+
orig = m = s;
if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
PL_bostr = orig;
@@ -2254,10 +2264,7 @@
/* How to do it in subst? */
/* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
&& !PL_sawampersand
- && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
- && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
- || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
- && (r_flags & REXEC_SCREAM))))
+ && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY))
goto yup;
*/
}
@@ -2272,27 +2279,10 @@
RETURN;
}
+ PL_curpm = pm;
+
/* known replacement string? */
if (dstr) {
- if (SvTAINTED(dstr))
- rxtainted |= SUBST_TAINT_REPL;
-
- /* Upgrade the source if the replacement is utf8 but the source is not,
- * but only if it matched; see
- * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
- */
- if (DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
- char * const orig_pvx = SvPVX(TARG);
- const STRLEN new_len = sv_utf8_upgrade_nomg(TARG);
-
- /* If the lengths are the same, the pattern contains only
- * invariants, can keep going; otherwise, various internal markers
- * could be off, so redo */
- if (new_len != len || orig_pvx != SvPVX(TARG)) {
- goto setup_match;
- }
- }
-
/* replacement needing upgrading? */
if (DO_UTF8(TARG) && !doutf8) {
nsv = sv_newmortal();
@@ -2308,6 +2298,9 @@
c = SvPV_const(dstr, clen);
doutf8 = DO_UTF8(dstr);
}
+
+ if (SvTAINTED(dstr))
+ rxtainted |= SUBST_TAINT_REPL;
}
else {
c = NULL;
@@ -2316,28 +2309,29 @@
/* can do inplace substitution? */
if (c
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
&& !is_cow
#endif
- && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
- && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
- && (!doutf8 || SvUTF8(TARG)))
+ && (I32)clen <= RX_MINLENRET(rx)
+ && (once || !(r_flags & REXEC_COPY_STR))
+ && !(RX_EXTFLAGS(rx) & RXf_NO_INPLACE_SUBST)
+ && (!doutf8 || SvUTF8(TARG))
+ && !(rpm->op_pmflags & PMf_NONDESTRUCT))
{
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
if (SvIsCOW(TARG)) {
- assert (!force_on_match);
+ if (!force_on_match)
goto have_a_cow;
+ assert(SvVOK(TARG));
}
#endif
if (force_on_match) {
force_on_match = 0;
- s = SvPV_force(TARG, len);
+ s = SvPV_force_nomg(TARG, len);
goto force_it;
}
d = s;
- PL_curpm = pm;
- SvSCREAM_off(TARG); /* disable possible screamer */
if (once) {
if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
rxtainted |= SUBST_TAINT_PAT;
@@ -2374,7 +2368,7 @@
sv_chop(TARG, d);
}
SPAGAIN;
- PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_yes);
+ PUSHs(&PL_sv_yes);
}
else {
do {
@@ -2403,28 +2397,34 @@
Move(s, d, i+1, char); /* include the NUL */
}
SPAGAIN;
- if (rpm->op_pmflags & PMf_NONDESTRUCT)
- PUSHs(TARG);
- else
- mPUSHi((I32)iters);
+ mPUSHi((I32)iters);
}
}
else {
+ bool first;
+ SV *repl;
if (force_on_match) {
force_on_match = 0;
- s = SvPV_force(TARG, len);
+ if (rpm->op_pmflags & PMf_NONDESTRUCT) {
+ /* I feel that it should be possible to avoid this mortal copy
+ given that the code below copies into a new destination.
+ However, I suspect it isn't worth the complexity of
+ unravelling the C<goto force_it> for the small number of
+ cases where it would be viable to drop into the copy code. */
+ TARG = sv_2mortal(newSVsv(TARG));
+ }
+ s = SvPV_force_nomg(TARG, len);
goto force_it;
}
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
have_a_cow:
#endif
if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
rxtainted |= SUBST_TAINT_PAT;
- dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
- SAVEFREESV(dstr);
- PL_curpm = pm;
+ repl = dstr;
+ dstr = newSVpvn_flags(m, s-m, SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
if (!c) {
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
SPAGAIN;
/* note that a whole bunch of local vars are saved here for
* use by pp_substcont: here's a list of them in case you're
@@ -2435,6 +2435,7 @@
RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
}
r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
+ first = TRUE;
do {
if (iters++ > maxiters)
DIE(aTHX_ "Substitution loop");
@@ -2443,58 +2444,74 @@
if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
m = s;
s = orig;
+ assert(RX_SUBOFFSET(rx) == 0);
orig = RX_SUBBEG(rx);
s = orig + (m - s);
strend = s + (strend - m);
}
m = RX_OFFS(rx)[0].start + orig;
- if (doutf8 && !SvUTF8(dstr))
- sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
- else
- sv_catpvn(dstr, s, m-s);
+ sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
s = RX_OFFS(rx)[0].end + orig;
- if (clen)
- sv_catpvn(dstr, c, clen);
+ if (first) {
+ /* replacement already stringified */
+ if (clen)
+ sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
+ first = FALSE;
+ }
+ else {
+ if (PL_encoding) {
+ if (!nsv) nsv = sv_newmortal();
+ sv_copypv(nsv, repl);
+ if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, PL_encoding);
+ sv_catsv(dstr, nsv);
+ }
+ else sv_catsv(dstr, repl);
+ if (SvTAINTED(repl))
+ rxtainted |= SUBST_TAINT_REPL;
+ }
if (once)
break;
} while (CALLREGEXEC(rx, s, strend, orig, s == m,
TARG, NULL, r_flags));
- if (doutf8 && !DO_UTF8(TARG))
- sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
- else
- sv_catpvn(dstr, s, strend - s);
+ sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
-#ifdef PERL_OLD_COPY_ON_WRITE
- /* The match may make the string COW. If so, brilliant, because that's
- just saved us one malloc, copy and free - the regexp has donated
- the old buffer, and we malloc an entirely new one, rather than the
- regexp malloc()ing a buffer and copying our original, only for
- us to throw it away here during the substitution. */
- if (SvIsCOW(TARG)) {
- sv_force_normal_flags(TARG, SV_COW_DROP_PV);
- } else
+ if (rpm->op_pmflags & PMf_NONDESTRUCT) {
+ /* From here on down we're using the copy, and leaving the original
+ untouched. */
+ TARG = dstr;
+ SPAGAIN;
+ PUSHs(dstr);
+ } else {
+#ifdef PERL_ANY_COW
+ /* The match may make the string COW. If so, brilliant, because
+ that's just saved us one malloc, copy and free - the regexp has
+ donated the old buffer, and we malloc an entirely new one, rather
+ than the regexp malloc()ing a buffer and copying our original,
+ only for us to throw it away here during the substitution. */
+ if (SvIsCOW(TARG)) {
+ sv_force_normal_flags(TARG, SV_COW_DROP_PV);
+ } else
#endif
- {
- SvPV_free(TARG);
- }
- SvPV_set(TARG, SvPVX(dstr));
- SvCUR_set(TARG, SvCUR(dstr));
- SvLEN_set(TARG, SvLEN(dstr));
- doutf8 |= DO_UTF8(dstr);
- SvPV_set(dstr, NULL);
+ {
+ SvPV_free(TARG);
+ }
+ SvPV_set(TARG, SvPVX(dstr));
+ SvCUR_set(TARG, SvCUR(dstr));
+ SvLEN_set(TARG, SvLEN(dstr));
+ SvFLAGS(TARG) |= SvUTF8(dstr);
+ SvPV_set(dstr, NULL);
- SPAGAIN;
- if (rpm->op_pmflags & PMf_NONDESTRUCT)
- PUSHs(TARG);
- else
+ SPAGAIN;
mPUSHi((I32)iters);
+ }
}
- (void)SvPOK_only_UTF8(TARG);
- if (doutf8)
- SvUTF8_on(TARG);
+ if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
+ (void)SvPOK_only_UTF8(TARG);
+ }
+
/* See "how taint works" above */
- if (PL_tainting) {
+ if (TAINTING_get) {
if ((rxtainted & SUBST_TAINT_PAT) ||
((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
(SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
@@ -2509,8 +2526,9 @@
SvTAINTED_off(TOPs); /* may have got tainted earlier */
/* needed for mg_set below */
- PL_tainted =
- cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
+ TAINT_set(
+ cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
+ );
SvTAINT(TARG);
}
SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
@@ -2578,7 +2596,7 @@
SV **newsp;
PMOP *newpm;
I32 gimme;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
SV *sv;
if (CxMULTICALL(&cxstack[cxstack_ix]))
@@ -2592,7 +2610,8 @@
MARK = newsp + 1;
if (MARK <= SP) {
if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
- if (SvTEMP(TOPs)) {
+ if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
+ && !SvMAGICAL(TOPs)) {
*MARK = SvREFCNT_inc(TOPs);
FREETMPS;
sv_2mortal(*MARK);
@@ -2601,11 +2620,15 @@
sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
FREETMPS;
*MARK = sv_mortalcopy(sv);
- SvREFCNT_dec(sv);
+ SvREFCNT_dec_NN(sv);
}
}
+ else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
+ && !SvMAGICAL(TOPs)) {
+ *MARK = TOPs;
+ }
else
- *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
+ *MARK = sv_mortalcopy(TOPs);
}
else {
MEXTEND(MARK, 0);
@@ -2615,7 +2638,8 @@
}
else if (gimme == G_ARRAY) {
for (MARK = newsp + 1; MARK <= SP; MARK++) {
- if (!SvTEMP(*MARK)) {
+ if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
+ || SvMAGICAL(*MARK)) {
*MARK = sv_mortalcopy(*MARK);
TAINT_NOT; /* Each item is independent */
}
@@ -2632,202 +2656,12 @@
return cx->blk_sub.retop;
}
-/* This duplicates the above code because the above code must not
- * get any slower by more conditions */
-PP(pp_leavesublv)
-{
- dVAR; dSP;
- SV **mark;
- SV **newsp;
- PMOP *newpm;
- I32 gimme;
- register PERL_CONTEXT *cx;
- SV *sv;
-
- if (CxMULTICALL(&cxstack[cxstack_ix]))
- return 0;
-
- POPBLOCK(cx,newpm);
- cxstack_ix++; /* temporarily protect top context */
-
- TAINT_NOT;
-
- if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
- /* We are an argument to a function or grep().
- * This kind of lvalueness was legal before lvalue
- * subroutines too, so be backward compatible:
- * cannot report errors. */
-
- /* Scalar context *is* possible, on the LHS of -> only,
- * as in f()->meth(). But this is not an lvalue. */
- if (gimme == G_SCALAR)
- goto temporise;
- if (gimme == G_ARRAY) {
- mark = newsp + 1;
- /* We want an array here, but padav will have left us an arrayref for an lvalue,
- * so we need to expand it */
- if(SvTYPE(*mark) == SVt_PVAV) {
- AV *const av = MUTABLE_AV(*mark);
- const I32 maxarg = AvFILL(av) + 1;
- (void)POPs; /* get rid of the array ref */
- EXTEND(SP, maxarg);
- if (SvRMAGICAL(av)) {
- U32 i;
- for (i=0; i < (U32)maxarg; i++) {
- SV ** const svp = av_fetch(av, i, FALSE);
- SP[i+1] = svp
- ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
- : &PL_sv_undef;
- }
- }
- else {
- Copy(AvARRAY(av), SP+1, maxarg, SV*);
- }
- SP += maxarg;
- PUTBACK;
- }
- if (!CvLVALUE(cx->blk_sub.cv))
- goto temporise_array;
- EXTEND_MORTAL(SP - newsp);
- for (mark = newsp + 1; mark <= SP; mark++) {
- if (SvTEMP(*mark))
- NOOP;
- else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
- *mark = sv_mortalcopy(*mark);
- else {
- /* Can be a localized value subject to deletion. */
- PL_tmps_stack[++PL_tmps_ix] = *mark;
- SvREFCNT_inc_void(*mark);
- }
- }
- }
- }
- else if (CxLVAL(cx)) { /* Leave it as it is if we can. */
- /* Here we go for robustness, not for speed, so we change all
- * the refcounts so the caller gets a live guy. Cannot set
- * TEMP, so sv_2mortal is out of question. */
- if (!CvLVALUE(cx->blk_sub.cv)) {
- LEAVE;
- cxstack_ix--;
- POPSUB(cx,sv);
- PL_curpm = newpm;
- LEAVESUB(sv);
- DIE(aTHX_ "Can't modify non-lvalue subroutine call");
- }
- if (gimme == G_SCALAR) {
- MARK = newsp + 1;
- EXTEND_MORTAL(1);
- if (MARK == SP) {
- /* Temporaries are bad unless they happen to have set magic
- * attached, such as the elements of a tied hash or array */
- if ((SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP) ||
- (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
- == SVf_READONLY
- ) &&
- !SvSMAGICAL(TOPs)) {
- LEAVE;
- cxstack_ix--;
- POPSUB(cx,sv);
- PL_curpm = newpm;
- LEAVESUB(sv);
- DIE(aTHX_ "Can't return %s from lvalue subroutine",
- SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
- : "a readonly value" : "a temporary");
- }
- else { /* Can be a localized value
- * subject to deletion. */
- PL_tmps_stack[++PL_tmps_ix] = *mark;
- SvREFCNT_inc_void(*mark);
- }
- }
- else { /* Should not happen? */
- LEAVE;
- cxstack_ix--;
- POPSUB(cx,sv);
- PL_curpm = newpm;
- LEAVESUB(sv);
- DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
- (MARK > SP ? "Empty array" : "Array"));
- }
- SP = MARK;
- }
- else if (gimme == G_ARRAY) {
- EXTEND_MORTAL(SP - newsp);
- for (mark = newsp + 1; mark <= SP; mark++) {
- if (*mark != &PL_sv_undef
- && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
- /* Might be flattened array after $#array = */
- PUTBACK;
- LEAVE;
- cxstack_ix--;
- POPSUB(cx,sv);
- PL_curpm = newpm;
- LEAVESUB(sv);
- DIE(aTHX_ "Can't return a %s from lvalue subroutine",
- SvREADONLY(TOPs) ? "readonly value" : "temporary");
- }
- else {
- /* Can be a localized value subject to deletion. */
- PL_tmps_stack[++PL_tmps_ix] = *mark;
- SvREFCNT_inc_void(*mark);
- }
- }
- }
- }
- else {
- if (gimme == G_SCALAR) {
- temporise:
- MARK = newsp + 1;
- if (MARK <= SP) {
- if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
- if (SvTEMP(TOPs)) {
- *MARK = SvREFCNT_inc(TOPs);
- FREETMPS;
- sv_2mortal(*MARK);
- }
- else {
- sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
- FREETMPS;
- *MARK = sv_mortalcopy(sv);
- SvREFCNT_dec(sv);
- }
- }
- else
- *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
- }
- else {
- MEXTEND(MARK, 0);
- *MARK = &PL_sv_undef;
- }
- SP = MARK;
- }
- else if (gimme == G_ARRAY) {
- temporise_array:
- for (MARK = newsp + 1; MARK <= SP; MARK++) {
- if (!SvTEMP(*MARK)) {
- *MARK = sv_mortalcopy(*MARK);
- TAINT_NOT; /* Each item is independent */
- }
- }
- }
- }
- PUTBACK;
-
- LEAVE;
- cxstack_ix--;
- POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
- PL_curpm = newpm; /* ... and pop $1 et al */
-
- LEAVESUB(sv);
- return cx->blk_sub.retop;
-}
-
PP(pp_entersub)
{
dVAR; dSP; dPOPss;
GV *gv;
- register CV *cv;
- register PERL_CONTEXT *cx;
+ CV *cv;
+ PERL_CONTEXT *cx;
I32 gimme;
const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
@@ -2836,8 +2670,6 @@
switch (SvTYPE(sv)) {
/* This is overwhelming the most common case: */
case SVt_PVGV:
- if (!isGV_with_GP(sv))
- DIE(aTHX_ "Not a CODE reference");
we_have_a_glob:
if (!(cv = GvCVu((const GV *)sv))) {
HV *stash;
@@ -2870,11 +2702,11 @@
else {
const char *sym;
STRLEN len;
+ if (!SvOK(sv))
+ DIE(aTHX_ PL_no_usym, "a subroutine");
sym = SvPV_nomg_const(sv, len);
- if (!sym)
- DIE(aTHX_ PL_no_usym, "a subroutine");
if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(aTHX_ "Can't use string (\"%.32s\"%s) as a subroutine ref while \"strict refs\" in use", sym, len>32 ? "..." : "");
+ DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
break;
}
@@ -2902,8 +2734,12 @@
SV* sub_name;
/* anonymous or undef'd function leaves us no recourse */
- if (CvANON(cv) || !(gv = CvGV(cv)))
+ if (CvANON(cv) || !(gv = CvGV(cv))) {
+ if (CvNAMED(cv))
+ DIE(aTHX_ "Undefined subroutine &%"HEKf" called",
+ HEKfARG(CvNAME_HEK(cv)));
DIE(aTHX_ "Undefined subroutine called");
+ }
/* autoloaded stub? */
if (cv != GvCV(gv)) {
@@ -2912,13 +2748,13 @@
/* should call AUTOLOAD now? */
else {
try_autoload:
- if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
- FALSE)))
+ if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
+ GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
{
cv = GvCV(autogv);
}
- /* sorry */
else {
+ sorry:
sub_name = sv_newmortal();
gv_efullname3(sub_name, gv, NULL);
DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
@@ -2925,7 +2761,7 @@
}
}
if (!cv)
- DIE(aTHX_ "Not a CODE reference");
+ goto sorry;
goto retry;
}
@@ -2950,17 +2786,12 @@
if (!(CvISXSUB(cv))) {
/* This path taken at least 75% of the time */
dMARK;
- register I32 items = SP - MARK;
- AV* const padlist = CvPADLIST(cv);
+ I32 items = SP - MARK;
+ PADLIST * const padlist = CvPADLIST(cv);
PUSHBLOCK(cx, CXt_SUB, MARK);
PUSHSUB(cx);
cx->blk_sub.retop = PL_op->op_next;
CvDEPTH(cv)++;
- /* XXX This would be a natural place to set C<PL_compcv = cv> so
- * that eval'' ops within this sub know the correct lexical space.
- * Owing the speed considerations, we choose instead to search for
- * the cv using find_runcv() when calling doeval().
- */
if (CvDEPTH(cv) >= 2) {
PERL_STACK_OVERFLOW_CHECK();
pad_push(padlist, CvDEPTH(cv));
@@ -2982,19 +2813,14 @@
cx->blk_sub.argarray = av;
++MARK;
- if (items > AvMAX(av) + 1) {
- SV **ary = AvALLOC(av);
- if (AvARRAY(av) != ary) {
- AvMAX(av) += AvARRAY(av) - AvALLOC(av);
- AvARRAY(av) = ary;
- }
- if (items > AvMAX(av) + 1) {
- AvMAX(av) = items - 1;
- Renew(ary,items,SV*);
- AvALLOC(av) = ary;
- AvARRAY(av) = ary;
- }
- }
+ if (items - 1 > AvMAX(av)) {
+ SV **ary = AvALLOC(av);
+ AvMAX(av) = items - 1;
+ Renew(ary, items, SV*);
+ AvALLOC(av) = ary;
+ AvARRAY(av) = ary;
+ }
+
Copy(MARK,AvARRAY(av),items,SV*);
AvFILLp(av) = items - 1;
@@ -3004,6 +2830,9 @@
MARK++;
}
}
+ if ((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
+ !CvLVALUE(cv))
+ DIE(aTHX_ "Can't modify non-lvalue subroutine call");
/* warning must come *after* we fully set up the context
* stuff so that __WARN__ handlers can safely dounwind()
* if they want to
@@ -3018,6 +2847,12 @@
PUTBACK;
+ if (((PL_op->op_private
+ & PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
+ ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
+ !CvLVALUE(cv))
+ DIE(aTHX_ "Can't modify non-lvalue subroutine call");
+
if (!hasargs) {
/* Need to copy @_ to stack. Alternative may be to
* switch stack to @_, and copy return values
@@ -3066,8 +2901,15 @@
if (CvANON(cv))
Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
else {
- SV* const tmpstr = sv_newmortal();
- gv_efullname3(tmpstr, CvGV(cv), NULL);
+ HEK *const hek = CvNAME_HEK(cv);
+ SV *tmpstr;
+ if (hek) {
+ tmpstr = sv_2mortal(newSVhek(hek));
+ }
+ else {
+ tmpstr = sv_newmortal();
+ gv_efullname3(tmpstr, CvGV(cv), NULL);
+ }
Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
SVfARG(tmpstr));
}
@@ -3090,8 +2932,6 @@
Perl_warner(aTHX_ packWARN(WARN_MISC),
"Use of reference \"%"SVf"\" as array index",
SVfARG(elemsv));
- if (elem > 0)
- elem -= CopARYBASE_get(PL_curcop);
if (SvTYPE(av) != SVt_PVAV)
RETPUSHUNDEF;
@@ -3142,8 +2982,10 @@
else
SAVEADELETE(av, elem);
}
- else if (PL_op->op_private & OPpDEREF)
- vivify_ref(*svp, PL_op->op_private & OPpDEREF);
+ else if (PL_op->op_private & OPpDEREF) {
+ PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
+ RETURN;
+ }
}
sv = (svp ? *svp : &PL_sv_undef);
if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
@@ -3152,7 +2994,7 @@
RETURN;
}
-void
+SV*
Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
{
PERL_ARGS_ASSERT_VIVIFY_REF;
@@ -3160,7 +3002,7 @@
SvGETMAGIC(sv);
if (!SvOK(sv)) {
if (SvREADONLY(sv))
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
prepare_SV_for_RV(sv);
switch (to_what) {
case OPpDEREF_SV:
@@ -3175,7 +3017,16 @@
}
SvROK_on(sv);
SvSETMAGIC(sv);
+ SvGETMAGIC(sv);
}
+ if (SvGMAGICAL(sv)) {
+ /* copy the sv without magic to prevent magic from being
+ executed twice */
+ SV* msv = sv_newmortal();
+ sv_setsv_nomg(msv, sv);
+ return msv;
+ }
+ return sv;
}
PP(pp_method)
@@ -3212,14 +3063,17 @@
SV* ob;
GV* gv;
HV* stash;
- const char* packname = NULL;
SV *packsv = NULL;
- STRLEN packlen;
- SV * const sv = *(PL_stack_base + TOPMARK + 1);
+ SV * const sv = PL_stack_base + TOPMARK == PL_stack_sp
+ ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
+ "package or object reference", SVfARG(meth)),
+ (SV *)NULL)
+ : *(PL_stack_base + TOPMARK + 1);
PERL_ARGS_ASSERT_METHOD_COMMON;
if (!sv)
+ undefined:
Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
SVfARG(meth));
@@ -3226,42 +3080,48 @@
SvGETMAGIC(sv);
if (SvROK(sv))
ob = MUTABLE_SV(SvRV(sv));
+ else if (!SvOK(sv)) goto undefined;
else {
+ /* this isn't a reference */
GV* iogv;
-
- /* this isn't a reference */
- if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
- const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
- if (he) {
+ STRLEN packlen;
+ const char * const packname = SvPV_nomg_const(sv, packlen);
+ const bool packname_is_utf8 = !!SvUTF8(sv);
+ const HE* const he =
+ (const HE *)hv_common(
+ PL_stashcache, NULL, packname, packlen,
+ packname_is_utf8 ? HVhek_UTF8 : 0, 0, NULL, 0
+ );
+
+ if (he) {
stash = INT2PTR(HV*,SvIV(HeVAL(he)));
+ DEBUG_o(Perl_deb(aTHX_ "PL_stashcache hit %p for '%"SVf"'\n",
+ stash, sv));
goto fetch;
- }
}
- if (!SvOK(sv) ||
- !(packname) ||
- !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
+ if (!(iogv = gv_fetchpvn_flags(
+ packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO
+ )) ||
!(ob=MUTABLE_SV(GvIO(iogv))))
{
/* this isn't the name of a filehandle either */
- if (!packname ||
- ((UTF8_IS_START(*packname) && DO_UTF8(sv))
- ? !isIDFIRST_utf8((U8*)packname)
- : !isIDFIRST(*packname)
- ))
+ if (!packlen)
{
- Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
- SVfARG(meth),
- SvOK(sv) ? "without a package or object reference"
- : "on an undefined value");
+ Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
+ "without a package or object reference",
+ SVfARG(meth));
}
/* assume it's a package name */
- stash = gv_stashpvn(packname, packlen, 0);
+ stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0);
if (!stash)
packsv = sv;
else {
SV* const ref = newSViv(PTR2IV(stash));
- (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
+ (void)hv_store(PL_stashcache, packname,
+ packname_is_utf8 ? -(I32)packlen : (I32)packlen, ref, 0);
+ DEBUG_o(Perl_deb(aTHX_ "PL_stashcache caching %p for '%"SVf"'\n",
+ stash, sv));
}
goto fetch;
}
@@ -3276,10 +3136,10 @@
&& (ob = MUTABLE_SV(GvIO((const GV *)ob)))
&& SvOBJECT(ob))))
{
- const char * const name = SvPV_nolen_const(meth);
- Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
- (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
- name);
+ Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
+ SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
+ ? newSVpvs_flags("DOES", SVs_TEMP)
+ : meth));
}
stash = SvSTASH(ob);
@@ -3300,9 +3160,8 @@
}
}
- gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv),
- SvPV_nolen_const(meth),
- GV_AUTOLOAD | GV_CROAK);
+ gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv),
+ meth, GV_AUTOLOAD | GV_CROAK);
assert(gv);
@@ -3313,8 +3172,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/pp_hot.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/pp_pack.c
===================================================================
--- trunk/contrib/perl/pp_pack.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/pp_pack.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -920,7 +920,7 @@
* returns char pointer to char after match, or NULL
*/
STATIC const char *
-S_group_end(pTHX_ register const char *patptr, register const char *patend, char ender)
+S_group_end(pTHX_ const char *patptr, const char *patend, char ender)
{
PERL_ARGS_ASSERT_GROUP_END;
@@ -951,7 +951,7 @@
* Advances char pointer to 1st non-digit char and returns number
*/
STATIC const char *
-S_get_num(pTHX_ register const char *patptr, I32 *lenptr )
+S_get_num(pTHX_ const char *patptr, I32 *lenptr )
{
I32 len = *patptr++ - '0';
@@ -1189,10 +1189,22 @@
/*
=for apidoc unpackstring
-The engine implementing unpack() Perl function. C<unpackstring> puts the
-extracted list items on the stack and returns the number of elements.
-Issue C<PUTBACK> before and C<SPAGAIN> after the call to this function.
+The engine implementing the unpack() Perl function.
+Using the template pat..patend, this function unpacks the string
+s..strend into a number of mortal SVs, which it pushes onto the perl
+argument (@_) stack (so you will need to issue a C<PUTBACK> before and
+C<SPAGAIN> after the call to this function). It returns the number of
+pushed elements.
+
+The strend and patend pointers should point to the byte following the last
+character of each string.
+
+Although this function returns its values on the perl argument stack, it
+doesn't take any parameters from that stack (and thus in particular
+there's no need to do a PUSHMARK before calling it, unlike L</call_pv> for
+example).
+
=cut */
I32
@@ -1470,7 +1482,7 @@
if (utf8 && (symptr->flags & FLAG_WAS_UTF8)) {
for (ptr = s+len-1; ptr >= s; ptr--)
if (*ptr != 0 && !UTF8_IS_CONTINUATION(*ptr) &&
- !is_utf8_space((U8 *) ptr)) break;
+ !isSPACE_utf8(ptr)) break;
if (ptr >= s) ptr += UTF8SKIP(ptr);
else ptr++;
if (ptr > s+len)
@@ -1690,10 +1702,10 @@
len = UTF8SKIP(result);
if (!uni_to_bytes(aTHX_ &ptr, strend,
(char *) &result[1], len-1, 'U')) break;
- auv = utf8n_to_uvuni(result, len, &retlen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV);
+ auv = utf8n_to_uvuni(result, len, &retlen, UTF8_ALLOW_DEFAULT);
s = ptr;
} else {
- auv = utf8n_to_uvuni((U8*)s, strend - s, &retlen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV);
+ auv = utf8n_to_uvuni((U8*)s, strend - s, &retlen, UTF8_ALLOW_DEFAULT);
if (retlen == (STRLEN) -1 || retlen == 0)
Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
s += retlen;
@@ -2234,7 +2246,7 @@
if (symptr->flags & FLAG_SLASH){
if (SP - PL_stack_base - start_sp_offset <= 0)
- Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
+ break;
if( next_symbol(symptr) ){
if( symptr->howlen == e_number )
Perl_croak(aTHX_ "Count after length/code in unpack" );
@@ -2395,7 +2407,7 @@
*/
void
-Perl_packlist(pTHX_ SV *cat, const char *pat, const char *patend, register SV **beglist, SV **endlist )
+Perl_packlist(pTHX_ SV *cat, const char *pat, const char *patend, SV **beglist, SV **endlist )
{
dVAR;
tempsym_t sym;
@@ -2455,7 +2467,8 @@
if (m != marks + sym_ptr->level+1) {
Safefree(marks);
Safefree(to_start);
- Perl_croak(aTHX_ "panic: marks beyond string end");
+ Perl_croak(aTHX_ "panic: marks beyond string end, m=%p, marks=%p, "
+ "level=%d", m, marks, sym_ptr->level);
}
for (group=sym_ptr; group; group = group->previous)
group->strbeg = marks[group->level] - to_start;
@@ -2557,18 +2570,7 @@
if (lookahead.howlen == e_number) count = lookahead.length;
else {
if (items > 0) {
- if (SvGAMAGIC(*beglist)) {
- /* Avoid reading the active data more than once
- by copying it to a temporary. */
- STRLEN len;
- const char *const pv = SvPV_const(*beglist, len);
- SV *const temp
- = newSVpvn_flags(pv, len,
- SVs_TEMP | SvUTF8(*beglist));
- *beglist = temp;
- }
- count = DO_UTF8(*beglist) ?
- sv_len_utf8(*beglist) : sv_len(*beglist);
+ count = sv_len_utf8(*beglist);
}
else count = 0;
if (lookahead.code == 'Z') count++;
@@ -2789,7 +2791,9 @@
GROWING(0, cat, start, cur, len);
if (!uni_to_bytes(aTHX_ &aptr, end, cur, fromlen,
datumtype | TYPE_IS_PACK))
- Perl_croak(aTHX_ "panic: predicted utf8 length not available");
+ Perl_croak(aTHX_ "panic: predicted utf8 length not available, "
+ "for '%c', aptr=%p end=%p cur=%p, fromlen=%"UVuf,
+ (int)datumtype, aptr, end, cur, (UV)fromlen);
cur += fromlen;
len -= fromlen;
} else if (utf8) {
@@ -3107,23 +3111,7 @@
NV anv;
fromstr = NEXTFROM;
anv = SvNV(fromstr);
-#ifdef __VOS__
- /* VOS does not automatically map a floating-point overflow
- during conversion from double to float into infinity, so we
- do it by hand. This code should either be generalized for
- any OS that needs it, or removed if and when VOS implements
- posix-976 (suggestion to support mapping to infinity).
- Paul.Green at stratus.com 02-04-02. */
-{
-extern const float _float_constants[];
- if (anv > FLT_MAX)
- afloat = _float_constants[0]; /* single prec. inf. */
- else if (anv < -FLT_MAX)
- afloat = _float_constants[0]; /* single prec. inf. */
- else afloat = (float) anv;
-}
-#else /* __VOS__ */
-# if defined(VMS) && !defined(__IEEE_FP)
+# if defined(VMS) && !defined(_IEEE_FP)
/* IEEE fp overflow shenanigans are unavailable on VAX and optional
* on Alpha; fake it if we don't have them.
*/
@@ -3135,7 +3123,6 @@
# else
afloat = (float)anv;
# endif
-#endif /* __VOS__ */
DO_BO_PACK_N(afloat, float);
PUSH_VAR(utf8, cur, afloat);
}
@@ -3146,23 +3133,7 @@
NV anv;
fromstr = NEXTFROM;
anv = SvNV(fromstr);
-#ifdef __VOS__
- /* VOS does not automatically map a floating-point overflow
- during conversion from long double to double into infinity,
- so we do it by hand. This code should either be generalized
- for any OS that needs it, or removed if and when VOS
- implements posix-976 (suggestion to support mapping to
- infinity). Paul.Green at stratus.com 02-04-02. */
-{
-extern const double _double_constants[];
- if (anv > DBL_MAX)
- adouble = _double_constants[0]; /* double prec. inf. */
- else if (anv < -DBL_MAX)
- adouble = _double_constants[0]; /* double prec. inf. */
- else adouble = (double) anv;
-}
-#else /* __VOS__ */
-# if defined(VMS) && !defined(__IEEE_FP)
+# if defined(VMS) && !defined(_IEEE_FP)
/* IEEE fp overflow shenanigans are unavailable on VAX and optional
* on Alpha; fake it if we don't have them.
*/
@@ -3174,7 +3145,6 @@
# else
adouble = (double)anv;
# endif
-#endif /* __VOS__ */
DO_BO_PACK_N(adouble, double);
PUSH_VAR(utf8, cur, adouble);
}
@@ -3566,7 +3536,7 @@
from_utf8 = DO_UTF8(fromstr);
if (from_utf8) {
aend = aptr + fromlen;
- fromlen = sv_len_utf8(fromstr);
+ fromlen = sv_len_utf8_nomg(fromstr);
} else aend = NULL; /* Unused, but keep compilers happy */
GROWING(utf8, cat, start, cur, (fromlen+2) / 3 * 4 + (fromlen+len-1)/len * 2);
while (fromlen > 0) {
@@ -3584,7 +3554,9 @@
'u' | TYPE_IS_PACK)) {
*cur = '\0';
SvCUR_set(cat, cur - start);
- Perl_croak(aTHX_ "panic: string is shorter than advertised");
+ Perl_croak(aTHX_ "panic: string is shorter than advertised, "
+ "aptr=%p, aend=%p, buffer=%p, todo=%ld",
+ aptr, aend, buffer, (long) todo);
}
end = doencodes(hunk, buffer, todo);
} else {
@@ -3610,11 +3582,11 @@
PP(pp_pack)
{
dVAR; dSP; dMARK; dORIGMARK; dTARGET;
- register SV *cat = TARG;
+ SV *cat = TARG;
STRLEN fromlen;
SV *pat_sv = *++MARK;
- register const char *pat = SvPV_const(pat_sv, fromlen);
- register const char *patend = pat + fromlen;
+ const char *pat = SvPV_const(pat_sv, fromlen);
+ const char *patend = pat + fromlen;
MARK++;
sv_setpvs(cat, "");
@@ -3632,8 +3604,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/pp_pack.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.4
\ No newline at end of property
Modified: trunk/contrib/perl/pp_proto.h
===================================================================
--- trunk/contrib/perl/pp_proto.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/pp_proto.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -27,7 +27,6 @@
PERL_CALLCONV OP *Perl_pp_bit_and(pTHX);
PERL_CALLCONV OP *Perl_pp_bit_or(pTHX);
PERL_CALLCONV OP *Perl_pp_bless(pTHX);
-PERL_CALLCONV OP *Perl_pp_boolkeys(pTHX);
PERL_CALLCONV OP *Perl_pp_break(pTHX);
PERL_CALLCONV OP *Perl_pp_caller(pTHX);
PERL_CALLCONV OP *Perl_pp_chdir(pTHX);
@@ -35,6 +34,7 @@
PERL_CALLCONV OP *Perl_pp_chown(pTHX);
PERL_CALLCONV OP *Perl_pp_chr(pTHX);
PERL_CALLCONV OP *Perl_pp_chroot(pTHX);
+PERL_CALLCONV OP *Perl_pp_clonecv(pTHX);
PERL_CALLCONV OP *Perl_pp_close(pTHX);
PERL_CALLCONV OP *Perl_pp_closedir(pTHX);
PERL_CALLCONV OP *Perl_pp_complement(pTHX);
@@ -42,6 +42,7 @@
PERL_CALLCONV OP *Perl_pp_cond_expr(pTHX);
PERL_CALLCONV OP *Perl_pp_const(pTHX);
PERL_CALLCONV OP *Perl_pp_continue(pTHX);
+PERL_CALLCONV OP *Perl_pp_coreargs(pTHX);
PERL_CALLCONV OP *Perl_pp_crypt(pTHX);
PERL_CALLCONV OP *Perl_pp_dbmopen(pTHX);
PERL_CALLCONV OP *Perl_pp_dbstate(pTHX);
@@ -65,6 +66,7 @@
PERL_CALLCONV OP *Perl_pp_exec(pTHX);
PERL_CALLCONV OP *Perl_pp_exists(pTHX);
PERL_CALLCONV OP *Perl_pp_exit(pTHX);
+PERL_CALLCONV OP *Perl_pp_fc(pTHX);
PERL_CALLCONV OP *Perl_pp_fileno(pTHX);
PERL_CALLCONV OP *Perl_pp_flip(pTHX);
PERL_CALLCONV OP *Perl_pp_flock(pTHX);
@@ -117,6 +119,7 @@
PERL_CALLCONV OP *Perl_pp_i_subtract(pTHX);
PERL_CALLCONV OP *Perl_pp_index(pTHX);
PERL_CALLCONV OP *Perl_pp_int(pTHX);
+PERL_CALLCONV OP *Perl_pp_introcv(pTHX);
PERL_CALLCONV OP *Perl_pp_ioctl(pTHX);
PERL_CALLCONV OP *Perl_pp_iter(pTHX);
PERL_CALLCONV OP *Perl_pp_join(pTHX);
@@ -162,14 +165,14 @@
PERL_CALLCONV OP *Perl_pp_ord(pTHX);
PERL_CALLCONV OP *Perl_pp_pack(pTHX);
PERL_CALLCONV OP *Perl_pp_padav(pTHX);
+PERL_CALLCONV OP *Perl_pp_padcv(pTHX);
PERL_CALLCONV OP *Perl_pp_padhv(pTHX);
+PERL_CALLCONV OP *Perl_pp_padrange(pTHX);
PERL_CALLCONV OP *Perl_pp_padsv(pTHX);
PERL_CALLCONV OP *Perl_pp_pipe_op(pTHX);
PERL_CALLCONV OP *Perl_pp_pos(pTHX);
-PERL_CALLCONV OP *Perl_pp_postdec(pTHX);
PERL_CALLCONV OP *Perl_pp_postinc(pTHX);
PERL_CALLCONV OP *Perl_pp_pow(pTHX);
-PERL_CALLCONV OP *Perl_pp_predec(pTHX);
PERL_CALLCONV OP *Perl_pp_preinc(pTHX);
PERL_CALLCONV OP *Perl_pp_print(pTHX);
PERL_CALLCONV OP *Perl_pp_prototype(pTHX);
@@ -200,6 +203,7 @@
PERL_CALLCONV OP *Perl_pp_right_shift(pTHX);
PERL_CALLCONV OP *Perl_pp_rkeys(pTHX);
PERL_CALLCONV OP *Perl_pp_rmdir(pTHX);
+PERL_CALLCONV OP *Perl_pp_runcv(pTHX);
PERL_CALLCONV OP *Perl_pp_rv2av(pTHX);
PERL_CALLCONV OP *Perl_pp_rv2cv(pTHX);
PERL_CALLCONV OP *Perl_pp_rv2gv(pTHX);
Property changes on: trunk/contrib/perl/pp_proto.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/pp_sort.c
===================================================================
--- trunk/contrib/perl/pp_sort.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/pp_sort.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -185,8 +185,8 @@
dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, const SVCOMPARE_t cmp)
{
I32 sense;
- register gptr *b, *p, *q, *t, *p2;
- register gptr *last, *r;
+ gptr *b, *p, *q, *t, *p2;
+ gptr *last, *r;
IV runs = 0;
b = list1;
@@ -354,7 +354,7 @@
dVAR;
IV i, run, offset;
I32 sense, level;
- register gptr *f1, *f2, *t, *b, *p;
+ gptr *f1, *f2, *t, *b, *p;
int iwhich;
gptr *aux;
gptr *p1;
@@ -392,7 +392,7 @@
list1 = which[iwhich]; /* area where runs are now */
list2 = which[++iwhich]; /* area for merged runs */
do {
- register gptr *l1, *l2, *tp2;
+ gptr *l1, *l2, *tp2;
offset = stackp->offset;
f1 = p1 = list1 + offset; /* start of first run */
p = tp2 = list2 + offset; /* where merged run will go */
@@ -422,7 +422,7 @@
** and -1 when equality should look high.
*/
- register gptr *q;
+ gptr *q;
if (cmp(aTHX_ *f1, *f2) <= 0) {
q = f2; b = f1; t = l1;
sense = -1;
@@ -763,7 +763,7 @@
STATIC void /* the standard unstable (u) quicksort (qsort) */
S_qsortsvu(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
{
- register SV * temp;
+ SV * temp;
struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
int next_stack_entry = 0;
int part_left;
@@ -783,10 +783,10 @@
/* Inoculate large partitions against quadratic behavior */
if (num_elts > QSORT_PLAY_SAFE) {
- register size_t n;
- register SV ** const q = array;
+ size_t n;
+ SV ** const q = array;
for (n = num_elts; n > 1; ) {
- register const size_t j = (size_t)(n-- * Drand01());
+ const size_t j = (size_t)(n-- * Drand01());
temp = q[j];
q[j] = q[n];
q[n] = temp;
@@ -1350,8 +1350,8 @@
{
dVAR;
if ((flags & SORTf_STABLE) != 0) {
- register gptr **pp, *q;
- register size_t n, j, i;
+ gptr **pp, *q;
+ size_t n, j, i;
gptr *small[SMALLSORT], **indir, tmp;
SVCOMPARE_t savecmp;
if (nmemb <= 1) return; /* sorted trivially */
@@ -1432,7 +1432,7 @@
Sort an array. Here is an example:
- sortsv(AvARRAY(av), av_len(av)+1, Perl_sv_cmp_locale);
+ sortsv(AvARRAY(av), av_top_index(av)+1, Perl_sv_cmp_locale);
Currently this always uses mergesort. See sortsv_flags for a more
flexible routine.
@@ -1473,8 +1473,8 @@
PP(pp_sort)
{
dVAR; dSP; dMARK; dORIGMARK;
- register SV **p1 = ORIGMARK+1, **p2;
- register I32 max, i;
+ SV **p1 = ORIGMARK+1, **p2;
+ I32 max, i;
AV* av = NULL;
HV *stash;
GV *gv;
@@ -1516,7 +1516,9 @@
stash = CopSTASH(PL_curcop);
}
else {
- cv = sv_2cv(*++MARK, &stash, &gv, 0);
+ GV *autogv = NULL;
+ cv = sv_2cv(*++MARK, &stash, &gv, GV_ADD);
+ check_cv:
if (cv && SvPOK(cv)) {
const char * const proto = SvPV_nolen_const(MUTABLE_SV(cv));
if (proto && strEQ(proto, "$$")) {
@@ -1523,15 +1525,31 @@
hasargs = TRUE;
}
}
- if (!(cv && CvROOT(cv))) {
- if (cv && CvISXSUB(cv)) {
- is_xsub = 1;
+ if (cv && CvISXSUB(cv) && CvXSUB(cv)) {
+ is_xsub = 1;
+ }
+ else if (!(cv && CvROOT(cv))) {
+ if (gv) {
+ goto autoload;
}
- else if (gv) {
+ else if (!CvANON(cv) && (gv = CvGV(cv))) {
+ if (cv != GvCV(gv)) cv = GvCV(gv);
+ autoload:
+ if (!autogv && (
+ autogv = gv_autoload_pvn(
+ GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
+ GvNAMEUTF8(gv) ? SVf_UTF8 : 0
+ )
+ )) {
+ cv = GvCVu(autogv);
+ goto check_cv;
+ }
+ else {
SV *tmpstr = sv_newmortal();
gv_efullname3(tmpstr, gv, NULL);
DIE(aTHX_ "Undefined sort subroutine \"%"SVf"\" called",
SVfARG(tmpstr));
+ }
}
else {
DIE(aTHX_ "Undefined subroutine in sort");
@@ -1568,7 +1586,7 @@
}
else {
if (SvREADONLY(av))
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
else
SvREADONLY_on(av);
p1 = p2 = AvARRAY(av);
@@ -1649,7 +1667,7 @@
if (CvDEPTH(cv)) SvREFCNT_inc_simple_void_NN(cv);
PUSHSUB(cx);
if (!is_xsub) {
- AV* const padlist = CvPADLIST(cv);
+ PADLIST * const padlist = CvPADLIST(cv);
if (++CvDEPTH(cv) >= 2) {
PERL_STACK_OVERFLOW_CHECK();
@@ -1745,7 +1763,10 @@
const I32 oldsaveix = PL_savestack_ix;
const I32 oldscopeix = PL_scopestack_ix;
I32 result;
+ SV *resultsv;
PMOP * const pm = PL_curpm;
+ OP * const sortop = PL_op;
+ COP * const cop = PL_curcop;
PERL_ARGS_ASSERT_SORTCV;
@@ -1754,9 +1775,21 @@
PL_stack_sp = PL_stack_base;
PL_op = PL_sortcop;
CALLRUNOPS(aTHX);
- if (PL_stack_sp != PL_stack_base + 1)
- Perl_croak(aTHX_ "Sort subroutine didn't return single value");
- result = SvIV(*PL_stack_sp);
+ PL_op = sortop;
+ PL_curcop = cop;
+ if (PL_stack_sp != PL_stack_base + 1) {
+ assert(PL_stack_sp == PL_stack_base);
+ resultsv = &PL_sv_undef;
+ }
+ else resultsv = *PL_stack_sp;
+ if (SvNIOK_nog(resultsv)) result = SvIV(resultsv);
+ else {
+ ENTER;
+ SAVEVPTR(PL_curpad);
+ PL_curpad = 0;
+ result = SvIV(resultsv);
+ LEAVE;
+ }
while (PL_scopestack_ix > oldscopeix) {
LEAVE;
}
@@ -1774,6 +1807,9 @@
I32 result;
AV * const av = GvAV(PL_defgv);
PMOP * const pm = PL_curpm;
+ OP * const sortop = PL_op;
+ COP * const cop = PL_curcop;
+ SV **pad;
PERL_ARGS_ASSERT_SORTCV_STACKED;
@@ -1802,9 +1838,15 @@
PL_stack_sp = PL_stack_base;
PL_op = PL_sortcop;
CALLRUNOPS(aTHX);
- if (PL_stack_sp != PL_stack_base + 1)
- Perl_croak(aTHX_ "Sort subroutine didn't return single value");
- result = SvIV(*PL_stack_sp);
+ PL_op = sortop;
+ PL_curcop = cop;
+ pad = PL_curpad; PL_curpad = 0;
+ if (PL_stack_sp != PL_stack_base + 1) {
+ assert(PL_stack_sp == PL_stack_base);
+ result = SvIV(&PL_sv_undef);
+ }
+ else result = SvIV(*PL_stack_sp);
+ PL_curpad = pad;
while (PL_scopestack_ix > oldscopeix) {
LEAVE;
}
@@ -1852,6 +1894,14 @@
PERL_ARGS_ASSERT_SV_NCMP;
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ if (Perl_isnan(nv1) || Perl_isnan(nv2)) {
+#else
+ if (nv1 != nv1 || nv2 != nv2) {
+#endif
+ if (ckWARN(WARN_UNINITIALIZED)) report_uninit(NULL);
+ return 0;
+ }
return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
}
@@ -1874,7 +1924,7 @@
#define SORT_NORMAL_RETURN_VALUE(val) (((val) > 0) ? 1 : ((val) ? -1 : 0))
static I32
-S_amagic_ncmp(pTHX_ register SV *const a, register SV *const b)
+S_amagic_ncmp(pTHX_ SV *const a, SV *const b)
{
dVAR;
SV * const tmpsv = tryCALL_AMAGICbin(a,b,ncmp_amg);
@@ -1895,7 +1945,7 @@
}
static I32
-S_amagic_i_ncmp(pTHX_ register SV *const a, register SV *const b)
+S_amagic_i_ncmp(pTHX_ SV *const a, SV *const b)
{
dVAR;
SV * const tmpsv = tryCALL_AMAGICbin(a,b,ncmp_amg);
@@ -1916,7 +1966,7 @@
}
static I32
-S_amagic_cmp(pTHX_ register SV *const str1, register SV *const str2)
+S_amagic_cmp(pTHX_ SV *const str1, SV *const str2)
{
dVAR;
SV * const tmpsv = tryCALL_AMAGICbin(str1,str2,scmp_amg);
@@ -1937,7 +1987,7 @@
}
static I32
-S_amagic_cmp_locale(pTHX_ register SV *const str1, register SV *const str2)
+S_amagic_cmp_locale(pTHX_ SV *const str1, SV *const str2)
{
dVAR;
SV * const tmpsv = tryCALL_AMAGICbin(str1,str2,scmp_amg);
@@ -1961,8 +2011,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/pp_sort.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/pp_sys.c
===================================================================
--- trunk/contrib/perl/pp_sys.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/pp_sys.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -49,10 +49,6 @@
# include <shadow.h>
#endif
-#ifdef I_SYS_WAIT
-# include <sys/wait.h>
-#endif
-
#ifdef I_SYS_RESOURCE
# include <sys/resource.h>
#endif
@@ -252,6 +248,7 @@
if (setresuid(euid, ruid, (Uid_t)-1))
#endif
#endif
+ /* diag_listed_as: entering effective %s failed */
Perl_croak(aTHX_ "entering effective uid failed");
#endif
@@ -265,6 +262,7 @@
if (setresgid(egid, rgid, (Gid_t)-1))
#endif
#endif
+ /* diag_listed_as: entering effective %s failed */
Perl_croak(aTHX_ "entering effective gid failed");
#endif
@@ -277,6 +275,7 @@
if (setresuid(ruid, euid, (Uid_t)-1))
#endif
#endif
+ /* diag_listed_as: leaving effective %s failed */
Perl_croak(aTHX_ "leaving effective uid failed");
#ifdef HAS_SETREGID
@@ -286,6 +285,7 @@
if (setresgid(rgid, egid, (Gid_t)-1))
#endif
#endif
+ /* diag_listed_as: leaving effective %s failed */
Perl_croak(aTHX_ "leaving effective gid failed");
return res;
@@ -359,22 +359,28 @@
dVAR;
OP *result;
dSP;
- /* make a copy of the pattern, to ensure that magic is called once
- * and only once */
- TOPm1s = sv_2mortal(newSVsv(TOPm1s));
+ GV * const gv = (PL_op->op_flags & OPf_SPECIAL) ? NULL : (GV *)POPs;
- tryAMAGICunTARGET(iter_amg, -1, (PL_op->op_flags & OPf_SPECIAL));
+ PUTBACK;
+ /* make a copy of the pattern if it is gmagical, to ensure that magic
+ * is called once and only once */
+ if (SvGMAGICAL(TOPs)) TOPs = sv_2mortal(newSVsv(TOPs));
+
+ tryAMAGICunTARGETlist(iter_amg, (PL_op->op_flags & OPf_SPECIAL));
+
if (PL_op->op_flags & OPf_SPECIAL) {
/* call Perl-level glob function instead. Stack args are:
- * MARK, wildcard, csh_glob context index
+ * MARK, wildcard
* and following OPs should be: gv(CORE::GLOBAL::glob), entersub
* */
return NORMAL;
}
- /* stack args are: wildcard, gv(_GEN_n) */
+ if (PL_globhook) {
+ PL_globhook(aTHX);
+ return NORMAL;
+ }
-
/* Note that we only ever get here if File::Glob fails to load
* without at the same time croaking, for some reason, or if
* perl was built with PERL_EXTERNAL_GLOB */
@@ -382,7 +388,7 @@
ENTER_with_name("glob");
#ifndef VMS
- if (PL_tainting) {
+ if (TAINTING_get) {
/*
* The external globbing program may use things we can't control,
* so for security reasons we must assume the worst.
@@ -393,7 +399,7 @@
#endif /* !VMS */
SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
- PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
+ PL_last_in_gv = gv;
SAVESPTR(PL_rs); /* This is not permanent, either. */
PL_rs = newSVpvs_flags("\000", SVs_TEMP);
@@ -419,7 +425,6 @@
{
dVAR; dSP; dMARK;
SV *exsv;
- const char *pv;
STRLEN len;
if (SP - MARK > 1) {
dTARGET;
@@ -434,20 +439,30 @@
}
else {
exsv = TOPs;
+ if (SvGMAGICAL(exsv)) exsv = sv_mortalcopy(exsv);
}
- if (SvROK(exsv) || (pv = SvPV_const(exsv, len), len)) {
+ if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
/* well-formed exception supplied */
}
- else if (SvROK(ERRSV)) {
- exsv = ERRSV;
- }
- else if (SvPOK(ERRSV) && SvCUR(ERRSV)) {
- exsv = sv_mortalcopy(ERRSV);
+ else {
+ SV * const errsv = ERRSV;
+ SvGETMAGIC(errsv);
+ if (SvROK(errsv)) {
+ if (SvGMAGICAL(errsv)) {
+ exsv = sv_newmortal();
+ sv_setsv_nomg(exsv, errsv);
+ }
+ else exsv = errsv;
+ }
+ else if (SvPOKp(errsv) ? SvCUR(errsv) : SvNIOKp(errsv)) {
+ exsv = sv_newmortal();
+ sv_setsv_nomg(exsv, errsv);
sv_catpvs(exsv, "\t...caught");
- }
- else {
+ }
+ else {
exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
+ }
}
if (SvROK(exsv) && !PL_warnhook)
Perl_warn(aTHX_ "%"SVf, SVfARG(exsv));
@@ -459,7 +474,6 @@
{
dVAR; dSP; dMARK;
SV *exsv;
- const char *pv;
STRLEN len;
#ifdef VMS
VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
@@ -474,36 +488,40 @@
exsv = TOPs;
}
- if (SvROK(exsv) || (pv = SvPV_const(exsv, len), len)) {
+ if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
/* well-formed exception supplied */
}
- else if (SvROK(ERRSV)) {
- exsv = ERRSV;
- if (sv_isobject(exsv)) {
- HV * const stash = SvSTASH(SvRV(exsv));
- GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
- if (gv) {
- SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
- SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
- EXTEND(SP, 3);
- PUSHMARK(SP);
- PUSHs(exsv);
- PUSHs(file);
- PUSHs(line);
- PUTBACK;
- call_sv(MUTABLE_SV(GvCV(gv)),
- G_SCALAR|G_EVAL|G_KEEPERR);
- exsv = sv_mortalcopy(*PL_stack_sp--);
+ else {
+ SV * const errsv = ERRSV;
+ SvGETMAGIC(errsv);
+ if (SvROK(errsv)) {
+ exsv = errsv;
+ if (sv_isobject(exsv)) {
+ HV * const stash = SvSTASH(SvRV(exsv));
+ GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
+ if (gv) {
+ SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
+ SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
+ EXTEND(SP, 3);
+ PUSHMARK(SP);
+ PUSHs(exsv);
+ PUSHs(file);
+ PUSHs(line);
+ PUTBACK;
+ call_sv(MUTABLE_SV(GvCV(gv)),
+ G_SCALAR|G_EVAL|G_KEEPERR);
+ exsv = sv_mortalcopy(*PL_stack_sp--);
+ }
}
}
+ else if (SvPOK(errsv) && SvCUR(errsv)) {
+ exsv = sv_mortalcopy(errsv);
+ sv_catpvs(exsv, "\t...propagated");
+ }
+ else {
+ exsv = newSVpvs_flags("Died", SVs_TEMP);
+ }
}
- else if (SvPOK(ERRSV) && SvCUR(ERRSV)) {
- exsv = sv_mortalcopy(ERRSV);
- sv_catpvs(exsv, "\t...propagated");
- }
- else {
- exsv = newSVpvs_flags("Died", SVs_TEMP);
- }
return die_sv(exsv);
}
@@ -513,6 +531,9 @@
Perl_tied_method(pTHX_ const char *const methname, SV **sp, SV *const sv,
const MAGIC *const mg, const U32 flags, U32 argc, ...)
{
+ SV **orig_sp = sp;
+ I32 ret_args;
+
PERL_ARGS_ASSERT_TIED_METHOD;
/* Ensure that our flag bits do not overlap. */
@@ -520,10 +541,15 @@
assert((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0);
assert((TIED_METHOD_SAY & G_WANT) == 0);
+ PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */
+ PUSHSTACKi(PERLSI_MAGIC);
+ EXTEND(SP, argc+1); /* object + args */
PUSHMARK(sp);
PUSHs(SvTIED_obj(sv, mg));
- if (flags & TIED_METHOD_ARGUMENTS_ON_STACK)
+ if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) {
+ Copy(orig_sp + 2, sp + 1, argc, SV*); /* copy args to new stack */
sp += argc;
+ }
else if (argc) {
const U32 mortalize_not_needed
= flags & TIED_METHOD_MORTALIZE_NOT_NEEDED;
@@ -546,7 +572,17 @@
SAVEGENERICSV(PL_ors_sv);
PL_ors_sv = newSVpvs("\n");
}
- call_method(methname, flags & G_WANT);
+ ret_args = call_method(methname, flags & G_WANT);
+ SPAGAIN;
+ orig_sp = sp;
+ POPSTACK;
+ SPAGAIN;
+ if (ret_args) { /* copy results back to original stack */
+ EXTEND(sp, ret_args);
+ Copy(orig_sp - ret_args + 1, sp + 1, ret_args, SV*);
+ sp += ret_args;
+ PUTBACK;
+ }
LEAVE_with_name("call_tied_method");
return NORMAL;
}
@@ -580,8 +616,8 @@
if (IoDIRP(io))
Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
- "Opening dirhandle %s also as a file",
- GvENAME(gv));
+ "Opening dirhandle %"HEKf" also as a file",
+ HEKfARG(GvENAME_HEK(gv)));
mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
@@ -615,7 +651,8 @@
PP(pp_close)
{
dVAR; dSP;
- GV * const gv = (MAXARG == 0) ? PL_defoutgv : MUTABLE_GV(POPs);
+ GV * const gv =
+ MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs);
if (MAXARG == 0)
EXTEND(SP, 1);
@@ -638,8 +675,8 @@
#ifdef HAS_PIPE
dVAR;
dSP;
- register IO *rstio;
- register IO *wstio;
+ IO *rstio;
+ IO *wstio;
int fd[2];
GV * const wgv = MUTABLE_GV(POPs);
@@ -732,7 +769,7 @@
dTARGET;
Mode_t anum;
- if (MAXARG < 1) {
+ if (MAXARG < 1 || (!TOPs && !POPs)) {
anum = PerlLIO_umask(022);
/* setting it to 022 between the two calls to umask avoids
* to have a window where the umask is set to 0 -- meaning
@@ -748,7 +785,7 @@
/* Only DIE if trying to restrict permissions on "user" (self).
* Otherwise it's harmless and more useful to just return undef
* since 'group' and 'other' concepts probably don't exist here. */
- if (MAXARG >= 1 && (POPi & 0700))
+ if (MAXARG >= 1 && (TOPs||POPs) && (POPi & 0700))
DIE(aTHX_ "umask not implemented");
XPUSHs(&PL_sv_undef);
#endif
@@ -830,19 +867,29 @@
switch(SvTYPE(varsv)) {
case SVt_PVHV:
+ {
+ HE *entry;
methname = "TIEHASH";
+ if (HvLAZYDEL(varsv) && (entry = HvEITER((HV *)varsv))) {
+ HvLAZYDEL_off(varsv);
+ hv_free_ent((HV *)varsv, entry);
+ }
HvEITER_set(MUTABLE_HV(varsv), 0);
break;
+ }
case SVt_PVAV:
methname = "TIEARRAY";
+ if (!AvREAL(varsv)) {
+ if (!AvREIFY(varsv))
+ Perl_croak(aTHX_ "Cannot tie unreifiable array");
+ av_clear((AV *)varsv);
+ AvREIFY_off(varsv);
+ AvREAL_on(varsv);
+ }
break;
case SVt_PVGV:
case SVt_PVLV:
- if (isGV_with_GP(varsv)) {
- if (SvFAKE(varsv) && !(GvFLAGS(varsv) & GVf_TIEWARNED)) {
- deprecate("tie on a handle without *");
- GvFLAGS(varsv) |= GVf_TIEWARNED;
- }
+ if (isGV_with_GP(varsv) && !SvFAKE(varsv)) {
methname = "TIEHANDLE";
how = PERL_MAGIC_tiedscalar;
/* For tied filehandles, we apply tiedscalar magic to the IO
@@ -875,10 +922,8 @@
* wrong error message, and worse case, supreme action at a distance.
* (Sorry obfuscation writers. You're not going to be given this one.)
*/
- STRLEN len;
- const char *name = SvPV_nomg_const(*MARK, len);
- stash = gv_stashpvn(name, len, 0);
- if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
+ stash = gv_stashsv(*MARK, 0);
+ if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
}
@@ -919,14 +964,8 @@
const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
- if (isGV_with_GP(sv)) {
- if (SvFAKE(sv) && !(GvFLAGS(sv) & GVf_TIEWARNED)) {
- deprecate("untie on a handle without *");
- GvFLAGS(sv) |= GVf_TIEWARNED;
- }
- if (!(sv = MUTABLE_SV(GvIOp(sv))))
+ if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
RETPUSHYES;
- }
if ((mg = SvTIED_mg(sv, how))) {
SV * const obj = SvRV(SvTIED_obj(sv, mg));
@@ -963,20 +1002,11 @@
const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
- if (isGV_with_GP(sv)) {
- if (SvFAKE(sv) && !(GvFLAGS(sv) & GVf_TIEWARNED)) {
- deprecate("tied on a handle without *");
- GvFLAGS(sv) |= GVf_TIEWARNED;
- }
- if (!(sv = MUTABLE_SV(GvIOp(sv))))
+ if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
RETPUSHUNDEF;
- }
if ((mg = SvTIED_mg(sv, how))) {
- SV *osv = SvTIED_obj(sv, mg);
- if (osv == mg->mg_obj)
- osv = sv_mortalcopy(osv);
- PUSHs(osv);
+ PUSHs(SvTIED_obj(sv, mg));
RETURN;
}
RETPUSHUNDEF;
@@ -1009,7 +1039,10 @@
if (SvIV(right))
mPUSHu(O_RDWR|O_CREAT);
else
+ {
mPUSHu(O_RDWR);
+ if (!SvOK(right)) right = &PL_sv_no;
+ }
PUSHs(right);
PUTBACK;
call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
@@ -1039,10 +1072,10 @@
{
#ifdef HAS_SELECT
dVAR; dSP; dTARGET;
- register I32 i;
- register I32 j;
- register char *s;
- register SV *sv;
+ I32 i;
+ I32 j;
+ char *s;
+ SV *sv;
NV value;
I32 maxlen = 0;
I32 nfound;
@@ -1066,17 +1099,18 @@
SP -= 4;
for (i = 1; i <= 3; i++) {
SV * const sv = SP[i];
+ SvGETMAGIC(sv);
if (!SvOK(sv))
continue;
- if (SvREADONLY(sv)) {
- if (SvIsCOW(sv))
+ if (SvIsCOW(sv))
sv_force_normal_flags(sv, 0);
- if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
- Perl_croak_no_modify(aTHX);
- }
+ if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
+ Perl_croak_no_modify();
if (!SvPOK(sv)) {
- Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
- SvPV_force_nolen(sv); /* force string conversion */
+ if (!SvPOKp(sv))
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
+ "Non-string passed as bitmask");
+ SvPV_force_nomg_nolen(sv); /* force string conversion */
}
j = SvCUR(sv);
if (maxlen < j)
@@ -1213,7 +1247,8 @@
Perl_setdefout(pTHX_ GV *gv)
{
dVAR;
- SvREFCNT_inc_simple_void(gv);
+ PERL_ARGS_ASSERT_SETDEFOUT;
+ SvREFCNT_inc_simple_void_NN(gv);
SvREFCNT_dec(PL_defoutgv);
PL_defoutgv = gv;
}
@@ -1224,21 +1259,20 @@
HV *hv;
GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
GV * egv = GvEGVx(PL_defoutgv);
+ GV * const *gvp;
if (!egv)
egv = PL_defoutgv;
hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
- if (! hv)
- XPUSHs(&PL_sv_undef);
- else {
- GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
- if (gvp && *gvp == egv) {
+ gvp = hv && HvENAME(hv)
+ ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE)
+ : NULL;
+ if (gvp && *gvp == egv) {
gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
XPUSHTARG;
- }
- else {
+ }
+ else {
mXPUSHs(newRV(MUTABLE_SV(egv)));
- }
}
if (newdefout) {
@@ -1253,7 +1287,8 @@
PP(pp_getc)
{
dVAR; dSP; dTARGET;
- GV * const gv = (MAXARG==0) ? PL_stdingv : MUTABLE_GV(POPs);
+ GV * const gv =
+ MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
IO *const io = GvIO(gv);
if (MAXARG == 0)
@@ -1298,7 +1333,7 @@
S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
{
dVAR;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
PERL_ARGS_ASSERT_DOFORM;
@@ -1311,8 +1346,12 @@
PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
PUSHFORMAT(cx, retop);
+ if (CvDEPTH(cv) >= 2) {
+ PERL_STACK_OVERFLOW_CHECK();
+ pad_push(CvPADLIST(cv), CvDEPTH(cv));
+ }
SAVECOMPPAD();
- PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
+ PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
setdefout(gv); /* locally select filehandle so $% et al work */
return CvSTART(cv);
@@ -1322,8 +1361,8 @@
{
dVAR;
dSP;
- register GV *gv;
- register IO *io;
+ GV *gv;
+ IO *io;
GV *fgv;
CV *cv = NULL;
SV *tmpsv = NULL;
@@ -1346,23 +1385,16 @@
else
fgv = gv;
- if (!fgv)
- goto not_a_format_reference;
+ assert(fgv);
cv = GvFORM(fgv);
if (!cv) {
- const char *name;
tmpsv = sv_newmortal();
gv_efullname4(tmpsv, fgv, NULL, FALSE);
- name = SvPV_nolen_const(tmpsv);
- if (name && *name)
- DIE(aTHX_ "Undefined format \"%s\" called", name);
-
- not_a_format_reference:
- DIE(aTHX_ "Not a format reference");
+ DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv));
}
IoFLAGS(io) &= ~IOf_DIDTOP;
- return doform(cv,gv,PL_op->op_next);
+ RETURNOP(doform(cv,gv,PL_op->op_next));
}
PP(pp_leavewrite)
@@ -1369,12 +1401,12 @@
{
dVAR; dSP;
GV * const gv = cxstack[cxstack_ix].blk_format.gv;
- register IO * const io = GvIOp(gv);
+ IO * const io = GvIOp(gv);
PerlIO *ofp;
PerlIO *fp;
SV **newsp;
I32 gimme;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
OP *retop;
if (!io || !(ofp = IoOFP(io)))
@@ -1395,7 +1427,8 @@
SV *topname;
if (!IoFMT_NAME(io))
IoFMT_NAME(io) = savepv(GvNAME(gv));
- topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
+ topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%"HEKf"_TOP",
+ HEKfARG(GvNAME_HEK(gv))));
topgv = gv_fetchsv(topname, 0, SVt_PVFM);
if ((topgv && GvFORM(topgv)) ||
!gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
@@ -1431,7 +1464,7 @@
}
}
if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
- do_print(PL_formfeed, ofp);
+ do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp);
IoLINES_LEFT(io) = IoPAGE_LEN(io);
IoPAGE(io)++;
PL_formtarget = PL_toptarget;
@@ -1442,13 +1475,8 @@
cv = GvFORM(fgv);
if (!cv) {
SV * const sv = sv_newmortal();
- const char *name;
gv_efullname4(sv, fgv, NULL, FALSE);
- name = SvPV_nolen_const(sv);
- if (name && *name)
- DIE(aTHX_ "Undefined top format \"%s\" called", name);
- else
- DIE(aTHX_ "Undefined top format called");
+ DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
}
return doform(cv, gv, PL_op);
}
@@ -1457,11 +1485,11 @@
POPBLOCK(cx,PL_curpm);
POPFORMAT(cx);
retop = cx->blk_sub.retop;
+ SP = newsp; /* ignore retval of formline */
LEAVE;
- fp = IoOFP(io);
- if (!fp) {
- if (IoIFP(io))
+ if (!io || !(fp = IoOFP(io))) {
+ if (io && IoIFP(io))
report_wrongway_fh(gv, '<');
else
report_evil_fh(gv);
@@ -1482,12 +1510,9 @@
PUSHs(&PL_sv_yes);
}
}
- /* bad_ofp: */
PL_formtarget = PL_bodytarget;
- PUTBACK;
- PERL_UNUSED_VAR(newsp);
PERL_UNUSED_VAR(gimme);
- return retop;
+ RETURNOP(retop);
}
PP(pp_prtf)
@@ -1494,12 +1519,14 @@
{
dVAR; dSP; dMARK; dORIGMARK;
PerlIO *fp;
- SV *sv;
GV * const gv
= (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
IO *const io = GvIO(gv);
+ /* Treat empty list as "" */
+ if (MARK == SP) XPUSHs(&PL_sv_no);
+
if (io) {
const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
@@ -1516,7 +1543,6 @@
}
}
- sv = newSV(0);
if (!io) {
report_evil_fh(gv);
SETERRNO(EBADF,RMS_IFI);
@@ -1531,6 +1557,7 @@
goto just_say_no;
}
else {
+ SV *sv = sv_newmortal();
do_sprintf(sv, SP - MARK, MARK + 1);
if (!do_print(sv, fp))
goto just_say_no;
@@ -1539,13 +1566,11 @@
if (PerlIO_flush(fp) == EOF)
goto just_say_no;
}
- SvREFCNT_dec(sv);
SP = ORIGMARK;
PUSHs(&PL_sv_yes);
RETURN;
just_say_no:
- SvREFCNT_dec(sv);
SP = ORIGMARK;
PUSHs(&PL_sv_undef);
RETURN;
@@ -1555,7 +1580,7 @@
{
dVAR;
dSP;
- const int perm = (MAXARG > 3) ? POPi : 0666;
+ const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
const int mode = POPi;
SV * const sv = POPs;
GV * const gv = MUTABLE_GV(POPs);
@@ -1577,12 +1602,12 @@
PP(pp_sysread)
{
dVAR; dSP; dMARK; dORIGMARK; dTARGET;
- int offset;
+ SSize_t offset;
IO *io;
char *buffer;
+ STRLEN orig_size;
SSize_t length;
SSize_t count;
- Sock_size_t bufsize;
SV *bufsv;
STRLEN blen;
int fp_utf8;
@@ -1612,6 +1637,8 @@
if (! SvOK(bufsv))
sv_setpvs(bufsv, "");
length = SvIVx(*++MARK);
+ if (length < 0)
+ DIE(aTHX_ "Negative length");
SETERRNO(0,0);
if (MARK < SP)
offset = SvIVx(*++MARK);
@@ -1633,18 +1660,20 @@
buffer = SvPV_force(bufsv, blen);
buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
}
- if (length < 0)
- DIE(aTHX_ "Negative length");
- wanted = length;
+ if (DO_UTF8(bufsv)) {
+ blen = sv_len_utf8_nomg(bufsv);
+ }
charstart = TRUE;
charskip = 0;
skip = 0;
+ wanted = length;
#ifdef HAS_SOCKET
if (PL_op->op_type == OP_RECV) {
+ Sock_size_t bufsize;
char namebuf[MAXPATHLEN];
-#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
+#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
bufsize = sizeof (struct sockaddr_in);
#else
bufsize = sizeof namebuf;
@@ -1662,10 +1691,6 @@
/* MSG_TRUNC can give oversized count; quietly lose it */
if (count > length)
count = length;
-#ifdef EPOC
- /* Bogus return without padding */
- bufsize = sizeof (struct sockaddr_in);
-#endif
SvCUR_set(bufsv, count);
*SvEND(bufsv) = '\0';
(void)SvPOK_only(bufsv);
@@ -1681,24 +1706,20 @@
RETURN;
}
#endif
- if (DO_UTF8(bufsv)) {
- /* offset adjust in characters not bytes */
- blen = sv_len_utf8(bufsv);
- }
if (offset < 0) {
- if (-offset > (int)blen)
+ if (-offset > (SSize_t)blen)
DIE(aTHX_ "Offset outside string");
offset += blen;
}
if (DO_UTF8(bufsv)) {
/* convert offset-as-chars to offset-as-bytes */
- if (offset >= (int)blen)
+ if (offset >= (SSize_t)blen)
offset += SvCUR(bufsv) - blen;
else
offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
}
more_bytes:
- bufsize = SvCUR(bufsv);
+ orig_size = SvCUR(bufsv);
/* Allocating length + offset + 1 isn't perfect in the case of reading
bytes from a byte file handle into a UTF8 buffer, but it won't harm us
unduly.
@@ -1705,8 +1726,8 @@
(should be 2 * length + offset + 1, or possibly something longer if
PL_encoding is true) */
buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
- if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */
- Zero(buffer+bufsize, offset-bufsize, char);
+ if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */
+ Zero(buffer+orig_size, offset-orig_size, char);
}
buffer = buffer + offset;
if (!buffer_utf8) {
@@ -1740,6 +1761,7 @@
else
#ifdef HAS_SOCKET__bad_code_maybe
if (IoTYPE(io) == IoTYPE_SOCKET) {
+ Sock_size_t bufsize;
char namebuf[MAXPATHLEN];
#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
bufsize = sizeof (struct sockaddr_in);
@@ -1916,15 +1938,9 @@
blen_chars = orig_blen_bytes;
} else {
/* The SV really is UTF-8. */
- if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
- /* Don't call sv_len_utf8 again because it will call magic
- or overloading a second time, and we might get back a
- different result. */
- blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
- } else {
- /* It's safe, and it may well be cached. */
- blen_chars = sv_len_utf8(bufsv);
- }
+ /* Don't call sv_len_utf8 on a magical or overloaded
+ scalar, as we might get back a different result. */
+ blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen);
}
} else {
blen_chars = blen;
@@ -2090,7 +2106,7 @@
GV *gv;
IO *io;
- if (MAXARG != 0)
+ if (MAXARG != 0 && (TOPs || POPs))
PL_last_in_gv = MUTABLE_GV(POPs);
else
EXTEND(SP, 1);
@@ -2186,14 +2202,14 @@
/* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
SETERRNO(0,0);
{
+ SV * const sv = POPs;
int result = 1;
GV *tmpgv;
IO *io;
- if (PL_op->op_flags & OPf_SPECIAL) {
- tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
-
- do_ftruncate_gv:
+ if (PL_op->op_flags & OPf_SPECIAL
+ ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
+ : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
io = GvIO(tmpgv);
if (!io)
result = 0;
@@ -2215,24 +2231,12 @@
}
}
}
- else {
- SV * const sv = POPs;
- const char *name;
-
- if (isGV_with_GP(sv)) {
- tmpgv = MUTABLE_GV(sv); /* *main::FRED for example */
- goto do_ftruncate_gv;
- }
- else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
- tmpgv = MUTABLE_GV(SvRV(sv)); /* \*main::FRED for example */
- goto do_ftruncate_gv;
- }
- else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
+ else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
goto do_ftruncate_io;
- }
-
- name = SvPV_nolen_const(sv);
+ }
+ else {
+ const char * const name = SvPV_nomg_const_nolen(sv);
TAINT_PROPER("truncate");
#ifdef HAS_TRUNCATE
if (truncate(name, len) < 0)
@@ -2340,7 +2344,7 @@
dVAR; dSP; dTARGET;
I32 value;
const int argtype = POPi;
- GV * const gv = (MAXARG == 0) ? PL_last_in_gv : MUTABLE_GV(POPs);
+ GV * const gv = MUTABLE_GV(POPs);
IO *const io = GvIO(gv);
PerlIO *const fp = io ? IoIFP(io) : NULL;
@@ -2372,7 +2376,7 @@
const int type = POPi;
const int domain = POPi;
GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = gv ? GvIOn(gv) : NULL;
+ IO * const io = gv ? GvIOn(gv) : NULL;
int fd;
if (!io) {
@@ -2403,10 +2407,6 @@
fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
#endif
-#ifdef EPOC
- setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
-#endif
-
RETPUSHYES;
}
#endif
@@ -2420,8 +2420,8 @@
const int domain = POPi;
GV * const gv2 = MUTABLE_GV(POPs);
GV * const gv1 = MUTABLE_GV(POPs);
- register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
- register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
+ IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
+ IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
int fd[2];
if (!io1)
@@ -2475,7 +2475,7 @@
/* OK, so on what platform does bind modify addr? */
const char *addr;
GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = GvIOn(gv);
+ IO * const io = GvIOn(gv);
STRLEN len;
const int op_type = PL_op->op_type;
@@ -2503,7 +2503,7 @@
dVAR; dSP;
const int backlog = POPi;
GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = gv ? GvIOn(gv) : NULL;
+ IO * const io = gv ? GvIOn(gv) : NULL;
if (!io || !IoIFP(io))
goto nuts;
@@ -2522,10 +2522,10 @@
PP(pp_accept)
{
dVAR; dSP; dTARGET;
- register IO *nstio;
- register IO *gstio;
+ IO *nstio;
+ IO *gstio;
char namebuf[MAXPATHLEN];
-#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
+#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
Sock_size_t len = sizeof (struct sockaddr_in);
#else
Sock_size_t len = sizeof namebuf;
@@ -2573,10 +2573,6 @@
fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
#endif
-#ifdef EPOC
- len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
- setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
-#endif
#ifdef __SCO_VERSION__
len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
#endif
@@ -2598,7 +2594,7 @@
dVAR; dSP; dTARGET;
const int how = POPi;
GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = GvIOn(gv);
+ IO * const io = GvIOn(gv);
if (!io || !IoIFP(io))
goto nuts;
@@ -2620,7 +2616,7 @@
const unsigned int optname = (unsigned int) POPi;
const unsigned int lvl = (unsigned int) POPi;
GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = GvIOn(gv);
+ IO * const io = GvIOn(gv);
int fd;
Sock_size_t len;
@@ -2689,7 +2685,7 @@
dVAR; dSP;
const int optype = PL_op->op_type;
GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = GvIOn(gv);
+ IO * const io = GvIOn(gv);
Sock_size_t len;
SV *sv;
int fd;
@@ -2751,59 +2747,60 @@
dVAR;
dSP;
GV *gv = NULL;
- IO *io;
+ IO *io = NULL;
I32 gimme;
I32 max = 13;
+ SV* sv;
- if (PL_op->op_flags & OPf_REF) {
- gv = cGVOP_gv;
+ if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
+ : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
if (PL_op->op_type == OP_LSTAT) {
if (gv != PL_defgv) {
do_fstat_warning_check:
Perl_ck_warner(aTHX_ packWARN(WARN_IO),
- "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
+ "lstat() on filehandle%s%"SVf,
+ gv ? " " : "",
+ SVfARG(gv
+ ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
+ : &PL_sv_no));
} else if (PL_laststype != OP_LSTAT)
+ /* diag_listed_as: The stat preceding %s wasn't an lstat */
Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
}
- do_fstat:
if (gv != PL_defgv) {
+ bool havefp;
+ do_fstat_have_io:
+ havefp = FALSE;
PL_laststype = OP_STAT;
- PL_statgv = gv;
+ PL_statgv = gv ? gv : (GV *)io;
sv_setpvs(PL_statname, "");
if(gv) {
io = GvIO(gv);
- do_fstat_have_io:
- if (io) {
+ }
+ if (io) {
if (IoIFP(io)) {
PL_laststatval =
PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
+ havefp = TRUE;
} else if (IoDIRP(io)) {
PL_laststatval =
PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
+ havefp = TRUE;
} else {
PL_laststatval = -1;
}
- }
}
+ else PL_laststatval = -1;
+ if (PL_laststatval < 0 && !havefp) report_evil_fh(gv);
}
if (PL_laststatval < 0) {
- report_evil_fh(gv);
max = 0;
}
}
else {
- SV* const sv = POPs;
- if (isGV_with_GP(sv)) {
- gv = MUTABLE_GV(sv);
- goto do_fstat;
- } else if(SvROK(sv) && isGV_with_GP(SvRV(sv))) {
- gv = MUTABLE_GV(SvRV(sv));
- if (PL_op->op_type == OP_LSTAT)
- goto do_fstat_warning_check;
- goto do_fstat;
- } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
+ if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
io = MUTABLE_IO(SvRV(sv));
if (PL_op->op_type == OP_LSTAT)
goto do_fstat_warning_check;
@@ -2810,7 +2807,8 @@
goto do_fstat_have_io;
}
- sv_setpv(PL_statname, SvPV_nolen_const(sv));
+ SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
+ sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
PL_statgv = NULL;
PL_laststype = PL_op->op_type;
if (PL_op->op_type == OP_LSTAT)
@@ -2834,7 +2832,15 @@
EXTEND(SP, max);
EXTEND_MORTAL(max);
mPUSHi(PL_statcache.st_dev);
+#if ST_INO_SIZE > IVSIZE
+ mPUSHn(PL_statcache.st_ino);
+#else
+# if ST_INO_SIGN <= 0
mPUSHi(PL_statcache.st_ino);
+# else
+ mPUSHu(PL_statcache.st_ino);
+# endif
+#endif
mPUSHu(PL_statcache.st_mode);
mPUSHu(PL_statcache.st_nlink);
#if Uid_t_size > IVSIZE
@@ -2885,62 +2891,85 @@
RETURN;
}
+/* All filetest ops avoid manipulating the perl stack pointer in their main
+ bodies (since commit d2c4d2d1e22d3125), and return using either
+ S_ft_return_false() or S_ft_return_true(). These two helper functions are
+ the only two which manipulate the perl stack. To ensure that no stack
+ manipulation macros are used, the filetest ops avoid defining a local copy
+ of the stack pointer with dSP. */
+
+/* If the next filetest is stacked up with this one
+ (PL_op->op_private & OPpFT_STACKING), we leave
+ the original argument on the stack for success,
+ and skip the stacked operators on failure.
+ The next few macros/functions take care of this.
+*/
+
+static OP *
+S_ft_return_false(pTHX_ SV *ret) {
+ OP *next = NORMAL;
+ dSP;
+
+ if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
+ else SETs(ret);
+ PUTBACK;
+
+ if (PL_op->op_private & OPpFT_STACKING) {
+ while (OP_IS_FILETEST(next->op_type)
+ && next->op_private & OPpFT_STACKED)
+ next = next->op_next;
+ }
+ return next;
+}
+
+PERL_STATIC_INLINE OP *
+S_ft_return_true(pTHX_ SV *ret) {
+ dSP;
+ if (PL_op->op_flags & OPf_REF)
+ XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
+ else if (!(PL_op->op_private & OPpFT_STACKING))
+ SETs(ret);
+ PUTBACK;
+ return NORMAL;
+}
+
+#define FT_RETURNNO return S_ft_return_false(aTHX_ &PL_sv_no)
+#define FT_RETURNUNDEF return S_ft_return_false(aTHX_ &PL_sv_undef)
+#define FT_RETURNYES return S_ft_return_true(aTHX_ &PL_sv_yes)
+
#define tryAMAGICftest_MG(chr) STMT_START { \
- if ( (SvFLAGS(TOPs) & (SVf_ROK|SVs_GMG)) \
- && S_try_amagic_ftest(aTHX_ chr)) \
- return NORMAL; \
+ if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
+ && PL_op->op_flags & OPf_KIDS) { \
+ OP *next = S_try_amagic_ftest(aTHX_ chr); \
+ if (next) return next; \
+ } \
} STMT_END
-STATIC bool
+STATIC OP *
S_try_amagic_ftest(pTHX_ char chr) {
dVAR;
- dSP;
- SV* const arg = TOPs;
+ SV *const arg = *PL_stack_sp;
assert(chr != '?');
- SvGETMAGIC(arg);
+ if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
- if ((PL_op->op_flags & OPf_KIDS)
- && SvAMAGIC(TOPs))
+ if (SvAMAGIC(arg))
{
const char tmpchr = chr;
- const OP *next;
SV * const tmpsv = amagic_call(arg,
newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
ftest_amg, AMGf_unary);
if (!tmpsv)
- return FALSE;
+ return NULL;
- SPAGAIN;
-
- next = PL_op->op_next;
- if (next->op_type >= OP_FTRREAD &&
- next->op_type <= OP_FTBINARY &&
- next->op_private & OPpFT_STACKED
- ) {
- if (SvTRUE(tmpsv))
- /* leave the object alone */
- return TRUE;
- }
-
- SETs(tmpsv);
- PUTBACK;
- return TRUE;
+ return SvTRUE(tmpsv)
+ ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
}
- return FALSE;
+ return NULL;
}
-/* This macro is used by the stacked filetest operators :
- * if the previous filetest failed, short-circuit and pass its value.
- * Else, discard it from the stack and continue. --rgs
- */
-#define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
- if (!SvTRUE(TOPs)) { RETURN; } \
- else { (void)POPs; PUTBACK; } \
- }
-
PP(pp_ftrread)
{
dVAR;
@@ -2964,7 +2993,6 @@
bool effective = FALSE;
char opchar = '?';
- dSP;
switch (PL_op->op_type) {
case OP_FTRREAD: opchar = 'R'; break;
@@ -2976,8 +3004,6 @@
}
tryAMAGICftest_MG(opchar);
- STACKED_FTEST_CHECK;
-
switch (PL_op->op_type) {
case OP_FTRREAD:
#if !(defined(HAS_ACCESS) && defined(R_OK))
@@ -3030,7 +3056,7 @@
if (use_access) {
#if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
- const char *name = POPpx;
+ const char *name = SvPV_nolen(*PL_stack_sp);
if (effective) {
# ifdef PERL_EFF_ACCESS
result = PERL_EFF_ACCESS(name, access_mode);
@@ -3047,20 +3073,19 @@
# endif
}
if (result == 0)
- RETPUSHYES;
+ FT_RETURNYES;
if (result < 0)
- RETPUSHUNDEF;
- RETPUSHNO;
+ FT_RETURNUNDEF;
+ FT_RETURNNO;
#endif
}
result = my_stat_flags(0);
- SPAGAIN;
if (result < 0)
- RETPUSHUNDEF;
+ FT_RETURNUNDEF;
if (cando(stat_mode, effective, &PL_statcache))
- RETPUSHYES;
- RETPUSHNO;
+ FT_RETURNYES;
+ FT_RETURNNO;
}
PP(pp_ftis)
@@ -3069,7 +3094,6 @@
I32 result;
const int op_type = PL_op->op_type;
char opchar = '?';
- dSP;
switch (op_type) {
case OP_FTIS: opchar = 'e'; break;
@@ -3080,14 +3104,11 @@
}
tryAMAGICftest_MG(opchar);
- STACKED_FTEST_CHECK;
-
result = my_stat_flags(0);
- SPAGAIN;
if (result < 0)
- RETPUSHUNDEF;
+ FT_RETURNUNDEF;
if (op_type == OP_FTIS)
- RETPUSHYES;
+ FT_RETURNYES;
{
/* You can't dTARGET inside OP_FTIS, because you'll get
"panic: pad_sv po" - the op is not flagged to have a target. */
@@ -3095,23 +3116,28 @@
switch (op_type) {
case OP_FTSIZE:
#if Off_t_size > IVSIZE
- PUSHn(PL_statcache.st_size);
+ sv_setnv(TARG, (NV)PL_statcache.st_size);
#else
- PUSHi(PL_statcache.st_size);
+ sv_setiv(TARG, (IV)PL_statcache.st_size);
#endif
break;
case OP_FTMTIME:
- PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
+ sv_setnv(TARG,
+ ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
break;
case OP_FTATIME:
- PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
+ sv_setnv(TARG,
+ ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
break;
case OP_FTCTIME:
- PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
+ sv_setnv(TARG,
+ ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
break;
}
+ SvSETMAGIC(TARG);
+ return SvTRUE_nomg(TARG)
+ ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
}
- RETURN;
}
PP(pp_ftrowned)
@@ -3119,7 +3145,6 @@
dVAR;
I32 result;
char opchar = '?';
- dSP;
switch (PL_op->op_type) {
case OP_FTROWNED: opchar = 'O'; break;
@@ -3137,215 +3162,185 @@
}
tryAMAGICftest_MG(opchar);
- STACKED_FTEST_CHECK;
-
/* I believe that all these three are likely to be defined on most every
system these days. */
#ifndef S_ISUID
if(PL_op->op_type == OP_FTSUID) {
- if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
- (void) POPs;
- RETPUSHNO;
+ FT_RETURNNO;
}
#endif
#ifndef S_ISGID
if(PL_op->op_type == OP_FTSGID) {
- if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
- (void) POPs;
- RETPUSHNO;
+ FT_RETURNNO;
}
#endif
#ifndef S_ISVTX
if(PL_op->op_type == OP_FTSVTX) {
- if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
- (void) POPs;
- RETPUSHNO;
+ FT_RETURNNO;
}
#endif
result = my_stat_flags(0);
- SPAGAIN;
if (result < 0)
- RETPUSHUNDEF;
+ FT_RETURNUNDEF;
switch (PL_op->op_type) {
case OP_FTROWNED:
- if (PL_statcache.st_uid == PL_uid)
- RETPUSHYES;
+ if (PL_statcache.st_uid == PerlProc_getuid())
+ FT_RETURNYES;
break;
case OP_FTEOWNED:
- if (PL_statcache.st_uid == PL_euid)
- RETPUSHYES;
+ if (PL_statcache.st_uid == PerlProc_geteuid())
+ FT_RETURNYES;
break;
case OP_FTZERO:
if (PL_statcache.st_size == 0)
- RETPUSHYES;
+ FT_RETURNYES;
break;
case OP_FTSOCK:
if (S_ISSOCK(PL_statcache.st_mode))
- RETPUSHYES;
+ FT_RETURNYES;
break;
case OP_FTCHR:
if (S_ISCHR(PL_statcache.st_mode))
- RETPUSHYES;
+ FT_RETURNYES;
break;
case OP_FTBLK:
if (S_ISBLK(PL_statcache.st_mode))
- RETPUSHYES;
+ FT_RETURNYES;
break;
case OP_FTFILE:
if (S_ISREG(PL_statcache.st_mode))
- RETPUSHYES;
+ FT_RETURNYES;
break;
case OP_FTDIR:
if (S_ISDIR(PL_statcache.st_mode))
- RETPUSHYES;
+ FT_RETURNYES;
break;
case OP_FTPIPE:
if (S_ISFIFO(PL_statcache.st_mode))
- RETPUSHYES;
+ FT_RETURNYES;
break;
#ifdef S_ISUID
case OP_FTSUID:
if (PL_statcache.st_mode & S_ISUID)
- RETPUSHYES;
+ FT_RETURNYES;
break;
#endif
#ifdef S_ISGID
case OP_FTSGID:
if (PL_statcache.st_mode & S_ISGID)
- RETPUSHYES;
+ FT_RETURNYES;
break;
#endif
#ifdef S_ISVTX
case OP_FTSVTX:
if (PL_statcache.st_mode & S_ISVTX)
- RETPUSHYES;
+ FT_RETURNYES;
break;
#endif
}
- RETPUSHNO;
+ FT_RETURNNO;
}
PP(pp_ftlink)
{
dVAR;
- dSP;
I32 result;
tryAMAGICftest_MG('l');
result = my_lstat_flags(0);
- SPAGAIN;
if (result < 0)
- RETPUSHUNDEF;
+ FT_RETURNUNDEF;
if (S_ISLNK(PL_statcache.st_mode))
- RETPUSHYES;
- RETPUSHNO;
+ FT_RETURNYES;
+ FT_RETURNNO;
}
PP(pp_fttty)
{
dVAR;
- dSP;
int fd;
GV *gv;
- SV *tmpsv = NULL;
char *name = NULL;
STRLEN namelen;
tryAMAGICftest_MG('t');
- STACKED_FTEST_CHECK;
-
if (PL_op->op_flags & OPf_REF)
gv = cGVOP_gv;
- else if (isGV_with_GP(TOPs))
- gv = MUTABLE_GV(POPs);
- else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
- gv = MUTABLE_GV(SvRV(POPs));
else {
- tmpsv = POPs;
+ SV *tmpsv = *PL_stack_sp;
+ if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
name = SvPV_nomg(tmpsv, namelen);
gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
+ }
}
if (GvIO(gv) && IoIFP(GvIOp(gv)))
fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
- else if (tmpsv && SvOK(tmpsv)) {
- if (isDIGIT(*name))
+ else if (name && isDIGIT(*name))
fd = atoi(name);
- else
- RETPUSHUNDEF;
- }
else
- RETPUSHUNDEF;
+ FT_RETURNUNDEF;
if (PerlLIO_isatty(fd))
- RETPUSHYES;
- RETPUSHNO;
+ FT_RETURNYES;
+ FT_RETURNNO;
}
-#if defined(atarist) /* this will work with atariST. Configure will
- make guesses for other systems. */
-# define FILE_base(f) ((f)->_base)
-# define FILE_ptr(f) ((f)->_ptr)
-# define FILE_cnt(f) ((f)->_cnt)
-# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
-#endif
-
PP(pp_fttext)
{
dVAR;
- dSP;
I32 i;
I32 len;
I32 odd = 0;
STDCHAR tbuf[512];
- register STDCHAR *s;
- register IO *io;
- register SV *sv;
+ STDCHAR *s;
+ IO *io;
+ SV *sv = NULL;
GV *gv;
PerlIO *fp;
tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
- STACKED_FTEST_CHECK;
-
if (PL_op->op_flags & OPf_REF)
gv = cGVOP_gv;
- else if (isGV_with_GP(TOPs))
- gv = MUTABLE_GV(POPs);
- else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
- gv = MUTABLE_GV(SvRV(POPs));
- else
- gv = NULL;
+ else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
+ == OPpFT_STACKED)
+ gv = PL_defgv;
+ else {
+ sv = *PL_stack_sp;
+ gv = MAYBE_DEREF_GV_nomg(sv);
+ }
if (gv) {
- EXTEND(SP, 1);
if (gv == PL_defgv) {
if (PL_statgv)
- io = GvIO(PL_statgv);
+ io = SvTYPE(PL_statgv) == SVt_PVIO
+ ? (IO *)PL_statgv
+ : GvIO(PL_statgv);
else {
- sv = PL_statname;
goto really_filename;
}
}
else {
PL_statgv = gv;
- PL_laststatval = -1;
sv_setpvs(PL_statname, "");
io = GvIO(PL_statgv);
}
+ PL_laststatval = -1;
+ PL_laststype = OP_STAT;
if (io && IoIFP(io)) {
if (! PerlIO_has_base(IoIFP(io)))
DIE(aTHX_ "-T and -B not implemented on filehandles");
PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
if (PL_laststatval < 0)
- RETPUSHUNDEF;
+ FT_RETURNUNDEF;
if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
if (PL_op->op_type == OP_FTTEXT)
- RETPUSHNO;
+ FT_RETURNNO;
else
- RETPUSHYES;
+ FT_RETURNYES;
}
if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
i = PerlIO_getc(IoIFP(io));
@@ -3353,7 +3348,7 @@
(void)PerlIO_ungetc(IoIFP(io),i);
}
if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
- RETPUSHYES;
+ FT_RETURNYES;
len = PerlIO_get_bufsiz(IoIFP(io));
s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
/* sfio can have large buffers - limit to 512 */
@@ -3361,27 +3356,31 @@
len = 512;
}
else {
- report_evil_fh(cGVOP_gv);
SETERRNO(EBADF,RMS_IFI);
- RETPUSHUNDEF;
+ report_evil_fh(gv);
+ SETERRNO(EBADF,RMS_IFI);
+ FT_RETURNUNDEF;
}
}
else {
- sv = POPs;
+ sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
really_filename:
PL_statgv = NULL;
- PL_laststype = OP_STAT;
- sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
+ if (!gv) {
+ PL_laststatval = -1;
+ PL_laststype = OP_STAT;
+ }
if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
'\n'))
Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
- RETPUSHUNDEF;
+ FT_RETURNUNDEF;
}
+ PL_laststype = OP_STAT;
PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
if (PL_laststatval < 0) {
(void)PerlIO_close(fp);
- RETPUSHUNDEF;
+ FT_RETURNUNDEF;
}
PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
len = PerlIO_read(fp, tbuf, sizeof(tbuf));
@@ -3388,8 +3387,8 @@
(void)PerlIO_close(fp);
if (len <= 0) {
if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
- RETPUSHNO; /* special case NFS directories */
- RETPUSHYES; /* null file is anything */
+ FT_RETURNNO; /* special case NFS directories */
+ FT_RETURNYES; /* null file is anything */
}
s = tbuf;
}
@@ -3443,9 +3442,9 @@
}
if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
- RETPUSHNO;
+ FT_RETURNNO;
else
- RETPUSHYES;
+ FT_RETURNYES;
}
/* File calls. */
@@ -3461,15 +3460,8 @@
if (PL_op->op_flags & OPf_SPECIAL) {
gv = gv_fetchsv(sv, 0, SVt_PVIO);
}
- else if (isGV_with_GP(sv)) {
- gv = MUTABLE_GV(sv);
- }
- else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
- gv = MUTABLE_GV(SvRV(sv));
- }
- else {
- tmps = SvPV_nolen_const(sv);
- }
+ else if (!(gv = MAYBE_DEREF_GV(sv)))
+ tmps = SvPV_nomg_const_nolen(sv);
}
if( !gv && (!tmps || !*tmps) ) {
@@ -3566,7 +3558,7 @@
if (same_dirent(tmps2, tmps)) /* can always rename to same name */
anum = 1;
else {
- if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
+ if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
(void)UNLINK(tmps2);
if (!(anum = link(tmps, tmps2)))
anum = UNLINK(tmps);
@@ -3768,7 +3760,7 @@
STRLEN len;
const char *tmps;
bool copy = FALSE;
- const int mode = (MAXARG > 1) ? POPi : 0777;
+ const int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPi : 0777;
TRIMSLASHES(tmps,len,copy);
@@ -3816,7 +3808,7 @@
dVAR; dSP;
const char * const dirname = POPpconstx;
GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = GvIOn(gv);
+ IO * const io = GvIOn(gv);
if (!io)
goto nope;
@@ -3823,8 +3815,8 @@
if ((IoIFP(io) || IoOFP(io)))
Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
- "Opening filehandle %s also as a directory",
- GvENAME(gv));
+ "Opening filehandle %"HEKf" also as a directory",
+ HEKfARG(GvENAME_HEK(gv)) );
if (IoDIRP(io))
PerlDir_close(IoDIRP(io));
if (!(IoDIRP(io) = PerlDir_open(dirname)))
@@ -3854,12 +3846,13 @@
SV *sv;
const I32 gimme = GIMME;
GV * const gv = MUTABLE_GV(POPs);
- register const Direntry_t *dp;
- register IO * const io = GvIOn(gv);
+ const Direntry_t *dp;
+ IO * const io = GvIOn(gv);
if (!io || !IoDIRP(io)) {
Perl_ck_warner(aTHX_ packWARN(WARN_IO),
- "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
+ "readdir() attempted on invalid dirhandle %"HEKf,
+ HEKfARG(GvENAME_HEK(gv)));
goto nope;
}
@@ -3906,11 +3899,12 @@
long telldir (DIR *);
# endif
GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = GvIOn(gv);
+ IO * const io = GvIOn(gv);
if (!io || !IoDIRP(io)) {
Perl_ck_warner(aTHX_ packWARN(WARN_IO),
- "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
+ "telldir() attempted on invalid dirhandle %"HEKf,
+ HEKfARG(GvENAME_HEK(gv)));
goto nope;
}
@@ -3931,11 +3925,12 @@
dVAR; dSP;
const long along = POPl;
GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = GvIOn(gv);
+ IO * const io = GvIOn(gv);
if (!io || !IoDIRP(io)) {
Perl_ck_warner(aTHX_ packWARN(WARN_IO),
- "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
+ "seekdir() attempted on invalid dirhandle %"HEKf,
+ HEKfARG(GvENAME_HEK(gv)));
goto nope;
}
(void)PerlDir_seek(IoDIRP(io), along);
@@ -3955,11 +3950,12 @@
#if defined(HAS_REWINDDIR) || defined(rewinddir)
dVAR; dSP;
GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = GvIOn(gv);
+ IO * const io = GvIOn(gv);
if (!io || !IoDIRP(io)) {
Perl_ck_warner(aTHX_ packWARN(WARN_IO),
- "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
+ "rewinddir() attempted on invalid dirhandle %"HEKf,
+ HEKfARG(GvENAME_HEK(gv)));
goto nope;
}
(void)PerlDir_rewind(IoDIRP(io));
@@ -3978,11 +3974,12 @@
#if defined(Direntry_t) && defined(HAS_READDIR)
dVAR; dSP;
GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = GvIOn(gv);
+ IO * const io = GvIOn(gv);
if (!io || !IoDIRP(io)) {
Perl_ck_warner(aTHX_ packWARN(WARN_IO),
- "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
+ "closedir() attempted on invalid dirhandle %"HEKf,
+ HEKfARG(GvENAME_HEK(gv)));
goto nope;
}
#ifdef VOID_CLOSEDIR
@@ -4012,22 +4009,34 @@
#ifdef HAS_FORK
dVAR; dSP; dTARGET;
Pid_t childpid;
+#if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
+ sigset_t oldmask, newmask;
+#endif
EXTEND(SP, 1);
PERL_FLUSHALL_FOR_CHILD;
+#if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
+ sigfillset(&newmask);
+ sigprocmask(SIG_SETMASK, &newmask, &oldmask);
+#endif
childpid = PerlProc_fork();
+ if (childpid == 0) {
+ int sig;
+ PL_sig_pending = 0;
+ if (PL_psig_pend)
+ for (sig = 1; sig < SIG_SIZE; sig++)
+ PL_psig_pend[sig] = 0;
+ }
+#if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
+ {
+ dSAVE_ERRNO;
+ sigprocmask(SIG_SETMASK, &oldmask, NULL);
+ RESTORE_ERRNO;
+ }
+#endif
if (childpid < 0)
- RETSETUNDEF;
+ RETPUSHUNDEF;
if (!childpid) {
- GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
- if (tmpgv) {
- SvREADONLY_off(GvSV(tmpgv));
- sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
- SvREADONLY_on(GvSV(tmpgv));
- }
-#ifdef THREADS_HAVE_PIDS
- PL_ppid = (IV)getppid();
-#endif
#ifdef PERL_USES_PL_PIDSTATUS
hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
#endif
@@ -4043,7 +4052,7 @@
PERL_FLUSHALL_FOR_CHILD;
childpid = PerlProc_fork();
if (childpid == -1)
- RETSETUNDEF;
+ RETPUSHUNDEF;
PUSHi(childpid);
RETURN;
# else
@@ -4121,11 +4130,11 @@
I32 value;
int result;
- if (PL_tainting) {
+ if (TAINTING_get) {
TAINT_ENV();
while (++MARK <= SP) {
(void)SvPV_nolen_const(*MARK); /* stringify for taint check */
- if (PL_tainted)
+ if (TAINT_get)
break;
}
MARK = ORIGMARK;
@@ -4137,9 +4146,17 @@
Pid_t childpid;
int pp[2];
I32 did_pipes = 0;
+#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
+ sigset_t newset, oldset;
+#endif
if (PerlProc_pipe(pp) >= 0)
did_pipes = 1;
+#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
+ sigemptyset(&newset);
+ sigaddset(&newset, SIGCHLD);
+ sigprocmask(SIG_BLOCK, &newset, &oldset);
+#endif
while ((childpid = PerlProc_fork()) == -1) {
if (errno != EAGAIN) {
value = -1;
@@ -4149,6 +4166,9 @@
PerlLIO_close(pp[0]);
PerlLIO_close(pp[1]);
}
+#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
+ sigprocmask(SIG_SETMASK, &oldset, NULL);
+#endif
RETURN;
}
sleep(5);
@@ -4167,6 +4187,9 @@
result = wait4pid(childpid, &status, 0);
} while (result == -1 && errno == EINTR);
#ifndef PERL_MICRO
+#ifdef HAS_SIGPROCMASK
+ sigprocmask(SIG_SETMASK, &oldset, NULL);
+#endif
(void)rsignal_restore(SIGINT, &ihand);
(void)rsignal_restore(SIGQUIT, &qhand);
#endif
@@ -4189,7 +4212,7 @@
PerlLIO_close(pp[0]);
if (n) { /* Error */
if (n != sizeof(int))
- DIE(aTHX_ "panic: kid popen errno read");
+ DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
errno = errkid; /* Propagate errno from kid */
STATUS_NATIVE_CHILD_SET(-1);
}
@@ -4197,6 +4220,9 @@
XPUSHi(STATUS_CURRENT);
RETURN;
}
+#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
+ sigprocmask(SIG_SETMASK, &oldset, NULL);
+#endif
if (did_pipes) {
PerlLIO_close(pp[0]);
#if defined(HAS_FCNTL) && defined(F_SETFD)
@@ -4251,11 +4277,11 @@
dVAR; dSP; dMARK; dORIGMARK; dTARGET;
I32 value;
- if (PL_tainting) {
+ if (TAINTING_get) {
TAINT_ENV();
while (++MARK <= SP) {
(void)SvPV_nolen_const(*MARK); /* stringify for taint check */
- if (PL_tainted)
+ if (TAINT_get)
break;
}
MARK = ORIGMARK;
@@ -4270,25 +4296,13 @@
#ifdef VMS
value = (I32)vms_do_aexec(NULL, MARK, SP);
#else
-# ifdef __OPEN_VM
- {
- (void ) do_aspawn(NULL, MARK, SP);
- value = 0;
- }
-# else
value = (I32)do_aexec(NULL, MARK, SP);
-# endif
#endif
else {
#ifdef VMS
value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
#else
-# ifdef __OPEN_VM
- (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
- value = 0;
-# else
value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
-# endif
#endif
}
@@ -4301,14 +4315,7 @@
{
#ifdef HAS_GETPPID
dVAR; dSP; dTARGET;
-# ifdef THREADS_HAVE_PIDS
- if (PL_ppid != 1 && getppid() == 1)
- /* maybe the parent process has died. Refresh ppid cache */
- PL_ppid = 1;
- XPUSHi( PL_ppid );
-# else
XPUSHi( getppid() );
-# endif
RETURN;
#else
DIE(aTHX_ PL_no_func, "getppid");
@@ -4320,7 +4327,8 @@
#ifdef HAS_GETPGRP
dVAR; dSP; dTARGET;
Pid_t pgrp;
- const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
+ const Pid_t pid =
+ (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
#ifdef BSD_GETPGRP
pgrp = (I32)BSD_GETPGRP(pid);
@@ -4342,15 +4350,12 @@
dVAR; dSP; dTARGET;
Pid_t pgrp;
Pid_t pid;
- if (MAXARG < 2) {
- pgrp = 0;
+ pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
+ if (MAXARG > 0) pid = TOPs && TOPi;
+ else {
pid = 0;
XPUSHi(-1);
}
- else {
- pgrp = POPi;
- pid = TOPi;
- }
TAINT_PROPER("setpgrp");
#ifdef BSD_SETPGRP
@@ -4479,7 +4484,7 @@
{"Jan", "Feb", "Mar", "Apr", "May", "Jun",
"Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
- if (MAXARG < 1) {
+ if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
time_t now;
(void)time(&now);
when = (Time64_T)now;
@@ -4488,6 +4493,7 @@
NV input = Perl_floor(POPn);
when = (Time64_T)input;
if (when != input) {
+ /* diag_listed_as: gmtime(%f) too large */
Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
"%s(%.0" NVff ") too large", opname, input);
}
@@ -4494,11 +4500,13 @@
}
if ( TIME_LOWER_BOUND > when ) {
+ /* diag_listed_as: gmtime(%f) too small */
Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
"%s(%.0" NVff ") too small", opname, when);
err = NULL;
}
else if( when > TIME_UPPER_BOUND ) {
+ /* diag_listed_as: gmtime(%f) too small */
Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
"%s(%.0" NVff ") too large", opname, when);
err = NULL;
@@ -4579,7 +4587,7 @@
Time_t when;
(void)time(&lasttime);
- if (MAXARG < 1)
+ if (MAXARG < 1 || (!TOPs && !POPs))
PerlProc_pause();
else {
duration = POPi;
@@ -4690,8 +4698,8 @@
#if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
dVAR; dSP;
I32 which = PL_op->op_type;
- register char **elem;
- register SV *sv;
+ char **elem;
+ SV *sv;
#ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
struct hostent *gethostbyname(Netdb_name_t);
@@ -4780,7 +4788,7 @@
#if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
dVAR; dSP;
I32 which = PL_op->op_type;
- register SV *sv;
+ SV *sv;
#ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
struct netent *getnetbyaddr(Netdb_net_t, int);
struct netent *getnetbyname(Netdb_name_t);
@@ -4853,7 +4861,7 @@
#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
dVAR; dSP;
I32 which = PL_op->op_type;
- register SV *sv;
+ SV *sv;
#ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
struct protoent *getprotobyname(Netdb_name_t);
struct protoent *getprotobynumber(int);
@@ -4913,7 +4921,7 @@
#if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
dVAR; dSP;
I32 which = PL_op->op_type;
- register SV *sv;
+ SV *sv;
#ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
struct servent *getservbyport(int, Netdb_name_t);
@@ -5090,7 +5098,7 @@
#ifdef HAS_PASSWD
dVAR; dSP;
I32 which = PL_op->op_type;
- register SV *sv;
+ SV *sv;
struct passwd *pwent = NULL;
/*
* We currently support only the SysV getsp* shadow password interface.
@@ -5414,12 +5422,12 @@
{
#ifdef HAS_SYSCALL
dVAR; dSP; dMARK; dORIGMARK; dTARGET;
- register I32 items = SP - MARK;
+ I32 items = SP - MARK;
unsigned long a[20];
- register I32 i = 0;
- I32 retval = -1;
+ I32 i = 0;
+ IV retval = -1;
- if (PL_tainting) {
+ if (TAINTING_get) {
while (++MARK <= SP) {
if (SvTAINTED(*MARK)) {
TAINT;
@@ -5473,30 +5481,6 @@
case 8:
retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
break;
-#ifdef atarist
- case 9:
- retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
- break;
- case 10:
- retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
- break;
- case 11:
- retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
- a[10]);
- break;
- case 12:
- retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
- a[10],a[11]);
- break;
- case 13:
- retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
- a[10],a[11],a[12]);
- break;
- case 14:
- retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
- a[10],a[11],a[12],a[13]);
- break;
-#endif /* atarist */
}
SP = ORIGMARK;
PUSHi(retval);
@@ -5631,8 +5615,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/pp_sys.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.4
\ No newline at end of property
Modified: trunk/contrib/perl/proto.h
===================================================================
--- trunk/contrib/perl/proto.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/proto.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -23,38 +23,81 @@
assert(stash)
PERL_CALLCONV const char * Perl_PerlIO_context_layers(pTHX_ const char *mode);
-PERL_CALLCONV void Perl__append_range_to_invlist(pTHX_ HV* const invlist, const UV start, const UV end)
+PERL_CALLCONV_NO_RET void Perl_croak_memory_wrap(void)
+ __attribute__noreturn__;
+
+PERL_CALLCONV void* Perl_Slab_Alloc(pTHX_ size_t sz)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV void Perl_Slab_Free(pTHX_ void *op)
__attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST \
- assert(invlist)
+#define PERL_ARGS_ASSERT_SLAB_FREE \
+ assert(op)
-PERL_CALLCONV HV* Perl__new_invlist(pTHX_ IV initial_size)
+PERL_CALLCONV bool Perl__is_uni_FOO(pTHX_ const U8 classnum, const UV c)
__attribute__warn_unused_result__;
-PERL_CALLCONV HV* Perl__swash_inversion_hash(pTHX_ SV* const swash)
+PERL_CALLCONV bool Perl__is_uni_perl_idcont(pTHX_ UV c)
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV bool Perl__is_uni_perl_idstart(pTHX_ UV c)
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV bool Perl__is_utf8_FOO(pTHX_ const U8 classnum, const U8 *p)
__attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT__IS_UTF8_FOO \
+ assert(p)
+
+PERL_CALLCONV bool Perl__is_utf8_mark(pTHX_ const U8 *p)
+ __attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT__SWASH_INVERSION_HASH \
- assert(swash)
+#define PERL_ARGS_ASSERT__IS_UTF8_MARK \
+ assert(p)
-PERL_CALLCONV HV* Perl__swash_to_invlist(pTHX_ SV* const swash)
+PERL_CALLCONV bool Perl__is_utf8_perl_idcont(pTHX_ const U8 *p)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT__SWASH_TO_INVLIST \
- assert(swash)
+#define PERL_ARGS_ASSERT__IS_UTF8_PERL_IDCONT \
+ assert(p)
-PERL_CALLCONV UV Perl__to_uni_fold_flags(pTHX_ UV c, U8 *p, STRLEN *lenp, U8 flags)
+PERL_CALLCONV bool Perl__is_utf8_perl_idstart(pTHX_ const U8 *p)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT__IS_UTF8_PERL_IDSTART \
+ assert(p)
+
+PERL_CALLCONV UV Perl__to_uni_fold_flags(pTHX_ UV c, U8 *p, STRLEN *lenp, const U8 flags)
__attribute__nonnull__(pTHX_2)
__attribute__nonnull__(pTHX_3);
#define PERL_ARGS_ASSERT__TO_UNI_FOLD_FLAGS \
assert(p); assert(lenp)
-PERL_CALLCONV UV Perl__to_utf8_fold_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, U8 flags)
+PERL_CALLCONV UV Perl__to_utf8_fold_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, U8 flags, bool* tainted_ptr)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
#define PERL_ARGS_ASSERT__TO_UTF8_FOLD_FLAGS \
assert(p); assert(ustrp)
+PERL_CALLCONV UV Perl__to_utf8_lower_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, const bool flags, bool* tainted_ptr)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT__TO_UTF8_LOWER_FLAGS \
+ assert(p); assert(ustrp)
+
+PERL_CALLCONV UV Perl__to_utf8_title_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, const bool flags, bool* tainted_ptr)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT__TO_UTF8_TITLE_FLAGS \
+ assert(p); assert(ustrp)
+
+PERL_CALLCONV UV Perl__to_utf8_upper_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, const bool flags, bool* tainted_ptr)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT__TO_UTF8_UPPER_FLAGS \
+ assert(p); assert(ustrp)
+
PERL_CALLCONV PADOFFSET Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_ALLOCMY \
@@ -71,6 +114,7 @@
#define PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL \
assert(ref)
+PERL_CALLCONV bool Perl_amagic_is_enabled(pTHX_ int method);
PERL_CALLCONV I32 Perl_apply(pTHX_ I32 type, SV** mark, SV** sp)
__attribute__nonnull__(pTHX_2)
__attribute__nonnull__(pTHX_3);
@@ -124,6 +168,13 @@
#define PERL_ARGS_ASSERT_AV_EXTEND \
assert(av)
+PERL_CALLCONV void Perl_av_extend_guts(pTHX_ AV *av, I32 key, SSize_t *maxp, SV ***allocp, SV ***arrayp)
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_4)
+ __attribute__nonnull__(pTHX_5);
+#define PERL_ARGS_ASSERT_AV_EXTEND_GUTS \
+ assert(maxp); assert(allocp); assert(arrayp)
+
PERL_CALLCONV SV** Perl_av_fetch(pTHX_ AV *av, I32 key, I32 lval)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
@@ -179,6 +230,16 @@
#define PERL_ARGS_ASSERT_AV_STORE \
assert(av)
+/* PERL_CALLCONV I32 Perl_av_tindex(pTHX_ AV *av)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1); */
+
+PERL_STATIC_INLINE I32 S_av_top_index(pTHX_ AV *av)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_AV_TOP_INDEX \
+ assert(av)
+
PERL_CALLCONV void Perl_av_undef(pTHX_ AV *av)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_AV_UNDEF \
@@ -298,10 +359,10 @@
#define PERL_ARGS_ASSERT_CK_BITOP \
assert(o)
-PERL_CALLCONV OP * Perl_ck_chdir(pTHX_ OP *o)
+PERL_CALLCONV OP * Perl_ck_cmp(pTHX_ OP *o)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_CK_CHDIR \
+#define PERL_ARGS_ASSERT_CK_CMP \
assert(o)
PERL_CALLCONV OP * Perl_ck_concat(pTHX_ OP *o)
@@ -334,6 +395,13 @@
#define PERL_ARGS_ASSERT_CK_EACH \
assert(o)
+PERL_CALLCONV OP* Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE \
+ assert(entersubop); assert(namegv); assert(protosv)
+
PERL_CALLCONV OP* Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST \
@@ -419,6 +487,12 @@
#define PERL_ARGS_ASSERT_CK_JOIN \
assert(o)
+PERL_CALLCONV OP * Perl_ck_length(pTHX_ OP *o)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CK_LENGTH \
+ assert(o)
+
PERL_CALLCONV OP * Perl_ck_lfun(pTHX_ OP *o)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
@@ -551,16 +625,16 @@
#define PERL_ARGS_ASSERT_CK_SVCONST \
assert(o)
-PERL_CALLCONV OP * Perl_ck_trunc(pTHX_ OP *o)
+PERL_CALLCONV OP * Perl_ck_tell(pTHX_ OP *o)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_CK_TRUNC \
+#define PERL_ARGS_ASSERT_CK_TELL \
assert(o)
-PERL_CALLCONV OP * Perl_ck_unpack(pTHX_ OP *o)
+PERL_CALLCONV OP * Perl_ck_trunc(pTHX_ OP *o)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_CK_UNPACK \
+#define PERL_ARGS_ASSERT_CK_TRUNC \
assert(o)
PERL_CALLCONV void Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
@@ -580,27 +654,55 @@
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(cop)
+
+PERL_CALLCONV void Perl_cop_store_label(pTHX_ COP *const cop, const char *label, STRLEN len, U32 flags)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_COP_STORE_LABEL \
+ assert(cop); assert(label)
+
+PERL_CALLCONV SV * Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code, int * const opnum)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_CORE_PROTOTYPE \
+ assert(name)
+
+PERL_CALLCONV OP * Perl_coresub_op(pTHX_ SV *const coreargssv, const int code, const int opnum)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CORESUB_OP \
+ assert(coreargssv)
+
PERL_CALLCONV PERL_CONTEXT* Perl_create_eval_scope(pTHX_ U32 flags);
-PERL_CALLCONV void Perl_croak(pTHX_ const char* pat, ...)
+PERL_CALLCONV_NO_RET void Perl_croak(pTHX_ const char* pat, ...)
__attribute__noreturn__
__attribute__format__null_ok__(__printf__,pTHX_1,pTHX_2);
-PERL_CALLCONV void Perl_croak_no_modify(pTHX)
+PERL_CALLCONV_NO_RET void Perl_croak_no_mem(void)
__attribute__noreturn__;
-PERL_CALLCONV void Perl_croak_sv(pTHX_ SV *baseex)
+PERL_CALLCONV_NO_RET void Perl_croak_no_modify(void)
+ __attribute__noreturn__;
+
+PERL_CALLCONV_NO_RET void Perl_croak_popstack(void)
+ __attribute__noreturn__;
+
+PERL_CALLCONV_NO_RET void Perl_croak_sv(pTHX_ SV *baseex)
__attribute__noreturn__
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_CROAK_SV \
assert(baseex)
-PERL_CALLCONV void Perl_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
+PERL_CALLCONV_NO_RET void Perl_croak_xs_usage(const CV *const cv, const char *const params)
__attribute__noreturn__
- __attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_2);
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2);
#define PERL_ARGS_ASSERT_CROAK_XS_USAGE \
assert(cv); assert(params)
+PERL_CALLCONV regexp_engine const * Perl_current_re_engine(pTHX);
PERL_CALLCONV const char * Perl_custom_op_desc(pTHX_ const OP *o)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
@@ -625,9 +727,9 @@
#define PERL_ARGS_ASSERT_CUSTOM_OP_XOP \
assert(o)
-PERL_CALLCONV void Perl_cv_ckproto_len(pTHX_ const CV* cv, const GV* gv, const char* p, const STRLEN len)
+PERL_CALLCONV void Perl_cv_ckproto_len_flags(pTHX_ const CV* cv, const GV* gv, const char* p, const STRLEN len, const U32 flags)
__attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_CV_CKPROTO_LEN \
+#define PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS \
assert(cv)
PERL_CALLCONV CV* Perl_cv_clone(pTHX_ CV* proto)
@@ -635,9 +737,20 @@
#define PERL_ARGS_ASSERT_CV_CLONE \
assert(proto)
+PERL_CALLCONV CV* Perl_cv_clone_into(pTHX_ CV* proto, CV *target)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_CV_CLONE_INTO \
+ assert(proto); assert(target)
+
PERL_CALLCONV SV* Perl_cv_const_sv(pTHX_ const CV *const cv)
__attribute__warn_unused_result__;
+PERL_CALLCONV void Perl_cv_forget_slab(pTHX_ CV *cv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CV_FORGET_SLAB \
+ assert(cv)
+
PERL_CALLCONV void Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2)
@@ -709,7 +822,7 @@
#define PERL_ARGS_ASSERT_DIE_SV \
assert(baseex)
-PERL_CALLCONV void Perl_die_unwind(pTHX_ SV* msv)
+PERL_CALLCONV_NO_RET void Perl_die_unwind(pTHX_ SV* msv)
__attribute__noreturn__
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_DIE_UNWIND \
@@ -776,6 +889,13 @@
#define PERL_ARGS_ASSERT_DO_MAGIC_DUMP \
assert(file); assert(mg)
+PERL_CALLCONV I32 Perl_do_ncmp(pTHX_ SV *const left, SV *const right)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_DO_NCMP \
+ assert(left); assert(right)
+
PERL_CALLCONV void Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
__attribute__nonnull__(pTHX_2);
#define PERL_ARGS_ASSERT_DO_OP_DUMP \
@@ -841,7 +961,7 @@
#define PERL_ARGS_ASSERT_DO_TRANS \
assert(sv)
-PERL_CALLCONV UV Perl_do_vecget(pTHX_ SV* sv, I32 offset, I32 size)
+PERL_CALLCONV UV Perl_do_vecget(pTHX_ SV* sv, SSize_t offset, int size)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_DO_VECGET \
assert(sv)
@@ -950,11 +1070,6 @@
#define PERL_ARGS_ASSERT_FEATURE_IS_ENABLED \
assert(name)
-PERL_CALLCONV const char * Perl_fetch_cop_label(pTHX_ COP *const cop, STRLEN *len, U32 *flags)
- __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_FETCH_COP_LABEL \
- assert(cop)
-
PERL_CALLCONV SV* Perl_filter_add(pTHX_ filter_t funcp, SV* datasv);
PERL_CALLCONV void Perl_filter_del(pTHX_ filter_t funcp)
__attribute__nonnull__(pTHX_1);
@@ -967,10 +1082,24 @@
#define PERL_ARGS_ASSERT_FILTER_READ \
assert(buf_sv)
+PERL_CALLCONV void Perl_finalize_optree(pTHX_ OP* o)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_FINALIZE_OPTREE \
+ assert(o)
+
+PERL_CALLCONV CV * Perl_find_lexical_cv(pTHX_ PADOFFSET off);
PERL_CALLCONV CV* Perl_find_runcv(pTHX_ U32 *db_seqp)
__attribute__warn_unused_result__;
+PERL_CALLCONV CV* Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
+ __attribute__warn_unused_result__;
+
PERL_CALLCONV SV* Perl_find_rundefsv(pTHX);
+PERL_CALLCONV SV* Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_FIND_RUNDEFSV2 \
+ assert(cv)
+
PERL_CALLCONV PADOFFSET Perl_find_rundefsvoffset(pTHX)
__attribute__deprecated__;
@@ -1041,8 +1170,10 @@
#define PERL_ARGS_ASSERT_GET_DB_SUB \
assert(cv)
-PERL_CALLCONV UV Perl_get_hash_seed(pTHX)
- __attribute__warn_unused_result__;
+PERL_CALLCONV void Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GET_HASH_SEED \
+ assert(seed_buffer)
PERL_CALLCONV HV* Perl_get_hv(pTHX_ const char *name, I32 flags)
__attribute__nonnull__(pTHX_1);
@@ -1122,12 +1253,28 @@
/* PERL_CALLCONV GV* Perl_gv_HVadd(pTHX_ GV *gv); */
/* PERL_CALLCONV GV* Perl_gv_IOadd(pTHX_ GV* gv); */
PERL_CALLCONV GV* Perl_gv_add_by_type(pTHX_ GV *gv, svtype type);
-PERL_CALLCONV GV* Perl_gv_autoload4(pTHX_ HV* stash, const char* name, STRLEN len, I32 method)
+/* PERL_CALLCONV GV* gv_autoload4(pTHX_ HV* stash, const char* name, STRLEN len, I32 method)
__attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_2); */
+
+PERL_CALLCONV GV* Perl_gv_autoload_pv(pTHX_ HV* stash, const char* namepv, U32 flags)
+ __attribute__warn_unused_result__
__attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_GV_AUTOLOAD4 \
+#define PERL_ARGS_ASSERT_GV_AUTOLOAD_PV \
+ assert(namepv)
+
+PERL_CALLCONV GV* Perl_gv_autoload_pvn(pTHX_ HV* stash, const char* name, STRLEN len, U32 flags)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN \
assert(name)
+PERL_CALLCONV GV* Perl_gv_autoload_sv(pTHX_ HV* stash, SV* namesv, U32 flags)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GV_AUTOLOAD_SV \
+ assert(namesv)
+
PERL_CALLCONV void Perl_gv_check(pTHX_ const HV* stash)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_GV_CHECK \
@@ -1172,16 +1319,42 @@
#define PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS \
assert(name)
-PERL_CALLCONV GV* Perl_gv_fetchmeth(pTHX_ HV* stash, const char* name, STRLEN len, I32 level)
+/* PERL_CALLCONV GV* gv_fetchmeth(pTHX_ HV* stash, const char* name, STRLEN len, I32 level)
+ __attribute__nonnull__(pTHX_2); */
+
+/* PERL_CALLCONV GV* gv_fetchmeth_autoload(pTHX_ HV* stash, const char* name, STRLEN len, I32 level)
+ __attribute__nonnull__(pTHX_2); */
+
+PERL_CALLCONV GV* Perl_gv_fetchmeth_pv(pTHX_ HV* stash, const char* name, I32 level, U32 flags)
__attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_GV_FETCHMETH \
+#define PERL_ARGS_ASSERT_GV_FETCHMETH_PV \
assert(name)
-PERL_CALLCONV GV* Perl_gv_fetchmeth_autoload(pTHX_ HV* stash, const char* name, STRLEN len, I32 level)
+PERL_CALLCONV GV* Perl_gv_fetchmeth_pv_autoload(pTHX_ HV* stash, const char* name, I32 level, U32 flags)
__attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_GV_FETCHMETH_AUTOLOAD \
+#define PERL_ARGS_ASSERT_GV_FETCHMETH_PV_AUTOLOAD \
assert(name)
+PERL_CALLCONV GV* Perl_gv_fetchmeth_pvn(pTHX_ HV* stash, const char* name, STRLEN len, I32 level, U32 flags)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GV_FETCHMETH_PVN \
+ assert(name)
+
+PERL_CALLCONV GV* Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV* stash, const char* name, STRLEN len, I32 level, U32 flags)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD \
+ assert(name)
+
+PERL_CALLCONV GV* Perl_gv_fetchmeth_sv(pTHX_ HV* stash, SV* namesv, I32 level, U32 flags)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GV_FETCHMETH_SV \
+ assert(namesv)
+
+PERL_CALLCONV GV* Perl_gv_fetchmeth_sv_autoload(pTHX_ HV* stash, SV* namesv, I32 level, U32 flags)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GV_FETCHMETH_SV_AUTOLOAD \
+ assert(namesv)
+
/* PERL_CALLCONV GV* Perl_gv_fetchmethod(pTHX_ HV* stash, const char* name)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2); */
@@ -1194,12 +1367,24 @@
#define PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD \
assert(stash); assert(name)
-PERL_CALLCONV GV* Perl_gv_fetchmethod_flags(pTHX_ HV* stash, const char* name, U32 flags)
+PERL_CALLCONV GV* Perl_gv_fetchmethod_pv_flags(pTHX_ HV* stash, const char* name, U32 flags)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_GV_FETCHMETHOD_FLAGS \
+#define PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS \
assert(stash); assert(name)
+PERL_CALLCONV GV* Perl_gv_fetchmethod_pvn_flags(pTHX_ HV* stash, const char* name, const STRLEN len, U32 flags)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS \
+ assert(stash); assert(name)
+
+PERL_CALLCONV GV* Perl_gv_fetchmethod_sv_flags(pTHX_ HV* stash, SV* namesv, U32 flags)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GV_FETCHMETHOD_SV_FLAGS \
+ assert(stash); assert(namesv)
+
PERL_CALLCONV GV* Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_GV_FETCHPV \
@@ -1236,12 +1421,28 @@
PERL_CALLCONV CV* Perl_gv_handler(pTHX_ HV* stash, I32 id)
__attribute__warn_unused_result__;
-PERL_CALLCONV void Perl_gv_init(pTHX_ GV* gv, HV* stash, const char* name, STRLEN len, int multi)
+/* PERL_CALLCONV void gv_init(pTHX_ GV* gv, HV* stash, const char* name, STRLEN len, int multi)
__attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_3); */
+
+PERL_CALLCONV void Perl_gv_init_pv(pTHX_ GV* gv, HV* stash, const char* name, U32 flags)
+ __attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_3);
-#define PERL_ARGS_ASSERT_GV_INIT \
+#define PERL_ARGS_ASSERT_GV_INIT_PV \
assert(gv); assert(name)
+PERL_CALLCONV void Perl_gv_init_pvn(pTHX_ GV* gv, HV* stash, const char* name, STRLEN len, U32 flags)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_GV_INIT_PVN \
+ assert(gv); assert(name)
+
+PERL_CALLCONV void Perl_gv_init_sv(pTHX_ GV* gv, HV* stash, SV* namesv, U32 flags)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_GV_INIT_SV \
+ assert(gv); assert(namesv)
+
PERL_CALLCONV void Perl_gv_name_set(pTHX_ GV* gv, const char *name, U32 len, U32 flags)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
@@ -1353,7 +1554,7 @@
#define PERL_ARGS_ASSERT_HV_FILL \
assert(hv)
-PERL_CALLCONV void Perl_hv_free_ent(pTHX_ HV *hv, HE *entryK)
+PERL_CALLCONV void Perl_hv_free_ent(pTHX_ HV *hv, HE *entry)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_HV_FREE_ENT \
assert(hv)
@@ -1435,6 +1636,11 @@
#define PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET \
assert(hv)
+PERL_CALLCONV void Perl_hv_rand_set(pTHX_ HV *hv, U32 new_xhv_rand)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_HV_RAND_SET \
+ assert(hv)
+
PERL_CALLCONV I32* Perl_hv_riter_p(pTHX_ HV *hv)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
@@ -1474,6 +1680,7 @@
#define PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS \
assert(argv)
+PERL_CALLCONV void Perl_init_constants(pTHX);
PERL_CALLCONV void Perl_init_dbargs(pTHX);
PERL_CALLCONV void Perl_init_debugger(pTHX);
PERL_CALLCONV int Perl_init_i18nl10n(pTHX_ int printwarn);
@@ -1501,208 +1708,229 @@
#define PERL_ARGS_ASSERT_IO_CLOSE \
assert(io)
+PERL_STATIC_INLINE bool S_isALNUM_lazy(pTHX_ const char* p)
+ __attribute__deprecated__
+ __attribute__warn_unused_result__
+ __attribute__pure__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_ISALNUM_LAZY \
+ assert(p)
+
+PERL_STATIC_INLINE bool S_isIDFIRST_lazy(pTHX_ const char* p)
+ __attribute__deprecated__
+ __attribute__warn_unused_result__
+ __attribute__pure__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_ISIDFIRST_LAZY \
+ assert(p)
+
PERL_CALLCONV bool Perl_is_ascii_string(const U8 *s, STRLEN len)
__attribute__nonnull__(1);
#define PERL_ARGS_ASSERT_IS_ASCII_STRING \
assert(s)
-PERL_CALLCONV bool Perl_is_gv_magical_sv(pTHX_ SV *const name_sv, U32 flags)
- __attribute__warn_unused_result__
- __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_IS_GV_MAGICAL_SV \
- assert(name_sv)
-
PERL_CALLCONV I32 Perl_is_lvalue_sub(pTHX)
__attribute__warn_unused_result__;
PERL_CALLCONV bool Perl_is_uni_alnum(pTHX_ UV c)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__pure__;
PERL_CALLCONV bool Perl_is_uni_alnum_lc(pTHX_ UV c)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__pure__;
+PERL_CALLCONV bool Perl_is_uni_alnumc(pTHX_ UV c)
+ __attribute__deprecated__
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV bool Perl_is_uni_alnumc_lc(pTHX_ UV c)
+ __attribute__deprecated__
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
PERL_CALLCONV bool Perl_is_uni_alpha(pTHX_ UV c)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__pure__;
PERL_CALLCONV bool Perl_is_uni_alpha_lc(pTHX_ UV c)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__pure__;
PERL_CALLCONV bool Perl_is_uni_ascii(pTHX_ UV c)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__pure__;
PERL_CALLCONV bool Perl_is_uni_ascii_lc(pTHX_ UV c)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__pure__;
+PERL_CALLCONV bool Perl_is_uni_blank(pTHX_ UV c)
+ __attribute__deprecated__
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
+PERL_CALLCONV bool Perl_is_uni_blank_lc(pTHX_ UV c)
+ __attribute__deprecated__
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+
PERL_CALLCONV bool Perl_is_uni_cntrl(pTHX_ UV c)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__pure__;
PERL_CALLCONV bool Perl_is_uni_cntrl_lc(pTHX_ UV c)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__pure__;
PERL_CALLCONV bool Perl_is_uni_digit(pTHX_ UV c)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__pure__;
PERL_CALLCONV bool Perl_is_uni_digit_lc(pTHX_ UV c)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__pure__;
PERL_CALLCONV bool Perl_is_uni_graph(pTHX_ UV c)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__pure__;
PERL_CALLCONV bool Perl_is_uni_graph_lc(pTHX_ UV c)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__pure__;
PERL_CALLCONV bool Perl_is_uni_idfirst(pTHX_ UV c)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__pure__;
PERL_CALLCONV bool Perl_is_uni_idfirst_lc(pTHX_ UV c)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__pure__;
PERL_CALLCONV bool Perl_is_uni_lower(pTHX_ UV c)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__pure__;
PERL_CALLCONV bool Perl_is_uni_lower_lc(pTHX_ UV c)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__pure__;
PERL_CALLCONV bool Perl_is_uni_print(pTHX_ UV c)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__pure__;
PERL_CALLCONV bool Perl_is_uni_print_lc(pTHX_ UV c)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__pure__;
PERL_CALLCONV bool Perl_is_uni_punct(pTHX_ UV c)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__pure__;
PERL_CALLCONV bool Perl_is_uni_punct_lc(pTHX_ UV c)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__pure__;
PERL_CALLCONV bool Perl_is_uni_space(pTHX_ UV c)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__pure__;
PERL_CALLCONV bool Perl_is_uni_space_lc(pTHX_ UV c)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__pure__;
PERL_CALLCONV bool Perl_is_uni_upper(pTHX_ UV c)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__pure__;
PERL_CALLCONV bool Perl_is_uni_upper_lc(pTHX_ UV c)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__pure__;
PERL_CALLCONV bool Perl_is_uni_xdigit(pTHX_ UV c)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__pure__;
PERL_CALLCONV bool Perl_is_uni_xdigit_lc(pTHX_ UV c)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__pure__;
-PERL_CALLCONV bool Perl_is_utf8_X_L(pTHX_ const U8 *p)
+PERL_CALLCONV bool Perl_is_utf8_alnum(pTHX_ const U8 *p)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_IS_UTF8_X_L \
+#define PERL_ARGS_ASSERT_IS_UTF8_ALNUM \
assert(p)
-PERL_CALLCONV bool Perl_is_utf8_X_LV(pTHX_ const U8 *p)
+PERL_CALLCONV bool Perl_is_utf8_alnumc(pTHX_ const U8 *p)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_IS_UTF8_X_LV \
+#define PERL_ARGS_ASSERT_IS_UTF8_ALNUMC \
assert(p)
-PERL_CALLCONV bool Perl_is_utf8_X_LVT(pTHX_ const U8 *p)
+PERL_CALLCONV bool Perl_is_utf8_alpha(pTHX_ const U8 *p)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_IS_UTF8_X_LVT \
+#define PERL_ARGS_ASSERT_IS_UTF8_ALPHA \
assert(p)
-PERL_CALLCONV bool Perl_is_utf8_X_LV_LVT_V(pTHX_ const U8 *p)
+PERL_CALLCONV bool Perl_is_utf8_ascii(pTHX_ const U8 *p)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_IS_UTF8_X_LV_LVT_V \
+#define PERL_ARGS_ASSERT_IS_UTF8_ASCII \
assert(p)
-PERL_CALLCONV bool Perl_is_utf8_X_T(pTHX_ const U8 *p)
+PERL_CALLCONV bool Perl_is_utf8_blank(pTHX_ const U8 *p)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_IS_UTF8_X_T \
+#define PERL_ARGS_ASSERT_IS_UTF8_BLANK \
assert(p)
-PERL_CALLCONV bool Perl_is_utf8_X_V(pTHX_ const U8 *p)
- __attribute__warn_unused_result__
- __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_IS_UTF8_X_V \
- assert(p)
-
-PERL_CALLCONV bool Perl_is_utf8_X_begin(pTHX_ const U8 *p)
- __attribute__warn_unused_result__
- __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_IS_UTF8_X_BEGIN \
- assert(p)
-
-PERL_CALLCONV bool Perl_is_utf8_X_extend(pTHX_ const U8 *p)
- __attribute__warn_unused_result__
- __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_IS_UTF8_X_EXTEND \
- assert(p)
-
-PERL_CALLCONV bool Perl_is_utf8_X_non_hangul(pTHX_ const U8 *p)
- __attribute__warn_unused_result__
- __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_IS_UTF8_X_NON_HANGUL \
- assert(p)
-
-PERL_CALLCONV bool Perl_is_utf8_X_prepend(pTHX_ const U8 *p)
- __attribute__warn_unused_result__
- __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_IS_UTF8_X_PREPEND \
- assert(p)
-
-PERL_CALLCONV bool Perl_is_utf8_alnum(pTHX_ const U8 *p)
- __attribute__warn_unused_result__
- __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_IS_UTF8_ALNUM \
- assert(p)
-
-PERL_CALLCONV bool Perl_is_utf8_alpha(pTHX_ const U8 *p)
- __attribute__warn_unused_result__
- __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_IS_UTF8_ALPHA \
- assert(p)
-
-PERL_CALLCONV bool Perl_is_utf8_ascii(pTHX_ const U8 *p)
- __attribute__warn_unused_result__
- __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_IS_UTF8_ASCII \
- assert(p)
-
PERL_CALLCONV STRLEN Perl_is_utf8_char(const U8 *s)
+ __attribute__deprecated__
__attribute__nonnull__(1);
#define PERL_ARGS_ASSERT_IS_UTF8_CHAR \
assert(s)
+PERL_CALLCONV STRLEN Perl_is_utf8_char_buf(const U8 *buf, const U8 *buf_end)
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2);
+#define PERL_ARGS_ASSERT_IS_UTF8_CHAR_BUF \
+ assert(buf); assert(buf_end)
+
PERL_CALLCONV bool Perl_is_utf8_cntrl(pTHX_ const U8 *p)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_IS_UTF8_CNTRL \
@@ -1709,6 +1937,7 @@
assert(p)
PERL_CALLCONV bool Perl_is_utf8_digit(pTHX_ const U8 *p)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_IS_UTF8_DIGIT \
@@ -1715,6 +1944,7 @@
assert(p)
PERL_CALLCONV bool Perl_is_utf8_graph(pTHX_ const U8 *p)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_IS_UTF8_GRAPH \
@@ -1721,6 +1951,7 @@
assert(p)
PERL_CALLCONV bool Perl_is_utf8_idcont(pTHX_ const U8 *p)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_IS_UTF8_IDCONT \
@@ -1727,6 +1958,7 @@
assert(p)
PERL_CALLCONV bool Perl_is_utf8_idfirst(pTHX_ const U8 *p)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_IS_UTF8_IDFIRST \
@@ -1733,6 +1965,7 @@
assert(p)
PERL_CALLCONV bool Perl_is_utf8_lower(pTHX_ const U8 *p)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_IS_UTF8_LOWER \
@@ -1739,6 +1972,7 @@
assert(p)
PERL_CALLCONV bool Perl_is_utf8_mark(pTHX_ const U8 *p)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_IS_UTF8_MARK \
@@ -1745,6 +1979,7 @@
assert(p)
PERL_CALLCONV bool Perl_is_utf8_perl_space(pTHX_ const U8 *p)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_IS_UTF8_PERL_SPACE \
@@ -1751,6 +1986,7 @@
assert(p)
PERL_CALLCONV bool Perl_is_utf8_perl_word(pTHX_ const U8 *p)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_IS_UTF8_PERL_WORD \
@@ -1757,6 +1993,7 @@
assert(p)
PERL_CALLCONV bool Perl_is_utf8_posix_digit(pTHX_ const U8 *p)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_IS_UTF8_POSIX_DIGIT \
@@ -1763,6 +2000,7 @@
assert(p)
PERL_CALLCONV bool Perl_is_utf8_print(pTHX_ const U8 *p)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_IS_UTF8_PRINT \
@@ -1769,6 +2007,7 @@
assert(p)
PERL_CALLCONV bool Perl_is_utf8_punct(pTHX_ const U8 *p)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_IS_UTF8_PUNCT \
@@ -1775,6 +2014,7 @@
assert(p)
PERL_CALLCONV bool Perl_is_utf8_space(pTHX_ const U8 *p)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_IS_UTF8_SPACE \
@@ -1785,7 +2025,7 @@
#define PERL_ARGS_ASSERT_IS_UTF8_STRING \
assert(s)
-/* PERL_CALLCONV bool Perl_is_utf8_string_loc(const U8 *s, STRLEN len, const U8 **p)
+/* PERL_CALLCONV bool Perl_is_utf8_string_loc(const U8 *s, STRLEN len, const U8 **ep)
__attribute__nonnull__(1); */
#define PERL_ARGS_ASSERT_IS_UTF8_STRING_LOC \
assert(s)
@@ -1796,6 +2036,7 @@
assert(s)
PERL_CALLCONV bool Perl_is_utf8_upper(pTHX_ const U8 *p)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_IS_UTF8_UPPER \
@@ -1802,6 +2043,7 @@
assert(p)
PERL_CALLCONV bool Perl_is_utf8_xdigit(pTHX_ const U8 *p)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_IS_UTF8_XDIGIT \
@@ -1808,6 +2050,7 @@
assert(p)
PERL_CALLCONV bool Perl_is_utf8_xidcont(pTHX_ const U8 *p)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_IS_UTF8_XIDCONT \
@@ -1814,6 +2057,7 @@
assert(p)
PERL_CALLCONV bool Perl_is_utf8_xidfirst(pTHX_ const U8 *p)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_IS_UTF8_XIDFIRST \
@@ -1897,6 +2141,12 @@
#define PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV \
assert(sv); assert(mg)
+PERL_CALLCONV int Perl_magic_cleararylen_p(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P \
+ assert(sv); assert(mg)
+
PERL_CALLCONV int Perl_magic_clearenv(pTHX_ SV* sv, MAGIC* mg)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
@@ -1932,6 +2182,13 @@
#define PERL_ARGS_ASSERT_MAGIC_CLEARSIG \
assert(sv); assert(mg)
+PERL_CALLCONV int Perl_magic_copycallchecker(pTHX_ SV* sv, MAGIC *mg, SV *nsv, const char *name, I32 namlen)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER \
+ assert(sv); assert(mg); assert(nsv)
+
PERL_CALLCONV void Perl_magic_dump(pTHX_ const MAGIC *mg);
PERL_CALLCONV int Perl_magic_existspack(pTHX_ SV* sv, const MAGIC* mg)
__attribute__nonnull__(pTHX_1)
@@ -2023,12 +2280,6 @@
#define PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS \
assert(sv); assert(mg)
-PERL_CALLCONV U32 Perl_magic_len(pTHX_ SV* sv, MAGIC* mg)
- __attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_MAGIC_LEN \
- assert(sv); assert(mg)
-
PERL_CALLCONV SV* Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags, U32 argc, ...)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2)
@@ -2055,13 +2306,6 @@
#define PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET \
assert(sv); assert(mg)
-PERL_CALLCONV int Perl_magic_regdatum_set(pTHX_ SV* sv, MAGIC* mg)
- __attribute__noreturn__
- __attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET \
- assert(sv); assert(mg)
-
PERL_CALLCONV SV* Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
@@ -2080,12 +2324,6 @@
#define PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV \
assert(sv); assert(mg)
-PERL_CALLCONV int Perl_magic_setamagic(pTHX_ SV* sv, MAGIC* mg)
- __attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_MAGIC_SETAMAGIC \
- assert(sv); assert(mg)
-
PERL_CALLCONV int Perl_magic_setarylen(pTHX_ SV* sv, MAGIC* mg)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
@@ -2249,6 +2487,7 @@
assert(sv)
PERL_CALLCONV U32 Perl_mg_length(pTHX_ SV* sv)
+ __attribute__deprecated__
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_MG_LENGTH \
assert(sv)
@@ -2279,7 +2518,6 @@
#define PERL_ARGS_ASSERT_MINI_MKTIME \
assert(ptm)
-PERL_CALLCONV OP* Perl_mod(pTHX_ OP* o, I32 type);
PERL_CALLCONV int Perl_mode_from_discipline(pTHX_ const char* s, STRLEN len);
PERL_CALLCONV void * Perl_more_bodies(pTHX_ const svtype sv_type, const size_t body_size, const size_t arena_size);
PERL_CALLCONV const char* Perl_moreswitches(pTHX_ const char* s)
@@ -2341,11 +2579,6 @@
#define PERL_ARGS_ASSERT_MRO_SET_PRIVATE_DATA \
assert(smeta); assert(which); assert(data)
-PERL_CALLCONV void Perl_munge_qwlist_to_paren_list(pTHX_ OP* qwlist)
- __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_MUNGE_QWLIST_TO_PAREN_LIST \
- assert(qwlist)
-
PERL_CALLCONV NV Perl_my_atof(pTHX_ const char *s)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_MY_ATOF \
@@ -2364,10 +2597,10 @@
PERL_CALLCONV void Perl_my_clearenv(pTHX);
PERL_CALLCONV int Perl_my_dirfd(pTHX_ DIR* dir);
-PERL_CALLCONV void Perl_my_exit(pTHX_ U32 status)
+PERL_CALLCONV_NO_RET void Perl_my_exit(pTHX_ U32 status)
__attribute__noreturn__;
-PERL_CALLCONV void Perl_my_failure_exit(pTHX)
+PERL_CALLCONV_NO_RET void Perl_my_failure_exit(pTHX)
__attribute__noreturn__;
PERL_CALLCONV I32 Perl_my_fflush_all(pTHX);
@@ -2374,13 +2607,6 @@
PERL_CALLCONV Pid_t Perl_my_fork(void);
/* PERL_CALLCONV I32 Perl_my_lstat(pTHX); */
PERL_CALLCONV I32 Perl_my_lstat_flags(pTHX_ const U32 flags);
-PERL_CALLCONV I32 Perl_my_pclose(pTHX_ PerlIO* ptr);
-PERL_CALLCONV PerlIO* Perl_my_popen(pTHX_ const char* cmd, const char* mode)
- __attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_MY_POPEN \
- assert(cmd); assert(mode)
-
PERL_CALLCONV PerlIO* Perl_my_popen_list(pTHX_ const char* mode, int n, SV ** args)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_3);
@@ -2430,6 +2656,7 @@
__attribute__warn_unused_result__;
PERL_CALLCONV CV* Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block);
+PERL_CALLCONV CV* Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block, U32 flags);
/* PERL_CALLCONV AV* Perl_newAV(pTHX)
__attribute__warn_unused_result__; */
@@ -2452,6 +2679,7 @@
assert(first)
PERL_CALLCONV CV* Perl_newCONSTSUB(pTHX_ HV* stash, const char* name, SV* sv);
+PERL_CALLCONV CV* Perl_newCONSTSUB_flags(pTHX_ HV* stash, const char* name, STRLEN len, U32 flags, SV* sv);
PERL_CALLCONV OP* Perl_newCVREF(pTHX_ I32 flags, OP* o)
__attribute__malloc__
__attribute__warn_unused_result__;
@@ -2487,11 +2715,14 @@
__attribute__malloc__
__attribute__warn_unused_result__;
-PERL_CALLCONV GV* Perl_newGVgen(pTHX_ const char* pack)
+/* PERL_CALLCONV GV* newGVgen(pTHX_ const char* pack)
+ __attribute__nonnull__(pTHX_1); */
+
+PERL_CALLCONV GV* Perl_newGVgen_flags(pTHX_ const char* pack, U32 flags)
__attribute__malloc__
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_NEWGVGEN \
+#define PERL_ARGS_ASSERT_NEWGVGEN_FLAGS \
assert(pack)
/* PERL_CALLCONV HV* Perl_newHV(pTHX)
@@ -2535,6 +2766,11 @@
__attribute__malloc__
__attribute__warn_unused_result__;
+PERL_CALLCONV CV * Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_NEWMYSUB \
+ assert(o)
+
PERL_CALLCONV OP* Perl_newNULLLIST(pTHX)
__attribute__malloc__
__attribute__warn_unused_result__;
@@ -2586,6 +2822,11 @@
__attribute__malloc__
__attribute__warn_unused_result__;
+PERL_CALLCONV CV* Perl_newSTUB(pTHX_ GV *gv, bool fake)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_NEWSTUB \
+ assert(gv)
+
/* PERL_CALLCONV CV* Perl_newSUB(pTHX_ I32 floor, OP* o, OP* proto, OP* block); */
PERL_CALLCONV SV* Perl_newSV(pTHX_ const STRLEN len)
__attribute__malloc__
@@ -2689,6 +2930,12 @@
#define PERL_ARGS_ASSERT_NEWXS_FLAGS \
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);
+#define PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS \
+ assert(subaddr); assert(filename)
+
PERL_CALLCONV void Perl_new_collate(pTHX_ const char* newcoll);
PERL_CALLCONV void Perl_new_ctype(pTHX_ const char* newctype)
__attribute__nonnull__(pTHX_1);
@@ -2765,7 +3012,8 @@
#define PERL_ARGS_ASSERT_OP_LINKLIST \
assert(o)
-PERL_CALLCONV OP* Perl_op_lvalue(pTHX_ OP* o, I32 type);
+/* PERL_CALLCONV OP* op_lvalue(pTHX_ OP* o, I32 type); */
+PERL_CALLCONV OP* Perl_op_lvalue_flags(pTHX_ OP* o, I32 type, U32 flags);
PERL_CALLCONV void Perl_op_null(pTHX_ OP* o)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_OP_NULL \
@@ -2775,6 +3023,7 @@
PERL_CALLCONV void Perl_op_refcnt_lock(pTHX);
PERL_CALLCONV void Perl_op_refcnt_unlock(pTHX);
PERL_CALLCONV OP* Perl_op_scope(pTHX_ OP* o);
+PERL_CALLCONV OP* Perl_op_unscope(pTHX_ OP* o);
PERL_CALLCONV void Perl_pack_cat(pTHX_ SV *cat, const char *pat, const char *patend, SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2)
@@ -2799,27 +3048,46 @@
#define PERL_ARGS_ASSERT_PACKLIST \
assert(cat); assert(pat); assert(patend); assert(beglist); assert(endlist)
-PERL_CALLCONV PADOFFSET Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type)
+PERL_CALLCONV PADOFFSET Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_PAD_ADD_ANON \
- assert(sv)
+ assert(func)
-PERL_CALLCONV PADOFFSET Perl_pad_add_name(pTHX_ const char *name, const STRLEN len, const U32 flags, HV *typestash, HV *ourstash)
+PERL_CALLCONV PADOFFSET Perl_pad_add_name_pv(pTHX_ const char *name, const U32 flags, HV *typestash, HV *ourstash)
__attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_PAD_ADD_NAME \
+#define PERL_ARGS_ASSERT_PAD_ADD_NAME_PV \
assert(name)
+PERL_CALLCONV PADOFFSET Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags, HV *typestash, HV *ourstash)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN \
+ assert(namepv)
+
+PERL_CALLCONV PADOFFSET Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_PAD_ADD_NAME_SV \
+ assert(name)
+
PERL_CALLCONV PADOFFSET Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype);
PERL_CALLCONV void Perl_pad_block_start(pTHX_ int full);
PERL_CALLCONV HV* Perl_pad_compname_type(pTHX_ const PADOFFSET po)
__attribute__warn_unused_result__;
-PERL_CALLCONV PADOFFSET Perl_pad_findmy(pTHX_ const char* name, STRLEN len, U32 flags)
- __attribute__warn_unused_result__
+PERL_CALLCONV PADOFFSET Perl_pad_findmy_pv(pTHX_ const char* name, U32 flags)
__attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_PAD_FINDMY \
+#define PERL_ARGS_ASSERT_PAD_FINDMY_PV \
assert(name)
+PERL_CALLCONV PADOFFSET Perl_pad_findmy_pvn(pTHX_ const char* namepv, STRLEN namelen, U32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_PAD_FINDMY_PVN \
+ assert(namepv)
+
+PERL_CALLCONV PADOFFSET Perl_pad_findmy_sv(pTHX_ SV* name, U32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_PAD_FINDMY_SV \
+ assert(name)
+
PERL_CALLCONV void Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2)
@@ -2828,7 +3096,7 @@
assert(padlist); assert(old_cv); assert(new_cv)
PERL_CALLCONV void Perl_pad_free(pTHX_ PADOFFSET po);
-PERL_CALLCONV void Perl_pad_leavemy(pTHX);
+PERL_CALLCONV OP * Perl_pad_leavemy(pTHX);
PERL_CALLCONV PADLIST* Perl_pad_new(pTHX_ int flags)
__attribute__malloc__
__attribute__warn_unused_result__;
@@ -2840,6 +3108,11 @@
PERL_CALLCONV void Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust);
PERL_CALLCONV void Perl_pad_tidy(pTHX_ padtidy_type type);
+PERL_CALLCONV PAD ** Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_PADLIST_STORE \
+ assert(padlist)
+
PERL_CALLCONV OP* Perl_parse_arithexpr(pTHX_ U32 flags);
PERL_CALLCONV OP* Perl_parse_barestmt(pTHX_ U32 flags);
PERL_CALLCONV OP* Perl_parse_block(pTHX_ U32 flags);
@@ -2887,7 +3160,7 @@
assert(my_perl)
PERL_CALLCONV void Perl_pmop_dump(pTHX_ PMOP* pm);
-PERL_CALLCONV OP* Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
+PERL_CALLCONV OP* Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
#define PERL_ARGS_ASSERT_PMRUNTIME \
@@ -2979,7 +3252,7 @@
#define PERL_ARGS_ASSERT_QERROR \
assert(err)
-PERL_CALLCONV REGEXP* Perl_re_compile(pTHX_ SV * const pattern, U32 flags)
+PERL_CALLCONV REGEXP* Perl_re_compile(pTHX_ SV * const pattern, U32 orig_rx_flags)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_RE_COMPILE \
assert(pattern)
@@ -2996,10 +3269,23 @@
#define PERL_ARGS_ASSERT_RE_INTUIT_STRING \
assert(r)
+PERL_CALLCONV REGEXP* Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, OP *expr, const regexp_engine* eng, REGEXP *old_re, bool *is_bare_re, U32 rx_flags, U32 pm_flags)
+ __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT_RE_OP_COMPILE \
+ assert(eng)
+
PERL_CALLCONV Malloc_t Perl_realloc(Malloc_t where, MEM_SIZE nbytes)
__attribute__malloc__
__attribute__warn_unused_result__;
+PERL_CALLCONV void Perl_reentrant_free(pTHX);
+PERL_CALLCONV void Perl_reentrant_init(pTHX);
+PERL_CALLCONV void* Perl_reentrant_retry(const char *f, ...)
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_REENTRANT_RETRY \
+ assert(f)
+
+PERL_CALLCONV void Perl_reentrant_size(pTHX);
/* PERL_CALLCONV OP* Perl_ref(pTHX_ OP* o, I32 type); */
PERL_CALLCONV HV * Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *c, U32 flags);
PERL_CALLCONV SV * Perl_refcounted_he_fetch_pv(pTHX_ const struct refcounted_he *chain, const char *key, U32 hash, U32 flags)
@@ -3112,11 +3398,6 @@
#define PERL_ARGS_ASSERT_REGDUMP \
assert(r)
-PERL_CALLCONV void Perl_regdump(pTHX_ const regexp* r)
- __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_REGDUMP \
- assert(r)
-
PERL_CALLCONV I32 Perl_regexec_flags(pTHX_ REGEXP *const rx, char *stringarg, char *strend, char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2)
@@ -3141,7 +3422,7 @@
#define PERL_ARGS_ASSERT_REGPROP \
assert(sv); assert(o)
-PERL_CALLCONV void Perl_repeatcpy(char* to, const char* from, I32 len, I32 count)
+PERL_CALLCONV void Perl_repeatcpy(char* to, const char* from, I32 len, IV count)
__attribute__nonnull__(1)
__attribute__nonnull__(2);
#define PERL_ARGS_ASSERT_REPEATCPY \
@@ -3399,10 +3680,7 @@
PERL_CALLCONV char* Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
__attribute__malloc__
- __attribute__warn_unused_result__
- __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_SAVESHAREDPVN \
- assert(pv)
+ __attribute__warn_unused_result__;
PERL_CALLCONV char* Perl_savesharedsvpv(pTHX_ SV *sv)
__attribute__malloc__
@@ -3480,7 +3758,11 @@
PERL_CALLCONV void Perl_set_numeric_local(pTHX);
PERL_CALLCONV void Perl_set_numeric_radix(pTHX);
PERL_CALLCONV void Perl_set_numeric_standard(pTHX);
-PERL_CALLCONV void Perl_setdefout(pTHX_ GV* gv);
+PERL_CALLCONV void Perl_setdefout(pTHX_ GV* gv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SETDEFOUT \
+ assert(gv)
+
PERL_CALLCONV HEK* Perl_share_hek(pTHX_ const char* str, I32 len, U32 hash)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_SHARE_HEK \
@@ -3509,19 +3791,6 @@
assert(tmpglob); assert(io)
PERL_CALLCONV I32 Perl_start_subparse(pTHX_ I32 is_format, U32 flags);
-PERL_CALLCONV bool Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
- __attribute__warn_unused_result__
- __attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_STASHPV_HVNAME_MATCH \
- assert(c); assert(hv)
-
-PERL_CALLCONV void Perl_store_cop_label(pTHX_ COP *const cop, const char *label, STRLEN len, U32 flags)
- __attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_STORE_COP_LABEL \
- assert(cop); assert(label)
-
PERL_CALLCONV NV Perl_str_to_version(pTHX_ SV *sv)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
@@ -3569,7 +3838,7 @@
#define PERL_ARGS_ASSERT_SV_2PV_NOLEN \
assert(sv)
-PERL_CALLCONV char* Perl_sv_2pvbyte(pTHX_ SV *const sv, STRLEN *const lp)
+PERL_CALLCONV char* Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_SV_2PVBYTE \
assert(sv)
@@ -3580,7 +3849,7 @@
#define PERL_ARGS_ASSERT_SV_2PVBYTE_NOLEN \
assert(sv)
-PERL_CALLCONV char* Perl_sv_2pvutf8(pTHX_ SV *const sv, STRLEN *const lp)
+PERL_CALLCONV char* Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_SV_2PVUTF8 \
assert(sv)
@@ -3692,29 +3961,22 @@
PERL_CALLCONV I32 Perl_sv_cmp_flags(pTHX_ SV *const sv1, SV *const sv2, const U32 flags);
PERL_CALLCONV I32 Perl_sv_cmp_locale(pTHX_ SV *const sv1, SV *const sv2);
PERL_CALLCONV I32 Perl_sv_cmp_locale_flags(pTHX_ SV *const sv1, SV *const sv2, const U32 flags);
-PERL_CALLCONV OP* Perl_sv_compile_2op(pTHX_ SV *sv, OP **startop, const char *code, PAD **padp)
- __attribute__deprecated__
+/* PERL_CALLCONV void Perl_sv_copypv(pTHX_ SV *const dsv, SV *const ssv)
__attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_2)
- __attribute__nonnull__(pTHX_3)
- __attribute__nonnull__(pTHX_4);
-#define PERL_ARGS_ASSERT_SV_COMPILE_2OP \
- assert(sv); assert(startop); assert(code); assert(padp)
+ __attribute__nonnull__(pTHX_2); */
+#define PERL_ARGS_ASSERT_SV_COPYPV \
+ assert(dsv); assert(ssv)
-PERL_CALLCONV OP* Perl_sv_compile_2op_is_broken(pTHX_ SV *sv, OP **startop, const char *code, PAD **padp)
+PERL_CALLCONV void Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
__attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_2)
- __attribute__nonnull__(pTHX_3)
- __attribute__nonnull__(pTHX_4);
-#define PERL_ARGS_ASSERT_SV_COMPILE_2OP_IS_BROKEN \
- assert(sv); assert(startop); assert(code); assert(padp)
-
-PERL_CALLCONV void Perl_sv_copypv(pTHX_ SV *const dsv, SV *const ssv)
- __attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_SV_COPYPV \
+#define PERL_ARGS_ASSERT_SV_COPYPV_FLAGS \
assert(dsv); assert(ssv)
+/* PERL_CALLCONV void Perl_sv_copypv_nomg(pTHX_ SV *const dsv, SV *const ssv)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2); */
+
PERL_CALLCONV void Perl_sv_dec(pTHX_ SV *const sv);
PERL_CALLCONV void Perl_sv_dec_nomg(pTHX_ SV *const sv);
PERL_CALLCONV void Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
@@ -3730,6 +3992,27 @@
#define PERL_ARGS_ASSERT_SV_DERIVED_FROM \
assert(sv); assert(name)
+PERL_CALLCONV bool Perl_sv_derived_from_pv(pTHX_ SV* sv, const char *const name, U32 flags)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_DERIVED_FROM_PV \
+ assert(sv); assert(name)
+
+PERL_CALLCONV bool Perl_sv_derived_from_pvn(pTHX_ SV* sv, const char *const name, const STRLEN len, U32 flags)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_DERIVED_FROM_PVN \
+ assert(sv); assert(name)
+
+PERL_CALLCONV bool Perl_sv_derived_from_sv(pTHX_ SV* sv, SV *namesv, U32 flags)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_DERIVED_FROM_SV \
+ assert(sv); assert(namesv)
+
PERL_CALLCONV bool Perl_sv_destroyable(pTHX_ SV *sv);
PERL_CALLCONV bool Perl_sv_does(pTHX_ SV* sv, const char *const name)
__attribute__warn_unused_result__
@@ -3738,6 +4021,27 @@
#define PERL_ARGS_ASSERT_SV_DOES \
assert(sv); assert(name)
+PERL_CALLCONV bool Perl_sv_does_pv(pTHX_ SV* sv, const char *const name, U32 flags)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_DOES_PV \
+ assert(sv); assert(name)
+
+PERL_CALLCONV bool Perl_sv_does_pvn(pTHX_ SV* sv, const char *const name, const STRLEN len, U32 flags)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_DOES_PVN \
+ assert(sv); assert(name)
+
+PERL_CALLCONV bool Perl_sv_does_sv(pTHX_ SV* sv, SV* namesv, U32 flags)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_DOES_SV \
+ assert(sv); assert(namesv)
+
PERL_CALLCONV void Perl_sv_dump(pTHX_ SV* sv)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_SV_DUMP \
@@ -3756,7 +4060,7 @@
assert(sv)
PERL_CALLCONV void Perl_sv_free(pTHX_ SV *const sv);
-PERL_CALLCONV void Perl_sv_free2(pTHX_ SV *const sv)
+PERL_CALLCONV void Perl_sv_free2(pTHX_ SV *const sv, const U32 refcnt)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_SV_FREE2 \
assert(sv)
@@ -3800,6 +4104,11 @@
PERL_CALLCONV STRLEN Perl_sv_len(pTHX_ SV *const sv);
PERL_CALLCONV STRLEN Perl_sv_len_utf8(pTHX_ SV *const sv);
+PERL_CALLCONV STRLEN Perl_sv_len_utf8_nomg(pTHX_ SV *const sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_LEN_UTF8_NOMG \
+ assert(sv)
+
PERL_CALLCONV void Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how, const char *const name, const I32 namlen)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_SV_MAGIC \
@@ -3810,8 +4119,12 @@
#define PERL_ARGS_ASSERT_SV_MAGICEXT \
assert(sv)
-PERL_CALLCONV SV* Perl_sv_mortalcopy(pTHX_ SV *const oldsv)
+/* PERL_CALLCONV SV* Perl_sv_mortalcopy(pTHX_ SV *const oldsv)
__attribute__malloc__
+ __attribute__warn_unused_result__; */
+
+PERL_CALLCONV SV* Perl_sv_mortalcopy_flags(pTHX_ SV *const oldsv, U32 flags)
+ __attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV SV* Perl_sv_newmortal(pTHX)
@@ -3908,6 +4221,11 @@
#define PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8 \
assert(sv); assert(encoding)
+PERL_CALLCONV SV* Perl_sv_ref(pTHX_ SV *dst, const SV *const sv, const int ob)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_REF \
+ assert(sv)
+
PERL_CALLCONV const char* Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
@@ -3926,11 +4244,17 @@
#define PERL_ARGS_ASSERT_SV_RESET \
assert(s)
+PERL_CALLCONV void Perl_sv_resetpvn(pTHX_ const char* s, STRLEN len, HV *const stash);
PERL_CALLCONV SV* Perl_sv_rvweaken(pTHX_ SV *const sv)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_SV_RVWEAKEN \
assert(sv)
+PERL_CALLCONV void Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_SETHEK \
+ assert(sv)
+
PERL_CALLCONV void Perl_sv_setiv(pTHX_ SV *const sv, const IV num)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_SV_SETIV \
@@ -4165,6 +4489,12 @@
#define PERL_ARGS_ASSERT_SV_VCATPVFN \
assert(sv); assert(pat)
+PERL_CALLCONV void Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted, const U32 flags)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_VCATPVFN_FLAGS \
+ assert(sv); assert(pat)
+
PERL_CALLCONV void Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
@@ -4190,6 +4520,7 @@
assert(swash); assert(ptr)
PERL_CALLCONV SV* Perl_swash_init(pTHX_ const char* pkg, const char* name, SV* listsv, I32 minbits, I32 none)
+ __attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2)
__attribute__nonnull__(pTHX_3);
@@ -4236,6 +4567,7 @@
assert(p); assert(lenp)
PERL_CALLCONV U32 Perl_to_uni_lower_lc(pTHX_ U32 c)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__pure__;
@@ -4246,6 +4578,7 @@
assert(p); assert(lenp)
PERL_CALLCONV U32 Perl_to_uni_title_lc(pTHX_ U32 c)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__pure__;
@@ -4256,6 +4589,7 @@
assert(p); assert(lenp)
PERL_CALLCONV U32 Perl_to_uni_upper_lc(pTHX_ U32 c)
+ __attribute__deprecated__
__attribute__warn_unused_result__
__attribute__pure__;
@@ -4270,22 +4604,24 @@
/* PERL_CALLCONV UV Perl_to_utf8_fold(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2); */
+#define PERL_ARGS_ASSERT_TO_UTF8_FOLD \
+ assert(p); assert(ustrp)
-PERL_CALLCONV UV Perl_to_utf8_lower(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
+/* PERL_CALLCONV UV Perl_to_utf8_lower(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
__attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_2);
+ __attribute__nonnull__(pTHX_2); */
#define PERL_ARGS_ASSERT_TO_UTF8_LOWER \
assert(p); assert(ustrp)
-PERL_CALLCONV UV Perl_to_utf8_title(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
+/* PERL_CALLCONV UV Perl_to_utf8_title(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
__attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_2);
+ __attribute__nonnull__(pTHX_2); */
#define PERL_ARGS_ASSERT_TO_UTF8_TITLE \
assert(p); assert(ustrp)
-PERL_CALLCONV UV Perl_to_utf8_upper(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
+/* PERL_CALLCONV UV Perl_to_utf8_upper(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
__attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_2);
+ __attribute__nonnull__(pTHX_2); */
#define PERL_ARGS_ASSERT_TO_UTF8_UPPER \
assert(p); assert(ustrp)
@@ -4358,15 +4694,29 @@
assert(s); assert(len)
PERL_CALLCONV UV Perl_utf8_to_uvchr(pTHX_ const U8 *s, STRLEN *retlen)
+ __attribute__deprecated__
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_UTF8_TO_UVCHR \
assert(s)
+PERL_CALLCONV UV Perl_utf8_to_uvchr_buf(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_UTF8_TO_UVCHR_BUF \
+ assert(s); assert(send)
+
PERL_CALLCONV UV Perl_utf8_to_uvuni(pTHX_ const U8 *s, STRLEN *retlen)
+ __attribute__deprecated__
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_UTF8_TO_UVUNI \
assert(s)
+PERL_CALLCONV UV Perl_utf8_to_uvuni_buf(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_UTF8_TO_UVUNI_BUF \
+ assert(s); assert(send)
+
PERL_CALLCONV UV Perl_utf8n_to_uvuni(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_UTF8N_TO_UVUNI \
@@ -4387,6 +4737,11 @@
#define PERL_ARGS_ASSERT_UVUNI_TO_UTF8_FLAGS \
assert(d)
+PERL_CALLCONV UV Perl_valid_utf8_to_uvuni(pTHX_ const U8 *s, STRLEN *retlen)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_VALID_UTF8_TO_UVUNI \
+ assert(s)
+
PERL_CALLCONV int Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
@@ -4393,7 +4748,7 @@
#define PERL_ARGS_ASSERT_VCMP \
assert(lhv); assert(rhv)
-PERL_CALLCONV void Perl_vcroak(pTHX_ const char* pat, va_list* args)
+PERL_CALLCONV_NO_RET void Perl_vcroak(pTHX_ const char* pat, va_list* args)
__attribute__noreturn__;
PERL_CALLCONV void Perl_vdeb(pTHX_ const char* pat, va_list* args)
@@ -4411,7 +4766,8 @@
#define PERL_ARGS_ASSERT_VIVIFY_DEFELEM \
assert(sv)
-PERL_CALLCONV void Perl_vivify_ref(pTHX_ SV* sv, U32 to_what)
+PERL_CALLCONV SV* Perl_vivify_ref(pTHX_ SV* sv, U32 to_what)
+ __attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_VIVIFY_REF \
assert(sv)
@@ -4485,16 +4841,38 @@
#define PERL_ARGS_ASSERT_WARNER \
assert(pat)
+PERL_CALLCONV I32 Perl_was_lvalue_sub(pTHX)
+ __attribute__warn_unused_result__;
+
PERL_CALLCONV void Perl_watch(pTHX_ char** addr)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_WATCH \
assert(addr)
-PERL_CALLCONV I32 Perl_whichsig(pTHX_ const char* sig)
+/* PERL_CALLCONV I32 whichsig(pTHX_ const char* sig)
+ __attribute__nonnull__(pTHX_1); */
+
+PERL_CALLCONV I32 Perl_whichsig_pv(pTHX_ const char* sig)
__attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_WHICHSIG \
+#define PERL_ARGS_ASSERT_WHICHSIG_PV \
assert(sig)
+PERL_CALLCONV I32 Perl_whichsig_pvn(pTHX_ const char* sig, STRLEN len)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_WHICHSIG_PVN \
+ assert(sig)
+
+PERL_CALLCONV I32 Perl_whichsig_sv(pTHX_ SV* sigsv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_WHICHSIG_SV \
+ assert(sigsv)
+
+PERL_CALLCONV void Perl_wrap_op_checker(pTHX_ Optype opcode, Perl_check_t new_checker, Perl_check_t *old_checker_p)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_WRAP_OP_CHECKER \
+ assert(new_checker); assert(old_checker_p)
+
PERL_CALLCONV void Perl_write_to_stderr(pTHX_ SV* msv)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_WRITE_TO_STDERR \
@@ -4516,6 +4894,16 @@
#define PERL_ARGS_ASSERT_YYERROR \
assert(s)
+PERL_CALLCONV int Perl_yyerror_pv(pTHX_ const char *const s, U32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_YYERROR_PV \
+ assert(s)
+
+PERL_CALLCONV int Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_YYERROR_PVN \
+ assert(s)
+
PERL_CALLCONV int Perl_yylex(pTHX);
PERL_CALLCONV int Perl_yyparse(pTHX_ int gramtype);
PERL_CALLCONV void Perl_yyunlex(pTHX);
@@ -4541,6 +4929,11 @@
#define PERL_ARGS_ASSERT_UVCHR_TO_UTF8 \
assert(d)
+/* PERL_CALLCONV UV Perl_valid_utf8_to_uvchr(pTHX_ const U8 *s, STRLEN *retlen)
+ __attribute__nonnull__(pTHX_1); */
+#define PERL_ARGS_ASSERT_VALID_UTF8_TO_UVCHR \
+ assert(s)
+
#endif
#if !(defined(HAS_SIGACTION) && defined(SA_SIGINFO))
PERL_CALLCONV Signal_t Perl_csighandler(int sig);
@@ -4567,9 +4960,6 @@
#endif
#if !(defined(PERL_MAD))
PERL_CALLCONV void Perl_newFORM(pTHX_ I32 floor, OP* o, OP* block);
-PERL_CALLCONV void Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
- __attribute__noreturn__;
-
PERL_CALLCONV void Perl_package(pTHX_ OP* o)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_PACKAGE \
@@ -4581,14 +4971,14 @@
assert(idop)
#endif
-#if !(defined(USE_ITHREADS))
-# if defined(PERL_IN_OP_C)
-STATIC void S_forget_pmop(pTHX_ PMOP *const o)
- __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_FORGET_PMOP \
- assert(o)
+#if !(defined(_MSC_VER))
+PERL_CALLCONV_NO_RET int Perl_magic_regdatum_set(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__noreturn__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET \
+ assert(sv); assert(mg)
-# endif
#endif
#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
PERL_CALLCONV char* Perl_my_bzero(char* loc, I32 len)
@@ -4677,6 +5067,15 @@
# endif
#endif
+#if !defined(PERL_IMPLICIT_SYS)
+PERL_CALLCONV I32 Perl_my_pclose(pTHX_ PerlIO* ptr);
+PERL_CALLCONV PerlIO* Perl_my_popen(pTHX_ const char* cmd, const char* mode)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MY_POPEN \
+ assert(cmd); assert(mode)
+
+#endif
#if !defined(PERL_IS_MINIPERL)
# if defined(PERL_IN_PERL_C)
STATIC SV * S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem)
@@ -4866,6 +5265,11 @@
#define PERL_ARGS_ASSERT_UVCHR_TO_UTF8 \
assert(d)
+PERL_CALLCONV UV Perl_valid_utf8_to_uvchr(pTHX_ const U8 *s, STRLEN *retlen)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_VALID_UTF8_TO_UVCHR \
+ assert(s)
+
#endif
#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
PERL_CALLCONV I32 Perl_do_ipcctl(pTHX_ I32 optype, SV** mark, SV** sp)
@@ -4944,17 +5348,14 @@
#endif
#if defined(MYSWAP)
PERL_CALLCONV long Perl_my_htonl(pTHX_ long l)
- __attribute__malloc__
__attribute__warn_unused_result__
__attribute__pure__;
PERL_CALLCONV long Perl_my_ntohl(pTHX_ long l)
- __attribute__malloc__
__attribute__warn_unused_result__
__attribute__pure__;
PERL_CALLCONV short Perl_my_swap(pTHX_ short s)
- __attribute__malloc__
__attribute__warn_unused_result__
__attribute__pure__;
@@ -4962,6 +5363,48 @@
#if defined(NO_MATHOMS)
/* PERL_CALLCONV void Perl_sv_nounlocking(pTHX_ SV *sv); */
#endif
+#if defined(PERL_ANY_COW)
+PERL_CALLCONV SV* Perl_sv_setsv_cow(pTHX_ SV* dstr, SV* sstr)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_SETSV_COW \
+ assert(sstr)
+
+#endif
+#if defined(PERL_CORE)
+PERL_CALLCONV void Perl_opslab_force_free(pTHX_ OPSLAB *slab)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE \
+ assert(slab)
+
+PERL_CALLCONV void Perl_opslab_free(pTHX_ OPSLAB *slab)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_OPSLAB_FREE \
+ assert(slab)
+
+PERL_CALLCONV void Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD \
+ assert(slab)
+
+PERL_CALLCONV void Perl_parser_free_nexttoke_ops(pTHX_ yy_parser *parser, OPSLAB *slab)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_PARSER_FREE_NEXTTOKE_OPS \
+ assert(parser); assert(slab)
+
+# if defined(PERL_DEBUG_READONLY_OPS)
+PERL_CALLCONV void Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SLAB_TO_RO \
+ assert(slab)
+
+PERL_CALLCONV void Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SLAB_TO_RW \
+ assert(slab)
+
+# endif
+#endif
#if defined(PERL_CR_FILTER)
# if defined(PERL_IN_TOKE_C)
STATIC I32 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen);
@@ -4973,16 +5416,6 @@
# endif
#endif
#if defined(PERL_DEBUG_READONLY_OPS)
-# if defined(PERL_IN_OP_C)
-# if defined(PL_OP_SLAB_ALLOC)
-STATIC void S_Slab_to_rw(pTHX_ void *op)
- __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_SLAB_TO_RW \
- assert(op)
-
-# endif
-# endif
-# if defined(PL_OP_SLAB_ALLOC)
PERL_CALLCONV PADOFFSET Perl_op_refcnt_dec(pTHX_ OP *o)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_OP_REFCNT_DEC \
@@ -4989,14 +5422,10 @@
assert(o)
PERL_CALLCONV OP * Perl_op_refcnt_inc(pTHX_ OP *o);
-PERL_CALLCONV void Perl_pending_Slabs_to_ro(pTHX);
-# endif
#endif
#if defined(PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION)
/* PERL_CALLCONV bool Perl_do_exec(pTHX_ const char* cmd)
__attribute__nonnull__(pTHX_1); */
-#define PERL_ARGS_ASSERT_DO_EXEC \
- assert(cmd)
#endif
#if defined(PERL_DONT_CREATE_GVSV)
@@ -5026,7 +5455,7 @@
# endif
#endif
#if defined(PERL_IMPLICIT_CONTEXT)
-PERL_CALLCONV void Perl_croak_nocontext(const char* pat, ...)
+PERL_CALLCONV_NO_RET void Perl_croak_nocontext(const char* pat, ...)
__attribute__noreturn__
__attribute__format__null_ok__(__printf__,1,2);
@@ -5209,27 +5638,6 @@
assert(sv)
#endif
-#if defined(PERL_IN_DQUOTE_STATIC_C)
-STATIC char S_grok_bslash_c(pTHX_ const char source, const bool utf8, const bool output_warning)
- __attribute__warn_unused_result__;
-
-STATIC bool S_grok_bslash_o(pTHX_ const char* s, UV* uv, STRLEN* len, const char** error_msg, const bool output_warning)
- __attribute__warn_unused_result__
- __attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_2)
- __attribute__nonnull__(pTHX_3)
- __attribute__nonnull__(pTHX_4);
-#define PERL_ARGS_ASSERT_GROK_BSLASH_O \
- assert(s); assert(uv); assert(len); assert(error_msg)
-
-PERL_STATIC_INLINE I32 S_regcurly(pTHX_ const char *s)
- __attribute__warn_unused_result__
- __attribute__pure__
- __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_REGCURLY \
- assert(s)
-
-#endif
#if defined(PERL_IN_DUMP_C)
STATIC CV* S_deb_curcv(pTHX_ const I32 ix);
STATIC void S_debprof(pTHX_ const OP *o)
@@ -5242,9 +5650,7 @@
#define PERL_ARGS_ASSERT_PM_DESCRIPTION \
assert(pm)
-STATIC void S_sequence(pTHX_ const OP *o);
STATIC UV S_sequence_num(pTHX_ const OP *o);
-STATIC void S_sequence_tail(pTHX_ const OP *o);
# if defined(PERL_MAD)
STATIC void S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
__attribute__format__(__printf__,pTHX_3,pTHX_4)
@@ -5255,7 +5661,7 @@
# endif
#endif
-#if defined(PERL_IN_DUMP_C) || defined(PERL_IN_HV_C) || defined(PERL_IN_SV_C)
+#if defined(PERL_IN_DUMP_C) || defined(PERL_IN_HV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_SCOPE_C)
PERL_CALLCONV void Perl_hv_kill_backrefs(pTHX_ HV *hv)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_HV_KILL_BACKREFS \
@@ -5263,14 +5669,9 @@
#endif
#if defined(PERL_IN_GV_C)
-STATIC HV* S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen)
+STATIC void S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
__attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_GV_GET_SUPER_PKG \
- assert(name)
-
-STATIC void S_gv_init_sv(pTHX_ GV *gv, const svtype sv_type)
- __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_GV_INIT_SV \
+#define PERL_ARGS_ASSERT_GV_INIT_SVTYPE \
assert(gv)
STATIC void S_gv_magicalize_isa(pTHX_ GV *gv)
@@ -5278,11 +5679,6 @@
#define PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA \
assert(gv)
-STATIC void S_gv_magicalize_overload(pTHX_ GV *gv)
- __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_GV_MAGICALIZE_OVERLOAD \
- assert(gv)
-
STATIC HV* S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv, const U32 flags)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2)
@@ -5311,17 +5707,23 @@
#define PERL_ARGS_ASSERT_HFREEENTRIES \
assert(hv)
-STATIC void S_hsplit(pTHX_ HV *hv)
+STATIC void S_hsplit(pTHX_ HV *hv, STRLEN const oldsize, STRLEN newsize)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_HSPLIT \
assert(hv)
-STATIC struct xpvhv_aux* S_hv_auxinit(HV *hv)
- __attribute__nonnull__(1);
+STATIC struct xpvhv_aux* S_hv_auxinit(pTHX_ HV *hv)
+ __attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_HV_AUXINIT \
assert(hv)
STATIC SV* S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, int k_flags, I32 d_flags, U32 hash);
+STATIC SV* S_hv_free_ent_ret(pTHX_ HV *hv, HE *entry)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_HV_FREE_ENT_RET \
+ assert(hv); assert(entry)
+
STATIC void S_hv_magic_check(HV *hv, bool *needs_copy, bool *needs_store)
__attribute__nonnull__(1)
__attribute__nonnull__(2)
@@ -5329,7 +5731,7 @@
#define PERL_ARGS_ASSERT_HV_MAGIC_CHECK \
assert(hv); assert(needs_copy); assert(needs_store)
-STATIC void S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen, const char *msg)
+PERL_STATIC_NO_RET void S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen, const char *msg)
__attribute__noreturn__
__attribute__nonnull__(pTHX_2)
__attribute__nonnull__(pTHX_4);
@@ -5340,6 +5742,7 @@
__attribute__malloc__
__attribute__warn_unused_result__;
+STATIC U32 S_ptr_hash(PTRV u);
STATIC SV * S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_REFCOUNTED_HE_VALUE \
@@ -5367,6 +5770,14 @@
assert(sv)
#endif
+#if defined(PERL_IN_HV_C) || defined(PERL_IN_SV_C)
+PERL_CALLCONV SV* Perl_hfree_next_entry(pTHX_ HV *hv, STRLEN *indexp)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_HFREE_NEXT_ENTRY \
+ assert(hv); assert(indexp)
+
+#endif
#if defined(PERL_IN_LOCALE_C)
# if defined(USE_LOCALE_NUMERIC) || defined(USE_LOCALE_COLLATE)
STATIC char* S_stdize_locale(pTHX_ char* locs)
@@ -5399,8 +5810,16 @@
STATIC void S_unwind_handler_stack(pTHX_ const void *p);
#endif
+#if defined(PERL_IN_MG_C) || defined(PERL_IN_PP_C)
+PERL_CALLCONV bool Perl_translate_substr_offsets(pTHX_ STRLEN curlen, IV pos1_iv, bool pos1_is_uv, IV len_iv, bool len_is_uv, STRLEN *posp, STRLEN *lenp)
+ __attribute__nonnull__(pTHX_6)
+ __attribute__nonnull__(pTHX_7);
+#define PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS \
+ assert(posp); assert(lenp)
+
+#endif
#if defined(PERL_IN_MRO_C)
-STATIC void S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name, const STRLEN len, HV * const exceptions)
+STATIC void S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name, const STRLEN len, HV * const exceptions, U32 flags)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
#define PERL_ARGS_ASSERT_MRO_CLEAN_ISAREV \
@@ -5423,7 +5842,8 @@
STATIC NV S_mulexp10(NV value, I32 exponent);
#endif
#if defined(PERL_IN_OP_C)
-STATIC void S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
+PERL_STATIC_INLINE bool S_aassign_common_vars(pTHX_ OP* o);
+STATIC void S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
#define PERL_ARGS_ASSERT_APPLY_ATTRS \
@@ -5436,13 +5856,20 @@
#define PERL_ARGS_ASSERT_APPLY_ATTRS_MY \
assert(stash); assert(target); assert(imopsp)
-STATIC void S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
+STATIC void S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
__attribute__nonnull__(pTHX_2)
__attribute__nonnull__(pTHX_3)
- __attribute__nonnull__(pTHX_4);
-#define PERL_ARGS_ASSERT_BAD_TYPE \
+ __attribute__nonnull__(pTHX_5);
+#define PERL_ARGS_ASSERT_BAD_TYPE_PV \
assert(t); assert(name); assert(kid)
+STATIC void S_bad_type_sv(pTHX_ I32 n, const char *t, SV *namesv, U32 flags, const OP *kid)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_5);
+#define PERL_ARGS_ASSERT_BAD_TYPE_SV \
+ assert(t); assert(namesv); assert(kid)
+
STATIC void S_cop_free(pTHX_ COP *cop)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_COP_FREE \
@@ -5453,6 +5880,11 @@
#define PERL_ARGS_ASSERT_DUP_ATTRLIST \
assert(o)
+STATIC void S_finalize_op(pTHX_ OP* o)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_FINALIZE_OP \
+ assert(o)
+
STATIC void S_find_and_forget_pmops(pTHX_ OP *o)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS \
@@ -5464,12 +5896,22 @@
assert(o)
STATIC OP* S_force_list(pTHX_ OP* arg);
+STATIC void S_forget_pmop(pTHX_ PMOP *const o)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_FORGET_PMOP \
+ assert(o)
+
STATIC OP* S_gen_constant_list(pTHX_ OP* o);
-STATIC const char* S_gv_ename(pTHX_ GV *gv)
+STATIC SV* S_gv_ename(pTHX_ GV *gv)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_GV_ENAME \
assert(gv)
+STATIC void S_inplace_aassign(pTHX_ OP* o)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_INPLACE_AASSIGN \
+ assert(o)
+
STATIC bool S_is_handle_constructor(const OP *o, I32 numargs)
__attribute__warn_unused_result__
__attribute__nonnull__(1);
@@ -5476,11 +5918,6 @@
#define PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR \
assert(o)
-STATIC OP* S_is_inplace_av(pTHX_ OP* o, OP* oright)
- __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_IS_INPLACE_AV \
- assert(o)
-
STATIC I32 S_is_list_assignment(pTHX_ const OP *o)
__attribute__warn_unused_result__;
@@ -5511,7 +5948,7 @@
#define PERL_ARGS_ASSERT_NEW_LOGOP \
assert(firstp); assert(otherp)
-STATIC void S_no_bareword_allowed(pTHX_ const OP *o)
+STATIC void S_no_bareword_allowed(pTHX_ OP *o)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED \
assert(o)
@@ -5522,11 +5959,16 @@
#define PERL_ARGS_ASSERT_NO_FH_ALLOWED \
assert(o)
-STATIC OP* S_opt_scalarhv(pTHX_ OP* rep_op)
+PERL_STATIC_INLINE OP* S_op_integerize(pTHX_ OP *o)
__attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_OPT_SCALARHV \
- assert(rep_op)
+#define PERL_ARGS_ASSERT_OP_INTEGERIZE \
+ assert(o)
+PERL_STATIC_INLINE OP* S_op_std_init(pTHX_ OP *o)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_OP_STD_INIT \
+ assert(o)
+
STATIC OP* S_pmtrans(pTHX_ OP* o, OP* expr, OP* repl)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2)
@@ -5534,10 +5976,10 @@
#define PERL_ARGS_ASSERT_PMTRANS \
assert(o); assert(expr); assert(repl)
-STATIC void S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv, CV *const cv)
- __attribute__nonnull__(pTHX_1)
+STATIC void S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, GV *const gv, CV *const cv)
__attribute__nonnull__(pTHX_2)
- __attribute__nonnull__(pTHX_3);
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_4);
#define PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS \
assert(fullname); assert(gv); assert(cv)
@@ -5544,10 +5986,7 @@
STATIC OP* S_ref_array_or_hash(pTHX_ OP* cond);
STATIC OP* S_refkids(pTHX_ OP* o, I32 type);
STATIC bool S_scalar_mod_type(const OP *o, I32 type)
- __attribute__warn_unused_result__
- __attribute__nonnull__(1);
-#define PERL_ARGS_ASSERT_SCALAR_MOD_TYPE \
- assert(o)
+ __attribute__warn_unused_result__;
STATIC OP* S_scalarboolean(pTHX_ OP *o)
__attribute__nonnull__(pTHX_1);
@@ -5567,46 +6006,60 @@
#define PERL_ARGS_ASSERT_SIMPLIFY_SORT \
assert(o)
-STATIC OP* S_too_few_arguments(pTHX_ OP *o, const char* name)
+STATIC OP* S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS \
+#define PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV \
assert(o); assert(name)
-STATIC OP* S_too_many_arguments(pTHX_ OP *o, const char* name)
+STATIC OP* S_too_few_arguments_sv(pTHX_ OP *o, SV* namesv, U32 flags)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS \
+#define PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV \
+ assert(o); assert(namesv)
+
+STATIC OP* S_too_many_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV \
assert(o); assert(name)
-# if defined(USE_ITHREADS)
-STATIC void S_forget_pmop(pTHX_ PMOP *const o, U32 flags)
- __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_FORGET_PMOP \
- assert(o)
+STATIC OP* S_too_many_arguments_sv(pTHX_ OP *o, SV* namesv, U32 flags)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV \
+ assert(o); assert(namesv)
-# endif
#endif
+#if defined(PERL_IN_OP_C) || defined(PERL_IN_SV_C)
+PERL_CALLCONV void Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv, SV * const *new_const_svp)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_REPORT_REDEFINED_CV \
+ assert(name); assert(old_cv)
+
+#endif
#if defined(PERL_IN_PAD_C)
-STATIC PADOFFSET S_pad_add_name_sv(pTHX_ SV *namesv, const U32 flags, HV *typestash, HV *ourstash)
+STATIC PADOFFSET S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash)
__attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_PAD_ADD_NAME_SV \
+#define PERL_ARGS_ASSERT_PAD_ALLOC_NAME \
assert(namesv)
-STATIC void S_pad_check_dup(pTHX_ SV *name, const U32 flags, const HV *ourstash)
+STATIC void S_pad_check_dup(pTHX_ SV *name, U32 flags, const HV *ourstash)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_PAD_CHECK_DUP \
assert(name)
-STATIC PADOFFSET S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn, SV** out_capture, SV** out_name_sv, int *out_flags)
+STATIC PADOFFSET S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq, int warn, SV** out_capture, SV** out_name_sv, int *out_flags)
__attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_2)
- __attribute__nonnull__(pTHX_6)
- __attribute__nonnull__(pTHX_7);
+ __attribute__nonnull__(pTHX_4)
+ __attribute__nonnull__(pTHX_8)
+ __attribute__nonnull__(pTHX_9);
#define PERL_ARGS_ASSERT_PAD_FINDLEX \
- assert(name); assert(cv); assert(out_name_sv); assert(out_flags)
+ assert(namepv); assert(cv); assert(out_name_sv); assert(out_flags)
STATIC void S_pad_reset(pTHX);
#endif
@@ -5638,25 +6091,30 @@
assert(argv)
STATIC void S_init_predump_symbols(pTHX);
-STATIC void S_my_exit_jump(pTHX)
+STATIC SV* S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MAYBERELOCATE \
+ assert(dir)
+
+PERL_STATIC_NO_RET void S_minus_v(pTHX)
__attribute__noreturn__;
+PERL_STATIC_NO_RET void S_my_exit_jump(pTHX)
+ __attribute__noreturn__;
+
STATIC void S_nuke_stacks(pTHX);
-STATIC int S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript, PerlIO **rsfpp)
+STATIC PerlIO * S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
__attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_3)
- __attribute__nonnull__(pTHX_4);
+ __attribute__nonnull__(pTHX_3);
#define PERL_ARGS_ASSERT_OPEN_SCRIPT \
- assert(scriptname); assert(suidscript); assert(rsfpp)
+ assert(scriptname); assert(suidscript)
STATIC void* S_parse_body(pTHX_ char **env, XSINIT_t xsinit);
-STATIC void S_run_body(pTHX_ I32 oldscope)
+PERL_STATIC_NO_RET void S_run_body(pTHX_ I32 oldscope)
__attribute__noreturn__;
-STATIC void S_usage(pTHX_ const char *name)
- __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_USAGE \
- assert(name)
+PERL_STATIC_NO_RET void S_usage(pTHX)
+ __attribute__noreturn__;
#endif
#if defined(PERL_IN_PP_C)
@@ -5685,6 +6143,13 @@
#endif
#if defined(PERL_IN_PP_CTL_C)
+STATIC SV ** S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE \
+ assert(newsp); assert(sp); assert(mark)
+
STATIC PerlIO * S_check_type_and_open(pTHX_ SV *name)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
@@ -5696,17 +6161,17 @@
#define PERL_ARGS_ASSERT_DESTROY_MATCHER \
assert(matcher)
-STATIC OP* S_do_smartmatch(pTHX_ HV* seen_this, HV* seen_other);
+STATIC OP* S_do_smartmatch(pTHX_ HV* seen_this, HV* seen_other, const bool copied);
STATIC OP* S_docatch(pTHX_ OP *o)
__attribute__warn_unused_result__;
-STATIC bool S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq);
-STATIC OP* S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
+STATIC bool S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV* hh);
+STATIC OP* S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2)
- __attribute__nonnull__(pTHX_3)
- __attribute__nonnull__(pTHX_4);
+ __attribute__nonnull__(pTHX_5)
+ __attribute__nonnull__(pTHX_6);
#define PERL_ARGS_ASSERT_DOFINDLABEL \
assert(o); assert(label); assert(opstack); assert(oplimit)
@@ -5721,7 +6186,7 @@
STATIC I32 S_dopoptogiven(pTHX_ I32 startingblock)
__attribute__warn_unused_result__;
-STATIC I32 S_dopoptolabel(pTHX_ const char *label)
+STATIC I32 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_DOPOPTOLABEL \
@@ -5785,12 +6250,11 @@
#endif
#if defined(PERL_IN_PP_HOT_C)
-STATIC void S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
+STATIC void S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
__attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_2)
- __attribute__nonnull__(pTHX_3);
+ __attribute__nonnull__(pTHX_2);
#define PERL_ARGS_ASSERT_DO_ODDBALL \
- assert(hash); assert(relem); assert(firstrelem)
+ assert(oddkey); assert(firstkey)
STATIC SV* S_method_common(pTHX_ SV* meth, U32* hashp)
__attribute__warn_unused_result__
@@ -5958,13 +6422,24 @@
#endif
#if defined(PERL_IN_REGCOMP_C)
-STATIC void S_add_alternate(pTHX_ AV** alternate_ptr, U8* string, STRLEN len)
- __attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_ADD_ALTERNATE \
- assert(alternate_ptr); assert(string)
+STATIC void S__append_range_to_invlist(pTHX_ SV* const invlist, const UV start, const UV end)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST \
+ assert(invlist)
-PERL_STATIC_INLINE HV* S_add_cp_to_invlist(pTHX_ HV* invlist, const UV cp)
+PERL_STATIC_INLINE UV* S__invlist_array_init(pTHX_ SV* const invlist, const bool will_have_0)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT \
+ assert(invlist)
+
+STATIC SV* S__new_invlist_C_array(pTHX_ UV* list)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT__NEW_INVLIST_C_ARRAY \
+ assert(list)
+
+PERL_STATIC_INLINE SV* S_add_cp_to_invlist(pTHX_ SV* invlist, const UV cp)
__attribute__warn_unused_result__;
STATIC U32 S_add_data(struct RExC_state_t *pRExC_state, U32 n, const char *s)
@@ -5974,14 +6449,13 @@
#define PERL_ARGS_ASSERT_ADD_DATA \
assert(pRExC_state); assert(s)
-STATIC HV* S_add_range_to_invlist(pTHX_ HV* invlist, const UV start, const UV end)
- __attribute__warn_unused_result__;
+PERL_STATIC_INLINE void S_alloc_maybe_populate_EXACT(pTHX_ struct RExC_state_t *pRExC_state, regnode *node, I32 *flagp, STRLEN len, UV code_point)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_ALLOC_MAYBE_POPULATE_EXACT \
+ assert(pRExC_state); assert(node); assert(flagp)
-STATIC void S_checkposixcc(pTHX_ struct RExC_state_t *pRExC_state)
- __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_CHECKPOSIXCC \
- assert(pRExC_state)
-
STATIC void S_cl_and(struct regnode_charclass_class *cl, const struct regnode_charclass_class *and_with)
__attribute__nonnull__(1)
__attribute__nonnull__(2);
@@ -6013,69 +6487,134 @@
#define PERL_ARGS_ASSERT_CL_OR \
assert(pRExC_state); assert(cl); assert(or_with)
-PERL_STATIC_INLINE UV* S_invlist_array(pTHX_ HV* const invlist)
+PERL_STATIC_INLINE U8 S_compute_EXACTish(pTHX_ struct RExC_state_t *pRExC_state)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_COMPUTE_EXACTISH \
+ assert(pRExC_state)
+
+STATIC bool S_could_it_be_a_POSIX_class(pTHX_ struct RExC_state_t *pRExC_state)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_COULD_IT_BE_A_POSIX_CLASS \
+ assert(pRExC_state)
+
+PERL_STATIC_INLINE UV* S_get_invlist_iter_addr(pTHX_ SV* invlist)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GET_INVLIST_ITER_ADDR \
+ assert(invlist)
+
+PERL_STATIC_INLINE IV* S_get_invlist_previous_index_addr(pTHX_ SV* invlist)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GET_INVLIST_PREVIOUS_INDEX_ADDR \
+ assert(invlist)
+
+PERL_STATIC_INLINE UV* S_get_invlist_version_id_addr(pTHX_ SV* invlist)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GET_INVLIST_VERSION_ID_ADDR \
+ assert(invlist)
+
+PERL_STATIC_INLINE UV* S_get_invlist_zero_addr(pTHX_ SV* invlist)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GET_INVLIST_ZERO_ADDR \
+ assert(invlist)
+
+STATIC bool S_grok_bslash_N(pTHX_ struct RExC_state_t *pRExC_state, regnode** nodep, UV *valuep, I32 *flagp, U32 depth, bool in_char_class, const bool strict)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT_GROK_BSLASH_N \
+ assert(pRExC_state); assert(flagp)
+
+STATIC regnode* S_handle_regex_sets(pTHX_ struct RExC_state_t *pRExC_state, SV ** return_invlist, I32 *flagp, U32 depth, char * const oregcomp_parse)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_5);
+#define PERL_ARGS_ASSERT_HANDLE_REGEX_SETS \
+ assert(pRExC_state); assert(flagp); assert(oregcomp_parse)
+
+PERL_STATIC_INLINE UV* S_invlist_array(pTHX_ SV* const invlist)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_INVLIST_ARRAY \
assert(invlist)
-PERL_STATIC_INLINE void S_invlist_destroy(pTHX_ HV* const invlist)
+PERL_STATIC_INLINE SV* S_invlist_clone(pTHX_ SV* const invlist)
+ __attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_INVLIST_DESTROY \
+#define PERL_ARGS_ASSERT_INVLIST_CLONE \
assert(invlist)
-STATIC void S_invlist_extend(pTHX_ HV* const invlist, const UV len)
+STATIC void S_invlist_extend(pTHX_ SV* const invlist, const UV len)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_INVLIST_EXTEND \
assert(invlist)
-STATIC HV* S_invlist_intersection(pTHX_ HV* const a, HV* const b)
+PERL_STATIC_INLINE UV S_invlist_highest(pTHX_ SV* const invlist)
__attribute__warn_unused_result__
- __attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_INVLIST_INTERSECTION \
- assert(a); assert(b)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_INVLIST_HIGHEST \
+ assert(invlist)
-PERL_STATIC_INLINE UV S_invlist_len(pTHX_ HV* const invlist)
+PERL_STATIC_INLINE bool S_invlist_is_iterating(pTHX_ SV* const invlist)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_INVLIST_LEN \
+#define PERL_ARGS_ASSERT_INVLIST_IS_ITERATING \
assert(invlist)
-PERL_STATIC_INLINE UV S_invlist_max(pTHX_ HV* const invlist)
+PERL_STATIC_INLINE void S_invlist_iterfinish(pTHX_ SV* invlist)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_INVLIST_ITERFINISH \
+ assert(invlist)
+
+PERL_STATIC_INLINE void S_invlist_iterinit(pTHX_ SV* invlist)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_INVLIST_ITERINIT \
+ assert(invlist)
+
+STATIC bool S_invlist_iternext(pTHX_ SV* invlist, UV* start, UV* end)
__attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_INVLIST_ITERNEXT \
+ assert(invlist); assert(start); assert(end)
+
+PERL_STATIC_INLINE UV S_invlist_max(pTHX_ SV* const invlist)
+ __attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_INVLIST_MAX \
assert(invlist)
-PERL_STATIC_INLINE void S_invlist_set_len(pTHX_ HV* const invlist, const UV len)
+PERL_STATIC_INLINE IV S_invlist_previous_index(pTHX_ SV* const invlist)
+ __attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_INVLIST_PREVIOUS_INDEX \
+ assert(invlist)
+
+PERL_STATIC_INLINE void S_invlist_set_len(pTHX_ SV* const invlist, const UV len)
+ __attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_INVLIST_SET_LEN \
assert(invlist)
-PERL_STATIC_INLINE void S_invlist_set_max(pTHX_ HV* const invlist, const UV max)
+PERL_STATIC_INLINE void S_invlist_set_previous_index(pTHX_ SV* const invlist, const IV index)
__attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_INVLIST_SET_MAX \
+#define PERL_ARGS_ASSERT_INVLIST_SET_PREVIOUS_INDEX \
assert(invlist)
-PERL_STATIC_INLINE void S_invlist_trim(pTHX_ HV* const invlist)
+PERL_STATIC_INLINE void S_invlist_trim(pTHX_ SV* const invlist)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_INVLIST_TRIM \
assert(invlist)
-STATIC HV* S_invlist_union(pTHX_ HV* const a, HV* const b)
- __attribute__warn_unused_result__
+STATIC U32 S_join_exact(pTHX_ struct RExC_state_t *pRExC_state, regnode *scan, UV *min_subtract, bool *has_exactf_sharp_s, U32 flags, regnode *val, U32 depth)
__attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_INVLIST_UNION \
- assert(a); assert(b)
-
-STATIC U32 S_join_exact(pTHX_ struct RExC_state_t *pRExC_state, regnode *scan, I32 *min, U32 flags, regnode *val, U32 depth)
- __attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2)
- __attribute__nonnull__(pTHX_3);
+ __attribute__nonnull__(pTHX_3)
+ __attribute__nonnull__(pTHX_4);
#define PERL_ARGS_ASSERT_JOIN_EXACT \
- assert(pRExC_state); assert(scan); assert(min)
+ assert(pRExC_state); assert(scan); assert(min_subtract); assert(has_exactf_sharp_s)
STATIC I32 S_make_trie(pTHX_ struct RExC_state_t *pRExC_state, regnode *startbranch, regnode *first, regnode *last, regnode *tail, U32 word_count, U32 flags, U32 depth)
__attribute__nonnull__(pTHX_1)
@@ -6098,7 +6637,12 @@
#define PERL_ARGS_ASSERT_NEXTCHAR \
assert(pRExC_state)
-STATIC void S_re_croak2(pTHX_ const char* pat1, const char* pat2, ...)
+STATIC void S_parse_lparen_question_flags(pTHX_ struct RExC_state_t *pRExC_state)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_PARSE_LPAREN_QUESTION_FLAGS \
+ assert(pRExC_state)
+
+PERL_STATIC_NO_RET void S_re_croak2(pTHX_ const char* pat1, const char* pat2, ...)
__attribute__noreturn__
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
@@ -6111,11 +6655,6 @@
#define PERL_ARGS_ASSERT_REG \
assert(pRExC_state); assert(flagp)
-STATIC regnode* S_reg_namedseq(pTHX_ struct RExC_state_t *pRExC_state, UV *valuep, I32 *flagp, U32 depth)
- __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_REG_NAMEDSEQ \
- assert(pRExC_state)
-
STATIC regnode* S_reg_node(pTHX_ struct RExC_state_t *pRExC_state, U8 op)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_REG_NODE \
@@ -6153,10 +6692,11 @@
#define PERL_ARGS_ASSERT_REGBRANCH \
assert(pRExC_state); assert(flagp)
-STATIC regnode* S_regclass(pTHX_ struct RExC_state_t *pRExC_state, U32 depth)
- __attribute__nonnull__(pTHX_1);
+STATIC regnode* S_regclass(pTHX_ struct RExC_state_t *pRExC_state, I32 *flagp, U32 depth, const bool stop_at_1, bool allow_multi_fold, const bool silence_non_portable, SV** ret_invlist)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
#define PERL_ARGS_ASSERT_REGCLASS \
- assert(pRExC_state)
+ assert(pRExC_state); assert(flagp)
STATIC void S_reginsert(pTHX_ struct RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
__attribute__nonnull__(pTHX_1)
@@ -6164,6 +6704,13 @@
#define PERL_ARGS_ASSERT_REGINSERT \
assert(pRExC_state); assert(opnd)
+STATIC char * S_regpatws(struct RExC_state_t *pRExC_state, char *p, const bool recognize_comment)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2);
+#define PERL_ARGS_ASSERT_REGPATWS \
+ assert(pRExC_state); assert(p)
+
STATIC regnode* S_regpiece(pTHX_ struct RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
@@ -6170,7 +6717,7 @@
#define PERL_ARGS_ASSERT_REGPIECE \
assert(pRExC_state); assert(flagp)
-STATIC I32 S_regpposixcc(pTHX_ struct RExC_state_t *pRExC_state, I32 value)
+PERL_STATIC_INLINE I32 S_regpposixcc(pTHX_ struct RExC_state_t *pRExC_state, I32 value, const bool strict)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_REGPPOSIXCC \
assert(pRExC_state)
@@ -6202,35 +6749,169 @@
#define PERL_ARGS_ASSERT_SCAN_COMMIT \
assert(pRExC_state); assert(data); assert(minlenp)
-PERL_STATIC_INLINE U8 S_set_regclass_bit(pTHX_ struct RExC_state_t* pRExC_state, regnode* node, const U8 value, HV** invlist_ptr, AV** alternate_ptr)
+STATIC I32 S_study_chunk(pTHX_ struct RExC_state_t *pRExC_state, regnode **scanp, I32 *minlenp, I32 *deltap, regnode *last, struct scan_data_t *data, I32 stopparen, U8* recursed, struct regnode_charclass_class *and_withp, U32 flags, U32 depth)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3)
__attribute__nonnull__(pTHX_4)
__attribute__nonnull__(pTHX_5);
-#define PERL_ARGS_ASSERT_SET_REGCLASS_BIT \
- assert(pRExC_state); assert(node); assert(invlist_ptr); assert(alternate_ptr)
+#define PERL_ARGS_ASSERT_STUDY_CHUNK \
+ assert(pRExC_state); assert(scanp); assert(minlenp); assert(deltap); assert(last)
-STATIC U8 S_set_regclass_bit_fold(pTHX_ struct RExC_state_t *pRExC_state, regnode* node, const U8 value, HV** invlist_ptr, AV** alternate_ptr)
+#endif
+#if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_REGEXEC_C) || defined(PERL_IN_UTF8_C)
+PERL_STATIC_INLINE UV* S__get_invlist_len_addr(pTHX_ SV* invlist)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT__GET_INVLIST_LEN_ADDR \
+ assert(invlist)
+
+PERL_CALLCONV SV* Perl__get_swash_invlist(pTHX_ SV* const swash)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT__GET_SWASH_INVLIST \
+ assert(swash)
+
+PERL_STATIC_INLINE bool S__invlist_contains_cp(pTHX_ SV* const invlist, const UV cp)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT__INVLIST_CONTAINS_CP \
+ assert(invlist)
+
+PERL_CALLCONV SV* Perl__invlist_contents(pTHX_ SV* const invlist)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT__INVLIST_CONTENTS \
+ assert(invlist)
+
+PERL_STATIC_INLINE UV S__invlist_len(pTHX_ SV* const invlist)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT__INVLIST_LEN \
+ assert(invlist)
+
+PERL_CALLCONV IV Perl__invlist_search(pTHX_ SV* const invlist, const UV cp)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT__INVLIST_SEARCH \
+ assert(invlist)
+
+PERL_CALLCONV HV* Perl__swash_inversion_hash(pTHX_ SV* const swash)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT__SWASH_INVERSION_HASH \
+ assert(swash)
+
+#endif
+#if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_REGEXEC_C) || defined(PERL_IN_UTF8_C) || defined(PERL_IN_TOKE_C)
+PERL_CALLCONV SV* Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV* listsv, I32 minbits, I32 none, SV* invlist, U8* const flags_p)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2)
- __attribute__nonnull__(pTHX_4)
- __attribute__nonnull__(pTHX_5);
-#define PERL_ARGS_ASSERT_SET_REGCLASS_BIT_FOLD \
- assert(pRExC_state); assert(node); assert(invlist_ptr); assert(alternate_ptr)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT__CORE_SWASH_INIT \
+ assert(pkg); assert(name); assert(listsv)
-STATIC I32 S_study_chunk(pTHX_ struct RExC_state_t *pRExC_state, regnode **scanp, I32 *minlenp, I32 *deltap, regnode *last, struct scan_data_t *data, I32 stopparen, U8* recursed, struct regnode_charclass_class *and_withp, U32 flags, U32 depth)
+#endif
+#if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_TOKE_C)
+STATIC char* S_form_short_octal_warning(pTHX_ const char * const s, const STRLEN len)
+ __attribute__warn_unused_result__
+ __attribute__pure__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_FORM_SHORT_OCTAL_WARNING \
+ assert(s)
+
+STATIC char S_grok_bslash_c(pTHX_ const char source, const bool utf8, const bool output_warning)
+ __attribute__warn_unused_result__;
+
+STATIC bool S_grok_bslash_o(pTHX_ char** s, UV* uv, const char** error_msg, const bool output_warning, const bool strict, const bool silence_non_portable, const bool utf8)
+ __attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2)
- __attribute__nonnull__(pTHX_3)
- __attribute__nonnull__(pTHX_4)
- __attribute__nonnull__(pTHX_5);
-#define PERL_ARGS_ASSERT_STUDY_CHUNK \
- assert(pRExC_state); assert(scanp); assert(minlenp); assert(deltap); assert(last)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_GROK_BSLASH_O \
+ assert(s); assert(uv); assert(error_msg)
+PERL_STATIC_INLINE bool S_grok_bslash_x(pTHX_ char** s, UV* uv, const char** error_msg, const bool output_warning, const bool strict, const bool silence_non_portable, const bool utf8)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_GROK_BSLASH_X \
+ assert(s); assert(uv); assert(error_msg)
+
+PERL_STATIC_INLINE I32 S_regcurly(pTHX_ const char *s, const bool rbrace_must_be_escaped)
+ __attribute__warn_unused_result__
+ __attribute__pure__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_REGCURLY \
+ assert(s)
+
#endif
+#if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_UTF8_C)
+PERL_CALLCONV SV* Perl__add_range_to_invlist(pTHX_ SV* invlist, const UV start, const UV end)
+ __attribute__warn_unused_result__;
+
+/* PERL_CALLCONV void _invlist_intersection(pTHX_ SV* const a, SV* const b, SV** i)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3); */
+
+PERL_CALLCONV void Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, bool complement_b, SV** i)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT__INVLIST_INTERSECTION_MAYBE_COMPLEMENT_2ND \
+ assert(b); assert(i)
+
+PERL_CALLCONV void Perl__invlist_invert(pTHX_ SV* const invlist)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT__INVLIST_INVERT \
+ assert(invlist)
+
+PERL_CALLCONV void Perl__invlist_invert_prop(pTHX_ SV* const invlist)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT__INVLIST_INVERT_PROP \
+ assert(invlist)
+
+PERL_CALLCONV void Perl__invlist_populate_swatch(pTHX_ SV* const invlist, const UV start, const UV end, U8* swatch)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT__INVLIST_POPULATE_SWATCH \
+ assert(invlist); assert(swatch)
+
+/* PERL_CALLCONV void _invlist_subtract(pTHX_ SV* const a, SV* const b, SV** result)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3); */
+
+/* PERL_CALLCONV void _invlist_union(pTHX_ SV* const a, SV* const b, SV** output)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3); */
+
+PERL_CALLCONV void Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, bool complement_b, SV** output)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT__INVLIST_UNION_MAYBE_COMPLEMENT_2ND \
+ assert(b); assert(output)
+
+PERL_CALLCONV SV* Perl__new_invlist(pTHX_ IV initial_size)
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV SV* Perl__swash_to_invlist(pTHX_ SV* const swash)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT__SWASH_TO_INVLIST \
+ assert(swash)
+
+#endif
#if defined(PERL_IN_REGEXEC_C)
-STATIC char* S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, const char *strend, regmatch_info *reginfo)
+STATIC SV* S_core_regclass_swash(pTHX_ const regexp *prog, const struct regnode *node, bool doinit, SV **listsvp)
__attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_CORE_REGCLASS_SWASH \
+ assert(node)
+
+STATIC char* S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, const char *strend, regmatch_info *reginfo, bool is_utf_pat)
+ __attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2)
__attribute__nonnull__(pTHX_3)
@@ -6238,6 +6919,15 @@
#define PERL_ARGS_ASSERT_FIND_BYCLASS \
assert(prog); assert(c); assert(s); assert(strend)
+STATIC bool S_isFOO_lc(pTHX_ const U8 classnum, const U8 character)
+ __attribute__warn_unused_result__;
+
+STATIC bool S_isFOO_utf8_lc(pTHX_ const U8 classnum, const U8* character)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_ISFOO_UTF8_LC \
+ assert(character)
+
STATIC I32 S_reg_check_named_buff_matched(pTHX_ const regexp *rex, const regnode *scan)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1)
@@ -6245,12 +6935,17 @@
#define PERL_ARGS_ASSERT_REG_CHECK_NAMED_BUFF_MATCHED \
assert(rex); assert(scan)
-STATIC char* S_regcppop(pTHX_ const regexp *rex)
+STATIC void S_regcppop(pTHX_ regexp *rex, U32 *maxopenparen_p)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_REGCPPOP \
+ assert(rex); assert(maxopenparen_p)
+
+STATIC CHECKPOINT S_regcppush(pTHX_ const regexp *rex, I32 parenfloor, U32 maxopenparen)
__attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_REGCPPOP \
+#define PERL_ARGS_ASSERT_REGCPPUSH \
assert(rex)
-STATIC CHECKPOINT S_regcppush(pTHX_ I32 parenfloor);
STATIC U8* S_reghop3(U8 *s, I32 off, const U8 *lim)
__attribute__warn_unused_result__
__attribute__nonnull__(1)
@@ -6265,7 +6960,7 @@
#define PERL_ARGS_ASSERT_REGHOPMAYBE3 \
assert(s); assert(lim)
-STATIC bool S_reginclass(pTHX_ const regexp * const prog, const regnode * const n, const U8 * const p, STRLEN *lenp, bool const do_utf8sv_is_utf8)
+STATIC bool S_reginclass(pTHX_ regexp * const prog, const regnode * const n, const U8 * const p, bool const utf8_target)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_2)
__attribute__nonnull__(pTHX_3);
@@ -6272,28 +6967,30 @@
#define PERL_ARGS_ASSERT_REGINCLASS \
assert(n); assert(p)
-STATIC I32 S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
+STATIC I32 S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_2);
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
#define PERL_ARGS_ASSERT_REGMATCH \
- assert(reginfo); assert(prog)
+ assert(reginfo); assert(startpos); assert(prog)
-STATIC I32 S_regrepeat(pTHX_ const regexp *prog, const regnode *p, I32 max, int depth)
+STATIC I32 S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, I32 max, int depth, bool is_utf8_pat)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_2);
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
#define PERL_ARGS_ASSERT_REGREPEAT \
- assert(prog); assert(p)
+ assert(prog); assert(startposp); assert(p)
-STATIC I32 S_regtry(pTHX_ regmatch_info *reginfo, char **startpos)
+STATIC I32 S_regtry(pTHX_ regmatch_info *reginfo, char **startposp)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
#define PERL_ARGS_ASSERT_REGTRY \
- assert(reginfo); assert(startpos)
+ assert(reginfo); assert(startposp)
-STATIC void S_to_byte_substr(pTHX_ regexp * prog)
+STATIC bool S_to_byte_substr(pTHX_ regexp * prog)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_TO_BYTE_SUBSTR \
assert(prog)
@@ -6431,7 +7128,7 @@
#define PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY \
assert(start); assert(send)
-STATIC void S_sv_unglob(pTHX_ SV *const sv)
+PERL_STATIC_INLINE void S_sv_unglob(pTHX_ SV *const sv, U32 flags)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_SV_UNGLOB \
assert(sv)
@@ -6455,9 +7152,6 @@
#define PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE \
assert(sv); assert(mgp)
-STATIC SV * S_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ, const SV *const keyname, I32 aindex, int subscript_type)
- __attribute__warn_unused_result__;
-
STATIC I32 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_VISIT \
@@ -6494,6 +7188,11 @@
# endif
#endif
+#if defined(PERL_IN_SV_C) || defined (PERL_IN_OP_C)
+PERL_CALLCONV SV * Perl_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ, const SV *const keyname, I32 aindex, int subscript_type)
+ __attribute__warn_unused_result__;
+
+#endif
#if defined(PERL_IN_TOKE_C)
STATIC int S_ao(pTHX_ int toketype);
STATIC void S_check_uni(pTHX);
@@ -6522,6 +7221,7 @@
#define PERL_ARGS_ASSERT_FORCE_IDENT \
assert(s)
+STATIC void S_force_ident_maybe_lex(pTHX_ char pit);
STATIC void S_force_next(pTHX_ I32 type);
STATIC char* S_force_strict_version(pTHX_ char *s)
__attribute__nonnull__(pTHX_1);
@@ -6538,6 +7238,13 @@
#define PERL_ARGS_ASSERT_FORCE_WORD \
assert(start)
+PERL_STATIC_INLINE SV* S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME \
+ assert(s); assert(e)
+
STATIC void S_incline(pTHX_ const char *s)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_INCLINE \
@@ -6558,7 +7265,7 @@
#define PERL_ARGS_ASSERT_LOP \
assert(s)
-STATIC void S_missingterm(pTHX_ char *s)
+PERL_STATIC_NO_RET void S_missingterm(pTHX_ char *s)
__attribute__noreturn__;
STATIC SV* S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen, SV *sv, SV *pv, const char *type, STRLEN typelen)
@@ -6572,6 +7279,14 @@
#define PERL_ARGS_ASSERT_NO_OP \
assert(what)
+STATIC void S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, bool is_utf8)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_PARSE_IDENT \
+ assert(s); assert(d); assert(e)
+
+STATIC int S_pending_ident(pTHX);
STATIC void S_readpipe_override(pTHX);
STATIC char* S_scan_const(pTHX_ char *start)
__attribute__warn_unused_result__
@@ -6610,7 +7325,7 @@
#define PERL_ARGS_ASSERT_SCAN_PAT \
assert(start)
-STATIC char* S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
+STATIC char* S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse, bool deprecate_escaped_matching)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_SCAN_STR \
@@ -6668,7 +7383,7 @@
assert(sv)
STATIC void S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len);
-STATIC int S_yywarn(pTHX_ const char *const s)
+STATIC int S_yywarn(pTHX_ const char *const s, U32 flags)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_YYWARN \
assert(s)
@@ -6694,7 +7409,7 @@
# endif
#endif
#if defined(PERL_IN_UNIVERSAL_C)
-STATIC bool S_isa_lookup(pTHX_ HV *stash, const char * const name)
+STATIC bool S_isa_lookup(pTHX_ HV *stash, const char * const name, STRLEN len, U32 flags)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
#define PERL_ARGS_ASSERT_ISA_LOOKUP \
@@ -6702,13 +7417,21 @@
#endif
#if defined(PERL_IN_UTF8_C)
-STATIC STRLEN S_is_utf8_char_slow(const U8 *s, const STRLEN len)
+STATIC UV S_check_locale_boundary_crossing(pTHX_ 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);
+#define PERL_ARGS_ASSERT_CHECK_LOCALE_BOUNDARY_CROSSING \
+ assert(p); assert(ustrp); assert(lenp)
+
+PERL_STATIC_INLINE STRLEN S_is_utf8_char_slow(const U8 *s, const STRLEN len)
+ __attribute__warn_unused_result__
__attribute__nonnull__(1);
#define PERL_ARGS_ASSERT_IS_UTF8_CHAR_SLOW \
assert(s)
-STATIC bool S_is_utf8_common(pTHX_ const U8 *const p, SV **swash, const char * const swashname)
+PERL_STATIC_INLINE bool S_is_utf8_common(pTHX_ const U8 *const p, SV **swash, const char * const swashname)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2)
@@ -6716,13 +7439,32 @@
#define PERL_ARGS_ASSERT_IS_UTF8_COMMON \
assert(p); assert(swash); assert(swashname)
-STATIC SV* S_swash_get(pTHX_ SV* swash, UV start, UV span)
+STATIC SV* S_swatch_get(pTHX_ SV* swash, UV start, UV span)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_SWASH_GET \
+#define PERL_ARGS_ASSERT_SWATCH_GET \
assert(swash)
+STATIC U8 S_to_lower_latin1(pTHX_ const U8 c, U8 *p, STRLEN *lenp)
+ __attribute__warn_unused_result__;
+
#endif
+#if defined(PERL_IN_UTF8_C) || defined(PERL_IN_PP_C)
+PERL_CALLCONV UV Perl__to_upper_title_latin1(pTHX_ const U8 c, U8 *p, STRLEN *lenp, const char S_or_s)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT__TO_UPPER_TITLE_LATIN1 \
+ assert(p); assert(lenp)
+
+#endif
+#if defined(PERL_IN_UTF8_C) || defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_REGEXEC_C)
+PERL_CALLCONV UV Perl__to_fold_latin1(pTHX_ const U8 c, U8 *p, STRLEN *lenp, const bool flags)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT__TO_FOLD_LATIN1 \
+ assert(p); assert(lenp)
+
+#endif
#if defined(PERL_IN_UTIL_C)
STATIC bool S_ckwarn_common(pTHX_ U32 w);
STATIC const COP* S_closest_cop(pTHX_ const COP *cop, const OP *o)
@@ -6737,9 +7479,6 @@
#define PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS \
assert(ex)
-STATIC char * S_write_no_mem(pTHX)
- __attribute__noreturn__;
-
# if defined(PERL_MEM_LOG) && !defined(PERL_MEM_LOG_NOIMPL)
STATIC void S_mem_log_common(enum mem_log_type mlt, const UV n, const UV typesize, const char *type_name, const SV *sv, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
__attribute__nonnull__(4)
@@ -6773,9 +7512,6 @@
#define PERL_ARGS_ASSERT_NEWMADSV \
assert(sv)
-PERL_CALLCONV OP * Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
- __attribute__noreturn__;
-
PERL_CALLCONV TOKEN* Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop);
PERL_CALLCONV void Perl_op_getmad(pTHX_ OP* from, OP* o, char slot);
PERL_CALLCONV void Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot);
@@ -6948,27 +7684,9 @@
#if defined(PERL_NEED_MY_LETOHS)
PERL_CALLCONV short Perl_my_letohs(short n);
#endif
-#if defined(PERL_OLD_COPY_ON_WRITE)
-PERL_CALLCONV SV* Perl_sv_setsv_cow(pTHX_ SV* dstr, SV* sstr)
- __attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_SV_SETSV_COW \
- assert(sstr)
-
-#endif
#if defined(PERL_USES_PL_PIDSTATUS) && defined(PERL_IN_UTIL_C)
STATIC void S_pidgone(pTHX_ Pid_t pid, int status);
#endif
-#if defined(PL_OP_SLAB_ALLOC)
-PERL_CALLCONV void* Perl_Slab_Alloc(pTHX_ size_t sz)
- __attribute__malloc__
- __attribute__warn_unused_result__;
-
-PERL_CALLCONV void Perl_Slab_Free(pTHX_ void *op)
- __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_SLAB_FREE \
- assert(op)
-
-#endif
#if defined(UNLINK_ALL_VERSIONS)
PERL_CALLCONV I32 Perl_unlnk(pTHX_ const char* f)
__attribute__nonnull__(pTHX_1);
@@ -6977,6 +7695,11 @@
#endif
#if defined(USE_ITHREADS)
+PERL_CALLCONV PADOFFSET Perl_alloccopstash(pTHX_ HV *hv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_ALLOCCOPSTASH \
+ assert(hv)
+
PERL_CALLCONV void* Perl_any_dup(pTHX_ void* v, const PerlInterpreter* proto_perl)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_2);
@@ -7050,7 +7773,7 @@
#define PERL_ARGS_ASSERT_NEWPADOP \
assert(sv)
-PERL_CALLCONV AV* Perl_padlist_dup(pTHX_ AV *const srcpad, CLONE_PARAMS *const param)
+PERL_CALLCONV PADLIST * Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_2);
#define PERL_ARGS_ASSERT_PADLIST_DUP \
@@ -7183,15 +7906,13 @@
assert(vbuf)
#endif
-#if defined(USE_REENTRANT_API)
-PERL_CALLCONV void Perl_reentrant_free(pTHX);
-PERL_CALLCONV void Perl_reentrant_init(pTHX);
-PERL_CALLCONV void* Perl_reentrant_retry(const char *f, ...)
+#if defined(WIN32)
+PERL_CALLCONV_NO_RET void win32_croak_not_implemented(const char * fname)
+ __attribute__noreturn__
__attribute__nonnull__(1);
-#define PERL_ARGS_ASSERT_REENTRANT_RETRY \
- assert(f)
+#define PERL_ARGS_ASSERT_WIN32_CROAK_NOT_IMPLEMENTED \
+ assert(fname)
-PERL_CALLCONV void Perl_reentrant_size(pTHX);
#endif
#if defined(WIN32) || defined(__SYMBIAN32__) || defined(VMS)
PERL_CALLCONV int Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
@@ -7211,6 +7932,14 @@
assert(cmd)
#endif
+#if defined(_MSC_VER)
+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)
+
+#endif
#ifdef PERL_CORE
# include "pp_proto.h"
#endif
Property changes on: trunk/contrib/perl/proto.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.4
\ No newline at end of property
Modified: trunk/contrib/perl/reentr.c
===================================================================
--- trunk/contrib/perl/reentr.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/reentr.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -300,10 +300,10 @@
void*
Perl_reentrant_retry(const char *f, ...)
{
- dTHX;
void *retptr = NULL;
va_list ap;
#ifdef USE_REENTRANT_API
+ dTHX;
/* Easier to special case this here than in embed.pl. (Look at what it
generates for proto.h) */
PERL_ARGS_ASSERT_REENTRANT_RETRY;
Property changes on: trunk/contrib/perl/reentr.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Index: trunk/contrib/perl/reentr.h
===================================================================
--- trunk/contrib/perl/reentr.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/reentr.h 2013-12-02 21:18:17 UTC (rev 6438)
Property changes on: trunk/contrib/perl/reentr.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/regcharclass.h
===================================================================
--- trunk/contrib/perl/regcharclass.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/regcharclass.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -2,7 +2,7 @@
*
* regcharclass.h
*
- * Copyright (C) 2007 by Larry Wall and others
+ * Copyright (C) 2007, 2011 by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
@@ -12,17 +12,15 @@
* Any changes made here will be lost!
*/
+
+#ifndef H_REGCHARCLASS /* Guard against nested #includes */
+#define H_REGCHARCLASS 1
+
/*
LNBREAK: Line Break: \R
"\x0D\x0A" # CRLF - Network (Windows) line ending
- 0x0A # LF | LINE FEED
- 0x0B # VT | VERTICAL TAB
- 0x0C # FF | FORM FEED
- 0x0D # CR | CARRIAGE RETURN
- 0x85 # NEL | NEXT LINE
- 0x2028 # LINE SEPARATOR
- 0x2029 # PARAGRAPH SEPARATOR
+ \p{VertSpace}
*/
/*** GENERATED CODE ***/
#define is_LNBREAK(s,is_utf8) \
@@ -32,9 +30,7 @@
: ( is_utf8 ) ? \
( ( 0xC2 == ((U8*)s)[0] ) ? \
( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \
- : ( 0xE2 == ((U8*)s)[0] ) ? \
- ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0xA8 == ((U8*)s)[2] || 0xA9 == ((U8*)s)[2] ) ) ? 3 : 0 )\
- : 0 ) \
+ : ( ( ( 0xE2 == ((U8*)s)[0] ) && ( 0x80 == ((U8*)s)[1] ) ) && ( ( ((U8*)s)[2] & 0xFE ) == 0xA8 ) ) ? 3 : 0 )\
: ( 0x85 == ((U8*)s)[0] ) )
/*** GENERATED CODE ***/
@@ -46,9 +42,7 @@
: ( is_utf8 ) ? \
( ( 0xC2 == ((U8*)s)[0] ) ? \
( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \
- : ( 0xE2 == ((U8*)s)[0] ) ? \
- ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0xA8 == ((U8*)s)[2] || 0xA9 == ((U8*)s)[2] ) ) ? 3 : 0 )\
- : 0 ) \
+ : ( ( ( 0xE2 == ((U8*)s)[0] ) && ( 0x80 == ((U8*)s)[1] ) ) && ( ( ((U8*)s)[2] & 0xFE ) == 0xA8 ) ) ? 3 : 0 )\
: ( 0x85 == ((U8*)s)[0] ) ) \
: ((e)-(s) > 1) ? \
( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0C ) ? 1 \
@@ -71,9 +65,7 @@
( ( 0x0A == ((U8*)s)[1] ) ? 2 : 1 ) \
: ( 0xC2 == ((U8*)s)[0] ) ? \
( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \
-: ( 0xE2 == ((U8*)s)[0] ) ? \
- ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0xA8 == ((U8*)s)[2] || 0xA9 == ((U8*)s)[2] ) ) ? 3 : 0 )\
-: 0 )
+: ( ( ( 0xE2 == ((U8*)s)[0] ) && ( 0x80 == ((U8*)s)[1] ) ) && ( ( ((U8*)s)[2] & 0xFE ) == 0xA8 ) ) ? 3 : 0 )
/*** GENERATED CODE ***/
#define is_LNBREAK_utf8_safe(s,e) \
@@ -83,16 +75,12 @@
( ( 0x0A == ((U8*)s)[1] ) ? 2 : 1 ) \
: ( 0xC2 == ((U8*)s)[0] ) ? \
( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \
- : ( 0xE2 == ((U8*)s)[0] ) ? \
- ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0xA8 == ((U8*)s)[2] || 0xA9 == ((U8*)s)[2] ) ) ? 3 : 0 )\
- : 0 ) \
+ : ( ( ( 0xE2 == ((U8*)s)[0] ) && ( 0x80 == ((U8*)s)[1] ) ) && ( ( ((U8*)s)[2] & 0xFE ) == 0xA8 ) ) ? 3 : 0 )\
: ((e)-(s) > 1) ? \
( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0C ) ? 1 \
: ( 0x0D == ((U8*)s)[0] ) ? \
( ( 0x0A == ((U8*)s)[1] ) ? 2 : 1 ) \
- : ( 0xC2 == ((U8*)s)[0] ) ? \
- ( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \
- : 0 ) \
+ : ( ( 0xC2 == ((U8*)s)[0] ) && ( 0x85 == ((U8*)s)[1] ) ) ? 2 : 0 ) \
: ((e)-(s) > 0) ? \
( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) \
: 0 )
@@ -99,18 +87,18 @@
/*** GENERATED CODE ***/
#define is_LNBREAK_latin1(s) \
-( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0C ) ? 1 \
+( ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0C ) || 0x85 == ((U8*)s)[0] ) ? 1\
: ( 0x0D == ((U8*)s)[0] ) ? \
( ( 0x0A == ((U8*)s)[1] ) ? 2 : 1 ) \
-: ( 0x85 == ((U8*)s)[0] ) )
+: 0 )
/*** GENERATED CODE ***/
#define is_LNBREAK_latin1_safe(s,e) \
( ((e)-(s) > 1) ? \
- ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0C ) ? 1 \
+ ( ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0C ) || 0x85 == ((U8*)s)[0] ) ? 1\
: ( 0x0D == ((U8*)s)[0] ) ? \
( ( 0x0A == ((U8*)s)[1] ) ? 2 : 1 ) \
- : ( 0x85 == ((U8*)s)[0] ) ) \
+ : 0 ) \
: ((e)-(s) > 0) ? \
( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) || 0x85 == ((U8*)s)[0] )\
: 0 )
@@ -118,25 +106,7 @@
/*
HORIZWS: Horizontal Whitespace: \h \H
- 0x09 # HT
- 0x20 # SPACE
- 0xa0 # NBSP
- 0x1680 # OGHAM SPACE MARK
- 0x180e # MONGOLIAN VOWEL SEPARATOR
- 0x2000 # EN QUAD
- 0x2001 # EM QUAD
- 0x2002 # EN SPACE
- 0x2003 # EM SPACE
- 0x2004 # THREE-PER-EM SPACE
- 0x2005 # FOUR-PER-EM SPACE
- 0x2006 # SIX-PER-EM SPACE
- 0x2007 # FIGURE SPACE
- 0x2008 # PUNCTUATION SPACE
- 0x2009 # THIN SPACE
- 0x200A # HAIR SPACE
- 0x202f # NARROW NO-BREAK SPACE
- 0x205f # MEDIUM MATHEMATICAL SPACE
- 0x3000 # IDEOGRAPHIC SPACE
+ \p{HorizSpace}
*/
/*** GENERATED CODE ***/
#define is_HORIZWS(s,is_utf8) \
@@ -147,18 +117,12 @@
: ( 0xE1 == ((U8*)s)[0] ) ? \
( ( 0x9A == ((U8*)s)[1] ) ? \
( ( 0x80 == ((U8*)s)[2] ) ? 3 : 0 ) \
- : ( 0xA0 == ((U8*)s)[1] ) ? \
- ( ( 0x8E == ((U8*)s)[2] ) ? 3 : 0 ) \
- : 0 ) \
+ : ( ( 0xA0 == ((U8*)s)[1] ) && ( 0x8E == ((U8*)s)[2] ) ) ? 3 : 0 ) \
: ( 0xE2 == ((U8*)s)[0] ) ? \
( ( 0x80 == ((U8*)s)[1] ) ? \
( ( ( 0x80 <= ((U8*)s)[2] && ((U8*)s)[2] <= 0x8A ) || 0xAF == ((U8*)s)[2] ) ? 3 : 0 )\
- : ( 0x81 == ((U8*)s)[1] ) ? \
- ( ( 0x9F == ((U8*)s)[2] ) ? 3 : 0 ) \
- : 0 ) \
- : ( 0xE3 == ((U8*)s)[0] ) ? \
- ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0x80 == ((U8*)s)[2] ) ) ? 3 : 0 ) \
- : 0 ) \
+ : ( ( 0x81 == ((U8*)s)[1] ) && ( 0x9F == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : ( ( ( 0xE3 == ((U8*)s)[0] ) && ( 0x80 == ((U8*)s)[1] ) ) && ( 0x80 == ((U8*)s)[2] ) ) ? 3 : 0 )\
: ( 0xA0 == ((U8*)s)[0] ) )
/*** GENERATED CODE ***/
@@ -171,18 +135,12 @@
: ( 0xE1 == ((U8*)s)[0] ) ? \
( ( 0x9A == ((U8*)s)[1] ) ? \
( ( 0x80 == ((U8*)s)[2] ) ? 3 : 0 ) \
- : ( 0xA0 == ((U8*)s)[1] ) ? \
- ( ( 0x8E == ((U8*)s)[2] ) ? 3 : 0 ) \
- : 0 ) \
+ : ( ( 0xA0 == ((U8*)s)[1] ) && ( 0x8E == ((U8*)s)[2] ) ) ? 3 : 0 )\
: ( 0xE2 == ((U8*)s)[0] ) ? \
( ( 0x80 == ((U8*)s)[1] ) ? \
( ( ( 0x80 <= ((U8*)s)[2] && ((U8*)s)[2] <= 0x8A ) || 0xAF == ((U8*)s)[2] ) ? 3 : 0 )\
- : ( 0x81 == ((U8*)s)[1] ) ? \
- ( ( 0x9F == ((U8*)s)[2] ) ? 3 : 0 ) \
- : 0 ) \
- : ( 0xE3 == ((U8*)s)[0] ) ? \
- ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0x80 == ((U8*)s)[2] ) ) ? 3 : 0 )\
- : 0 ) \
+ : ( ( 0x81 == ((U8*)s)[1] ) && ( 0x9F == ((U8*)s)[2] ) ) ? 3 : 0 )\
+ : ( ( ( 0xE3 == ((U8*)s)[0] ) && ( 0x80 == ((U8*)s)[1] ) ) && ( 0x80 == ((U8*)s)[2] ) ) ? 3 : 0 )\
: ( 0xA0 == ((U8*)s)[0] ) ) \
: ((e)-(s) > 1) ? \
( ( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] ) ? 1 \
@@ -204,18 +162,12 @@
: ( 0xE1 == ((U8*)s)[0] ) ? \
( ( 0x9A == ((U8*)s)[1] ) ? \
( ( 0x80 == ((U8*)s)[2] ) ? 3 : 0 ) \
- : ( 0xA0 == ((U8*)s)[1] ) ? \
- ( ( 0x8E == ((U8*)s)[2] ) ? 3 : 0 ) \
- : 0 ) \
+ : ( ( 0xA0 == ((U8*)s)[1] ) && ( 0x8E == ((U8*)s)[2] ) ) ? 3 : 0 ) \
: ( 0xE2 == ((U8*)s)[0] ) ? \
( ( 0x80 == ((U8*)s)[1] ) ? \
- ( ( ( 0x80 <= ((U8*)s)[2] && ((U8*)s)[2] <= 0x8A ) || 0xAF == ((U8*)s)[2] ) ? 3 : 0 )\
- : ( 0x81 == ((U8*)s)[1] ) ? \
- ( ( 0x9F == ((U8*)s)[2] ) ? 3 : 0 ) \
- : 0 ) \
-: ( 0xE3 == ((U8*)s)[0] ) ? \
- ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0x80 == ((U8*)s)[2] ) ) ? 3 : 0 ) \
-: 0 )
+ ( ( ( ((U8*)s)[2] <= 0x8A ) || 0xAF == ((U8*)s)[2] ) ? 3 : 0 ) \
+ : ( ( 0x81 == ((U8*)s)[1] ) && ( 0x9F == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+: ( ( ( 0xE3 == ((U8*)s)[0] ) && ( 0x80 == ((U8*)s)[1] ) ) && ( 0x80 == ((U8*)s)[2] ) ) ? 3 : 0 )
/*** GENERATED CODE ***/
#define is_HORIZWS_utf8_safe(s,e) \
@@ -226,23 +178,15 @@
: ( 0xE1 == ((U8*)s)[0] ) ? \
( ( 0x9A == ((U8*)s)[1] ) ? \
( ( 0x80 == ((U8*)s)[2] ) ? 3 : 0 ) \
- : ( 0xA0 == ((U8*)s)[1] ) ? \
- ( ( 0x8E == ((U8*)s)[2] ) ? 3 : 0 ) \
- : 0 ) \
+ : ( ( 0xA0 == ((U8*)s)[1] ) && ( 0x8E == ((U8*)s)[2] ) ) ? 3 : 0 ) \
: ( 0xE2 == ((U8*)s)[0] ) ? \
( ( 0x80 == ((U8*)s)[1] ) ? \
( ( ( 0x80 <= ((U8*)s)[2] && ((U8*)s)[2] <= 0x8A ) || 0xAF == ((U8*)s)[2] ) ? 3 : 0 )\
- : ( 0x81 == ((U8*)s)[1] ) ? \
- ( ( 0x9F == ((U8*)s)[2] ) ? 3 : 0 ) \
- : 0 ) \
- : ( 0xE3 == ((U8*)s)[0] ) ? \
- ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0x80 == ((U8*)s)[2] ) ) ? 3 : 0 ) \
- : 0 ) \
+ : ( ( 0x81 == ((U8*)s)[1] ) && ( 0x9F == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : ( ( ( 0xE3 == ((U8*)s)[0] ) && ( 0x80 == ((U8*)s)[1] ) ) && ( 0x80 == ((U8*)s)[2] ) ) ? 3 : 0 )\
: ((e)-(s) > 1) ? \
( ( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] ) ? 1 \
- : ( 0xC2 == ((U8*)s)[0] ) ? \
- ( ( 0xA0 == ((U8*)s)[1] ) ? 2 : 0 ) \
- : 0 ) \
+ : ( ( 0xC2 == ((U8*)s)[0] ) && ( 0xA0 == ((U8*)s)[1] ) ) ? 2 : 0 ) \
: ((e)-(s) > 0) ? \
( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] ) \
: 0 )
@@ -249,15 +193,41 @@
/*** GENERATED CODE ***/
#define is_HORIZWS_latin1(s) \
-( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] || 0xA0 == ((U8*)s)[0] )
+( ((U8*)s)[0] == 0x09 || ( ( ((U8*)s)[0] & 0x7F ) == 0x20 ) )
/*** GENERATED CODE ***/
#define is_HORIZWS_latin1_safe(s,e) \
( ((e)-(s) > 0) ? \
- ( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] || 0xA0 == ((U8*)s)[0] ) \
+ ( ((U8*)s)[0] == 0x09 || ( ( ((U8*)s)[0] & 0x7F ) == 0x20 ) ) \
: 0 )
/*** GENERATED CODE ***/
+#define is_HORIZWS_high(s) \
+( ( 0xE1 == ((U8*)s)[0] ) ? \
+ ( ( 0x9A == ((U8*)s)[1] ) ? \
+ ( ( 0x80 == ((U8*)s)[2] ) ? 3 : 0 ) \
+ : ( ( 0xA0 == ((U8*)s)[1] ) && ( 0x8E == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+: ( 0xE2 == ((U8*)s)[0] ) ? \
+ ( ( 0x80 == ((U8*)s)[1] ) ? \
+ ( ( ( ((U8*)s)[2] <= 0x8A ) || 0xAF == ((U8*)s)[2] ) ? 3 : 0 ) \
+ : ( ( 0x81 == ((U8*)s)[1] ) && ( 0x9F == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+: ( ( ( 0xE3 == ((U8*)s)[0] ) && ( 0x80 == ((U8*)s)[1] ) ) && ( 0x80 == ((U8*)s)[2] ) ) ? 3 : 0 )
+
+/*** GENERATED CODE ***/
+#define is_HORIZWS_high_safe(s,e) \
+( ((e)-(s) > 2) ? \
+ ( ( 0xE1 == ((U8*)s)[0] ) ? \
+ ( ( 0x9A == ((U8*)s)[1] ) ? \
+ ( ( 0x80 == ((U8*)s)[2] ) ? 3 : 0 ) \
+ : ( ( 0xA0 == ((U8*)s)[1] ) && ( 0x8E == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : ( 0xE2 == ((U8*)s)[0] ) ? \
+ ( ( 0x80 == ((U8*)s)[1] ) ? \
+ ( ( ( 0x80 <= ((U8*)s)[2] && ((U8*)s)[2] <= 0x8A ) || 0xAF == ((U8*)s)[2] ) ? 3 : 0 )\
+ : ( ( 0x81 == ((U8*)s)[1] ) && ( 0x9F == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : ( ( ( 0xE3 == ((U8*)s)[0] ) && ( 0x80 == ((U8*)s)[1] ) ) && ( 0x80 == ((U8*)s)[2] ) ) ? 3 : 0 )\
+: 0 )
+
+/*** GENERATED CODE ***/
#define is_HORIZWS_cp(cp) \
( 0x09 == cp || ( 0x09 < cp && \
( 0x20 == cp || ( 0x20 < cp && \
@@ -266,19 +236,20 @@
( 0x180E == cp || ( 0x180E < cp && \
( ( 0x2000 <= cp && cp <= 0x200A ) || ( 0x200A < cp && \
( 0x202F == cp || ( 0x202F < cp && \
-( 0x205F == cp || ( 0x205F < cp && \
-0x3000 == cp ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) )
+( 0x205F == cp || 0x3000 == cp ) ) ) ) ) ) ) ) ) ) ) ) ) ) )
+/*** GENERATED CODE ***/
+#define is_HORIZWS_cp_high(cp) \
+( 0x1680 == cp || ( 0x1680 < cp && \
+( 0x180E == cp || ( 0x180E < cp && \
+( ( 0x2000 <= cp && cp <= 0x200A ) || ( 0x200A < cp && \
+( 0x202F == cp || ( 0x202F < cp && \
+( 0x205F == cp || 0x3000 == cp ) ) ) ) ) ) ) ) )
+
/*
VERTWS: Vertical Whitespace: \v \V
- 0x0A # LF
- 0x0B # VT
- 0x0C # FF
- 0x0D # CR
- 0x85 # NEL
- 0x2028 # LINE SEPARATOR
- 0x2029 # PARAGRAPH SEPARATOR
+ \p{VertSpace}
*/
/*** GENERATED CODE ***/
#define is_VERTWS(s,is_utf8) \
@@ -286,9 +257,7 @@
: ( is_utf8 ) ? \
( ( 0xC2 == ((U8*)s)[0] ) ? \
( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \
- : ( 0xE2 == ((U8*)s)[0] ) ? \
- ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0xA8 == ((U8*)s)[2] || 0xA9 == ((U8*)s)[2] ) ) ? 3 : 0 )\
- : 0 ) \
+ : ( ( ( 0xE2 == ((U8*)s)[0] ) && ( 0x80 == ((U8*)s)[1] ) ) && ( ( ((U8*)s)[2] & 0xFE ) == 0xA8 ) ) ? 3 : 0 )\
: ( 0x85 == ((U8*)s)[0] ) )
/*** GENERATED CODE ***/
@@ -298,9 +267,7 @@
: ( is_utf8 ) ? \
( ( 0xC2 == ((U8*)s)[0] ) ? \
( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \
- : ( 0xE2 == ((U8*)s)[0] ) ? \
- ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0xA8 == ((U8*)s)[2] || 0xA9 == ((U8*)s)[2] ) ) ? 3 : 0 )\
- : 0 ) \
+ : ( ( ( 0xE2 == ((U8*)s)[0] ) && ( 0x80 == ((U8*)s)[1] ) ) && ( ( ((U8*)s)[2] & 0xFE ) == 0xA8 ) ) ? 3 : 0 )\
: ( 0x85 == ((U8*)s)[0] ) ) \
: ((e)-(s) > 1) ? \
( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) ? 1 \
@@ -319,9 +286,7 @@
( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) ? 1 \
: ( 0xC2 == ((U8*)s)[0] ) ? \
( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \
-: ( 0xE2 == ((U8*)s)[0] ) ? \
- ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0xA8 == ((U8*)s)[2] || 0xA9 == ((U8*)s)[2] ) ) ? 3 : 0 )\
-: 0 )
+: ( ( ( 0xE2 == ((U8*)s)[0] ) && ( 0x80 == ((U8*)s)[1] ) ) && ( ( ((U8*)s)[2] & 0xFE ) == 0xA8 ) ) ? 3 : 0 )
/*** GENERATED CODE ***/
#define is_VERTWS_utf8_safe(s,e) \
@@ -329,19 +294,23 @@
( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) ? 1 \
: ( 0xC2 == ((U8*)s)[0] ) ? \
( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \
- : ( 0xE2 == ((U8*)s)[0] ) ? \
- ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0xA8 == ((U8*)s)[2] || 0xA9 == ((U8*)s)[2] ) ) ? 3 : 0 )\
- : 0 ) \
+ : ( ( ( 0xE2 == ((U8*)s)[0] ) && ( 0x80 == ((U8*)s)[1] ) ) && ( ( ((U8*)s)[2] & 0xFE ) == 0xA8 ) ) ? 3 : 0 )\
: ((e)-(s) > 1) ? \
( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) ? 1 \
- : ( 0xC2 == ((U8*)s)[0] ) ? \
- ( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \
- : 0 ) \
+ : ( ( 0xC2 == ((U8*)s)[0] ) && ( 0x85 == ((U8*)s)[1] ) ) ? 2 : 0 ) \
: ((e)-(s) > 0) ? \
( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) \
: 0 )
/*** GENERATED CODE ***/
+#define is_VERTWS_high(s) \
+( ( ( ( 0xE2 == ((U8*)s)[0] ) && ( 0x80 == ((U8*)s)[1] ) ) && ( ( ((U8*)s)[2] & 0xFE ) == 0xA8 ) ) ? 3 : 0 )
+
+/*** GENERATED CODE ***/
+#define is_VERTWS_high_safe(s,e) \
+( ( ( ( ((e)-(s) > 2) && ( 0xE2 == ((U8*)s)[0] ) ) && ( 0x80 == ((U8*)s)[1] ) ) && ( ( ((U8*)s)[2] & 0xFE ) == 0xA8 ) ) ? 3 : 0 )
+
+/*** GENERATED CODE ***/
#define is_VERTWS_latin1(s) \
( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) || 0x85 == ((U8*)s)[0] )
@@ -355,171 +324,599 @@
#define is_VERTWS_cp(cp) \
( ( 0x0A <= cp && cp <= 0x0D ) || ( 0x0D < cp && \
( 0x85 == cp || ( 0x85 < cp && \
+( 0x2028 == cp || 0x2029 == cp ) ) ) ) )
+
+/*** GENERATED CODE ***/
+#define is_VERTWS_cp_high(cp) \
+( 0x2028 == cp || 0x2029 == cp )
+
+/*
+ XDIGIT: Hexadecimal digits
+
+ \p{XDigit}
+*/
+/*** GENERATED CODE ***/
+#define is_XDIGIT_utf8(s) \
+( ( ( 0x30 <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x39 ) || ( 0x41 <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x46 ) || ( 0x61 <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x66 ) ) ? 1\
+: ( 0xEF == ((U8*)s)[0] ) ? \
+ ( ( 0xBC == ((U8*)s)[1] ) ? \
+ ( ( ( 0x90 <= ((U8*)s)[2] && ((U8*)s)[2] <= 0x99 ) || ( 0xA1 <= ((U8*)s)[2] && ((U8*)s)[2] <= 0xA6 ) ) ? 3 : 0 )\
+ : ( ( 0xBD == ((U8*)s)[1] ) && ( 0x81 <= ((U8*)s)[2] && ((U8*)s)[2] <= 0x86 ) ) ? 3 : 0 )\
+: 0 )
+
+/*** GENERATED CODE ***/
+#define is_XDIGIT_high(s) \
+( ( 0xEF == ((U8*)s)[0] ) ? \
+ ( ( 0xBC == ((U8*)s)[1] ) ? \
+ ( ( ( 0x90 <= ((U8*)s)[2] && ((U8*)s)[2] <= 0x99 ) || ( 0xA1 <= ((U8*)s)[2] && ((U8*)s)[2] <= 0xA6 ) ) ? 3 : 0 )\
+ : ( ( 0xBD == ((U8*)s)[1] ) && ( 0x81 <= ((U8*)s)[2] && ((U8*)s)[2] <= 0x86 ) ) ? 3 : 0 )\
+: 0 )
+
+/*** GENERATED CODE ***/
+#define is_XDIGIT_cp_high(cp) \
+( ( 0xFF10 <= cp && cp <= 0xFF19 ) || ( 0xFF19 < cp && \
+( ( 0xFF21 <= cp && cp <= 0xFF26 ) || ( 0xFF41 <= cp && cp <= 0xFF46 ) ) ) )
+
+/*
+ XPERLSPACE: \p{XPerlSpace}
+
+ \p{XPerlSpace}
+*/
+/*** GENERATED CODE ***/
+#define is_XPERLSPACE(s,is_utf8) \
+( ( ( 0x09 <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) || 0x20 == ((U8*)s)[0] ) ? 1\
+: ( is_utf8 ) ? \
+ ( ( 0xC2 == ((U8*)s)[0] ) ? \
+ ( ( 0x85 == ((U8*)s)[1] || 0xA0 == ((U8*)s)[1] ) ? 2 : 0 ) \
+ : ( 0xE1 == ((U8*)s)[0] ) ? \
+ ( ( 0x9A == ((U8*)s)[1] ) ? \
+ ( ( 0x80 == ((U8*)s)[2] ) ? 3 : 0 ) \
+ : ( ( 0xA0 == ((U8*)s)[1] ) && ( 0x8E == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : ( 0xE2 == ((U8*)s)[0] ) ? \
+ ( ( 0x80 == ((U8*)s)[1] ) ? \
+ ( ( ( 0x80 <= ((U8*)s)[2] && ((U8*)s)[2] <= 0x8A ) || ( ((U8*)s)[2] & 0xFE ) == 0xA8 || 0xAF == ((U8*)s)[2] ) ? 3 : 0 )\
+ : ( ( 0x81 == ((U8*)s)[1] ) && ( 0x9F == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : ( ( ( 0xE3 == ((U8*)s)[0] ) && ( 0x80 == ((U8*)s)[1] ) ) && ( 0x80 == ((U8*)s)[2] ) ) ? 3 : 0 )\
+: ( 0x85 == ((U8*)s)[0] || 0xA0 == ((U8*)s)[0] ) )
+
+/*** GENERATED CODE ***/
+#define is_XPERLSPACE_utf8(s) \
+( ( ( 0x09 <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) || 0x20 == ((U8*)s)[0] ) ? 1\
+: ( 0xC2 == ((U8*)s)[0] ) ? \
+ ( ( 0x85 == ((U8*)s)[1] || 0xA0 == ((U8*)s)[1] ) ? 2 : 0 ) \
+: ( 0xE1 == ((U8*)s)[0] ) ? \
+ ( ( 0x9A == ((U8*)s)[1] ) ? \
+ ( ( 0x80 == ((U8*)s)[2] ) ? 3 : 0 ) \
+ : ( ( 0xA0 == ((U8*)s)[1] ) && ( 0x8E == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+: ( 0xE2 == ((U8*)s)[0] ) ? \
+ ( ( 0x80 == ((U8*)s)[1] ) ? \
+ ( ( ( ((U8*)s)[2] <= 0x8A ) || ( ((U8*)s)[2] & 0xFE ) == 0xA8 || 0xAF == ((U8*)s)[2] ) ? 3 : 0 )\
+ : ( ( 0x81 == ((U8*)s)[1] ) && ( 0x9F == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+: ( ( ( 0xE3 == ((U8*)s)[0] ) && ( 0x80 == ((U8*)s)[1] ) ) && ( 0x80 == ((U8*)s)[2] ) ) ? 3 : 0 )
+
+/*** GENERATED CODE ***/
+#define is_XPERLSPACE_high(s) \
+( ( 0xE1 == ((U8*)s)[0] ) ? \
+ ( ( 0x9A == ((U8*)s)[1] ) ? \
+ ( ( 0x80 == ((U8*)s)[2] ) ? 3 : 0 ) \
+ : ( ( 0xA0 == ((U8*)s)[1] ) && ( 0x8E == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+: ( 0xE2 == ((U8*)s)[0] ) ? \
+ ( ( 0x80 == ((U8*)s)[1] ) ? \
+ ( ( ( ((U8*)s)[2] <= 0x8A ) || ( ((U8*)s)[2] & 0xFE ) == 0xA8 || 0xAF == ((U8*)s)[2] ) ? 3 : 0 )\
+ : ( ( 0x81 == ((U8*)s)[1] ) && ( 0x9F == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+: ( ( ( 0xE3 == ((U8*)s)[0] ) && ( 0x80 == ((U8*)s)[1] ) ) && ( 0x80 == ((U8*)s)[2] ) ) ? 3 : 0 )
+
+/*** GENERATED CODE ***/
+#define is_XPERLSPACE_cp_high(cp) \
+( 0x1680 == cp || ( 0x1680 < cp && \
+( 0x180E == cp || ( 0x180E < cp && \
+( ( 0x2000 <= cp && cp <= 0x200A ) || ( 0x200A < cp && \
( 0x2028 == cp || ( 0x2028 < cp && \
-0x2029 == cp ) ) ) ) ) )
+( 0x2029 == cp || ( 0x2029 < cp && \
+( 0x202F == cp || ( 0x202F < cp && \
+( 0x205F == cp || 0x3000 == cp ) ) ) ) ) ) ) ) ) ) ) ) )
/*
- TRICKYFOLD: Problematic fold case letters.
+ REPLACEMENT: Unicode REPLACEMENT CHARACTER
- 0x00DF # LATIN SMALL LETTER SHARP S
- 0x0390 # GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
- 0x03B0 # GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
- 0x1E9E # LATIN CAPITAL LETTER SHARP S, because maps to same as 00DF
- 0x1FD3 # GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA; maps same as 0390
- 0x1FE3 # GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA; maps same as 03B0
+ 0xFFFD
*/
/*** GENERATED CODE ***/
-#define is_TRICKYFOLD(s,is_utf8) \
-( ( is_utf8 ) ? \
- ( ( 0xC3 == ((U8*)s)[0] ) ? \
- ( ( 0x9F == ((U8*)s)[1] ) ? 2 : 0 ) \
- : ( 0xCE == ((U8*)s)[0] ) ? \
- ( ( 0x90 == ((U8*)s)[1] || 0xB0 == ((U8*)s)[1] ) ? 2 : 0 ) \
- : ( 0xE1 == ((U8*)s)[0] ) ? \
- ( ( 0xBA == ((U8*)s)[1] ) ? \
- ( ( 0x9E == ((U8*)s)[2] ) ? 3 : 0 ) \
- : ( 0xBF == ((U8*)s)[1] ) ? \
- ( ( 0x93 == ((U8*)s)[2] || 0xA3 == ((U8*)s)[2] ) ? 3 : 0 ) \
- : 0 ) \
+#define is_REPLACEMENT_utf8_safe(s,e) \
+( ( ( ( ((e)-(s) > 2) && ( 0xEF == ((U8*)s)[0] ) ) && ( 0xBF == ((U8*)s)[1] ) ) && ( 0xBD == ((U8*)s)[2] ) ) ? 3 : 0 )
+
+/*
+ NONCHAR: Non character code points
+
+ \p{Nchar}
+*/
+/*** GENERATED CODE ***/
+#define is_NONCHAR_utf8(s) \
+( ( 0xEF == ((U8*)s)[0] ) ? \
+ ( ( 0xB7 == ((U8*)s)[1] ) ? \
+ ( ( 0x90 <= ((U8*)s)[2] && ((U8*)s)[2] <= 0xAF ) ? 3 : 0 ) \
+ : ( ( 0xBF == ((U8*)s)[1] ) && ( ((U8*)s)[2] >= 0xBE ) ) ? 3 : 0 ) \
+: ( 0xF0 == ((U8*)s)[0] ) ? \
+ ( ( ( ( ((U8*)s)[1] == 0x9F || ( ( ((U8*)s)[1] & 0xEF ) == 0xAF ) ) && ( 0xBF == ((U8*)s)[2] ) ) && ( ((U8*)s)[3] >= 0xBE ) ) ? 4 : 0 )\
+: ( 0xF1 <= ((U8*)s)[0] && ((U8*)s)[0] <= 0xF3 ) ? \
+ ( ( ( ( ( ((U8*)s)[1] & 0xCF ) == 0x8F ) && ( 0xBF == ((U8*)s)[2] ) ) && ( ((U8*)s)[3] >= 0xBE ) ) ? 4 : 0 )\
+: ( ( ( ( 0xF4 == ((U8*)s)[0] ) && ( 0x8F == ((U8*)s)[1] ) ) && ( 0xBF == ((U8*)s)[2] ) ) && ( ((U8*)s)[3] >= 0xBE ) ) ? 4 : 0 )
+
+/*
+ SURROGATE: Surrogate characters
+
+ \p{Gc=Cs}
+*/
+/*** GENERATED CODE ***/
+#define is_SURROGATE_utf8(s) \
+( ( ( 0xED == ((U8*)s)[0] ) && ( ((U8*)s)[1] >= 0xA0 ) ) ? 3 : 0 )
+
+/*
+ GCB_L: Grapheme_Cluster_Break=L
+
+ \p{_X_GCB_L}
+*/
+/*** GENERATED CODE ***/
+#define is_GCB_L_utf8(s) \
+( ( 0xE1 == ((U8*)s)[0] ) ? \
+ ( ( 0x84 == ((U8*)s)[1] ) ? \
+ 3 \
+ : ( ( 0x85 == ((U8*)s)[1] ) && ( ((U8*)s)[2] <= 0x9F ) ) ? 3 : 0 ) \
+: ( ( ( 0xEA == ((U8*)s)[0] ) && ( 0xA5 == ((U8*)s)[1] ) ) && ( 0xA0 <= ((U8*)s)[2] && ((U8*)s)[2] <= 0xBC ) ) ? 3 : 0 )
+
+/*
+ GCB_LV_LVT_V: Grapheme_Cluster_Break=(LV or LVT or V)
+
+ \p{_X_LV_LVT_V}
+*/
+/*** GENERATED CODE ***/
+#define is_GCB_LV_LVT_V_utf8(s) \
+( ( 0xE1 == ((U8*)s)[0] ) ? \
+ ( ( 0x85 == ((U8*)s)[1] ) ? \
+ ( ( ((U8*)s)[2] >= 0xA0 ) ? 3 : 0 ) \
+ : ( ( 0x86 == ((U8*)s)[1] ) && ( ((U8*)s)[2] <= 0xA7 ) ) ? 3 : 0 ) \
+: ( 0xEA == ((U8*)s)[0] ) ? \
+ ( ( ((U8*)s)[1] >= 0xB0 ) ? \
+ 3 \
: 0 ) \
-: ( 0xDF == ((U8*)s)[0] ) )
+: ( 0xEB == ((U8*)s)[0] || 0xEC == ((U8*)s)[0] ) ? \
+ 3 \
+: ( 0xED == ((U8*)s)[0] ) ? \
+ ( ( ((U8*)s)[1] <= 0x9D ) ? \
+ 3 \
+ : ( 0x9E == ((U8*)s)[1] ) ? \
+ ( ( ( ((U8*)s)[2] <= 0xA3 ) || ( ((U8*)s)[2] >= 0xB0 ) ) ? 3 : 0 ) \
+ : ( ( 0x9F == ((U8*)s)[1] ) && ( ((U8*)s)[2] <= 0x86 ) ) ? 3 : 0 ) \
+: 0 )
+/*
+ GCB_Prepend: Grapheme_Cluster_Break=Prepend
+
+ \p{_X_GCB_Prepend}
+*/
/*** GENERATED CODE ***/
-#define is_TRICKYFOLD_safe(s,e,is_utf8) \
-( ((e)-(s) > 2) ? \
- ( ( is_utf8 ) ? \
- ( ( 0xC3 == ((U8*)s)[0] ) ? \
- ( ( 0x9F == ((U8*)s)[1] ) ? 2 : 0 ) \
- : ( 0xCE == ((U8*)s)[0] ) ? \
- ( ( 0x90 == ((U8*)s)[1] || 0xB0 == ((U8*)s)[1] ) ? 2 : 0 ) \
- : ( 0xE1 == ((U8*)s)[0] ) ? \
- ( ( 0xBA == ((U8*)s)[1] ) ? \
- ( ( 0x9E == ((U8*)s)[2] ) ? 3 : 0 ) \
- : ( 0xBF == ((U8*)s)[1] ) ? \
- ( ( 0x93 == ((U8*)s)[2] || 0xA3 == ((U8*)s)[2] ) ? 3 : 0 ) \
- : 0 ) \
- : 0 ) \
- : ( 0xDF == ((U8*)s)[0] ) ) \
-: ((e)-(s) > 1) ? \
- ( ( is_utf8 ) ? \
- ( ( 0xC3 == ((U8*)s)[0] ) ? \
- ( ( 0x9F == ((U8*)s)[1] ) ? 2 : 0 ) \
- : ( 0xCE == ((U8*)s)[0] ) ? \
- ( ( 0x90 == ((U8*)s)[1] || 0xB0 == ((U8*)s)[1] ) ? 2 : 0 ) \
- : 0 ) \
- : ( 0xDF == ((U8*)s)[0] ) ) \
-: ((e)-(s) > 0) ? \
- ( ( !( is_utf8 ) ) ? \
- ( 0xDF == ((U8*)s)[0] ) \
+#define is_GCB_Prepend_utf8(s) \
+( 0 )
+
+/*
+ GCB_RI: Grapheme_Cluster_Break=RI
+
+ \p{_X_RI}
+*/
+/*** GENERATED CODE ***/
+#define is_GCB_RI_utf8(s) \
+( ( ( ( ( 0xF0 == ((U8*)s)[0] ) && ( 0x9F == ((U8*)s)[1] ) ) && ( 0x87 == ((U8*)s)[2] ) ) && ( ((U8*)s)[3] >= 0xA6 ) ) ? 4 : 0 )
+
+/*
+ GCB_SPECIAL_BEGIN_START: Grapheme_Cluster_Break=special_begin_starts
+
+ \p{_X_Special_Begin_Start}
+*/
+/*** GENERATED CODE ***/
+#define is_GCB_SPECIAL_BEGIN_START_utf8(s) \
+( ( 0xE1 == ((U8*)s)[0] ) ? \
+ ( ( ( ((U8*)s)[1] & 0xFC ) == 0x84 ) ? \
+ 3 \
: 0 ) \
+: ( 0xEA == ((U8*)s)[0] ) ? \
+ ( ( 0xA5 == ((U8*)s)[1] ) ? \
+ ( ( 0xA0 <= ((U8*)s)[2] && ((U8*)s)[2] <= 0xBC ) ? 3 : 0 ) \
+ : ( ((U8*)s)[1] >= 0xB0 ) ? \
+ 3 \
+ : 0 ) \
+: ( 0xEB == ((U8*)s)[0] || 0xEC == ((U8*)s)[0] ) ? \
+ 3 \
+: ( 0xED == ((U8*)s)[0] ) ? \
+ ( ( ((U8*)s)[1] <= 0x9D ) ? \
+ 3 \
+ : ( 0x9E == ((U8*)s)[1] ) ? \
+ ( ( ( ((U8*)s)[2] <= 0xA3 ) || ( ((U8*)s)[2] >= 0xB0 ) ) ? 3 : 0 ) \
+ : ( ( 0x9F == ((U8*)s)[1] ) && ( ( ((U8*)s)[2] <= 0x86 ) || ( 0x8B <= ((U8*)s)[2] && ((U8*)s)[2] <= 0xBB ) ) ) ? 3 : 0 )\
+: ( ( ( ( 0xF0 == ((U8*)s)[0] ) && ( 0x9F == ((U8*)s)[1] ) ) && ( 0x87 == ((U8*)s)[2] ) ) && ( ((U8*)s)[3] >= 0xA6 ) ) ? 4 : 0 )
+
+/*
+ GCB_T: Grapheme_Cluster_Break=T
+
+ \p{_X_GCB_T}
+*/
+/*** GENERATED CODE ***/
+#define is_GCB_T_utf8(s) \
+( ( 0xE1 == ((U8*)s)[0] ) ? \
+ ( ( 0x86 == ((U8*)s)[1] ) ? \
+ ( ( ((U8*)s)[2] >= 0xA8 ) ? 3 : 0 ) \
+ : ( 0x87 == ((U8*)s)[1] ) ? \
+ 3 \
+ : 0 ) \
+: ( ( ( 0xED == ((U8*)s)[0] ) && ( 0x9F == ((U8*)s)[1] ) ) && ( 0x8B <= ((U8*)s)[2] && ((U8*)s)[2] <= 0xBB ) ) ? 3 : 0 )
+
+/*
+ GCB_V: Grapheme_Cluster_Break=V
+
+ \p{_X_GCB_V}
+*/
+/*** GENERATED CODE ***/
+#define is_GCB_V_utf8(s) \
+( ( 0xE1 == ((U8*)s)[0] ) ? \
+ ( ( 0x85 == ((U8*)s)[1] ) ? \
+ ( ( ((U8*)s)[2] >= 0xA0 ) ? 3 : 0 ) \
+ : ( ( 0x86 == ((U8*)s)[1] ) && ( ((U8*)s)[2] <= 0xA7 ) ) ? 3 : 0 ) \
+: ( 0xED == ((U8*)s)[0] ) ? \
+ ( ( 0x9E == ((U8*)s)[1] ) ? \
+ ( ( ((U8*)s)[2] >= 0xB0 ) ? 3 : 0 ) \
+ : ( ( 0x9F == ((U8*)s)[1] ) && ( ((U8*)s)[2] <= 0x86 ) ) ? 3 : 0 ) \
: 0 )
+/*
+ QUOTEMETA: Meta-characters that \Q should quote
+
+ \p{_Perl_Quotemeta}
+*/
/*** GENERATED CODE ***/
-#define is_TRICKYFOLD_cp(cp) \
-( 0xDF == cp || ( 0xDF < cp && \
-( 0x390 == cp || ( 0x390 < cp && \
-( 0x3B0 == cp || ( 0x3B0 < cp && \
-( 0x1E9E == cp || ( 0x1E9E < cp && \
-( 0x1FD3 == cp || ( 0x1FD3 < cp && \
-0x1FE3 == cp ) ) ) ) ) ) ) ) ) )
+#define is_QUOTEMETA_high(s) \
+( ( 0xCD == ((U8*)s)[0] ) ? \
+ ( ( 0x8F == ((U8*)s)[1] ) ? 2 : 0 ) \
+: ( 0xE1 == ((U8*)s)[0] ) ? \
+ ( ( 0x85 == ((U8*)s)[1] ) ? \
+ ( ( 0x9F == ((U8*)s)[2] || 0xA0 == ((U8*)s)[2] ) ? 3 : 0 ) \
+ : ( 0x9A == ((U8*)s)[1] ) ? \
+ ( ( 0x80 == ((U8*)s)[2] ) ? 3 : 0 ) \
+ : ( 0x9E == ((U8*)s)[1] ) ? \
+ ( ( ( ((U8*)s)[2] & 0xFE ) == 0xB4 ) ? 3 : 0 ) \
+ : ( ( 0xA0 == ((U8*)s)[1] ) && ( 0x8B <= ((U8*)s)[2] && ((U8*)s)[2] <= 0x8E ) ) ? 3 : 0 )\
+: ( 0xE2 == ((U8*)s)[0] ) ? \
+ ( ( 0x80 == ((U8*)s)[1] ) ? \
+ ( ( ((U8*)s)[2] <= 0xBE ) ? 3 : 0 ) \
+ : ( 0x81 == ((U8*)s)[1] ) ? \
+ ( ( ( 0x81 <= ((U8*)s)[2] && ((U8*)s)[2] <= 0x93 ) || ( 0x95 <= ((U8*)s)[2] && ((U8*)s)[2] <= 0xAF ) ) ? 3 : 0 )\
+ : ( 0x86 == ((U8*)s)[1] ) ? \
+ ( ( ((U8*)s)[2] >= 0x90 ) ? 3 : 0 ) \
+ : ( ( 0x87 <= ((U8*)s)[1] && ((U8*)s)[1] <= 0x90 ) || ( 0x94 <= ((U8*)s)[1] && ((U8*)s)[1] <= 0x9C ) || ( 0x9F <= ((U8*)s)[1] && ((U8*)s)[1] <= 0xAF ) || ( ((U8*)s)[1] & 0xFE ) == 0xB8 ) ?\
+ 3 \
+ : ( 0x91 == ((U8*)s)[1] ) ? \
+ ( ( ((U8*)s)[2] <= 0x9F ) ? 3 : 0 ) \
+ : ( 0x9D == ((U8*)s)[1] ) ? \
+ ( ( ((U8*)s)[2] <= 0xB5 ) ? 3 : 0 ) \
+ : ( ( 0x9E == ((U8*)s)[1] ) && ( ((U8*)s)[2] >= 0x94 ) ) ? 3 : 0 ) \
+: ( 0xE3 == ((U8*)s)[0] ) ? \
+ ( ( 0x80 == ((U8*)s)[1] ) ? \
+ ( ( ( ((U8*)s)[2] <= 0x83 ) || ( 0x88 <= ((U8*)s)[2] && ((U8*)s)[2] <= 0xA0 ) || 0xB0 == ((U8*)s)[2] ) ? 3 : 0 )\
+ : ( ( 0x85 == ((U8*)s)[1] ) && ( 0xA4 == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+: ( 0xEF == ((U8*)s)[0] ) ? \
+ ( ( 0xB4 == ((U8*)s)[1] ) ? \
+ ( ( ((U8*)s)[2] >= 0xBE ) ? 3 : 0 ) \
+ : ( 0xB8 == ((U8*)s)[1] ) ? \
+ ( ( ((U8*)s)[2] <= 0x8F ) ? 3 : 0 ) \
+ : ( 0xB9 == ((U8*)s)[1] ) ? \
+ ( ( 0x85 == ((U8*)s)[2] || 0x86 == ((U8*)s)[2] ) ? 3 : 0 ) \
+ : ( 0xBB == ((U8*)s)[1] ) ? \
+ ( ( 0xBF == ((U8*)s)[2] ) ? 3 : 0 ) \
+ : ( 0xBE == ((U8*)s)[1] ) ? \
+ ( ( 0xA0 == ((U8*)s)[2] ) ? 3 : 0 ) \
+ : ( ( 0xBF == ((U8*)s)[1] ) && ( 0xB0 <= ((U8*)s)[2] && ((U8*)s)[2] <= 0xB8 ) ) ? 3 : 0 )\
+: ( 0xF0 == ((U8*)s)[0] ) ? \
+ ( ( ( ( 0x9D == ((U8*)s)[1] ) && ( 0x85 == ((U8*)s)[2] ) ) && ( 0xB3 <= ((U8*)s)[3] && ((U8*)s)[3] <= 0xBA ) ) ? 4 : 0 )\
+: ( ( 0xF3 == ((U8*)s)[0] ) && ( 0xA0 == ((U8*)s)[1] ) ) ? 4 : 0 )
+/*
+ MULTI_CHAR_FOLD: multi-char strings that are folded to by a single character
+
+ do regen/regcharclass_multi_char_folds.pl
+ ®charclass_multi_char_folds::multi_char_folds(1)
+*/
/*** GENERATED CODE ***/
-#define what_TRICKYFOLD(s,is_utf8) \
-( ( is_utf8 ) ? \
- ( ( 0xC3 == ((U8*)s)[0] ) ? \
- ( ( 0x9F == ((U8*)s)[1] ) ? 0xDF : 0 ) \
+#define is_MULTI_CHAR_FOLD_utf8_safe_part0(s,e) \
+( ( 0x61 == ((U8*)s)[0] ) ? \
+ ( ( ( 0xCA == ((U8*)s)[1] ) && ( 0xBE == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : ( 0x66 == ((U8*)s)[0] ) ? \
+ ( ( 0x66 == ((U8*)s)[1] ) ? \
+ ( ( 0x69 == ((U8*)s)[2] || 0x6C == ((U8*)s)[2] ) ? 3 : 2 ) \
+ : ( 0x69 == ((U8*)s)[1] || 0x6C == ((U8*)s)[1] ) ? 2 : 0 ) \
+ : ( 0x68 == ((U8*)s)[0] ) ? \
+ ( ( ( 0xCC == ((U8*)s)[1] ) && ( 0xB1 == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : ( 0x69 == ((U8*)s)[0] ) ? \
+ ( ( ( 0xCC == ((U8*)s)[1] ) && ( 0x87 == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : ( 0x6A == ((U8*)s)[0] ) ? \
+ ( ( ( 0xCC == ((U8*)s)[1] ) && ( 0x8C == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : ( 0x73 == ((U8*)s)[0] ) ? \
+ ( ( 0x73 == ((U8*)s)[1] || 0x74 == ((U8*)s)[1] ) ? 2 : 0 ) \
+ : ( 0x74 == ((U8*)s)[0] ) ? \
+ ( ( ( 0xCC == ((U8*)s)[1] ) && ( 0x88 == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : ( 0x77 == ((U8*)s)[0] || 0x79 == ((U8*)s)[0] ) ? \
+ ( ( ( 0xCC == ((U8*)s)[1] ) && ( 0x8A == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : ( 0xCA == ((U8*)s)[0] ) ? \
+ ( ( ( 0xBC == ((U8*)s)[1] ) && ( 0x6E == ((U8*)s)[2] ) ) ? 3 : 0 ) \
: ( 0xCE == ((U8*)s)[0] ) ? \
- ( ( 0x90 == ((U8*)s)[1] ) ? 0x390 \
- : ( 0xB0 == ((U8*)s)[1] ) ? 0x3B0 : 0 ) \
+ ( ( ( ((U8*)s)[1] & 0xFD ) == 0xAC ) ? \
+ ( ( ( 0xCE == ((U8*)s)[2] ) && ( 0xB9 == ((U8*)s)[3] ) ) ? 4 : 0 )\
+ : ( 0xB1 == ((U8*)s)[1] || 0xB7 == ((U8*)s)[1] ) ? \
+ ( ( 0xCD == ((U8*)s)[2] ) ? \
+ ( ( 0x82 == ((U8*)s)[3] ) ? 4 : 0 ) \
+ : ( ( 0xCE == ((U8*)s)[2] ) && ( 0xB9 == ((U8*)s)[3] ) ) ? 4 : 0 )\
+ : ( ( ( 0xB9 == ((U8*)s)[1] ) && ( 0xCD == ((U8*)s)[2] ) ) && ( 0x82 == ((U8*)s)[3] ) ) ? 4 : 0 )\
+ : ( 0xCF == ((U8*)s)[0] ) ? \
+ ( ( 0x81 == ((U8*)s)[1] ) ? \
+ ( ( ( 0xCC == ((U8*)s)[2] ) && ( 0x93 == ((U8*)s)[3] ) ) ? 4 : 0 )\
+ : ( 0x85 == ((U8*)s)[1] ) ? \
+ ( ( 0xCC == ((U8*)s)[2] ) ? \
+ ( ( 0x93 == ((U8*)s)[3] ) ? 4 : 0 ) \
+ : ( ( 0xCD == ((U8*)s)[2] ) && ( 0x82 == ((U8*)s)[3] ) ) ? 4 : 0 )\
+ : ( 0x89 == ((U8*)s)[1] ) ? \
+ ( ( 0xCD == ((U8*)s)[2] ) ? \
+ ( ( 0x82 == ((U8*)s)[3] ) ? 4 : 0 ) \
+ : ( ( 0xCE == ((U8*)s)[2] ) && ( 0xB9 == ((U8*)s)[3] ) ) ? 4 : 0 )\
+ : ( ( ( 0x8E == ((U8*)s)[1] ) && ( 0xCE == ((U8*)s)[2] ) ) && ( 0xB9 == ((U8*)s)[3] ) ) ? 4 : 0 )\
+ : ( 0xD5 == ((U8*)s)[0] ) ? \
+ ( ( 0xA5 == ((U8*)s)[1] ) ? \
+ ( ( ( 0xD6 == ((U8*)s)[2] ) && ( 0x82 == ((U8*)s)[3] ) ) ? 4 : 0 )\
+ : ( 0xB4 == ((U8*)s)[1] ) ? \
+ ( ( ( 0xD5 == ((U8*)s)[2] ) && ( ( ( ((U8*)s)[3] & 0xF7 ) == 0xA5 ) || ((U8*)s)[3] == 0xAB || ((U8*)s)[3] == 0xB6 ) ) ? 4 : 0 )\
+ : ( ( ( 0xBE == ((U8*)s)[1] ) && ( 0xD5 == ((U8*)s)[2] ) ) && ( 0xB6 == ((U8*)s)[3] ) ) ? 4 : 0 )\
: ( 0xE1 == ((U8*)s)[0] ) ? \
- ( ( 0xBA == ((U8*)s)[1] ) ? \
- ( ( 0x9E == ((U8*)s)[2] ) ? 0x1E9E : 0 ) \
- : ( 0xBF == ((U8*)s)[1] ) ? \
- ( ( 0x93 == ((U8*)s)[2] ) ? 0x1FD3 \
- : ( 0xA3 == ((U8*)s)[2] ) ? 0x1FE3 : 0 ) \
+ ( ( 0xBC == ((U8*)s)[1] ) ? \
+ ( ( ( ( ( ((U8*)s)[2] & 0xD8 ) == 0x80 ) && ( 0xCE == ((U8*)s)[3] ) ) && ( 0xB9 == ((U8*)s)[4] ) ) ? 5 : 0 )\
+ : ( ( ( ( 0xBD == ((U8*)s)[1] ) && ( ( ( ((U8*)s)[2] & 0xF8 ) == 0xA0 ) || ( ( ((U8*)s)[2] & 0xFB ) == 0xB0 ) || ((U8*)s)[2] == 0xBC ) ) && ( 0xCE == ((U8*)s)[3] ) ) && ( 0xB9 == ((U8*)s)[4] ) ) ? 5 : 0 )\
+ : 0 )
+
+
+/*** GENERATED CODE ***/
+#define is_MULTI_CHAR_FOLD_utf8_safe_part1(s,e) \
+( ((e)-(s) > 3) ? \
+ ( ( 0x61 == ((U8*)s)[0] ) ? \
+ ( ( ( 0xCA == ((U8*)s)[1] ) && ( 0xBE == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : ( 0x66 == ((U8*)s)[0] ) ? \
+ ( ( 0x66 == ((U8*)s)[1] ) ? \
+ ( ( 0x69 == ((U8*)s)[2] || 0x6C == ((U8*)s)[2] ) ? 3 : 2 ) \
+ : ( 0x69 == ((U8*)s)[1] || 0x6C == ((U8*)s)[1] ) ? 2 : 0 ) \
+ : ( 0x68 == ((U8*)s)[0] ) ? \
+ ( ( ( 0xCC == ((U8*)s)[1] ) && ( 0xB1 == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : ( 0x69 == ((U8*)s)[0] ) ? \
+ ( ( ( 0xCC == ((U8*)s)[1] ) && ( 0x87 == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : ( 0x6A == ((U8*)s)[0] ) ? \
+ ( ( ( 0xCC == ((U8*)s)[1] ) && ( 0x8C == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : ( 0x73 == ((U8*)s)[0] ) ? \
+ ( ( 0x73 == ((U8*)s)[1] || 0x74 == ((U8*)s)[1] ) ? 2 : 0 ) \
+ : ( 0x74 == ((U8*)s)[0] ) ? \
+ ( ( ( 0xCC == ((U8*)s)[1] ) && ( 0x88 == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : ( 0x77 == ((U8*)s)[0] || 0x79 == ((U8*)s)[0] ) ? \
+ ( ( ( 0xCC == ((U8*)s)[1] ) && ( 0x8A == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : ( 0xCA == ((U8*)s)[0] ) ? \
+ ( ( ( 0xBC == ((U8*)s)[1] ) && ( 0x6E == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : ( 0xCE == ((U8*)s)[0] ) ? \
+ ( ( ( ((U8*)s)[1] & 0xFD ) == 0xAC ) ? \
+ ( ( ( 0xCE == ((U8*)s)[2] ) && ( 0xB9 == ((U8*)s)[3] ) ) ? 4 : 0 )\
+ : ( 0xB1 == ((U8*)s)[1] || 0xB7 == ((U8*)s)[1] ) ? \
+ ( ( 0xCD == ((U8*)s)[2] ) ? \
+ ( ( 0x82 == ((U8*)s)[3] ) ? 4 : 0 ) \
+ : ( ( 0xCE == ((U8*)s)[2] ) && ( 0xB9 == ((U8*)s)[3] ) ) ? 4 : 0 )\
+ : ( ( ( 0xB9 == ((U8*)s)[1] ) && ( 0xCD == ((U8*)s)[2] ) ) && ( 0x82 == ((U8*)s)[3] ) ) ? 4 : 0 )\
+ : ( 0xCF == ((U8*)s)[0] ) ? \
+ ( ( 0x81 == ((U8*)s)[1] ) ? \
+ ( ( ( 0xCC == ((U8*)s)[2] ) && ( 0x93 == ((U8*)s)[3] ) ) ? 4 : 0 )\
+ : ( 0x85 == ((U8*)s)[1] ) ? \
+ ( ( 0xCC == ((U8*)s)[2] ) ? \
+ ( ( 0x93 == ((U8*)s)[3] ) ? 4 : 0 ) \
+ : ( ( 0xCD == ((U8*)s)[2] ) && ( 0x82 == ((U8*)s)[3] ) ) ? 4 : 0 )\
+ : ( 0x89 == ((U8*)s)[1] ) ? \
+ ( ( 0xCD == ((U8*)s)[2] ) ? \
+ ( ( 0x82 == ((U8*)s)[3] ) ? 4 : 0 ) \
+ : ( ( 0xCE == ((U8*)s)[2] ) && ( 0xB9 == ((U8*)s)[3] ) ) ? 4 : 0 )\
+ : ( ( ( 0x8E == ((U8*)s)[1] ) && ( 0xCE == ((U8*)s)[2] ) ) && ( 0xB9 == ((U8*)s)[3] ) ) ? 4 : 0 )\
+ : ( 0xD5 == ((U8*)s)[0] ) ? \
+ ( ( 0xA5 == ((U8*)s)[1] ) ? \
+ ( ( ( 0xD6 == ((U8*)s)[2] ) && ( 0x82 == ((U8*)s)[3] ) ) ? 4 : 0 )\
+ : ( 0xB4 == ((U8*)s)[1] ) ? \
+ ( ( ( 0xD5 == ((U8*)s)[2] ) && ( ( ( ((U8*)s)[3] & 0xF7 ) == 0xA5 ) || ((U8*)s)[3] == 0xAB || ((U8*)s)[3] == 0xB6 ) ) ? 4 : 0 )\
+ : ( ( ( 0xBE == ((U8*)s)[1] ) && ( 0xD5 == ((U8*)s)[2] ) ) && ( 0xB6 == ((U8*)s)[3] ) ) ? 4 : 0 )\
+ : 0 ) \
+: ((e)-(s) > 2) ? \
+ ( ( 0x61 == ((U8*)s)[0] ) ? \
+ ( ( ( 0xCA == ((U8*)s)[1] ) && ( 0xBE == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : ( 0x66 == ((U8*)s)[0] ) ? \
+ ( ( 0x66 == ((U8*)s)[1] ) ? \
+ ( ( 0x69 == ((U8*)s)[2] || 0x6C == ((U8*)s)[2] ) ? 3 : 2 ) \
+ : ( 0x69 == ((U8*)s)[1] || 0x6C == ((U8*)s)[1] ) ? 2 : 0 ) \
+ : ( 0x68 == ((U8*)s)[0] ) ? \
+ ( ( ( 0xCC == ((U8*)s)[1] ) && ( 0xB1 == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : ( 0x69 == ((U8*)s)[0] ) ? \
+ ( ( ( 0xCC == ((U8*)s)[1] ) && ( 0x87 == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : ( 0x6A == ((U8*)s)[0] ) ? \
+ ( ( ( 0xCC == ((U8*)s)[1] ) && ( 0x8C == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : ( 0x73 == ((U8*)s)[0] ) ? \
+ ( ( 0x73 == ((U8*)s)[1] || 0x74 == ((U8*)s)[1] ) ? 2 : 0 ) \
+ : ( 0x74 == ((U8*)s)[0] ) ? \
+ ( ( ( 0xCC == ((U8*)s)[1] ) && ( 0x88 == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : ( 0x77 == ((U8*)s)[0] || 0x79 == ((U8*)s)[0] ) ? \
+ ( ( ( 0xCC == ((U8*)s)[1] ) && ( 0x8A == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : ( ( ( 0xCA == ((U8*)s)[0] ) && ( 0xBC == ((U8*)s)[1] ) ) && ( 0x6E == ((U8*)s)[2] ) ) ? 3 : 0 )\
+: ((e)-(s) > 1) ? \
+ ( ( 0x66 == ((U8*)s)[0] ) ? \
+ ( ( 0x66 == ((U8*)s)[1] || 0x69 == ((U8*)s)[1] || 0x6C == ((U8*)s)[1] ) ? 2 : 0 )\
+ : ( ( 0x73 == ((U8*)s)[0] ) && ( 0x73 == ((U8*)s)[1] || 0x74 == ((U8*)s)[1] ) ) ? 2 : 0 )\
+: 0 )
+
+
+/*** GENERATED CODE ***/
+#define is_MULTI_CHAR_FOLD_utf8_safe(s,e) \
+( ((e)-(s) > 5) ? \
+ ( ( 0x61 == ((U8*)s)[0] ) ? \
+ ( ( ( 0xCA == ((U8*)s)[1] ) && ( 0xBE == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : ( 0x66 == ((U8*)s)[0] ) ? \
+ ( ( 0x66 == ((U8*)s)[1] ) ? \
+ ( ( 0x69 == ((U8*)s)[2] || 0x6C == ((U8*)s)[2] ) ? 3 : 2 ) \
+ : ( 0x69 == ((U8*)s)[1] || 0x6C == ((U8*)s)[1] ) ? 2 : 0 ) \
+ : ( 0x68 == ((U8*)s)[0] ) ? \
+ ( ( ( 0xCC == ((U8*)s)[1] ) && ( 0xB1 == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : ( 0x69 == ((U8*)s)[0] ) ? \
+ ( ( ( 0xCC == ((U8*)s)[1] ) && ( 0x87 == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : ( 0x6A == ((U8*)s)[0] ) ? \
+ ( ( ( 0xCC == ((U8*)s)[1] ) && ( 0x8C == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : ( 0x73 == ((U8*)s)[0] ) ? \
+ ( ( 0x73 == ((U8*)s)[1] || 0x74 == ((U8*)s)[1] ) ? 2 : 0 ) \
+ : ( 0x74 == ((U8*)s)[0] ) ? \
+ ( ( ( 0xCC == ((U8*)s)[1] ) && ( 0x88 == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : ( 0x77 == ((U8*)s)[0] || 0x79 == ((U8*)s)[0] ) ? \
+ ( ( ( 0xCC == ((U8*)s)[1] ) && ( 0x8A == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : ( 0xCA == ((U8*)s)[0] ) ? \
+ ( ( ( 0xBC == ((U8*)s)[1] ) && ( 0x6E == ((U8*)s)[2] ) ) ? 3 : 0 ) \
+ : ( 0xCE == ((U8*)s)[0] ) ? \
+ ( ( ( ((U8*)s)[1] & 0xFD ) == 0xAC ) ? \
+ ( ( ( 0xCE == ((U8*)s)[2] ) && ( 0xB9 == ((U8*)s)[3] ) ) ? 4 : 0 )\
+ : ( 0xB1 == ((U8*)s)[1] || 0xB7 == ((U8*)s)[1] ) ? \
+ ( ( 0xCD == ((U8*)s)[2] ) ? \
+ ( ( 0x82 == ((U8*)s)[3] ) ? \
+ ( ( ( 0xCE == ((U8*)s)[4] ) && ( 0xB9 == ((U8*)s)[5] ) ) ? 6 : 4 )\
+ : 0 ) \
+ : ( ( 0xCE == ((U8*)s)[2] ) && ( 0xB9 == ((U8*)s)[3] ) ) ? 4 : 0 )\
+ : ( 0xB9 == ((U8*)s)[1] ) ? \
+ ( ( 0xCC == ((U8*)s)[2] ) ? \
+ ( ( 0x88 == ((U8*)s)[3] ) ? \
+ ( ( 0xCC == ((U8*)s)[4] ) ? \
+ ( ( ( ((U8*)s)[5] & 0xFE ) == 0x80 ) ? 6 : 0 ) \
+ : ( ( 0xCD == ((U8*)s)[4] ) && ( 0x82 == ((U8*)s)[5] ) ) ? 6 : 0 )\
+ : 0 ) \
+ : ( ( 0xCD == ((U8*)s)[2] ) && ( 0x82 == ((U8*)s)[3] ) ) ? 4 : 0 )\
: 0 ) \
+ : ( 0xCF == ((U8*)s)[0] ) ? \
+ ( ( 0x81 == ((U8*)s)[1] ) ? \
+ ( ( ( 0xCC == ((U8*)s)[2] ) && ( 0x93 == ((U8*)s)[3] ) ) ? 4 : 0 )\
+ : ( 0x85 == ((U8*)s)[1] ) ? \
+ ( ( 0xCC == ((U8*)s)[2] ) ? \
+ ( ( 0x88 == ((U8*)s)[3] ) ? \
+ ( ( 0xCC == ((U8*)s)[4] ) ? \
+ ( ( ( ((U8*)s)[5] & 0xFE ) == 0x80 ) ? 6 : 0 ) \
+ : ( ( 0xCD == ((U8*)s)[4] ) && ( 0x82 == ((U8*)s)[5] ) ) ? 6 : 0 )\
+ : ( 0x93 == ((U8*)s)[3] ) ? \
+ ( ( 0xCC == ((U8*)s)[4] ) ? \
+ ( ( ( ((U8*)s)[5] & 0xFE ) == 0x80 ) ? 6 : 4 ) \
+ : ( ( 0xCD == ((U8*)s)[4] ) && ( 0x82 == ((U8*)s)[5] ) ) ? 6 : 4 )\
+ : 0 ) \
+ : ( ( 0xCD == ((U8*)s)[2] ) && ( 0x82 == ((U8*)s)[3] ) ) ? 4 : 0 )\
+ : ( 0x89 == ((U8*)s)[1] ) ? \
+ ( ( 0xCD == ((U8*)s)[2] ) ? \
+ ( ( 0x82 == ((U8*)s)[3] ) ? \
+ ( ( ( 0xCE == ((U8*)s)[4] ) && ( 0xB9 == ((U8*)s)[5] ) ) ? 6 : 4 )\
+ : 0 ) \
+ : ( ( 0xCE == ((U8*)s)[2] ) && ( 0xB9 == ((U8*)s)[3] ) ) ? 4 : 0 )\
+ : ( ( ( 0x8E == ((U8*)s)[1] ) && ( 0xCE == ((U8*)s)[2] ) ) && ( 0xB9 == ((U8*)s)[3] ) ) ? 4 : 0 )\
+ : ( 0xD5 == ((U8*)s)[0] ) ? \
+ ( ( 0xA5 == ((U8*)s)[1] ) ? \
+ ( ( ( 0xD6 == ((U8*)s)[2] ) && ( 0x82 == ((U8*)s)[3] ) ) ? 4 : 0 )\
+ : ( 0xB4 == ((U8*)s)[1] ) ? \
+ ( ( ( 0xD5 == ((U8*)s)[2] ) && ( ( ( ((U8*)s)[3] & 0xF7 ) == 0xA5 ) || ((U8*)s)[3] == 0xAB || ((U8*)s)[3] == 0xB6 ) ) ? 4 : 0 )\
+ : ( ( ( 0xBE == ((U8*)s)[1] ) && ( 0xD5 == ((U8*)s)[2] ) ) && ( 0xB6 == ((U8*)s)[3] ) ) ? 4 : 0 )\
+ : ( 0xE1 == ((U8*)s)[0] ) ? \
+ ( ( 0xBC == ((U8*)s)[1] ) ? \
+ ( ( ( ( ( ((U8*)s)[2] & 0xD8 ) == 0x80 ) && ( 0xCE == ((U8*)s)[3] ) ) && ( 0xB9 == ((U8*)s)[4] ) ) ? 5 : 0 )\
+ : ( ( ( ( 0xBD == ((U8*)s)[1] ) && ( ( ( ((U8*)s)[2] & 0xF8 ) == 0xA0 ) || ( ( ((U8*)s)[2] & 0xFB ) == 0xB0 ) || ((U8*)s)[2] == 0xBC ) ) && ( 0xCE == ((U8*)s)[3] ) ) && ( 0xB9 == ((U8*)s)[4] ) ) ? 5 : 0 )\
: 0 ) \
-: ( 0xDF == ((U8*)s)[0] ) ? 0xDF : 0 )
+: ((e)-(s) > 4) ? is_MULTI_CHAR_FOLD_utf8_safe_part0(s,e) : is_MULTI_CHAR_FOLD_utf8_safe_part1(s,e) )
+/*
+ MULTI_CHAR_FOLD: multi-char strings that are folded to by a single character
+
+ ®charclass_multi_char_folds::multi_char_folds(0)
+*/
/*** GENERATED CODE ***/
-#define what_TRICKYFOLD_safe(s,e,is_utf8) \
+#define is_MULTI_CHAR_FOLD_latin1_safe(s,e) \
( ((e)-(s) > 2) ? \
- ( ( is_utf8 ) ? \
- ( ( 0xC3 == ((U8*)s)[0] ) ? \
- ( ( 0x9F == ((U8*)s)[1] ) ? 0xDF : 0 ) \
- : ( 0xCE == ((U8*)s)[0] ) ? \
- ( ( 0x90 == ((U8*)s)[1] ) ? 0x390 \
- : ( 0xB0 == ((U8*)s)[1] ) ? 0x3B0 : 0 ) \
- : ( 0xE1 == ((U8*)s)[0] ) ? \
- ( ( 0xBA == ((U8*)s)[1] ) ? \
- ( ( 0x9E == ((U8*)s)[2] ) ? 0x1E9E : 0 ) \
- : ( 0xBF == ((U8*)s)[1] ) ? \
- ( ( 0x93 == ((U8*)s)[2] ) ? 0x1FD3 \
- : ( 0xA3 == ((U8*)s)[2] ) ? 0x1FE3 : 0 ) \
- : 0 ) \
- : 0 ) \
- : ( 0xDF == ((U8*)s)[0] ) ? 0xDF : 0 ) \
+ ( ( ( ((U8*)s)[0] & 0xDF ) == 0x46 ) ? \
+ ( ( ( ((U8*)s)[1] & 0xDF ) == 0x46 ) ? \
+ ( ( ( ( ((U8*)s)[2] & 0xDF ) == 0x49 ) || ( ( ((U8*)s)[2] & 0xDF ) == 0x4C ) ) ? 3 : 2 )\
+ : ( ( ( ((U8*)s)[1] & 0xDF ) == 0x49 ) || ( ( ((U8*)s)[1] & 0xDF ) == 0x4C ) ) ? 2 : 0 )\
+ : ( ( ( ((U8*)s)[0] & 0xDF ) == 0x53 ) && ( ( ( ((U8*)s)[1] & 0xDF ) == 0x53 ) || ( ( ((U8*)s)[1] & 0xDF ) == 0x54 ) ) ) ? 2 : 0 )\
: ((e)-(s) > 1) ? \
- ( ( is_utf8 ) ? \
- ( ( 0xC3 == ((U8*)s)[0] ) ? \
- ( ( 0x9F == ((U8*)s)[1] ) ? 0xDF : 0 ) \
- : ( 0xCE == ((U8*)s)[0] ) ? \
- ( ( 0x90 == ((U8*)s)[1] ) ? 0x390 \
- : ( 0xB0 == ((U8*)s)[1] ) ? 0x3B0 : 0 ) \
- : 0 ) \
- : ( 0xDF == ((U8*)s)[0] ) ? 0xDF : 0 ) \
+ ( ( ( ((U8*)s)[0] & 0xDF ) == 0x46 ) ? \
+ ( ( ( ( ((U8*)s)[1] & 0xDF ) == 0x46 ) || ( ( ((U8*)s)[1] & 0xDF ) == 0x49 ) || ( ( ((U8*)s)[1] & 0xDF ) == 0x4C ) ) ? 2 : 0 )\
+ : ( ( ( ((U8*)s)[0] & 0xDF ) == 0x53 ) && ( ( ( ((U8*)s)[1] & 0xDF ) == 0x53 ) || ( ( ((U8*)s)[1] & 0xDF ) == 0x54 ) ) ) ? 2 : 0 )\
+: 0 )
+
+/*
+ PATWS: pattern white space
+
+ \p{PatWS}
+*/
+/*** GENERATED CODE ***/
+#define is_PATWS(s,is_utf8) \
+( ( ( 0x09 <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) || 0x20 == ((U8*)s)[0] ) ? 1\
+: ( is_utf8 ) ? \
+ ( ( 0xC2 == ((U8*)s)[0] ) ? \
+ ( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \
+ : ( ( ( 0xE2 == ((U8*)s)[0] ) && ( 0x80 == ((U8*)s)[1] ) ) && ( ( ((U8*)s)[2] & 0xFE ) == 0x8E || ( ((U8*)s)[2] & 0xFE ) == 0xA8 ) ) ? 3 : 0 )\
+: ( 0x85 == ((U8*)s)[0] ) )
+
+/*** GENERATED CODE ***/
+#define is_PATWS_safe(s,e,is_utf8) \
+( ((e)-(s) > 2) ? \
+ ( ( ( 0x09 <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) || 0x20 == ((U8*)s)[0] ) ? 1\
+ : ( is_utf8 ) ? \
+ ( ( 0xC2 == ((U8*)s)[0] ) ? \
+ ( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \
+ : ( ( ( 0xE2 == ((U8*)s)[0] ) && ( 0x80 == ((U8*)s)[1] ) ) && ( ( ((U8*)s)[2] & 0xFE ) == 0x8E || ( ((U8*)s)[2] & 0xFE ) == 0xA8 ) ) ? 3 : 0 )\
+ : ( 0x85 == ((U8*)s)[0] ) ) \
+: ((e)-(s) > 1) ? \
+ ( ( ( 0x09 <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) || 0x20 == ((U8*)s)[0] ) ? 1\
+ : ( is_utf8 ) ? \
+ ( ( ( 0xC2 == ((U8*)s)[0] ) && ( 0x85 == ((U8*)s)[1] ) ) ? 2 : 0 ) \
+ : ( 0x85 == ((U8*)s)[0] ) ) \
: ((e)-(s) > 0) ? \
- ( ( ( !( is_utf8 ) ) && ( 0xDF == ((U8*)s)[0] ) ) ? 0xDF : 0 ) \
+ ( ( ( 0x09 <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) || 0x20 == ((U8*)s)[0] ) ? 1\
+ : ( !( is_utf8 ) ) ? \
+ ( 0x85 == ((U8*)s)[0] ) \
+ : 0 ) \
: 0 )
/*** GENERATED CODE ***/
-#define what_len_TRICKYFOLD(s,is_utf8,len) \
+#define is_PATWS_non_low(s,is_utf8) \
( ( is_utf8 ) ? \
- ( ( 0xC3 == ((U8*)s)[0] ) ? \
- ( ( 0x9F == ((U8*)s)[1] ) ? len=2, 0xDF : 0 ) \
- : ( 0xCE == ((U8*)s)[0] ) ? \
- ( ( 0x90 == ((U8*)s)[1] ) ? len=2, 0x390 \
- : ( 0xB0 == ((U8*)s)[1] ) ? len=2, 0x3B0 : 0 ) \
- : ( 0xE1 == ((U8*)s)[0] ) ? \
- ( ( 0xBA == ((U8*)s)[1] ) ? \
- ( ( 0x9E == ((U8*)s)[2] ) ? len=3, 0x1E9E : 0 ) \
- : ( 0xBF == ((U8*)s)[1] ) ? \
- ( ( 0x93 == ((U8*)s)[2] ) ? len=3, 0x1FD3 \
- : ( 0xA3 == ((U8*)s)[2] ) ? len=3, 0x1FE3 : 0 ) \
- : 0 ) \
- : 0 ) \
-: ( 0xDF == ((U8*)s)[0] ) ? len=1, 0xDF : 0 )
+ ( ( 0xC2 == ((U8*)s)[0] ) ? \
+ ( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \
+ : ( ( ( 0xE2 == ((U8*)s)[0] ) && ( 0x80 == ((U8*)s)[1] ) ) && ( ( ((U8*)s)[2] & 0xFE ) == 0x8E || ( ((U8*)s)[2] & 0xFE ) == 0xA8 ) ) ? 3 : 0 )\
+: ( 0x85 == ((U8*)s)[0] ) )
/*** GENERATED CODE ***/
-#define what_len_TRICKYFOLD_safe(s,e,is_utf8,len) \
+#define is_PATWS_non_low_safe(s,e,is_utf8) \
( ((e)-(s) > 2) ? \
( ( is_utf8 ) ? \
- ( ( 0xC3 == ((U8*)s)[0] ) ? \
- ( ( 0x9F == ((U8*)s)[1] ) ? len=2, 0xDF : 0 ) \
- : ( 0xCE == ((U8*)s)[0] ) ? \
- ( ( 0x90 == ((U8*)s)[1] ) ? len=2, 0x390 \
- : ( 0xB0 == ((U8*)s)[1] ) ? len=2, 0x3B0 : 0 ) \
- : ( 0xE1 == ((U8*)s)[0] ) ? \
- ( ( 0xBA == ((U8*)s)[1] ) ? \
- ( ( 0x9E == ((U8*)s)[2] ) ? len=3, 0x1E9E : 0 ) \
- : ( 0xBF == ((U8*)s)[1] ) ? \
- ( ( 0x93 == ((U8*)s)[2] ) ? len=3, 0x1FD3 \
- : ( 0xA3 == ((U8*)s)[2] ) ? len=3, 0x1FE3 : 0 ) \
- : 0 ) \
- : 0 ) \
- : ( 0xDF == ((U8*)s)[0] ) ? len=1, 0xDF : 0 ) \
+ ( ( 0xC2 == ((U8*)s)[0] ) ? \
+ ( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \
+ : ( ( ( 0xE2 == ((U8*)s)[0] ) && ( 0x80 == ((U8*)s)[1] ) ) && ( ( ((U8*)s)[2] & 0xFE ) == 0x8E || ( ((U8*)s)[2] & 0xFE ) == 0xA8 ) ) ? 3 : 0 )\
+ : ( 0x85 == ((U8*)s)[0] ) ) \
: ((e)-(s) > 1) ? \
( ( is_utf8 ) ? \
- ( ( 0xC3 == ((U8*)s)[0] ) ? \
- ( ( 0x9F == ((U8*)s)[1] ) ? len=2, 0xDF : 0 ) \
- : ( 0xCE == ((U8*)s)[0] ) ? \
- ( ( 0x90 == ((U8*)s)[1] ) ? len=2, 0x390 \
- : ( 0xB0 == ((U8*)s)[1] ) ? len=2, 0x3B0 : 0 ) \
- : 0 ) \
- : ( 0xDF == ((U8*)s)[0] ) ? len=1, 0xDF : 0 ) \
-: ((e)-(s) > 0) ? \
- ( ( ( !( is_utf8 ) ) && ( 0xDF == ((U8*)s)[0] ) ) ? len=1, 0xDF : 0 ) \
-: 0 )
+ ( ( ( 0xC2 == ((U8*)s)[0] ) && ( 0x85 == ((U8*)s)[1] ) ) ? 2 : 0 ) \
+ : ( 0x85 == ((U8*)s)[0] ) ) \
+: ( ((e)-(s) > 0) && ( !( is_utf8 ) ) ) ? ( 0x85 == ((U8*)s)[0] ) : 0 )
+/*** GENERATED CODE ***/
+#define is_PATWS_cp(cp) \
+( ( 0x09 <= cp && cp <= 0x0D ) || ( 0x0D < cp && \
+( 0x20 == cp || ( 0x20 < cp && \
+( 0x85 == cp || ( 0x85 < cp && \
+( 0x200E == cp || ( 0x200E < cp && \
+( 0x200F == cp || ( 0x200F < cp && \
+( 0x2028 == cp || 0x2029 == cp ) ) ) ) ) ) ) ) ) ) )
+
+#endif /* H_REGCHARCLASS */
+
/* ex: set ro: */
Property changes on: trunk/contrib/perl/regcharclass.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/regcomp.c
===================================================================
--- trunk/contrib/perl/regcomp.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/regcomp.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -81,12 +81,20 @@
#define REG_COMP_C
#ifdef PERL_IN_XSUB_RE
# include "re_comp.h"
+extern const struct regexp_engine my_reg_engine;
#else
# include "regcomp.h"
#endif
#include "dquote_static.c"
+#include "charclass_invlists.h"
+#include "inline_invlist.c"
+#include "unicode_constants.h"
+#define HAS_NONLATIN1_FOLD_CLOSURE(i) _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)
+#define IS_NON_FINAL_FOLD(c) _IS_NON_FINAL_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
+#define IS_IN_SOME_FOLD_L1(c) _IS_IN_SOME_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
+
#ifdef op
#undef op
#endif /* op */
@@ -104,8 +112,10 @@
#define STATIC static
#endif
+
typedef struct RExC_state_t {
- U32 flags; /* are we folding, multilining? */
+ U32 flags; /* RXf_* are we folding, multilining? */
+ U32 pm_flags; /* PMf_* stuff from the calling PMOP */
char *precomp; /* uncompiled string. */
REGEXP *rx_sv; /* The SV that is the regexp. */
regexp *rx; /* perl core regexp structure */
@@ -126,7 +136,6 @@
I32 nestroot; /* root parens we are in - used by accept */
I32 extralen;
I32 seen_zerolen;
- I32 seen_evals;
regnode **open_parens; /* pointers to open parens */
regnode **close_parens; /* pointers to close parens */
regnode *opend; /* END node in program */
@@ -144,10 +153,16 @@
I32 in_lookbehind;
I32 contains_locale;
I32 override_recoding;
+ I32 in_multi_char_class;
+ struct reg_code_block *code_blocks; /* positions of literal (?{})
+ within pattern */
+ int num_code_blocks; /* size of code_blocks[] */
+ int code_index; /* next code_blocks[] slot */
#if ADD_TO_REGEXEC
char *starttry; /* -Dr: where regtry was called. */
#define RExC_starttry (pRExC_state->starttry)
#endif
+ SV *runtime_code_qr; /* qr with the runtime code blocks */
#ifdef DEBUGGING
const char *lastparse;
I32 lastnum;
@@ -159,6 +174,7 @@
} RExC_state_t;
#define RExC_flags (pRExC_state->flags)
+#define RExC_pm_flags (pRExC_state->pm_flags)
#define RExC_precomp (pRExC_state->precomp)
#define RExC_rx_sv (pRExC_state->rx_sv)
#define RExC_rx (pRExC_state->rx)
@@ -181,7 +197,6 @@
#define RExC_nestroot (pRExC_state->nestroot)
#define RExC_extralen (pRExC_state->extralen)
#define RExC_seen_zerolen (pRExC_state->seen_zerolen)
-#define RExC_seen_evals (pRExC_state->seen_evals)
#define RExC_utf8 (pRExC_state->utf8)
#define RExC_uni_semantics (pRExC_state->uni_semantics)
#define RExC_orig_utf8 (pRExC_state->orig_utf8)
@@ -193,12 +208,13 @@
#define RExC_recurse_count (pRExC_state->recurse_count)
#define RExC_in_lookbehind (pRExC_state->in_lookbehind)
#define RExC_contains_locale (pRExC_state->contains_locale)
-#define RExC_override_recoding (pRExC_state->override_recoding)
+#define RExC_override_recoding (pRExC_state->override_recoding)
+#define RExC_in_multi_char_class (pRExC_state->in_multi_char_class)
#define ISMULT1(c) ((c) == '*' || (c) == '+' || (c) == '?')
#define ISMULT2(s) ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
- ((*s) == '{' && regcurly(s)))
+ ((*s) == '{' && regcurly(s, FALSE)))
#ifdef SPSTART
#undef SPSTART /* dratted cpp namespace... */
@@ -209,12 +225,15 @@
#define WORST 0 /* Worst case. */
#define HASWIDTH 0x01 /* Known to match non-null strings. */
-/* Simple enough to be STAR/PLUS operand, in an EXACT node must be a single
- * character, and if utf8, must be invariant. Note that this is not the same thing as REGNODE_SIMPLE */
+/* Simple enough to be STAR/PLUS operand; in an EXACTish node must be a single
+ * character. (There needs to be a case: in the switch statement in regexec.c
+ * for any node marked SIMPLE.) Note that this is not the same thing as
+ * REGNODE_SIMPLE */
#define SIMPLE 0x02
-#define SPSTART 0x04 /* Starts with * or +. */
-#define TRYAGAIN 0x08 /* Weeded out a declaration. */
-#define POSTPONED 0x10 /* (?1),(?&name), (??{...}) or similar */
+#define SPSTART 0x04 /* Starts with * or + */
+#define POSTPONED 0x08 /* (?1),(?&name), (??{...}) or similar */
+#define TRYAGAIN 0x10 /* Weeded out a declaration. */
+#define RESTART_UTF8 0x20 /* Restart, need to calcuate sizes as UTF-8 */
#define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
@@ -233,12 +252,18 @@
#define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren)
#define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren))
-/* If not already in utf8, do a longjmp back to the beginning */
-#define UTF8_LONGJMP 42 /* Choose a value not likely to ever conflict */
#define REQUIRE_UTF8 STMT_START { \
- if (! UTF) JMPENV_JUMP(UTF8_LONGJMP); \
+ if (!UTF) { \
+ *flagp = RESTART_UTF8; \
+ return NULL; \
+ } \
} STMT_END
+/* This converts the named class defined in regcomp.h to its equivalent class
+ * number defined in handy.h. */
+#define namedclass_to_classnum(class) ((int) ((class) / 2))
+#define classnum_to_namedclass(classnum) ((classnum) * 2)
+
/* About scan_data_t.
During optimisation we recurse through the regexp program performing
@@ -277,8 +302,8 @@
string can occur infinitely far to the right.
- minlenp
- A pointer to the minimum length of the pattern that the string
- was found inside. This is important as in the case of positive
+ A pointer to the minimum number of characters of the pattern that the
+ string was found inside. This is important as in the case of positive
lookahead or positive lookbehind we can have multiple patterns
involved. Consider
@@ -379,19 +404,25 @@
#define SCF_SEEN_ACCEPT 0x8000
#define UTF cBOOL(RExC_utf8)
+
+/* The enums for all these are ordered so things work out correctly */
#define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
+#define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_DEPENDS_CHARSET)
#define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
-#define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_DEPENDS_CHARSET)
#define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags) >= REGEX_UNICODE_CHARSET)
#define ASCII_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_RESTRICTED_CHARSET)
-#define MORE_ASCII_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
#define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags) >= REGEX_ASCII_RESTRICTED_CHARSET)
+#define ASCII_FOLD_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
#define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
-#define OOB_UNICODE 12345678
#define OOB_NAMEDCLASS -1
+/* There is no code point that is out-of-bounds, so this is problematic. But
+ * its only current use is to initialize a variable that is always set before
+ * looked at. */
+#define OOB_UNICODE 0xDEADBEEF
+
#define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
#define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
@@ -419,7 +450,7 @@
IV len = RExC_end - RExC_precomp; \
\
if (!SIZE_ONLY) \
- SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv); \
+ SAVEFREESV(RExC_rx_sv); \
if (len > RegexLengthToShowInErrorMessages) { \
/* chop 10 shorter than the max, to ensure meaning of "..." */ \
len = RegexLengthToShowInErrorMessages - 10; \
@@ -450,7 +481,7 @@
*/
#define vFAIL(m) STMT_START { \
if (!SIZE_ONLY) \
- SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv); \
+ SAVEFREESV(RExC_rx_sv); \
Simple_vFAIL(m); \
} STMT_END
@@ -468,7 +499,7 @@
*/
#define vFAIL2(m,a1) STMT_START { \
if (!SIZE_ONLY) \
- SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv); \
+ SAVEFREESV(RExC_rx_sv); \
Simple_vFAIL2(m, a1); \
} STMT_END
@@ -487,7 +518,7 @@
*/
#define vFAIL3(m,a1,a2) STMT_START { \
if (!SIZE_ONLY) \
- SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv); \
+ SAVEFREESV(RExC_rx_sv); \
Simple_vFAIL3(m, a1, a2); \
} STMT_END
@@ -500,6 +531,19 @@
(int)offset, RExC_precomp, RExC_precomp + offset); \
} STMT_END
+#define vFAIL4(m,a1,a2,a3) STMT_START { \
+ if (!SIZE_ONLY) \
+ SAVEFREESV(RExC_rx_sv); \
+ Simple_vFAIL4(m, a1, a2, a3); \
+} STMT_END
+
+/* m is not necessarily a "literal string", in this macro */
+#define reg_warn_non_literal_string(loc, m) STMT_START { \
+ const IV offset = loc - RExC_precomp; \
+ Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s" REPORT_LOCATION, \
+ m, (int)offset, RExC_precomp, RExC_precomp + offset); \
+} STMT_END
+
#define ckWARNreg(loc,m) STMT_START { \
const IV offset = loc - RExC_precomp; \
Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
@@ -506,6 +550,19 @@
(int)offset, RExC_precomp, RExC_precomp + offset); \
} STMT_END
+#define vWARN_dep(loc, m) STMT_START { \
+ const IV offset = loc - RExC_precomp; \
+ Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), m REPORT_LOCATION, \
+ (int)offset, RExC_precomp, RExC_precomp + offset); \
+} STMT_END
+
+#define ckWARNdep(loc,m) STMT_START { \
+ const IV offset = loc - RExC_precomp; \
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), \
+ m REPORT_LOCATION, \
+ (int)offset, RExC_precomp, RExC_precomp + offset); \
+} STMT_END
+
#define ckWARNregdep(loc,m) STMT_START { \
const IV offset = loc - RExC_precomp; \
Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP), \
@@ -665,8 +722,6 @@
PerlIO_printf(Perl_debug_log,"\n"); \
});
-static void clear_re(pTHX_ void *r);
-
/* Mark that we cannot extend a found fixed substring at this point.
Update the longest found anchored substring and the longest found
floating substrings if needed. */
@@ -689,7 +744,7 @@
|= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
else
data->flags &= ~SF_FIX_BEFORE_EOL;
- data->minlen_fixed=minlenp;
+ data->minlen_fixed=minlenp;
data->lookbehind_fixed=0;
}
else { /* *data->longest == data->longest_float */
@@ -696,7 +751,7 @@
data->offset_float_min = l ? data->last_start_min : data->pos_min;
data->offset_float_max = (l
? data->last_start_max
- : data->pos_min + data->pos_delta);
+ : (data->pos_delta == I32_MAX ? I32_MAX : data->pos_min + data->pos_delta));
if (is_inf || (U32)data->offset_float_max > (U32)I32_MAX)
data->offset_float_max = I32_MAX;
if (data->flags & SF_BEFORE_EOL)
@@ -722,6 +777,17 @@
DEBUG_STUDYDATA("commit: ",data,0);
}
+/* These macros set, clear and test whether the synthetic start class ('ssc',
+ * given by the parameter) matches an empty string (EOS). This uses the
+ * 'next_off' field in the node, to save a bit in the flags field. The ssc
+ * stands alone, so there is never a next_off, so this field is otherwise
+ * unused. The EOS information is used only for compilation, but theoretically
+ * it could be passed on to the execution code. This could be used to store
+ * more than one bit of information, but only this one is currently used. */
+#define SET_SSC_EOS(node) STMT_START { (node)->next_off = TRUE; } STMT_END
+#define CLEAR_SSC_EOS(node) STMT_START { (node)->next_off = FALSE; } STMT_END
+#define TEST_SSC_EOS(node) cBOOL((node)->next_off)
+
/* Can match anything (initialization) */
STATIC void
S_cl_anything(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
@@ -729,8 +795,8 @@
PERL_ARGS_ASSERT_CL_ANYTHING;
ANYOF_BITMAP_SETALL(cl);
- cl->flags = ANYOF_CLASS|ANYOF_EOS|ANYOF_UNICODE_ALL
- |ANYOF_LOC_NONBITMAP_FOLD|ANYOF_NON_UTF8_LATIN1_ALL;
+ cl->flags = ANYOF_UNICODE_ALL;
+ SET_SSC_EOS(cl);
/* If any portion of the regex is to operate under locale rules,
* initialization includes it. The reason this isn't done for all regexes
@@ -741,7 +807,7 @@
* necessary. */
if (RExC_contains_locale) {
ANYOF_CLASS_SETALL(cl); /* /l uses class */
- cl->flags |= ANYOF_LOCALE;
+ cl->flags |= ANYOF_LOCALE|ANYOF_CLASS|ANYOF_LOC_FOLD;
}
else {
ANYOF_CLASS_ZERO(cl); /* Only /l uses class now */
@@ -756,7 +822,7 @@
PERL_ARGS_ASSERT_CL_IS_ANYTHING;
- for (value = 0; value <= ANYOF_MAX; value += 2)
+ for (value = 0; value < ANYOF_MAX; value += 2)
if (ANYOF_CLASS_TEST(cl, value) && ANYOF_CLASS_TEST(cl, value + 1))
return 1;
if (!(cl->flags & ANYOF_UNICODE_ALL))
@@ -790,14 +856,14 @@
{
PERL_ARGS_ASSERT_CL_AND;
- assert(and_with->type == ANYOF);
+ assert(PL_regkind[and_with->type] == ANYOF);
/* I (khw) am not sure all these restrictions are necessary XXX */
if (!(ANYOF_CLASS_TEST_ANY_SET(and_with))
&& !(ANYOF_CLASS_TEST_ANY_SET(cl))
&& (and_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
- && !(and_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
- && !(cl->flags & ANYOF_LOC_NONBITMAP_FOLD)) {
+ && !(and_with->flags & ANYOF_LOC_FOLD)
+ && !(cl->flags & ANYOF_LOC_FOLD)) {
int i;
if (and_with->flags & ANYOF_INVERT)
@@ -930,8 +996,8 @@
* (OK1(i) | OK1(i')) | (!OK1(i) & !OK1(i'))
*/
else if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
- && !(or_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
- && !(cl->flags & ANYOF_LOC_NONBITMAP_FOLD) ) {
+ && !(or_with->flags & ANYOF_LOC_FOLD)
+ && !(cl->flags & ANYOF_LOC_FOLD) ) {
int i;
for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
@@ -957,18 +1023,16 @@
} else { /* 'or_with' is not inverted */
/* (B1 | CL1) | (B2 | CL2) = (B1 | B2) | (CL1 | CL2)) */
if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
- && (!(or_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
- || (cl->flags & ANYOF_LOC_NONBITMAP_FOLD)) ) {
+ && (!(or_with->flags & ANYOF_LOC_FOLD)
+ || (cl->flags & ANYOF_LOC_FOLD)) ) {
int i;
/* OR char bitmap and class bitmap separately */
for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
cl->bitmap[i] |= or_with->bitmap[i];
- if (ANYOF_CLASS_TEST_ANY_SET(or_with)) {
- for (i = 0; i < ANYOF_CLASSBITMAP_SIZE; i++)
- cl->classflags[i] |= or_with->classflags[i];
- cl->flags |= ANYOF_CLASS;
- }
+ if (or_with->flags & ANYOF_CLASS) {
+ ANYOF_CLASS_OR(or_with, cl);
+ }
}
else { /* XXXX: logic is complicated, leave it along for a moment. */
cl_anything(pRExC_state, cl);
@@ -1361,44 +1425,47 @@
*(d++) = uv;
*/
-#define TRIE_STORE_REVCHAR \
+#define TRIE_STORE_REVCHAR(val) \
STMT_START { \
if (UTF) { \
- SV *zlopp = newSV(2); \
+ SV *zlopp = newSV(7); /* XXX: optimize me */ \
unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp); \
- unsigned const char *const kapow = uvuni_to_utf8(flrbbbbb, uvc & 0xFF); \
+ unsigned const char *const kapow = uvuni_to_utf8(flrbbbbb, val); \
SvCUR_set(zlopp, kapow - flrbbbbb); \
SvPOK_on(zlopp); \
SvUTF8_on(zlopp); \
av_push(revcharmap, zlopp); \
} else { \
- char ooooff = (char)uvc; \
+ char ooooff = (char)val; \
av_push(revcharmap, newSVpvn(&ooooff, 1)); \
} \
} STMT_END
-#define TRIE_READ_CHAR STMT_START { \
- wordlen++; \
- if ( UTF ) { \
- if ( folder ) { \
- if ( foldlen > 0 ) { \
- uvc = utf8n_to_uvuni( scan, UTF8_MAXLEN, &len, uniflags ); \
- foldlen -= len; \
- scan += len; \
- len = 0; \
- } else { \
- uvc = utf8n_to_uvuni( (const U8*)uc, UTF8_MAXLEN, &len, uniflags);\
- uvc = to_uni_fold( uvc, foldbuf, &foldlen ); \
- foldlen -= UNISKIP( uvc ); \
- scan = foldbuf + UNISKIP( uvc ); \
- } \
- } else { \
- uvc = utf8n_to_uvuni( (const U8*)uc, UTF8_MAXLEN, &len, uniflags);\
- } \
- } else { \
- uvc = (U32)*uc; \
- len = 1; \
- } \
+#define TRIE_READ_CHAR STMT_START { \
+ wordlen++; \
+ if ( UTF ) { \
+ /* if it is UTF then it is either already folded, or does not need folding */ \
+ uvc = utf8n_to_uvuni( (const U8*) uc, UTF8_MAXLEN, &len, uniflags); \
+ } \
+ else if (folder == PL_fold_latin1) { \
+ /* if we use this folder we have to obey unicode rules on latin-1 data */ \
+ if ( foldlen > 0 ) { \
+ uvc = utf8n_to_uvuni( (const U8*) scan, UTF8_MAXLEN, &len, uniflags ); \
+ foldlen -= len; \
+ scan += len; \
+ len = 0; \
+ } else { \
+ len = 1; \
+ uvc = _to_fold_latin1( (U8) *uc, foldbuf, &foldlen, 1); \
+ skiplen = UNISKIP(uvc); \
+ foldlen -= skiplen; \
+ scan = foldbuf + skiplen; \
+ } \
+ } else { \
+ /* raw data, will be folded later if needed */ \
+ uvc = (U32)*uc; \
+ len = 1; \
+ } \
} STMT_END
@@ -1515,10 +1582,14 @@
#endif
switch (flags) {
+ case EXACT: break;
case EXACTFA:
+ case EXACTFU_SS:
+ case EXACTFU_TRICKYFOLD:
case EXACTFU: folder = PL_fold_latin1; break;
case EXACTF: folder = PL_fold; break;
case EXACTFL: folder = PL_fold_locale; break;
+ default: Perl_croak( aTHX_ "panic! In trie construction, unknown node type %u %s", (unsigned) flags, PL_reg_name[flags] );
}
trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
@@ -1527,7 +1598,7 @@
trie->wordcount = word_count;
RExC_rxi->data->data[ data_slot ] = (void*)trie;
trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
- if (!(UTF && folder))
+ if (flags == EXACT)
trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
trie->wordcount+1, sizeof(reg_trie_wordinfo));
@@ -1540,7 +1611,7 @@
if (!SvIOK(re_trie_maxbuff)) {
sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
}
- DEBUG_OPTIMISE_r({
+ DEBUG_TRIE_COMPILE_r({
PerlIO_printf( Perl_debug_log,
"%*smake_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
(int)depth * 2 + 2, "",
@@ -1582,11 +1653,12 @@
*/
for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
- regnode * const noper = NEXTOPER( cur );
+ regnode *noper = NEXTOPER( cur );
const U8 *uc = (U8*)STRING( noper );
- const U8 * const e = uc + STR_LEN( noper );
+ const U8 *e = uc + STR_LEN( noper );
STRLEN foldlen = 0;
U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
+ STRLEN skiplen = 0;
const U8 *scan = (U8*)NULL;
U32 wordlen = 0; /* required init */
STRLEN chars = 0;
@@ -1593,31 +1665,49 @@
bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the bitmap?*/
if (OP(noper) == NOTHING) {
- trie->minlen= 0;
- continue;
+ regnode *noper_next= regnext(noper);
+ if (noper_next != tail && OP(noper_next) == flags) {
+ noper = noper_next;
+ uc= (U8*)STRING(noper);
+ e= uc + STR_LEN(noper);
+ trie->minlen= STR_LEN(noper);
+ } else {
+ trie->minlen= 0;
+ continue;
+ }
}
- if ( set_bit ) /* bitmap only alloced when !(UTF&&Folding) */
+
+ if ( set_bit ) { /* bitmap only alloced when !(UTF&&Folding) */
TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
regardless of encoding */
-
+ if (OP( noper ) == EXACTFU_SS) {
+ /* false positives are ok, so just set this */
+ TRIE_BITMAP_SET(trie,0xDF);
+ }
+ }
for ( ; uc < e ; uc += len ) {
TRIE_CHARCOUNT(trie)++;
TRIE_READ_CHAR;
chars++;
if ( uvc < 256 ) {
+ if ( folder ) {
+ U8 folded= folder[ (U8) uvc ];
+ if ( !trie->charmap[ folded ] ) {
+ trie->charmap[ folded ]=( ++trie->uniquecharcount );
+ TRIE_STORE_REVCHAR( folded );
+ }
+ }
if ( !trie->charmap[ uvc ] ) {
trie->charmap[ uvc ]=( ++trie->uniquecharcount );
- if ( folder )
- trie->charmap[ folder[ uvc ] ] = trie->charmap[ uvc ];
- TRIE_STORE_REVCHAR;
+ TRIE_STORE_REVCHAR( uvc );
}
if ( set_bit ) {
/* store the codepoint in the bitmap, and its folded
* equivalent. */
- TRIE_BITMAP_SET(trie,uvc);
+ TRIE_BITMAP_SET(trie, uvc);
/* store the folded codepoint */
- if ( folder ) TRIE_BITMAP_SET(trie,folder[ uvc ]);
+ if ( folder ) TRIE_BITMAP_SET(trie, folder[(U8) uvc ]);
if ( !UTF ) {
/* store first byte of utf8 representation of
@@ -1640,18 +1730,29 @@
if ( !SvTRUE( *svpp ) ) {
sv_setiv( *svpp, ++trie->uniquecharcount );
- TRIE_STORE_REVCHAR;
+ TRIE_STORE_REVCHAR(uvc);
}
}
}
if( cur == first ) {
- trie->minlen=chars;
- trie->maxlen=chars;
+ trie->minlen = chars;
+ trie->maxlen = chars;
} else if (chars < trie->minlen) {
- trie->minlen=chars;
+ trie->minlen = chars;
} else if (chars > trie->maxlen) {
- trie->maxlen=chars;
+ trie->maxlen = chars;
}
+ if (OP( noper ) == EXACTFU_SS) {
+ /* XXX: workaround - 'ss' could match "\x{DF}" so minlen could be 1 and not 2*/
+ if (trie->minlen > 1)
+ trie->minlen= 1;
+ }
+ if (OP( noper ) == EXACTFU_TRICKYFOLD) {
+ /* XXX: workround - things like "\x{1FBE}\x{0308}\x{0301}" can match "\x{0390}"
+ * - We assume that any such sequence might match a 2 byte string */
+ if (trie->minlen > 2 )
+ trie->minlen= 2;
+ }
} /* end first pass */
DEBUG_TRIE_COMPILE_r(
@@ -1705,7 +1806,7 @@
DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log,
"%*sCompiling trie using list compiler\n",
(int)depth * 2 + 2, ""));
-
+
trie->states = (reg_trie_state *)
PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
sizeof(reg_trie_state) );
@@ -1714,9 +1815,9 @@
for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
- regnode * const noper = NEXTOPER( cur );
+ regnode *noper = NEXTOPER( cur );
U8 *uc = (U8*)STRING( noper );
- const U8 * const e = uc + STR_LEN( noper );
+ const U8 *e = uc + STR_LEN( noper );
U32 state = 1; /* required init */
U16 charid = 0; /* sanity init */
U8 *scan = (U8*)NULL; /* sanity init */
@@ -1723,7 +1824,17 @@
STRLEN foldlen = 0; /* required init */
U32 wordlen = 0; /* required init */
U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
+ STRLEN skiplen = 0;
+ if (OP(noper) == NOTHING) {
+ regnode *noper_next= regnext(noper);
+ if (noper_next != tail && OP(noper_next) == flags) {
+ noper = noper_next;
+ uc= (U8*)STRING(noper);
+ e= uc + STR_LEN(noper);
+ }
+ }
+
if (OP(noper) != NOTHING) {
for ( ; uc < e ; uc += len ) {
@@ -1911,9 +2022,9 @@
for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
- regnode * const noper = NEXTOPER( cur );
+ regnode *noper = NEXTOPER( cur );
const U8 *uc = (U8*)STRING( noper );
- const U8 * const e = uc + STR_LEN( noper );
+ const U8 *e = uc + STR_LEN( noper );
U32 state = 1; /* required init */
@@ -1923,8 +2034,18 @@
STRLEN foldlen = 0; /* required init */
U32 wordlen = 0; /* required init */
+ STRLEN skiplen = 0;
U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
+ if (OP(noper) == NOTHING) {
+ regnode *noper_next= regnext(noper);
+ if (noper_next != tail && OP(noper_next) == flags) {
+ noper = noper_next;
+ uc= (U8*)STRING(noper);
+ e= uc + STR_LEN(noper);
+ }
+ }
+
if ( OP(noper) != NOTHING ) {
for ( ; uc < e ; uc += len ) {
@@ -2362,7 +2483,7 @@
RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
#else
- SvREFCNT_dec(revcharmap);
+ SvREFCNT_dec_NN(revcharmap);
#endif
return trie->jump
? MADE_JUMP_TRIE
@@ -2503,15 +2624,99 @@
}});
+/* The below joins as many adjacent EXACTish nodes as possible into a single
+ * one. The regop may be changed if the node(s) contain certain sequences that
+ * require special handling. The joining is only done if:
+ * 1) there is room in the current conglomerated node to entirely contain the
+ * next one.
+ * 2) they are the exact same node type
+ *
+ * The adjacent nodes actually may be separated by NOTHING-kind nodes, and
+ * these get optimized out
+ *
+ * If a node is to match under /i (folded), the number of characters it matches
+ * can be different than its character length if it contains a multi-character
+ * fold. *min_subtract is set to the total delta of the input nodes.
+ *
+ * And *has_exactf_sharp_s is set to indicate whether or not the node is EXACTF
+ * and contains LATIN SMALL LETTER SHARP S
+ *
+ * This is as good a place as any to discuss the design of handling these
+ * multi-character fold sequences. It's been wrong in Perl for a very long
+ * time. There are three code points in Unicode whose multi-character folds
+ * were long ago discovered to mess things up. The previous designs for
+ * dealing with these involved assigning a special node for them. This
+ * approach doesn't work, as evidenced by this example:
+ * "\xDFs" =~ /s\xDF/ui # Used to fail before these patches
+ * Both these fold to "sss", but if the pattern is parsed to create a node that
+ * would match just the \xDF, it won't be able to handle the case where a
+ * successful match would have to cross the node's boundary. The new approach
+ * that hopefully generally solves the problem generates an EXACTFU_SS node
+ * that is "sss".
+ *
+ * It turns out that there are problems with all multi-character folds, and not
+ * just these three. Now the code is general, for all such cases, but the
+ * three still have some special handling. The approach taken is:
+ * 1) This routine examines each EXACTFish node that could contain multi-
+ * character fold sequences. It returns in *min_subtract how much to
+ * subtract from the the actual length of the string to get a real minimum
+ * match length; it is 0 if there are no multi-char folds. This delta is
+ * used by the caller to adjust the min length of the match, and the delta
+ * between min and max, so that the optimizer doesn't reject these
+ * possibilities based on size constraints.
+ * 2) Certain of these sequences require special handling by the trie code,
+ * so, if found, this code changes the joined node type to special ops:
+ * EXACTFU_TRICKYFOLD and EXACTFU_SS.
+ * 3) For the sequence involving the Sharp s (\xDF), the node type EXACTFU_SS
+ * is used for an EXACTFU node that contains at least one "ss" sequence in
+ * it. For non-UTF-8 patterns and strings, this is the only case where
+ * there is a possible fold length change. That means that a regular
+ * EXACTFU node without UTF-8 involvement doesn't have to concern itself
+ * with length changes, and so can be processed faster. regexec.c takes
+ * advantage of this. Generally, an EXACTFish node that is in UTF-8 is
+ * pre-folded by regcomp.c. This saves effort in regex matching.
+ * However, the pre-folding isn't done for non-UTF8 patterns because the
+ * fold of the MICRO SIGN requires UTF-8, and we don't want to slow things
+ * down by forcing the pattern into UTF8 unless necessary. Also what
+ * EXACTF and EXACTFL nodes fold to isn't known until runtime. The fold
+ * possibilities for the non-UTF8 patterns are quite simple, except for
+ * the sharp s. All the ones that don't involve a UTF-8 target string are
+ * members of a fold-pair, and arrays are set up for all of them so that
+ * the other member of the pair can be found quickly. Code elsewhere in
+ * this file makes sure that in EXACTFU nodes, the sharp s gets folded to
+ * 'ss', even if the pattern isn't UTF-8. This avoids the issues
+ * described in the next item.
+ * 4) A problem remains for the sharp s in EXACTF nodes. Whether it matches
+ * 'ss' or not is not knowable at compile time. It will match iff the
+ * target string is in UTF-8, unlike the EXACTFU nodes, where it always
+ * matches; and the EXACTFL and EXACTFA nodes where it never does. Thus
+ * it can't be folded to "ss" at compile time, unlike EXACTFU does (as
+ * described in item 3). An assumption that the optimizer part of
+ * regexec.c (probably unwittingly) makes is that a character in the
+ * pattern corresponds to at most a single character in the target string.
+ * (And I do mean character, and not byte here, unlike other parts of the
+ * documentation that have never been updated to account for multibyte
+ * Unicode.) This assumption is wrong only in this case, as all other
+ * cases are either 1-1 folds when no UTF-8 is involved; or is true by
+ * virtue of having this file pre-fold UTF-8 patterns. I'm
+ * reluctant to try to change this assumption, so instead the code punts.
+ * This routine examines EXACTF nodes for the sharp s, and returns a
+ * boolean indicating whether or not the node is an EXACTF node that
+ * contains a sharp s. When it is true, the caller sets a flag that later
+ * causes the optimizer in this file to not set values for the floating
+ * and fixed string lengths, and thus avoids the optimizer code in
+ * regexec.c that makes the invalid assumption. Thus, there is no
+ * optimization based on string lengths for EXACTF nodes that contain the
+ * sharp s. This only happens for /id rules (which means the pattern
+ * isn't in UTF-8).
+ */
-
-
-#define JOIN_EXACT(scan,min,flags) \
+#define JOIN_EXACT(scan,min_subtract,has_exactf_sharp_s, flags) \
if (PL_regkind[OP(scan)] == EXACT) \
- join_exact(pRExC_state,(scan),(min),(flags),NULL,depth+1)
+ join_exact(pRExC_state,(scan),(min_subtract),has_exactf_sharp_s, (flags),NULL,depth+1)
STATIC U32
-S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, I32 *min, U32 flags,regnode *val, U32 depth) {
+S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, UV *min_subtract, bool *has_exactf_sharp_s, U32 flags,regnode *val, U32 depth) {
/* Merge several consecutive EXACTish nodes into one. */
regnode *n = regnext(scan);
U32 stringok = 1;
@@ -2531,13 +2736,15 @@
PERL_UNUSED_ARG(val);
#endif
DEBUG_PEEP("join",scan,depth);
-
- /* Skip NOTHING, merge EXACT*. */
- while (n &&
- ( PL_regkind[OP(n)] == NOTHING ||
- (stringok && (OP(n) == OP(scan))))
+
+ /* Look through the subsequent nodes in the chain. Skip NOTHING, merge
+ * EXACT ones that are mergeable to the current one. */
+ while (n
+ && (PL_regkind[OP(n)] == NOTHING
+ || (stringok && OP(n) == OP(scan)))
&& NEXT_OFF(n)
- && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX) {
+ && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX)
+ {
if (OP(n) == TAIL || n > next)
stringok = 0;
@@ -2554,12 +2761,16 @@
else if (stringok) {
const unsigned int oldl = STR_LEN(scan);
regnode * const nnext = regnext(n);
+
+ /* XXX I (khw) kind of doubt that this works on platforms where
+ * U8_MAX is above 255 because of lots of other assumptions */
+ /* Don't join if the sum can't fit into a single node */
+ if (oldl + STR_LEN(n) > U8_MAX)
+ break;
DEBUG_PEEP("merg",n,depth);
-
merged++;
- if (oldl + STR_LEN(n) > U8_MAX)
- break;
+
NEXT_OFF(scan) += NEXT_OFF(n);
STR_LEN(scan) += STR_LEN(n);
next = n + NODE_SZ_STR(n);
@@ -2585,75 +2796,169 @@
}
#endif
}
-#define GREEK_SMALL_LETTER_IOTA_WITH_DIALYTIKA_AND_TONOS 0x0390
-#define IOTA_D_T GREEK_SMALL_LETTER_IOTA_WITH_DIALYTIKA_AND_TONOS
-#define GREEK_SMALL_LETTER_UPSILON_WITH_DIALYTIKA_AND_TONOS 0x03B0
-#define UPSILON_D_T GREEK_SMALL_LETTER_UPSILON_WITH_DIALYTIKA_AND_TONOS
- if (UTF
- && ( OP(scan) == EXACTF || OP(scan) == EXACTFU || OP(scan) == EXACTFA)
- && ( STR_LEN(scan) >= 6 ) )
- {
- /*
- Two problematic code points in Unicode casefolding of EXACT nodes:
-
- U+0390 - GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
- U+03B0 - GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
-
- which casefold to
-
- Unicode UTF-8
-
- U+03B9 U+0308 U+0301 0xCE 0xB9 0xCC 0x88 0xCC 0x81
- U+03C5 U+0308 U+0301 0xCF 0x85 0xCC 0x88 0xCC 0x81
-
- This means that in case-insensitive matching (or "loose matching",
- as Unicode calls it), an EXACTF of length six (the UTF-8 encoded byte
- length of the above casefolded versions) can match a target string
- of length two (the byte length of UTF-8 encoded U+0390 or U+03B0).
- This would rather mess up the minimum length computation.
-
- What we'll do is to look for the tail four bytes, and then peek
- at the preceding two bytes to see whether we need to decrease
- the minimum length by four (six minus two).
-
- Thanks to the design of UTF-8, there cannot be false matches:
- A sequence of valid UTF-8 bytes cannot be a subsequence of
- another valid sequence of UTF-8 bytes.
-
- */
- char * const s0 = STRING(scan), *s, *t;
- char * const s1 = s0 + STR_LEN(scan) - 1;
- char * const s2 = s1 - 4;
-#ifdef EBCDIC /* RD tunifold greek 0390 and 03B0 */
- const char t0[] = "\xaf\x49\xaf\x42";
-#else
- const char t0[] = "\xcc\x88\xcc\x81";
-#endif
- const char * const t1 = t0 + 3;
-
- for (s = s0 + 2;
- s < s2 && (t = ninstr(s, s1, t0, t1));
- s = t + 4) {
-#ifdef EBCDIC
- if (((U8)t[-1] == 0x68 && (U8)t[-2] == 0xB4) ||
- ((U8)t[-1] == 0x46 && (U8)t[-2] == 0xB5))
-#else
- if (((U8)t[-1] == 0xB9 && (U8)t[-2] == 0xCE) ||
- ((U8)t[-1] == 0x85 && (U8)t[-2] == 0xCF))
-#endif
- *min -= 4;
- }
+ *min_subtract = 0;
+ *has_exactf_sharp_s = FALSE;
+
+ /* Here, all the adjacent mergeable EXACTish nodes have been merged. We
+ * can now analyze for sequences of problematic code points. (Prior to
+ * this final joining, sequences could have been split over boundaries, and
+ * hence missed). The sequences only happen in folding, hence for any
+ * non-EXACT EXACTish node */
+ if (OP(scan) != EXACT) {
+ const U8 * const s0 = (U8*) STRING(scan);
+ const U8 * s = s0;
+ const U8 * const s_end = s0 + STR_LEN(scan);
+
+ /* One pass is made over the node's string looking for all the
+ * possibilities. to avoid some tests in the loop, there are two main
+ * cases, for UTF-8 patterns (which can't have EXACTF nodes) and
+ * non-UTF-8 */
+ if (UTF) {
+
+ /* Examine the string for a multi-character fold sequence. UTF-8
+ * patterns have all characters pre-folded by the time this code is
+ * executed */
+ while (s < s_end - 1) /* Can stop 1 before the end, as minimum
+ length sequence we are looking for is 2 */
+ {
+ int count = 0;
+ int len = is_MULTI_CHAR_FOLD_utf8_safe(s, s_end);
+ if (! len) { /* Not a multi-char fold: get next char */
+ s += UTF8SKIP(s);
+ continue;
+ }
+
+ /* Nodes with 'ss' require special handling, except for EXACTFL
+ * and EXACTFA for which there is no multi-char fold to this */
+ if (len == 2 && *s == 's' && *(s+1) == 's'
+ && OP(scan) != EXACTFL && OP(scan) != EXACTFA)
+ {
+ count = 2;
+ OP(scan) = EXACTFU_SS;
+ s += 2;
+ }
+ else if (len == 6 /* len is the same in both ASCII and EBCDIC for these */
+ && (memEQ(s, GREEK_SMALL_LETTER_IOTA_UTF8
+ COMBINING_DIAERESIS_UTF8
+ COMBINING_ACUTE_ACCENT_UTF8,
+ 6)
+ || memEQ(s, GREEK_SMALL_LETTER_UPSILON_UTF8
+ COMBINING_DIAERESIS_UTF8
+ COMBINING_ACUTE_ACCENT_UTF8,
+ 6)))
+ {
+ count = 3;
+
+ /* These two folds require special handling by trie's, so
+ * change the node type to indicate this. If EXACTFA and
+ * EXACTFL were ever to be handled by trie's, this would
+ * have to be changed. If this node has already been
+ * changed to EXACTFU_SS in this loop, leave it as is. (I
+ * (khw) think it doesn't matter in regexec.c for UTF
+ * patterns, but no need to change it */
+ if (OP(scan) == EXACTFU) {
+ OP(scan) = EXACTFU_TRICKYFOLD;
+ }
+ s += 6;
+ }
+ else { /* Here is a generic multi-char fold. */
+ const U8* multi_end = s + len;
+
+ /* Count how many characters in it. In the case of /l and
+ * /aa, no folds which contain ASCII code points are
+ * allowed, so check for those, and skip if found. (In
+ * EXACTFL, no folds are allowed to any Latin1 code point,
+ * not just ASCII. But there aren't any of these
+ * currently, nor ever likely, so don't take the time to
+ * test for them. The code that generates the
+ * is_MULTI_foo() macros croaks should one actually get put
+ * into Unicode .) */
+ if (OP(scan) != EXACTFL && OP(scan) != EXACTFA) {
+ count = utf8_length(s, multi_end);
+ s = multi_end;
+ }
+ else {
+ while (s < multi_end) {
+ if (isASCII(*s)) {
+ s++;
+ goto next_iteration;
+ }
+ else {
+ s += UTF8SKIP(s);
+ }
+ count++;
+ }
+ }
+ }
+
+ /* The delta is how long the sequence is minus 1 (1 is how long
+ * the character that folds to the sequence is) */
+ *min_subtract += count - 1;
+ next_iteration: ;
+ }
+ }
+ else if (OP(scan) != EXACTFL && OP(scan) != EXACTFA) {
+
+ /* Here, the pattern is not UTF-8. Look for the multi-char folds
+ * that are all ASCII. As in the above case, EXACTFL and EXACTFA
+ * nodes can't have multi-char folds to this range (and there are
+ * no existing ones in the upper latin1 range). In the EXACTF
+ * case we look also for the sharp s, which can be in the final
+ * position. Otherwise we can stop looking 1 byte earlier because
+ * have to find at least two characters for a multi-fold */
+ const U8* upper = (OP(scan) == EXACTF) ? s_end : s_end -1;
+
+ /* The below is perhaps overboard, but this allows us to save a
+ * test each time through the loop at the expense of a mask. This
+ * is because on both EBCDIC and ASCII machines, 'S' and 's' differ
+ * by a single bit. On ASCII they are 32 apart; on EBCDIC, they
+ * are 64. This uses an exclusive 'or' to find that bit and then
+ * inverts it to form a mask, with just a single 0, in the bit
+ * position where 'S' and 's' differ. */
+ const U8 S_or_s_mask = (U8) ~ ('S' ^ 's');
+ const U8 s_masked = 's' & S_or_s_mask;
+
+ while (s < upper) {
+ int len = is_MULTI_CHAR_FOLD_latin1_safe(s, s_end);
+ if (! len) { /* Not a multi-char fold. */
+ if (*s == LATIN_SMALL_LETTER_SHARP_S && OP(scan) == EXACTF)
+ {
+ *has_exactf_sharp_s = TRUE;
+ }
+ s++;
+ continue;
+ }
+
+ if (len == 2
+ && ((*s & S_or_s_mask) == s_masked)
+ && ((*(s+1) & S_or_s_mask) == s_masked))
+ {
+
+ /* EXACTF nodes need to know that the minimum length
+ * changed so that a sharp s in the string can match this
+ * ss in the pattern, but they remain EXACTF nodes, as they
+ * won't match this unless the target string is is UTF-8,
+ * which we don't know until runtime */
+ if (OP(scan) != EXACTF) {
+ OP(scan) = EXACTFU_SS;
+ }
+ }
+
+ *min_subtract += len - 1;
+ s += len;
+ }
+ }
}
-
+
#ifdef DEBUGGING
- /* Allow dumping */
+ /* Allow dumping but overwriting the collection of skipped
+ * ops and/or strings with fake optimized ops */
n = scan + NODE_SZ_STR(scan);
while (n <= stop) {
- if (PL_regkind[OP(n)] != NOTHING || OP(n) == NOTHING) {
- OP(n) = OPTIMIZED;
- NEXT_OFF(n) = 0;
- }
+ OP(n) = OPTIMIZED;
+ FLAGS(n) = 0;
+ NEXT_OFF(n) = 0;
n++;
}
#endif
@@ -2686,34 +2991,6 @@
#define SCAN_COMMIT(s, data, m) scan_commit(s, data, m, is_inf)
-#define CASE_SYNST_FNC(nAmE) \
-case nAmE: \
- if (flags & SCF_DO_STCLASS_AND) { \
- for (value = 0; value < 256; value++) \
- if (!is_ ## nAmE ## _cp(value)) \
- ANYOF_BITMAP_CLEAR(data->start_class, value); \
- } \
- else { \
- for (value = 0; value < 256; value++) \
- if (is_ ## nAmE ## _cp(value)) \
- ANYOF_BITMAP_SET(data->start_class, value); \
- } \
- break; \
-case N ## nAmE: \
- if (flags & SCF_DO_STCLASS_AND) { \
- for (value = 0; value < 256; value++) \
- if (is_ ## nAmE ## _cp(value)) \
- ANYOF_BITMAP_CLEAR(data->start_class, value); \
- } \
- else { \
- for (value = 0; value < 256; value++) \
- if (!is_ ## nAmE ## _cp(value)) \
- ANYOF_BITMAP_SET(data->start_class, value); \
- } \
- break
-
-
-
STATIC I32
S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
I32 *minlenp, I32 *deltap,
@@ -2732,7 +3009,8 @@
/* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
{
dVAR;
- I32 min = 0, pars = 0, code;
+ I32 min = 0; /* There must be at least this number of characters to match */
+ I32 pars = 0, code;
regnode *scan = *scanp, *next;
I32 delta = 0;
int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
@@ -2759,11 +3037,19 @@
fake_study_recurse:
while ( scan && OP(scan) != END && scan < last ){
+ UV min_subtract = 0; /* How mmany chars to subtract from the minimum
+ node length to get a real minimum (because
+ the folded version may be shorter) */
+ bool has_exactf_sharp_s = FALSE;
/* Peephole optimizer: */
DEBUG_STUDYDATA("Peep:", data,depth);
DEBUG_PEEP("Peep",scan,depth);
- JOIN_EXACT(scan,&min,0);
+ /* Its not clear to khw or hv why this is done here, and not in the
+ * clauses that deal with EXACT nodes. khw's guess is that it's
+ * because of a previous design */
+ JOIN_EXACT(scan,&min_subtract, &has_exactf_sharp_s, 0);
+
/* Follow the next-chain of the current node and optimize
away all the NOTHINGs from it. */
if (OP(scan) != CURLYX) {
@@ -2774,7 +3060,7 @@
int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
int noff;
regnode *n = scan;
-
+
/* Skip NOTHING and LONGJMP. */
while ((n = regnext(n))
&& ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
@@ -2796,7 +3082,7 @@
next = regnext(scan);
code = OP(scan);
/* demq: the op(next)==code check is to see if we have "branch-branch" AFAICT */
-
+
if (OP(next) == code || code == IFTHEN) {
/* NOTE - There is similar code to this block below for handling
TRIE nodes on a re-study. If you change stuff here check there
@@ -2804,7 +3090,7 @@
I32 max1 = 0, min1 = I32_MAX, num = 0;
struct regnode_charclass_class accum;
regnode * const startbranch=scan;
-
+
if (flags & SCF_DO_SUBSTR)
SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot merge strings after this. */
if (flags & SCF_DO_STCLASS)
@@ -2842,10 +3128,11 @@
stopparen, recursed, NULL, f,depth+1);
if (min1 > minnext)
min1 = minnext;
- if (max1 < minnext + deltanext)
+ if (deltanext == I32_MAX) {
+ is_inf = is_inf_internal = 1;
+ max1 = I32_MAX;
+ } else if (max1 < minnext + deltanext)
max1 = minnext + deltanext;
- if (deltanext == I32_MAX)
- is_inf = is_inf_internal = 1;
scan = next;
if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
pars++;
@@ -2868,12 +3155,18 @@
min1 = 0;
if (flags & SCF_DO_SUBSTR) {
data->pos_min += min1;
- data->pos_delta += max1 - min1;
+ if (data->pos_delta >= I32_MAX - (max1 - min1))
+ data->pos_delta = I32_MAX;
+ else
+ data->pos_delta += max1 - min1;
if (max1 != min1 || is_inf)
data->longest = &(data->longest_float);
}
min += min1;
- delta += max1 - min1;
+ if (delta == I32_MAX || I32_MAX - delta - (max1 - min1) < 0)
+ delta = I32_MAX;
+ else
+ delta += max1 - min1;
if (flags & SCF_DO_STCLASS_OR) {
cl_or(pRExC_state, data->start_class, &accum);
if (min1) {
@@ -2896,7 +3189,7 @@
StructCopy(&accum, data->start_class,
struct regnode_charclass_class);
flags |= SCF_DO_STCLASS_OR;
- data->start_class->flags |= ANYOF_EOS;
+ SET_SSC_EOS(data->start_class);
}
}
@@ -2941,7 +3234,7 @@
a nested if into a case structure of sorts.
*/
-
+
int made=0;
if (!re_trie_maxbuff) {
re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
@@ -2953,7 +3246,7 @@
regnode *first = (regnode *)NULL;
regnode *last = (regnode *)NULL;
regnode *tail = scan;
- U8 optype = 0;
+ U8 trietype = 0;
U32 count=0;
#ifdef DEBUGGING
@@ -2973,7 +3266,7 @@
}
- DEBUG_OPTIMISE_r({
+ DEBUG_TRIE_COMPILE_r({
regprop(RExC_rx, mysv, tail );
PerlIO_printf( Perl_debug_log, "%*s%s%s\n",
(int)depth * 2 + 2, "",
@@ -2984,37 +3277,66 @@
/*
- step through the branches, cur represents each
- branch, noper is the first thing to be matched
- as part of that branch and noper_next is the
- regnext() of that node. if noper is an EXACT
- and noper_next is the same as scan (our current
- position in the regex) then the EXACT branch is
- a possible optimization target. Once we have
- two or more consecutive such branches we can
- create a trie of the EXACT's contents and stich
- it in place. If the sequence represents all of
- the branches we eliminate the whole thing and
- replace it with a single TRIE. If it is a
- subsequence then we need to stitch it in. This
- means the first branch has to remain, and needs
- to be repointed at the item on the branch chain
- following the last branch optimized. This could
- be either a BRANCH, in which case the
- subsequence is internal, or it could be the
- item following the branch sequence in which
- case the subsequence is at the end.
+ Step through the branches
+ cur represents each branch,
+ noper is the first thing to be matched as part of that branch
+ noper_next is the regnext() of that node.
+ We normally handle a case like this /FOO[xyz]|BAR[pqr]/
+ via a "jump trie" but we also support building with NOJUMPTRIE,
+ which restricts the trie logic to structures like /FOO|BAR/.
+
+ If noper is a trieable nodetype then the branch is a possible optimization
+ target. If we are building under NOJUMPTRIE then we require that noper_next
+ is the same as scan (our current position in the regex program).
+
+ Once we have two or more consecutive such branches we can create a
+ trie of the EXACT's contents and stitch it in place into the program.
+
+ If the sequence represents all of the branches in the alternation we
+ replace the entire thing with a single TRIE node.
+
+ Otherwise when it is a subsequence we need to stitch it in place and
+ replace only the relevant branches. This means the first branch has
+ to remain as it is used by the alternation logic, and its next pointer,
+ and needs to be repointed at the item on the branch chain following
+ the last branch we have optimized away.
+
+ This could be either a BRANCH, in which case the subsequence is internal,
+ or it could be the item following the branch sequence in which case the
+ subsequence is at the end (which does not necessarily mean the first node
+ is the start of the alternation).
+
+ TRIE_TYPE(X) is a define which maps the optype to a trietype.
+
+ optype | trietype
+ ----------------+-----------
+ NOTHING | NOTHING
+ EXACT | EXACT
+ EXACTFU | EXACTFU
+ EXACTFU_SS | EXACTFU
+ EXACTFU_TRICKYFOLD | EXACTFU
+ EXACTFA | 0
+
+
*/
+#define TRIE_TYPE(X) ( ( NOTHING == (X) ) ? NOTHING : \
+ ( EXACT == (X) ) ? EXACT : \
+ ( EXACTFU == (X) || EXACTFU_SS == (X) || EXACTFU_TRICKYFOLD == (X) ) ? EXACTFU : \
+ 0 )
/* dont use tail as the end marker for this traverse */
for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
regnode * const noper = NEXTOPER( cur );
+ U8 noper_type = OP( noper );
+ U8 noper_trietype = TRIE_TYPE( noper_type );
#if defined(DEBUGGING) || defined(NOJUMPTRIE)
regnode * const noper_next = regnext( noper );
+ U8 noper_next_type = (noper_next && noper_next != tail) ? OP(noper_next) : 0;
+ U8 noper_next_trietype = (noper_next && noper_next != tail) ? TRIE_TYPE( noper_next_type ) :0;
#endif
- DEBUG_OPTIMISE_r({
+ DEBUG_TRIE_COMPILE_r({
regprop(RExC_rx, mysv, cur);
PerlIO_printf( Perl_debug_log, "%*s- %s (%d)",
(int)depth * 2 + 2,"", SvPV_nolen_const( mysv ), REG_NODE_NUM(cur) );
@@ -3028,60 +3350,92 @@
PerlIO_printf( Perl_debug_log,"\t=> %s\t",
SvPV_nolen_const(mysv));
}
- PerlIO_printf( Perl_debug_log, "(First==%d,Last==%d,Cur==%d)\n",
- REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur) );
+ PerlIO_printf( Perl_debug_log, "(First==%d,Last==%d,Cur==%d,tt==%s,nt==%s,nnt==%s)\n",
+ REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur),
+ PL_reg_name[trietype], PL_reg_name[noper_trietype], PL_reg_name[noper_next_trietype]
+ );
});
- if ( (((first && optype!=NOTHING) ? OP( noper ) == optype
- : PL_regkind[ OP( noper ) ] == EXACT )
- || OP(noper) == NOTHING )
+
+ /* Is noper a trieable nodetype that can be merged with the
+ * current trie (if there is one)? */
+ if ( noper_trietype
+ &&
+ (
+ ( noper_trietype == NOTHING)
+ || ( trietype == NOTHING )
+ || ( trietype == noper_trietype )
+ )
#ifdef NOJUMPTRIE
&& noper_next == tail
#endif
&& count < U16_MAX)
{
- count++;
- if ( !first || optype == NOTHING ) {
- if (!first) first = cur;
- optype = OP( noper );
+ /* Handle mergable triable node
+ * Either we are the first node in a new trieable sequence,
+ * in which case we do some bookkeeping, otherwise we update
+ * the end pointer. */
+ if ( !first ) {
+ first = cur;
+ if ( noper_trietype == NOTHING ) {
+#if !defined(DEBUGGING) && !defined(NOJUMPTRIE)
+ regnode * const noper_next = regnext( noper );
+ U8 noper_next_type = (noper_next && noper_next!=tail) ? OP(noper_next) : 0;
+ U8 noper_next_trietype = noper_next_type ? TRIE_TYPE( noper_next_type ) :0;
+#endif
+
+ if ( noper_next_trietype ) {
+ trietype = noper_next_trietype;
+ } else if (noper_next_type) {
+ /* a NOTHING regop is 1 regop wide. We need at least two
+ * for a trie so we can't merge this in */
+ first = NULL;
+ }
+ } else {
+ trietype = noper_trietype;
+ }
} else {
+ if ( trietype == NOTHING )
+ trietype = noper_trietype;
last = cur;
}
- } else {
-/*
- Currently the trie logic handles case insensitive matching properly only
- when the pattern is UTF-8 and the node is EXACTFU (thus forcing unicode
- semantics).
-
- If/when this is fixed the following define can be swapped
- in below to fully enable trie logic.
-
-#define TRIE_TYPE_IS_SAFE 1
-
-*/
-#define TRIE_TYPE_IS_SAFE ((UTF && optype == EXACTFU) || optype==EXACT)
-
- if ( last && TRIE_TYPE_IS_SAFE ) {
- make_trie( pRExC_state,
- startbranch, first, cur, tail, count,
- optype, depth+1 );
+ if (first)
+ count++;
+ } /* end handle mergable triable node */
+ else {
+ /* handle unmergable node -
+ * noper may either be a triable node which can not be tried
+ * together with the current trie, or a non triable node */
+ if ( last ) {
+ /* If last is set and trietype is not NOTHING then we have found
+ * at least two triable branch sequences in a row of a similar
+ * trietype so we can turn them into a trie. If/when we
+ * allow NOTHING to start a trie sequence this condition will be
+ * required, and it isn't expensive so we leave it in for now. */
+ if ( trietype && trietype != NOTHING )
+ make_trie( pRExC_state,
+ startbranch, first, cur, tail, count,
+ trietype, depth+1 );
+ last = NULL; /* note: we clear/update first, trietype etc below, so we dont do it here */
}
- if ( PL_regkind[ OP( noper ) ] == EXACT
+ if ( noper_trietype
#ifdef NOJUMPTRIE
&& noper_next == tail
#endif
){
+ /* noper is triable, so we can start a new trie sequence */
count = 1;
first = cur;
- optype = OP( noper );
- } else {
+ trietype = noper_trietype;
+ } else if (first) {
+ /* if we already saw a first but the current node is not triable then we have
+ * to reset the first information. */
count = 0;
first = NULL;
- optype = 0;
+ trietype = 0;
}
- last = NULL;
- }
- }
- DEBUG_OPTIMISE_r({
+ } /* end handle unmergable node */
+ } /* loop over branches */
+ DEBUG_TRIE_COMPILE_r({
regprop(RExC_rx, mysv, cur);
PerlIO_printf( Perl_debug_log,
"%*s- %s (%d) <SCAN FINISHED>\n", (int)depth * 2 + 2,
@@ -3088,24 +3442,48 @@
"", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
});
-
- if ( last && TRIE_TYPE_IS_SAFE ) {
- made= make_trie( pRExC_state, startbranch, first, scan, tail, count, optype, depth+1 );
-#ifdef TRIE_STUDY_OPT
- if ( ((made == MADE_EXACT_TRIE &&
- startbranch == first)
- || ( first_non_open == first )) &&
- depth==0 ) {
- flags |= SCF_TRIE_RESTUDY;
- if ( startbranch == first
- && scan == tail )
- {
- RExC_seen &=~REG_TOP_LEVEL_BRANCHES;
+ if ( last && trietype ) {
+ if ( trietype != NOTHING ) {
+ /* the last branch of the sequence was part of a trie,
+ * so we have to construct it here outside of the loop
+ */
+ made= make_trie( pRExC_state, startbranch, first, scan, tail, count, trietype, depth+1 );
+#ifdef TRIE_STUDY_OPT
+ if ( ((made == MADE_EXACT_TRIE &&
+ startbranch == first)
+ || ( first_non_open == first )) &&
+ depth==0 ) {
+ flags |= SCF_TRIE_RESTUDY;
+ if ( startbranch == first
+ && scan == tail )
+ {
+ RExC_seen &=~REG_TOP_LEVEL_BRANCHES;
+ }
}
+#endif
+ } else {
+ /* at this point we know whatever we have is a NOTHING sequence/branch
+ * AND if 'startbranch' is 'first' then we can turn the whole thing into a NOTHING
+ */
+ if ( startbranch == first ) {
+ regnode *opt;
+ /* the entire thing is a NOTHING sequence, something like this:
+ * (?:|) So we can turn it into a plain NOTHING op. */
+ DEBUG_TRIE_COMPILE_r({
+ regprop(RExC_rx, mysv, cur);
+ PerlIO_printf( Perl_debug_log,
+ "%*s- %s (%d) <NOTHING BRANCH SEQUENCE>\n", (int)depth * 2 + 2,
+ "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
+
+ });
+ OP(startbranch)= NOTHING;
+ NEXT_OFF(startbranch)= tail - startbranch;
+ for ( opt= startbranch + 1; opt < tail ; opt++ )
+ OP(opt)= OPTIMIZED;
+ }
}
-#endif
- }
- }
+ } /* end if ( last) */
+ } /* TRIE_MAXBUF is non zero */
} /* do trie */
@@ -3178,8 +3556,8 @@
UV uc;
if (UTF) {
const U8 * const s = (U8*)STRING(scan);
+ uc = utf8_to_uvchr_buf(s, s + l, NULL);
l = utf8_length(s, s + l);
- uc = utf8_to_uvchr(s, NULL);
} else {
uc = *((U8*)STRING(scan));
}
@@ -3219,9 +3597,9 @@
* utf8 string, so accept a possible false positive for
* latin1-range folds */
if (uc >= 0x100 ||
- (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
+ (!(data->start_class->flags & ANYOF_LOCALE)
&& !ANYOF_BITMAP_TEST(data->start_class, uc)
- && (!(data->start_class->flags & ANYOF_LOC_NONBITMAP_FOLD)
+ && (!(data->start_class->flags & ANYOF_LOC_FOLD)
|| !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
)
{
@@ -3242,12 +3620,12 @@
* elsewhere that does compute the fold settles down, it
* can be extracted out and re-used here */
for (i = 0; i < 256; i++){
- if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)) {
+ if (HAS_NONLATIN1_FOLD_CLOSURE(i)) {
ANYOF_BITMAP_SET(data->start_class, i);
}
}
}
- data->start_class->flags &= ~ANYOF_EOS;
+ CLEAR_SSC_EOS(data->start_class);
if (uc < 0x100)
data->start_class->flags &= ~ANYOF_UNICODE_ALL;
}
@@ -3257,7 +3635,7 @@
ANYOF_BITMAP_SET(data->start_class, uc);
else
data->start_class->flags |= ANYOF_UNICODE_ALL;
- data->start_class->flags &= ~ANYOF_EOS;
+ CLEAR_SSC_EOS(data->start_class);
cl_and(data->start_class, and_withp);
}
flags &= ~SCF_DO_STCLASS;
@@ -3273,17 +3651,30 @@
}
if (UTF) {
const U8 * const s = (U8 *)STRING(scan);
+ uc = utf8_to_uvchr_buf(s, s + l, NULL);
l = utf8_length(s, s + l);
- uc = utf8_to_uvchr(s, NULL);
}
- min += l;
- if (flags & SCF_DO_SUBSTR)
- data->pos_min += l;
+ if (has_exactf_sharp_s) {
+ RExC_seen |= REG_SEEN_EXACTF_SHARP_S;
+ }
+ min += l - min_subtract;
+ assert (min >= 0);
+ delta += min_subtract;
+ if (flags & SCF_DO_SUBSTR) {
+ data->pos_min += l - min_subtract;
+ if (data->pos_min < 0) {
+ data->pos_min = 0;
+ }
+ data->pos_delta += min_subtract;
+ if (min_subtract) {
+ data->longest = &(data->longest_float);
+ }
+ }
if (flags & SCF_DO_STCLASS_AND) {
/* Check whether it is compatible with what we know already! */
int compat = 1;
if (uc >= 0x100 ||
- (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
+ (!(data->start_class->flags & ANYOF_LOCALE)
&& !ANYOF_BITMAP_TEST(data->start_class, uc)
&& !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
{
@@ -3293,13 +3684,12 @@
ANYOF_BITMAP_ZERO(data->start_class);
if (compat) {
ANYOF_BITMAP_SET(data->start_class, uc);
- data->start_class->flags &= ~ANYOF_EOS;
- data->start_class->flags |= ANYOF_LOC_NONBITMAP_FOLD;
+ CLEAR_SSC_EOS(data->start_class);
if (OP(scan) == EXACTFL) {
/* XXX This set is probably no longer necessary, and
* probably wrong as LOCALE now is on in the initial
* state */
- data->start_class->flags |= ANYOF_LOCALE;
+ data->start_class->flags |= ANYOF_LOCALE|ANYOF_LOC_FOLD;
}
else {
@@ -3306,8 +3696,22 @@
/* Also set the other member of the fold pair. In case
* that unicode semantics is called for at runtime, use
* the full latin1 fold. (Can't do this for locale,
- * because not known until runtime */
+ * because not known until runtime) */
ANYOF_BITMAP_SET(data->start_class, PL_fold_latin1[uc]);
+
+ /* All other (EXACTFL handled above) folds except under
+ * /iaa that include s, S, and sharp_s also may include
+ * the others */
+ if (OP(scan) != EXACTFA) {
+ if (uc == 's' || uc == 'S') {
+ ANYOF_BITMAP_SET(data->start_class,
+ LATIN_SMALL_LETTER_SHARP_S);
+ }
+ else if (uc == LATIN_SMALL_LETTER_SHARP_S) {
+ ANYOF_BITMAP_SET(data->start_class, 's');
+ ANYOF_BITMAP_SET(data->start_class, 'S');
+ }
+ }
}
}
else if (uc >= 0x100) {
@@ -3320,7 +3724,7 @@
}
}
else if (flags & SCF_DO_STCLASS_OR) {
- if (data->start_class->flags & ANYOF_LOC_NONBITMAP_FOLD) {
+ if (data->start_class->flags & ANYOF_LOC_FOLD) {
/* false positive possible if the class is case-folded.
Assume that the locale settings are the same... */
if (uc < 0x100) {
@@ -3332,9 +3736,22 @@
* run-time */
ANYOF_BITMAP_SET(data->start_class,
PL_fold_latin1[uc]);
+
+ /* All folds except under /iaa that include s, S,
+ * and sharp_s also may include the others */
+ if (OP(scan) != EXACTFA) {
+ if (uc == 's' || uc == 'S') {
+ ANYOF_BITMAP_SET(data->start_class,
+ LATIN_SMALL_LETTER_SHARP_S);
+ }
+ else if (uc == LATIN_SMALL_LETTER_SHARP_S) {
+ ANYOF_BITMAP_SET(data->start_class, 's');
+ ANYOF_BITMAP_SET(data->start_class, 'S');
+ }
+ }
}
}
- data->start_class->flags &= ~ANYOF_EOS;
+ CLEAR_SSC_EOS(data->start_class);
}
cl_and(data->start_class, and_withp);
}
@@ -3451,7 +3868,7 @@
StructCopy(&this_class, data->start_class,
struct regnode_charclass_class);
flags |= SCF_DO_STCLASS_OR;
- data->start_class->flags |= ANYOF_EOS;
+ SET_SSC_EOS(data->start_class);
}
} else { /* Non-zero len */
if (flags & SCF_DO_STCLASS_OR) {
@@ -3470,16 +3887,21 @@
&& data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
&& maxcount <= REG_INFTY/3) /* Complement check for big count */
{
+ /* Fatal warnings may leak the regexp without this: */
+ SAVEFREESV(RExC_rx_sv);
ckWARNreg(RExC_parse,
"Quantifier unexpected on zero-length expression");
+ (void)ReREFCNT_inc(RExC_rx_sv);
}
min += minnext * mincount;
- is_inf_internal |= ((maxcount == REG_INFTY
- && (minnext + deltanext) > 0)
- || deltanext == I32_MAX);
+ is_inf_internal |= deltanext == I32_MAX
+ || (maxcount == REG_INFTY && minnext + deltanext > 0);
is_inf |= is_inf_internal;
- delta += (minnext + deltanext) * maxcount - minnext * mincount;
+ if (is_inf)
+ delta = I32_MAX;
+ else
+ delta += (minnext + deltanext) * maxcount - minnext * mincount;
/* Try powerful optimization CURLYX => CURLYN. */
if ( OP(oscan) == CURLYX && data
@@ -3531,6 +3953,7 @@
&& !(data->flags & SF_HAS_EVAL)
&& !deltanext /* atom is fixed width */
&& minnext != 0 /* CURLYM can't handle zero width */
+ && ! (RExC_seen & REG_SEEN_EXACTF_SHARP_S) /* Nor \xDF */
) {
/* XXXX How to optimize if data == 0? */
/* Optimize to a simpler form. */
@@ -3663,7 +4086,16 @@
}
/* It is counted once already... */
data->pos_min += minnext * (mincount - counted);
- data->pos_delta += - counted * deltanext +
+#if 0
+PerlIO_printf(Perl_debug_log, "counted=%d deltanext=%d I32_MAX=%d minnext=%d maxcount=%d mincount=%d\n",
+ counted, deltanext, I32_MAX, minnext, maxcount, mincount);
+if (deltanext != I32_MAX)
+PerlIO_printf(Perl_debug_log, "LHS=%d RHS=%d\n", -counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount, I32_MAX - data->pos_delta);
+#endif
+ if (deltanext == I32_MAX || -counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount >= I32_MAX - data->pos_delta)
+ data->pos_delta = I32_MAX;
+ else
+ data->pos_delta += - counted * deltanext +
(minnext + deltanext) * maxcount - minnext * mincount;
if (mincount != maxcount) {
/* Cannot extend fixed substrings found inside
@@ -3698,7 +4130,7 @@
NEXT_OFF(oscan) += NEXT_OFF(next);
}
continue;
- default: /* REF, ANYOFV, and CLUMP only? */
+ default: /* REF, and CLUMP only? */
if (flags & SCF_DO_SUBSTR) {
SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */
data->longest = &(data->longest_float);
@@ -3713,7 +4145,7 @@
else if (OP(scan) == LNBREAK) {
if (flags & SCF_DO_STCLASS) {
int value = 0;
- data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
+ CLEAR_SSC_EOS(data->start_class); /* No match on empty */
if (flags & SCF_DO_STCLASS_AND) {
for (value = 0; value < 256; value++)
if (!is_VERTWS_cp(value))
@@ -3728,8 +4160,8 @@
cl_and(data->start_class, and_withp);
flags &= ~SCF_DO_STCLASS;
}
- min += 1;
- delta += 1;
+ min++;
+ delta++; /* Because of the 2 char string cr-lf */
if (flags & SCF_DO_SUBSTR) {
SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */
data->pos_min += 1;
@@ -3737,18 +4169,6 @@
data->longest = &(data->longest_float);
}
}
- else if (OP(scan) == FOLDCHAR) {
- int d = ARG(scan) == LATIN_SMALL_LETTER_SHARP_S ? 1 : 2;
- flags &= ~SCF_DO_STCLASS;
- min += 1;
- delta += d;
- if (flags & SCF_DO_SUBSTR) {
- SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */
- data->pos_min += 1;
- data->pos_delta += d;
- data->longest = &(data->longest_float);
- }
- }
else if (REGNODE_SIMPLE(OP(scan))) {
int value = 0;
@@ -3758,15 +4178,20 @@
}
min++;
if (flags & SCF_DO_STCLASS) {
- data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
+ int loop_max = 256;
+ CLEAR_SSC_EOS(data->start_class); /* No match on empty */
/* Some of the logic below assumes that switching
locale on will only add false positives. */
switch (PL_regkind[OP(scan)]) {
+ U8 classnum;
+
case SANY:
default:
- do_default:
- /* Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); */
+#ifdef DEBUGGING
+ Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan));
+#endif
+ do_default:
if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
cl_anything(pRExC_state, data->start_class);
break;
@@ -3775,7 +4200,7 @@
goto do_default;
if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */
value = (ANYOF_BITMAP_TEST(data->start_class,'\n')
- || ANYOF_CLASS_TEST_ANY_SET(data->start_class));
+ || ANYOF_CLASS_TEST_ANY_SET(data->start_class));
cl_anything(pRExC_state, data->start_class);
}
if (flags & SCF_DO_STCLASS_AND || !value)
@@ -3789,200 +4214,77 @@
cl_or(pRExC_state, data->start_class,
(struct regnode_charclass_class*)scan);
break;
- case ALNUM:
+ case POSIXA:
+ loop_max = 128;
+ /* FALL THROUGH */
+ case POSIXL:
+ case POSIXD:
+ case POSIXU:
+ classnum = FLAGS(scan);
if (flags & SCF_DO_STCLASS_AND) {
if (!(data->start_class->flags & ANYOF_LOCALE)) {
- ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
- if (OP(scan) == ALNUMU) {
- for (value = 0; value < 256; value++) {
- if (!isWORDCHAR_L1(value)) {
- ANYOF_BITMAP_CLEAR(data->start_class, value);
- }
+ ANYOF_CLASS_CLEAR(data->start_class, classnum_to_namedclass(classnum) + 1);
+ for (value = 0; value < loop_max; value++) {
+ if (! _generic_isCC(UNI_TO_NATIVE(value), classnum)) {
+ ANYOF_BITMAP_CLEAR(data->start_class, UNI_TO_NATIVE(value));
}
- } else {
- for (value = 0; value < 256; value++) {
- if (!isALNUM(value)) {
- ANYOF_BITMAP_CLEAR(data->start_class, value);
- }
- }
}
}
}
else {
- if (data->start_class->flags & ANYOF_LOCALE)
- ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
+ if (data->start_class->flags & ANYOF_LOCALE) {
+ ANYOF_CLASS_SET(data->start_class, classnum_to_namedclass(classnum));
+ }
+ else {
/* Even if under locale, set the bits for non-locale
* in case it isn't a true locale-node. This will
* create false positives if it truly is locale */
- if (OP(scan) == ALNUMU) {
- for (value = 0; value < 256; value++) {
- if (isWORDCHAR_L1(value)) {
- ANYOF_BITMAP_SET(data->start_class, value);
- }
+ for (value = 0; value < loop_max; value++) {
+ if (_generic_isCC(UNI_TO_NATIVE(value), classnum)) {
+ ANYOF_BITMAP_SET(data->start_class, UNI_TO_NATIVE(value));
}
- } else {
- for (value = 0; value < 256; value++) {
- if (isALNUM(value)) {
- ANYOF_BITMAP_SET(data->start_class, value);
- }
- }
}
+ }
}
break;
- case NALNUM:
+ case NPOSIXA:
+ loop_max = 128;
+ /* FALL THROUGH */
+ case NPOSIXL:
+ case NPOSIXU:
+ case NPOSIXD:
+ classnum = FLAGS(scan);
if (flags & SCF_DO_STCLASS_AND) {
if (!(data->start_class->flags & ANYOF_LOCALE)) {
- ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
- if (OP(scan) == NALNUMU) {
- for (value = 0; value < 256; value++) {
- if (isWORDCHAR_L1(value)) {
- ANYOF_BITMAP_CLEAR(data->start_class, value);
- }
+ ANYOF_CLASS_CLEAR(data->start_class, classnum_to_namedclass(classnum));
+ for (value = 0; value < loop_max; value++) {
+ if (_generic_isCC(UNI_TO_NATIVE(value), classnum)) {
+ ANYOF_BITMAP_CLEAR(data->start_class, UNI_TO_NATIVE(value));
}
- } else {
- for (value = 0; value < 256; value++) {
- if (isALNUM(value)) {
- ANYOF_BITMAP_CLEAR(data->start_class, value);
- }
- }
- }
+ }
}
}
else {
- if (data->start_class->flags & ANYOF_LOCALE)
- ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
+ if (data->start_class->flags & ANYOF_LOCALE) {
+ ANYOF_CLASS_SET(data->start_class, classnum_to_namedclass(classnum) + 1);
+ }
+ else {
/* Even if under locale, set the bits for non-locale in
* case it isn't a true locale-node. This will create
* false positives if it truly is locale */
- if (OP(scan) == NALNUMU) {
- for (value = 0; value < 256; value++) {
- if (! isWORDCHAR_L1(value)) {
- ANYOF_BITMAP_SET(data->start_class, value);
- }
- }
- } else {
- for (value = 0; value < 256; value++) {
- if (! isALNUM(value)) {
- ANYOF_BITMAP_SET(data->start_class, value);
- }
- }
- }
- }
- break;
- case SPACE:
- if (flags & SCF_DO_STCLASS_AND) {
- if (!(data->start_class->flags & ANYOF_LOCALE)) {
- ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
- if (OP(scan) == SPACEU) {
- for (value = 0; value < 256; value++) {
- if (!isSPACE_L1(value)) {
- ANYOF_BITMAP_CLEAR(data->start_class, value);
- }
- }
- } else {
- for (value = 0; value < 256; value++) {
- if (!isSPACE(value)) {
- ANYOF_BITMAP_CLEAR(data->start_class, value);
- }
- }
+ for (value = 0; value < loop_max; value++) {
+ if (! _generic_isCC(UNI_TO_NATIVE(value), classnum)) {
+ ANYOF_BITMAP_SET(data->start_class, UNI_TO_NATIVE(value));
}
- }
- }
- else {
- if (data->start_class->flags & ANYOF_LOCALE) {
- ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
}
- if (OP(scan) == SPACEU) {
- for (value = 0; value < 256; value++) {
- if (isSPACE_L1(value)) {
- ANYOF_BITMAP_SET(data->start_class, value);
- }
- }
- } else {
- for (value = 0; value < 256; value++) {
- if (isSPACE(value)) {
- ANYOF_BITMAP_SET(data->start_class, value);
- }
- }
- }
- }
- break;
- case NSPACE:
- if (flags & SCF_DO_STCLASS_AND) {
- if (!(data->start_class->flags & ANYOF_LOCALE)) {
- ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
- if (OP(scan) == NSPACEU) {
- for (value = 0; value < 256; value++) {
- if (isSPACE_L1(value)) {
- ANYOF_BITMAP_CLEAR(data->start_class, value);
- }
- }
- } else {
- for (value = 0; value < 256; value++) {
- if (isSPACE(value)) {
- ANYOF_BITMAP_CLEAR(data->start_class, value);
- }
- }
- }
- }
- }
- else {
- if (data->start_class->flags & ANYOF_LOCALE)
- ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
- if (OP(scan) == NSPACEU) {
- for (value = 0; value < 256; value++) {
- if (!isSPACE_L1(value)) {
- ANYOF_BITMAP_SET(data->start_class, value);
- }
- }
+ if (PL_regkind[OP(scan)] == NPOSIXD) {
+ data->start_class->flags |= ANYOF_NON_UTF8_LATIN1_ALL;
}
- else {
- for (value = 0; value < 256; value++) {
- if (!isSPACE(value)) {
- ANYOF_BITMAP_SET(data->start_class, value);
- }
- }
}
}
break;
- case DIGIT:
- if (flags & SCF_DO_STCLASS_AND) {
- if (!(data->start_class->flags & ANYOF_LOCALE)) {
- ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NDIGIT);
- for (value = 0; value < 256; value++)
- if (!isDIGIT(value))
- ANYOF_BITMAP_CLEAR(data->start_class, value);
- }
- }
- else {
- if (data->start_class->flags & ANYOF_LOCALE)
- ANYOF_CLASS_SET(data->start_class,ANYOF_DIGIT);
- for (value = 0; value < 256; value++)
- if (isDIGIT(value))
- ANYOF_BITMAP_SET(data->start_class, value);
- }
- break;
- case NDIGIT:
- if (flags & SCF_DO_STCLASS_AND) {
- if (!(data->start_class->flags & ANYOF_LOCALE))
- ANYOF_CLASS_CLEAR(data->start_class,ANYOF_DIGIT);
- for (value = 0; value < 256; value++)
- if (isDIGIT(value))
- ANYOF_BITMAP_CLEAR(data->start_class, value);
- }
- else {
- if (data->start_class->flags & ANYOF_LOCALE)
- ANYOF_CLASS_SET(data->start_class,ANYOF_NDIGIT);
- for (value = 0; value < 256; value++)
- if (!isDIGIT(value))
- ANYOF_BITMAP_SET(data->start_class, value);
- }
- break;
- CASE_SYNST_FNC(VERTWS);
- CASE_SYNST_FNC(HORIZWS);
-
}
if (flags & SCF_DO_STCLASS_OR)
cl_and(data->start_class, and_withp);
@@ -3993,11 +4295,39 @@
data->flags |= (OP(scan) == MEOL
? SF_BEFORE_MEOL
: SF_BEFORE_SEOL);
+ SCAN_COMMIT(pRExC_state, data, minlenp);
+
}
else if ( PL_regkind[OP(scan)] == BRANCHJ
/* Lookbehind, or need to calculate parens/evals/stclass: */
&& (scan->flags || data || (flags & SCF_DO_STCLASS))
&& (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
+ if ( OP(scan) == UNLESSM &&
+ scan->flags == 0 &&
+ OP(NEXTOPER(NEXTOPER(scan))) == NOTHING &&
+ OP(regnext(NEXTOPER(NEXTOPER(scan)))) == SUCCEED
+ ) {
+ regnode *opt;
+ regnode *upto= regnext(scan);
+ DEBUG_PARSE_r({
+ SV * const mysv_val=sv_newmortal();
+ DEBUG_STUDYDATA("OPFAIL",data,depth);
+
+ /*DEBUG_PARSE_MSG("opfail");*/
+ regprop(RExC_rx, mysv_val, upto);
+ PerlIO_printf(Perl_debug_log, "~ replace with OPFAIL pointed at %s (%"IVdf") offset %"IVdf"\n",
+ SvPV_nolen_const(mysv_val),
+ (IV)REG_NODE_NUM(upto),
+ (IV)(upto - scan)
+ );
+ });
+ OP(scan) = OPFAIL;
+ NEXT_OFF(scan) = upto - scan;
+ for (opt= scan + 1; opt < upto ; opt++)
+ OP(opt) = OPTIMIZED;
+ scan= upto;
+ continue;
+ }
if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY
|| OP(scan) == UNLESSM )
{
@@ -4057,11 +4387,11 @@
cl_init(pRExC_state, data->start_class);
} else {
/* AND before and after: combine and continue */
- const int was = (data->start_class->flags & ANYOF_EOS);
+ const int was = TEST_SSC_EOS(data->start_class);
cl_and(data->start_class, &intrnl);
if (was)
- data->start_class->flags |= ANYOF_EOS;
+ SET_SSC_EOS(data->start_class);
}
}
}
@@ -4129,11 +4459,11 @@
*minnextp += min;
if (f & SCF_DO_STCLASS_AND) {
- const int was = (data->start_class->flags & ANYOF_EOS);
+ const int was = TEST_SSC_EOS(data.start_class);
cl_and(data->start_class, &intrnl);
if (was)
- data->start_class->flags |= ANYOF_EOS;
+ SET_SSC_EOS(data->start_class);
}
if (data) {
if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
@@ -4145,7 +4475,7 @@
if (RExC_rx->minlen<*minnextp)
RExC_rx->minlen=*minnextp;
SCAN_COMMIT(pRExC_state, &data_fake, minnextp);
- SvREFCNT_dec(data_fake.last_found);
+ SvREFCNT_dec_NN(data_fake.last_found);
if ( data_fake.minlen_fixed != minlenp )
{
@@ -4162,8 +4492,6 @@
}
}
}
-
-
}
#endif
}
@@ -4285,10 +4613,11 @@
if (min1 > (I32)(minnext + trie->minlen))
min1 = minnext + trie->minlen;
- if (max1 < (I32)(minnext + deltanext + trie->maxlen))
+ if (deltanext == I32_MAX) {
+ is_inf = is_inf_internal = 1;
+ max1 = I32_MAX;
+ } else if (max1 < (I32)(minnext + deltanext + trie->maxlen))
max1 = minnext + deltanext + trie->maxlen;
- if (deltanext == I32_MAX)
- is_inf = is_inf_internal = 1;
if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
pars++;
@@ -4338,7 +4667,7 @@
StructCopy(&accum, data->start_class,
struct regnode_charclass_class);
flags |= SCF_DO_STCLASS_OR;
- data->start_class->flags |= ANYOF_EOS;
+ SET_SSC_EOS(data->start_class);
}
}
scan= tail;
@@ -4363,7 +4692,7 @@
flags &= ~SCF_DO_SUBSTR;
}
#endif /* old or new */
-#endif /* TRIE_STUDY_OPT */
+#endif /* TRIE_STUDY_OPT */
/* Else: zero-length, ignore. */
scan = regnext(scan);
@@ -4454,81 +4783,708 @@
#ifdef TRIE_STUDY_OPT
-#define CHECK_RESTUDY_GOTO \
+#define CHECK_RESTUDY_GOTO_butfirst(dOsomething) \
+ STMT_START { \
if ( \
(data.flags & SCF_TRIE_RESTUDY) \
&& ! restudied++ \
- ) goto reStudy
+ ) { \
+ dOsomething; \
+ goto reStudy; \
+ } \
+ } STMT_END
#else
-#define CHECK_RESTUDY_GOTO
+#define CHECK_RESTUDY_GOTO_butfirst
#endif
/*
- - pregcomp - compile a regular expression into internal code
+ * pregcomp - compile a regular expression into internal code
*
- * We can't allocate space until we know how big the compiled form will be,
- * but we can't compile it (and thus know how big it is) until we've got a
- * place to put the code. So we cheat: we compile it twice, once with code
- * generation turned off and size counting turned on, and once "for real".
- * This also means that we don't allocate space until we are sure that the
- * thing really will compile successfully, and we never have to move the
- * code and thus invalidate pointers into it. (Note that it has to be in
- * one piece because free() must be able to free it all.) [NB: not true in perl]
- *
- * Beware that the optimization-preparation code in here knows about some
- * of the structure of the compiled regexp. [I'll say.]
+ * Decides which engine's compiler to call based on the hint currently in
+ * scope
*/
+#ifndef PERL_IN_XSUB_RE
+/* return the currently in-scope regex engine (or the default if none) */
-#ifndef PERL_IN_XSUB_RE
-#define RE_ENGINE_PTR &PL_core_reg_engine
-#else
-extern const struct regexp_engine my_reg_engine;
-#define RE_ENGINE_PTR &my_reg_engine
-#endif
+regexp_engine const *
+Perl_current_re_engine(pTHX)
+{
+ dVAR;
-#ifndef PERL_IN_XSUB_RE
+ if (IN_PERL_COMPILETIME) {
+ HV * const table = GvHV(PL_hintgv);
+ SV **ptr;
+
+ if (!table)
+ return &PL_core_reg_engine;
+ ptr = hv_fetchs(table, "regcomp", FALSE);
+ if ( !(ptr && SvIOK(*ptr) && SvIV(*ptr)))
+ return &PL_core_reg_engine;
+ return INT2PTR(regexp_engine*,SvIV(*ptr));
+ }
+ else {
+ SV *ptr;
+ if (!PL_curcop->cop_hints_hash)
+ return &PL_core_reg_engine;
+ ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
+ if ( !(ptr && SvIOK(ptr) && SvIV(ptr)))
+ return &PL_core_reg_engine;
+ return INT2PTR(regexp_engine*,SvIV(ptr));
+ }
+}
+
+
REGEXP *
Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
{
dVAR;
- HV * const table = GvHV(PL_hintgv);
+ regexp_engine const *eng = current_re_engine();
+ GET_RE_DEBUG_FLAGS_DECL;
PERL_ARGS_ASSERT_PREGCOMP;
- /* Dispatch a request to compile a regexp to correct
- regexp engine. */
- if (table) {
- SV **ptr= hv_fetchs(table, "regcomp", FALSE);
- GET_RE_DEBUG_FLAGS_DECL;
- if (ptr && SvIOK(*ptr) && SvIV(*ptr)) {
- const regexp_engine *eng=INT2PTR(regexp_engine*,SvIV(*ptr));
- DEBUG_COMPILE_r({
- PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
- SvIV(*ptr));
- });
- return CALLREGCOMP_ENG(eng, pattern, flags);
- }
- }
- return Perl_re_compile(aTHX_ pattern, flags);
+ /* Dispatch a request to compile a regexp to correct regexp engine. */
+ DEBUG_COMPILE_r({
+ PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
+ PTR2UV(eng));
+ });
+ return CALLREGCOMP_ENG(eng, pattern, flags);
}
#endif
+/* public(ish) entry point for the perl core's own regex compiling code.
+ * It's actually a wrapper for Perl_re_op_compile that only takes an SV
+ * pattern rather than a list of OPs, and uses the internal engine rather
+ * than the current one */
+
REGEXP *
-Perl_re_compile(pTHX_ SV * const pattern, U32 orig_pm_flags)
+Perl_re_compile(pTHX_ SV * const pattern, U32 rx_flags)
{
+ SV *pat = pattern; /* defeat constness! */
+ PERL_ARGS_ASSERT_RE_COMPILE;
+ return Perl_re_op_compile(aTHX_ &pat, 1, NULL,
+#ifdef PERL_IN_XSUB_RE
+ &my_reg_engine,
+#else
+ &PL_core_reg_engine,
+#endif
+ NULL, NULL, rx_flags, 0);
+}
+
+
+/* upgrade pattern pat_p of length plen_p to UTF8, and if there are code
+ * blocks, recalculate the indices. Update pat_p and plen_p in-place to
+ * point to the realloced string and length.
+ *
+ * This is essentially a copy of Perl_bytes_to_utf8() with the code index
+ * stuff added */
+
+static void
+S_pat_upgrade_to_utf8(pTHX_ RExC_state_t * const pRExC_state,
+ char **pat_p, STRLEN *plen_p, int num_code_blocks)
+{
+ U8 *const src = (U8*)*pat_p;
+ U8 *dst;
+ int n=0;
+ STRLEN s = 0, d = 0;
+ bool do_end = 0;
+ GET_RE_DEBUG_FLAGS_DECL;
+
+ DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
+ "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
+
+ Newx(dst, *plen_p * 2 + 1, U8);
+
+ while (s < *plen_p) {
+ const UV uv = NATIVE_TO_ASCII(src[s]);
+ if (UNI_IS_INVARIANT(uv))
+ dst[d] = (U8)UTF_TO_NATIVE(uv);
+ else {
+ dst[d++] = (U8)UTF8_EIGHT_BIT_HI(uv);
+ dst[d] = (U8)UTF8_EIGHT_BIT_LO(uv);
+ }
+ if (n < num_code_blocks) {
+ if (!do_end && pRExC_state->code_blocks[n].start == s) {
+ pRExC_state->code_blocks[n].start = d;
+ assert(dst[d] == '(');
+ do_end = 1;
+ }
+ else if (do_end && pRExC_state->code_blocks[n].end == s) {
+ pRExC_state->code_blocks[n].end = d;
+ assert(dst[d] == ')');
+ do_end = 0;
+ n++;
+ }
+ }
+ s++;
+ d++;
+ }
+ dst[d] = '\0';
+ *plen_p = d;
+ *pat_p = (char*) dst;
+ SAVEFREEPV(*pat_p);
+ RExC_orig_utf8 = RExC_utf8 = 1;
+}
+
+
+
+/* S_concat_pat(): concatenate a list of args to the pattern string pat,
+ * while recording any code block indices, and handling overloading,
+ * nested qr// objects etc. If pat is null, it will allocate a new
+ * string, or just return the first arg, if there's only one.
+ *
+ * Returns the malloced/updated pat.
+ * patternp and pat_count is the array of SVs to be concatted;
+ * oplist is the optional list of ops that generated the SVs;
+ * recompile_p is a pointer to a boolean that will be set if
+ * the regex will need to be recompiled.
+ * delim, if non-null is an SV that will be inserted between each element
+ */
+
+static SV*
+S_concat_pat(pTHX_ RExC_state_t * const pRExC_state,
+ SV *pat, SV ** const patternp, int pat_count,
+ OP *oplist, bool *recompile_p, SV *delim)
+{
+ SV **svp;
+ int n = 0;
+ bool use_delim = FALSE;
+ bool alloced = FALSE;
+
+ /* if we know we have at least two args, create an empty string,
+ * then concatenate args to that. For no args, return an empty string */
+ if (!pat && pat_count != 1) {
+ pat = newSVpvn("", 0);
+ SAVEFREESV(pat);
+ alloced = TRUE;
+ }
+
+ for (svp = patternp; svp < patternp + pat_count; svp++) {
+ SV *sv;
+ SV *rx = NULL;
+ STRLEN orig_patlen = 0;
+ bool code = 0;
+ SV *msv = use_delim ? delim : *svp;
+
+ /* if we've got a delimiter, we go round the loop twice for each
+ * svp slot (except the last), using the delimiter the second
+ * time round */
+ if (use_delim) {
+ svp--;
+ use_delim = FALSE;
+ }
+ else if (delim)
+ use_delim = TRUE;
+
+ if (SvTYPE(msv) == SVt_PVAV) {
+ /* we've encountered an interpolated array within
+ * the pattern, e.g. /... at a..../. Expand the list of elements,
+ * then recursively append elements.
+ * The code in this block is based on S_pushav() */
+
+ AV *const av = (AV*)msv;
+ const I32 maxarg = AvFILL(av) + 1;
+ SV **array;
+
+ if (oplist) {
+ assert(oplist->op_type == OP_PADAV
+ || oplist->op_type == OP_RV2AV);
+ oplist = oplist->op_sibling;;
+ }
+
+ if (SvRMAGICAL(av)) {
+ U32 i;
+
+ Newx(array, maxarg, SV*);
+ SAVEFREEPV(array);
+ for (i=0; i < (U32)maxarg; i++) {
+ SV ** const svp = av_fetch(av, i, FALSE);
+ array[i] = svp ? *svp : &PL_sv_undef;
+ }
+ }
+ else
+ array = AvARRAY(av);
+
+ pat = S_concat_pat(aTHX_ pRExC_state, pat,
+ array, maxarg, NULL, recompile_p,
+ /* $" */
+ GvSV((gv_fetchpvs("\"", GV_ADDMULTI, SVt_PV))));
+
+ continue;
+ }
+
+
+ /* we make the assumption here that each op in the list of
+ * op_siblings maps to one SV pushed onto the stack,
+ * except for code blocks, with have both an OP_NULL and
+ * and OP_CONST.
+ * This allows us to match up the list of SVs against the
+ * list of OPs to find the next code block.
+ *
+ * Note that PUSHMARK PADSV PADSV ..
+ * is optimised to
+ * PADRANGE PADSV PADSV ..
+ * so the alignment still works. */
+
+ if (oplist) {
+ if (oplist->op_type == OP_NULL
+ && (oplist->op_flags & OPf_SPECIAL))
+ {
+ assert(n < pRExC_state->num_code_blocks);
+ pRExC_state->code_blocks[n].start = pat ? SvCUR(pat) : 0;
+ pRExC_state->code_blocks[n].block = oplist;
+ pRExC_state->code_blocks[n].src_regex = NULL;
+ n++;
+ code = 1;
+ oplist = oplist->op_sibling; /* skip CONST */
+ assert(oplist);
+ }
+ oplist = oplist->op_sibling;;
+ }
+
+ /* apply magic and QR overloading to arg */
+
+ SvGETMAGIC(msv);
+ if (SvROK(msv) && SvAMAGIC(msv)) {
+ SV *sv = AMG_CALLunary(msv, regexp_amg);
+ if (sv) {
+ if (SvROK(sv))
+ sv = SvRV(sv);
+ if (SvTYPE(sv) != SVt_REGEXP)
+ Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP");
+ msv = sv;
+ }
+ }
+
+ /* try concatenation overload ... */
+ if (pat && (SvAMAGIC(pat) || SvAMAGIC(msv)) &&
+ (sv = amagic_call(pat, msv, concat_amg, AMGf_assign)))
+ {
+ sv_setsv(pat, sv);
+ /* overloading involved: all bets are off over literal
+ * code. Pretend we haven't seen it */
+ pRExC_state->num_code_blocks -= n;
+ n = 0;
+ }
+ else {
+ /* ... or failing that, try "" overload */
+ while (SvAMAGIC(msv)
+ && (sv = AMG_CALLunary(msv, string_amg))
+ && sv != msv
+ && !( SvROK(msv)
+ && SvROK(sv)
+ && SvRV(msv) == SvRV(sv))
+ ) {
+ msv = sv;
+ SvGETMAGIC(msv);
+ }
+ if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP)
+ msv = SvRV(msv);
+
+ if (pat) {
+ /* this is a partially unrolled
+ * sv_catsv_nomg(pat, msv);
+ * that allows us to adjust code block indices if
+ * needed */
+ STRLEN dlen;
+ char *dst = SvPV_force_nomg(pat, dlen);
+ orig_patlen = dlen;
+ if (SvUTF8(msv) && !SvUTF8(pat)) {
+ S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &dst, &dlen, n);
+ sv_setpvn(pat, dst, dlen);
+ SvUTF8_on(pat);
+ }
+ sv_catsv_nomg(pat, msv);
+ rx = msv;
+ }
+ else
+ pat = msv;
+
+ if (code)
+ pRExC_state->code_blocks[n-1].end = SvCUR(pat)-1;
+ }
+
+ /* extract any code blocks within any embedded qr//'s */
+ if (rx && SvTYPE(rx) == SVt_REGEXP
+ && RX_ENGINE((REGEXP*)rx)->op_comp)
+ {
+
+ RXi_GET_DECL(ReANY((REGEXP *)rx), ri);
+ if (ri->num_code_blocks) {
+ int i;
+ /* the presence of an embedded qr// with code means
+ * we should always recompile: the text of the
+ * qr// may not have changed, but it may be a
+ * different closure than last time */
+ *recompile_p = 1;
+ Renew(pRExC_state->code_blocks,
+ pRExC_state->num_code_blocks + ri->num_code_blocks,
+ struct reg_code_block);
+ pRExC_state->num_code_blocks += ri->num_code_blocks;
+
+ for (i=0; i < ri->num_code_blocks; i++) {
+ struct reg_code_block *src, *dst;
+ STRLEN offset = orig_patlen
+ + ReANY((REGEXP *)rx)->pre_prefix;
+ assert(n < pRExC_state->num_code_blocks);
+ src = &ri->code_blocks[i];
+ dst = &pRExC_state->code_blocks[n];
+ dst->start = src->start + offset;
+ dst->end = src->end + offset;
+ dst->block = src->block;
+ dst->src_regex = (REGEXP*) SvREFCNT_inc( (SV*)
+ src->src_regex
+ ? src->src_regex
+ : (REGEXP*)rx);
+ n++;
+ }
+ }
+ }
+ }
+ /* avoid calling magic multiple times on a single element e.g. =~ $qr */
+ if (alloced)
+ SvSETMAGIC(pat);
+
+ return pat;
+}
+
+
+
+/* see if there are any run-time code blocks in the pattern.
+ * False positives are allowed */
+
+static bool
+S_has_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
+ char *pat, STRLEN plen)
+{
+ int n = 0;
+ STRLEN s;
+
+ for (s = 0; s < plen; s++) {
+ if (n < pRExC_state->num_code_blocks
+ && s == pRExC_state->code_blocks[n].start)
+ {
+ s = pRExC_state->code_blocks[n].end;
+ n++;
+ continue;
+ }
+ /* TODO ideally should handle [..], (#..), /#.../x to reduce false
+ * positives here */
+ if (pat[s] == '(' && s+2 <= plen && pat[s+1] == '?' &&
+ (pat[s+2] == '{'
+ || (s + 2 <= plen && pat[s+2] == '?' && pat[s+3] == '{'))
+ )
+ return 1;
+ }
+ return 0;
+}
+
+/* Handle run-time code blocks. We will already have compiled any direct
+ * or indirect literal code blocks. Now, take the pattern 'pat' and make a
+ * copy of it, but with any literal code blocks blanked out and
+ * appropriate chars escaped; then feed it into
+ *
+ * eval "qr'modified_pattern'"
+ *
+ * For example,
+ *
+ * a\bc(?{"this was literal"})def'ghi\\jkl(?{"this is runtime"})mno
+ *
+ * becomes
+ *
+ * qr'a\\bc_______________________def\'ghi\\\\jkl(?{"this is runtime"})mno'
+ *
+ * After eval_sv()-ing that, grab any new code blocks from the returned qr
+ * and merge them with any code blocks of the original regexp.
+ *
+ * If the pat is non-UTF8, while the evalled qr is UTF8, don't merge;
+ * instead, just save the qr and return FALSE; this tells our caller that
+ * the original pattern needs upgrading to utf8.
+ */
+
+static bool
+S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
+ char *pat, STRLEN plen)
+{
+ SV *qr;
+
+ GET_RE_DEBUG_FLAGS_DECL;
+
+ if (pRExC_state->runtime_code_qr) {
+ /* this is the second time we've been called; this should
+ * only happen if the main pattern got upgraded to utf8
+ * during compilation; re-use the qr we compiled first time
+ * round (which should be utf8 too)
+ */
+ qr = pRExC_state->runtime_code_qr;
+ pRExC_state->runtime_code_qr = NULL;
+ assert(RExC_utf8 && SvUTF8(qr));
+ }
+ else {
+ int n = 0;
+ STRLEN s;
+ char *p, *newpat;
+ int newlen = plen + 6; /* allow for "qr''x\0" extra chars */
+ SV *sv, *qr_ref;
+ dSP;
+
+ /* determine how many extra chars we need for ' and \ escaping */
+ for (s = 0; s < plen; s++) {
+ if (pat[s] == '\'' || pat[s] == '\\')
+ newlen++;
+ }
+
+ Newx(newpat, newlen, char);
+ p = newpat;
+ *p++ = 'q'; *p++ = 'r'; *p++ = '\'';
+
+ for (s = 0; s < plen; s++) {
+ if (n < pRExC_state->num_code_blocks
+ && s == pRExC_state->code_blocks[n].start)
+ {
+ /* blank out literal code block */
+ assert(pat[s] == '(');
+ while (s <= pRExC_state->code_blocks[n].end) {
+ *p++ = '_';
+ s++;
+ }
+ s--;
+ n++;
+ continue;
+ }
+ if (pat[s] == '\'' || pat[s] == '\\')
+ *p++ = '\\';
+ *p++ = pat[s];
+ }
+ *p++ = '\'';
+ if (pRExC_state->pm_flags & RXf_PMf_EXTENDED)
+ *p++ = 'x';
+ *p++ = '\0';
+ DEBUG_COMPILE_r({
+ PerlIO_printf(Perl_debug_log,
+ "%sre-parsing pattern for runtime code:%s %s\n",
+ PL_colors[4],PL_colors[5],newpat);
+ });
+
+ sv = newSVpvn_flags(newpat, p-newpat-1, RExC_utf8 ? SVf_UTF8 : 0);
+ Safefree(newpat);
+
+ ENTER;
+ SAVETMPS;
+ save_re_context();
+ PUSHSTACKi(PERLSI_REQUIRE);
+ /* G_RE_REPARSING causes the toker to collapse \\ into \ when
+ * parsing qr''; normally only q'' does this. It also alters
+ * hints handling */
+ eval_sv(sv, G_SCALAR|G_RE_REPARSING);
+ SvREFCNT_dec_NN(sv);
+ SPAGAIN;
+ qr_ref = POPs;
+ PUTBACK;
+ {
+ SV * const errsv = ERRSV;
+ if (SvTRUE_NN(errsv))
+ {
+ Safefree(pRExC_state->code_blocks);
+ /* use croak_sv ? */
+ Perl_croak_nocontext("%s", SvPV_nolen_const(errsv));
+ }
+ }
+ assert(SvROK(qr_ref));
+ qr = SvRV(qr_ref);
+ assert(SvTYPE(qr) == SVt_REGEXP && RX_ENGINE((REGEXP*)qr)->op_comp);
+ /* the leaving below frees the tmp qr_ref.
+ * Give qr a life of its own */
+ SvREFCNT_inc(qr);
+ POPSTACK;
+ FREETMPS;
+ LEAVE;
+
+ }
+
+ if (!RExC_utf8 && SvUTF8(qr)) {
+ /* first time through; the pattern got upgraded; save the
+ * qr for the next time through */
+ assert(!pRExC_state->runtime_code_qr);
+ pRExC_state->runtime_code_qr = qr;
+ return 0;
+ }
+
+
+ /* extract any code blocks within the returned qr// */
+
+
+ /* merge the main (r1) and run-time (r2) code blocks into one */
+ {
+ RXi_GET_DECL(ReANY((REGEXP *)qr), r2);
+ struct reg_code_block *new_block, *dst;
+ RExC_state_t * const r1 = pRExC_state; /* convenient alias */
+ int i1 = 0, i2 = 0;
+
+ if (!r2->num_code_blocks) /* we guessed wrong */
+ {
+ SvREFCNT_dec_NN(qr);
+ return 1;
+ }
+
+ Newx(new_block,
+ r1->num_code_blocks + r2->num_code_blocks,
+ struct reg_code_block);
+ dst = new_block;
+
+ while ( i1 < r1->num_code_blocks
+ || i2 < r2->num_code_blocks)
+ {
+ struct reg_code_block *src;
+ bool is_qr = 0;
+
+ if (i1 == r1->num_code_blocks) {
+ src = &r2->code_blocks[i2++];
+ is_qr = 1;
+ }
+ else if (i2 == r2->num_code_blocks)
+ src = &r1->code_blocks[i1++];
+ else if ( r1->code_blocks[i1].start
+ < r2->code_blocks[i2].start)
+ {
+ src = &r1->code_blocks[i1++];
+ assert(src->end < r2->code_blocks[i2].start);
+ }
+ else {
+ assert( r1->code_blocks[i1].start
+ > r2->code_blocks[i2].start);
+ src = &r2->code_blocks[i2++];
+ is_qr = 1;
+ assert(src->end < r1->code_blocks[i1].start);
+ }
+
+ assert(pat[src->start] == '(');
+ assert(pat[src->end] == ')');
+ dst->start = src->start;
+ dst->end = src->end;
+ dst->block = src->block;
+ dst->src_regex = is_qr ? (REGEXP*) SvREFCNT_inc( (SV*) qr)
+ : src->src_regex;
+ dst++;
+ }
+ r1->num_code_blocks += r2->num_code_blocks;
+ Safefree(r1->code_blocks);
+ r1->code_blocks = new_block;
+ }
+
+ SvREFCNT_dec_NN(qr);
+ return 1;
+}
+
+
+STATIC bool
+S_setup_longest(pTHX_ RExC_state_t *pRExC_state, SV* sv_longest, SV** rx_utf8, SV** rx_substr, I32* rx_end_shift, I32 lookbehind, I32 offset, I32 *minlen, STRLEN longest_length, bool eol, bool meol)
+{
+ /* This is the common code for setting up the floating and fixed length
+ * string data extracted from Perl_re_op_compile() below. Returns a boolean
+ * as to whether succeeded or not */
+
+ I32 t,ml;
+
+ if (! (longest_length
+ || (eol /* Can't have SEOL and MULTI */
+ && (! meol || (RExC_flags & RXf_PMf_MULTILINE)))
+ )
+ /* See comments for join_exact for why REG_SEEN_EXACTF_SHARP_S */
+ || (RExC_seen & REG_SEEN_EXACTF_SHARP_S))
+ {
+ return FALSE;
+ }
+
+ /* copy the information about the longest from the reg_scan_data
+ over to the program. */
+ if (SvUTF8(sv_longest)) {
+ *rx_utf8 = sv_longest;
+ *rx_substr = NULL;
+ } else {
+ *rx_substr = sv_longest;
+ *rx_utf8 = NULL;
+ }
+ /* end_shift is how many chars that must be matched that
+ follow this item. We calculate it ahead of time as once the
+ lookbehind offset is added in we lose the ability to correctly
+ calculate it.*/
+ ml = minlen ? *(minlen) : (I32)longest_length;
+ *rx_end_shift = ml - offset
+ - longest_length + (SvTAIL(sv_longest) != 0)
+ + lookbehind;
+
+ t = (eol/* Can't have SEOL and MULTI */
+ && (! meol || (RExC_flags & RXf_PMf_MULTILINE)));
+ fbm_compile(sv_longest, t ? FBMcf_TAIL : 0);
+
+ return TRUE;
+}
+
+/*
+ * Perl_re_op_compile - the perl internal RE engine's function to compile a
+ * regular expression into internal code.
+ * The pattern may be passed either as:
+ * a list of SVs (patternp plus pat_count)
+ * a list of OPs (expr)
+ * If both are passed, the SV list is used, but the OP list indicates
+ * which SVs are actually pre-compiled code blocks
+ *
+ * The SVs in the list have magic and qr overloading applied to them (and
+ * the list may be modified in-place with replacement SVs in the latter
+ * case).
+ *
+ * If the pattern hasn't changed from old_re, then old_re will be
+ * returned.
+ *
+ * eng is the current engine. If that engine has an op_comp method, then
+ * handle directly (i.e. we assume that op_comp was us); otherwise, just
+ * do the initial concatenation of arguments and pass on to the external
+ * engine.
+ *
+ * If is_bare_re is not null, set it to a boolean indicating whether the
+ * arg list reduced (after overloading) to a single bare regex which has
+ * been returned (i.e. /$qr/).
+ *
+ * orig_rx_flags contains RXf_* flags. See perlreapi.pod for more details.
+ *
+ * pm_flags contains the PMf_* flags, typically based on those from the
+ * pm_flags field of the related PMOP. Currently we're only interested in
+ * PMf_HAS_CV, PMf_IS_QR, PMf_USE_RE_EVAL.
+ *
+ * We can't allocate space until we know how big the compiled form will be,
+ * but we can't compile it (and thus know how big it is) until we've got a
+ * place to put the code. So we cheat: we compile it twice, once with code
+ * generation turned off and size counting turned on, and once "for real".
+ * This also means that we don't allocate space until we are sure that the
+ * thing really will compile successfully, and we never have to move the
+ * code and thus invalidate pointers into it. (Note that it has to be in
+ * one piece because free() must be able to free it all.) [NB: not true in perl]
+ *
+ * Beware that the optimization-preparation code in here knows about some
+ * of the structure of the compiled regexp. [I'll say.]
+ */
+
+REGEXP *
+Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
+ OP *expr, const regexp_engine* eng, REGEXP *old_re,
+ bool *is_bare_re, U32 orig_rx_flags, U32 pm_flags)
+{
dVAR;
REGEXP *rx;
struct regexp *r;
- register regexp_internal *ri;
+ regexp_internal *ri;
STRLEN plen;
- char *exp;
- char* xend;
+ char *exp;
regnode *scan;
I32 flags;
I32 minlen = 0;
- U32 pm_flags;
+ U32 rx_flags;
+ SV *pat;
+ SV *code_blocksv = NULL;
+ SV** new_patternp = patternp;
/* these are all flags - maybe they should be turned
* into a single int with different bit masks */
@@ -4535,85 +5491,239 @@
I32 sawlookahead = 0;
I32 sawplus = 0;
I32 sawopen = 0;
- bool used_setjump = FALSE;
- regex_charset initial_charset = get_regex_charset(orig_pm_flags);
-
- U8 jump_ret = 0;
- dJMPENV;
+ regex_charset initial_charset = get_regex_charset(orig_rx_flags);
+ bool recompile = 0;
+ bool runtime_code = 0;
scan_data_t data;
RExC_state_t RExC_state;
RExC_state_t * const pRExC_state = &RExC_state;
#ifdef TRIE_STUDY_OPT
- int restudied;
+ int restudied = 0;
RExC_state_t copyRExC_state;
#endif
GET_RE_DEBUG_FLAGS_DECL;
- PERL_ARGS_ASSERT_RE_COMPILE;
+ PERL_ARGS_ASSERT_RE_OP_COMPILE;
DEBUG_r(if (!PL_colorset) reginitcolors());
- RExC_utf8 = RExC_orig_utf8 = SvUTF8(pattern);
- RExC_uni_semantics = 0;
- RExC_contains_locale = 0;
+#ifndef PERL_IN_XSUB_RE
+ /* Initialize these here instead of as-needed, as is quick and avoids
+ * having to test them each time otherwise */
+ if (! PL_AboveLatin1) {
+ PL_AboveLatin1 = _new_invlist_C_array(AboveLatin1_invlist);
+ PL_ASCII = _new_invlist_C_array(ASCII_invlist);
+ PL_Latin1 = _new_invlist_C_array(Latin1_invlist);
- /****************** LONG JUMP TARGET HERE***********************/
- /* Longjmp back to here if have to switch in midstream to utf8 */
- if (! RExC_orig_utf8) {
- JMPENV_PUSH(jump_ret);
- used_setjump = TRUE;
+ PL_L1Posix_ptrs[_CC_ALPHANUMERIC]
+ = _new_invlist_C_array(L1PosixAlnum_invlist);
+ PL_Posix_ptrs[_CC_ALPHANUMERIC]
+ = _new_invlist_C_array(PosixAlnum_invlist);
+
+ PL_L1Posix_ptrs[_CC_ALPHA]
+ = _new_invlist_C_array(L1PosixAlpha_invlist);
+ PL_Posix_ptrs[_CC_ALPHA] = _new_invlist_C_array(PosixAlpha_invlist);
+
+ PL_Posix_ptrs[_CC_BLANK] = _new_invlist_C_array(PosixBlank_invlist);
+ PL_XPosix_ptrs[_CC_BLANK] = _new_invlist_C_array(XPosixBlank_invlist);
+
+ /* Cased is the same as Alpha in the ASCII range */
+ PL_L1Posix_ptrs[_CC_CASED] = _new_invlist_C_array(L1Cased_invlist);
+ PL_Posix_ptrs[_CC_CASED] = _new_invlist_C_array(PosixAlpha_invlist);
+
+ PL_Posix_ptrs[_CC_CNTRL] = _new_invlist_C_array(PosixCntrl_invlist);
+ PL_XPosix_ptrs[_CC_CNTRL] = _new_invlist_C_array(XPosixCntrl_invlist);
+
+ PL_Posix_ptrs[_CC_DIGIT] = _new_invlist_C_array(PosixDigit_invlist);
+ PL_L1Posix_ptrs[_CC_DIGIT] = _new_invlist_C_array(PosixDigit_invlist);
+
+ PL_L1Posix_ptrs[_CC_GRAPH] = _new_invlist_C_array(L1PosixGraph_invlist);
+ PL_Posix_ptrs[_CC_GRAPH] = _new_invlist_C_array(PosixGraph_invlist);
+
+ PL_L1Posix_ptrs[_CC_LOWER] = _new_invlist_C_array(L1PosixLower_invlist);
+ PL_Posix_ptrs[_CC_LOWER] = _new_invlist_C_array(PosixLower_invlist);
+
+ PL_L1Posix_ptrs[_CC_PRINT] = _new_invlist_C_array(L1PosixPrint_invlist);
+ PL_Posix_ptrs[_CC_PRINT] = _new_invlist_C_array(PosixPrint_invlist);
+
+ PL_L1Posix_ptrs[_CC_PUNCT] = _new_invlist_C_array(L1PosixPunct_invlist);
+ PL_Posix_ptrs[_CC_PUNCT] = _new_invlist_C_array(PosixPunct_invlist);
+
+ PL_Posix_ptrs[_CC_SPACE] = _new_invlist_C_array(PerlSpace_invlist);
+ PL_XPosix_ptrs[_CC_SPACE] = _new_invlist_C_array(XPerlSpace_invlist);
+ PL_Posix_ptrs[_CC_PSXSPC] = _new_invlist_C_array(PosixSpace_invlist);
+ PL_XPosix_ptrs[_CC_PSXSPC] = _new_invlist_C_array(XPosixSpace_invlist);
+
+ PL_L1Posix_ptrs[_CC_UPPER] = _new_invlist_C_array(L1PosixUpper_invlist);
+ PL_Posix_ptrs[_CC_UPPER] = _new_invlist_C_array(PosixUpper_invlist);
+
+ PL_XPosix_ptrs[_CC_VERTSPACE] = _new_invlist_C_array(VertSpace_invlist);
+
+ PL_Posix_ptrs[_CC_WORDCHAR] = _new_invlist_C_array(PosixWord_invlist);
+ PL_L1Posix_ptrs[_CC_WORDCHAR]
+ = _new_invlist_C_array(L1PosixWord_invlist);
+
+ PL_Posix_ptrs[_CC_XDIGIT] = _new_invlist_C_array(PosixXDigit_invlist);
+ PL_XPosix_ptrs[_CC_XDIGIT] = _new_invlist_C_array(XPosixXDigit_invlist);
+
+ PL_HasMultiCharFold = _new_invlist_C_array(_Perl_Multi_Char_Folds_invlist);
}
+#endif
- if (jump_ret == 0) { /* First time through */
- exp = SvPV(pattern, plen);
- xend = exp + plen;
- /* ignore the utf8ness if the pattern is 0 length */
- if (plen == 0) {
- RExC_utf8 = RExC_orig_utf8 = 0;
+ pRExC_state->code_blocks = NULL;
+ pRExC_state->num_code_blocks = 0;
+
+ if (is_bare_re)
+ *is_bare_re = FALSE;
+
+ if (expr && (expr->op_type == OP_LIST ||
+ (expr->op_type == OP_NULL && expr->op_targ == OP_LIST))) {
+ /* allocate code_blocks if needed */
+ OP *o;
+ int ncode = 0;
+
+ for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling)
+ if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL))
+ ncode++; /* count of DO blocks */
+ if (ncode) {
+ pRExC_state->num_code_blocks = ncode;
+ Newx(pRExC_state->code_blocks, ncode, struct reg_code_block);
}
+ }
- DEBUG_COMPILE_r({
+ if (!pat_count) {
+ /* compile-time pattern with just OP_CONSTs and DO blocks */
+
+ int n;
+ OP *o;
+
+ /* find how many CONSTs there are */
+ assert(expr);
+ n = 0;
+ if (expr->op_type == OP_CONST)
+ n = 1;
+ else
+ for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
+ if (o->op_type == OP_CONST)
+ n++;
+ }
+
+ /* fake up an SV array */
+
+ assert(!new_patternp);
+ Newx(new_patternp, n, SV*);
+ SAVEFREEPV(new_patternp);
+ pat_count = n;
+
+ n = 0;
+ if (expr->op_type == OP_CONST)
+ new_patternp[n] = cSVOPx_sv(expr);
+ else
+ for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
+ if (o->op_type == OP_CONST)
+ new_patternp[n++] = cSVOPo_sv;
+ }
+
+ }
+
+ DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
+ "Assembling pattern from %d elements%s\n", pat_count,
+ orig_rx_flags & RXf_SPLIT ? " for split" : ""));
+
+ /* set expr to the first arg op */
+
+ if (pRExC_state->num_code_blocks
+ && expr->op_type != OP_CONST)
+ {
+ expr = cLISTOPx(expr)->op_first;
+ assert( expr->op_type == OP_PUSHMARK
+ || (expr->op_type == OP_NULL && expr->op_targ == OP_PUSHMARK)
+ || expr->op_type == OP_PADRANGE);
+ expr = expr->op_sibling;
+ }
+
+ pat = S_concat_pat(aTHX_ pRExC_state, NULL, new_patternp, pat_count,
+ expr, &recompile, NULL);
+
+ /* handle bare (possibly after overloading) regex: foo =~ $re */
+ {
+ SV *re = pat;
+ if (SvROK(re))
+ re = SvRV(re);
+ if (SvTYPE(re) == SVt_REGEXP) {
+ if (is_bare_re)
+ *is_bare_re = TRUE;
+ SvREFCNT_inc(re);
+ Safefree(pRExC_state->code_blocks);
+ DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
+ "Precompiled pattern%s\n",
+ orig_rx_flags & RXf_SPLIT ? " for split" : ""));
+
+ return (REGEXP*)re;
+ }
+ }
+
+ exp = SvPV_nomg(pat, plen);
+
+ if (!eng->op_comp) {
+ if ((SvUTF8(pat) && IN_BYTES)
+ || SvGMAGICAL(pat) || SvAMAGIC(pat))
+ {
+ /* make a temporary copy; either to convert to bytes,
+ * or to avoid repeating get-magic / overloaded stringify */
+ pat = newSVpvn_flags(exp, plen, SVs_TEMP |
+ (IN_BYTES ? 0 : SvUTF8(pat)));
+ }
+ Safefree(pRExC_state->code_blocks);
+ return CALLREGCOMP_ENG(eng, pat, orig_rx_flags);
+ }
+
+ /* ignore the utf8ness if the pattern is 0 length */
+ RExC_utf8 = RExC_orig_utf8 = (plen == 0 || IN_BYTES) ? 0 : SvUTF8(pat);
+ RExC_uni_semantics = 0;
+ RExC_contains_locale = 0;
+ pRExC_state->runtime_code_qr = NULL;
+
+ DEBUG_COMPILE_r({
SV *dsv= sv_newmortal();
- RE_PV_QUOTED_DECL(s, RExC_utf8,
- dsv, exp, plen, 60);
+ RE_PV_QUOTED_DECL(s, RExC_utf8, dsv, exp, plen, 60);
PerlIO_printf(Perl_debug_log, "%sCompiling REx%s %s\n",
- PL_colors[4],PL_colors[5],s);
+ PL_colors[4],PL_colors[5],s);
});
- }
- else { /* longjumped back */
- STRLEN len = plen;
- /* If the cause for the longjmp was other than changing to utf8, pop
- * our own setjmp, and longjmp to the correct handler */
- if (jump_ret != UTF8_LONGJMP) {
- JMPENV_POP;
- JMPENV_JUMP(jump_ret);
- }
+ redo_first_pass:
+ /* we jump here if we upgrade the pattern to utf8 and have to
+ * recompile */
- GET_RE_DEBUG_FLAGS;
+ if ((pm_flags & PMf_USE_RE_EVAL)
+ /* this second condition covers the non-regex literal case,
+ * i.e. $foo =~ '(?{})'. */
+ || (IN_PERL_COMPILETIME && (PL_hints & HINT_RE_EVAL))
+ )
+ runtime_code = S_has_runtime_code(aTHX_ pRExC_state, exp, plen);
- /* It's possible to write a regexp in ascii that represents Unicode
- codepoints outside of the byte range, such as via \x{100}. If we
- detect such a sequence we have to convert the entire pattern to utf8
- and then recompile, as our sizing calculation will have been based
- on 1 byte == 1 character, but we will need to use utf8 to encode
- at least some part of the pattern, and therefore must convert the whole
- thing.
- -- dmq */
- DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
- "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
- exp = (char*)Perl_bytes_to_utf8(aTHX_ (U8*)SvPV(pattern, plen), &len);
- xend = exp + len;
- RExC_orig_utf8 = RExC_utf8 = 1;
- SAVEFREEPV(exp);
+ /* return old regex if pattern hasn't changed */
+ /* XXX: note in the below we have to check the flags as well as the pattern.
+ *
+ * Things get a touch tricky as we have to compare the utf8 flag independently
+ * from the compile flags.
+ */
+
+ if ( old_re
+ && !recompile
+ && !!RX_UTF8(old_re) == !!RExC_utf8
+ && ( RX_COMPFLAGS(old_re) == ( orig_rx_flags & RXf_PMf_FLAGCOPYMASK ) )
+ && RX_PRECOMP(old_re)
+ && RX_PRELEN(old_re) == plen
+ && memEQ(RX_PRECOMP(old_re), exp, plen)
+ && !runtime_code /* with runtime code, always recompile */ )
+ {
+ Safefree(pRExC_state->code_blocks);
+ return old_re;
}
-#ifdef TRIE_STUDY_OPT
- restudied = 0;
-#endif
+ rx_flags = orig_rx_flags;
- pm_flags = orig_pm_flags;
-
if (initial_charset == REGEX_LOCALE_CHARSET) {
RExC_contains_locale = 1;
}
@@ -4621,24 +5731,40 @@
/* Set to use unicode semantics if the pattern is in utf8 and has the
* 'depends' charset specified, as it means unicode when utf8 */
- set_regex_charset(&pm_flags, REGEX_UNICODE_CHARSET);
+ set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
}
RExC_precomp = exp;
- RExC_flags = pm_flags;
+ RExC_flags = rx_flags;
+ RExC_pm_flags = pm_flags;
+
+ if (runtime_code) {
+ if (TAINTING_get && TAINT_get)
+ Perl_croak(aTHX_ "Eval-group in insecure regular expression");
+
+ if (!S_compile_runtime_code(aTHX_ pRExC_state, exp, plen)) {
+ /* whoops, we have a non-utf8 pattern, whilst run-time code
+ * got compiled as utf8. Try again with a utf8 pattern */
+ S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
+ pRExC_state->num_code_blocks);
+ goto redo_first_pass;
+ }
+ }
+ assert(!pRExC_state->runtime_code_qr);
+
RExC_sawback = 0;
RExC_seen = 0;
RExC_in_lookbehind = 0;
RExC_seen_zerolen = *exp == '^' ? -1 : 0;
- RExC_seen_evals = 0;
RExC_extralen = 0;
RExC_override_recoding = 0;
+ RExC_in_multi_char_class = 0;
/* First pass: determine size, legality. */
RExC_parse = exp;
RExC_start = exp;
- RExC_end = xend;
+ RExC_end = exp + plen;
RExC_naughty = 0;
RExC_npar = 1;
RExC_nestroot = 0;
@@ -4654,22 +5780,47 @@
#endif
RExC_recurse = NULL;
RExC_recurse_count = 0;
+ pRExC_state->code_index = 0;
#if 0 /* REGC() is (currently) a NOP at the first pass.
* Clever compilers notice this and complain. --jhi */
REGC((U8)REG_MAGIC, (char*)RExC_emit);
#endif
- DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "Starting first pass (sizing)\n"));
+ DEBUG_PARSE_r(
+ PerlIO_printf(Perl_debug_log, "Starting first pass (sizing)\n");
+ RExC_lastnum=0;
+ RExC_lastparse=NULL;
+ );
+ /* reg may croak on us, not giving us a chance to free
+ pRExC_state->code_blocks. We cannot SAVEFREEPV it now, as we may
+ need it to survive as long as the regexp (qr/(?{})/).
+ We must check that code_blocksv is not already set, because we may
+ have jumped back to restart the sizing pass. */
+ if (pRExC_state->code_blocks && !code_blocksv) {
+ code_blocksv = newSV_type(SVt_PV);
+ SAVEFREESV(code_blocksv);
+ SvPV_set(code_blocksv, (char *)pRExC_state->code_blocks);
+ SvLEN_set(code_blocksv, 1); /*sufficient to make sv_clear free it*/
+ }
if (reg(pRExC_state, 0, &flags,1) == NULL) {
- RExC_precomp = NULL;
- return(NULL);
+ /* It's possible to write a regexp in ascii that represents Unicode
+ codepoints outside of the byte range, such as via \x{100}. If we
+ detect such a sequence we have to convert the entire pattern to utf8
+ and then recompile, as our sizing calculation will have been based
+ on 1 byte == 1 character, but we will need to use utf8 to encode
+ at least some part of the pattern, and therefore must convert the whole
+ thing.
+ -- dmq */
+ if (flags & RESTART_UTF8) {
+ S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
+ pRExC_state->num_code_blocks);
+ goto redo_first_pass;
+ }
+ Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for sizing pass, flags=%#X", flags);
}
+ if (code_blocksv)
+ SvLEN_set(code_blocksv,0); /* no you can't have it, sv_clear */
- /* Here, finished first pass. Get rid of any added setjmp */
- if (used_setjump) {
- JMPENV_POP;
- }
-
DEBUG_PARSE_r({
PerlIO_printf(Perl_debug_log,
"Required size %"IVdf" nodes\n"
@@ -4681,9 +5832,9 @@
/* The first pass could have found things that force Unicode semantics */
if ((RExC_utf8 || RExC_uni_semantics)
- && get_regex_charset(pm_flags) == REGEX_DEPENDS_CHARSET)
+ && get_regex_charset(rx_flags) == REGEX_DEPENDS_CHARSET)
{
- set_regex_charset(&pm_flags, REGEX_UNICODE_CHARSET);
+ set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
}
/* Small enough for pointer-storage convention?
@@ -4699,7 +5850,7 @@
of zeroing when in debug mode, thus anything assigned has to
happen after that */
rx = (REGEXP*) newSV_type(SVt_REGEXP);
- r = (struct regexp*)SvANY(rx);
+ r = ReANY(rx);
Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
char, regexp_internal);
if ( r == NULL || ri == NULL )
@@ -4714,9 +5865,24 @@
/* non-zero initialization begins here */
RXi_SET( r, ri );
- r->engine= RE_ENGINE_PTR;
- r->extflags = pm_flags;
+ r->engine= eng;
+ r->extflags = rx_flags;
+ RXp_COMPFLAGS(r) = orig_rx_flags & RXf_PMf_FLAGCOPYMASK;
+
+ if (pm_flags & PMf_IS_QR) {
+ ri->code_blocks = pRExC_state->code_blocks;
+ ri->num_code_blocks = pRExC_state->num_code_blocks;
+ }
+ else
{
+ int n;
+ for (n = 0; n < pRExC_state->num_code_blocks; n++)
+ if (pRExC_state->code_blocks[n].src_regex)
+ SAVEFREESV(pRExC_state->code_blocks[n].src_regex);
+ SAVEFREEPV(pRExC_state->code_blocks);
+ }
+
+ {
bool has_p = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
bool has_charset = (get_regex_charset(r->extflags) != REGEX_DEPENDS_CHARSET);
@@ -4745,9 +5911,10 @@
+ (sizeof(STD_PAT_MODS) - 1)
+ (sizeof("(?:)") - 1);
- p = sv_grow(MUTABLE_SV(rx), wraplen + 1); /* +1 for the ending NUL */
- SvPOK_on(rx);
- SvFLAGS(rx) |= SvUTF8(pattern);
+ Newx(p, wraplen + 1, char); /* +1 for the ending NUL */
+ r->xpv_len_u.xpvlenu_pv = p;
+ if (RExC_utf8)
+ SvFLAGS(rx) |= SVf_UTF8;
*p++='('; *p++='?';
/* If a default, cover it using the caret */
@@ -4780,7 +5947,7 @@
*p++ = '\n';
*p++ = ')';
*p = 0;
- SvCUR_set(rx, p - SvPVX_const(rx));
+ SvCUR_set(rx, p - RX_WRAPPED(rx));
}
r->intflags = 0;
@@ -4807,21 +5974,21 @@
RExC_rxi = ri;
/* Second pass: emit code. */
- RExC_flags = pm_flags; /* don't let top level (?i) bleed */
+ RExC_flags = rx_flags; /* don't let top level (?i) bleed */
+ RExC_pm_flags = pm_flags;
RExC_parse = exp;
- RExC_end = xend;
+ RExC_end = exp + plen;
RExC_naughty = 0;
RExC_npar = 1;
RExC_emit_start = ri->program;
RExC_emit = ri->program;
RExC_emit_bound = ri->program + RExC_size + 1;
+ pRExC_state->code_index = 0;
- /* Store the count of eval-groups for security checks: */
- RExC_rx->seen_evals = RExC_seen_evals;
REGC((U8)REG_MAGIC, (char*) RExC_emit++);
if (reg(pRExC_state, 0, &flags,1) == NULL) {
ReREFCNT_dec(rx);
- return(NULL);
+ Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for generation pass, flags=%#X", flags);
}
/* XXXX To minimize changes to RE engine we always allocate
3-units-long substrs field. */
@@ -4848,11 +6015,6 @@
RExC_seen |= REG_TOP_LEVEL_BRANCHES;
else
RExC_seen &= ~REG_TOP_LEVEL_BRANCHES;
- if (data.last_found) {
- SvREFCNT_dec(data.longest_fixed);
- SvREFCNT_dec(data.longest_float);
- SvREFCNT_dec(data.last_found);
- }
StructCopy(&zero_scan_data, &data, scan_data_t);
}
#else
@@ -4911,7 +6073,7 @@
sawplus = 1;
else
first += regarglen[OP(first)];
-
+
first = NEXTOPER(first);
first_next= regnext(first);
}
@@ -4926,7 +6088,7 @@
else
ri->regstclass = first;
}
-#ifdef TRIE_STCLASS
+#ifdef TRIE_STCLASS
else if (PL_regkind[OP(first)] == TRIE &&
((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0)
{
@@ -4947,7 +6109,7 @@
make_trie_failtable(pRExC_state, (regnode *)first, trie_op, 0);
ri->regstclass = trie_op;
}
-#endif
+#endif
else if (REGNODE_SIMPLE(OP(first)))
ri->regstclass = first;
else if (PL_regkind[OP(first)] == BOUND ||
@@ -4970,7 +6132,7 @@
else if ((!sawopen || !RExC_sawback) &&
(OP(first) == STAR &&
PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
- !(r->extflags & RXf_ANCH) && !(RExC_seen & REG_SEEN_EVAL))
+ !(r->extflags & RXf_ANCH) && !pRExC_state->num_code_blocks)
{
/* turn .* into ^.* with an implied $*=1 */
const int type =
@@ -4983,7 +6145,7 @@
goto again;
}
if (sawplus && !sawlookahead && (!sawopen || !RExC_sawback)
- && !(RExC_seen & REG_SEEN_EVAL)) /* May examine pos and $& */
+ && !pRExC_state->num_code_blocks) /* May examine pos and $& */
/* x+ must match at the 1st pos of run of x's */
r->intflags |= PREGf_SKIP;
@@ -5013,11 +6175,15 @@
* it happens that c_offset_min has been invalidated, since the
* earlier string may buy us something the later one won't.]
*/
-
+
data.longest_fixed = newSVpvs("");
data.longest_float = newSVpvs("");
data.last_found = newSVpvs("");
data.longest = &(data.longest_fixed);
+ ENTER_with_name("study_chunk");
+ SAVEFREESV(data.longest_fixed);
+ SAVEFREESV(data.longest_float);
+ SAVEFREESV(data.last_found);
first = scan;
if (!ri->regstclass) {
cl_init(pRExC_state, &ch_class);
@@ -5031,10 +6197,10 @@
&data, -1, NULL, NULL,
SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag,0);
-
- CHECK_RESTUDY_GOTO;
+ CHECK_RESTUDY_GOTO_butfirst(LEAVE_with_name("study_chunk"));
+
if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
&& data.last_start_min == 0 && data.last_end > 0
&& !RExC_seen_zerolen
@@ -5042,102 +6208,58 @@
&& (!(RExC_seen & REG_SEEN_GPOS) || (r->extflags & RXf_ANCH_GPOS)))
r->extflags |= RXf_CHECK_ALL;
scan_commit(pRExC_state, &data,&minlen,0);
- SvREFCNT_dec(data.last_found);
- /* Note that code very similar to this but for anchored string
- follows immediately below, changes may need to be made to both.
- Be careful.
- */
longest_float_length = CHR_SVLEN(data.longest_float);
- if (longest_float_length
- || (data.flags & SF_FL_BEFORE_EOL
- && (!(data.flags & SF_FL_BEFORE_MEOL)
- || (RExC_flags & RXf_PMf_MULTILINE))))
+
+ if (! ((SvCUR(data.longest_fixed) /* ok to leave SvCUR */
+ && data.offset_fixed == data.offset_float_min
+ && SvCUR(data.longest_fixed) == SvCUR(data.longest_float)))
+ && S_setup_longest (aTHX_ pRExC_state,
+ data.longest_float,
+ &(r->float_utf8),
+ &(r->float_substr),
+ &(r->float_end_shift),
+ data.lookbehind_float,
+ data.offset_float_min,
+ data.minlen_float,
+ longest_float_length,
+ cBOOL(data.flags & SF_FL_BEFORE_EOL),
+ cBOOL(data.flags & SF_FL_BEFORE_MEOL)))
{
- I32 t,ml;
-
- if (SvCUR(data.longest_fixed) /* ok to leave SvCUR */
- && data.offset_fixed == data.offset_float_min
- && SvCUR(data.longest_fixed) == SvCUR(data.longest_float))
- goto remove_float; /* As in (a)+. */
-
- /* copy the information about the longest float from the reg_scan_data
- over to the program. */
- if (SvUTF8(data.longest_float)) {
- r->float_utf8 = data.longest_float;
- r->float_substr = NULL;
- } else {
- r->float_substr = data.longest_float;
- r->float_utf8 = NULL;
- }
- /* float_end_shift is how many chars that must be matched that
- follow this item. We calculate it ahead of time as once the
- lookbehind offset is added in we lose the ability to correctly
- calculate it.*/
- ml = data.minlen_float ? *(data.minlen_float)
- : (I32)longest_float_length;
- r->float_end_shift = ml - data.offset_float_min
- - longest_float_length + (SvTAIL(data.longest_float) != 0)
- + data.lookbehind_float;
r->float_min_offset = data.offset_float_min - data.lookbehind_float;
r->float_max_offset = data.offset_float_max;
if (data.offset_float_max < I32_MAX) /* Don't offset infinity */
r->float_max_offset -= data.lookbehind_float;
-
- t = (data.flags & SF_FL_BEFORE_EOL /* Can't have SEOL and MULTI */
- && (!(data.flags & SF_FL_BEFORE_MEOL)
- || (RExC_flags & RXf_PMf_MULTILINE)));
- fbm_compile(data.longest_float, t ? FBMcf_TAIL : 0);
+ SvREFCNT_inc_simple_void_NN(data.longest_float);
}
else {
- remove_float:
r->float_substr = r->float_utf8 = NULL;
- SvREFCNT_dec(data.longest_float);
longest_float_length = 0;
}
- /* Note that code very similar to this but for floating string
- is immediately above, changes may need to be made to both.
- Be careful.
- */
longest_fixed_length = CHR_SVLEN(data.longest_fixed);
- if (longest_fixed_length
- || (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */
- && (!(data.flags & SF_FIX_BEFORE_MEOL)
- || (RExC_flags & RXf_PMf_MULTILINE))))
+
+ if (S_setup_longest (aTHX_ pRExC_state,
+ data.longest_fixed,
+ &(r->anchored_utf8),
+ &(r->anchored_substr),
+ &(r->anchored_end_shift),
+ data.lookbehind_fixed,
+ data.offset_fixed,
+ data.minlen_fixed,
+ longest_fixed_length,
+ cBOOL(data.flags & SF_FIX_BEFORE_EOL),
+ cBOOL(data.flags & SF_FIX_BEFORE_MEOL)))
{
- I32 t,ml;
-
- /* copy the information about the longest fixed
- from the reg_scan_data over to the program. */
- if (SvUTF8(data.longest_fixed)) {
- r->anchored_utf8 = data.longest_fixed;
- r->anchored_substr = NULL;
- } else {
- r->anchored_substr = data.longest_fixed;
- r->anchored_utf8 = NULL;
- }
- /* fixed_end_shift is how many chars that must be matched that
- follow this item. We calculate it ahead of time as once the
- lookbehind offset is added in we lose the ability to correctly
- calculate it.*/
- ml = data.minlen_fixed ? *(data.minlen_fixed)
- : (I32)longest_fixed_length;
- r->anchored_end_shift = ml - data.offset_fixed
- - longest_fixed_length + (SvTAIL(data.longest_fixed) != 0)
- + data.lookbehind_fixed;
r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
-
- t = (data.flags & SF_FIX_BEFORE_EOL /* Can't have SEOL and MULTI */
- && (!(data.flags & SF_FIX_BEFORE_MEOL)
- || (RExC_flags & RXf_PMf_MULTILINE)));
- fbm_compile(data.longest_fixed, t ? FBMcf_TAIL : 0);
+ SvREFCNT_inc_simple_void_NN(data.longest_fixed);
}
else {
r->anchored_substr = r->anchored_utf8 = NULL;
- SvREFCNT_dec(data.longest_fixed);
longest_fixed_length = 0;
}
+ LEAVE_with_name("study_chunk");
+
if (ri->regstclass
&& (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
ri->regstclass = NULL;
@@ -5144,11 +6266,11 @@
if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
&& stclass_flag
- && !(data.start_class->flags & ANYOF_EOS)
+ && ! TEST_SSC_EOS(data.start_class)
&& !cl_is_anything(data.start_class))
{
const U32 n = add_data(pRExC_state, 1, "f");
- data.start_class->flags |= ANYOF_IS_SYNTHETIC;
+ OP(data.start_class) = ANYOF_SYNTHETIC;
Newx(RExC_rxi->data->data[n], 1,
struct regnode_charclass_class);
@@ -5199,7 +6321,7 @@
I32 fake;
struct regnode_charclass_class ch_class;
I32 last_close = 0;
-
+
DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nMulti Top Level\n"));
scan = ri->program + 1;
@@ -5211,16 +6333,16 @@
minlen = study_chunk(pRExC_state, &scan, &minlen, &fake, scan + RExC_size,
&data, -1, NULL, NULL, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS,0);
- CHECK_RESTUDY_GOTO;
+ CHECK_RESTUDY_GOTO_butfirst(NOOP);
r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
= r->float_substr = r->float_utf8 = NULL;
- if (!(data.start_class->flags & ANYOF_EOS)
+ if (! TEST_SSC_EOS(data.start_class)
&& !cl_is_anything(data.start_class))
{
const U32 n = add_data(pRExC_state, 1, "f");
- data.start_class->flags |= ANYOF_IS_SYNTHETIC;
+ OP(data.start_class) = ANYOF_SYNTHETIC;
Newx(RExC_rxi->data->data[n], 1,
struct regnode_charclass_class);
@@ -5250,47 +6372,41 @@
if (RExC_seen & REG_SEEN_GPOS)
r->extflags |= RXf_GPOS_SEEN;
if (RExC_seen & REG_SEEN_LOOKBEHIND)
- r->extflags |= RXf_LOOKBEHIND_SEEN;
- if (RExC_seen & REG_SEEN_EVAL)
+ r->extflags |= RXf_NO_INPLACE_SUBST; /* inplace might break the lookbehind */
+ if (pRExC_state->num_code_blocks)
r->extflags |= RXf_EVAL_SEEN;
if (RExC_seen & REG_SEEN_CANY)
r->extflags |= RXf_CANY_SEEN;
if (RExC_seen & REG_SEEN_VERBARG)
+ {
r->intflags |= PREGf_VERBARG_SEEN;
+ r->extflags |= RXf_NO_INPLACE_SUBST; /* don't understand this! Yves */
+ }
if (RExC_seen & REG_SEEN_CUTGROUP)
r->intflags |= PREGf_CUTGROUP_SEEN;
+ if (pm_flags & PMf_USE_RE_EVAL)
+ r->intflags |= PREGf_USE_RE_EVAL;
if (RExC_paren_names)
RXp_PAREN_NAMES(r) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
else
RXp_PAREN_NAMES(r) = NULL;
-#ifdef STUPID_PATTERN_CHECKS
- if (RX_PRELEN(rx) == 0)
- r->extflags |= RXf_NULL;
- if (r->extflags & RXf_SPLIT && RX_PRELEN(rx) == 1 && RX_PRECOMP(rx)[0] == ' ')
- /* XXX: this should happen BEFORE we compile */
- r->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
- else if (RX_PRELEN(rx) == 3 && memEQ("\\s+", RX_PRECOMP(rx), 3))
- r->extflags |= RXf_WHITE;
- else if (RX_PRELEN(rx) == 1 && RXp_PRECOMP(rx)[0] == '^')
- r->extflags |= RXf_START_ONLY;
-#else
- if (r->extflags & RXf_SPLIT && RX_PRELEN(rx) == 1 && RX_PRECOMP(rx)[0] == ' ')
- /* XXX: this should happen BEFORE we compile */
- r->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
- else {
+ {
regnode *first = ri->program + 1;
U8 fop = OP(first);
+ regnode *next = NEXTOPER(first);
+ U8 nop = OP(next);
- if (PL_regkind[fop] == NOTHING && OP(NEXTOPER(first)) == END)
+ if (PL_regkind[fop] == NOTHING && nop == END)
r->extflags |= RXf_NULL;
- else if (PL_regkind[fop] == BOL && OP(NEXTOPER(first)) == END)
+ else if (PL_regkind[fop] == BOL && nop == END)
r->extflags |= RXf_START_ONLY;
- else if (fop == PLUS && OP(NEXTOPER(first)) == SPACE
- && OP(regnext(first)) == END)
- r->extflags |= RXf_WHITE;
+ else if (fop == PLUS && PL_regkind[nop] == POSIXD && FLAGS(next) == _CC_SPACE && OP(regnext(first)) == END)
+ r->extflags |= RXf_WHITE;
+ else if ( r->extflags & RXf_SPLIT && fop == EXACT && STR_LEN(first) == 1 && *(STRING(first)) == ' ' && OP(regnext(first)) == END )
+ r->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
+
}
-#endif
#ifdef DEBUGGING
if (RExC_paren_names) {
ri->name_list_idx = add_data( pRExC_state, 1, "a" );
@@ -5326,12 +6442,18 @@
PerlIO_printf(Perl_debug_log, "\n");
});
#endif
+
+#ifdef USE_ITHREADS
+ /* under ithreads the ?pat? PMf_USED flag on the pmop is simulated
+ * by setting the regexp SV to readonly-only instead. If the
+ * pattern's been recompiled, the USEDness should remain. */
+ if (old_re && SvREADONLY(old_re))
+ SvREADONLY_on(rx);
+#endif
return rx;
}
-#undef RE_ENGINE_PTR
-
SV*
Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
const U32 flags)
@@ -5343,7 +6465,7 @@
if (flags & RXapif_FETCH) {
return reg_named_buff_fetch(rx, key, flags);
} else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
return NULL;
} else if (flags & RXapif_EXISTS) {
return reg_named_buff_exists(rx, key, flags)
@@ -5382,7 +6504,7 @@
{
AV *retarray = NULL;
SV *ret;
- struct regexp *const rx = (struct regexp *)SvANY(r);
+ struct regexp *const rx = ReANY(r);
PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
@@ -5405,7 +6527,8 @@
if (!retarray)
return ret;
} else {
- ret = newSVsv(&PL_sv_undef);
+ if (retarray)
+ ret = newSVsv(&PL_sv_undef);
}
if (retarray)
av_push(retarray, ret);
@@ -5421,7 +6544,7 @@
Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
const U32 flags)
{
- struct regexp *const rx = (struct regexp *)SvANY(r);
+ struct regexp *const rx = ReANY(r);
PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
@@ -5431,7 +6554,7 @@
} else {
SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
if (sv) {
- SvREFCNT_dec(sv);
+ SvREFCNT_dec_NN(sv);
return TRUE;
} else {
return FALSE;
@@ -5445,7 +6568,7 @@
SV*
Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
{
- struct regexp *const rx = (struct regexp *)SvANY(r);
+ struct regexp *const rx = ReANY(r);
PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
@@ -5461,7 +6584,7 @@
SV*
Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
{
- struct regexp *const rx = (struct regexp *)SvANY(r);
+ struct regexp *const rx = ReANY(r);
GET_RE_DEBUG_FLAGS_DECL;
PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
@@ -5497,7 +6620,7 @@
SV *ret;
AV *av;
I32 length;
- struct regexp *const rx = (struct regexp *)SvANY(r);
+ struct regexp *const rx = ReANY(r);
PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
@@ -5508,7 +6631,7 @@
ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
av = MUTABLE_AV(SvRV(ret));
length = av_len(av);
- SvREFCNT_dec(ret);
+ SvREFCNT_dec_NN(ret);
return newSViv(length + 1);
} else {
Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar", (int)flags);
@@ -5521,7 +6644,7 @@
SV*
Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
{
- struct regexp *const rx = (struct regexp *)SvANY(r);
+ struct regexp *const rx = ReANY(r);
AV *av = newAV();
PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
@@ -5557,47 +6680,67 @@
Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
SV * const sv)
{
- struct regexp *const rx = (struct regexp *)SvANY(r);
+ struct regexp *const rx = ReANY(r);
char *s = NULL;
I32 i = 0;
I32 s1, t1;
+ I32 n = paren;
PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
- if (!rx->subbeg) {
- sv_setsv(sv,&PL_sv_undef);
- return;
- }
- else
- if (paren == RX_BUFF_IDX_PREMATCH && rx->offs[0].start != -1) {
- /* $` */
+ if ( ( n == RX_BUFF_IDX_CARET_PREMATCH
+ || n == RX_BUFF_IDX_CARET_FULLMATCH
+ || n == RX_BUFF_IDX_CARET_POSTMATCH
+ )
+ && !(rx->extflags & RXf_PMf_KEEPCOPY)
+ )
+ goto ret_undef;
+
+ if (!rx->subbeg)
+ goto ret_undef;
+
+ if (n == RX_BUFF_IDX_CARET_FULLMATCH)
+ /* no need to distinguish between them any more */
+ n = RX_BUFF_IDX_FULLMATCH;
+
+ if ((n == RX_BUFF_IDX_PREMATCH || n == RX_BUFF_IDX_CARET_PREMATCH)
+ && rx->offs[0].start != -1)
+ {
+ /* $`, ${^PREMATCH} */
i = rx->offs[0].start;
s = rx->subbeg;
}
else
- if (paren == RX_BUFF_IDX_POSTMATCH && rx->offs[0].end != -1) {
- /* $' */
- s = rx->subbeg + rx->offs[0].end;
- i = rx->sublen - rx->offs[0].end;
+ if ((n == RX_BUFF_IDX_POSTMATCH || n == RX_BUFF_IDX_CARET_POSTMATCH)
+ && rx->offs[0].end != -1)
+ {
+ /* $', ${^POSTMATCH} */
+ s = rx->subbeg - rx->suboffset + rx->offs[0].end;
+ i = rx->sublen + rx->suboffset - rx->offs[0].end;
}
else
- if ( 0 <= paren && paren <= (I32)rx->nparens &&
- (s1 = rx->offs[paren].start) != -1 &&
- (t1 = rx->offs[paren].end) != -1)
+ if ( 0 <= n && n <= (I32)rx->nparens &&
+ (s1 = rx->offs[n].start) != -1 &&
+ (t1 = rx->offs[n].end) != -1)
{
- /* $& $1 ... */
+ /* $&, ${^MATCH}, $1 ... */
i = t1 - s1;
- s = rx->subbeg + s1;
+ s = rx->subbeg + s1 - rx->suboffset;
} else {
- sv_setsv(sv,&PL_sv_undef);
- return;
+ goto ret_undef;
}
+
+ assert(s >= rx->subbeg);
assert(rx->sublen >= (s - rx->subbeg) + i );
if (i >= 0) {
- const int oldtainted = PL_tainted;
+#if NO_TAINT_SUPPORT
+ sv_setpvn(sv, s, i);
+#else
+ const int oldtainted = TAINT_get;
TAINT_NOT;
sv_setpvn(sv, s, i);
- PL_tainted = oldtainted;
+ TAINT_set(oldtainted);
+#endif
if ( (rx->extflags & RXf_CANY_SEEN)
? (RXp_MATCH_UTF8(rx)
&& (!i || is_utf8_string((U8*)s, i)))
@@ -5607,12 +6750,12 @@
}
else
SvUTF8_off(sv);
- if (PL_tainting) {
+ if (TAINTING_get) {
if (RXp_MATCH_TAINTED(rx)) {
if (SvTYPE(sv) >= SVt_PVMG) {
MAGIC* const mg = SvMAGIC(sv);
MAGIC* mgt;
- PL_tainted = 1;
+ TAINT;
SvMAGIC_set(sv, mg->mg_moremagic);
SvTAINT(sv);
if ((mgt = SvMAGIC(sv))) {
@@ -5620,7 +6763,7 @@
SvMAGIC_set(sv, mg);
}
} else {
- PL_tainted = 1;
+ TAINT;
SvTAINT(sv);
}
} else
@@ -5627,6 +6770,7 @@
SvTAINTED_off(sv);
}
} else {
+ ret_undef:
sv_setsv(sv,&PL_sv_undef);
return;
}
@@ -5643,7 +6787,7 @@
PERL_UNUSED_ARG(value);
if (!PL_localizing)
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
}
I32
@@ -5650,7 +6794,7 @@
Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
const I32 paren)
{
- struct regexp *const rx = (struct regexp *)SvANY(r);
+ struct regexp *const rx = ReANY(r);
I32 i;
I32 s1, t1;
@@ -5657,9 +6801,13 @@
PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
/* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
- switch (paren) {
- /* $` / ${^PREMATCH} */
- case RX_BUFF_IDX_PREMATCH:
+ switch (paren) {
+ case RX_BUFF_IDX_CARET_PREMATCH: /* ${^PREMATCH} */
+ if (!(rx->extflags & RXf_PMf_KEEPCOPY))
+ goto warn_undef;
+ /*FALLTHROUGH*/
+
+ case RX_BUFF_IDX_PREMATCH: /* $` */
if (rx->offs[0].start != -1) {
i = rx->offs[0].start;
if (i > 0) {
@@ -5669,8 +6817,11 @@
}
}
return 0;
- /* $' / ${^POSTMATCH} */
- case RX_BUFF_IDX_POSTMATCH:
+
+ case RX_BUFF_IDX_CARET_POSTMATCH: /* ${^POSTMATCH} */
+ if (!(rx->extflags & RXf_PMf_KEEPCOPY))
+ goto warn_undef;
+ case RX_BUFF_IDX_POSTMATCH: /* $' */
if (rx->offs[0].end != -1) {
i = rx->sublen - rx->offs[0].end;
if (i > 0) {
@@ -5680,6 +6831,12 @@
}
}
return 0;
+
+ case RX_BUFF_IDX_CARET_FULLMATCH: /* ${^MATCH} */
+ if (!(rx->extflags & RXf_PMf_KEEPCOPY))
+ goto warn_undef;
+ /*FALLTHROUGH*/
+
/* $& / ${^MATCH}, $1, $2, ... */
default:
if (paren <= (I32)rx->nparens &&
@@ -5689,6 +6846,7 @@
i = t1 - s1;
goto getlen;
} else {
+ warn_undef:
if (ckWARN(WARN_UNINITIALIZED))
report_uninit((const SV *)sv);
return 0;
@@ -5696,7 +6854,7 @@
}
getlen:
if (i > 0 && RXp_MATCH_UTF8(rx)) {
- const char * const s = rx->subbeg + s1;
+ const char * const s = rx->subbeg - rx->suboffset + s1;
const U8 *ep;
STRLEN el;
@@ -5742,13 +6900,15 @@
if (UTF)
do {
RExC_parse += UTF8SKIP(RExC_parse);
- } while (isALNUM_utf8((U8*)RExC_parse));
+ } while (isWORDCHAR_utf8((U8*)RExC_parse));
else
do {
RExC_parse++;
- } while (isALNUM(*RExC_parse));
+ } while (isWORDCHAR(*RExC_parse));
+ } else {
+ RExC_parse++; /* so the <- from the vFAIL is after the offending character */
+ vFAIL("Group name must start with a non-digit word character");
}
-
if ( flags ) {
SV* sv_name
= newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
@@ -5769,9 +6929,10 @@
return sv_dat;
}
else {
- Perl_croak(aTHX_ "panic: bad flag in reg_scan_name");
+ Perl_croak(aTHX_ "panic: bad flag %lx in reg_scan_name",
+ (unsigned long) flags);
}
- /* NOT REACHED */
+ assert(0); /* NOT REACHED */
}
return NULL;
}
@@ -5824,22 +6985,77 @@
/* This section of code defines the inversion list object and its methods. The
* interfaces are highly subject to change, so as much as possible is static to
- * this file. An inversion list is here implemented as a malloc'd C array with
- * some added info. More will be coming when functionality is added later.
+ * this file. An inversion list is here implemented as a malloc'd C UV array
+ * with some added info that is placed as UVs at the beginning in a header
+ * portion. An inversion list for Unicode is an array of code points, sorted
+ * by ordinal number. The zeroth element is the first code point in the list.
+ * The 1th element is the first element beyond that not in the list. In other
+ * words, the first range is
+ * invlist[0]..(invlist[1]-1)
+ * The other ranges follow. Thus every element whose index is divisible by two
+ * marks the beginning of a range that is in the list, and every element not
+ * divisible by two marks the beginning of a range not in the list. A single
+ * element inversion list that contains the single code point N generally
+ * consists of two elements
+ * invlist[0] == N
+ * invlist[1] == N+1
+ * (The exception is when N is the highest representable value on the
+ * machine, in which case the list containing just it would be a single
+ * element, itself. By extension, if the last range in the list extends to
+ * infinity, then the first element of that range will be in the inversion list
+ * at a position that is divisible by two, and is the final element in the
+ * list.)
+ * Taking the complement (inverting) an inversion list is quite simple, if the
+ * first element is 0, remove it; otherwise add a 0 element at the beginning.
+ * This implementation reserves an element at the beginning of each inversion
+ * list to contain 0 when the list contains 0, and contains 1 otherwise. The
+ * actual beginning of the list is either that element if 0, or the next one if
+ * 1.
*
- * It is currently implemented as an HV to the outside world, but is actually
- * an SV pointing to an array of UVs that the SV thinks are bytes. This allows
- * us to have an array of UV whose memory management is automatically handled
- * by the existing facilities for SV's.
+ * More about inversion lists can be found in "Unicode Demystified"
+ * Chapter 13 by Richard Gillam, published by Addison-Wesley.
+ * More will be coming when functionality is added later.
*
+ * The inversion list data structure is currently implemented as an SV pointing
+ * to an array of UVs that the SV thinks are bytes. This allows us to have an
+ * array of UV whose memory management is automatically handled by the existing
+ * facilities for SV's.
+ *
* Some of the methods should always be private to the implementation, and some
* should eventually be made public */
+/* The header definitions are in F<inline_invlist.c> */
+#define TO_INTERNAL_SIZE(x) (((x) + HEADER_LENGTH) * sizeof(UV))
+#define FROM_INTERNAL_SIZE(x) (((x)/ sizeof(UV)) - HEADER_LENGTH)
+
#define INVLIST_INITIAL_LEN 10
PERL_STATIC_INLINE UV*
-S_invlist_array(pTHX_ HV* const invlist)
+S__invlist_array_init(pTHX_ SV* const invlist, const bool will_have_0)
{
+ /* Returns a pointer to the first element in the inversion list's array.
+ * This is called upon initialization of an inversion list. Where the
+ * array begins depends on whether the list has the code point U+0000
+ * in it or not. The other parameter tells it whether the code that
+ * follows this call is about to put a 0 in the inversion list or not.
+ * The first element is either the element with 0, if 0, or the next one,
+ * if 1 */
+
+ UV* zero = get_invlist_zero_addr(invlist);
+
+ PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT;
+
+ /* Must be empty */
+ assert(! *_get_invlist_len_addr(invlist));
+
+ /* 1^1 = 0; 1^0 = 1 */
+ *zero = 1 ^ will_have_0;
+ return zero + *zero;
+}
+
+PERL_STATIC_INLINE UV*
+S_invlist_array(pTHX_ SV* const invlist)
+{
/* Returns the pointer to the inversion list's array. Every time the
* length changes, this needs to be called in case malloc or realloc moved
* it */
@@ -5846,58 +7062,107 @@
PERL_ARGS_ASSERT_INVLIST_ARRAY;
- return (UV *) SvPVX(invlist);
+ /* Must not be empty. If these fail, you probably didn't check for <len>
+ * being non-zero before trying to get the array */
+ assert(*_get_invlist_len_addr(invlist));
+ assert(*get_invlist_zero_addr(invlist) == 0
+ || *get_invlist_zero_addr(invlist) == 1);
+
+ /* The array begins either at the element reserved for zero if the
+ * list contains 0 (that element will be set to 0), or otherwise the next
+ * element (in which case the reserved element will be set to 1). */
+ return (UV *) (get_invlist_zero_addr(invlist)
+ + *get_invlist_zero_addr(invlist));
}
-PERL_STATIC_INLINE UV
-S_invlist_len(pTHX_ HV* const invlist)
+PERL_STATIC_INLINE void
+S_invlist_set_len(pTHX_ SV* const invlist, const UV len)
{
- /* Returns the current number of elements in the inversion list's array */
+ /* Sets the current number of elements stored in the inversion list */
- PERL_ARGS_ASSERT_INVLIST_LEN;
+ PERL_ARGS_ASSERT_INVLIST_SET_LEN;
- return SvCUR(invlist) / sizeof(UV);
+ *_get_invlist_len_addr(invlist) = len;
+
+ assert(len <= SvLEN(invlist));
+
+ SvCUR_set(invlist, TO_INTERNAL_SIZE(len));
+ /* If the list contains U+0000, that element is part of the header,
+ * and should not be counted as part of the array. It will contain
+ * 0 in that case, and 1 otherwise. So we could flop 0=>1, 1=>0 and
+ * subtract:
+ * SvCUR_set(invlist,
+ * TO_INTERNAL_SIZE(len
+ * - (*get_invlist_zero_addr(inv_list) ^ 1)));
+ * But, this is only valid if len is not 0. The consequences of not doing
+ * this is that the memory allocation code may think that 1 more UV is
+ * being used than actually is, and so might do an unnecessary grow. That
+ * seems worth not bothering to make this the precise amount.
+ *
+ * Note that when inverting, SvCUR shouldn't change */
}
-PERL_STATIC_INLINE UV
-S_invlist_max(pTHX_ HV* const invlist)
+PERL_STATIC_INLINE IV*
+S_get_invlist_previous_index_addr(pTHX_ SV* invlist)
{
- /* Returns the maximum number of elements storable in the inversion list's
- * array, without having to realloc() */
+ /* Return the address of the UV that is reserved to hold the cached index
+ * */
- PERL_ARGS_ASSERT_INVLIST_MAX;
+ PERL_ARGS_ASSERT_GET_INVLIST_PREVIOUS_INDEX_ADDR;
- return SvLEN(invlist) / sizeof(UV);
+ return (IV *) (SvPVX(invlist) + (INVLIST_PREVIOUS_INDEX_OFFSET * sizeof (UV)));
}
-PERL_STATIC_INLINE void
-S_invlist_set_len(pTHX_ HV* const invlist, const UV len)
+PERL_STATIC_INLINE IV
+S_invlist_previous_index(pTHX_ SV* const invlist)
{
- /* Sets the current number of elements stored in the inversion list */
+ /* Returns cached index of previous search */
- PERL_ARGS_ASSERT_INVLIST_SET_LEN;
+ PERL_ARGS_ASSERT_INVLIST_PREVIOUS_INDEX;
- SvCUR_set(invlist, len * sizeof(UV));
+ return *get_invlist_previous_index_addr(invlist);
}
PERL_STATIC_INLINE void
-S_invlist_set_max(pTHX_ HV* const invlist, const UV max)
+S_invlist_set_previous_index(pTHX_ SV* const invlist, const IV index)
{
+ /* Caches <index> for later retrieval */
- /* Sets the maximum number of elements storable in the inversion list
- * without having to realloc() */
+ PERL_ARGS_ASSERT_INVLIST_SET_PREVIOUS_INDEX;
- PERL_ARGS_ASSERT_INVLIST_SET_MAX;
+ assert(index == 0 || index < (int) _invlist_len(invlist));
- if (max < invlist_len(invlist)) {
- Perl_croak(aTHX_ "panic: Can't make max size '%"UVuf"' less than current length %"UVuf" in inversion list", invlist_max(invlist), invlist_len(invlist));
- }
+ *get_invlist_previous_index_addr(invlist) = index;
+}
- SvLEN_set(invlist, max * sizeof(UV));
+PERL_STATIC_INLINE UV
+S_invlist_max(pTHX_ SV* const invlist)
+{
+ /* Returns the maximum number of elements storable in the inversion list's
+ * array, without having to realloc() */
+
+ PERL_ARGS_ASSERT_INVLIST_MAX;
+
+ return SvLEN(invlist) == 0 /* This happens under _new_invlist_C_array */
+ ? _invlist_len(invlist)
+ : FROM_INTERNAL_SIZE(SvLEN(invlist));
}
+PERL_STATIC_INLINE UV*
+S_get_invlist_zero_addr(pTHX_ SV* invlist)
+{
+ /* Return the address of the UV that is reserved to hold 0 if the inversion
+ * list contains 0. This has to be the last element of the heading, as the
+ * list proper starts with either it if 0, or the next element if not.
+ * (But we force it to contain either 0 or 1) */
+
+ PERL_ARGS_ASSERT_GET_INVLIST_ZERO_ADDR;
+
+ return (UV *) (SvPVX(invlist) + (INVLIST_ZERO_OFFSET * sizeof (UV)));
+}
+
#ifndef PERL_IN_XSUB_RE
-HV*
+SV*
Perl__new_invlist(pTHX_ IV initial_size)
{
@@ -5905,37 +7170,76 @@
* space to store 'initial_size' elements. If that number is negative, a
* system default is used instead */
+ SV* new_list;
+
if (initial_size < 0) {
initial_size = INVLIST_INITIAL_LEN;
}
/* Allocate the initial space */
- return (HV *) newSV(initial_size * sizeof(UV));
+ new_list = newSV(TO_INTERNAL_SIZE(initial_size));
+ invlist_set_len(new_list, 0);
+
+ /* Force iterinit() to be used to get iteration to work */
+ *get_invlist_iter_addr(new_list) = UV_MAX;
+
+ /* This should force a segfault if a method doesn't initialize this
+ * properly */
+ *get_invlist_zero_addr(new_list) = UV_MAX;
+
+ *get_invlist_previous_index_addr(new_list) = 0;
+ *get_invlist_version_id_addr(new_list) = INVLIST_VERSION_ID;
+#if HEADER_LENGTH != 5
+# error Need to regenerate INVLIST_VERSION_ID by running perl -E 'say int(rand 2**31-1)', and then changing the #if to the new length
+#endif
+
+ return new_list;
}
#endif
-PERL_STATIC_INLINE void
-S_invlist_destroy(pTHX_ HV* const invlist)
+STATIC SV*
+S__new_invlist_C_array(pTHX_ UV* list)
{
- /* Inversion list destructor */
+ /* Return a pointer to a newly constructed inversion list, initialized to
+ * point to <list>, which has to be in the exact correct inversion list
+ * form, including internal fields. Thus this is a dangerous routine that
+ * should not be used in the wrong hands */
- PERL_ARGS_ASSERT_INVLIST_DESTROY;
+ SV* invlist = newSV_type(SVt_PV);
- SvREFCNT_dec(invlist);
+ PERL_ARGS_ASSERT__NEW_INVLIST_C_ARRAY;
+
+ SvPV_set(invlist, (char *) list);
+ SvLEN_set(invlist, 0); /* Means we own the contents, and the system
+ shouldn't touch it */
+ SvCUR_set(invlist, TO_INTERNAL_SIZE(_invlist_len(invlist)));
+
+ if (*get_invlist_version_id_addr(invlist) != INVLIST_VERSION_ID) {
+ Perl_croak(aTHX_ "panic: Incorrect version for previously generated inversion list");
+ }
+
+ /* Initialize the iteration pointer.
+ * XXX This could be done at compile time in charclass_invlists.h, but I
+ * (khw) am not confident that the suffixes for specifying the C constant
+ * UV_MAX are portable, e.g. 'ull' on a 32 bit machine that is configured
+ * to use 64 bits; might need a Configure probe */
+ invlist_iterfinish(invlist);
+
+ return invlist;
}
STATIC void
-S_invlist_extend(pTHX_ HV* const invlist, const UV new_max)
+S_invlist_extend(pTHX_ SV* const invlist, const UV new_max)
{
/* Grow the maximum size of an inversion list */
PERL_ARGS_ASSERT_INVLIST_EXTEND;
- SvGROW((SV *)invlist, new_max * sizeof(UV));
+ SvGROW((SV *)invlist, TO_INTERNAL_SIZE(new_max));
}
PERL_STATIC_INLINE void
-S_invlist_trim(pTHX_ HV* const invlist)
+S_invlist_trim(pTHX_ SV* const invlist)
{
PERL_ARGS_ASSERT_INVLIST_TRIM;
@@ -5945,27 +7249,25 @@
SvPV_shrink_to_cur((SV *) invlist);
}
-/* An element is in an inversion list iff its index is even numbered: 0, 2, 4,
- * etc */
+#define _invlist_union_complement_2nd(a, b, output) _invlist_union_maybe_complement_2nd(a, b, TRUE, output)
-#define ELEMENT_IN_INVLIST_SET(i) (! ((i) & 1))
-
-#ifndef PERL_IN_XSUB_RE
-void
-Perl__append_range_to_invlist(pTHX_ HV* const invlist, const UV start, const UV end)
+STATIC void
+S__append_range_to_invlist(pTHX_ SV* const invlist, const UV start, const UV end)
{
/* Subject to change or removal. Append the range from 'start' to 'end' at
* the end of the inversion list. The range must be above any existing
* ones. */
- UV* array = invlist_array(invlist);
+ UV* array;
UV max = invlist_max(invlist);
- UV len = invlist_len(invlist);
+ UV len = _invlist_len(invlist);
PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
- if (len > 0) {
-
+ if (len == 0) { /* Empty lists must be initialized */
+ array = _invlist_array_init(invlist, start == 0);
+ }
+ else {
/* Here, the existing list is non-empty. The current max entry in the
* list is generally the first value not in the set, except when the
* set extends to the end of permissible values, in which case it is
@@ -5973,10 +7275,13 @@
* append out-of-order */
UV final_element = len - 1;
+ array = invlist_array(invlist);
if (array[final_element] > start
- || ELEMENT_IN_INVLIST_SET(final_element))
+ || ELEMENT_RANGE_MATCHES_INVLIST(final_element))
{
- Perl_croak(aTHX_ "panic: attempting to append to an inversion list, but wasn't at the end of the list");
+ Perl_croak(aTHX_ "panic: attempting to append to an inversion list, but wasn't at the end of the list, final=%"UVuf", start=%"UVuf", match=%c",
+ array[final_element], start,
+ ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f');
}
/* Here, it is a legal append. If the new range begins with the first
@@ -5989,7 +7294,7 @@
}
else {
/* But if the end is the maximum representable on the machine,
- * just let the range that this would extend have no end */
+ * just let the range that this would extend to have no end */
invlist_set_len(invlist, len - 1);
}
return;
@@ -6004,11 +7309,14 @@
* moved */
if (max < len) {
invlist_extend(invlist, len);
+ invlist_set_len(invlist, len); /* Have to set len here to avoid assert
+ failure in invlist_array() */
array = invlist_array(invlist);
}
+ else {
+ invlist_set_len(invlist, len);
+ }
- invlist_set_len(invlist, len);
-
/* The next item on the list starts the range, the one after that is
* one past the new range. */
array[len - 2] = start;
@@ -6021,12 +7329,200 @@
invlist_set_len(invlist, len - 1);
}
}
-#endif
-STATIC HV*
-S_invlist_union(pTHX_ HV* const a, HV* const b)
+#ifndef PERL_IN_XSUB_RE
+
+IV
+Perl__invlist_search(pTHX_ SV* const invlist, const UV cp)
{
- /* Return a new inversion list which is the union of two inversion lists.
+ /* Searches the inversion list for the entry that contains the input code
+ * point <cp>. If <cp> is not in the list, -1 is returned. Otherwise, the
+ * return value is the index into the list's array of the range that
+ * contains <cp> */
+
+ IV low = 0;
+ IV mid;
+ IV high = _invlist_len(invlist);
+ const IV highest_element = high - 1;
+ const UV* array;
+
+ PERL_ARGS_ASSERT__INVLIST_SEARCH;
+
+ /* If list is empty, return failure. */
+ if (high == 0) {
+ return -1;
+ }
+
+ /* (We can't get the array unless we know the list is non-empty) */
+ array = invlist_array(invlist);
+
+ mid = invlist_previous_index(invlist);
+ assert(mid >=0 && mid <= highest_element);
+
+ /* <mid> contains the cache of the result of the previous call to this
+ * function (0 the first time). See if this call is for the same result,
+ * or if it is for mid-1. This is under the theory that calls to this
+ * function will often be for related code points that are near each other.
+ * And benchmarks show that caching gives better results. We also test
+ * here if the code point is within the bounds of the list. These tests
+ * replace others that would have had to be made anyway to make sure that
+ * the array bounds were not exceeded, and these give us extra information
+ * at the same time */
+ if (cp >= array[mid]) {
+ if (cp >= array[highest_element]) {
+ return highest_element;
+ }
+
+ /* Here, array[mid] <= cp < array[highest_element]. This means that
+ * the final element is not the answer, so can exclude it; it also
+ * means that <mid> is not the final element, so can refer to 'mid + 1'
+ * safely */
+ if (cp < array[mid + 1]) {
+ return mid;
+ }
+ high--;
+ low = mid + 1;
+ }
+ else { /* cp < aray[mid] */
+ if (cp < array[0]) { /* Fail if outside the array */
+ return -1;
+ }
+ high = mid;
+ if (cp >= array[mid - 1]) {
+ goto found_entry;
+ }
+ }
+
+ /* Binary search. What we are looking for is <i> such that
+ * array[i] <= cp < array[i+1]
+ * The loop below converges on the i+1. Note that there may not be an
+ * (i+1)th element in the array, and things work nonetheless */
+ while (low < high) {
+ mid = (low + high) / 2;
+ assert(mid <= highest_element);
+ if (array[mid] <= cp) { /* cp >= array[mid] */
+ low = mid + 1;
+
+ /* We could do this extra test to exit the loop early.
+ if (cp < array[low]) {
+ return mid;
+ }
+ */
+ }
+ else { /* cp < array[mid] */
+ high = mid;
+ }
+ }
+
+ found_entry:
+ high--;
+ invlist_set_previous_index(invlist, high);
+ return high;
+}
+
+void
+Perl__invlist_populate_swatch(pTHX_ SV* const invlist, const UV start, const UV end, U8* swatch)
+{
+ /* populates a swatch of a swash the same way swatch_get() does in utf8.c,
+ * but is used when the swash has an inversion list. This makes this much
+ * faster, as it uses a binary search instead of a linear one. This is
+ * intimately tied to that function, and perhaps should be in utf8.c,
+ * except it is intimately tied to inversion lists as well. It assumes
+ * that <swatch> is all 0's on input */
+
+ UV current = start;
+ const IV len = _invlist_len(invlist);
+ IV i;
+ const UV * array;
+
+ PERL_ARGS_ASSERT__INVLIST_POPULATE_SWATCH;
+
+ if (len == 0) { /* Empty inversion list */
+ return;
+ }
+
+ array = invlist_array(invlist);
+
+ /* Find which element it is */
+ i = _invlist_search(invlist, start);
+
+ /* We populate from <start> to <end> */
+ while (current < end) {
+ UV upper;
+
+ /* The inversion list gives the results for every possible code point
+ * after the first one in the list. Only those ranges whose index is
+ * even are ones that the inversion list matches. For the odd ones,
+ * and if the initial code point is not in the list, we have to skip
+ * forward to the next element */
+ if (i == -1 || ! ELEMENT_RANGE_MATCHES_INVLIST(i)) {
+ i++;
+ if (i >= len) { /* Finished if beyond the end of the array */
+ return;
+ }
+ current = array[i];
+ if (current >= end) { /* Finished if beyond the end of what we
+ are populating */
+ if (LIKELY(end < UV_MAX)) {
+ return;
+ }
+
+ /* We get here when the upper bound is the maximum
+ * representable on the machine, and we are looking for just
+ * that code point. Have to special case it */
+ i = len;
+ goto join_end_of_list;
+ }
+ }
+ assert(current >= start);
+
+ /* The current range ends one below the next one, except don't go past
+ * <end> */
+ i++;
+ upper = (i < len && array[i] < end) ? array[i] : end;
+
+ /* Here we are in a range that matches. Populate a bit in the 3-bit U8
+ * for each code point in it */
+ for (; current < upper; current++) {
+ const STRLEN offset = (STRLEN)(current - start);
+ swatch[offset >> 3] |= 1 << (offset & 7);
+ }
+
+ join_end_of_list:
+
+ /* Quit if at the end of the list */
+ if (i >= len) {
+
+ /* But first, have to deal with the highest possible code point on
+ * the platform. The previous code assumes that <end> is one
+ * beyond where we want to populate, but that is impossible at the
+ * platform's infinity, so have to handle it specially */
+ if (UNLIKELY(end == UV_MAX && ELEMENT_RANGE_MATCHES_INVLIST(len-1)))
+ {
+ const STRLEN offset = (STRLEN)(end - start);
+ swatch[offset >> 3] |= 1 << (offset & 7);
+ }
+ return;
+ }
+
+ /* Advance to the next range, which will be for code points not in the
+ * inversion list */
+ current = array[i];
+ }
+
+ return;
+}
+
+void
+Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, bool complement_b, SV** output)
+{
+ /* Take the union of two inversion lists and point <output> to it. *output
+ * SHOULD BE DEFINED upon input, and if it points to one of the two lists,
+ * the reference count to that list will be decremented. The first list,
+ * <a>, may be NULL, in which case a copy of the second list is returned.
+ * If <complement_b> is TRUE, the union is taken of the complement
+ * (inversion) of <b> instead of b itself.
+ *
* The basis for this comes from "Unicode Demystified" Chapter 13 by
* Richard Gillam, published by Addison-Wesley, and explained at some
* length there. The preface says to incorporate its examples into your
@@ -6037,14 +7533,15 @@
* XXX A potential performance improvement is to keep track as we go along
* if only one of the inputs contributes to the result, meaning the other
* is a subset of that one. In that case, we can skip the final copy and
- * return the larger of the input lists */
+ * return the larger of the input lists, but then outside code might need
+ * to keep track of whether to free the input list or not */
- UV* array_a = invlist_array(a); /* a's array */
- UV* array_b = invlist_array(b);
- UV len_a = invlist_len(a); /* length of a's array */
- UV len_b = invlist_len(b);
+ UV* array_a; /* a's array */
+ UV* array_b;
+ UV len_a; /* length of a's array */
+ UV len_b;
- HV* u; /* the resulting union */
+ SV* u; /* the resulting union */
UV* array_u;
UV len_u;
@@ -6060,13 +7557,82 @@
*/
UV count = 0;
- PERL_ARGS_ASSERT_INVLIST_UNION;
+ PERL_ARGS_ASSERT__INVLIST_UNION_MAYBE_COMPLEMENT_2ND;
+ assert(a != b);
+ /* If either one is empty, the union is the other one */
+ if (a == NULL || ((len_a = _invlist_len(a)) == 0)) {
+ if (*output == a) {
+ if (a != NULL) {
+ SvREFCNT_dec_NN(a);
+ }
+ }
+ if (*output != b) {
+ *output = invlist_clone(b);
+ if (complement_b) {
+ _invlist_invert(*output);
+ }
+ } /* else *output already = b; */
+ return;
+ }
+ else if ((len_b = _invlist_len(b)) == 0) {
+ if (*output == b) {
+ SvREFCNT_dec_NN(b);
+ }
+
+ /* The complement of an empty list is a list that has everything in it,
+ * so the union with <a> includes everything too */
+ if (complement_b) {
+ if (a == *output) {
+ SvREFCNT_dec_NN(a);
+ }
+ *output = _new_invlist(1);
+ _append_range_to_invlist(*output, 0, UV_MAX);
+ }
+ else if (*output != a) {
+ *output = invlist_clone(a);
+ }
+ /* else *output already = a; */
+ return;
+ }
+
+ /* Here both lists exist and are non-empty */
+ array_a = invlist_array(a);
+ array_b = invlist_array(b);
+
+ /* If are to take the union of 'a' with the complement of b, set it
+ * up so are looking at b's complement. */
+ if (complement_b) {
+
+ /* To complement, we invert: if the first element is 0, remove it. To
+ * do this, we just pretend the array starts one later, and clear the
+ * flag as we don't have to do anything else later */
+ if (array_b[0] == 0) {
+ array_b++;
+ len_b--;
+ complement_b = FALSE;
+ }
+ else {
+
+ /* But if the first element is not zero, we unshift a 0 before the
+ * array. The data structure reserves a space for that 0 (which
+ * should be a '1' right now), so physical shifting is unneeded,
+ * but temporarily change that element to 0. Before exiting the
+ * routine, we must restore the element to '1' */
+ array_b--;
+ len_b++;
+ array_b[0] = 0;
+ }
+ }
+
/* Size the union for the worst case: that the sets are completely
* disjoint */
u = _new_invlist(len_a + len_b);
- array_u = invlist_array(u);
+ /* Will contain U+0000 if either component does */
+ array_u = _invlist_array_init(u, (len_a > 0 && array_a[0] == 0)
+ || (len_b > 0 && array_b[0] == 0));
+
/* Go through each list item by item, stopping when exhausted one of
* them */
while (i_a < len_a && i_b < len_b) {
@@ -6085,14 +7651,15 @@
* be seamlessly merged. (In a tie and both are in the set or both not
* in the set, it doesn't matter which we take first.) */
if (array_a[i_a] < array_b[i_b]
- || (array_a[i_a] == array_b[i_b] && ELEMENT_IN_INVLIST_SET(i_a)))
+ || (array_a[i_a] == array_b[i_b]
+ && ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
{
- cp_in_set = ELEMENT_IN_INVLIST_SET(i_a);
+ cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
cp= array_a[i_a++];
}
else {
- cp_in_set = ELEMENT_IN_INVLIST_SET(i_b);
- cp= array_b[i_b++];
+ cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
+ cp = array_b[i_b++];
}
/* Here, have chosen which of the two inputs to look at. Only output
@@ -6115,9 +7682,9 @@
/* Here, we are finished going through at least one of the lists, which
* means there is something remaining in at most one. We check if the list
* that hasn't been exhausted is positioned such that we are in the middle
- * of a range in its set or not. (We are in the set if the next item in
- * the array marks the beginning of something not in the set) If in the
- * set, we decrement 'count'; if 0, there is potentially more to output.
+ * of a range in its set or not. (i_a and i_b point to the element beyond
+ * the one we care about.) If in the set, we decrement 'count'; if 0, there
+ * is potentially more to output.
* There are four cases:
* 1) Both weren't in their sets, count is 0, and remains 0. What's left
* in the union is entirely from the non-exhausted set.
@@ -6127,12 +7694,12 @@
* that
* 3) the exhausted was in its set, non-exhausted isn't, count is 1.
* Nothing further should be output because the union includes
- * everything from the exhausted set. Not decrementing insures that.
+ * everything from the exhausted set. Not decrementing ensures that.
* 4) the exhausted wasn't in its set, non-exhausted is, count is 1;
* decrementing to 0 insures that we look at the remainder of the
* non-exhausted set */
- if ((i_a != len_a && ! ELEMENT_IN_INVLIST_SET(i_a))
- || (i_b != len_b && ! ELEMENT_IN_INVLIST_SET(i_b)))
+ if ((i_a != len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
+ || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
{
count--;
}
@@ -6149,7 +7716,7 @@
/* Set result to final length, which can change the pointer to array_u, so
* re-find it */
- if (len_u != invlist_len(u)) {
+ if (len_u != _invlist_len(u)) {
invlist_set_len(u, len_u);
invlist_trim(u);
array_u = invlist_array(u);
@@ -6171,27 +7738,45 @@
}
}
- return u;
+ /* If we've changed b, restore it */
+ if (complement_b) {
+ array_b[0] = 1;
+ }
+
+ /* We may be removing a reference to one of the inputs */
+ if (a == *output || b == *output) {
+ assert(! invlist_is_iterating(*output));
+ SvREFCNT_dec_NN(*output);
+ }
+
+ *output = u;
+ return;
}
-STATIC HV*
-S_invlist_intersection(pTHX_ HV* const a, HV* const b)
+void
+Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, bool complement_b, SV** i)
{
- /* Return the intersection of two inversion lists. The basis for this
- * comes from "Unicode Demystified" Chapter 13 by Richard Gillam, published
- * by Addison-Wesley, and explained at some length there. The preface says
- * to incorporate its examples into your code at your own risk.
+ /* Take the intersection of two inversion lists and point <i> to it. *i
+ * SHOULD BE DEFINED upon input, and if it points to one of the two lists,
+ * the reference count to that list will be decremented.
+ * If <complement_b> is TRUE, the result will be the intersection of <a>
+ * and the complement (or inversion) of <b> instead of <b> directly.
*
+ * The basis for this comes from "Unicode Demystified" Chapter 13 by
+ * Richard Gillam, published by Addison-Wesley, and explained at some
+ * length there. The preface says to incorporate its examples into your
+ * code at your own risk. In fact, it had bugs
+ *
* The algorithm is like a merge sort, and is essentially the same as the
* union above
*/
- UV* array_a = invlist_array(a); /* a's array */
- UV* array_b = invlist_array(b);
- UV len_a = invlist_len(a); /* length of a's array */
- UV len_b = invlist_len(b);
+ UV* array_a; /* a's array */
+ UV* array_b;
+ UV len_a; /* length of a's array */
+ UV len_b;
- HV* r; /* the resulting intersection */
+ SV* r; /* the resulting intersection */
UV* array_r;
UV len_r;
@@ -6207,13 +7792,79 @@
*/
UV count = 0;
- PERL_ARGS_ASSERT_INVLIST_INTERSECTION;
+ PERL_ARGS_ASSERT__INVLIST_INTERSECTION_MAYBE_COMPLEMENT_2ND;
+ assert(a != b);
+ /* Special case if either one is empty */
+ len_a = _invlist_len(a);
+ if ((len_a == 0) || ((len_b = _invlist_len(b)) == 0)) {
+
+ if (len_a != 0 && complement_b) {
+
+ /* Here, 'a' is not empty, therefore from the above 'if', 'b' must
+ * be empty. Here, also we are using 'b's complement, which hence
+ * must be every possible code point. Thus the intersection is
+ * simply 'a'. */
+ if (*i != a) {
+ *i = invlist_clone(a);
+
+ if (*i == b) {
+ SvREFCNT_dec_NN(b);
+ }
+ }
+ /* else *i is already 'a' */
+ return;
+ }
+
+ /* Here, 'a' or 'b' is empty and not using the complement of 'b'. The
+ * intersection must be empty */
+ if (*i == a) {
+ SvREFCNT_dec_NN(a);
+ }
+ else if (*i == b) {
+ SvREFCNT_dec_NN(b);
+ }
+ *i = _new_invlist(0);
+ return;
+ }
+
+ /* Here both lists exist and are non-empty */
+ array_a = invlist_array(a);
+ array_b = invlist_array(b);
+
+ /* If are to take the intersection of 'a' with the complement of b, set it
+ * up so are looking at b's complement. */
+ if (complement_b) {
+
+ /* To complement, we invert: if the first element is 0, remove it. To
+ * do this, we just pretend the array starts one later, and clear the
+ * flag as we don't have to do anything else later */
+ if (array_b[0] == 0) {
+ array_b++;
+ len_b--;
+ complement_b = FALSE;
+ }
+ else {
+
+ /* But if the first element is not zero, we unshift a 0 before the
+ * array. The data structure reserves a space for that 0 (which
+ * should be a '1' right now), so physical shifting is unneeded,
+ * but temporarily change that element to 0. Before exiting the
+ * routine, we must restore the element to '1' */
+ array_b--;
+ len_b++;
+ array_b[0] = 0;
+ }
+ }
+
/* Size the intersection for the worst case: that the intersection ends up
* fragmenting everything to be completely disjoint */
r= _new_invlist(len_a + len_b);
- array_r = invlist_array(r);
+ /* Will contain U+0000 iff both components do */
+ array_r = _invlist_array_init(r, len_a > 0 && array_a[0] == 0
+ && len_b > 0 && array_b[0] == 0);
+
/* Go through each list item by item, stopping when exhausted one of
* them */
while (i_a < len_a && i_b < len_b) {
@@ -6221,25 +7872,26 @@
array */
bool cp_in_set; /* Is it in the input list's set or not */
- /* We need to take one or the other of the two inputs for the union.
- * Since we are merging two sorted lists, we take the smaller of the
- * next items. In case of a tie, we take the one that is not in its
- * set first (a difference from the union algorithm). If we took one
- * in the set first, it would increment the count, possibly to 2 which
- * would cause it to be output as starting a range in the intersection,
- * and the next time through we would take that same number, and output
- * it again as ending the set. By doing it the opposite of this, we
- * there is no possibility that the count will be momentarily
- * incremented to 2. (In a tie and both are in the set or both not in
- * the set, it doesn't matter which we take first.) */
+ /* We need to take one or the other of the two inputs for the
+ * intersection. Since we are merging two sorted lists, we take the
+ * smaller of the next items. In case of a tie, we take the one that
+ * is not in its set first (a difference from the union algorithm). If
+ * we took one in the set first, it would increment the count, possibly
+ * to 2 which would cause it to be output as starting a range in the
+ * intersection, and the next time through we would take that same
+ * number, and output it again as ending the set. By doing it the
+ * opposite of this, there is no possibility that the count will be
+ * momentarily incremented to 2. (In a tie and both are in the set or
+ * both not in the set, it doesn't matter which we take first.) */
if (array_a[i_a] < array_b[i_b]
- || (array_a[i_a] == array_b[i_b] && ! ELEMENT_IN_INVLIST_SET(i_a)))
+ || (array_a[i_a] == array_b[i_b]
+ && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
{
- cp_in_set = ELEMENT_IN_INVLIST_SET(i_a);
+ cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
cp= array_a[i_a++];
}
else {
- cp_in_set = ELEMENT_IN_INVLIST_SET(i_b);
+ cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
cp= array_b[i_b++];
}
@@ -6260,25 +7912,38 @@
}
}
- /* Here, we are finished going through at least one of the sets, which
- * means there is something remaining in at most one. See the comments in
- * the union code */
- if ((i_a != len_a && ! ELEMENT_IN_INVLIST_SET(i_a))
- || (i_b != len_b && ! ELEMENT_IN_INVLIST_SET(i_b)))
+ /* Here, we are finished going through at least one of the lists, which
+ * means there is something remaining in at most one. We check if the list
+ * that has been exhausted is positioned such that we are in the middle
+ * of a range in its set or not. (i_a and i_b point to elements 1 beyond
+ * the ones we care about.) There are four cases:
+ * 1) Both weren't in their sets, count is 0, and remains 0. There's
+ * nothing left in the intersection.
+ * 2) Both were in their sets, count is 2 and perhaps is incremented to
+ * above 2. What should be output is exactly that which is in the
+ * non-exhausted set, as everything it has is also in the intersection
+ * set, and everything it doesn't have can't be in the intersection
+ * 3) The exhausted was in its set, non-exhausted isn't, count is 1, and
+ * gets incremented to 2. Like the previous case, the intersection is
+ * everything that remains in the non-exhausted set.
+ * 4) the exhausted wasn't in its set, non-exhausted is, count is 1, and
+ * remains 1. And the intersection has nothing more. */
+ if ((i_a == len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
+ || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
{
- count--;
+ count++;
}
/* The final length is what we've output so far plus what else is in the
- * intersection. Only one of the subexpressions below will be non-zero */
+ * intersection. At most one of the subexpressions below will be non-zero */
len_r = i_r;
- if (count == 2) {
+ if (count >= 2) {
len_r += (len_a - i_a) + (len_b - i_b);
}
/* Set result to final length, which can change the pointer to array_r, so
* re-find it */
- if (len_r != invlist_len(r)) {
+ if (len_r != _invlist_len(r)) {
invlist_set_len(r, len_r);
invlist_trim(r);
array_r = invlist_array(r);
@@ -6285,7 +7950,7 @@
}
/* Finish outputting any remaining */
- if (count == 2) { /* Only one of will have a non-zero copy count */
+ if (count >= 2) { /* At most one will have a non-zero copy count */
IV copy_count;
if ((copy_count = len_a - i_a) > 0) {
Copy(array_a + i_a, array_r + i_r, copy_count, UV);
@@ -6295,11 +7960,23 @@
}
}
- return r;
+ /* If we've changed b, restore it */
+ if (complement_b) {
+ array_b[0] = 1;
+ }
+
+ /* We may be removing a reference to one of the inputs */
+ if (a == *i || b == *i) {
+ assert(! invlist_is_iterating(*i));
+ SvREFCNT_dec_NN(*i);
+ }
+
+ *i = r;
+ return;
}
-STATIC HV*
-S_add_range_to_invlist(pTHX_ HV* invlist, const UV start, const UV end)
+SV*
+Perl__add_range_to_invlist(pTHX_ SV* invlist, const UV start, const UV end)
{
/* 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
@@ -6307,8 +7984,7 @@
* passed in inversion list can be NULL, in which case a new one is created
* with just the one range in it */
- HV* range_invlist;
- HV* added_invlist;
+ SV* range_invlist;
UV len;
if (invlist == NULL) {
@@ -6316,13 +7992,14 @@
len = 0;
}
else {
- len = invlist_len(invlist);
+ len = _invlist_len(invlist);
}
- /* If comes after the final entry, can just append it to the end */
+ /* If comes after the final entry actually in the list, can just append it
+ * to the end, */
if (len == 0
- || start >= invlist_array(invlist)
- [invlist_len(invlist) - 1])
+ || (! ELEMENT_RANGE_MATCHES_INVLIST(len - 1)
+ && start >= invlist_array(invlist)[len - 1]))
{
_append_range_to_invlist(invlist, start, end);
return invlist;
@@ -6333,24 +8010,573 @@
range_invlist = _new_invlist(2);
_append_range_to_invlist(range_invlist, start, end);
- added_invlist = invlist_union(invlist, range_invlist);
+ _invlist_union(invlist, range_invlist, &invlist);
- /* The passed in list can be freed, as well as our temporary */
- invlist_destroy(range_invlist);
- if (invlist != added_invlist) {
- invlist_destroy(invlist);
+ /* The temporary can be freed */
+ SvREFCNT_dec_NN(range_invlist);
+
+ return invlist;
+}
+
+#endif
+
+PERL_STATIC_INLINE SV*
+S_add_cp_to_invlist(pTHX_ SV* invlist, const UV cp) {
+ return _add_range_to_invlist(invlist, cp, cp);
+}
+
+#ifndef PERL_IN_XSUB_RE
+void
+Perl__invlist_invert(pTHX_ SV* const invlist)
+{
+ /* Complement the input inversion list. This adds a 0 if the list didn't
+ * have a zero; removes it otherwise. As described above, the data
+ * structure is set up so that this is very efficient */
+
+ UV* len_pos = _get_invlist_len_addr(invlist);
+
+ PERL_ARGS_ASSERT__INVLIST_INVERT;
+
+ assert(! invlist_is_iterating(invlist));
+
+ /* The inverse of matching nothing is matching everything */
+ if (*len_pos == 0) {
+ _append_range_to_invlist(invlist, 0, UV_MAX);
+ return;
}
- return added_invlist;
+ /* The exclusive or complents 0 to 1; and 1 to 0. If the result is 1, the
+ * zero element was a 0, so it is being removed, so the length decrements
+ * by 1; and vice-versa. SvCUR is unaffected */
+ if (*get_invlist_zero_addr(invlist) ^= 1) {
+ (*len_pos)--;
+ }
+ else {
+ (*len_pos)++;
+ }
}
-PERL_STATIC_INLINE HV*
-S_add_cp_to_invlist(pTHX_ HV* invlist, const UV cp) {
- return add_range_to_invlist(invlist, cp, cp);
+void
+Perl__invlist_invert_prop(pTHX_ SV* const invlist)
+{
+ /* Complement the input inversion list (which must be a Unicode property,
+ * all of which don't match above the Unicode maximum code point.) And
+ * Perl has chosen to not have the inversion match above that either. This
+ * adds a 0x110000 if the list didn't end with it, and removes it if it did
+ */
+
+ UV len;
+ UV* array;
+
+ PERL_ARGS_ASSERT__INVLIST_INVERT_PROP;
+
+ _invlist_invert(invlist);
+
+ len = _invlist_len(invlist);
+
+ if (len != 0) { /* If empty do nothing */
+ array = invlist_array(invlist);
+ if (array[len - 1] != PERL_UNICODE_MAX + 1) {
+ /* Add 0x110000. First, grow if necessary */
+ len++;
+ if (invlist_max(invlist) < len) {
+ invlist_extend(invlist, len);
+ array = invlist_array(invlist);
+ }
+ invlist_set_len(invlist, len);
+ array[len - 1] = PERL_UNICODE_MAX + 1;
+ }
+ else { /* Remove the 0x110000 */
+ invlist_set_len(invlist, len - 1);
+ }
+ }
+
+ return;
}
+#endif
+PERL_STATIC_INLINE SV*
+S_invlist_clone(pTHX_ SV* const invlist)
+{
+
+ /* Return a new inversion list that is a copy of the input one, which is
+ * unchanged */
+
+ /* Need to allocate extra space to accommodate Perl's addition of a
+ * trailing NUL to SvPV's, since it thinks they are always strings */
+ SV* new_invlist = _new_invlist(_invlist_len(invlist) + 1);
+ STRLEN length = SvCUR(invlist);
+
+ PERL_ARGS_ASSERT_INVLIST_CLONE;
+
+ SvCUR_set(new_invlist, length); /* This isn't done automatically */
+ Copy(SvPVX(invlist), SvPVX(new_invlist), length, char);
+
+ return new_invlist;
+}
+
+PERL_STATIC_INLINE UV*
+S_get_invlist_iter_addr(pTHX_ SV* invlist)
+{
+ /* Return the address of the UV that contains the current iteration
+ * position */
+
+ PERL_ARGS_ASSERT_GET_INVLIST_ITER_ADDR;
+
+ return (UV *) (SvPVX(invlist) + (INVLIST_ITER_OFFSET * sizeof (UV)));
+}
+
+PERL_STATIC_INLINE UV*
+S_get_invlist_version_id_addr(pTHX_ SV* invlist)
+{
+ /* Return the address of the UV that contains the version id. */
+
+ PERL_ARGS_ASSERT_GET_INVLIST_VERSION_ID_ADDR;
+
+ return (UV *) (SvPVX(invlist) + (INVLIST_VERSION_ID_OFFSET * sizeof (UV)));
+}
+
+PERL_STATIC_INLINE void
+S_invlist_iterinit(pTHX_ SV* invlist) /* Initialize iterator for invlist */
+{
+ PERL_ARGS_ASSERT_INVLIST_ITERINIT;
+
+ *get_invlist_iter_addr(invlist) = 0;
+}
+
+PERL_STATIC_INLINE void
+S_invlist_iterfinish(pTHX_ SV* invlist)
+{
+ /* Terminate iterator for invlist. This is to catch development errors.
+ * Any iteration that is interrupted before completed should call this
+ * function. Functions that add code points anywhere else but to the end
+ * of an inversion list assert that they are not in the middle of an
+ * iteration. If they were, the addition would make the iteration
+ * problematical: if the iteration hadn't reached the place where things
+ * were being added, it would be ok */
+
+ PERL_ARGS_ASSERT_INVLIST_ITERFINISH;
+
+ *get_invlist_iter_addr(invlist) = UV_MAX;
+}
+
+STATIC bool
+S_invlist_iternext(pTHX_ SV* invlist, UV* start, UV* end)
+{
+ /* An C<invlist_iterinit> call on <invlist> must be used to set this up.
+ * This call sets in <*start> and <*end>, the next range in <invlist>.
+ * Returns <TRUE> if successful and the next call will return the next
+ * range; <FALSE> if was already at the end of the list. If the latter,
+ * <*start> and <*end> are unchanged, and the next call to this function
+ * will start over at the beginning of the list */
+
+ UV* pos = get_invlist_iter_addr(invlist);
+ UV len = _invlist_len(invlist);
+ UV *array;
+
+ PERL_ARGS_ASSERT_INVLIST_ITERNEXT;
+
+ if (*pos >= len) {
+ *pos = UV_MAX; /* Force iterinit() to be required next time */
+ return FALSE;
+ }
+
+ array = invlist_array(invlist);
+
+ *start = array[(*pos)++];
+
+ if (*pos >= len) {
+ *end = UV_MAX;
+ }
+ else {
+ *end = array[(*pos)++] - 1;
+ }
+
+ return TRUE;
+}
+
+PERL_STATIC_INLINE bool
+S_invlist_is_iterating(pTHX_ SV* const invlist)
+{
+ PERL_ARGS_ASSERT_INVLIST_IS_ITERATING;
+
+ return *(get_invlist_iter_addr(invlist)) < UV_MAX;
+}
+
+PERL_STATIC_INLINE UV
+S_invlist_highest(pTHX_ SV* const invlist)
+{
+ /* Returns the highest code point that matches an inversion list. This API
+ * has an ambiguity, as it returns 0 under either the highest is actually
+ * 0, or if the list is empty. If this distinction matters to you, check
+ * for emptiness before calling this function */
+
+ UV len = _invlist_len(invlist);
+ UV *array;
+
+ PERL_ARGS_ASSERT_INVLIST_HIGHEST;
+
+ if (len == 0) {
+ return 0;
+ }
+
+ array = invlist_array(invlist);
+
+ /* The last element in the array in the inversion list always starts a
+ * range that goes to infinity. That range may be for code points that are
+ * matched in the inversion list, or it may be for ones that aren't
+ * matched. In the latter case, the highest code point in the set is one
+ * less than the beginning of this range; otherwise it is the final element
+ * of this range: infinity */
+ return (ELEMENT_RANGE_MATCHES_INVLIST(len - 1))
+ ? UV_MAX
+ : array[len - 1] - 1;
+}
+
+#ifndef PERL_IN_XSUB_RE
+SV *
+Perl__invlist_contents(pTHX_ SV* const invlist)
+{
+ /* Get the contents of an inversion list into a string SV so that they can
+ * be printed out. It uses the format traditionally done for debug tracing
+ */
+
+ UV start, end;
+ SV* output = newSVpvs("\n");
+
+ PERL_ARGS_ASSERT__INVLIST_CONTENTS;
+
+ assert(! invlist_is_iterating(invlist));
+
+ invlist_iterinit(invlist);
+ while (invlist_iternext(invlist, &start, &end)) {
+ if (end == UV_MAX) {
+ Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\tINFINITY\n", start);
+ }
+ else if (end != start) {
+ Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\t%04"UVXf"\n",
+ start, end);
+ }
+ else {
+ Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\n", start);
+ }
+ }
+
+ return output;
+}
+#endif
+
+#ifdef PERL_ARGS_ASSERT__INVLIST_DUMP
+void
+Perl__invlist_dump(pTHX_ SV* const invlist, const char * const header)
+{
+ /* Dumps out the ranges in an inversion list. The string 'header'
+ * if present is output on a line before the first range */
+
+ UV start, end;
+
+ PERL_ARGS_ASSERT__INVLIST_DUMP;
+
+ if (header && strlen(header)) {
+ PerlIO_printf(Perl_debug_log, "%s\n", header);
+ }
+ if (invlist_is_iterating(invlist)) {
+ PerlIO_printf(Perl_debug_log, "Can't dump because is in middle of iterating\n");
+ return;
+ }
+
+ invlist_iterinit(invlist);
+ while (invlist_iternext(invlist, &start, &end)) {
+ if (end == UV_MAX) {
+ PerlIO_printf(Perl_debug_log, "0x%04"UVXf" .. INFINITY\n", start);
+ }
+ else if (end != start) {
+ PerlIO_printf(Perl_debug_log, "0x%04"UVXf" .. 0x%04"UVXf"\n",
+ start, end);
+ }
+ else {
+ PerlIO_printf(Perl_debug_log, "0x%04"UVXf"\n", start);
+ }
+ }
+}
+#endif
+
+#if 0
+bool
+S__invlistEQ(pTHX_ SV* const a, SV* const b, bool complement_b)
+{
+ /* Return a boolean as to if the two passed in inversion lists are
+ * identical. The final argument, if TRUE, says to take the complement of
+ * the second inversion list before doing the comparison */
+
+ UV* array_a = invlist_array(a);
+ UV* array_b = invlist_array(b);
+ UV len_a = _invlist_len(a);
+ UV len_b = _invlist_len(b);
+
+ UV i = 0; /* current index into the arrays */
+ bool retval = TRUE; /* Assume are identical until proven otherwise */
+
+ PERL_ARGS_ASSERT__INVLISTEQ;
+
+ /* If are to compare 'a' with the complement of b, set it
+ * up so are looking at b's complement. */
+ if (complement_b) {
+
+ /* The complement of nothing is everything, so <a> would have to have
+ * just one element, starting at zero (ending at infinity) */
+ if (len_b == 0) {
+ return (len_a == 1 && array_a[0] == 0);
+ }
+ else if (array_b[0] == 0) {
+
+ /* Otherwise, to complement, we invert. Here, the first element is
+ * 0, just remove it. To do this, we just pretend the array starts
+ * one later, and clear the flag as we don't have to do anything
+ * else later */
+
+ array_b++;
+ len_b--;
+ complement_b = FALSE;
+ }
+ else {
+
+ /* But if the first element is not zero, we unshift a 0 before the
+ * array. The data structure reserves a space for that 0 (which
+ * should be a '1' right now), so physical shifting is unneeded,
+ * but temporarily change that element to 0. Before exiting the
+ * routine, we must restore the element to '1' */
+ array_b--;
+ len_b++;
+ array_b[0] = 0;
+ }
+ }
+
+ /* Make sure that the lengths are the same, as well as the final element
+ * before looping through the remainder. (Thus we test the length, final,
+ * and first elements right off the bat) */
+ if (len_a != len_b || array_a[len_a-1] != array_b[len_a-1]) {
+ retval = FALSE;
+ }
+ else for (i = 0; i < len_a - 1; i++) {
+ if (array_a[i] != array_b[i]) {
+ retval = FALSE;
+ break;
+ }
+ }
+
+ if (complement_b) {
+ array_b[0] = 1;
+ }
+ return retval;
+}
+#endif
+
+#undef HEADER_LENGTH
+#undef INVLIST_INITIAL_LENGTH
+#undef TO_INTERNAL_SIZE
+#undef FROM_INTERNAL_SIZE
+#undef INVLIST_LEN_OFFSET
+#undef INVLIST_ZERO_OFFSET
+#undef INVLIST_ITER_OFFSET
+#undef INVLIST_VERSION_ID
+#undef INVLIST_PREVIOUS_INDEX_OFFSET
+
/* End of inversion list object */
+STATIC void
+S_parse_lparen_question_flags(pTHX_ struct RExC_state_t *pRExC_state)
+{
+ /* This parses the flags that are in either the '(?foo)' or '(?foo:bar)'
+ * constructs, and updates RExC_flags with them. On input, RExC_parse
+ * should point to the first flag; it is updated on output to point to the
+ * final ')' or ':'. There needs to be at least one flag, or this will
+ * abort */
+
+ /* for (?g), (?gc), and (?o) warnings; warning
+ about (?c) will warn about (?g) -- japhy */
+
+#define WASTED_O 0x01
+#define WASTED_G 0x02
+#define WASTED_C 0x04
+#define WASTED_GC (0x02|0x04)
+ I32 wastedflags = 0x00;
+ U32 posflags = 0, negflags = 0;
+ U32 *flagsp = &posflags;
+ char has_charset_modifier = '\0';
+ regex_charset cs;
+ bool has_use_defaults = FALSE;
+ const char* const seqstart = RExC_parse - 1; /* Point to the '?' */
+
+ PERL_ARGS_ASSERT_PARSE_LPAREN_QUESTION_FLAGS;
+
+ /* '^' as an initial flag sets certain defaults */
+ if (UCHARAT(RExC_parse) == '^') {
+ RExC_parse++;
+ has_use_defaults = TRUE;
+ STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
+ set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics)
+ ? REGEX_UNICODE_CHARSET
+ : REGEX_DEPENDS_CHARSET);
+ }
+
+ cs = get_regex_charset(RExC_flags);
+ if (cs == REGEX_DEPENDS_CHARSET
+ && (RExC_utf8 || RExC_uni_semantics))
+ {
+ cs = REGEX_UNICODE_CHARSET;
+ }
+
+ while (*RExC_parse) {
+ /* && strchr("iogcmsx", *RExC_parse) */
+ /* (?g), (?gc) and (?o) are useless here
+ and must be globally applied -- japhy */
+ switch (*RExC_parse) {
+
+ /* Code for the imsx flags */
+ CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp);
+
+ case LOCALE_PAT_MOD:
+ if (has_charset_modifier) {
+ goto excess_modifier;
+ }
+ else if (flagsp == &negflags) {
+ goto neg_modifier;
+ }
+ cs = REGEX_LOCALE_CHARSET;
+ has_charset_modifier = LOCALE_PAT_MOD;
+ RExC_contains_locale = 1;
+ break;
+ case UNICODE_PAT_MOD:
+ if (has_charset_modifier) {
+ goto excess_modifier;
+ }
+ else if (flagsp == &negflags) {
+ goto neg_modifier;
+ }
+ cs = REGEX_UNICODE_CHARSET;
+ has_charset_modifier = UNICODE_PAT_MOD;
+ break;
+ case ASCII_RESTRICT_PAT_MOD:
+ if (flagsp == &negflags) {
+ goto neg_modifier;
+ }
+ if (has_charset_modifier) {
+ if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
+ goto excess_modifier;
+ }
+ /* Doubled modifier implies more restricted */
+ cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
+ }
+ else {
+ cs = REGEX_ASCII_RESTRICTED_CHARSET;
+ }
+ has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
+ break;
+ case DEPENDS_PAT_MOD:
+ if (has_use_defaults) {
+ goto fail_modifiers;
+ }
+ else if (flagsp == &negflags) {
+ goto neg_modifier;
+ }
+ else if (has_charset_modifier) {
+ goto excess_modifier;
+ }
+
+ /* The dual charset means unicode semantics if the
+ * pattern (or target, not known until runtime) are
+ * utf8, or something in the pattern indicates unicode
+ * semantics */
+ cs = (RExC_utf8 || RExC_uni_semantics)
+ ? REGEX_UNICODE_CHARSET
+ : REGEX_DEPENDS_CHARSET;
+ has_charset_modifier = DEPENDS_PAT_MOD;
+ break;
+ excess_modifier:
+ RExC_parse++;
+ if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
+ vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
+ }
+ else if (has_charset_modifier == *(RExC_parse - 1)) {
+ vFAIL2("Regexp modifier \"%c\" may not appear twice", *(RExC_parse - 1));
+ }
+ else {
+ vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
+ }
+ /*NOTREACHED*/
+ neg_modifier:
+ RExC_parse++;
+ vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"", *(RExC_parse - 1));
+ /*NOTREACHED*/
+ case ONCE_PAT_MOD: /* 'o' */
+ case GLOBAL_PAT_MOD: /* 'g' */
+ if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
+ const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G;
+ if (! (wastedflags & wflagbit) ) {
+ wastedflags |= wflagbit;
+ vWARN5(
+ RExC_parse + 1,
+ "Useless (%s%c) - %suse /%c modifier",
+ flagsp == &negflags ? "?-" : "?",
+ *RExC_parse,
+ flagsp == &negflags ? "don't " : "",
+ *RExC_parse
+ );
+ }
+ }
+ break;
+
+ case CONTINUE_PAT_MOD: /* 'c' */
+ if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
+ if (! (wastedflags & WASTED_C) ) {
+ wastedflags |= WASTED_GC;
+ vWARN3(
+ RExC_parse + 1,
+ "Useless (%sc) - %suse /gc modifier",
+ flagsp == &negflags ? "?-" : "?",
+ flagsp == &negflags ? "don't " : ""
+ );
+ }
+ }
+ break;
+ case KEEPCOPY_PAT_MOD: /* 'p' */
+ if (flagsp == &negflags) {
+ if (SIZE_ONLY)
+ ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
+ } else {
+ *flagsp |= RXf_PMf_KEEPCOPY;
+ }
+ break;
+ case '-':
+ /* A flag is a default iff it is following a minus, so
+ * if there is a minus, it means will be trying to
+ * re-specify a default which is an error */
+ if (has_use_defaults || flagsp == &negflags) {
+ goto fail_modifiers;
+ }
+ flagsp = &negflags;
+ wastedflags = 0; /* reset so (?g-c) warns twice */
+ break;
+ case ':':
+ case ')':
+ RExC_flags |= posflags;
+ RExC_flags &= ~negflags;
+ set_regex_charset(&RExC_flags, cs);
+ return;
+ /*NOTREACHED*/
+ default:
+ fail_modifiers:
+ RExC_parse++;
+ vFAIL3("Sequence (%.*s...) not recognized",
+ RExC_parse-seqstart, seqstart);
+ /*NOTREACHED*/
+ }
+
+ ++RExC_parse;
+ }
+}
+
/*
- reg - regular expression, i.e. main body or parenthesized thing
*
@@ -6367,16 +8593,24 @@
#define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
#endif
+/* Returns NULL, setting *flagp to TRYAGAIN at the end of (?) that only sets
+ flags. Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan
+ needs to be restarted.
+ Otherwise would only return NULL if regbranch() returns NULL, which
+ cannot happen. */
STATIC regnode *
S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
- /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
+ /* paren: Parenthesized? 0=top; 1,2=inside '(': changed to letter.
+ * 2 is like 1, but indicates that nextchar() has been called to advance
+ * RExC_parse beyond the '('. Things like '(?' are indivisible tokens, and
+ * this flag alerts us to the need to check for that */
{
dVAR;
- register regnode *ret; /* Will be the head of the group. */
- register regnode *br;
- register regnode *lastbr;
- register regnode *ender = NULL;
- register I32 parno = 0;
+ regnode *ret; /* Will be the head of the group. */
+ regnode *br;
+ regnode *lastbr;
+ regnode *ender = NULL;
+ I32 parno = 0;
I32 flags;
U32 oregflags = RExC_flags;
bool have_branch = 0;
@@ -6384,15 +8618,6 @@
I32 freeze_paren = 0;
I32 after_freeze = 0;
- /* for (?g), (?gc), and (?o) warnings; warning
- about (?c) will warn about (?g) -- japhy */
-
-#define WASTED_O 0x01
-#define WASTED_G 0x02
-#define WASTED_C 0x04
-#define WASTED_GC (0x02|0x04)
- I32 wastedflags = 0x00;
-
char * parse_start = RExC_parse; /* MJD */
char * const oregcomp_parse = RExC_parse;
@@ -6406,6 +8631,13 @@
/* Make an OPEN node, if parenthesized. */
if (paren) {
+
+ /* Under /x, space and comments can be gobbled up between the '(' and
+ * here (if paren ==2). The forms '(*VERB' and '(?...' disallow such
+ * intervening space, as the sequence is a token, and a token should be
+ * indivisible */
+ bool has_intervening_patws = paren == 2 && *(RExC_parse - 1) != '(';
+
if ( *RExC_parse == '*') { /* (*VERB:ARG) */
char *start_verb = RExC_parse;
STRLEN verb_len = 0;
@@ -6413,6 +8645,10 @@
unsigned char op = 0;
int argok = 1;
int internal_argval = 0; /* internal_argval is only useful if !argok */
+
+ if (has_intervening_patws && SIZE_ONLY) {
+ ckWARNregdep(RExC_parse + 1, "In '(*VERB...)', splitting the initial '(*' is deprecated");
+ }
while ( *RExC_parse && *RExC_parse != ')' ) {
if ( *RExC_parse == ':' ) {
start_arg = RExC_parse + 1;
@@ -6514,7 +8750,9 @@
if (*RExC_parse == '?') { /* (?...) */
bool is_logical = 0;
const char * const seqstart = RExC_parse;
- bool has_use_defaults = FALSE;
+ if (has_intervening_patws && SIZE_ONLY) {
+ ckWARNregdep(RExC_parse + 1, "In '(?...)', splitting the initial '(?' is deprecated");
+ }
RExC_parse++;
paren = *RExC_parse++;
@@ -6547,7 +8785,7 @@
ret = reganode(pRExC_state,
((! FOLD)
? NREF
- : (MORE_ASCII_RESTRICTED)
+ : (ASCII_FOLD_RESTRICTED)
? NREFFA
: (AT_LEAST_UNI_SEMANTICS)
? NREFFU
@@ -6638,8 +8876,9 @@
SvIV_set(sv_dat, 1);
}
#ifdef DEBUGGING
+ /* Yes this does cause a memory leak in debugging Perls */
if (!av_store(RExC_paren_name_list, RExC_npar, SvREFCNT_inc(svname)))
- SvREFCNT_dec(svname);
+ SvREFCNT_dec_NN(svname);
#endif
/*sv_dump(sv_dat);*/
@@ -6675,8 +8914,12 @@
case '@': /* (?@...) */
vFAIL2("Sequence (?%c...) not implemented", (int)paren);
break;
- case '#': /* (?#...) */
- while (*RExC_parse && *RExC_parse != ')')
+ case '#': /* (?#...) */
+ /* XXX As soon as we disallow separating the '?' and '*' (by
+ * spaces or (?#...) comment), it is believed that this case
+ * will be unreachable and can be removed. See
+ * [perl #117327] */
+ while (*RExC_parse && *RExC_parse != ')')
RExC_parse++;
if (*RExC_parse != ')')
FAIL("Sequence (?#... not terminated");
@@ -6703,7 +8946,7 @@
num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
}
goto gen_recurse_regop;
- /* NOT REACHED */
+ assert(0); /* NOT REACHED */
case '+':
if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
RExC_parse++;
@@ -6729,7 +8972,7 @@
RExC_parse++;
if (*RExC_parse!=')')
vFAIL("Expecting close bracket");
-
+
gen_recurse_regop:
if ( paren == '-' ) {
/*
@@ -6773,7 +9016,7 @@
nextchar(pRExC_state);
return ret;
} /* named and numeric backreferences */
- /* NOT REACHED */
+ assert(0); /* NOT REACHED */
case '?': /* (??...) */
is_logical = 1;
@@ -6787,67 +9030,51 @@
/* FALL THROUGH */
case '{': /* (?{...}) */
{
- I32 count = 1;
U32 n = 0;
- char c;
- char *s = RExC_parse;
+ struct reg_code_block *cb;
RExC_seen_zerolen++;
- RExC_seen |= REG_SEEN_EVAL;
- while (count && (c = *RExC_parse)) {
- if (c == '\\') {
- if (RExC_parse[1])
- RExC_parse++;
- }
- else if (c == '{')
- count++;
- else if (c == '}')
- count--;
- RExC_parse++;
+
+ if ( !pRExC_state->num_code_blocks
+ || pRExC_state->code_index >= pRExC_state->num_code_blocks
+ || pRExC_state->code_blocks[pRExC_state->code_index].start
+ != (STRLEN)((RExC_parse -3 - (is_logical ? 1 : 0))
+ - RExC_start)
+ ) {
+ if (RExC_pm_flags & PMf_USE_RE_EVAL)
+ FAIL("panic: Sequence (?{...}): no code block found\n");
+ FAIL("Eval-group not allowed at runtime, use re 'eval'");
}
- if (*RExC_parse != ')') {
- RExC_parse = s;
- vFAIL("Sequence (?{...}) not terminated or not {}-balanced");
- }
+ /* this is a pre-compiled code block (?{...}) */
+ cb = &pRExC_state->code_blocks[pRExC_state->code_index];
+ RExC_parse = RExC_start + cb->end;
if (!SIZE_ONLY) {
- PAD *pad;
- OP_4tree *sop, *rop;
- SV * const sv = newSVpvn(s, RExC_parse - 1 - s);
-
- ENTER;
- Perl_save_re_context(aTHX);
- rop = Perl_sv_compile_2op_is_broken(aTHX_ sv, &sop, "re", &pad);
- sop->op_private |= OPpREFCOUNTED;
- /* re_dup will OpREFCNT_inc */
- OpREFCNT_set(sop, 1);
- LEAVE;
-
- n = add_data(pRExC_state, 3, "nop");
- RExC_rxi->data->data[n] = (void*)rop;
- RExC_rxi->data->data[n+1] = (void*)sop;
- RExC_rxi->data->data[n+2] = (void*)pad;
- SvREFCNT_dec(sv);
+ OP *o = cb->block;
+ if (cb->src_regex) {
+ n = add_data(pRExC_state, 2, "rl");
+ RExC_rxi->data->data[n] =
+ (void*)SvREFCNT_inc((SV*)cb->src_regex);
+ RExC_rxi->data->data[n+1] = (void*)o;
+ }
+ else {
+ n = add_data(pRExC_state, 1,
+ (RExC_pm_flags & PMf_HAS_CV) ? "L" : "l");
+ RExC_rxi->data->data[n] = (void*)o;
+ }
}
- else { /* First pass */
- if (PL_reginterp_cnt < ++RExC_seen_evals
- && IN_PERL_RUNTIME)
- /* No compiled RE interpolated, has runtime
- components ===> unsafe. */
- FAIL("Eval-group not allowed at runtime, use re 'eval'");
- if (PL_tainting && PL_tainted)
- FAIL("Eval-group in insecure regular expression");
-#if PERL_VERSION > 8
- if (IN_PERL_COMPILETIME)
- PL_cv_has_eval = 1;
-#endif
- }
+ pRExC_state->code_index++;
+ nextchar(pRExC_state);
- nextchar(pRExC_state);
if (is_logical) {
+ regnode *eval;
ret = reg_node(pRExC_state, LOGICAL);
- if (!SIZE_ONLY)
+ eval = reganode(pRExC_state, EVAL, n);
+ if (!SIZE_ONLY) {
ret->flags = 2;
- REGTAIL(pRExC_state, ret, reganode(pRExC_state, EVAL, n));
+ /* for later propagation into (??{}) return value */
+ eval->flags = (U8) (RExC_flags & RXf_PMf_COMPILETIME);
+ }
+ REGTAIL(pRExC_state, ret, eval);
/* deal with the length of this later - MJD */
return ret;
}
@@ -6864,11 +9091,18 @@
|| RExC_parse[1] == '<'
|| RExC_parse[1] == '{') { /* Lookahead or eval. */
I32 flag;
-
+ regnode *tail;
+
ret = reg_node(pRExC_state, LOGICAL);
if (!SIZE_ONLY)
ret->flags = 1;
- REGTAIL(pRExC_state, ret, reg(pRExC_state, 1, &flag,depth+1));
+
+ tail = reg(pRExC_state, 1, &flag, depth+1);
+ if (flag & RESTART_UTF8) {
+ *flagp = RESTART_UTF8;
+ return NULL;
+ }
+ REGTAIL(pRExC_state, ret, tail);
goto insert_if;
}
}
@@ -6936,9 +9170,14 @@
insert_if:
REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
br = regbranch(pRExC_state, &flags, 1,depth+1);
- if (br == NULL)
- br = reganode(pRExC_state, LONGJMP, 0);
- else
+ if (br == NULL) {
+ if (flags & RESTART_UTF8) {
+ *flagp = RESTART_UTF8;
+ return NULL;
+ }
+ FAIL2("panic: regbranch returned NULL, flags=%#X",
+ flags);
+ } else
REGTAIL(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
c = *nextchar(pRExC_state);
if (flags&HASWIDTH)
@@ -6947,7 +9186,14 @@
if (is_define)
vFAIL("(?(DEFINE)....) does not allow branches");
lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
- regbranch(pRExC_state, &flags, 1,depth+1);
+ if (!regbranch(pRExC_state, &flags, 1,depth+1)) {
+ if (flags & RESTART_UTF8) {
+ *flagp = RESTART_UTF8;
+ return NULL;
+ }
+ FAIL2("panic: regbranch returned NULL, flags=%#X",
+ flags);
+ }
REGTAIL(pRExC_state, ret, lastbr);
if (flags&HASWIDTH)
*flagp |= HASWIDTH;
@@ -6974,189 +9220,27 @@
vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
}
}
+ case '[': /* (?[ ... ]) */
+ return handle_regex_sets(pRExC_state, NULL, flagp, depth,
+ oregcomp_parse);
case 0:
RExC_parse--; /* for vFAIL to print correctly */
vFAIL("Sequence (? incomplete");
break;
- case DEFAULT_PAT_MOD: /* Use default flags with the exceptions
- that follow */
- has_use_defaults = TRUE;
- STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
- set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics)
- ? REGEX_UNICODE_CHARSET
- : REGEX_DEPENDS_CHARSET);
- goto parse_flags;
- default:
+ default: /* e.g., (?i) */
--RExC_parse;
- parse_flags: /* (?i) */
- {
- U32 posflags = 0, negflags = 0;
- U32 *flagsp = &posflags;
- char has_charset_modifier = '\0';
- regex_charset cs = (RExC_utf8 || RExC_uni_semantics)
- ? REGEX_UNICODE_CHARSET
- : REGEX_DEPENDS_CHARSET;
-
- while (*RExC_parse) {
- /* && strchr("iogcmsx", *RExC_parse) */
- /* (?g), (?gc) and (?o) are useless here
- and must be globally applied -- japhy */
- switch (*RExC_parse) {
- CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp);
- case LOCALE_PAT_MOD:
- if (has_charset_modifier) {
- goto excess_modifier;
- }
- else if (flagsp == &negflags) {
- goto neg_modifier;
- }
- cs = REGEX_LOCALE_CHARSET;
- has_charset_modifier = LOCALE_PAT_MOD;
- RExC_contains_locale = 1;
- break;
- case UNICODE_PAT_MOD:
- if (has_charset_modifier) {
- goto excess_modifier;
- }
- else if (flagsp == &negflags) {
- goto neg_modifier;
- }
- cs = REGEX_UNICODE_CHARSET;
- has_charset_modifier = UNICODE_PAT_MOD;
- break;
- case ASCII_RESTRICT_PAT_MOD:
- if (flagsp == &negflags) {
- goto neg_modifier;
- }
- if (has_charset_modifier) {
- if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
- goto excess_modifier;
- }
- /* Doubled modifier implies more restricted */
- cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
- }
- else {
- cs = REGEX_ASCII_RESTRICTED_CHARSET;
- }
- has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
- break;
- case DEPENDS_PAT_MOD:
- if (has_use_defaults) {
- goto fail_modifiers;
- }
- else if (flagsp == &negflags) {
- goto neg_modifier;
- }
- else if (has_charset_modifier) {
- goto excess_modifier;
- }
-
- /* The dual charset means unicode semantics if the
- * pattern (or target, not known until runtime) are
- * utf8, or something in the pattern indicates unicode
- * semantics */
- cs = (RExC_utf8 || RExC_uni_semantics)
- ? REGEX_UNICODE_CHARSET
- : REGEX_DEPENDS_CHARSET;
- has_charset_modifier = DEPENDS_PAT_MOD;
- break;
- excess_modifier:
- RExC_parse++;
- if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
- vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
- }
- else if (has_charset_modifier == *(RExC_parse - 1)) {
- vFAIL2("Regexp modifier \"%c\" may not appear twice", *(RExC_parse - 1));
- }
- else {
- vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
- }
- /*NOTREACHED*/
- neg_modifier:
- RExC_parse++;
- vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"", *(RExC_parse - 1));
- /*NOTREACHED*/
- case ONCE_PAT_MOD: /* 'o' */
- case GLOBAL_PAT_MOD: /* 'g' */
- if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
- const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G;
- if (! (wastedflags & wflagbit) ) {
- wastedflags |= wflagbit;
- vWARN5(
- RExC_parse + 1,
- "Useless (%s%c) - %suse /%c modifier",
- flagsp == &negflags ? "?-" : "?",
- *RExC_parse,
- flagsp == &negflags ? "don't " : "",
- *RExC_parse
- );
- }
- }
- break;
-
- case CONTINUE_PAT_MOD: /* 'c' */
- if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
- if (! (wastedflags & WASTED_C) ) {
- wastedflags |= WASTED_GC;
- vWARN3(
- RExC_parse + 1,
- "Useless (%sc) - %suse /gc modifier",
- flagsp == &negflags ? "?-" : "?",
- flagsp == &negflags ? "don't " : ""
- );
- }
- }
- break;
- case KEEPCOPY_PAT_MOD: /* 'p' */
- if (flagsp == &negflags) {
- if (SIZE_ONLY)
- ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
- } else {
- *flagsp |= RXf_PMf_KEEPCOPY;
- }
- break;
- case '-':
- /* A flag is a default iff it is following a minus, so
- * if there is a minus, it means will be trying to
- * re-specify a default which is an error */
- if (has_use_defaults || flagsp == &negflags) {
- fail_modifiers:
- RExC_parse++;
- vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
- /*NOTREACHED*/
- }
- flagsp = &negflags;
- wastedflags = 0; /* reset so (?g-c) warns twice */
- break;
- case ':':
- paren = ':';
- /*FALLTHROUGH*/
- case ')':
- RExC_flags |= posflags;
- RExC_flags &= ~negflags;
- set_regex_charset(&RExC_flags, cs);
- if (paren != ':') {
- oregflags |= posflags;
- oregflags &= ~negflags;
- set_regex_charset(&oregflags, cs);
- }
- nextchar(pRExC_state);
- if (paren != ':') {
- *flagp = TRYAGAIN;
- return NULL;
- } else {
- ret = NULL;
- goto parse_rest;
- }
- /*NOTREACHED*/
- default:
- RExC_parse++;
- vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
- /*NOTREACHED*/
- }
- ++RExC_parse;
- }
- }} /* one for the default block, one for the switch */
+ parse_flags:
+ parse_lparen_question_flags(pRExC_state);
+ if (UCHARAT(RExC_parse) != ':') {
+ nextchar(pRExC_state);
+ *flagp = TRYAGAIN;
+ return NULL;
+ }
+ paren = ':';
+ nextchar(pRExC_state);
+ ret = NULL;
+ goto parse_rest;
+ } /* end switch */
}
else { /* (...) */
capturing_parens:
@@ -7191,8 +9275,13 @@
/* branch_len = (paren != 0); */
- if (br == NULL)
- return(NULL);
+ if (br == NULL) {
+ if (flags & RESTART_UTF8) {
+ *flagp = RESTART_UTF8;
+ return NULL;
+ }
+ FAIL2("panic: regbranch returned NULL, flags=%#X", flags);
+ }
if (*RExC_parse == '|') {
if (!SIZE_ONLY && RExC_extralen) {
reginsert(pRExC_state, BRANCHJ, br, depth+1);
@@ -7231,8 +9320,13 @@
}
br = regbranch(pRExC_state, &flags, 0, depth+1);
- if (br == NULL)
- return(NULL);
+ if (br == NULL) {
+ if (flags & RESTART_UTF8) {
+ *flagp = RESTART_UTF8;
+ return NULL;
+ }
+ FAIL2("panic: regbranch returned NULL, flags=%#X", flags);
+ }
REGTAIL(pRExC_state, lastbr, br); /* BRANCH -> BRANCH. */
lastbr = br;
*flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
@@ -7244,7 +9338,7 @@
case ':':
ender = reg_node(pRExC_state, TAIL);
break;
- case 1:
+ case 1: case 2:
ender = reganode(pRExC_state, CLOSE, parno);
if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) {
DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
@@ -7274,9 +9368,24 @@
}
break;
}
+ DEBUG_PARSE_r(if (!SIZE_ONLY) {
+ SV * const mysv_val1=sv_newmortal();
+ SV * const mysv_val2=sv_newmortal();
+ DEBUG_PARSE_MSG("lsbr");
+ regprop(RExC_rx, mysv_val1, lastbr);
+ regprop(RExC_rx, mysv_val2, ender);
+ PerlIO_printf(Perl_debug_log, "~ tying lastbr %s (%"IVdf") to ender %s (%"IVdf") offset %"IVdf"\n",
+ SvPV_nolen_const(mysv_val1),
+ (IV)REG_NODE_NUM(lastbr),
+ SvPV_nolen_const(mysv_val2),
+ (IV)REG_NODE_NUM(ender),
+ (IV)(ender - lastbr)
+ );
+ });
REGTAIL(pRExC_state, lastbr, ender);
if (have_branch && !SIZE_ONLY) {
+ char is_nothing= 1;
if (depth==1)
RExC_seen |= REG_TOP_LEVEL_BRANCHES;
@@ -7285,11 +9394,44 @@
const U8 op = PL_regkind[OP(br)];
if (op == BRANCH) {
REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
+ if (OP(NEXTOPER(br)) != NOTHING || regnext(NEXTOPER(br)) != ender)
+ is_nothing= 0;
}
else if (op == BRANCHJ) {
REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
+ /* for now we always disable this optimisation * /
+ if (OP(NEXTOPER(NEXTOPER(br))) != NOTHING || regnext(NEXTOPER(NEXTOPER(br))) != ender)
+ */
+ is_nothing= 0;
}
}
+ if (is_nothing) {
+ br= PL_regkind[OP(ret)] != BRANCH ? regnext(ret) : ret;
+ DEBUG_PARSE_r(if (!SIZE_ONLY) {
+ SV * const mysv_val1=sv_newmortal();
+ SV * const mysv_val2=sv_newmortal();
+ DEBUG_PARSE_MSG("NADA");
+ regprop(RExC_rx, mysv_val1, ret);
+ regprop(RExC_rx, mysv_val2, ender);
+ PerlIO_printf(Perl_debug_log, "~ converting ret %s (%"IVdf") to ender %s (%"IVdf") offset %"IVdf"\n",
+ SvPV_nolen_const(mysv_val1),
+ (IV)REG_NODE_NUM(ret),
+ SvPV_nolen_const(mysv_val2),
+ (IV)REG_NODE_NUM(ender),
+ (IV)(ender - ret)
+ );
+ });
+ OP(br)= NOTHING;
+ if (OP(ender) == TAIL) {
+ NEXT_OFF(br)= 0;
+ RExC_emit= br + 1;
+ } else {
+ regnode *opt;
+ for ( opt= br + 1; opt < ender ; opt++ )
+ OP(opt)= OPTIMIZED;
+ NEXT_OFF(br)= ender - br;
+ }
+ }
}
}
@@ -7313,7 +9455,8 @@
/* Check for proper termination. */
if (paren) {
- RExC_flags = oregflags;
+ /* restore original flags, but keep (?p) */
+ RExC_flags = oregflags | (RExC_flags & RXf_PMf_KEEPCOPY);
if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
RExC_parse = oregcomp_parse;
vFAIL("Unmatched (");
@@ -7326,7 +9469,7 @@
}
else
FAIL("Junk on end of regexp"); /* "Can't happen". */
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
}
if (RExC_in_lookbehind) {
@@ -7341,14 +9484,17 @@
- regbranch - one alternative of an | operator
*
* Implements the concatenation operator.
+ *
+ * Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs to be
+ * restarted.
*/
STATIC regnode *
S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
{
dVAR;
- register regnode *ret;
- register regnode *chain = NULL;
- register regnode *latest;
+ regnode *ret;
+ regnode *chain = NULL;
+ regnode *latest;
I32 flags = 0, c = 0;
GET_RE_DEBUG_FLAGS_DECL;
@@ -7366,7 +9512,7 @@
Set_Node_Length(ret, 1);
}
}
-
+
if (!first && SIZE_ONLY)
RExC_extralen += 1; /* BRANCHJ */
@@ -7380,7 +9526,11 @@
if (latest == NULL) {
if (flags & TRYAGAIN)
continue;
- return(NULL);
+ if (flags & RESTART_UTF8) {
+ *flagp = RESTART_UTF8;
+ return NULL;
+ }
+ FAIL2("panic: regpiece returned NULL, flags=%#X", flags);
}
else if (ret == NULL)
ret = latest;
@@ -7414,20 +9564,31 @@
* both the endmarker for their branch list and the body of the last branch.
* It might seem that this node could be dispensed with entirely, but the
* endmarker role is not redundant.
+ *
+ * Returns NULL, setting *flagp to TRYAGAIN if regatom() returns NULL with
+ * TRYAGAIN.
+ * Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs to be
+ * restarted.
*/
STATIC regnode *
S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
{
dVAR;
- register regnode *ret;
- register char op;
- register char *next;
+ regnode *ret;
+ char op;
+ char *next;
I32 flags;
const char * const origparse = RExC_parse;
I32 min;
I32 max = REG_INFTY;
+#ifdef RE_TRACK_PATTERN_OFFSETS
char *parse_start;
+#endif
const char *maxpos = NULL;
+
+ /* Save the original in case we change the emitted regop to a FAIL. */
+ regnode * const orig_emit = RExC_emit;
+
GET_RE_DEBUG_FLAGS_DECL;
PERL_ARGS_ASSERT_REGPIECE;
@@ -7436,16 +9597,20 @@
ret = regatom(pRExC_state, &flags,depth+1);
if (ret == NULL) {
- if (flags & TRYAGAIN)
- *flagp |= TRYAGAIN;
+ if (flags & (TRYAGAIN|RESTART_UTF8))
+ *flagp |= flags & (TRYAGAIN|RESTART_UTF8);
+ else
+ FAIL2("panic: regatom returned NULL, flags=%#X", flags);
return(NULL);
}
op = *RExC_parse;
- if (op == '{' && regcurly(RExC_parse)) {
+ if (op == '{' && regcurly(RExC_parse, FALSE)) {
maxpos = NULL;
+#ifdef RE_TRACK_PATTERN_OFFSETS
parse_start = RExC_parse; /* MJD */
+#endif
next = RExC_parse + 1;
while (isDIGIT(*next) || *next == ',') {
if (*next == ',') {
@@ -7472,7 +9637,24 @@
vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
RExC_parse = next;
nextchar(pRExC_state);
+ if (max < min) { /* If can't match, warn and optimize to fail
+ unconditionally */
+ if (SIZE_ONLY) {
+ ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match");
+ /* We can't back off the size because we have to reserve
+ * enough space for all the things we are about to throw
+ * away, but we can shrink it by the ammount we are about
+ * to re-use here */
+ RExC_size = PREVOPER(RExC_size) - regarglen[(U8)OPFAIL];
+ }
+ else {
+ RExC_emit = orig_emit;
+ }
+ ret = reg_node(pRExC_state, OPFAIL);
+ return ret;
+ }
+
do_curly:
if ((flags&SIMPLE)) {
RExC_naughty += 2 + RExC_naughty / 2;
@@ -7509,8 +9691,6 @@
*flagp = WORST;
if (max > 0)
*flagp |= HASWIDTH;
- if (max < min)
- vFAIL("Can't do {n,m} with n > m");
if (!SIZE_ONLY) {
ARG1_SET(ret, (U16)min);
ARG2_SET(ret, (U16)max);
@@ -7541,7 +9721,9 @@
vFAIL("Regexp *+ operand could be empty");
#endif
+#ifdef RE_TRACK_PATTERN_OFFSETS
parse_start = RExC_parse;
+#endif
nextchar(pRExC_state);
*flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
@@ -7570,10 +9752,12 @@
}
nest_check:
if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
+ SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
ckWARN3reg(RExC_parse,
"%.*s matches null string many times",
(int)(RExC_parse >= origparse ? RExC_parse - origparse : 0),
origparse);
+ (void)ReREFCNT_inc(RExC_rx_sv);
}
if (RExC_parse < RExC_end && *RExC_parse == '?') {
@@ -7604,86 +9788,100 @@
return(ret);
}
-
-/* reg_namedseq(pRExC_state,UVp, UV depth)
+STATIC bool
+S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, UV *valuep, I32 *flagp, U32 depth, bool in_char_class,
+ const bool strict /* Apply stricter parsing rules? */
+ )
+{
- This is expected to be called by a parser routine that has
- recognized '\N' and needs to handle the rest. RExC_parse is
- expected to point at the first char following the N at the time
- of the call.
+ /* This is expected to be called by a parser routine that has recognized '\N'
+ and needs to handle the rest. RExC_parse is expected to point at the first
+ char following the N at the time of the call. On successful return,
+ RExC_parse has been updated to point to just after the sequence identified
+ by this routine, and <*flagp> has been updated.
- The \N may be inside (indicated by valuep not being NULL) or outside a
+ The \N may be inside (indicated by the boolean <in_char_class>) or outside a
character class.
\N may begin either a named sequence, or if outside a character class, mean
to match a non-newline. For non single-quoted regexes, the tokenizer has
- attempted to decide which, and in the case of a named sequence converted it
+ attempted to decide which, and in the case of a named sequence, converted it
into one of the forms: \N{} (if the sequence is null), or \N{U+c1.c2...},
where c1... are the characters in the sequence. For single-quoted regexes,
the tokenizer passes the \N sequence through unchanged; this code will not
- attempt to determine this nor expand those. The net effect is that if the
- beginning of the passed-in pattern isn't '{U+' or there is no '}', it
- signals that this \N occurrence means to match a non-newline.
-
+ attempt to determine this nor expand those, instead raising a syntax error.
+ The net effect is that if the beginning of the passed-in pattern isn't '{U+'
+ or there is no '}', it signals that this \N occurrence means to match a
+ non-newline.
+
Only the \N{U+...} form should occur in a character class, for the same
reason that '.' inside a character class means to just match a period: it
just doesn't make sense.
-
- If valuep is non-null then it is assumed that we are parsing inside
- of a charclass definition and the first codepoint in the resolved
- string is returned via *valuep and the routine will return NULL.
- In this mode if a multichar string is returned from the charnames
- handler, a warning will be issued, and only the first char in the
- sequence will be examined. If the string returned is zero length
- then the value of *valuep is undefined and NON-NULL will
- be returned to indicate failure. (This will NOT be a valid pointer
- to a regnode.)
-
- If valuep is null then it is assumed that we are parsing normal text and a
- new EXACT node is inserted into the program containing the resolved string,
- and a pointer to the new node is returned. But if the string is zero length
- a NOTHING node is emitted instead.
- On success RExC_parse is set to the char following the endbrace.
- Parsing failures will generate a fatal error via vFAIL(...)
+ The function raises an error (via vFAIL), and doesn't return for various
+ syntax errors. Otherwise it returns TRUE and sets <node_p> or <valuep> on
+ success; it returns FALSE otherwise. Returns FALSE, setting *flagp to
+ RESTART_UTF8 if the sizing scan needs to be restarted. Such a restart is
+ only possible if node_p is non-NULL.
+
+
+ If <valuep> is non-null, it means the caller can accept an input sequence
+ consisting of a just a single code point; <*valuep> is set to that value
+ if the input is such.
+
+ If <node_p> is non-null it signifies that the caller can accept any other
+ legal sequence (i.e., one that isn't just a single code point). <*node_p>
+ is set as follows:
+ 1) \N means not-a-NL: points to a newly created REG_ANY node;
+ 2) \N{}: points to a new NOTHING node;
+ 3) otherwise: points to a new EXACT node containing the resolved
+ string.
+ Note that FALSE is returned for single code point sequences if <valuep> is
+ null.
*/
-STATIC regnode *
-S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep, I32 *flagp, U32 depth)
-{
+
char * endbrace; /* '}' following the name */
- regnode *ret = NULL;
char* p;
+ char *endchar; /* Points to '.' or '}' ending cur char in the input
+ stream */
+ bool has_multiple_chars; /* true if the input stream contains a sequence of
+ more than one character */
GET_RE_DEBUG_FLAGS_DECL;
- PERL_ARGS_ASSERT_REG_NAMEDSEQ;
+ PERL_ARGS_ASSERT_GROK_BSLASH_N;
GET_RE_DEBUG_FLAGS;
+ assert(cBOOL(node_p) ^ cBOOL(valuep)); /* Exactly one should be set */
+
/* The [^\n] meaning of \N ignores spaces and comments under the /x
* modifier. The other meaning does not */
p = (RExC_flags & RXf_PMf_EXTENDED)
? regwhite( pRExC_state, RExC_parse )
: RExC_parse;
-
+
/* Disambiguate between \N meaning a named character versus \N meaning
* [^\n]. The former is assumed when it can't be the latter. */
- if (*p != '{' || regcurly(p)) {
+ if (*p != '{' || regcurly(p, FALSE)) {
RExC_parse = p;
- if (valuep) {
+ if (! node_p) {
/* no bare \N in a charclass */
- vFAIL("\\N in a character class must be a named character: \\N{...}");
- }
+ if (in_char_class) {
+ vFAIL("\\N in a character class must be a named character: \\N{...}");
+ }
+ return FALSE;
+ }
nextchar(pRExC_state);
- ret = reg_node(pRExC_state, REG_ANY);
+ *node_p = reg_node(pRExC_state, REG_ANY);
*flagp |= HASWIDTH|SIMPLE;
RExC_naughty++;
RExC_parse--;
- Set_Node_Length(ret, 1); /* MJD */
- return ret;
+ Set_Node_Length(*node_p, 1); /* MJD */
+ return TRUE;
}
- /* Here, we have decided it should be a named sequence */
+ /* Here, we have decided it should be a named character or sequence */
/* The test above made sure that the next real character is a '{', but
* under the /x modifier, it could be separated by space (or a comment and
@@ -7705,44 +9903,53 @@
}
if (endbrace == RExC_parse) { /* empty: \N{} */
- if (! valuep) {
- RExC_parse = endbrace + 1;
- return reg_node(pRExC_state,NOTHING);
+ bool ret = TRUE;
+ if (node_p) {
+ *node_p = reg_node(pRExC_state,NOTHING);
}
-
- if (SIZE_ONLY) {
- ckWARNreg(RExC_parse,
- "Ignoring zero length \\N{} in character class"
- );
- RExC_parse = endbrace + 1;
+ else if (in_char_class) {
+ if (SIZE_ONLY && in_char_class) {
+ if (strict) {
+ RExC_parse++; /* Position after the "}" */
+ vFAIL("Zero length \\N{}");
+ }
+ else {
+ ckWARNreg(RExC_parse,
+ "Ignoring zero length \\N{} in character class");
+ }
+ }
+ ret = FALSE;
}
- *valuep = 0;
- return (regnode *) &RExC_parse; /* Invalid regnode pointer */
+ else {
+ return FALSE;
+ }
+ nextchar(pRExC_state);
+ return ret;
}
- REQUIRE_UTF8; /* named sequences imply Unicode semantics */
+ RExC_uni_semantics = 1; /* Unicode named chars imply Unicode semantics */
RExC_parse += 2; /* Skip past the 'U+' */
- if (valuep) { /* In a bracketed char class */
- /* We only pay attention to the first char of
- multichar strings being returned. I kinda wonder
+ endchar = RExC_parse + strcspn(RExC_parse, ".}");
+
+ /* Code points are separated by dots. If none, there is only one code
+ * point, and is terminated by the brace */
+ has_multiple_chars = (endchar < endbrace);
+
+ if (valuep && (! has_multiple_chars || in_char_class)) {
+ /* We only pay attention to the first char of
+ multichar strings being returned in char classes. I kinda wonder
if this makes sense as it does change the behaviour
from earlier versions, OTOH that behaviour was broken
as well. XXX Solution is to recharacterize as
[rest-of-class]|multi1|multi2... */
- STRLEN length_of_hex;
- I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
+ STRLEN length_of_hex = (STRLEN)(endchar - RExC_parse);
+ I32 grok_hex_flags = PERL_SCAN_ALLOW_UNDERSCORES
| PERL_SCAN_DISALLOW_PREFIX
| (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
-
- char * endchar = RExC_parse + strcspn(RExC_parse, ".}");
- if (endchar < endbrace) {
- ckWARNreg(endchar, "Using just the first character returned by \\N{} in character class");
- }
- length_of_hex = (STRLEN)(endchar - RExC_parse);
- *valuep = grok_hex(RExC_parse, &length_of_hex, &flags, NULL);
+ *valuep = grok_hex(RExC_parse, &length_of_hex, &grok_hex_flags, NULL);
/* The tokenizer should have guaranteed validity, but it's possible to
* bypass it by using single quoting, so check */
@@ -7754,17 +9961,34 @@
? UTF8SKIP(RExC_parse)
: 1;
/* Guard against malformed utf8 */
- if (RExC_parse >= endchar) RExC_parse = endchar;
+ if (RExC_parse >= endchar) {
+ RExC_parse = endchar;
+ }
vFAIL("Invalid hexadecimal number in \\N{U+...}");
- }
+ }
- RExC_parse = endbrace + 1;
- if (endchar == endbrace) return NULL;
+ if (in_char_class && has_multiple_chars) {
+ if (strict) {
+ RExC_parse = endbrace;
+ vFAIL("\\N{} in character class restricted to one character");
+ }
+ else {
+ ckWARNreg(endchar, "Using just the first character returned by \\N{} in character class");
+ }
+ }
- ret = (regnode *) &RExC_parse; /* Invalid regnode pointer */
+ RExC_parse = endbrace + 1;
}
- else { /* Not a char class */
+ else if (! node_p || ! has_multiple_chars) {
+ /* Here, the input is legal, but not according to the caller's
+ * options. We fail without advancing the parse, so that the
+ * caller can try again */
+ RExC_parse = p;
+ return FALSE;
+ }
+ else {
+
/* What is done here is to convert this to a sub-pattern of the form
* (?:\x{char1}\x{char2}...)
* and then call reg recursively. That way, it retains its atomicness,
@@ -7776,16 +10000,11 @@
SV * substitute_parse = newSVpvn_flags("?:", 2, SVf_UTF8|SVs_TEMP);
STRLEN len;
- char *endchar; /* Points to '.' or '}' ending cur char in the input
- stream */
char *orig_end = RExC_end;
+ I32 flags;
while (RExC_parse < endbrace) {
- /* Code points are separated by dots. If none, there is only one
- * code point, and is terminated by the brace */
- endchar = RExC_parse + strcspn(RExC_parse, ".}");
-
/* Convert to notation the rest of the code understands */
sv_catpv(substitute_parse, "\\x{");
sv_catpvn(substitute_parse, RExC_parse, endchar - RExC_parse);
@@ -7793,6 +10012,7 @@
/* Point to the beginning of the next character in the sequence. */
RExC_parse = endchar + 1;
+ endchar = RExC_parse + strcspn(RExC_parse, ".}");
}
sv_catpv(substitute_parse, ")");
@@ -7807,16 +10027,24 @@
/* The values are Unicode, and therefore not subject to recoding */
RExC_override_recoding = 1;
- ret = reg(pRExC_state, 1, flagp, depth+1);
+ if (!(*node_p = reg(pRExC_state, 1, &flags, depth+1))) {
+ if (flags & RESTART_UTF8) {
+ *flagp = RESTART_UTF8;
+ return FALSE;
+ }
+ FAIL2("panic: reg returned NULL to grok_bslash_N, flags=%#X",
+ flags);
+ }
+ *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
RExC_parse = endbrace;
RExC_end = orig_end;
RExC_override_recoding = 0;
- nextchar(pRExC_state);
+ nextchar(pRExC_state);
}
- return ret;
+ return TRUE;
}
@@ -7853,7 +10081,109 @@
return uv;
}
+PERL_STATIC_INLINE U8
+S_compute_EXACTish(pTHX_ RExC_state_t *pRExC_state)
+{
+ U8 op;
+ PERL_ARGS_ASSERT_COMPUTE_EXACTISH;
+
+ if (! FOLD) {
+ return EXACT;
+ }
+
+ op = get_regex_charset(RExC_flags);
+ if (op >= REGEX_ASCII_RESTRICTED_CHARSET) {
+ op--; /* /a is same as /u, and map /aa's offset to what /a's would have
+ been, so there is no hole */
+ }
+
+ return op + EXACTF;
+}
+
+PERL_STATIC_INLINE void
+S_alloc_maybe_populate_EXACT(pTHX_ RExC_state_t *pRExC_state, regnode *node, I32* flagp, STRLEN len, UV code_point)
+{
+ /* This knows the details about sizing an EXACTish node, setting flags for
+ * it (by setting <*flagp>, and potentially populating it with a single
+ * character.
+ *
+ * If <len> (the length in bytes) is non-zero, this function assumes that
+ * the node has already been populated, and just does the sizing. In this
+ * case <code_point> should be the final code point that has already been
+ * placed into the node. This value will be ignored except that under some
+ * circumstances <*flagp> is set based on it.
+ *
+ * If <len> is zero, the function assumes that the node is to contain only
+ * the single character given by <code_point> and calculates what <len>
+ * should be. In pass 1, it sizes the node appropriately. In pass 2, it
+ * additionally will populate the node's STRING with <code_point>, if <len>
+ * is 0. In both cases <*flagp> is appropriately set
+ *
+ * It knows that under FOLD, the Latin Sharp S and UTF characters above
+ * 255, must be folded (the former only when the rules indicate it can
+ * match 'ss') */
+
+ bool len_passed_in = cBOOL(len != 0);
+ U8 character[UTF8_MAXBYTES_CASE+1];
+
+ PERL_ARGS_ASSERT_ALLOC_MAYBE_POPULATE_EXACT;
+
+ if (! len_passed_in) {
+ if (UTF) {
+ if (FOLD && (! LOC || code_point > 255)) {
+ _to_uni_fold_flags(NATIVE_TO_UNI(code_point),
+ character,
+ &len,
+ FOLD_FLAGS_FULL | ((LOC)
+ ? FOLD_FLAGS_LOCALE
+ : (ASCII_FOLD_RESTRICTED)
+ ? FOLD_FLAGS_NOMIX_ASCII
+ : 0));
+ }
+ else {
+ uvchr_to_utf8( character, code_point);
+ len = UTF8SKIP(character);
+ }
+ }
+ else if (! FOLD
+ || code_point != LATIN_SMALL_LETTER_SHARP_S
+ || ASCII_FOLD_RESTRICTED
+ || ! AT_LEAST_UNI_SEMANTICS)
+ {
+ *character = (U8) code_point;
+ len = 1;
+ }
+ else {
+ *character = 's';
+ *(character + 1) = 's';
+ len = 2;
+ }
+ }
+
+ if (SIZE_ONLY) {
+ RExC_size += STR_SZ(len);
+ }
+ else {
+ RExC_emit += STR_SZ(len);
+ STR_LEN(node) = len;
+ if (! len_passed_in) {
+ Copy((char *) character, STRING(node), len, char);
+ }
+ }
+
+ *flagp |= HASWIDTH;
+
+ /* A single character node is SIMPLE, except for the special-cased SHARP S
+ * under /di. */
+ if ((len == 1 || (UTF && len == UNISKIP(code_point)))
+ && (code_point != LATIN_SMALL_LETTER_SHARP_S
+ || ! FOLD || ! DEPENDS_SEMANTICS))
+ {
+ *flagp |= SIMPLE;
+ }
+}
+
/*
- regatom - the lowest level
@@ -7869,11 +10199,55 @@
sequence, we return.
Note: we have to be careful with escapes, as they can be both literal
- and special, and in the case of \10 and friends can either, depending
- on context. Specifically there are two separate switches for handling
+ and special, and in the case of \10 and friends, context determines which.
+
+ A summary of the code structure is:
+
+ switch (first_byte) {
+ cases for each special:
+ handle this special;
+ break;
+ case '\\':
+ switch (2nd byte) {
+ cases for each unambiguous special:
+ handle this special;
+ break;
+ cases for each ambigous special/literal:
+ disambiguate;
+ if (special) handle here
+ else goto defchar;
+ default: // unambiguously literal:
+ goto defchar;
+ }
+ default: // is a literal char
+ // FALL THROUGH
+ defchar:
+ create EXACTish node for literal;
+ while (more input and node isn't full) {
+ switch (input_byte) {
+ cases for each special;
+ make sure parse pointer is set so that the next call to
+ regatom will see this special first
+ goto loopdone; // EXACTish node terminated by prev. char
+ default:
+ append char to EXACTISH node;
+ }
+ get next input byte;
+ }
+ loopdone:
+ }
+ return the generated node;
+
+ Specifically there are two separate switches for handling
escape sequences, with the one for handling literal escapes requiring
a dummy entry for all of the special escapes that are actually handled
by the other.
+
+ Returns NULL, setting *flagp to TRYAGAIN if reg() returns NULL with
+ TRYAGAIN.
+ Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs to be
+ restarted.
+ Otherwise does not return NULL.
*/
STATIC regnode *
@@ -7880,14 +10254,18 @@
S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
{
dVAR;
- register regnode *ret = NULL;
- I32 flags;
+ regnode *ret = NULL;
+ I32 flags = 0;
char *parse_start = RExC_parse;
U8 op;
+ int invert = 0;
+
GET_RE_DEBUG_FLAGS_DECL;
- DEBUG_PARSE("atom");
+
*flagp = WORST; /* Tentatively. */
+ DEBUG_PARSE("atom");
+
PERL_ARGS_ASSERT_REGATOM;
tryagain:
@@ -7928,19 +10306,28 @@
case '[':
{
char * const oregcomp_parse = ++RExC_parse;
- ret = regclass(pRExC_state,depth+1);
+ ret = regclass(pRExC_state, flagp,depth+1,
+ FALSE, /* means parse the whole char class */
+ TRUE, /* allow multi-char folds */
+ FALSE, /* don't silence non-portable warnings. */
+ NULL);
if (*RExC_parse != ']') {
RExC_parse = oregcomp_parse;
vFAIL("Unmatched [");
}
+ if (ret == NULL) {
+ if (*flagp & RESTART_UTF8)
+ return NULL;
+ FAIL2("panic: regclass returned NULL to regatom, flags=%#X",
+ *flagp);
+ }
nextchar(pRExC_state);
- *flagp |= HASWIDTH|SIMPLE;
Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
break;
}
case '(':
nextchar(pRExC_state);
- ret = reg(pRExC_state, 1, &flags,depth+1);
+ ret = reg(pRExC_state, 2, &flags,depth+1);
if (ret == NULL) {
if (flags & TRYAGAIN) {
if (RExC_parse == RExC_end) {
@@ -7950,7 +10337,11 @@
}
goto tryagain;
}
- return(NULL);
+ if (flags & RESTART_UTF8) {
+ *flagp = RESTART_UTF8;
+ return NULL;
+ }
+ FAIL2("panic: reg returned NULL to regatom, flags=%#X", flags);
}
*flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
break;
@@ -7964,7 +10355,7 @@
/* Supposed to be caught earlier. */
break;
case '{':
- if (!regcurly(RExC_parse)) {
+ if (!regcurly(RExC_parse, FALSE)) {
RExC_parse++;
goto defchar;
}
@@ -7989,6 +10380,7 @@
literal text handling code.
*/
switch ((U8)*++RExC_parse) {
+ U8 arg;
/* Special Escapes */
case 'A':
RExC_seen_zerolen++;
@@ -8029,201 +10421,98 @@
ret = reg_node(pRExC_state, CLUMP);
*flagp |= HASWIDTH;
goto finish_meta_pat;
+
+ case 'W':
+ invert = 1;
+ /* FALLTHROUGH */
case 'w':
- switch (get_regex_charset(RExC_flags)) {
- case REGEX_LOCALE_CHARSET:
- op = ALNUML;
- break;
- case REGEX_UNICODE_CHARSET:
- op = ALNUMU;
- break;
- case REGEX_ASCII_RESTRICTED_CHARSET:
- case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
- op = ALNUMA;
- break;
- case REGEX_DEPENDS_CHARSET:
- op = ALNUM;
- break;
- default:
- goto bad_charset;
- }
- ret = reg_node(pRExC_state, op);
- *flagp |= HASWIDTH|SIMPLE;
- goto finish_meta_pat;
- case 'W':
- switch (get_regex_charset(RExC_flags)) {
- case REGEX_LOCALE_CHARSET:
- op = NALNUML;
- break;
- case REGEX_UNICODE_CHARSET:
- op = NALNUMU;
- break;
- case REGEX_ASCII_RESTRICTED_CHARSET:
- case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
- op = NALNUMA;
- break;
- case REGEX_DEPENDS_CHARSET:
- op = NALNUM;
- break;
- default:
- goto bad_charset;
- }
- ret = reg_node(pRExC_state, op);
- *flagp |= HASWIDTH|SIMPLE;
- goto finish_meta_pat;
+ arg = ANYOF_WORDCHAR;
+ goto join_posix;
+
case 'b':
RExC_seen_zerolen++;
RExC_seen |= REG_SEEN_LOOKBEHIND;
- switch (get_regex_charset(RExC_flags)) {
- case REGEX_LOCALE_CHARSET:
- op = BOUNDL;
- break;
- case REGEX_UNICODE_CHARSET:
- op = BOUNDU;
- break;
- case REGEX_ASCII_RESTRICTED_CHARSET:
- case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
- op = BOUNDA;
- break;
- case REGEX_DEPENDS_CHARSET:
- op = BOUND;
- break;
- default:
- goto bad_charset;
+ op = BOUND + get_regex_charset(RExC_flags);
+ if (op > BOUNDA) { /* /aa is same as /a */
+ op = BOUNDA;
}
ret = reg_node(pRExC_state, op);
FLAGS(ret) = get_regex_charset(RExC_flags);
*flagp |= SIMPLE;
if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
- ckWARNregdep(RExC_parse, "\"\\b{\" is deprecated; use \"\\b\\{\" instead");
+ ckWARNdep(RExC_parse, "\"\\b{\" is deprecated; use \"\\b\\{\" or \"\\b[{]\" instead");
}
goto finish_meta_pat;
case 'B':
RExC_seen_zerolen++;
RExC_seen |= REG_SEEN_LOOKBEHIND;
- switch (get_regex_charset(RExC_flags)) {
- case REGEX_LOCALE_CHARSET:
- op = NBOUNDL;
- break;
- case REGEX_UNICODE_CHARSET:
- op = NBOUNDU;
- break;
- case REGEX_ASCII_RESTRICTED_CHARSET:
- case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
- op = NBOUNDA;
- break;
- case REGEX_DEPENDS_CHARSET:
- op = NBOUND;
- break;
- default:
- goto bad_charset;
+ op = NBOUND + get_regex_charset(RExC_flags);
+ if (op > NBOUNDA) { /* /aa is same as /a */
+ op = NBOUNDA;
}
ret = reg_node(pRExC_state, op);
FLAGS(ret) = get_regex_charset(RExC_flags);
*flagp |= SIMPLE;
if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
- ckWARNregdep(RExC_parse, "\"\\B{\" is deprecated; use \"\\B\\{\" instead");
+ ckWARNdep(RExC_parse, "\"\\B{\" is deprecated; use \"\\B\\{\" or \"\\B[{]\" instead");
}
goto finish_meta_pat;
- case 's':
- switch (get_regex_charset(RExC_flags)) {
- case REGEX_LOCALE_CHARSET:
- op = SPACEL;
- break;
- case REGEX_UNICODE_CHARSET:
- op = SPACEU;
- break;
- case REGEX_ASCII_RESTRICTED_CHARSET:
- case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
- op = SPACEA;
- break;
- case REGEX_DEPENDS_CHARSET:
- op = SPACE;
- break;
- default:
- goto bad_charset;
- }
- ret = reg_node(pRExC_state, op);
+
+ case 'D':
+ invert = 1;
+ /* FALLTHROUGH */
+ case 'd':
+ arg = ANYOF_DIGIT;
+ goto join_posix;
+
+ case 'R':
+ ret = reg_node(pRExC_state, LNBREAK);
*flagp |= HASWIDTH|SIMPLE;
goto finish_meta_pat;
+
+ case 'H':
+ invert = 1;
+ /* FALLTHROUGH */
+ case 'h':
+ arg = ANYOF_BLANK;
+ op = POSIXU;
+ goto join_posix_op_known;
+
+ case 'V':
+ invert = 1;
+ /* FALLTHROUGH */
+ case 'v':
+ arg = ANYOF_VERTWS;
+ op = POSIXU;
+ goto join_posix_op_known;
+
case 'S':
- switch (get_regex_charset(RExC_flags)) {
- case REGEX_LOCALE_CHARSET:
- op = NSPACEL;
- break;
- case REGEX_UNICODE_CHARSET:
- op = NSPACEU;
- break;
- case REGEX_ASCII_RESTRICTED_CHARSET:
- case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
- op = NSPACEA;
- break;
- case REGEX_DEPENDS_CHARSET:
- op = NSPACE;
- break;
- default:
- goto bad_charset;
+ invert = 1;
+ /* FALLTHROUGH */
+ case 's':
+ arg = ANYOF_SPACE;
+
+ join_posix:
+
+ op = POSIXD + get_regex_charset(RExC_flags);
+ if (op > POSIXA) { /* /aa is same as /a */
+ op = POSIXA;
}
- ret = reg_node(pRExC_state, op);
- *flagp |= HASWIDTH|SIMPLE;
- goto finish_meta_pat;
- case 'd':
- switch (get_regex_charset(RExC_flags)) {
- case REGEX_LOCALE_CHARSET:
- op = DIGITL;
- break;
- case REGEX_ASCII_RESTRICTED_CHARSET:
- case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
- op = DIGITA;
- break;
- case REGEX_DEPENDS_CHARSET: /* No difference between these */
- case REGEX_UNICODE_CHARSET:
- op = DIGIT;
- break;
- default:
- goto bad_charset;
+
+ join_posix_op_known:
+
+ if (invert) {
+ op += NPOSIXD - POSIXD;
}
+
ret = reg_node(pRExC_state, op);
- *flagp |= HASWIDTH|SIMPLE;
- goto finish_meta_pat;
- case 'D':
- switch (get_regex_charset(RExC_flags)) {
- case REGEX_LOCALE_CHARSET:
- op = NDIGITL;
- break;
- case REGEX_ASCII_RESTRICTED_CHARSET:
- case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
- op = NDIGITA;
- break;
- case REGEX_DEPENDS_CHARSET: /* No difference between these */
- case REGEX_UNICODE_CHARSET:
- op = NDIGIT;
- break;
- default:
- goto bad_charset;
+ if (! SIZE_ONLY) {
+ FLAGS(ret) = namedclass_to_classnum(arg);
}
- ret = reg_node(pRExC_state, op);
+
*flagp |= HASWIDTH|SIMPLE;
- goto finish_meta_pat;
- case 'R':
- ret = reg_node(pRExC_state, LNBREAK);
- *flagp |= HASWIDTH|SIMPLE;
- goto finish_meta_pat;
- case 'h':
- ret = reg_node(pRExC_state, HORIZWS);
- *flagp |= HASWIDTH|SIMPLE;
- goto finish_meta_pat;
- case 'H':
- ret = reg_node(pRExC_state, NHORIZWS);
- *flagp |= HASWIDTH|SIMPLE;
- goto finish_meta_pat;
- case 'v':
- ret = reg_node(pRExC_state, VERTWS);
- *flagp |= HASWIDTH|SIMPLE;
- goto finish_meta_pat;
- case 'V':
- ret = reg_node(pRExC_state, NVERTWS);
- *flagp |= HASWIDTH|SIMPLE;
+ /* FALL THROUGH */
+
finish_meta_pat:
nextchar(pRExC_state);
Set_Node_Length(ret, 2); /* MJD */
@@ -8230,48 +10519,52 @@
break;
case 'p':
case 'P':
- {
- char* const oldregxend = RExC_end;
+ {
#ifdef DEBUGGING
char* parse_start = RExC_parse - 2;
#endif
- if (RExC_parse[1] == '{') {
- /* a lovely hack--pretend we saw [\pX] instead */
- RExC_end = strchr(RExC_parse, '}');
- if (!RExC_end) {
- const U8 c = (U8)*RExC_parse;
- RExC_parse += 2;
- RExC_end = oldregxend;
- vFAIL2("Missing right brace on \\%c{}", c);
- }
- RExC_end++;
- }
- else {
- RExC_end = RExC_parse + 2;
- if (RExC_end > oldregxend)
- RExC_end = oldregxend;
- }
RExC_parse--;
- ret = regclass(pRExC_state,depth+1);
+ ret = regclass(pRExC_state, flagp,depth+1,
+ TRUE, /* means just parse this element */
+ FALSE, /* don't allow multi-char folds */
+ FALSE, /* don't silence non-portable warnings.
+ It would be a bug if these returned
+ non-portables */
+ NULL);
+ /* regclass() can only return RESTART_UTF8 if multi-char folds
+ are allowed. */
+ if (!ret)
+ FAIL2("panic: regclass returned NULL to regatom, flags=%#X",
+ *flagp);
- RExC_end = oldregxend;
RExC_parse--;
Set_Node_Offset(ret, parse_start + 2);
Set_Node_Cur_Length(ret);
nextchar(pRExC_state);
- *flagp |= HASWIDTH|SIMPLE;
}
break;
case 'N':
- /* Handle \N and \N{NAME} here and not below because it can be
- multicharacter. join_exact() will join them up later on.
- Also this makes sure that things like /\N{BLAH}+/ and
- \N{BLAH} being multi char Just Happen. dmq*/
+ /* Handle \N and \N{NAME} with multiple code points here and not
+ * below because it can be multicharacter. join_exact() will join
+ * them up later on. Also this makes sure that things like
+ * /\N{BLAH}+/ and \N{BLAH} being multi char Just Happen. dmq.
+ * The options to the grok function call causes it to fail if the
+ * sequence is just a single code point. We then go treat it as
+ * just another character in the current EXACT node, and hence it
+ * gets uniform treatment with all the other characters. The
+ * special treatment for quantifiers is not needed for such single
+ * character sequences */
++RExC_parse;
- ret= reg_namedseq(pRExC_state, NULL, flagp, depth);
+ if (! grok_bslash_N(pRExC_state, &ret, NULL, flagp, depth, FALSE,
+ FALSE /* not strict */ )) {
+ if (*flagp & RESTART_UTF8)
+ return NULL;
+ RExC_parse--;
+ goto defchar;
+ }
break;
case 'k': /* Handle \k<NAME> and \k'NAME' */
parse_named_seq:
@@ -8301,7 +10594,7 @@
ret = reganode(pRExC_state,
((! FOLD)
? NREF
- : (MORE_ASCII_RESTRICTED)
+ : (ASCII_FOLD_RESTRICTED)
? NREFFA
: (AT_LEAST_UNI_SEMANTICS)
? NREFFU
@@ -8351,6 +10644,7 @@
vFAIL("Reference to nonexistent or unclosed group");
}
if (!isg && num > 9 && num >= RExC_npar)
+ /* Probably a character specified in octal, e.g. \35 */
goto defchar;
else {
char * const parse_start = RExC_parse - 1; /* MJD */
@@ -8371,7 +10665,7 @@
ret = reganode(pRExC_state,
((! FOLD)
? REF
- : (MORE_ASCII_RESTRICTED)
+ : (ASCII_FOLD_RESTRICTED)
? REFFA
: (AT_LEAST_UNI_SEMANTICS)
? REFFU
@@ -8415,43 +10709,64 @@
RExC_parse++;
defchar: {
- typedef enum {
- generic_char = 0,
- char_s,
- upsilon_1,
- upsilon_2,
- iota_1,
- iota_2,
- } char_state;
- char_state latest_char_state = generic_char;
- register STRLEN len;
- register UV ender;
- register char *p;
+ STRLEN len = 0;
+ UV ender;
+ char *p;
char *s;
+#define MAX_NODE_STRING_SIZE 127
+ char foldbuf[MAX_NODE_STRING_SIZE+UTF8_MAXBYTES_CASE];
+ char *s0;
+ U8 upper_parse = MAX_NODE_STRING_SIZE;
STRLEN foldlen;
- U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
- regnode * orig_emit;
+ U8 node_type;
+ bool next_is_quantifier;
+ char * oldp = NULL;
+ /* If a folding node contains only code points that don't
+ * participate in folds, it can be changed into an EXACT node,
+ * which allows the optimizer more things to look for */
+ bool maybe_exact;
+
ender = 0;
- orig_emit = RExC_emit; /* Save the original output node position in
- case we need to output a different node
- type */
- ret = reg_node(pRExC_state,
- (U8) ((! FOLD) ? EXACT
- : (LOC)
- ? EXACTFL
- : (MORE_ASCII_RESTRICTED)
- ? EXACTFA
- : (AT_LEAST_UNI_SEMANTICS)
- ? EXACTFU
- : EXACTF)
- );
- s = STRING(ret);
- for (len = 0, p = RExC_parse - 1;
- len < 127 && p < RExC_end;
- len++)
+ node_type = compute_EXACTish(pRExC_state);
+ ret = reg_node(pRExC_state, node_type);
+
+ /* In pass1, folded, we use a temporary buffer instead of the
+ * actual node, as the node doesn't exist yet */
+ s = (SIZE_ONLY && FOLD) ? foldbuf : STRING(ret);
+
+ s0 = s;
+
+ reparse:
+
+ /* We do the EXACTFish to EXACT node only if folding, and not if in
+ * locale, as whether a character folds or not isn't known until
+ * runtime */
+ maybe_exact = FOLD && ! LOC;
+
+ /* XXX The node can hold up to 255 bytes, yet this only goes to
+ * 127. I (khw) do not know why. Keeping it somewhat less than
+ * 255 allows us to not have to worry about overflow due to
+ * converting to utf8 and fold expansion, but that value is
+ * 255-UTF8_MAXBYTES_CASE. join_exact() may join adjacent nodes
+ * split up by this limit into a single one using the real max of
+ * 255. Even at 127, this breaks under rare circumstances. If
+ * folding, we do not want to split a node at a character that is a
+ * non-final in a multi-char fold, as an input string could just
+ * happen to want to match across the node boundary. The join
+ * would solve that problem if the join actually happens. But a
+ * series of more than two nodes in a row each of 127 would cause
+ * the first join to succeed to get to 254, but then there wouldn't
+ * be room for the next one, which could at be one of those split
+ * multi-char folds. I don't know of any fool-proof solution. One
+ * could back off to end with only a code point that isn't such a
+ * non-final, but it is possible for there not to be any in the
+ * entire node. */
+ for (p = RExC_parse - 1;
+ len < upper_parse && p < RExC_end;
+ len++)
{
- char * const oldp = p;
+ oldp = p;
if (RExC_flags & RXf_PMf_EXTENDED)
p = regwhite( pRExC_state, p );
@@ -8487,7 +10802,6 @@
case 'g': case 'G': /* generic-backref, pos assertion */
case 'h': case 'H': /* HORIZWS */
case 'k': case 'K': /* named backref, keep marker */
- case 'N': /* named char sequence */
case 'p': case 'P': /* Unicode property */
case 'R': /* LNBREAK */
case 's': case 'S': /* space class */
@@ -8505,6 +10819,25 @@
ender = '\n';
p++;
break;
+ case 'N': /* Handle a single-code point named character. */
+ /* The options cause it to fail if a multiple code
+ * point sequence. Handle those in the switch() above
+ * */
+ RExC_parse = p + 1;
+ if (! grok_bslash_N(pRExC_state, NULL, &ender,
+ flagp, depth, FALSE,
+ FALSE /* not strict */ ))
+ {
+ if (*flagp & RESTART_UTF8)
+ FAIL("panic: grok_bslash_N set RESTART_UTF8");
+ RExC_parse = p = oldp;
+ goto loopdone;
+ }
+ p = RExC_parse;
+ if (ender > 0xff) {
+ REQUIRE_UTF8;
+ }
+ break;
case 'r':
ender = '\r';
p++;
@@ -8527,25 +10860,24 @@
break;
case 'o':
{
- STRLEN brace_len = len;
UV result;
const char* error_msg;
- bool valid = grok_bslash_o(p,
+ bool valid = grok_bslash_o(&p,
&result,
- &brace_len,
&error_msg,
- 1);
- p += brace_len;
+ TRUE, /* out warnings */
+ FALSE, /* not strict */
+ TRUE, /* Output warnings
+ for non-
+ portables */
+ UTF);
if (! valid) {
RExC_parse = p; /* going to die anyway; point
to exact spot of failure */
vFAIL(error_msg);
}
- else
- {
- ender = result;
- }
+ ender = result;
if (PL_encoding && ender < 0x100) {
goto recode_encoding;
}
@@ -8555,38 +10887,41 @@
break;
}
case 'x':
- if (*++p == '{') {
- char* const e = strchr(p, '}');
-
- if (!e) {
- RExC_parse = p + 1;
- vFAIL("Missing right brace on \\x{}");
+ {
+ UV result = UV_MAX; /* initialize to erroneous
+ value */
+ const char* error_msg;
+
+ bool valid = grok_bslash_x(&p,
+ &result,
+ &error_msg,
+ TRUE, /* out warnings */
+ FALSE, /* not strict */
+ TRUE, /* Output warnings
+ for non-
+ portables */
+ UTF);
+ if (! valid) {
+ RExC_parse = p; /* going to die anyway; point
+ to exact spot of failure */
+ vFAIL(error_msg);
}
- else {
- I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
- | PERL_SCAN_DISALLOW_PREFIX;
- STRLEN numlen = e - p - 1;
- ender = grok_hex(p + 1, &numlen, &flags, NULL);
- if (ender > 0xff)
- REQUIRE_UTF8;
- p = e + 1;
+ ender = result;
+
+ if (PL_encoding && ender < 0x100) {
+ goto recode_encoding;
}
+ if (ender > 0xff) {
+ REQUIRE_UTF8;
+ }
+ break;
}
- else {
- I32 flags = PERL_SCAN_DISALLOW_PREFIX;
- STRLEN numlen = 2;
- ender = grok_hex(p, &numlen, &flags, NULL);
- p += numlen;
- }
- if (PL_encoding && ender < 0x100)
- goto recode_encoding;
- break;
case 'c':
p++;
ender = grok_bslash_c(*p++, UTF, SIZE_ONLY);
break;
case '0': case '1': case '2': case '3':case '4':
- case '5': case '6': case '7': case '8':case '9':
+ case '5': case '6': case '7':
if (*p == '0' ||
(isDIGIT(p[1]) && atoi(p) >= RExC_npar))
{
@@ -8597,8 +10932,18 @@
REQUIRE_UTF8;
}
p += numlen;
+ if (SIZE_ONLY /* like \08, \178 */
+ && numlen < 3
+ && p < RExC_end
+ && isDIGIT(*p) && ckWARN(WARN_REGEXP))
+ {
+ reg_warn_non_literal_string(
+ p + 1,
+ form_short_octal_warning(p, numlen));
+ }
}
- else {
+ else { /* Not to be treated as an octal constant, go
+ find backref */
--p;
goto loopdone;
}
@@ -8619,17 +10964,27 @@
FAIL("Trailing \\");
/* FALL THROUGH */
default:
- if (!SIZE_ONLY&& isALPHA(*p)) {
+ if (!SIZE_ONLY&& isALPHANUMERIC(*p)) {
/* Include any { following the alpha to emphasize
* that it could be part of an escape at some point
* in the future */
- int len = (*(p + 1) == '{') ? 2 : 1;
+ int len = (isALPHA(*p) && *(p + 1) == '{') ? 2 : 1;
ckWARN3reg(p + len, "Unrecognized escape \\%.*s passed through", len, p);
}
goto normal_default;
- }
+ } /* End of switch on '\' */
break;
- default:
+ default: /* A literal character */
+
+ if (! SIZE_ONLY
+ && RExC_flags & RXf_PMf_EXTENDED
+ && ckWARN(WARN_DEPRECATED)
+ && is_PATWS_non_low(p, UTF))
+ {
+ vWARN_dep(p + ((UTF) ? UTF8SKIP(p) : 1),
+ "Escape literal pattern white space under /x");
+ }
+
normal_default:
if (UTF8_IS_START(*p) && UTF) {
STRLEN numlen;
@@ -8642,346 +10997,308 @@
break;
} /* End of switch on the literal */
- /* Certain characters are problematic because their folded
- * length is so different from their original length that it
- * isn't handleable by the optimizer. They are therefore not
- * placed in an EXACTish node; and are here handled specially.
- * (Even if the optimizer handled LATIN_SMALL_LETTER_SHARP_S,
- * putting it in a special node keeps regexec from having to
- * deal with a non-utf8 multi-char fold */
- if (FOLD
- && (ender > 255 || (! MORE_ASCII_RESTRICTED && ! LOC)))
+ /* Here, have looked at the literal character and <ender>
+ * contains its ordinal, <p> points to the character after it
+ */
+
+ if ( RExC_flags & RXf_PMf_EXTENDED)
+ p = regwhite( pRExC_state, p );
+
+ /* If the next thing is a quantifier, it applies to this
+ * character only, which means that this character has to be in
+ * its own node and can't just be appended to the string in an
+ * existing node, so if there are already other characters in
+ * the node, close the node with just them, and set up to do
+ * this character again next time through, when it will be the
+ * only thing in its new node */
+ if ((next_is_quantifier = (p < RExC_end && ISMULT2(p))) && len)
{
- /* We look for either side of the fold. For example \xDF
- * folds to 'ss'. We look for both the single character
- * \xDF and the sequence 'ss'. When we find something that
- * could be one of those, we stop and flush whatever we
- * have output so far into the EXACTish node that was being
- * built. Then restore the input pointer to what it was.
- * regatom will return that EXACT node, and will be called
- * again, positioned so the first character is the one in
- * question, which we return in a different node type.
- * The multi-char folds are a sequence, so the occurrence
- * of the first character in that sequence doesn't
- * necessarily mean that what follows is the rest of the
- * sequence. We keep track of that with a state machine,
- * with the state being set to the latest character
- * processed before the current one. Most characters will
- * set the state to 0, but if one occurs that is part of a
- * potential tricky fold sequence, the state is set to that
- * character, and the next loop iteration sees if the state
- * should progress towards the final folded-from character,
- * or if it was a false alarm. If it turns out to be a
- * false alarm, the character(s) will be output in a new
- * EXACTish node, and join_exact() will later combine them.
- * In the case of the 'ss' sequence, which is more common
- * and more easily checked, some look-ahead is done to
- * save time by ruling-out some false alarms */
- switch (ender) {
- default:
- latest_char_state = generic_char;
- break;
- case 's':
- case 'S':
- case 0x17F: /* LATIN SMALL LETTER LONG S */
- if (AT_LEAST_UNI_SEMANTICS) {
- if (latest_char_state == char_s) { /* 'ss' */
- ender = LATIN_SMALL_LETTER_SHARP_S;
- goto do_tricky;
- }
- else if (p < RExC_end) {
+ p = oldp;
+ goto loopdone;
+ }
- /* Look-ahead at the next character. If it
- * is also an s, we handle as a sharp s
- * tricky regnode. */
- if (*p == 's' || *p == 'S') {
+ if (FOLD) {
+ if (UTF
+ /* See comments for join_exact() as to why we fold
+ * this non-UTF at compile time */
+ || (node_type == EXACTFU
+ && ender == LATIN_SMALL_LETTER_SHARP_S))
+ {
- /* But first flush anything in the
- * EXACTish buffer */
- if (len != 0) {
- p = oldp;
- goto loopdone;
- }
- p++; /* Account for swallowing this
- 's' up */
- ender = LATIN_SMALL_LETTER_SHARP_S;
- goto do_tricky;
- }
- /* Here, the next character is not a
- * literal 's', but still could
- * evaluate to one if part of a \o{},
- * \x or \OCTAL-DIGIT. The minimum
- * length required for that is 4, eg
- * \x53 or \123 */
- else if (*p == '\\'
- && p < RExC_end - 4
- && (isDIGIT(*(p + 1))
- || *(p + 1) == 'x'
- || *(p + 1) == 'o' ))
- {
- /* Here, it could be an 's', too much
- * bother to figure it out here. Flush
- * the buffer if any; when come back
- * here, set the state so know that the
- * previous char was an 's' */
- if (len != 0) {
- latest_char_state = generic_char;
- p = oldp;
- goto loopdone;
- }
- latest_char_state = char_s;
- break;
- }
- }
- }
+ /* Prime the casefolded buffer. Locale rules, which
+ * apply only to code points < 256, aren't known until
+ * execution, so for them, just output the original
+ * character using utf8. If we start to fold non-UTF
+ * patterns, be sure to update join_exact() */
+ if (LOC && ender < 256) {
+ if (UNI_IS_INVARIANT(ender)) {
+ *s = (U8) ender;
+ foldlen = 1;
+ } else {
+ *s = UTF8_TWO_BYTE_HI(ender);
+ *(s + 1) = UTF8_TWO_BYTE_LO(ender);
+ foldlen = 2;
+ }
+ }
+ else {
+ UV folded = _to_uni_fold_flags(
+ ender,
+ (U8 *) s,
+ &foldlen,
+ FOLD_FLAGS_FULL
+ | ((LOC) ? FOLD_FLAGS_LOCALE
+ : (ASCII_FOLD_RESTRICTED)
+ ? FOLD_FLAGS_NOMIX_ASCII
+ : 0)
+ );
- /* Here, can't be an 'ss' sequence, or at least not
- * one that could fold to/from the sharp ss */
- latest_char_state = generic_char;
- break;
- case 0x03C5: /* First char in upsilon series */
- if (p < RExC_end - 4) { /* Need >= 4 bytes left */
- latest_char_state = upsilon_1;
- if (len != 0) {
- p = oldp;
- goto loopdone;
- }
- }
- else {
- latest_char_state = generic_char;
- }
- break;
- case 0x03B9: /* First char in iota series */
- if (p < RExC_end - 4) {
- latest_char_state = iota_1;
- if (len != 0) {
- p = oldp;
- goto loopdone;
- }
- }
- else {
- latest_char_state = generic_char;
- }
- break;
- case 0x0308:
- if (latest_char_state == upsilon_1) {
- latest_char_state = upsilon_2;
- }
- else if (latest_char_state == iota_1) {
- latest_char_state = iota_2;
- }
- else {
- latest_char_state = generic_char;
- }
- break;
- case 0x301:
- if (latest_char_state == upsilon_2) {
- ender = GREEK_SMALL_LETTER_UPSILON_WITH_DIALYTIKA_AND_TONOS;
- goto do_tricky;
- }
- else if (latest_char_state == iota_2) {
- ender = GREEK_SMALL_LETTER_IOTA_WITH_DIALYTIKA_AND_TONOS;
- goto do_tricky;
- }
- latest_char_state = generic_char;
- break;
+ /* If this node only contains non-folding code
+ * points so far, see if this new one is also
+ * non-folding */
+ if (maybe_exact) {
+ if (folded != ender) {
+ maybe_exact = FALSE;
+ }
+ else {
+ /* Here the fold is the original; we have
+ * to check further to see if anything
+ * folds to it */
+ if (! PL_utf8_foldable) {
+ SV* swash = swash_init("utf8",
+ "_Perl_Any_Folds",
+ &PL_sv_undef, 1, 0);
+ PL_utf8_foldable =
+ _get_swash_invlist(swash);
+ SvREFCNT_dec_NN(swash);
+ }
+ if (_invlist_contains_cp(PL_utf8_foldable,
+ ender))
+ {
+ maybe_exact = FALSE;
+ }
+ }
+ }
+ ender = folded;
+ }
+ s += foldlen;
- /* These are the tricky fold characters. Flush any
- * buffer first. */
- case GREEK_SMALL_LETTER_UPSILON_WITH_DIALYTIKA_AND_TONOS:
- case GREEK_SMALL_LETTER_IOTA_WITH_DIALYTIKA_AND_TONOS:
- case LATIN_SMALL_LETTER_SHARP_S:
- case LATIN_CAPITAL_LETTER_SHARP_S:
- case 0x1FD3:
- case 0x1FE3:
- if (len != 0) {
- p = oldp;
- goto loopdone;
- }
- /* FALL THROUGH */
- do_tricky: {
- char* const oldregxend = RExC_end;
- U8 tmpbuf[UTF8_MAXBYTES+1];
+ /* The loop increments <len> each time, as all but this
+ * path (and the one just below for UTF) through it add
+ * a single byte to the EXACTish node. But this one
+ * has changed len to be the correct final value, so
+ * subtract one to cancel out the increment that
+ * follows */
+ len += foldlen - 1;
+ }
+ else {
+ *(s++) = (char) ender;
+ maybe_exact &= ! IS_IN_SOME_FOLD_L1(ender);
+ }
+ }
+ else if (UTF) {
+ const STRLEN unilen = reguni(pRExC_state, ender, s);
+ if (unilen > 0) {
+ s += unilen;
+ len += unilen;
+ }
- /* Here, we know we need to generate a special
- * regnode, and 'ender' contains the tricky
- * character. What's done is to pretend it's in a
- * [bracketed] class, and let the code that deals
- * with those handle it, as that code has all the
- * intelligence necessary. First save the current
- * parse state, get rid of the already allocated
- * but empty EXACT node that the ANYOFV node will
- * replace, and point the parse to a buffer which
- * we fill with the character we want the regclass
- * code to think is being parsed */
- RExC_emit = orig_emit;
- RExC_parse = (char *) tmpbuf;
- if (UTF) {
- U8 *d = uvchr_to_utf8(tmpbuf, ender);
- *d = '\0';
- RExC_end = (char *) d;
- }
- else { /* ender above 255 already excluded */
- tmpbuf[0] = (U8) ender;
- tmpbuf[1] = '\0';
- RExC_end = RExC_parse + 1;
- }
+ /* See comment just above for - 1 */
+ len--;
+ }
+ else {
+ REGC((char)ender, s++);
+ }
- ret = regclass(pRExC_state,depth+1);
+ if (next_is_quantifier) {
- /* Here, have parsed the buffer. Reset the parse to
- * the actual input, and return */
- RExC_end = oldregxend;
- RExC_parse = p - 1;
+ /* Here, the next input is a quantifier, and to get here,
+ * the current character is the only one in the node.
+ * Also, here <len> doesn't include the final byte for this
+ * character */
+ len++;
+ goto loopdone;
+ }
- Set_Node_Offset(ret, RExC_parse);
- Set_Node_Cur_Length(ret);
- nextchar(pRExC_state);
- *flagp |= HASWIDTH|SIMPLE;
- return ret;
- }
- }
+ } /* End of loop through literal characters */
+
+ /* Here we have either exhausted the input or ran out of room in
+ * the node. (If we encountered a character that can't be in the
+ * node, transfer is made directly to <loopdone>, and so we
+ * wouldn't have fallen off the end of the loop.) In the latter
+ * case, we artificially have to split the node into two, because
+ * we just don't have enough space to hold everything. This
+ * creates a problem if the final character participates in a
+ * multi-character fold in the non-final position, as a match that
+ * should have occurred won't, due to the way nodes are matched,
+ * and our artificial boundary. So back off until we find a non-
+ * problematic character -- one that isn't at the beginning or
+ * middle of such a fold. (Either it doesn't participate in any
+ * folds, or appears only in the final position of all the folds it
+ * does participate in.) A better solution with far fewer false
+ * positives, and that would fill the nodes more completely, would
+ * be to actually have available all the multi-character folds to
+ * test against, and to back-off only far enough to be sure that
+ * this node isn't ending with a partial one. <upper_parse> is set
+ * further below (if we need to reparse the node) to include just
+ * up through that final non-problematic character that this code
+ * identifies, so when it is set to less than the full node, we can
+ * skip the rest of this */
+ if (FOLD && p < RExC_end && upper_parse == MAX_NODE_STRING_SIZE) {
+
+ const STRLEN full_len = len;
+
+ assert(len >= MAX_NODE_STRING_SIZE);
+
+ /* Here, <s> points to the final byte of the final character.
+ * Look backwards through the string until find a non-
+ * problematic character */
+
+ if (! UTF) {
+
+ /* These two have no multi-char folds to non-UTF characters
+ */
+ if (ASCII_FOLD_RESTRICTED || LOC) {
+ goto loopdone;
+ }
+
+ while (--s >= s0 && IS_NON_FINAL_FOLD(*s)) { }
+ len = s - s0 + 1;
}
+ else {
+ if (! PL_NonL1NonFinalFold) {
+ PL_NonL1NonFinalFold = _new_invlist_C_array(
+ NonL1_Perl_Non_Final_Folds_invlist);
+ }
- if ( RExC_flags & RXf_PMf_EXTENDED)
- p = regwhite( pRExC_state, p );
- if (UTF && FOLD) {
- /* Prime the casefolded buffer. Locale rules, which apply
- * only to code points < 256, aren't known until execution,
- * so for them, just output the original character using
- * utf8 */
- if (LOC && ender < 256) {
- if (UNI_IS_INVARIANT(ender)) {
- *tmpbuf = (U8) ender;
- foldlen = 1;
- } else {
- *tmpbuf = UTF8_TWO_BYTE_HI(ender);
- *(tmpbuf + 1) = UTF8_TWO_BYTE_LO(ender);
- foldlen = 2;
- }
- }
- else if (isASCII(ender)) { /* Note: Here can't also be LOC
- */
- ender = toLOWER(ender);
- *tmpbuf = (U8) ender;
- foldlen = 1;
- }
- else if (! MORE_ASCII_RESTRICTED && ! LOC) {
+ /* Point to the first byte of the final character */
+ s = (char *) utf8_hop((U8 *) s, -1);
- /* Locale and /aa require more selectivity about the
- * fold, so are handled below. Otherwise, here, just
- * use the fold */
- ender = toFOLD_uni(ender, tmpbuf, &foldlen);
- }
- else {
- /* Under locale rules or /aa we are not to mix,
- * respectively, ords < 256 or ASCII with non-. So
- * reject folds that mix them, using only the
- * non-folded code point. So do the fold to a
- * temporary, and inspect each character in it. */
- U8 trialbuf[UTF8_MAXBYTES_CASE+1];
- U8* s = trialbuf;
- UV tmpender = toFOLD_uni(ender, trialbuf, &foldlen);
- U8* e = s + foldlen;
- bool fold_ok = TRUE;
+ while (s >= s0) { /* Search backwards until find
+ non-problematic char */
+ if (UTF8_IS_INVARIANT(*s)) {
- while (s < e) {
- if (isASCII(*s)
- || (LOC && (UTF8_IS_INVARIANT(*s)
- || UTF8_IS_DOWNGRADEABLE_START(*s))))
- {
- fold_ok = FALSE;
- break;
- }
- s += UTF8SKIP(s);
- }
- if (fold_ok) {
- Copy(trialbuf, tmpbuf, foldlen, U8);
- ender = tmpender;
- }
- else {
- uvuni_to_utf8(tmpbuf, ender);
- foldlen = UNISKIP(ender);
- }
- }
+ /* There are no ascii characters that participate
+ * in multi-char folds under /aa. In EBCDIC, the
+ * non-ascii invariants are all control characters,
+ * so don't ever participate in any folds. */
+ if (ASCII_FOLD_RESTRICTED
+ || ! IS_NON_FINAL_FOLD(*s))
+ {
+ break;
+ }
+ }
+ else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
+
+ /* No Latin1 characters participate in multi-char
+ * folds under /l */
+ if (LOC
+ || ! IS_NON_FINAL_FOLD(TWO_BYTE_UTF8_TO_UNI(
+ *s, *(s+1))))
+ {
+ break;
+ }
+ }
+ else if (! _invlist_contains_cp(
+ PL_NonL1NonFinalFold,
+ valid_utf8_to_uvchr((U8 *) s, NULL)))
+ {
+ break;
+ }
+
+ /* Here, the current character is problematic in that
+ * it does occur in the non-final position of some
+ * fold, so try the character before it, but have to
+ * special case the very first byte in the string, so
+ * we don't read outside the string */
+ s = (s == s0) ? s -1 : (char *) utf8_hop((U8 *) s, -1);
+ } /* End of loop backwards through the string */
+
+ /* If there were only problematic characters in the string,
+ * <s> will point to before s0, in which case the length
+ * should be 0, otherwise include the length of the
+ * non-problematic character just found */
+ len = (s < s0) ? 0 : s - s0 + UTF8SKIP(s);
}
- if (p < RExC_end && ISMULT2(p)) { /* Back off on ?+*. */
- if (len)
- p = oldp;
- else if (UTF) {
- if (FOLD) {
- /* Emit all the Unicode characters. */
- STRLEN numlen;
- for (foldbuf = tmpbuf;
- foldlen;
- foldlen -= numlen) {
- ender = utf8_to_uvchr(foldbuf, &numlen);
- if (numlen > 0) {
- const STRLEN unilen = reguni(pRExC_state, ender, s);
- s += unilen;
- len += unilen;
- /* In EBCDIC the numlen
- * and unilen can differ. */
- foldbuf += numlen;
- if (numlen >= foldlen)
- break;
- }
- else
- break; /* "Can't happen." */
- }
- }
- else {
- const STRLEN unilen = reguni(pRExC_state, ender, s);
- if (unilen > 0) {
- s += unilen;
- len += unilen;
- }
- }
- }
- else {
- len++;
- REGC((char)ender, s++);
- }
- break;
- }
- if (UTF) {
- if (FOLD) {
- /* Emit all the Unicode characters. */
- STRLEN numlen;
- for (foldbuf = tmpbuf;
- foldlen;
- foldlen -= numlen) {
- ender = utf8_to_uvchr(foldbuf, &numlen);
- if (numlen > 0) {
- const STRLEN unilen = reguni(pRExC_state, ender, s);
- len += unilen;
- s += unilen;
- /* In EBCDIC the numlen
- * and unilen can differ. */
- foldbuf += numlen;
- if (numlen >= foldlen)
- break;
- }
- else
- break;
- }
- }
- else {
- const STRLEN unilen = reguni(pRExC_state, ender, s);
- if (unilen > 0) {
- s += unilen;
- len += unilen;
- }
- }
- len--;
- }
- else {
- REGC((char)ender, s++);
- }
- }
+
+ /* Here, have found the final character, if any, that is
+ * non-problematic as far as ending the node without splitting
+ * it across a potential multi-char fold. <len> contains the
+ * number of bytes in the node up-to and including that
+ * character, or is 0 if there is no such character, meaning
+ * the whole node contains only problematic characters. In
+ * this case, give up and just take the node as-is. We can't
+ * do any better */
+ if (len == 0) {
+ len = full_len;
+ } else {
+
+ /* Here, the node does contain some characters that aren't
+ * problematic. If one such is the final character in the
+ * node, we are done */
+ if (len == full_len) {
+ goto loopdone;
+ }
+ else if (len + ((UTF) ? UTF8SKIP(s) : 1) == full_len) {
+
+ /* If the final character is problematic, but the
+ * penultimate is not, back-off that last character to
+ * later start a new node with it */
+ p = oldp;
+ goto loopdone;
+ }
+
+ /* Here, the final non-problematic character is earlier
+ * in the input than the penultimate character. What we do
+ * is reparse from the beginning, going up only as far as
+ * this final ok one, thus guaranteeing that the node ends
+ * in an acceptable character. The reason we reparse is
+ * that we know how far in the character is, but we don't
+ * know how to correlate its position with the input parse.
+ * An alternate implementation would be to build that
+ * correlation as we go along during the original parse,
+ * but that would entail extra work for every node, whereas
+ * this code gets executed only when the string is too
+ * large for the node, and the final two characters are
+ * problematic, an infrequent occurrence. Yet another
+ * possible strategy would be to save the tail of the
+ * string, and the next time regatom is called, initialize
+ * with that. The problem with this is that unless you
+ * back off one more character, you won't be guaranteed
+ * regatom will get called again, unless regbranch,
+ * regpiece ... are also changed. If you do back off that
+ * extra character, so that there is input guaranteed to
+ * force calling regatom, you can't handle the case where
+ * just the first character in the node is acceptable. I
+ * (khw) decided to try this method which doesn't have that
+ * pitfall; if performance issues are found, we can do a
+ * combination of the current approach plus that one */
+ upper_parse = len;
+ len = 0;
+ s = s0;
+ goto reparse;
+ }
+ } /* End of verifying node ends with an appropriate char */
+
loopdone: /* Jumped to when encounters something that shouldn't be in
the node */
+
+ /* If 'maybe_exact' is still set here, means there are no
+ * code points in the node that participate in folds */
+ if (FOLD && maybe_exact) {
+ OP(ret) = EXACT;
+ }
+
+ /* I (khw) don't know if you can get here with zero length, but the
+ * old code handled this situation by creating a zero-length EXACT
+ * node. Might as well be NOTHING instead */
+ if (len == 0) {
+ OP(ret) = NOTHING;
+ }
+ else{
+ alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, len, ender);
+ }
+
RExC_parse = p - 1;
Set_Node_Cur_Length(ret); /* MJD */
nextchar(pRExC_state);
@@ -8991,27 +11308,12 @@
if (iv < 0)
vFAIL("Internal disaster");
}
- if (len > 0)
- *flagp |= HASWIDTH;
- if (len == 1 && UNI_IS_INVARIANT(ender))
- *flagp |= SIMPLE;
-
- if (SIZE_ONLY)
- RExC_size += STR_SZ(len);
- else {
- STR_LEN(ret) = len;
- RExC_emit += STR_SZ(len);
- }
- }
+
+ } /* End of label 'defchar:' */
break;
- }
+ } /* End of giant switch on input character */
return(ret);
-
-/* Jumped to when an unrecognized character set is encountered */
-bad_charset:
- Perl_croak(aTHX_ "panic: Unknown regex character set encoding: %u", get_regex_charset(RExC_flags));
- return(NULL);
}
STATIC char *
@@ -9041,6 +11343,40 @@
return p;
}
+STATIC char *
+S_regpatws( RExC_state_t *pRExC_state, char *p , const bool recognize_comment )
+{
+ /* Returns the next non-pattern-white space, non-comment character (the
+ * latter only if 'recognize_comment is true) in the string p, which is
+ * ended by RExC_end. If there is no line break ending a comment,
+ * RExC_seen has added the REG_SEEN_RUN_ON_COMMENT flag; */
+ const char *e = RExC_end;
+
+ PERL_ARGS_ASSERT_REGPATWS;
+
+ while (p < e) {
+ STRLEN len;
+ if ((len = is_PATWS_safe(p, e, UTF))) {
+ p += len;
+ }
+ else if (recognize_comment && *p == '#') {
+ bool ended = 0;
+ do {
+ p++;
+ if (is_LNBREAK_safe(p, e, UTF)) {
+ ended = 1;
+ break;
+ }
+ } while (p < e);
+ if (!ended)
+ RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
+ }
+ else
+ break;
+ }
+ return p;
+}
+
/* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
Character classes ([:foo:]) can also be negated ([:^foo:]).
Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
@@ -9051,8 +11387,8 @@
#define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
#define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
-STATIC I32
-S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value)
+PERL_STATIC_INLINE I32
+S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value, const bool strict)
{
dVAR;
I32 namedclass = OOB_NAMEDCLASS;
@@ -9061,15 +11397,27 @@
if (value == '[' && RExC_parse + 1 < RExC_end &&
/* I smell either [: or [= or [. -- POSIX has been here, right? */
- POSIXCC(UCHARAT(RExC_parse))) {
+ POSIXCC(UCHARAT(RExC_parse)))
+ {
const char c = UCHARAT(RExC_parse);
char* const s = RExC_parse++;
-
+
while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
RExC_parse++;
- if (RExC_parse == RExC_end)
+ if (RExC_parse == RExC_end) {
+ if (strict) {
+
+ /* Try to give a better location for the error (than the end of
+ * the string) by looking for the matching ']' */
+ RExC_parse = s;
+ while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
+ RExC_parse++;
+ }
+ vFAIL2("Unmatched '%c' in POSIX class", c);
+ }
/* Grandfather lone [:, [=, [. */
RExC_parse = s;
+ }
else {
const char* const t = RExC_parse++; /* skip over the c */
assert(*t == c);
@@ -9085,8 +11433,10 @@
/* Initially switch on the length of the name. */
switch (skip) {
case 4:
- if (memEQ(posixcc, "word", 4)) /* this is not POSIX, this is the Perl \w */
- namedclass = complement ? ANYOF_NALNUM : ANYOF_ALNUM;
+ if (memEQ(posixcc, "word", 4)) /* this is not POSIX,
+ this is the Perl \w
+ */
+ namedclass = ANYOF_WORDCHAR;
break;
case 5:
/* Names all of length 5. */
@@ -9096,51 +11446,51 @@
switch (posixcc[4]) {
case 'a':
if (memEQ(posixcc, "alph", 4)) /* alpha */
- namedclass = complement ? ANYOF_NALPHA : ANYOF_ALPHA;
+ namedclass = ANYOF_ALPHA;
break;
case 'e':
if (memEQ(posixcc, "spac", 4)) /* space */
- namedclass = complement ? ANYOF_NPSXSPC : ANYOF_PSXSPC;
+ namedclass = ANYOF_PSXSPC;
break;
case 'h':
if (memEQ(posixcc, "grap", 4)) /* graph */
- namedclass = complement ? ANYOF_NGRAPH : ANYOF_GRAPH;
+ namedclass = ANYOF_GRAPH;
break;
case 'i':
if (memEQ(posixcc, "asci", 4)) /* ascii */
- namedclass = complement ? ANYOF_NASCII : ANYOF_ASCII;
+ namedclass = ANYOF_ASCII;
break;
case 'k':
if (memEQ(posixcc, "blan", 4)) /* blank */
- namedclass = complement ? ANYOF_NBLANK : ANYOF_BLANK;
+ namedclass = ANYOF_BLANK;
break;
case 'l':
if (memEQ(posixcc, "cntr", 4)) /* cntrl */
- namedclass = complement ? ANYOF_NCNTRL : ANYOF_CNTRL;
+ namedclass = ANYOF_CNTRL;
break;
case 'm':
if (memEQ(posixcc, "alnu", 4)) /* alnum */
- namedclass = complement ? ANYOF_NALNUMC : ANYOF_ALNUMC;
+ namedclass = ANYOF_ALPHANUMERIC;
break;
case 'r':
if (memEQ(posixcc, "lowe", 4)) /* lower */
- namedclass = complement ? ANYOF_NLOWER : ANYOF_LOWER;
+ namedclass = (FOLD) ? ANYOF_CASED : ANYOF_LOWER;
else if (memEQ(posixcc, "uppe", 4)) /* upper */
- namedclass = complement ? ANYOF_NUPPER : ANYOF_UPPER;
+ namedclass = (FOLD) ? ANYOF_CASED : ANYOF_UPPER;
break;
case 't':
if (memEQ(posixcc, "digi", 4)) /* digit */
- namedclass = complement ? ANYOF_NDIGIT : ANYOF_DIGIT;
+ namedclass = ANYOF_DIGIT;
else if (memEQ(posixcc, "prin", 4)) /* print */
- namedclass = complement ? ANYOF_NPRINT : ANYOF_PRINT;
+ namedclass = ANYOF_PRINT;
else if (memEQ(posixcc, "punc", 4)) /* punct */
- namedclass = complement ? ANYOF_NPUNCT : ANYOF_PUNCT;
+ namedclass = ANYOF_PUNCT;
break;
}
break;
case 6:
if (memEQ(posixcc, "xdigit", 6))
- namedclass = complement ? ANYOF_NXDIGIT : ANYOF_XDIGIT;
+ namedclass = ANYOF_XDIGIT;
break;
}
@@ -9147,6 +11497,12 @@
if (namedclass == OOB_NAMEDCLASS)
Simple_vFAIL3("POSIX class [:%.*s:] unknown",
t - s - 1, s + 1);
+
+ /* The #defines are structured so each complement is +1 to
+ * the normal one */
+ if (complement) {
+ namedclass++;
+ }
assert (posixcc[skip] == ':');
assert (posixcc[skip+1] == ']');
} else if (!SIZE_ONLY) {
@@ -9156,11 +11512,16 @@
the class closes */
while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
RExC_parse++;
- Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
+ vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
}
} else {
/* Maternal grandfather:
* "[:" ending in ":" but not in ":]" */
+ if (strict) {
+ vFAIL("Unmatched '[' in POSIX class");
+ }
+
+ /* Grandfather lone [:, [=, [. */
RExC_parse = s;
}
}
@@ -9169,347 +11530,644 @@
return namedclass;
}
-STATIC void
-S_checkposixcc(pTHX_ RExC_state_t *pRExC_state)
+STATIC bool
+S_could_it_be_a_POSIX_class(pTHX_ RExC_state_t *pRExC_state)
{
- dVAR;
+ /* This applies some heuristics at the current parse position (which should
+ * be at a '[') to see if what follows might be intended to be a [:posix:]
+ * class. It returns true if it really is a posix class, of course, but it
+ * also can return true if it thinks that what was intended was a posix
+ * class that didn't quite make it.
+ *
+ * It will return true for
+ * [:alphanumerics:
+ * [:alphanumerics] (as long as the ] isn't followed immediately by a
+ * ')' indicating the end of the (?[
+ * [:any garbage including %^&$ punctuation:]
+ *
+ * This is designed to be called only from S_handle_regex_sets; it could be
+ * easily adapted to be called from the spot at the beginning of regclass()
+ * that checks to see in a normal bracketed class if the surrounding []
+ * have been omitted ([:word:] instead of [[:word:]]). But doing so would
+ * change long-standing behavior, so I (khw) didn't do that */
+ char* p = RExC_parse + 1;
+ char first_char = *p;
- PERL_ARGS_ASSERT_CHECKPOSIXCC;
+ PERL_ARGS_ASSERT_COULD_IT_BE_A_POSIX_CLASS;
- if (POSIXCC(UCHARAT(RExC_parse))) {
- const char *s = RExC_parse;
- const char c = *s++;
+ assert(*(p - 1) == '[');
- while (isALNUM(*s))
- s++;
- if (*s && c == *s && s[1] == ']') {
- ckWARN3reg(s+2,
- "POSIX syntax [%c %c] belongs inside character classes",
- c, c);
+ if (! POSIXCC(first_char)) {
+ return FALSE;
+ }
- /* [[=foo=]] and [[.foo.]] are still future. */
- if (POSIXCC_NOTYET(c)) {
- /* adjust RExC_parse so the error shows after
- the class closes */
- while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse++) != ']')
- NOOP;
- Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
- }
- }
+ p++;
+ while (p < RExC_end && isWORDCHAR(*p)) p++;
+
+ if (p >= RExC_end) {
+ return FALSE;
}
-}
-/* No locale test, and always Unicode semantics */
-#define _C_C_T_NOLOC_(NAME,TEST,WORD) \
-ANYOF_##NAME: \
- for (value = 0; value < 256; value++) \
- if (TEST) \
- stored += set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate); \
- yesno = '+'; \
- what = WORD; \
- break; \
-case ANYOF_N##NAME: \
- for (value = 0; value < 256; value++) \
- if (!TEST) \
- stored += set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate); \
- yesno = '!'; \
- what = WORD; \
- break
+ if (p - RExC_parse > 2 /* Got at least 1 word character */
+ && (*p == first_char
+ || (*p == ']' && p + 1 < RExC_end && *(p + 1) != ')')))
+ {
+ return TRUE;
+ }
-/* Like the above, but there are differences if we are in uni-8-bit or not, so
- * there are two tests passed in, to use depending on that. There aren't any
- * cases where the label is different from the name, so no need for that
- * parameter */
-#define _C_C_T_(NAME, TEST_8, TEST_7, WORD) \
-ANYOF_##NAME: \
- if (LOC) ANYOF_CLASS_SET(ret, ANYOF_##NAME); \
- else if (UNI_SEMANTICS) { \
- for (value = 0; value < 256; value++) { \
- if (TEST_8(value)) stored += \
- set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate); \
- } \
- } \
- else { \
- for (value = 0; value < 128; value++) { \
- if (TEST_7(UNI_TO_NATIVE(value))) stored += \
- set_regclass_bit(pRExC_state, ret, \
- (U8) UNI_TO_NATIVE(value), &l1_fold_invlist, &unicode_alternate); \
- } \
- } \
- yesno = '+'; \
- what = WORD; \
- break; \
-case ANYOF_N##NAME: \
- if (LOC) ANYOF_CLASS_SET(ret, ANYOF_N##NAME); \
- else if (UNI_SEMANTICS) { \
- for (value = 0; value < 256; value++) { \
- if (! TEST_8(value)) stored += \
- set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate); \
- } \
- } \
- else { \
- for (value = 0; value < 128; value++) { \
- if (! TEST_7(UNI_TO_NATIVE(value))) stored += set_regclass_bit( \
- pRExC_state, ret, (U8) UNI_TO_NATIVE(value), &l1_fold_invlist, &unicode_alternate); \
- } \
- if (AT_LEAST_ASCII_RESTRICTED) { \
- for (value = 128; value < 256; value++) { \
- stored += set_regclass_bit( \
- pRExC_state, ret, (U8) UNI_TO_NATIVE(value), &l1_fold_invlist, &unicode_alternate); \
- } \
- ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL; \
- } \
- else { \
- /* For a non-ut8 target string with DEPENDS semantics, all above \
- * ASCII Latin1 code points match the complement of any of the \
- * classes. But in utf8, they have their Unicode semantics, so \
- * can't just set them in the bitmap, or else regexec.c will think \
- * they matched when they shouldn't. */ \
- ANYOF_FLAGS(ret) |= ANYOF_NON_UTF8_LATIN1_ALL; \
- } \
- } \
- yesno = '!'; \
- what = WORD; \
- break
+ p = (char *) memchr(RExC_parse, ']', RExC_end - RExC_parse);
-STATIC U8
-S_set_regclass_bit_fold(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, HV** invlist_ptr, AV** alternate_ptr)
+ return (p
+ && p - RExC_parse > 2 /* [:] evaluates to colon;
+ [::] is a bad posix class. */
+ && first_char == *(p - 1));
+}
+
+STATIC regnode *
+S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist, I32 *flagp, U32 depth,
+ char * const oregcomp_parse)
{
+ /* Handle the (?[...]) construct to do set operations */
- /* Handle the setting of folds in the bitmap for non-locale ANYOF nodes.
- * Locale folding is done at run-time, so this function should not be
- * called for nodes that are for locales.
+ U8 curchar;
+ UV start, end; /* End points of code point ranges */
+ SV* result_string;
+ char *save_end, *save_parse;
+ SV* final;
+ STRLEN len;
+ regnode* node;
+ AV* stack;
+ const bool save_fold = FOLD;
+
+ GET_RE_DEBUG_FLAGS_DECL;
+
+ PERL_ARGS_ASSERT_HANDLE_REGEX_SETS;
+
+ if (LOC) {
+ vFAIL("(?[...]) not valid in locale");
+ }
+ RExC_uni_semantics = 1;
+
+ /* This will return only an ANYOF regnode, or (unlikely) something smaller
+ * (such as EXACT). Thus we can skip most everything if just sizing. We
+ * call regclass to handle '[]' so as to not have to reinvent its parsing
+ * rules here (throwing away the size it computes each time). And, we exit
+ * upon an unescaped ']' that isn't one ending a regclass. To do both
+ * these things, we need to realize that something preceded by a backslash
+ * is escaped, so we have to keep track of backslashes */
+ if (SIZE_ONLY) {
+
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__REGEX_SETS),
+ "The regex_sets feature is experimental" REPORT_LOCATION,
+ (int) (RExC_parse - RExC_precomp) , RExC_precomp, RExC_parse);
+
+ while (RExC_parse < RExC_end) {
+ SV* current = NULL;
+ RExC_parse = regpatws(pRExC_state, RExC_parse,
+ TRUE); /* means recognize comments */
+ switch (*RExC_parse) {
+ default:
+ break;
+ case '\\':
+ /* Skip the next byte (which could cause us to end up in
+ * the middle of a UTF-8 character, but since none of those
+ * are confusable with anything we currently handle in this
+ * switch (invariants all), it's safe. We'll just hit the
+ * default: case next time and keep on incrementing until
+ * we find one of the invariants we do handle. */
+ RExC_parse++;
+ break;
+ case '[':
+ {
+ /* If this looks like it is a [:posix:] class, leave the
+ * parse pointer at the '[' to fool regclass() into
+ * thinking it is part of a '[[:posix:]]'. That function
+ * will use strict checking to force a syntax error if it
+ * doesn't work out to a legitimate class */
+ bool is_posix_class
+ = could_it_be_a_POSIX_class(pRExC_state);
+ if (! is_posix_class) {
+ RExC_parse++;
+ }
+
+ /* regclass() can only return RESTART_UTF8 if multi-char
+ folds are allowed. */
+ if (!regclass(pRExC_state, flagp,depth+1,
+ is_posix_class, /* parse the whole char
+ class only if not a
+ posix class */
+ FALSE, /* don't allow multi-char folds */
+ TRUE, /* silence non-portable warnings. */
+ ¤t))
+ FAIL2("panic: regclass returned NULL to handle_sets, flags=%#X",
+ *flagp);
+
+ /* function call leaves parse pointing to the ']', except
+ * if we faked it */
+ if (is_posix_class) {
+ RExC_parse--;
+ }
+
+ SvREFCNT_dec(current); /* In case it returned something */
+ break;
+ }
+
+ case ']':
+ RExC_parse++;
+ if (RExC_parse < RExC_end
+ && *RExC_parse == ')')
+ {
+ node = reganode(pRExC_state, ANYOF, 0);
+ RExC_size += ANYOF_SKIP;
+ nextchar(pRExC_state);
+ Set_Node_Length(node,
+ RExC_parse - oregcomp_parse + 1); /* MJD */
+ return node;
+ }
+ goto no_close;
+ }
+ RExC_parse++;
+ }
+
+ no_close:
+ FAIL("Syntax error in (?[...])");
+ }
+
+ /* Pass 2 only after this. Everything in this construct is a
+ * metacharacter. Operands begin with either a '\' (for an escape
+ * sequence), or a '[' for a bracketed character class. Any other
+ * character should be an operator, or parenthesis for grouping. Both
+ * types of operands are handled by calling regclass() to parse them. It
+ * is called with a parameter to indicate to return the computed inversion
+ * list. The parsing here is implemented via a stack. Each entry on the
+ * stack is a single character representing one of the operators, or the
+ * '('; or else a pointer to an operand inversion list. */
+
+#define IS_OPERAND(a) (! SvIOK(a))
+
+ /* The stack starts empty. It is a syntax error if the first thing parsed
+ * is a binary operator; everything else is pushed on the stack. When an
+ * operand is parsed, the top of the stack is examined. If it is a binary
+ * operator, the item before it should be an operand, and both are replaced
+ * by the result of doing that operation on the new operand and the one on
+ * the stack. Thus a sequence of binary operands is reduced to a single
+ * one before the next one is parsed.
*
- * This function sets the bit corresponding to the fold of the input
- * 'value', if not already set. The fold of 'f' is 'F', and the fold of
- * 'F' is 'f'.
+ * A unary operator may immediately follow a binary in the input, for
+ * example
+ * [a] + ! [b]
+ * When an operand is parsed and the top of the stack is a unary operator,
+ * the operation is performed, and then the stack is rechecked to see if
+ * this new operand is part of a binary operation; if so, it is handled as
+ * above.
*
- * It also knows about the characters that are in the bitmap that have
- * folds that are matchable only outside it, and sets the appropriate lists
- * and flags.
- *
- * It returns the number of bits that actually changed from 0 to 1 */
+ * A '(' is simply pushed on the stack; it is valid only if the stack is
+ * empty, or the top element of the stack is an operator or another '('
+ * (for which the parenthesized expression will become an operand). By the
+ * time the corresponding ')' is parsed everything in between should have
+ * been parsed and evaluated to a single operand (or else is a syntax
+ * error), and is handled as a regular operand */
- U8 stored = 0;
- U8 fold;
+ sv_2mortal((SV *)(stack = newAV()));
- PERL_ARGS_ASSERT_SET_REGCLASS_BIT_FOLD;
+ while (RExC_parse < RExC_end) {
+ I32 top_index = av_tindex(stack);
+ SV** top_ptr;
+ SV* current = NULL;
- fold = (AT_LEAST_UNI_SEMANTICS) ? PL_fold_latin1[value]
- : PL_fold[value];
+ /* Skip white space */
+ RExC_parse = regpatws(pRExC_state, RExC_parse,
+ TRUE); /* means recognize comments */
+ if (RExC_parse >= RExC_end) {
+ Perl_croak(aTHX_ "panic: Read past end of '(?[ ])'");
+ }
+ if ((curchar = UCHARAT(RExC_parse)) == ']') {
+ break;
+ }
- /* It assumes the bit for 'value' has already been set */
- if (fold != value && ! ANYOF_BITMAP_TEST(node, fold)) {
- ANYOF_BITMAP_SET(node, fold);
- stored++;
- }
- if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(value) && (! isASCII(value) || ! MORE_ASCII_RESTRICTED)) {
- /* Certain Latin1 characters have matches outside the bitmap. To get
- * here, 'value' is one of those characters. None of these matches is
- * valid for ASCII characters under /aa, which have been excluded by
- * the 'if' above. The matches fall into three categories:
- * 1) They are singly folded-to or -from an above 255 character, as
- * LATIN SMALL LETTER Y WITH DIAERESIS and LATIN CAPITAL LETTER Y
- * WITH DIAERESIS;
- * 2) They are part of a multi-char fold with another character in the
- * bitmap, only LATIN SMALL LETTER SHARP S => "ss" fits that bill;
- * 3) They are part of a multi-char fold with a character not in the
- * bitmap, such as various ligatures.
- * We aren't dealing fully with multi-char folds, except we do deal
- * with the pattern containing a character that has a multi-char fold
- * (not so much the inverse).
- * For types 1) and 3), the matches only happen when the target string
- * is utf8; that's not true for 2), and we set a flag for it.
- *
- * The code below adds to the passed in inversion list the single fold
- * closures for 'value'. The values are hard-coded here so that an
- * innocent-looking character class, like /[ks]/i won't have to go out
- * to disk to find the possible matches. XXX It would be better to
- * generate these via regen, in case a new version of the Unicode
- * standard adds new mappings, though that is not really likely. */
- switch (value) {
- case 'k':
- case 'K':
- /* KELVIN SIGN */
- *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x212A);
- break;
- case 's':
- case 'S':
- /* LATIN SMALL LETTER LONG S */
- *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x017F);
- break;
- case MICRO_SIGN:
- *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
- GREEK_SMALL_LETTER_MU);
- *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
- GREEK_CAPITAL_LETTER_MU);
- break;
- case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
- case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
- /* ANGSTROM SIGN */
- *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x212B);
- if (DEPENDS_SEMANTICS) { /* See DEPENDS comment below */
- *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
- PL_fold_latin1[value]);
- }
- break;
- case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
- *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
- LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
- break;
- case LATIN_SMALL_LETTER_SHARP_S:
- *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
- LATIN_CAPITAL_LETTER_SHARP_S);
+ switch (curchar) {
- /* Under /a, /d, and /u, this can match the two chars "ss" */
- if (! MORE_ASCII_RESTRICTED) {
- add_alternate(alternate_ptr, (U8 *) "ss", 2);
+ case '?':
+ if (av_tindex(stack) >= 0 /* This makes sure that we can
+ safely subtract 1 from
+ RExC_parse in the next clause.
+ If we have something on the
+ stack, we have parsed something
+ */
+ && UCHARAT(RExC_parse - 1) == '('
+ && RExC_parse < RExC_end)
+ {
+ /* If is a '(?', could be an embedded '(?flags:(?[...])'.
+ * This happens when we have some thing like
+ *
+ * my $thai_or_lao = qr/(?[ \p{Thai} + \p{Lao} ])/;
+ * ...
+ * qr/(?[ \p{Digit} & $thai_or_lao ])/;
+ *
+ * Here we would be handling the interpolated
+ * '$thai_or_lao'. We handle this by a recursive call to
+ * ourselves which returns the inversion list the
+ * interpolated expression evaluates to. We use the flags
+ * from the interpolated pattern. */
+ U32 save_flags = RExC_flags;
+ const char * const save_parse = ++RExC_parse;
- /* And under /u or /a, it can match even if the target is
- * not utf8 */
- if (AT_LEAST_UNI_SEMANTICS) {
- ANYOF_FLAGS(node) |= ANYOF_NONBITMAP_NON_UTF8;
- }
- }
- break;
- case 'F': case 'f':
- case 'I': case 'i':
- case 'L': case 'l':
- case 'T': case 't':
- case 'A': case 'a':
- case 'H': case 'h':
- case 'J': case 'j':
- case 'N': case 'n':
- case 'W': case 'w':
- case 'Y': case 'y':
- /* These all are targets of multi-character folds from code
- * points that require UTF8 to express, so they can't match
- * unless the target string is in UTF-8, so no action here is
- * necessary, as regexec.c properly handles the general case
- * for UTF-8 matching */
- break;
- default:
- /* Use deprecated warning to increase the chances of this
- * being output */
- ckWARN2regdep(RExC_parse, "Perl folding rules are not up-to-date for 0x%x; please use the perlbug utility to report;", value);
- break;
- }
- }
- else if (DEPENDS_SEMANTICS
- && ! isASCII(value)
- && PL_fold_latin1[value] != value)
- {
- /* Under DEPENDS rules, non-ASCII Latin1 characters match their
- * folds only when the target string is in UTF-8. We add the fold
- * here to the list of things to match outside the bitmap, which
- * won't be looked at unless it is UTF8 (or else if something else
- * says to look even if not utf8, but those things better not happen
- * under DEPENDS semantics. */
- *invlist_ptr = add_cp_to_invlist(*invlist_ptr, PL_fold_latin1[value]);
- }
+ parse_lparen_question_flags(pRExC_state);
- return stored;
-}
+ if (RExC_parse == save_parse /* Makes sure there was at
+ least one flag (or this
+ embedding wasn't compiled)
+ */
+ || RExC_parse >= RExC_end - 4
+ || UCHARAT(RExC_parse) != ':'
+ || UCHARAT(++RExC_parse) != '('
+ || UCHARAT(++RExC_parse) != '?'
+ || UCHARAT(++RExC_parse) != '[')
+ {
+ /* In combination with the above, this moves the
+ * pointer to the point just after the first erroneous
+ * character (or if there are no flags, to where they
+ * should have been) */
+ if (RExC_parse >= RExC_end - 4) {
+ RExC_parse = RExC_end;
+ }
+ else if (RExC_parse != save_parse) {
+ RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
+ }
+ vFAIL("Expecting '(?flags:(?[...'");
+ }
+ RExC_parse++;
+ (void) handle_regex_sets(pRExC_state, ¤t, flagp,
+ depth+1, oregcomp_parse);
-PERL_STATIC_INLINE U8
-S_set_regclass_bit(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, HV** invlist_ptr, AV** alternate_ptr)
-{
- /* This inline function sets a bit in the bitmap if not already set, and if
- * appropriate, its fold, returning the number of bits that actually
- * changed from 0 to 1 */
+ /* Here, 'current' contains the embedded expression's
+ * inversion list, and RExC_parse points to the trailing
+ * ']'; the next character should be the ')' which will be
+ * paired with the '(' that has been put on the stack, so
+ * the whole embedded expression reduces to '(operand)' */
+ RExC_parse++;
- U8 stored;
+ RExC_flags = save_flags;
+ goto handle_operand;
+ }
+ /* FALL THROUGH */
- PERL_ARGS_ASSERT_SET_REGCLASS_BIT;
+ default:
+ RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
+ vFAIL("Unexpected character");
- if (ANYOF_BITMAP_TEST(node, value)) { /* Already set */
- return 0;
+ case '\\':
+ /* regclass() can only return RESTART_UTF8 if multi-char
+ folds are allowed. */
+ if (!regclass(pRExC_state, flagp,depth+1,
+ TRUE, /* means parse just the next thing */
+ FALSE, /* don't allow multi-char folds */
+ FALSE, /* don't silence non-portable warnings. */
+ ¤t))
+ FAIL2("panic: regclass returned NULL to handle_sets, flags=%#X",
+ *flagp);
+ /* regclass() will return with parsing just the \ sequence,
+ * leaving the parse pointer at the next thing to parse */
+ RExC_parse--;
+ goto handle_operand;
+
+ case '[': /* Is a bracketed character class */
+ {
+ bool is_posix_class = could_it_be_a_POSIX_class(pRExC_state);
+
+ if (! is_posix_class) {
+ RExC_parse++;
+ }
+
+ /* regclass() can only return RESTART_UTF8 if multi-char
+ folds are allowed. */
+ if(!regclass(pRExC_state, flagp,depth+1,
+ is_posix_class, /* parse the whole char class
+ only if not a posix class */
+ FALSE, /* don't allow multi-char folds */
+ FALSE, /* don't silence non-portable warnings. */
+ ¤t))
+ FAIL2("panic: regclass returned NULL to handle_sets, flags=%#X",
+ *flagp);
+ /* function call leaves parse pointing to the ']', except if we
+ * faked it */
+ if (is_posix_class) {
+ RExC_parse--;
+ }
+
+ goto handle_operand;
+ }
+
+ case '&':
+ case '|':
+ case '+':
+ case '-':
+ case '^':
+ if (top_index < 0
+ || ( ! (top_ptr = av_fetch(stack, top_index, FALSE)))
+ || ! IS_OPERAND(*top_ptr))
+ {
+ RExC_parse++;
+ vFAIL2("Unexpected binary operator '%c' with no preceding operand", curchar);
+ }
+ av_push(stack, newSVuv(curchar));
+ break;
+
+ case '!':
+ av_push(stack, newSVuv(curchar));
+ break;
+
+ case '(':
+ if (top_index >= 0) {
+ top_ptr = av_fetch(stack, top_index, FALSE);
+ assert(top_ptr);
+ if (IS_OPERAND(*top_ptr)) {
+ RExC_parse++;
+ vFAIL("Unexpected '(' with no preceding operator");
+ }
+ }
+ av_push(stack, newSVuv(curchar));
+ break;
+
+ case ')':
+ {
+ SV* lparen;
+ if (top_index < 1
+ || ! (current = av_pop(stack))
+ || ! IS_OPERAND(current)
+ || ! (lparen = av_pop(stack))
+ || IS_OPERAND(lparen)
+ || SvUV(lparen) != '(')
+ {
+ SvREFCNT_dec(current);
+ RExC_parse++;
+ vFAIL("Unexpected ')'");
+ }
+ top_index -= 2;
+ SvREFCNT_dec_NN(lparen);
+
+ /* FALL THROUGH */
+ }
+
+ handle_operand:
+
+ /* Here, we have an operand to process, in 'current' */
+
+ if (top_index < 0) { /* Just push if stack is empty */
+ av_push(stack, current);
+ }
+ else {
+ SV* top = av_pop(stack);
+ SV *prev = NULL;
+ char current_operator;
+
+ if (IS_OPERAND(top)) {
+ SvREFCNT_dec_NN(top);
+ SvREFCNT_dec_NN(current);
+ vFAIL("Operand with no preceding operator");
+ }
+ current_operator = (char) SvUV(top);
+ switch (current_operator) {
+ case '(': /* Push the '(' back on followed by the new
+ operand */
+ av_push(stack, top);
+ av_push(stack, current);
+ SvREFCNT_inc(top); /* Counters the '_dec' done
+ just after the 'break', so
+ it doesn't get wrongly freed
+ */
+ break;
+
+ case '!':
+ _invlist_invert(current);
+
+ /* Unlike binary operators, the top of the stack,
+ * now that this unary one has been popped off, may
+ * legally be an operator, and we now have operand
+ * for it. */
+ top_index--;
+ SvREFCNT_dec_NN(top);
+ goto handle_operand;
+
+ case '&':
+ prev = av_pop(stack);
+ _invlist_intersection(prev,
+ current,
+ ¤t);
+ av_push(stack, current);
+ break;
+
+ case '|':
+ case '+':
+ prev = av_pop(stack);
+ _invlist_union(prev, current, ¤t);
+ av_push(stack, current);
+ break;
+
+ case '-':
+ prev = av_pop(stack);;
+ _invlist_subtract(prev, current, ¤t);
+ av_push(stack, current);
+ break;
+
+ case '^': /* The union minus the intersection */
+ {
+ SV* i = NULL;
+ SV* u = NULL;
+ SV* element;
+
+ prev = av_pop(stack);
+ _invlist_union(prev, current, &u);
+ _invlist_intersection(prev, current, &i);
+ /* _invlist_subtract will overwrite current
+ without freeing what it already contains */
+ element = current;
+ _invlist_subtract(u, i, ¤t);
+ av_push(stack, current);
+ SvREFCNT_dec_NN(i);
+ SvREFCNT_dec_NN(u);
+ SvREFCNT_dec_NN(element);
+ break;
+ }
+
+ default:
+ Perl_croak(aTHX_ "panic: Unexpected item on '(?[ ])' stack");
+ }
+ SvREFCNT_dec_NN(top);
+ SvREFCNT_dec(prev);
+ }
+ }
+
+ RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
}
- ANYOF_BITMAP_SET(node, value);
- stored = 1;
+ if (av_tindex(stack) < 0 /* Was empty */
+ || ((final = av_pop(stack)) == NULL)
+ || ! IS_OPERAND(final)
+ || av_tindex(stack) >= 0) /* More left on stack */
+ {
+ vFAIL("Incomplete expression within '(?[ ])'");
+ }
- if (FOLD && ! LOC) { /* Locale folds aren't known until runtime */
- stored += set_regclass_bit_fold(pRExC_state, node, value, invlist_ptr, alternate_ptr);
+ /* Here, 'final' is the resultant inversion list from evaluating the
+ * expression. Return it if so requested */
+ if (return_invlist) {
+ *return_invlist = final;
+ return END;
}
- return stored;
-}
+ /* Otherwise generate a resultant node, based on 'final'. regclass() is
+ * expecting a string of ranges and individual code points */
+ invlist_iterinit(final);
+ result_string = newSVpvs("");
+ while (invlist_iternext(final, &start, &end)) {
+ if (start == end) {
+ Perl_sv_catpvf(aTHX_ result_string, "\\x{%"UVXf"}", start);
+ }
+ else {
+ Perl_sv_catpvf(aTHX_ result_string, "\\x{%"UVXf"}-\\x{%"UVXf"}",
+ start, end);
+ }
+ }
-STATIC void
-S_add_alternate(pTHX_ AV** alternate_ptr, U8* string, STRLEN len)
-{
- /* Adds input 'string' with length 'len' to the ANYOF node's unicode
- * alternate list, pointed to by 'alternate_ptr'. This is an array of
- * the multi-character folds of characters in the node */
- SV *sv;
+ save_parse = RExC_parse;
+ RExC_parse = SvPV(result_string, len);
+ save_end = RExC_end;
+ RExC_end = RExC_parse + len;
- PERL_ARGS_ASSERT_ADD_ALTERNATE;
+ /* We turn off folding around the call, as the class we have constructed
+ * already has all folding taken into consideration, and we don't want
+ * regclass() to add to that */
+ RExC_flags &= ~RXf_PMf_FOLD;
+ /* regclass() can only return RESTART_UTF8 if multi-char folds are allowed.
+ */
+ node = regclass(pRExC_state, flagp,depth+1,
+ FALSE, /* means parse the whole char class */
+ FALSE, /* don't allow multi-char folds */
+ TRUE, /* silence non-portable warnings. The above may very
+ well have generated non-portable code points, but
+ they're valid on this machine */
+ NULL);
+ if (!node)
+ FAIL2("panic: regclass returned NULL to handle_sets, flags=%#"UVxf,
+ PTR2UV(flagp));
+ if (save_fold) {
+ RExC_flags |= RXf_PMf_FOLD;
+ }
+ RExC_parse = save_parse + 1;
+ RExC_end = save_end;
+ SvREFCNT_dec_NN(final);
+ SvREFCNT_dec_NN(result_string);
- if (! *alternate_ptr) {
- *alternate_ptr = newAV();
- }
- sv = newSVpvn_utf8((char*)string, len, TRUE);
- av_push(*alternate_ptr, sv);
- return;
+ nextchar(pRExC_state);
+ Set_Node_Length(node, RExC_parse - oregcomp_parse + 1); /* MJD */
+ return node;
}
+#undef IS_OPERAND
-/*
- parse a class specification and produce either an ANYOF node that
- matches the pattern or perhaps will be optimized into an EXACTish node
- instead. The node contains a bit map for the first 256 characters, with the
- corresponding bit set if that character is in the list. For characters
- above 255, a range list is used */
+/* The names of properties whose definitions are not known at compile time are
+ * stored in this SV, after a constant heading. So if the length has been
+ * changed since initialization, then there is a run-time definition. */
+#define HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION (SvCUR(listsv) != initial_listsv_len)
STATIC regnode *
-S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth)
+S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth,
+ const bool stop_at_1, /* Just parse the next thing, don't
+ look for a full character class */
+ bool allow_multi_folds,
+ const bool silence_non_portable, /* Don't output warnings
+ about too large
+ characters */
+ SV** ret_invlist) /* Return an inversion list, not a node */
{
+ /* parse a bracketed class specification. Most of these will produce an
+ * ANYOF node; but something like [a] will produce an EXACT node; [aA], an
+ * EXACTFish node; [[:ascii:]], a POSIXA node; etc. It is more complex
+ * under /i with multi-character folds: it will be rewritten following the
+ * paradigm of this example, where the <multi-fold>s are characters which
+ * fold to multiple character sequences:
+ * /[abc\x{multi-fold1}def\x{multi-fold2}ghi]/i
+ * gets effectively rewritten as:
+ * /(?:\x{multi-fold1}|\x{multi-fold2}|[abcdefghi]/i
+ * reg() gets called (recursively) on the rewritten version, and this
+ * function will return what it constructs. (Actually the <multi-fold>s
+ * aren't physically removed from the [abcdefghi], it's just that they are
+ * ignored in the recursion by means of a flag:
+ * <RExC_in_multi_char_class>.)
+ *
+ * ANYOF nodes contain a bit map for the first 256 characters, with the
+ * corresponding bit set if that character is in the list. For characters
+ * above 255, a range list or swash is used. There are extra bits for \w,
+ * etc. in locale ANYOFs, as what these match is not determinable at
+ * compile time
+ *
+ * Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs
+ * to be restarted. This can only happen if ret_invlist is non-NULL.
+ */
+
dVAR;
- register UV nextvalue;
- register IV prevvalue = OOB_UNICODE;
- register IV range = 0;
- UV value = 0; /* XXX:dmq: needs to be referenceable (unfortunately) */
- register regnode *ret;
+ UV prevvalue = OOB_UNICODE, save_prevvalue = OOB_UNICODE;
+ IV range = 0;
+ UV value = OOB_UNICODE, save_value = OOB_UNICODE;
+ regnode *ret;
STRLEN numlen;
- IV namedclass;
+ IV namedclass = OOB_NAMEDCLASS;
char *rangebegin = NULL;
bool need_class = 0;
- bool allow_full_fold = TRUE; /* Assume wants multi-char folding */
SV *listsv = NULL;
STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
than just initialized. */
+ SV* properties = NULL; /* Code points that match \p{} \P{} */
+ SV* posixes = NULL; /* Code points that match classes like, [:word:],
+ extended beyond the Latin1 range */
+ UV element_count = 0; /* Number of distinct elements in the class.
+ Optimizations may be possible if this is tiny */
+ AV * multi_char_matches = NULL; /* Code points that fold to more than one
+ character; used under /i */
UV n;
+ char * stop_ptr = RExC_end; /* where to stop parsing */
+ const bool skip_white = cBOOL(ret_invlist); /* ignore unescaped white
+ space? */
+ const bool strict = cBOOL(ret_invlist); /* Apply strict parsing rules? */
- /* code points this node matches that can't be stored in the bitmap */
- HV* nonbitmap = NULL;
+ /* Unicode properties are stored in a swash; this holds the current one
+ * being parsed. If this swash is the only above-latin1 component of the
+ * character class, an optimization is to pass it directly on to the
+ * execution engine. Otherwise, it is set to NULL to indicate that there
+ * are other things in the class that have to be dealt with at execution
+ * time */
+ SV* swash = NULL; /* Code points that match \p{} \P{} */
- /* The items that are to match that aren't stored in the bitmap, but are a
- * result of things that are stored there. This is the fold closure of
- * such a character, either because it has DEPENDS semantics and shouldn't
- * be matched unless the target string is utf8, or is a code point that is
- * too large for the bit map, as for example, the fold of the MICRO SIGN is
- * above 255. This all is solely for performance reasons. By having this
- * code know the outside-the-bitmap folds that the bitmapped characters are
- * involved with, we don't have to go out to disk to find the list of
- * matches, unless the character class includes code points that aren't
- * storable in the bit map. That means that a character class with an 's'
- * in it, for example, doesn't need to go out to disk to find everything
- * that matches. A 2nd list is used so that the 'nonbitmap' list is kept
- * empty unless there is something whose fold we don't know about, and will
- * have to go out to the disk to find. */
- HV* l1_fold_invlist = NULL;
+ /* Set if a component of this character class is user-defined; just passed
+ * on to the engine */
+ bool has_user_defined_property = FALSE;
- /* List of multi-character folds that are matched by this node */
- AV* unicode_alternate = NULL;
+ /* inversion list of code points this node matches only when the target
+ * string is in UTF-8. (Because is under /d) */
+ SV* depends_list = NULL;
+
+ /* inversion list of code points this node matches. For much of the
+ * function, it includes only those that match regardless of the utf8ness
+ * of the target string */
+ SV* cp_list = NULL;
+
#ifdef EBCDIC
+ /* In a range, counts how many 0-2 of the ends of it came from literals,
+ * not escapes. Thus we can tell if 'A' was input vs \x{C1} */
UV literal_endpoint = 0;
#endif
- UV stored = 0; /* how many chars stored in the bitmap */
+ bool invert = FALSE; /* Is this class to be complemented */
+ /* Is there any thing like \W or [:^digit:] that matches above the legal
+ * Unicode range? */
+ bool runtime_posix_matches_above_Unicode = FALSE;
+
regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
case we need to change the emitted regop to an EXACT. */
const char * orig_parse = RExC_parse;
+ const I32 orig_size = RExC_size;
GET_RE_DEBUG_FLAGS_DECL;
PERL_ARGS_ASSERT_REGCLASS;
@@ -9522,60 +12180,89 @@
/* Assume we are going to generate an ANYOF node. */
ret = reganode(pRExC_state, ANYOF, 0);
-
- if (!SIZE_ONLY) {
- ANYOF_FLAGS(ret) = 0;
- }
-
- if (UCHARAT(RExC_parse) == '^') { /* Complement of range. */
- RExC_naughty++;
- RExC_parse++;
- if (!SIZE_ONLY)
- ANYOF_FLAGS(ret) |= ANYOF_INVERT;
-
- /* We have decided to not allow multi-char folds in inverted character
- * classes, due to the confusion that can happen, even with classes
- * that are designed for a non-Unicode world: You have the peculiar
- * case that:
- "s s" =~ /^[^\xDF]+$/i => Y
- "ss" =~ /^[^\xDF]+$/i => N
- *
- * See [perl #89750] */
- allow_full_fold = FALSE;
- }
-
if (SIZE_ONLY) {
RExC_size += ANYOF_SKIP;
listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
}
else {
+ ANYOF_FLAGS(ret) = 0;
+
RExC_emit += ANYOF_SKIP;
if (LOC) {
ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
}
- ANYOF_BITMAP_ZERO(ret);
- listsv = newSVpvs("# comment\n");
+ listsv = newSVpvs_flags("# comment\n", SVs_TEMP);
initial_listsv_len = SvCUR(listsv);
+ SvTEMP_off(listsv); /* Grr, TEMPs and mortals are conflated. */
}
- nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
+ if (skip_white) {
+ RExC_parse = regpatws(pRExC_state, RExC_parse,
+ FALSE /* means don't recognize comments */);
+ }
- if (!SIZE_ONLY && POSIXCC(nextvalue))
- checkposixcc(pRExC_state);
+ if (UCHARAT(RExC_parse) == '^') { /* Complement of range. */
+ RExC_parse++;
+ invert = TRUE;
+ allow_multi_folds = FALSE;
+ RExC_naughty++;
+ if (skip_white) {
+ RExC_parse = regpatws(pRExC_state, RExC_parse,
+ FALSE /* means don't recognize comments */);
+ }
+ }
- /* allow 1st char to be ] (allowing it to be - is dealt with later) */
+ /* Check that they didn't say [:posix:] instead of [[:posix:]] */
+ if (!SIZE_ONLY && RExC_parse < RExC_end && POSIXCC(UCHARAT(RExC_parse))) {
+ const char *s = RExC_parse;
+ const char c = *s++;
+
+ while (isWORDCHAR(*s))
+ s++;
+ if (*s && c == *s && s[1] == ']') {
+ SAVEFREESV(RExC_rx_sv);
+ ckWARN3reg(s+2,
+ "POSIX syntax [%c %c] belongs inside character classes",
+ c, c);
+ (void)ReREFCNT_inc(RExC_rx_sv);
+ }
+ }
+
+ /* If the caller wants us to just parse a single element, accomplish this
+ * by faking the loop ending condition */
+ if (stop_at_1 && RExC_end > RExC_parse) {
+ stop_ptr = RExC_parse + 1;
+ }
+
+ /* allow 1st char to be ']' (allowing it to be '-' is dealt with later) */
if (UCHARAT(RExC_parse) == ']')
goto charclassloop;
parseit:
- while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
+ while (1) {
+ if (RExC_parse >= stop_ptr) {
+ break;
+ }
+ if (skip_white) {
+ RExC_parse = regpatws(pRExC_state, RExC_parse,
+ FALSE /* means don't recognize comments */);
+ }
+
+ if (UCHARAT(RExC_parse) == ']') {
+ break;
+ }
+
charclassloop:
namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
+ save_value = value;
+ save_prevvalue = prevvalue;
- if (!range)
+ if (!range) {
rangebegin = RExC_parse;
+ element_count++;
+ }
if (UTF) {
value = utf8n_to_uvchr((U8*)RExC_parse,
RExC_end - RExC_parse,
@@ -9585,10 +12272,13 @@
else
value = UCHARAT(RExC_parse++);
- nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
- if (value == '[' && POSIXCC(nextvalue))
- namedclass = regpposixcc(pRExC_state, value);
- else if (value == '\\') {
+ if (value == '['
+ && RExC_parse < RExC_end
+ && POSIXCC(UCHARAT(RExC_parse)))
+ {
+ namedclass = regpposixcc(pRExC_state, value, strict);
+ }
+ else if (value == '\\') {
if (UTF) {
value = utf8n_to_uvchr((U8*)RExC_parse,
RExC_end - RExC_parse,
@@ -9597,14 +12287,21 @@
}
else
value = UCHARAT(RExC_parse++);
+
/* Some compilers cannot handle switching on 64-bit integer
* values, therefore value cannot be an UV. Yes, this will
* be a problem later if we want switch on Unicode.
* A similar issue a little bit later when switching on
* namedclass. --jhi */
- switch ((I32)value) {
- case 'w': namedclass = ANYOF_ALNUM; break;
- case 'W': namedclass = ANYOF_NALNUM; break;
+
+ /* If the \ is escaping white space when white space is being
+ * skipped, it means that that white space is wanted literally, and
+ * is already in 'value'. Otherwise, need to translate the escape
+ * into what it signifies. */
+ if (! skip_white || ! is_PATWS_cp(value)) switch ((I32)value) {
+
+ case 'w': namedclass = ANYOF_WORDCHAR; break;
+ case 'W': namedclass = ANYOF_NWORDCHAR; break;
case 's': namedclass = ANYOF_SPACE; break;
case 'S': namedclass = ANYOF_NSPACE; break;
case 'd': namedclass = ANYOF_DIGIT; break;
@@ -9620,11 +12317,14 @@
if this makes sense as it does change the behaviour
from earlier versions, OTOH that behaviour was broken
as well. */
- UV v; /* value is register so we cant & it /grrr */
- if (reg_namedseq(pRExC_state, &v, NULL, depth)) {
+ if (! grok_bslash_N(pRExC_state, NULL, &value, flagp, depth,
+ TRUE, /* => charclass */
+ strict))
+ {
+ if (*flagp & RESTART_UTF8)
+ FAIL("panic: grok_bslash_N set RESTART_UTF8");
goto parseit;
}
- value= v;
}
break;
case 'p':
@@ -9631,6 +12331,10 @@
case 'P':
{
char *e;
+
+ /* We will handle any undefined properties ourselves */
+ U8 swash_init_flags = _CORE_SWASH_INIT_RETURN_IF_UNDEF;
+
if (RExC_parse >= RExC_end)
vFAIL2("Empty \\%c{}", (U8)value);
if (*RExC_parse == '{') {
@@ -9651,35 +12355,106 @@
n = 1;
}
if (!SIZE_ONLY) {
+ SV* invlist;
+ char* name;
+
if (UCHARAT(RExC_parse) == '^') {
RExC_parse++;
n--;
- value = value == 'p' ? 'P' : 'p'; /* toggle */
+ /* toggle. (The rhs xor gets the single bit that
+ * differs between P and p; the other xor inverts just
+ * that bit) */
+ value ^= 'P' ^ 'p';
+
while (isSPACE(UCHARAT(RExC_parse))) {
RExC_parse++;
n--;
}
}
+ /* Try to get the definition of the property into
+ * <invlist>. If /i is in effect, the effective property
+ * will have its name be <__NAME_i>. The design is
+ * discussed in commit
+ * 2f833f5208e26b208886e51e09e2c072b5eabb46 */
+ Newx(name, n + sizeof("_i__\n"), char);
- /* Add the property name to the list. If /i matching, give
- * a different name which consists of the normal name
- * sandwiched between two underscores and '_i'. The design
- * is discussed in the commit message for this. */
- Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s%.*s%s\n",
- (value=='p' ? '+' : '!'),
- (FOLD) ? "__" : "",
- (int)n,
- RExC_parse,
- (FOLD) ? "_i" : ""
- );
+ sprintf(name, "%s%.*s%s\n",
+ (FOLD) ? "__" : "",
+ (int)n,
+ RExC_parse,
+ (FOLD) ? "_i" : ""
+ );
+
+ /* Look up the property name, and get its swash and
+ * inversion list, if the property is found */
+ if (swash) {
+ SvREFCNT_dec_NN(swash);
+ }
+ swash = _core_swash_init("utf8", name, &PL_sv_undef,
+ 1, /* binary */
+ 0, /* not tr/// */
+ NULL, /* No inversion list */
+ &swash_init_flags
+ );
+ if (! swash || ! (invlist = _get_swash_invlist(swash))) {
+ if (swash) {
+ SvREFCNT_dec_NN(swash);
+ swash = NULL;
+ }
+
+ /* Here didn't find it. It could be a user-defined
+ * property that will be available at run-time. If we
+ * accept only compile-time properties, is an error;
+ * otherwise add it to the list for run-time look up */
+ if (ret_invlist) {
+ RExC_parse = e + 1;
+ vFAIL3("Property '%.*s' is unknown", (int) n, name);
+ }
+ Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s\n",
+ (value == 'p' ? '+' : '!'),
+ name);
+ has_user_defined_property = TRUE;
+
+ /* We don't know yet, so have to assume that the
+ * property could match something in the Latin1 range,
+ * hence something that isn't utf8. Note that this
+ * would cause things in <depends_list> to match
+ * inappropriately, except that any \p{}, including
+ * this one forces Unicode semantics, which means there
+ * is <no depends_list> */
+ ANYOF_FLAGS(ret) |= ANYOF_NONBITMAP_NON_UTF8;
+ }
+ else {
+
+ /* Here, did get the swash and its inversion list. If
+ * the swash is from a user-defined property, then this
+ * whole character class should be regarded as such */
+ has_user_defined_property =
+ (swash_init_flags
+ & _CORE_SWASH_INIT_USER_DEFINED_PROPERTY);
+
+ /* Invert if asking for the complement */
+ if (value == 'P') {
+ _invlist_union_complement_2nd(properties,
+ invlist,
+ &properties);
+
+ /* The swash can't be used as-is, because we've
+ * inverted things; delay removing it to here after
+ * have copied its invlist above */
+ SvREFCNT_dec_NN(swash);
+ swash = NULL;
+ }
+ else {
+ _invlist_union(properties, invlist, &properties);
+ }
+ }
+ Safefree(name);
}
RExC_parse = e + 1;
+ namedclass = ANYOF_UNIPROP; /* no official name, but it's
+ named */
- /* The \p could match something in the Latin1 range, hence
- * something that isn't utf8 */
- ANYOF_FLAGS(ret) |= ANYOF_NONBITMAP_NON_UTF8;
- namedclass = ANYOF_MAX; /* no official name, but it's named */
-
/* \p means they want Unicode semantics */
RExC_uni_semantics = 1;
}
@@ -9695,12 +12470,14 @@
RExC_parse--; /* function expects to be pointed at the 'o' */
{
const char* error_msg;
- bool valid = grok_bslash_o(RExC_parse,
+ bool valid = grok_bslash_o(&RExC_parse,
&value,
- &numlen,
&error_msg,
- SIZE_ONLY);
- RExC_parse += numlen;
+ SIZE_ONLY, /* warnings in pass
+ 1 only */
+ strict,
+ silence_non_portable,
+ UTF);
if (! valid) {
vFAIL(error_msg);
}
@@ -9710,23 +12487,20 @@
}
break;
case 'x':
- if (*RExC_parse == '{') {
- I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
- | PERL_SCAN_DISALLOW_PREFIX;
- char * const e = strchr(RExC_parse++, '}');
- if (!e)
- vFAIL("Missing right brace on \\x{}");
-
- numlen = e - RExC_parse;
- value = grok_hex(RExC_parse, &numlen, &flags, NULL);
- RExC_parse = e + 1;
+ RExC_parse--; /* function expects to be pointed at the 'x' */
+ {
+ const char* error_msg;
+ bool valid = grok_bslash_x(&RExC_parse,
+ &value,
+ &error_msg,
+ TRUE, /* Output warnings */
+ strict,
+ silence_non_portable,
+ UTF);
+ if (! valid) {
+ vFAIL(error_msg);
+ }
}
- else {
- I32 flags = PERL_SCAN_DISALLOW_PREFIX;
- numlen = 2;
- value = grok_hex(RExC_parse, &numlen, &flags, NULL);
- RExC_parse += numlen;
- }
if (PL_encoding && value < 0x100)
goto recode_encoding;
break;
@@ -9738,9 +12512,27 @@
{
/* Take 1-3 octal digits */
I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
- numlen = 3;
- value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
+ numlen = (strict) ? 4 : 3;
+ value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
RExC_parse += numlen;
+ if (numlen != 3) {
+ if (strict) {
+ RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
+ vFAIL("Need exactly 3 octal digits");
+ }
+ else if (! SIZE_ONLY /* like \08, \178 */
+ && numlen < 3
+ && RExC_parse < RExC_end
+ && isDIGIT(*RExC_parse)
+ && ckWARN(WARN_REGEXP))
+ {
+ SAVEFREESV(RExC_rx_sv);
+ reg_warn_non_literal_string(
+ RExC_parse + 1,
+ form_short_octal_warning(RExC_parse, numlen));
+ (void)ReREFCNT_inc(RExC_rx_sv);
+ }
+ }
if (PL_encoding && value < 0x100)
goto recode_encoding;
break;
@@ -9749,172 +12541,373 @@
if (! RExC_override_recoding) {
SV* enc = PL_encoding;
value = reg_recode((const char)(U8)value, &enc);
- if (!enc && SIZE_ONLY)
- ckWARNreg(RExC_parse,
+ if (!enc) {
+ if (strict) {
+ vFAIL("Invalid escape in the specified encoding");
+ }
+ else if (SIZE_ONLY) {
+ ckWARNreg(RExC_parse,
"Invalid escape in the specified encoding");
+ }
+ }
break;
}
default:
/* Allow \_ to not give an error */
- if (!SIZE_ONLY && isALNUM(value) && value != '_') {
- ckWARN2reg(RExC_parse,
- "Unrecognized escape \\%c in character class passed through",
- (int)value);
+ if (!SIZE_ONLY && isWORDCHAR(value) && value != '_') {
+ if (strict) {
+ vFAIL2("Unrecognized escape \\%c in character class",
+ (int)value);
+ }
+ else {
+ SAVEFREESV(RExC_rx_sv);
+ ckWARN2reg(RExC_parse,
+ "Unrecognized escape \\%c in character class passed through",
+ (int)value);
+ (void)ReREFCNT_inc(RExC_rx_sv);
+ }
}
break;
- }
- } /* end of \blah */
+ } /* End of switch on char following backslash */
+ } /* end of handling backslash escape sequences */
#ifdef EBCDIC
- else
- literal_endpoint++;
+ else
+ literal_endpoint++;
#endif
+ /* Here, we have the current token in 'value' */
+
+ /* What matches in a locale is not known until runtime. This includes
+ * what the Posix classes (like \w, [:space:]) match. Room must be
+ * reserved (one time per class) to store such classes, either if Perl
+ * is compiled so that locale nodes always should have this space, or
+ * if there is such class info to be stored. The space will contain a
+ * bit for each named class that is to be matched against. This isn't
+ * needed for \p{} and pseudo-classes, as they are not affected by
+ * locale, and hence are dealt with separately */
+ if (LOC
+ && ! need_class
+ && (ANYOF_LOCALE == ANYOF_CLASS
+ || (namedclass > OOB_NAMEDCLASS && namedclass < ANYOF_MAX)))
+ {
+ need_class = 1;
+ if (SIZE_ONLY) {
+ RExC_size += ANYOF_CLASS_SKIP - ANYOF_SKIP;
+ }
+ else {
+ RExC_emit += ANYOF_CLASS_SKIP - ANYOF_SKIP;
+ ANYOF_CLASS_ZERO(ret);
+ }
+ ANYOF_FLAGS(ret) |= ANYOF_CLASS;
+ }
+
if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
- /* What matches in a locale is not known until runtime, so need to
- * (one time per class) allocate extra space to pass to regexec.
- * The space will contain a bit for each named class that is to be
- * matched against. This isn't needed for \p{} and pseudo-classes,
- * as they are not affected by locale, and hence are dealt with
- * separately */
- if (LOC && namedclass < ANYOF_MAX && ! need_class) {
- need_class = 1;
- if (SIZE_ONLY) {
- RExC_size += ANYOF_CLASS_SKIP - ANYOF_SKIP;
- }
- else {
- RExC_emit += ANYOF_CLASS_SKIP - ANYOF_SKIP;
- ANYOF_CLASS_ZERO(ret);
- }
- ANYOF_FLAGS(ret) |= ANYOF_CLASS;
- }
-
/* a bad range like a-\d, a-[:digit:]. The '-' is taken as a
* literal, as is the character that began the false range, i.e.
* the 'a' in the examples */
if (range) {
if (!SIZE_ONLY) {
- const int w =
- RExC_parse >= rangebegin ?
- RExC_parse - rangebegin : 0;
- ckWARN4reg(RExC_parse,
- "False [] range \"%*.*s\"",
- w, w, rangebegin);
-
- stored +=
- set_regclass_bit(pRExC_state, ret, '-', &l1_fold_invlist, &unicode_alternate);
- if (prevvalue < 256) {
- stored +=
- set_regclass_bit(pRExC_state, ret, (U8) prevvalue, &l1_fold_invlist, &unicode_alternate);
- }
- else {
- nonbitmap = add_cp_to_invlist(nonbitmap, prevvalue);
- }
+ const int w = (RExC_parse >= rangebegin)
+ ? RExC_parse - rangebegin
+ : 0;
+ if (strict) {
+ vFAIL4("False [] range \"%*.*s\"", w, w, rangebegin);
+ }
+ else {
+ SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
+ ckWARN4reg(RExC_parse,
+ "False [] range \"%*.*s\"",
+ w, w, rangebegin);
+ (void)ReREFCNT_inc(RExC_rx_sv);
+ cp_list = add_cp_to_invlist(cp_list, '-');
+ cp_list = add_cp_to_invlist(cp_list, prevvalue);
+ }
}
range = 0; /* this was not a true range */
+ element_count += 2; /* So counts for three values */
}
+ if (! SIZE_ONLY) {
+ U8 classnum = namedclass_to_classnum(namedclass);
+ if (namedclass >= ANYOF_MAX) { /* If a special class */
+ if (namedclass != ANYOF_UNIPROP) { /* UNIPROP = \p and \P */
-
- if (!SIZE_ONLY) {
- const char *what = NULL;
- char yesno = 0;
+ /* Here, should be \h, \H, \v, or \V. Neither /d nor
+ * /l make a difference in what these match. There
+ * would be problems if these characters had folds
+ * other than themselves, as cp_list is subject to
+ * folding. */
+ if (classnum != _CC_VERTSPACE) {
+ assert( namedclass == ANYOF_HORIZWS
+ || namedclass == ANYOF_NHORIZWS);
- /* Possible truncation here but in some 64-bit environments
- * the compiler gets heartburn about switch on 64-bit values.
- * A similar issue a little earlier when switching on value.
- * --jhi */
- switch ((I32)namedclass) {
-
- case _C_C_T_(ALNUMC, isALNUMC_L1, isALNUMC, "XPosixAlnum");
- case _C_C_T_(ALPHA, isALPHA_L1, isALPHA, "XPosixAlpha");
- case _C_C_T_(BLANK, isBLANK_L1, isBLANK, "XPosixBlank");
- case _C_C_T_(CNTRL, isCNTRL_L1, isCNTRL, "XPosixCntrl");
- case _C_C_T_(GRAPH, isGRAPH_L1, isGRAPH, "XPosixGraph");
- case _C_C_T_(LOWER, isLOWER_L1, isLOWER, "XPosixLower");
- case _C_C_T_(PRINT, isPRINT_L1, isPRINT, "XPosixPrint");
- case _C_C_T_(PSXSPC, isPSXSPC_L1, isPSXSPC, "XPosixSpace");
- case _C_C_T_(PUNCT, isPUNCT_L1, isPUNCT, "XPosixPunct");
- case _C_C_T_(UPPER, isUPPER_L1, isUPPER, "XPosixUpper");
- /* \s, \w match all unicode if utf8. */
- case _C_C_T_(SPACE, isSPACE_L1, isSPACE, "SpacePerl");
- case _C_C_T_(ALNUM, isWORDCHAR_L1, isALNUM, "Word");
- case _C_C_T_(XDIGIT, isXDIGIT_L1, isXDIGIT, "XPosixXDigit");
- case _C_C_T_NOLOC_(VERTWS, is_VERTWS_latin1(&value), "VertSpace");
- case _C_C_T_NOLOC_(HORIZWS, is_HORIZWS_latin1(&value), "HorizSpace");
- case ANYOF_ASCII:
- if (LOC)
- ANYOF_CLASS_SET(ret, ANYOF_ASCII);
- else {
- for (value = 0; value < 128; value++)
- stored +=
- set_regclass_bit(pRExC_state, ret, (U8) ASCII_TO_NATIVE(value), &l1_fold_invlist, &unicode_alternate);
- }
- yesno = '+';
- what = NULL; /* Doesn't match outside ascii, so
- don't want to add +utf8:: */
- break;
- case ANYOF_NASCII:
- if (LOC)
- ANYOF_CLASS_SET(ret, ANYOF_NASCII);
- else {
- for (value = 128; value < 256; value++)
- stored +=
- set_regclass_bit(pRExC_state, ret, (U8) ASCII_TO_NATIVE(value), &l1_fold_invlist, &unicode_alternate);
- }
- ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;
- yesno = '!';
- what = "ASCII";
- break;
- case ANYOF_DIGIT:
- if (LOC)
- ANYOF_CLASS_SET(ret, ANYOF_DIGIT);
- else {
- /* consecutive digits assumed */
- for (value = '0'; value <= '9'; value++)
- stored +=
- set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);
- }
- yesno = '+';
- what = "Digit";
- break;
- case ANYOF_NDIGIT:
- if (LOC)
- ANYOF_CLASS_SET(ret, ANYOF_NDIGIT);
- else {
- /* consecutive digits assumed */
- for (value = 0; value < '0'; value++)
- stored +=
- set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);
- for (value = '9' + 1; value < 256; value++)
- stored +=
- set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);
- }
- yesno = '!';
- what = "Digit";
- if (AT_LEAST_ASCII_RESTRICTED ) {
- ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;
- }
- break;
- case ANYOF_MAX:
- /* this is to handle \p and \P */
- break;
- default:
- vFAIL("Invalid [::] class");
- break;
- }
- if (what && ! (AT_LEAST_ASCII_RESTRICTED)) {
- /* Strings such as "+utf8::isWord\n" */
- Perl_sv_catpvf(aTHX_ listsv, "%cutf8::Is%s\n", yesno, what);
- }
+ /* It turns out that \h is just a synonym for
+ * XPosixBlank */
+ classnum = _CC_BLANK;
+ }
- continue;
+ _invlist_union_maybe_complement_2nd(
+ cp_list,
+ PL_XPosix_ptrs[classnum],
+ cBOOL(namedclass % 2), /* Complement if odd
+ (NHORIZWS, NVERTWS)
+ */
+ &cp_list);
+ }
+ }
+ else if (classnum == _CC_ASCII) {
+#ifdef HAS_ISASCII
+ if (LOC) {
+ ANYOF_CLASS_SET(ret, namedclass);
+ }
+ else
+#endif /* Not isascii(); just use the hard-coded definition for it */
+ _invlist_union_maybe_complement_2nd(
+ posixes,
+ PL_ASCII,
+ cBOOL(namedclass % 2), /* Complement if odd
+ (NASCII) */
+ &posixes);
+ }
+ else { /* Garden variety class */
+
+ /* The ascii range inversion list */
+ SV* ascii_source = PL_Posix_ptrs[classnum];
+
+ /* The full Latin1 range inversion list */
+ SV* l1_source = PL_L1Posix_ptrs[classnum];
+
+ /* This code is structured into two major clauses. The
+ * first is for classes whose complete definitions may not
+ * already be known. It not, the Latin1 definition
+ * (guaranteed to already known) is used plus code is
+ * generated to load the rest at run-time (only if needed).
+ * If the complete definition is known, it drops down to
+ * the second clause, where the complete definition is
+ * known */
+
+ if (classnum < _FIRST_NON_SWASH_CC) {
+
+ /* Here, the class has a swash, which may or not
+ * already be loaded */
+
+ /* The name of the property to use to match the full
+ * eXtended Unicode range swash for this character
+ * class */
+ const char *Xname = swash_property_names[classnum];
+
+ /* If returning the inversion list, we can't defer
+ * getting this until runtime */
+ if (ret_invlist && ! PL_utf8_swash_ptrs[classnum]) {
+ PL_utf8_swash_ptrs[classnum] =
+ _core_swash_init("utf8", Xname, &PL_sv_undef,
+ 1, /* binary */
+ 0, /* not tr/// */
+ NULL, /* No inversion list */
+ NULL /* No flags */
+ );
+ assert(PL_utf8_swash_ptrs[classnum]);
+ }
+ if ( ! PL_utf8_swash_ptrs[classnum]) {
+ if (namedclass % 2 == 0) { /* A non-complemented
+ class */
+ /* If not /a matching, there are code points we
+ * don't know at compile time. Arrange for the
+ * unknown matches to be loaded at run-time, if
+ * needed */
+ if (! AT_LEAST_ASCII_RESTRICTED) {
+ Perl_sv_catpvf(aTHX_ listsv, "+utf8::%s\n",
+ Xname);
+ }
+ if (LOC) { /* Under locale, set run-time
+ lookup */
+ ANYOF_CLASS_SET(ret, namedclass);
+ }
+ else {
+ /* Add the current class's code points to
+ * the running total */
+ _invlist_union(posixes,
+ (AT_LEAST_ASCII_RESTRICTED)
+ ? ascii_source
+ : l1_source,
+ &posixes);
+ }
+ }
+ else { /* A complemented class */
+ if (AT_LEAST_ASCII_RESTRICTED) {
+ /* Under /a should match everything above
+ * ASCII, plus the complement of the set's
+ * ASCII matches */
+ _invlist_union_complement_2nd(posixes,
+ ascii_source,
+ &posixes);
+ }
+ else {
+ /* Arrange for the unknown matches to be
+ * loaded at run-time, if needed */
+ Perl_sv_catpvf(aTHX_ listsv, "!utf8::%s\n",
+ Xname);
+ runtime_posix_matches_above_Unicode = TRUE;
+ if (LOC) {
+ ANYOF_CLASS_SET(ret, namedclass);
+ }
+ else {
+
+ /* We want to match everything in
+ * Latin1, except those things that
+ * l1_source matches */
+ SV* scratch_list = NULL;
+ _invlist_subtract(PL_Latin1, l1_source,
+ &scratch_list);
+
+ /* Add the list from this class to the
+ * running total */
+ if (! posixes) {
+ posixes = scratch_list;
+ }
+ else {
+ _invlist_union(posixes,
+ scratch_list,
+ &posixes);
+ SvREFCNT_dec_NN(scratch_list);
+ }
+ if (DEPENDS_SEMANTICS) {
+ ANYOF_FLAGS(ret)
+ |= ANYOF_NON_UTF8_LATIN1_ALL;
+ }
+ }
+ }
+ }
+ goto namedclass_done;
+ }
+
+ /* Here, there is a swash loaded for the class. If no
+ * inversion list for it yet, get it */
+ if (! PL_XPosix_ptrs[classnum]) {
+ PL_XPosix_ptrs[classnum]
+ = _swash_to_invlist(PL_utf8_swash_ptrs[classnum]);
+ }
+ }
+
+ /* Here there is an inversion list already loaded for the
+ * entire class */
+
+ if (namedclass % 2 == 0) { /* A non-complemented class,
+ like ANYOF_PUNCT */
+ if (! LOC) {
+ /* For non-locale, just add it to any existing list
+ * */
+ _invlist_union(posixes,
+ (AT_LEAST_ASCII_RESTRICTED)
+ ? ascii_source
+ : PL_XPosix_ptrs[classnum],
+ &posixes);
+ }
+ else { /* Locale */
+ SV* scratch_list = NULL;
+
+ /* For above Latin1 code points, we use the full
+ * Unicode range */
+ _invlist_intersection(PL_AboveLatin1,
+ PL_XPosix_ptrs[classnum],
+ &scratch_list);
+ /* And set the output to it, adding instead if
+ * there already is an output. Checking if
+ * 'posixes' is NULL first saves an extra clone.
+ * Its reference count will be decremented at the
+ * next union, etc, or if this is the only
+ * instance, at the end of the routine */
+ if (! posixes) {
+ posixes = scratch_list;
+ }
+ else {
+ _invlist_union(posixes, scratch_list, &posixes);
+ SvREFCNT_dec_NN(scratch_list);
+ }
+
+#ifndef HAS_ISBLANK
+ if (namedclass != ANYOF_BLANK) {
+#endif
+ /* Set this class in the node for runtime
+ * matching */
+ ANYOF_CLASS_SET(ret, namedclass);
+#ifndef HAS_ISBLANK
+ }
+ else {
+ /* No isblank(), use the hard-coded ASCII-range
+ * blanks, adding them to the running total. */
+
+ _invlist_union(posixes, ascii_source, &posixes);
+ }
+#endif
+ }
+ }
+ else { /* A complemented class, like ANYOF_NPUNCT */
+ if (! LOC) {
+ _invlist_union_complement_2nd(
+ posixes,
+ (AT_LEAST_ASCII_RESTRICTED)
+ ? ascii_source
+ : PL_XPosix_ptrs[classnum],
+ &posixes);
+ /* Under /d, everything in the upper half of the
+ * Latin1 range matches this complement */
+ if (DEPENDS_SEMANTICS) {
+ ANYOF_FLAGS(ret) |= ANYOF_NON_UTF8_LATIN1_ALL;
+ }
+ }
+ else { /* Locale */
+ SV* scratch_list = NULL;
+ _invlist_subtract(PL_AboveLatin1,
+ PL_XPosix_ptrs[classnum],
+ &scratch_list);
+ if (! posixes) {
+ posixes = scratch_list;
+ }
+ else {
+ _invlist_union(posixes, scratch_list, &posixes);
+ SvREFCNT_dec_NN(scratch_list);
+ }
+#ifndef HAS_ISBLANK
+ if (namedclass != ANYOF_NBLANK) {
+#endif
+ ANYOF_CLASS_SET(ret, namedclass);
+#ifndef HAS_ISBLANK
+ }
+ else {
+ /* Get the list of all code points in Latin1
+ * that are not ASCII blanks, and add them to
+ * the running total */
+ _invlist_subtract(PL_Latin1, ascii_source,
+ &scratch_list);
+ _invlist_union(posixes, scratch_list, &posixes);
+ SvREFCNT_dec_NN(scratch_list);
+ }
+#endif
+ }
+ }
+ }
+ namedclass_done:
+ continue; /* Go get next character */
}
} /* end of namedclass \blah */
+ /* Here, we have a single value. If 'range' is set, it is the ending
+ * of a range--check its validity. Later, we will handle each
+ * individual code point in the range. If 'range' isn't set, this
+ * could be the beginning of a range, so check for that by looking
+ * ahead to see if the next real character to be processed is the range
+ * indicator--the minus sign */
+
+ if (skip_white) {
+ RExC_parse = regpatws(pRExC_state, RExC_parse,
+ FALSE /* means don't recognize comments */);
+ }
+
if (range) {
- if (prevvalue > (IV)value) /* b-a */ {
+ if (prevvalue > value) /* b-a */ {
const int w = RExC_parse - rangebegin;
Simple_vFAIL4("Invalid [] range \"%*.*s\"", w, w, rangebegin);
range = 0; /* not a valid range */
@@ -9921,32 +12914,53 @@
}
}
else {
- prevvalue = value; /* save the beginning of the range */
- if (RExC_parse+1 < RExC_end
- && *RExC_parse == '-'
- && RExC_parse[1] != ']')
- {
- RExC_parse++;
+ prevvalue = value; /* save the beginning of the potential range */
+ if (! stop_at_1 /* Can't be a range if parsing just one thing */
+ && *RExC_parse == '-')
+ {
+ char* next_char_ptr = RExC_parse + 1;
+ if (skip_white) { /* Get the next real char after the '-' */
+ next_char_ptr = regpatws(pRExC_state,
+ RExC_parse + 1,
+ FALSE); /* means don't recognize
+ comments */
+ }
- /* a bad range like \w-, [:word:]- ? */
- if (namedclass > OOB_NAMEDCLASS) {
- if (ckWARN(WARN_REGEXP)) {
- const int w =
- RExC_parse >= rangebegin ?
- RExC_parse - rangebegin : 0;
- vWARN4(RExC_parse,
- "False [] range \"%*.*s\"",
- w, w, rangebegin);
- }
- if (!SIZE_ONLY)
- stored +=
- set_regclass_bit(pRExC_state, ret, '-', &l1_fold_invlist, &unicode_alternate);
- } else
- range = 1; /* yeah, it's a range! */
- continue; /* but do it the next time */
+ /* If the '-' is at the end of the class (just before the ']',
+ * it is a literal minus; otherwise it is a range */
+ if (next_char_ptr < RExC_end && *next_char_ptr != ']') {
+ RExC_parse = next_char_ptr;
+
+ /* a bad range like \w-, [:word:]- ? */
+ if (namedclass > OOB_NAMEDCLASS) {
+ if (strict || ckWARN(WARN_REGEXP)) {
+ const int w =
+ RExC_parse >= rangebegin ?
+ RExC_parse - rangebegin : 0;
+ if (strict) {
+ vFAIL4("False [] range \"%*.*s\"",
+ w, w, rangebegin);
+ }
+ else {
+ vWARN4(RExC_parse,
+ "False [] range \"%*.*s\"",
+ w, w, rangebegin);
+ }
+ }
+ if (!SIZE_ONLY) {
+ cp_list = add_cp_to_invlist(cp_list, '-');
+ }
+ element_count++;
+ } else
+ range = 1; /* yeah, it's a range! */
+ continue; /* but do it the next time */
+ }
}
}
+ /* Here, <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 */
if (value > 255) {
@@ -9953,448 +12967,988 @@
RExC_uni_semantics = 1;
}
- /* now is the next time */
- if (!SIZE_ONLY) {
- if (prevvalue < 256) {
- const IV ceilvalue = value < 256 ? value : 255;
- IV i;
-#ifdef EBCDIC
- /* In EBCDIC [\x89-\x91] should include
- * the \x8e but [i-j] should not. */
- if (literal_endpoint == 2 &&
- ((isLOWER(prevvalue) && isLOWER(ceilvalue)) ||
- (isUPPER(prevvalue) && isUPPER(ceilvalue))))
- {
- if (isLOWER(prevvalue)) {
- for (i = prevvalue; i <= ceilvalue; i++)
- if (isLOWER(i) && !ANYOF_BITMAP_TEST(ret,i)) {
- stored +=
- set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
- }
- } else {
- for (i = prevvalue; i <= ceilvalue; i++)
- if (isUPPER(i) && !ANYOF_BITMAP_TEST(ret,i)) {
- stored +=
- set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
- }
- }
- }
- else
+ /* Ready to process either the single value, or the completed range.
+ * For single-valued non-inverted ranges, we consider the possibility
+ * of multi-char folds. (We made a conscious decision to not do this
+ * for the other cases because it can often lead to non-intuitive
+ * results. For example, you have the peculiar case that:
+ * "s s" =~ /^[^\xDF]+$/i => Y
+ * "ss" =~ /^[^\xDF]+$/i => N
+ *
+ * See [perl #89750] */
+ if (FOLD && allow_multi_folds && value == prevvalue) {
+ if (value == LATIN_SMALL_LETTER_SHARP_S
+ || (value > 255 && _invlist_contains_cp(PL_HasMultiCharFold,
+ value)))
+ {
+ /* Here <value> is indeed a multi-char fold. Get what it is */
+
+ U8 foldbuf[UTF8_MAXBYTES_CASE];
+ STRLEN foldlen;
+
+ UV folded = _to_uni_fold_flags(
+ value,
+ foldbuf,
+ &foldlen,
+ FOLD_FLAGS_FULL
+ | ((LOC) ? FOLD_FLAGS_LOCALE
+ : (ASCII_FOLD_RESTRICTED)
+ ? FOLD_FLAGS_NOMIX_ASCII
+ : 0)
+ );
+
+ /* Here, <folded> should be the first character of the
+ * multi-char fold of <value>, with <foldbuf> containing the
+ * whole thing. But, if this fold is not allowed (because of
+ * the flags), <fold> will be the same as <value>, and should
+ * be processed like any other character, so skip the special
+ * handling */
+ if (folded != value) {
+
+ /* Skip if we are recursed, currently parsing the class
+ * again. Otherwise add this character to the list of
+ * multi-char folds. */
+ if (! RExC_in_multi_char_class) {
+ AV** this_array_ptr;
+ AV* this_array;
+ STRLEN cp_count = utf8_length(foldbuf,
+ foldbuf + foldlen);
+ SV* multi_fold = sv_2mortal(newSVpvn("", 0));
+
+ Perl_sv_catpvf(aTHX_ multi_fold, "\\x{%"UVXf"}", value);
+
+
+ if (! multi_char_matches) {
+ multi_char_matches = newAV();
+ }
+
+ /* <multi_char_matches> is actually an array of arrays.
+ * There will be one or two top-level elements: [2],
+ * and/or [3]. The [2] element is an array, each
+ * element thereof is a character which folds to two
+ * characters; likewise for [3]. (Unicode guarantees a
+ * maximum of 3 characters in any fold.) When we
+ * rewrite the character class below, we will do so
+ * such that the longest folds are written first, so
+ * that it prefers the longest matching strings first.
+ * This is done even if it turns out that any
+ * quantifier is non-greedy, out of programmer
+ * laziness. Tom Christiansen has agreed that this is
+ * ok. This makes the test for the ligature 'ffi' come
+ * before the test for 'ff' */
+ if (av_exists(multi_char_matches, cp_count)) {
+ this_array_ptr = (AV**) av_fetch(multi_char_matches,
+ cp_count, FALSE);
+ this_array = *this_array_ptr;
+ }
+ else {
+ this_array = newAV();
+ av_store(multi_char_matches, cp_count,
+ (SV*) this_array);
+ }
+ av_push(this_array, multi_fold);
+ }
+
+ /* This element should not be processed further in this
+ * class */
+ element_count--;
+ value = save_value;
+ prevvalue = save_prevvalue;
+ continue;
+ }
+ }
+ }
+
+ /* Deal with this element of the class */
+ if (! SIZE_ONLY) {
+#ifndef EBCDIC
+ cp_list = _add_range_to_invlist(cp_list, prevvalue, value);
+#else
+ SV* this_range = _new_invlist(1);
+ _append_range_to_invlist(this_range, prevvalue, value);
+
+ /* In EBCDIC, the ranges 'A-Z' and 'a-z' are each not contiguous.
+ * If this range was specified using something like 'i-j', we want
+ * to include only the 'i' and the 'j', and not anything in
+ * between, so exclude non-ASCII, non-alphabetics from it.
+ * However, if the range was specified with something like
+ * [\x89-\x91] or [\x89-j], all code points within it should be
+ * included. literal_endpoint==2 means both ends of the range used
+ * a literal character, not \x{foo} */
+ if (literal_endpoint == 2
+ && (prevvalue >= 'a' && value <= 'z')
+ || (prevvalue >= 'A' && value <= 'Z'))
+ {
+ _invlist_intersection(this_range, PL_Posix_ptrs[_CC_ALPHA],
+ &this_range);
+ }
+ _invlist_union(cp_list, this_range, &cp_list);
+ literal_endpoint = 0;
#endif
- for (i = prevvalue; i <= ceilvalue; i++) {
- stored += set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
- }
- }
- if (value > 255) {
- const UV prevnatvalue = NATIVE_TO_UNI(prevvalue);
- const UV natvalue = NATIVE_TO_UNI(value);
- nonbitmap = add_range_to_invlist(nonbitmap, prevnatvalue, natvalue);
- }
-#ifdef EBCDIC
- literal_endpoint = 0;
+ }
+
+ range = 0; /* this range (if it was one) is done now */
+ } /* End of loop through all the text within the brackets */
+
+ /* If anything in the class expands to more than one character, we have to
+ * deal with them by building up a substitute parse string, and recursively
+ * calling reg() on it, instead of proceeding */
+ if (multi_char_matches) {
+ SV * substitute_parse = newSVpvn_flags("?:", 2, SVs_TEMP);
+ I32 cp_count;
+ STRLEN len;
+ char *save_end = RExC_end;
+ char *save_parse = RExC_parse;
+ bool first_time = TRUE; /* First multi-char occurrence doesn't get
+ a "|" */
+ I32 reg_flags;
+
+ assert(! invert);
+#if 0 /* Have decided not to deal with multi-char folds in inverted classes,
+ because too confusing */
+ if (invert) {
+ sv_catpv(substitute_parse, "(?:");
+ }
#endif
+
+ /* Look at the longest folds first */
+ for (cp_count = av_len(multi_char_matches); cp_count > 0; cp_count--) {
+
+ if (av_exists(multi_char_matches, cp_count)) {
+ AV** this_array_ptr;
+ SV* this_sequence;
+
+ this_array_ptr = (AV**) av_fetch(multi_char_matches,
+ cp_count, FALSE);
+ while ((this_sequence = av_pop(*this_array_ptr)) !=
+ &PL_sv_undef)
+ {
+ if (! first_time) {
+ sv_catpv(substitute_parse, "|");
+ }
+ first_time = FALSE;
+
+ sv_catpv(substitute_parse, SvPVX(this_sequence));
+ }
+ }
}
- range = 0; /* this range (if it was one) is done now */
+ /* If the character class contains anything else besides these
+ * multi-character folds, have to include it in recursive parsing */
+ if (element_count) {
+ sv_catpv(substitute_parse, "|[");
+ sv_catpvn(substitute_parse, orig_parse, RExC_parse - orig_parse);
+ sv_catpv(substitute_parse, "]");
+ }
+
+ sv_catpv(substitute_parse, ")");
+#if 0
+ if (invert) {
+ /* This is a way to get the parse to skip forward a whole named
+ * sequence instead of matching the 2nd character when it fails the
+ * first */
+ sv_catpv(substitute_parse, "(*THEN)(*SKIP)(*FAIL)|.)");
+ }
+#endif
+
+ RExC_parse = SvPV(substitute_parse, len);
+ RExC_end = RExC_parse + len;
+ RExC_in_multi_char_class = 1;
+ RExC_emit = (regnode *)orig_emit;
+
+ ret = reg(pRExC_state, 1, ®_flags, depth+1);
+
+ *flagp |= reg_flags&(HASWIDTH|SIMPLE|SPSTART|POSTPONED|RESTART_UTF8);
+
+ RExC_parse = save_parse;
+ RExC_end = save_end;
+ RExC_in_multi_char_class = 0;
+ SvREFCNT_dec_NN(multi_char_matches);
+ return ret;
}
+ /* If the character class contains only a single element, it may be
+ * optimizable into another node type which is smaller and runs faster.
+ * Check if this is the case for this class */
+ if (element_count == 1 && ! ret_invlist) {
+ U8 op = END;
+ U8 arg = 0;
+ if (namedclass > OOB_NAMEDCLASS) { /* this is a named class, like \w or
+ [:digit:] or \p{foo} */
+ /* All named classes are mapped into POSIXish nodes, with its FLAG
+ * argument giving which class it is */
+ switch ((I32)namedclass) {
+ case ANYOF_UNIPROP:
+ break;
+
+ /* These don't depend on the charset modifiers. They always
+ * match under /u rules */
+ case ANYOF_NHORIZWS:
+ case ANYOF_HORIZWS:
+ namedclass = ANYOF_BLANK + namedclass - ANYOF_HORIZWS;
+ /* FALLTHROUGH */
+
+ case ANYOF_NVERTWS:
+ case ANYOF_VERTWS:
+ op = POSIXU;
+ goto join_posix;
+
+ /* The actual POSIXish node for all the rest depends on the
+ * charset modifier. The ones in the first set depend only on
+ * ASCII or, if available on this platform, locale */
+ case ANYOF_ASCII:
+ case ANYOF_NASCII:
+#ifdef HAS_ISASCII
+ op = (LOC) ? POSIXL : POSIXA;
+#else
+ op = POSIXA;
+#endif
+ goto join_posix;
+
+ case ANYOF_NCASED:
+ case ANYOF_LOWER:
+ case ANYOF_NLOWER:
+ case ANYOF_UPPER:
+ case ANYOF_NUPPER:
+ /* under /a could be alpha */
+ if (FOLD) {
+ if (ASCII_RESTRICTED) {
+ namedclass = ANYOF_ALPHA + (namedclass % 2);
+ }
+ else if (! LOC) {
+ break;
+ }
+ }
+ /* FALLTHROUGH */
+
+ /* The rest have more possibilities depending on the charset.
+ * We take advantage of the enum ordering of the charset
+ * modifiers to get the exact node type, */
+ default:
+ op = POSIXD + get_regex_charset(RExC_flags);
+ if (op > POSIXA) { /* /aa is same as /a */
+ op = POSIXA;
+ }
+#ifndef HAS_ISBLANK
+ if (op == POSIXL
+ && (namedclass == ANYOF_BLANK
+ || namedclass == ANYOF_NBLANK))
+ {
+ op = POSIXA;
+ }
+#endif
+
+ join_posix:
+ /* The odd numbered ones are the complements of the
+ * next-lower even number one */
+ if (namedclass % 2 == 1) {
+ invert = ! invert;
+ namedclass--;
+ }
+ arg = namedclass_to_classnum(namedclass);
+ break;
+ }
+ }
+ else if (value == prevvalue) {
+
+ /* Here, the class consists of just a single code point */
+
+ if (invert) {
+ if (! LOC && value == '\n') {
+ op = REG_ANY; /* Optimize [^\n] */
+ *flagp |= HASWIDTH|SIMPLE;
+ RExC_naughty++;
+ }
+ }
+ else if (value < 256 || UTF) {
+
+ /* Optimize a single value into an EXACTish node, but not if it
+ * would require converting the pattern to UTF-8. */
+ op = compute_EXACTish(pRExC_state);
+ }
+ } /* Otherwise is a range */
+ else if (! LOC) { /* locale could vary these */
+ if (prevvalue == '0') {
+ if (value == '9') {
+ arg = _CC_DIGIT;
+ op = POSIXA;
+ }
+ }
+ }
+
+ /* Here, we have changed <op> away from its initial value iff we found
+ * an optimization */
+ if (op != END) {
+
+ /* Throw away this ANYOF regnode, and emit the calculated one,
+ * which should correspond to the beginning, not current, state of
+ * the parse */
+ const char * cur_parse = RExC_parse;
+ RExC_parse = (char *)orig_parse;
+ if ( SIZE_ONLY) {
+ if (! LOC) {
+
+ /* To get locale nodes to not use the full ANYOF size would
+ * require moving the code above that writes the portions
+ * of it that aren't in other nodes to after this point.
+ * e.g. ANYOF_CLASS_SET */
+ RExC_size = orig_size;
+ }
+ }
+ else {
+ RExC_emit = (regnode *)orig_emit;
+ if (PL_regkind[op] == POSIXD) {
+ if (invert) {
+ op += NPOSIXD - POSIXD;
+ }
+ }
+ }
+
+ ret = reg_node(pRExC_state, op);
+
+ if (PL_regkind[op] == POSIXD || PL_regkind[op] == NPOSIXD) {
+ if (! SIZE_ONLY) {
+ FLAGS(ret) = arg;
+ }
+ *flagp |= HASWIDTH|SIMPLE;
+ }
+ else if (PL_regkind[op] == EXACT) {
+ alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value);
+ }
+
+ RExC_parse = (char *) cur_parse;
+
+ SvREFCNT_dec(posixes);
+ SvREFCNT_dec(cp_list);
+ return ret;
+ }
+ }
+
if (SIZE_ONLY)
return ret;
- /****** !SIZE_ONLY AFTER HERE *********/
+ /****** !SIZE_ONLY (Pass 2) AFTER HERE *********/
- /* If folding and there are code points above 255, we calculate all
- * characters that could fold to or from the ones already on the list */
- if (FOLD && nonbitmap) {
- UV i;
+ /* If folding, we calculate all characters that could fold to or from the
+ * ones already on the list */
+ if (FOLD && cp_list) {
+ UV start, end; /* End points of code point ranges */
- HV* fold_intersection;
- UV* fold_list;
+ SV* fold_intersection = NULL;
- /* This is a list of all the characters that participate in folds
- * (except marks, etc in multi-char folds */
- if (! PL_utf8_foldable) {
- SV* swash = swash_init("utf8", "Cased", &PL_sv_undef, 1, 0);
- PL_utf8_foldable = _swash_to_invlist(swash);
- }
+ /* If the highest code point is within Latin1, we can use the
+ * compiled-in Alphas list, and not have to go out to disk. This
+ * yields two false positives, the masculine and feminine ordinal
+ * indicators, which are weeded out below using the
+ * IS_IN_SOME_FOLD_L1() macro */
+ if (invlist_highest(cp_list) < 256) {
+ _invlist_intersection(PL_L1Posix_ptrs[_CC_ALPHA], cp_list,
+ &fold_intersection);
+ }
+ else {
- /* This is a hash that for a particular fold gives all characters
- * that are involved in it */
- if (! PL_utf8_foldclosures) {
+ /* Here, there are non-Latin1 code points, so we will have to go
+ * fetch the list of all the characters that participate in folds
+ */
+ if (! PL_utf8_foldable) {
+ SV* swash = swash_init("utf8", "_Perl_Any_Folds",
+ &PL_sv_undef, 1, 0);
+ PL_utf8_foldable = _get_swash_invlist(swash);
+ SvREFCNT_dec_NN(swash);
+ }
- /* If we were unable to find any folds, then we likely won't be
- * able to find the closures. So just create an empty list.
- * Folding will effectively be restricted to the non-Unicode rules
- * hard-coded into Perl. (This case happens legitimately during
- * compilation of Perl itself before the Unicode tables are
- * generated) */
- if (invlist_len(PL_utf8_foldable) == 0) {
- PL_utf8_foldclosures = _new_invlist(0);
- } else {
- /* If the folds haven't been read in, call a fold function
- * to force that */
- if (! PL_utf8_tofold) {
- U8 dummy[UTF8_MAXBYTES+1];
- STRLEN dummy_len;
- to_utf8_fold((U8*) "A", dummy, &dummy_len);
- }
- PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
- }
- }
+ /* This is a hash that for a particular fold gives all characters
+ * that are involved in it */
+ if (! PL_utf8_foldclosures) {
- /* Only the characters in this class that participate in folds need
- * be checked. Get the intersection of this class and all the
- * possible characters that are foldable. This can quickly narrow
- * down a large class */
- fold_intersection = invlist_intersection(PL_utf8_foldable, nonbitmap);
+ /* If we were unable to find any folds, then we likely won't be
+ * able to find the closures. So just create an empty list.
+ * Folding will effectively be restricted to the non-Unicode
+ * rules hard-coded into Perl. (This case happens legitimately
+ * during compilation of Perl itself before the Unicode tables
+ * are generated) */
+ if (_invlist_len(PL_utf8_foldable) == 0) {
+ PL_utf8_foldclosures = newHV();
+ }
+ else {
+ /* If the folds haven't been read in, call a fold function
+ * to force that */
+ if (! PL_utf8_tofold) {
+ U8 dummy[UTF8_MAXBYTES+1];
+ /* This string is just a short named one above \xff */
+ to_utf8_fold((U8*) HYPHEN_UTF8, dummy, NULL);
+ assert(PL_utf8_tofold); /* Verify that worked */
+ }
+ PL_utf8_foldclosures =
+ _swash_inversion_hash(PL_utf8_tofold);
+ }
+ }
+
+ /* Only the characters in this class that participate in folds need
+ * be checked. Get the intersection of this class and all the
+ * possible characters that are foldable. This can quickly narrow
+ * down a large class */
+ _invlist_intersection(PL_utf8_foldable, cp_list,
+ &fold_intersection);
+ }
+
/* Now look at the foldable characters in this class individually */
- fold_list = invlist_array(fold_intersection);
- for (i = 0; i < invlist_len(fold_intersection); i++) {
+ invlist_iterinit(fold_intersection);
+ while (invlist_iternext(fold_intersection, &start, &end)) {
UV j;
- /* The next entry is the beginning of the range that is in the
- * class */
- UV start = fold_list[i++];
+ /* Locale folding for Latin1 characters is deferred until runtime */
+ if (LOC && start < 256) {
+ start = 256;
+ }
-
- /* The next entry is the beginning of the next range, which
- * isn't in the class, so the end of the current range is one
- * less than that */
- UV end = fold_list[i] - 1;
-
/* Look at every character in the range */
for (j = start; j <= end; j++) {
- /* Get its fold */
U8 foldbuf[UTF8_MAXBYTES_CASE+1];
STRLEN foldlen;
- const UV f =
- _to_uni_fold_flags(j, foldbuf, &foldlen, allow_full_fold);
+ SV** listp;
- if (foldlen > (STRLEN)UNISKIP(f)) {
+ if (j < 256) {
- /* Any multicharacter foldings (disallowed in
- * lookbehind patterns) require the following
- * transform: [ABCDEF] -> (?:[ABCabcDEFd]|pq|rst) where
- * E folds into "pq" and F folds into "rst", all other
- * characters fold to single characters. We save away
- * these multicharacter foldings, to be later saved as
- * part of the additional "s" data. */
- if (! RExC_in_lookbehind) {
- U8* loc = foldbuf;
- U8* e = foldbuf + foldlen;
+ /* We have the latin1 folding rules hard-coded here so that
+ * an innocent-looking character class, like /[ks]/i won't
+ * have to go out to disk to find the possible matches.
+ * XXX It would be better to generate these via regen, in
+ * case a new version of the Unicode standard adds new
+ * mappings, though that is not really likely, and may be
+ * caught by the default: case of the switch below. */
- /* If any of the folded characters of this are in
- * the Latin1 range, tell the regex engine that
- * this can match a non-utf8 target string. The
- * only multi-byte fold whose source is in the
- * Latin1 range (U+00DF) applies only when the
- * target string is utf8, or under unicode rules */
- if (j > 255 || AT_LEAST_UNI_SEMANTICS) {
- while (loc < e) {
+ if (IS_IN_SOME_FOLD_L1(j)) {
- /* Can't mix ascii with non- under /aa */
- if (MORE_ASCII_RESTRICTED
- && (isASCII(*loc) != isASCII(j)))
- {
- goto end_multi_fold;
- }
- if (UTF8_IS_INVARIANT(*loc)
- || UTF8_IS_DOWNGRADEABLE_START(*loc))
- {
- /* Can't mix above and below 256 under
- * LOC */
- if (LOC) {
- goto end_multi_fold;
- }
- ANYOF_FLAGS(ret)
- |= ANYOF_NONBITMAP_NON_UTF8;
- break;
- }
- loc += UTF8SKIP(loc);
- }
- }
+ /* ASCII is always matched; non-ASCII is matched only
+ * under Unicode rules */
+ if (isASCII(j) || AT_LEAST_UNI_SEMANTICS) {
+ cp_list =
+ add_cp_to_invlist(cp_list, PL_fold_latin1[j]);
+ }
+ else {
+ depends_list =
+ add_cp_to_invlist(depends_list, PL_fold_latin1[j]);
+ }
+ }
- add_alternate(&unicode_alternate, foldbuf, foldlen);
- end_multi_fold: ;
- }
+ if (HAS_NONLATIN1_FOLD_CLOSURE(j)
+ && (! isASCII(j) || ! ASCII_FOLD_RESTRICTED))
+ {
+ /* Certain Latin1 characters have matches outside
+ * Latin1. To get here, <j> is one of those
+ * characters. None of these matches is valid for
+ * ASCII characters under /aa, which is why the 'if'
+ * just above excludes those. These matches only
+ * happen when the target string is utf8. The code
+ * below adds the single fold closures for <j> to the
+ * inversion list. */
+ switch (j) {
+ case 'k':
+ case 'K':
+ cp_list =
+ add_cp_to_invlist(cp_list, KELVIN_SIGN);
+ break;
+ case 's':
+ case 'S':
+ cp_list = add_cp_to_invlist(cp_list,
+ LATIN_SMALL_LETTER_LONG_S);
+ break;
+ case MICRO_SIGN:
+ cp_list = add_cp_to_invlist(cp_list,
+ GREEK_CAPITAL_LETTER_MU);
+ cp_list = add_cp_to_invlist(cp_list,
+ GREEK_SMALL_LETTER_MU);
+ break;
+ case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
+ case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
+ cp_list =
+ add_cp_to_invlist(cp_list, ANGSTROM_SIGN);
+ break;
+ case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
+ cp_list = add_cp_to_invlist(cp_list,
+ LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
+ break;
+ case LATIN_SMALL_LETTER_SHARP_S:
+ cp_list = add_cp_to_invlist(cp_list,
+ LATIN_CAPITAL_LETTER_SHARP_S);
+ break;
+ case 'F': case 'f':
+ case 'I': case 'i':
+ case 'L': case 'l':
+ case 'T': case 't':
+ case 'A': case 'a':
+ case 'H': case 'h':
+ case 'J': case 'j':
+ case 'N': case 'n':
+ case 'W': case 'w':
+ case 'Y': case 'y':
+ /* These all are targets of multi-character
+ * folds from code points that require UTF8 to
+ * express, so they can't match unless the
+ * target string is in UTF-8, so no action here
+ * is necessary, as regexec.c properly handles
+ * the general case for UTF-8 matching and
+ * multi-char folds */
+ break;
+ default:
+ /* Use deprecated warning to increase the
+ * chances of this being output */
+ ckWARN2regdep(RExC_parse, "Perl folding rules are not up-to-date for 0x%"UVXf"; please use the perlbug utility to report;", j);
+ break;
+ }
+ }
+ continue;
+ }
- /* This is special-cased, as it is the only letter which
- * has both a multi-fold and single-fold in Latin1. All
- * the other chars that have single and multi-folds are
- * always in utf8, and the utf8 folding algorithm catches
- * them */
- if (! LOC && j == LATIN_CAPITAL_LETTER_SHARP_S) {
- stored += set_regclass_bit(pRExC_state,
- ret,
- LATIN_SMALL_LETTER_SHARP_S,
- &l1_fold_invlist, &unicode_alternate);
- }
- }
- else {
- /* Single character fold. Add everything in its fold
- * closure to the list that this node should match */
- SV** listp;
+ /* Here is an above Latin1 character. We don't have the rules
+ * hard-coded for it. First, get its fold. This is the simple
+ * fold, as the multi-character folds have been handled earlier
+ * and separated out */
+ _to_uni_fold_flags(j, foldbuf, &foldlen,
+ ((LOC)
+ ? FOLD_FLAGS_LOCALE
+ : (ASCII_FOLD_RESTRICTED)
+ ? FOLD_FLAGS_NOMIX_ASCII
+ : 0));
- /* The fold closures data structure is a hash with the
- * keys being every character that is folded to, like
- * 'k', and the values each an array of everything that
- * folds to its key. e.g. [ 'k', 'K', KELVIN_SIGN ] */
- if ((listp = hv_fetch(PL_utf8_foldclosures,
- (char *) foldbuf, foldlen, FALSE)))
- {
- AV* list = (AV*) *listp;
- IV k;
- for (k = 0; k <= av_len(list); k++) {
- SV** c_p = av_fetch(list, k, FALSE);
- UV c;
- if (c_p == NULL) {
- Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
- }
- c = SvUV(*c_p);
+ /* Single character fold of above Latin1. Add everything in
+ * its fold closure to the list that this node should match.
+ * The fold closures data structure is a hash with the keys
+ * being the UTF-8 of every character that is folded to, like
+ * 'k', and the values each an array of all code points that
+ * fold to its key. e.g. [ 'k', 'K', KELVIN_SIGN ].
+ * Multi-character folds are not included */
+ if ((listp = hv_fetch(PL_utf8_foldclosures,
+ (char *) foldbuf, foldlen, FALSE)))
+ {
+ AV* list = (AV*) *listp;
+ IV k;
+ for (k = 0; k <= av_len(list); k++) {
+ SV** c_p = av_fetch(list, k, FALSE);
+ UV c;
+ if (c_p == NULL) {
+ Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
+ }
+ c = SvUV(*c_p);
- /* /aa doesn't allow folds between ASCII and
- * non-; /l doesn't allow them between above
- * and below 256 */
- if ((MORE_ASCII_RESTRICTED
- && (isASCII(c) != isASCII(j)))
- || (LOC && ((c < 256) != (j < 256))))
- {
- continue;
- }
+ /* /aa doesn't allow folds between ASCII and non-; /l
+ * doesn't allow them between above and below 256 */
+ if ((ASCII_FOLD_RESTRICTED
+ && (isASCII(c) != isASCII(j)))
+ || (LOC && ((c < 256) != (j < 256))))
+ {
+ continue;
+ }
- if (c < 256 && AT_LEAST_UNI_SEMANTICS) {
- stored += set_regclass_bit(pRExC_state,
- ret,
- (U8) c,
- &l1_fold_invlist, &unicode_alternate);
- }
- /* It may be that the code point is already
- * in this range or already in the bitmap,
- * in which case we need do nothing */
- else if ((c < start || c > end)
- && (c > 255
- || ! ANYOF_BITMAP_TEST(ret, c)))
- {
- nonbitmap = add_cp_to_invlist(nonbitmap, c);
- }
- }
- }
- }
- }
+ /* Folds involving non-ascii Latin1 characters
+ * under /d are added to a separate list */
+ if (isASCII(c) || c > 255 || AT_LEAST_UNI_SEMANTICS)
+ {
+ cp_list = add_cp_to_invlist(cp_list, c);
+ }
+ else {
+ depends_list = add_cp_to_invlist(depends_list, c);
+ }
+ }
+ }
+ }
}
- invlist_destroy(fold_intersection);
+ SvREFCNT_dec_NN(fold_intersection);
}
- /* Combine the two lists into one. */
- if (l1_fold_invlist) {
- if (nonbitmap) {
- HV* temp = invlist_union(nonbitmap, l1_fold_invlist);
- invlist_destroy(nonbitmap);
- nonbitmap = temp;
- invlist_destroy(l1_fold_invlist);
- }
- else {
- nonbitmap = l1_fold_invlist;
- }
+ /* And combine the result (if any) with any inversion list from posix
+ * classes. The lists are kept separate up to now because we don't want to
+ * fold the classes (folding of those is automatically handled by the swash
+ * fetching code) */
+ if (posixes) {
+ if (! DEPENDS_SEMANTICS) {
+ if (cp_list) {
+ _invlist_union(cp_list, posixes, &cp_list);
+ SvREFCNT_dec_NN(posixes);
+ }
+ else {
+ cp_list = posixes;
+ }
+ }
+ else {
+ /* Under /d, we put into a separate list the Latin1 things that
+ * match only when the target string is utf8 */
+ SV* nonascii_but_latin1_properties = NULL;
+ _invlist_intersection(posixes, PL_Latin1,
+ &nonascii_but_latin1_properties);
+ _invlist_subtract(nonascii_but_latin1_properties, PL_ASCII,
+ &nonascii_but_latin1_properties);
+ _invlist_subtract(posixes, nonascii_but_latin1_properties,
+ &posixes);
+ if (cp_list) {
+ _invlist_union(cp_list, posixes, &cp_list);
+ SvREFCNT_dec_NN(posixes);
+ }
+ else {
+ cp_list = posixes;
+ }
+
+ if (depends_list) {
+ _invlist_union(depends_list, nonascii_but_latin1_properties,
+ &depends_list);
+ SvREFCNT_dec_NN(nonascii_but_latin1_properties);
+ }
+ else {
+ depends_list = nonascii_but_latin1_properties;
+ }
+ }
}
+ /* And combine the result (if any) with any inversion list from properties.
+ * The lists are kept separate up to now so that we can distinguish the two
+ * in regards to matching above-Unicode. A run-time warning is generated
+ * if a Unicode property is matched against a non-Unicode code point. But,
+ * we allow user-defined properties to match anything, without any warning,
+ * and we also suppress the warning if there is a portion of the character
+ * class that isn't a Unicode property, and which matches above Unicode, \W
+ * or [\x{110000}] for example.
+ * (Note that in this case, unlike the Posix one above, there is no
+ * <depends_list>, because having a Unicode property forces Unicode
+ * semantics */
+ if (properties) {
+ bool warn_super = ! has_user_defined_property;
+ if (cp_list) {
+
+ /* If it matters to the final outcome, see if a non-property
+ * component of the class matches above Unicode. If so, the
+ * warning gets suppressed. This is true even if just a single
+ * such code point is specified, as though not strictly correct if
+ * another such code point is matched against, the fact that they
+ * are using above-Unicode code points indicates they should know
+ * the issues involved */
+ if (warn_super) {
+ bool non_prop_matches_above_Unicode =
+ runtime_posix_matches_above_Unicode
+ | (invlist_highest(cp_list) > PERL_UNICODE_MAX);
+ if (invert) {
+ non_prop_matches_above_Unicode =
+ ! non_prop_matches_above_Unicode;
+ }
+ warn_super = ! non_prop_matches_above_Unicode;
+ }
+
+ _invlist_union(properties, cp_list, &cp_list);
+ SvREFCNT_dec_NN(properties);
+ }
+ else {
+ cp_list = properties;
+ }
+
+ if (warn_super) {
+ OP(ret) = ANYOF_WARN_SUPER;
+ }
+ }
+
/* Here, we have calculated what code points should be in the character
- * class. Now we can see about various optimizations. Fold calculation
- * needs to take place before inversion. Otherwise /[^k]/i would invert to
- * include K, which under /i would match k. */
+ * class.
+ *
+ * Now we can see about various optimizations. Fold calculation (which we
+ * did above) needs to take place before inversion. Otherwise /[^k]/i
+ * would invert to include K, which under /i would match k, which it
+ * shouldn't. Therefore we can't invert folded locale now, as it won't be
+ * folded until runtime */
- /* Optimize inverted simple patterns (e.g. [^a-z]). Note that we haven't
- * set the FOLD flag yet, so this this does optimize those. It doesn't
- * optimize locale. Doing so perhaps could be done as long as there is
- * nothing like \w in it; some thought also would have to be given to the
- * interaction with above 0x100 chars */
- if (! LOC
- && (ANYOF_FLAGS(ret) & ANYOF_FLAGS_ALL) == ANYOF_INVERT
- && ! unicode_alternate
- && ! nonbitmap
- && SvCUR(listsv) == initial_listsv_len)
+ /* Optimize inverted simple patterns (e.g. [^a-z]) when everything is known
+ * at compile time. Besides not inverting folded locale now, we can't
+ * invert if there are things such as \w, which aren't known until runtime
+ * */
+ if (invert
+ && ! (LOC && (FOLD || (ANYOF_FLAGS(ret) & ANYOF_CLASS)))
+ && ! depends_list
+ && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
{
- for (value = 0; value < ANYOF_BITMAP_SIZE; ++value)
- ANYOF_BITMAP(ret)[value] ^= 0xFF;
- stored = 256 - stored;
+ _invlist_invert(cp_list);
- /* The inversion means that everything above 255 is matched; and at the
- * same time we clear the invert flag */
- ANYOF_FLAGS(ret) = ANYOF_UNICODE_ALL;
+ /* Any swash can't be used as-is, because we've inverted things */
+ if (swash) {
+ SvREFCNT_dec_NN(swash);
+ swash = NULL;
+ }
+
+ /* Clear the invert flag since have just done it here */
+ invert = FALSE;
}
- /* Folding in the bitmap is taken care of above, but not for locale (for
- * which we have to wait to see what folding is in effect at runtime), and
- * for things not in the bitmap. Set run-time fold flag for these */
- if (FOLD && (LOC || nonbitmap || unicode_alternate)) {
- ANYOF_FLAGS(ret) |= ANYOF_LOC_NONBITMAP_FOLD;
+ if (ret_invlist) {
+ *ret_invlist = cp_list;
+ SvREFCNT_dec(swash);
+
+ /* Discard the generated node */
+ if (SIZE_ONLY) {
+ RExC_size = orig_size;
+ }
+ else {
+ RExC_emit = orig_emit;
+ }
+ return orig_emit;
}
- /* A single character class can be "optimized" into an EXACTish node.
- * Note that since we don't currently count how many characters there are
- * outside the bitmap, we are XXX missing optimization possibilities for
- * them. This optimization can't happen unless this is a truly single
- * character class, which means that it can't be an inversion into a
- * many-character class, and there must be no possibility of there being
- * things outside the bitmap. 'stored' (only) for locales doesn't include
- * \w, etc, so have to make a special test that they aren't present
- *
- * Similarly A 2-character class of the very special form like [bB] can be
- * optimized into an EXACTFish node, but only for non-locales, and for
- * characters which only have the two folds; so things like 'fF' and 'Ii'
- * wouldn't work because they are part of the fold of 'LATIN SMALL LIGATURE
- * FI'. */
- if (! nonbitmap
- && ! unicode_alternate
- && SvCUR(listsv) == initial_listsv_len
- && ! (ANYOF_FLAGS(ret) & (ANYOF_INVERT|ANYOF_UNICODE_ALL))
- && (((stored == 1 && ((! (ANYOF_FLAGS(ret) & ANYOF_LOCALE))
- || (! ANYOF_CLASS_TEST_ANY_SET(ret)))))
- || (stored == 2 && ((! (ANYOF_FLAGS(ret) & ANYOF_LOCALE))
- && (! _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(value))
- /* If the latest code point has a fold whose
- * bit is set, it must be the only other one */
- && ((prevvalue = PL_fold_latin1[value]) != (IV)value)
- && ANYOF_BITMAP_TEST(ret, prevvalue)))))
+ /* If we didn't do folding, it's because some information isn't available
+ * until runtime; set the run-time fold flag for these. (We don't have to
+ * worry about properties folding, as that is taken care of by the swash
+ * fetching) */
+ if (FOLD && LOC)
{
- /* Note that the information needed to decide to do this optimization
- * is not currently available until the 2nd pass, and that the actually
- * used EXACTish node takes less space than the calculated ANYOF node,
- * and hence the amount of space calculated in the first pass is larger
- * than actually used, so this optimization doesn't gain us any space.
- * But an EXACT node is faster than an ANYOF node, and can be combined
- * with any adjacent EXACT nodes later by the optimizer for further
- * gains. The speed of executing an EXACTF is similar to an ANYOF
- * node, so the optimization advantage comes from the ability to join
- * it to adjacent EXACT nodes */
+ ANYOF_FLAGS(ret) |= ANYOF_LOC_FOLD;
+ }
+ /* Some character classes are equivalent to other nodes. Such nodes take
+ * up less room and generally fewer operations to execute than ANYOF nodes.
+ * Above, we checked for and optimized into some such equivalents for
+ * certain common classes that are easy to test. Getting to this point in
+ * the code means that the class didn't get optimized there. Since this
+ * code is only executed in Pass 2, it is too late to save space--it has
+ * been allocated in Pass 1, and currently isn't given back. But turning
+ * things into an EXACTish node can allow the optimizer to join it to any
+ * adjacent such nodes. And if the class is equivalent to things like /./,
+ * expensive run-time swashes can be avoided. Now that we have more
+ * complete information, we can find things necessarily missed by the
+ * earlier code. I (khw) am not sure how much to look for here. It would
+ * be easy, but perhaps too slow, to check any candidates against all the
+ * node types they could possibly match using _invlistEQ(). */
+
+ if (cp_list
+ && ! invert
+ && ! depends_list
+ && ! (ANYOF_FLAGS(ret) & ANYOF_CLASS)
+ && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
+ {
+ UV start, end;
+ U8 op = END; /* The optimzation node-type */
const char * cur_parse= RExC_parse;
- U8 op;
- RExC_emit = (regnode *)orig_emit;
- RExC_parse = (char *)orig_parse;
- if (stored == 1) {
+ invlist_iterinit(cp_list);
+ if (! invlist_iternext(cp_list, &start, &end)) {
- /* A locale node with one point can be folded; all the other cases
- * with folding will have two points, since we calculate them above
- */
- if (ANYOF_FLAGS(ret) & ANYOF_LOC_NONBITMAP_FOLD) {
- op = EXACTFL;
- }
- else {
- op = EXACT;
- }
- } /* else 2 chars in the bit map: the folds of each other */
- else if (AT_LEAST_UNI_SEMANTICS || !isASCII(value)) {
+ /* Here, the list is empty. This happens, for example, when a
+ * Unicode property is the only thing in the character class, and
+ * it doesn't match anything. (perluniprops.pod notes such
+ * properties) */
+ op = OPFAIL;
+ *flagp |= HASWIDTH|SIMPLE;
+ }
+ else if (start == end) { /* The range is a single code point */
+ if (! invlist_iternext(cp_list, &start, &end)
- /* To join adjacent nodes, they must be the exact EXACTish type.
- * Try to use the most likely type, by using EXACTFU if the regex
- * calls for them, or is required because the character is
- * non-ASCII */
- op = EXACTFU;
- }
- else { /* Otherwise, more likely to be EXACTF type */
- op = EXACTF;
- }
+ /* Don't do this optimization if it would require changing
+ * the pattern to UTF-8 */
+ && (start < 256 || UTF))
+ {
+ /* Here, the list contains a single code point. Can optimize
+ * into an EXACT node */
- ret = reg_node(pRExC_state, op);
- RExC_parse = (char *)cur_parse;
- if (UTF && ! NATIVE_IS_INVARIANT(value)) {
- *STRING(ret)= UTF8_EIGHT_BIT_HI((U8) value);
- *(STRING(ret) + 1)= UTF8_EIGHT_BIT_LO((U8) value);
- STR_LEN(ret)= 2;
- RExC_emit += STR_SZ(2);
- }
- else {
- *STRING(ret)= (char)value;
- STR_LEN(ret)= 1;
- RExC_emit += STR_SZ(1);
- }
- SvREFCNT_dec(listsv);
- return ret;
+ value = start;
+
+ if (! FOLD) {
+ op = EXACT;
+ }
+ else if (LOC) {
+
+ /* A locale node under folding with one code point can be
+ * an EXACTFL, as its fold won't be calculated until
+ * runtime */
+ op = EXACTFL;
+ }
+ else {
+
+ /* Here, we are generally folding, but there is only one
+ * code point to match. If we have to, we use an EXACT
+ * node, but it would be better for joining with adjacent
+ * nodes in the optimization pass if we used the same
+ * EXACTFish node that any such are likely to be. We can
+ * do this iff the code point doesn't participate in any
+ * folds. For example, an EXACTF of a colon is the same as
+ * an EXACT one, since nothing folds to or from a colon. */
+ if (value < 256) {
+ if (IS_IN_SOME_FOLD_L1(value)) {
+ op = EXACT;
+ }
+ }
+ else {
+ if (! PL_utf8_foldable) {
+ SV* swash = swash_init("utf8", "_Perl_Any_Folds",
+ &PL_sv_undef, 1, 0);
+ PL_utf8_foldable = _get_swash_invlist(swash);
+ SvREFCNT_dec_NN(swash);
+ }
+ if (_invlist_contains_cp(PL_utf8_foldable, value)) {
+ op = EXACT;
+ }
+ }
+
+ /* If we haven't found the node type, above, it means we
+ * can use the prevailing one */
+ if (op == END) {
+ op = compute_EXACTish(pRExC_state);
+ }
+ }
+ }
+ }
+ else if (start == 0) {
+ if (end == UV_MAX) {
+ op = SANY;
+ *flagp |= HASWIDTH|SIMPLE;
+ RExC_naughty++;
+ }
+ else if (end == '\n' - 1
+ && invlist_iternext(cp_list, &start, &end)
+ && start == '\n' + 1 && end == UV_MAX)
+ {
+ op = REG_ANY;
+ *flagp |= HASWIDTH|SIMPLE;
+ RExC_naughty++;
+ }
+ }
+ invlist_iterfinish(cp_list);
+
+ if (op != END) {
+ RExC_parse = (char *)orig_parse;
+ RExC_emit = (regnode *)orig_emit;
+
+ ret = reg_node(pRExC_state, op);
+
+ RExC_parse = (char *)cur_parse;
+
+ if (PL_regkind[op] == EXACT) {
+ alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value);
+ }
+
+ SvREFCNT_dec_NN(cp_list);
+ return ret;
+ }
}
- if (nonbitmap) {
- UV* nonbitmap_array = invlist_array(nonbitmap);
- UV nonbitmap_len = invlist_len(nonbitmap);
- UV i;
+ /* Here, <cp_list> contains all the code points we can determine at
+ * compile time that match under all conditions. Go through it, and
+ * for things that belong in the bitmap, put them there, and delete from
+ * <cp_list>. While we are at it, see if everything above 255 is in the
+ * list, and if so, set a flag to speed up execution */
+ ANYOF_BITMAP_ZERO(ret);
+ if (cp_list) {
- /* Here have the full list of items to match that aren't in the
- * bitmap. Convert to the structure that the rest of the code is
- * expecting. XXX That rest of the code should convert to this
- * structure */
- for (i = 0; i < nonbitmap_len; i++) {
+ /* This gets set if we actually need to modify things */
+ bool change_invlist = FALSE;
- /* The next entry is the beginning of the range that is in the
- * class */
- UV start = nonbitmap_array[i++];
- UV end;
+ UV start, end;
- /* The next entry is the beginning of the next range, which isn't
- * in the class, so the end of the current range is one less than
- * that. But if there is no next range, it means that the range
- * begun by 'start' extends to infinity, which for this platform
- * ends at UV_MAX */
- if (i == nonbitmap_len) {
- end = UV_MAX;
+ /* Start looking through <cp_list> */
+ invlist_iterinit(cp_list);
+ while (invlist_iternext(cp_list, &start, &end)) {
+ UV high;
+ int i;
+
+ if (end == UV_MAX && start <= 256) {
+ ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;
+ }
+
+ /* Quit if are above what we should change */
+ if (start > 255) {
+ break;
}
- else {
- end = nonbitmap_array[i] - 1;
- }
- if (start == end) {
- Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n", start);
+ change_invlist = TRUE;
+
+ /* Set all the bits in the range, up to the max that we are doing */
+ high = (end < 255) ? end : 255;
+ for (i = start; i <= (int) high; i++) {
+ if (! ANYOF_BITMAP_TEST(ret, i)) {
+ ANYOF_BITMAP_SET(ret, i);
+ prevvalue = value;
+ value = i;
+ }
}
- else {
- /* The \t sets the whole range */
- Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n",
- /* XXX EBCDIC */
- start, end);
- }
}
- invlist_destroy(nonbitmap);
+ invlist_iterfinish(cp_list);
+
+ /* Done with loop; remove any code points that are in the bitmap from
+ * <cp_list> */
+ if (change_invlist) {
+ _invlist_subtract(cp_list, PL_Latin1, &cp_list);
+ }
+
+ /* If have completely emptied it, remove it completely */
+ if (_invlist_len(cp_list) == 0) {
+ SvREFCNT_dec_NN(cp_list);
+ cp_list = NULL;
+ }
}
- if (SvCUR(listsv) == initial_listsv_len && ! unicode_alternate) {
+ if (invert) {
+ ANYOF_FLAGS(ret) |= ANYOF_INVERT;
+ }
+
+ /* Here, the bitmap has been populated with all the Latin1 code points that
+ * always match. Can now add to the overall list those that match only
+ * when the target string is UTF-8 (<depends_list>). */
+ if (depends_list) {
+ if (cp_list) {
+ _invlist_union(cp_list, depends_list, &cp_list);
+ SvREFCNT_dec_NN(depends_list);
+ }
+ else {
+ cp_list = depends_list;
+ }
+ }
+
+ /* If there is a swash and more than one element, we can't use the swash in
+ * the optimization below. */
+ if (swash && element_count > 1) {
+ SvREFCNT_dec_NN(swash);
+ swash = NULL;
+ }
+
+ if (! cp_list
+ && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
+ {
ARG_SET(ret, ANYOF_NONBITMAP_EMPTY);
- SvREFCNT_dec(listsv);
- SvREFCNT_dec(unicode_alternate);
}
else {
-
+ /* av[0] stores the character class description in its textual form:
+ * used later (regexec.c:Perl_regclass_swash()) to initialize the
+ * appropriate swash, and is also useful for dumping the regnode.
+ * av[1] if NULL, is a placeholder to later contain the swash computed
+ * from av[0]. But if no further computation need be done, the
+ * swash is stored there now.
+ * av[2] stores the cp_list inversion list for use in addition or
+ * instead of av[0]; used only if av[1] is NULL
+ * av[3] is set if any component of the class is from a user-defined
+ * property; used only if av[1] is NULL */
AV * const av = newAV();
SV *rv;
- /* The 0th element stores the character class description
- * in its textual form: used later (regexec.c:Perl_regclass_swash())
- * to initialize the appropriate swash (which gets stored in
- * the 1st element), and also useful for dumping the regnode.
- * The 2nd element stores the multicharacter foldings,
- * used later (regexec.c:S_reginclass()). */
- av_store(av, 0, listsv);
- av_store(av, 1, NULL);
- /* Store any computed multi-char folds only if we are allowing
- * them */
- if (allow_full_fold) {
- av_store(av, 2, MUTABLE_SV(unicode_alternate));
- if (unicode_alternate) { /* This node is variable length */
- OP(ret) = ANYOFV;
- }
- }
- else {
- av_store(av, 2, NULL);
- }
+ av_store(av, 0, (HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
+ ? SvREFCNT_inc(listsv) : &PL_sv_undef);
+ if (swash) {
+ av_store(av, 1, swash);
+ SvREFCNT_dec_NN(cp_list);
+ }
+ else {
+ av_store(av, 1, NULL);
+ if (cp_list) {
+ av_store(av, 2, cp_list);
+ av_store(av, 3, newSVuv(has_user_defined_property));
+ }
+ }
+
rv = newRV_noinc(MUTABLE_SV(av));
n = add_data(pRExC_state, 1, "s");
RExC_rxi->data->data[n] = (void*)rv;
ARG_SET(ret, n);
}
+
+ *flagp |= HASWIDTH|SIMPLE;
return ret;
}
-#undef _C_C_T_
+#undef HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION
/* reg_skipcomment()
@@ -10451,8 +14005,11 @@
PERL_ARGS_ASSERT_NEXTCHAR;
for (;;) {
- if (*RExC_parse == '(' && RExC_parse[1] == '?' &&
- RExC_parse[2] == '#') {
+ if (RExC_end - RExC_parse >= 3
+ && *RExC_parse == '('
+ && RExC_parse[1] == '?'
+ && RExC_parse[2] == '#')
+ {
while (*RExC_parse != ')') {
if (RExC_parse == RExC_end)
FAIL("Sequence (?#... not terminated");
@@ -10482,7 +14039,7 @@
S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
{
dVAR;
- register regnode *ptr;
+ regnode *ptr;
regnode * const ret = RExC_emit;
GET_RE_DEBUG_FLAGS_DECL;
@@ -10494,7 +14051,8 @@
return(ret);
}
if (RExC_emit >= RExC_emit_bound)
- Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d", op);
+ Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
+ op, RExC_emit, RExC_emit_bound);
NODE_ALIGN_FILL(ret);
ptr = ret;
@@ -10523,7 +14081,7 @@
S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
{
dVAR;
- register regnode *ptr;
+ regnode *ptr;
regnode * const ret = RExC_emit;
GET_RE_DEBUG_FLAGS_DECL;
@@ -10536,7 +14094,7 @@
We can't do this:
assert(2==regarglen[op]+1);
-
+
Anything larger than this has to allocate the extra amount.
If we changed this to be:
@@ -10549,7 +14107,8 @@
return(ret);
}
if (RExC_emit >= RExC_emit_bound)
- Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d", op);
+ Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
+ op, RExC_emit, RExC_emit_bound);
NODE_ALIGN_FILL(ret);
ptr = ret;
@@ -10594,9 +14153,9 @@
S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
{
dVAR;
- register regnode *src;
- register regnode *dst;
- register regnode *place;
+ regnode *src;
+ regnode *dst;
+ regnode *place;
const int offset = regarglen[(U8)op];
const int size = NODE_STEP_REGNODE + offset;
GET_RE_DEBUG_FLAGS_DECL;
@@ -10682,7 +14241,7 @@
S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
{
dVAR;
- register regnode *scan;
+ regnode *scan;
GET_RE_DEBUG_FLAGS_DECL;
PERL_ARGS_ASSERT_REGTAIL;
@@ -10741,7 +14300,7 @@
S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
{
dVAR;
- register regnode *scan;
+ regnode *scan;
U8 exact = PSEUDO;
#ifdef EXPERIMENTAL_INPLACESCAN
I32 min = 0;
@@ -10760,9 +14319,11 @@
for (;;) {
regnode * const temp = regnext(scan);
#ifdef EXPERIMENTAL_INPLACESCAN
- if (PL_regkind[OP(scan)] == EXACT)
- if (join_exact(pRExC_state,scan,&min,1,val,depth+1))
+ if (PL_regkind[OP(scan)] == EXACT) {
+ bool has_exactf_sharp_s; /* Unexamined in this routine */
+ if (join_exact(pRExC_state,scan,&min, &has_exactf_sharp_s, 1,val,depth+1))
return EXACT;
+ }
#endif
if ( exact ) {
switch (OP(scan)) {
@@ -10770,6 +14331,8 @@
case EXACTF:
case EXACTFA:
case EXACTFU:
+ case EXACTFU_SS:
+ case EXACTFU_TRICKYFOLD:
case EXACTFL:
if( exact == PSEUDO )
exact= OP(scan);
@@ -10978,7 +14541,53 @@
{
#ifdef DEBUGGING
dVAR;
- register int k;
+ int k;
+
+ /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */
+ static const char * const anyofs[] = {
+#if _CC_WORDCHAR != 0 || _CC_DIGIT != 1 || _CC_ALPHA != 2 || _CC_LOWER != 3 \
+ || _CC_UPPER != 4 || _CC_PUNCT != 5 || _CC_PRINT != 6 \
+ || _CC_ALPHANUMERIC != 7 || _CC_GRAPH != 8 || _CC_CASED != 9 \
+ || _CC_SPACE != 10 || _CC_BLANK != 11 || _CC_XDIGIT != 12 \
+ || _CC_PSXSPC != 13 || _CC_CNTRL != 14 || _CC_ASCII != 15 \
+ || _CC_VERTSPACE != 16
+ #error Need to adjust order of anyofs[]
+#endif
+ "[\\w]",
+ "[\\W]",
+ "[\\d]",
+ "[\\D]",
+ "[:alpha:]",
+ "[:^alpha:]",
+ "[:lower:]",
+ "[:^lower:]",
+ "[:upper:]",
+ "[:^upper:]",
+ "[:punct:]",
+ "[:^punct:]",
+ "[:print:]",
+ "[:^print:]",
+ "[:alnum:]",
+ "[:^alnum:]",
+ "[:graph:]",
+ "[:^graph:]",
+ "[:cased:]",
+ "[:^cased:]",
+ "[\\s]",
+ "[\\S]",
+ "[:blank:]",
+ "[:^blank:]",
+ "[:xdigit:]",
+ "[:^xdigit:]",
+ "[:space:]",
+ "[:^space:]",
+ "[:cntrl:]",
+ "[:^cntrl:]",
+ "[:ascii:]",
+ "[:^ascii:]",
+ "[\\v]",
+ "[\\V]"
+ };
RXi_GET_DECL(prog,progi);
GET_RE_DEBUG_FLAGS_DECL;
@@ -11094,55 +14703,20 @@
SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
} else if (k == LOGICAL)
Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* 2: embedded, otherwise 1 */
- else if (k == FOLDCHAR)
- Perl_sv_catpvf(aTHX_ sv, "[0x%"UVXf"]", PTR2UV(ARG(o)) );
else if (k == ANYOF) {
int i, rangestart = -1;
const U8 flags = ANYOF_FLAGS(o);
int do_sep = 0;
- /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */
- static const char * const anyofs[] = {
- "\\w",
- "\\W",
- "\\s",
- "\\S",
- "\\d",
- "\\D",
- "[:alnum:]",
- "[:^alnum:]",
- "[:alpha:]",
- "[:^alpha:]",
- "[:ascii:]",
- "[:^ascii:]",
- "[:cntrl:]",
- "[:^cntrl:]",
- "[:graph:]",
- "[:^graph:]",
- "[:lower:]",
- "[:^lower:]",
- "[:print:]",
- "[:^print:]",
- "[:punct:]",
- "[:^punct:]",
- "[:upper:]",
- "[:^upper:]",
- "[:xdigit:]",
- "[:^xdigit:]",
- "[:space:]",
- "[:^space:]",
- "[:blank:]",
- "[:^blank:]"
- };
if (flags & ANYOF_LOCALE)
sv_catpvs(sv, "{loc}");
- if (flags & ANYOF_LOC_NONBITMAP_FOLD)
+ if (flags & ANYOF_LOC_FOLD)
sv_catpvs(sv, "{i}");
Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
if (flags & ANYOF_INVERT)
sv_catpvs(sv, "^");
-
+
/* output what the standard cp 0-255 bitmap matches */
for (i = 0; i <= 256; i++) {
if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
@@ -11186,72 +14760,100 @@
sv_catpvs(sv, "{outside bitmap}");
if (ANYOF_NONBITMAP(o)) {
- SV *lv;
- SV * const sw = regclass_swash(prog, o, FALSE, &lv, 0);
-
- if (lv) {
+ SV *lv; /* Set if there is something outside the bit map */
+ SV * const sw = regclass_swash(prog, o, FALSE, &lv, NULL);
+ bool byte_output = FALSE; /* If something in the bitmap has been
+ output */
+
+ if (lv && lv != &PL_sv_undef) {
if (sw) {
U8 s[UTF8_MAXBYTES_CASE+1];
- for (i = 0; i <= 256; i++) { /* just the first 256 */
+ for (i = 0; i <= 256; i++) { /* Look at chars in bitmap */
uvchr_to_utf8(s, i);
-
- if (i < 256 && swash_fetch(sw, s, TRUE)) {
+
+ if (i < 256
+ && ! ANYOF_BITMAP_TEST(o, i) /* Don't duplicate
+ things already
+ output as part
+ of the bitmap */
+ && swash_fetch(sw, s, TRUE))
+ {
if (rangestart == -1)
rangestart = i;
} else if (rangestart != -1) {
+ byte_output = TRUE;
if (i <= rangestart + 3)
for (; rangestart < i; rangestart++) {
- const U8 * const e = uvchr_to_utf8(s,rangestart);
- U8 *p;
- for(p = s; p < e; p++)
- put_byte(sv, *p);
+ put_byte(sv, rangestart);
}
else {
- const U8 *e = uvchr_to_utf8(s,rangestart);
- U8 *p;
- for (p = s; p < e; p++)
- put_byte(sv, *p);
+ put_byte(sv, rangestart);
sv_catpvs(sv, "-");
- e = uvchr_to_utf8(s, i-1);
- for (p = s; p < e; p++)
- put_byte(sv, *p);
- }
- rangestart = -1;
+ put_byte(sv, i-1);
}
+ rangestart = -1;
}
-
- sv_catpvs(sv, "..."); /* et cetera */
+ }
}
{
char *s = savesvpv(lv);
char * const origs = s;
-
+
while (*s && *s != '\n')
s++;
-
+
if (*s == '\n') {
const char * const t = ++s;
-
+
+ if (byte_output) {
+ sv_catpvs(sv, " ");
+ }
+
while (*s) {
- if (*s == '\n')
+ if (*s == '\n') {
+
+ /* Truncate very long output */
+ if (s - origs > 256) {
+ Perl_sv_catpvf(aTHX_ sv,
+ "%.*s...",
+ (int) (s - origs - 1),
+ t);
+ goto out_dump;
+ }
*s = ' ';
+ }
+ else if (*s == '\t') {
+ *s = '-';
+ }
s++;
}
if (s[-1] == ' ')
s[-1] = 0;
-
+
sv_catpv(sv, t);
}
-
+
+ out_dump:
+
Safefree(origs);
}
+ SvREFCNT_dec_NN(lv);
}
}
Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
}
+ else if (k == POSIXD || k == NPOSIXD) {
+ U8 index = FLAGS(o) * 2;
+ if (index > (sizeof(anyofs) / sizeof(anyofs[0]))) {
+ Perl_sv_catpvf(aTHX_ sv, "[illegal type=%d])", index);
+ }
+ else {
+ sv_catpv(sv, anyofs[index]);
+ }
+ }
else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
#else
@@ -11266,7 +14868,7 @@
Perl_re_intuit_string(pTHX_ REGEXP * const r)
{ /* Assume that RE_INTUIT is set */
dVAR;
- struct regexp *const prog = (struct regexp *)SvANY(r);
+ struct regexp *const prog = ReANY(r);
GET_RE_DEBUG_FLAGS_DECL;
PERL_ARGS_ASSERT_RE_INTUIT_STRING;
@@ -11314,7 +14916,7 @@
Perl_pregfree2(pTHX_ REGEXP *rx)
{
dVAR;
- struct regexp *const r = (struct regexp *)SvANY(rx);
+ struct regexp *const r = ReANY(rx);
GET_RE_DEBUG_FLAGS_DECL;
PERL_ARGS_ASSERT_PREGFREE2;
@@ -11324,6 +14926,7 @@
} else {
CALLREGFREE_PVT(rx); /* free the private data */
SvREFCNT_dec(RXp_PAREN_NAMES(r));
+ Safefree(r->xpv_len_u.xpvlenu_pv);
}
if (r->substrs) {
SvREFCNT_dec(r->anchored_substr);
@@ -11333,10 +14936,12 @@
Safefree(r->substrs);
}
RX_MATCH_COPY_FREE(rx);
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
SvREFCNT_dec(r->saved_copy);
#endif
Safefree(r->offs);
+ SvREFCNT_dec(r->qr_anoncv);
+ rx->sv_u.svu_rx = 0;
}
/* reg_temp_copy()
@@ -11360,29 +14965,47 @@
Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
{
struct regexp *ret;
- struct regexp *const r = (struct regexp *)SvANY(rx);
- register const I32 npar = r->nparens+1;
+ struct regexp *const r = ReANY(rx);
+ const bool islv = ret_x && SvTYPE(ret_x) == SVt_PVLV;
PERL_ARGS_ASSERT_REG_TEMP_COPY;
if (!ret_x)
ret_x = (REGEXP*) newSV_type(SVt_REGEXP);
- ret = (struct regexp *)SvANY(ret_x);
+ else {
+ SvOK_off((SV *)ret_x);
+ if (islv) {
+ /* For PVLVs, SvANY points to the xpvlv body while sv_u points
+ to the regexp. (For SVt_REGEXPs, sv_upgrade has already
+ made both spots point to the same regexp body.) */
+ REGEXP *temp = (REGEXP *)newSV_type(SVt_REGEXP);
+ assert(!SvPVX(ret_x));
+ ret_x->sv_u.svu_rx = temp->sv_any;
+ temp->sv_any = NULL;
+ SvFLAGS(temp) = (SvFLAGS(temp) & ~SVTYPEMASK) | SVt_NULL;
+ SvREFCNT_dec_NN(temp);
+ /* SvCUR still resides in the xpvlv struct, so the regexp copy-
+ ing below will not set it. */
+ SvCUR_set(ret_x, SvCUR(rx));
+ }
+ }
+ /* This ensures that SvTHINKFIRST(sv) is true, and hence that
+ sv_force_normal(sv) is called. */
+ SvFAKE_on(ret_x);
+ ret = ReANY(ret_x);
- (void)ReREFCNT_inc(rx);
- /* We can take advantage of the existing "copied buffer" mechanism in SVs
- by pointing directly at the buffer, but flagging that the allocated
- space in the copy is zero. As we've just done a struct copy, it's now
- a case of zero-ing that, rather than copying the current length. */
- SvPV_set(ret_x, RX_WRAPPED(rx));
- SvFLAGS(ret_x) |= SvFLAGS(rx) & (SVf_POK|SVp_POK|SVf_UTF8);
+ SvFLAGS(ret_x) |= SvUTF8(rx);
+ /* We share the same string buffer as the original regexp, on which we
+ hold a reference count, incremented when mother_re is set below.
+ The string pointer is copied here, being part of the regexp struct.
+ */
memcpy(&(ret->xpv_cur), &(r->xpv_cur),
sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
- SvLEN_set(ret_x, 0);
- SvSTASH_set(ret_x, NULL);
- SvMAGIC_set(ret_x, NULL);
- Newx(ret->offs, npar, regexp_paren_pair);
- Copy(r->offs, ret->offs, npar, regexp_paren_pair);
+ if (r->offs) {
+ const I32 npar = r->nparens+1;
+ Newx(ret->offs, npar, regexp_paren_pair);
+ Copy(r->offs, ret->offs, npar, regexp_paren_pair);
+ }
if (r->substrs) {
Newx(ret->substrs, 1, struct reg_substr_data);
StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
@@ -11396,10 +15019,11 @@
anchored or float namesakes, and don't hold a second reference. */
}
RX_MATCH_COPIED_off(ret_x);
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
ret->saved_copy = NULL;
#endif
- ret->mother_re = rx;
+ ret->mother_re = ReREFCNT_inc(r->mother_re ? r->mother_re : rx);
+ SvREFCNT_inc_void(ret->qr_anoncv);
return ret_x;
}
@@ -11421,7 +15045,7 @@
Perl_regfree_internal(pTHX_ REGEXP * const rx)
{
dVAR;
- struct regexp *const r = (struct regexp *)SvANY(rx);
+ struct regexp *const r = ReANY(rx);
RXi_GET_DECL(r,ri);
GET_RE_DEBUG_FLAGS_DECL;
@@ -11442,16 +15066,21 @@
if (ri->u.offsets)
Safefree(ri->u.offsets); /* 20010421 MJD */
#endif
+ if (ri->code_blocks) {
+ int n;
+ for (n = 0; n < ri->num_code_blocks; n++)
+ SvREFCNT_dec(ri->code_blocks[n].src_regex);
+ Safefree(ri->code_blocks);
+ }
+
if (ri->data) {
int n = ri->data->count;
- PAD* new_comppad = NULL;
- PAD* old_comppad;
- PADOFFSET refcnt;
while (--n >= 0) {
/* If you add a ->what type here, update the comment in regcomp.h */
switch (ri->data->what[n]) {
case 'a':
+ case 'r':
case 's':
case 'S':
case 'u':
@@ -11460,27 +15089,8 @@
case 'f':
Safefree(ri->data->data[n]);
break;
- case 'p':
- new_comppad = MUTABLE_AV(ri->data->data[n]);
- break;
- case 'o':
- if (new_comppad == NULL)
- Perl_croak(aTHX_ "panic: pregfree comppad");
- PAD_SAVE_LOCAL(old_comppad,
- /* Watch out for global destruction's random ordering. */
- (SvTYPE(new_comppad) == SVt_PVAV) ? new_comppad : NULL
- );
- OP_REFCNT_LOCK;
- refcnt = OpREFCNT_dec((OP_4tree*)ri->data->data[n]);
- OP_REFCNT_UNLOCK;
- if (!refcnt)
- op_free((OP_4tree*)ri->data->data[n]);
-
- PAD_RESTORE_LOCAL(old_comppad);
- SvREFCNT_dec(MUTABLE_SV(new_comppad));
- new_comppad = NULL;
- break;
- case 'n':
+ case 'l':
+ case 'L':
break;
case 'T':
{ /* Aho Corasick add-on structure for a trie node.
@@ -11556,8 +15166,8 @@
{
dVAR;
I32 npar;
- const struct regexp *r = (const struct regexp *)SvANY(sstr);
- struct regexp *ret = (struct regexp *)SvANY(dstr);
+ const struct regexp *r = ReANY(sstr);
+ struct regexp *ret = ReANY(dstr);
PERL_ARGS_ASSERT_RE_DUP_GUTS;
@@ -11564,10 +15174,6 @@
npar = r->nparens+1;
Newx(ret->offs, npar, regexp_paren_pair);
Copy(r->offs, ret->offs, npar, regexp_paren_pair);
- if(ret->swap) {
- /* no need to copy these */
- Newx(ret->swap, npar, regexp_paren_pair);
- }
if (ret->substrs) {
/* Do it this way to avoid reading from *r after the StructCopy().
@@ -11608,6 +15214,7 @@
}
RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
+ ret->qr_anoncv = MUTABLE_CV(sv_dup_inc((const SV *)ret->qr_anoncv, param));
if (ret->pprivate)
RXi_SET(ret,CALLREGDUPE_PVT(dstr,param));
@@ -11616,24 +15223,18 @@
ret->subbeg = SAVEPVN(ret->subbeg, ret->sublen);
else
ret->subbeg = NULL;
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
ret->saved_copy = NULL;
#endif
- if (ret->mother_re) {
- if (SvPVX_const(dstr) == SvPVX_const(ret->mother_re)) {
- /* Our storage points directly to our mother regexp, but that's
+ /* Whether mother_re be set or no, we need to copy the string. We
+ cannot refrain from copying it when the storage points directly to
+ our mother regexp, because that's
1: a buffer in a different thread
2: something we no longer hold a reference on
so we need to copy it locally. */
- /* Note we need to sue SvCUR() on our mother_re, because it, in
- turn, may well be pointing to its own mother_re. */
- SvPV_set(dstr, SAVEPVN(SvPVX_const(ret->mother_re),
- SvCUR(ret->mother_re)+1));
- SvLEN_set(dstr, SvCUR(ret->mother_re)+1);
- }
- ret->mother_re = NULL;
- }
+ RX_WRAPPED(dstr) = SAVEPVN(RX_WRAPPED(sstr), SvCUR(sstr)+1);
+ ret->mother_re = NULL;
ret->gofs = 0;
}
#endif /* PERL_IN_XSUB_RE */
@@ -11656,20 +15257,32 @@
Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
{
dVAR;
- struct regexp *const r = (struct regexp *)SvANY(rx);
+ struct regexp *const r = ReANY(rx);
regexp_internal *reti;
- int len, npar;
+ int len;
RXi_GET_DECL(r,ri);
PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
- npar = r->nparens+1;
len = ProgLen(ri);
Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode), char, regexp_internal);
Copy(ri->program, reti->program, len+1, regnode);
-
+ reti->num_code_blocks = ri->num_code_blocks;
+ if (ri->code_blocks) {
+ int n;
+ Newxc(reti->code_blocks, ri->num_code_blocks, struct reg_code_block,
+ struct reg_code_block);
+ Copy(ri->code_blocks, reti->code_blocks, ri->num_code_blocks,
+ struct reg_code_block);
+ for (n = 0; n < ri->num_code_blocks; n++)
+ reti->code_blocks[n].src_regex = (REGEXP*)
+ sv_dup_inc((SV*)(ri->code_blocks[n].src_regex), param);
+ }
+ else
+ reti->code_blocks = NULL;
+
reti->regstclass = NULL;
if (ri->data) {
@@ -11685,12 +15298,11 @@
for (i = 0; i < count; i++) {
d->what[i] = ri->data->what[i];
switch (d->what[i]) {
- /* legal options are one of: sSfpontTua
- see also regcomp.h and pregfree() */
+ /* see also regcomp.h and regfree_internal() */
case 'a': /* actually an AV, but the dup function is identical. */
+ case 'r':
case 's':
case 'S':
- case 'p': /* actually an AV, but the dup function is identical. */
case 'u': /* actually an HV, but the dup function is identical. */
d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
break;
@@ -11701,13 +15313,6 @@
struct regnode_charclass_class);
reti->regstclass = (regnode*)d->data[i];
break;
- case 'o':
- /* Compiled op trees are readonly and in shared memory,
- and can thus be shared without duplication. */
- OP_REFCNT_LOCK;
- d->data[i] = (void*)OpREFCNT_inc((OP*)ri->data->data[i]);
- OP_REFCNT_UNLOCK;
- break;
case 'T':
/* Trie stclasses are readonly and can thus be shared
* without duplication. We free the stclass in pregfree
@@ -11720,7 +15325,8 @@
((reg_trie_data*)ri->data->data[i])->refcount++;
OP_REFCNT_UNLOCK;
/* Fall through */
- case 'n':
+ case 'l':
+ case 'L':
d->data[i] = ri->data->data[i];
break;
default:
@@ -11755,10 +15361,10 @@
- regnext - dig the "next" pointer out of a node
*/
regnode *
-Perl_regnext(pTHX_ register regnode *p)
+Perl_regnext(pTHX_ regnode *p)
{
dVAR;
- register I32 offset;
+ I32 offset;
if (!p)
return(NULL);
@@ -11775,7 +15381,7 @@
}
#endif
-STATIC void
+STATIC void
S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
{
va_list args;
@@ -11830,15 +15436,15 @@
Copy(&PL_reg_state, state, 1, struct re_save_state);
- PL_reg_start_tmp = 0;
- PL_reg_start_tmpl = 0;
PL_reg_oldsaved = NULL;
PL_reg_oldsavedlen = 0;
+ PL_reg_oldsavedoffset = 0;
+ PL_reg_oldsavedcoffset = 0;
PL_reg_maxiter = 0;
PL_reg_leftiter = 0;
PL_reg_poscache = NULL;
PL_reg_poscache_size = 0;
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
PL_nrs = NULL;
#endif
@@ -11864,13 +15470,6 @@
}
#endif
-static void
-clear_re(pTHX_ void *r)
-{
- dVAR;
- ReREFCNT_dec((REGEXP *)r);
-}
-
#ifdef DEBUGGING
STATIC void
@@ -11886,8 +15485,11 @@
EO, or Eight Ones, is an 8-bit EBCDIC character code represented as all
ones (binary 1111 1111, hexadecimal FF). It is similar, but not
- identical, to the ASCII delete (DEL) or rubout control character.
- ) So the old condition can be simplified to !isPRINT(c) */
+ identical, to the ASCII delete (DEL) or rubout control character. ...
+ it is typically mapped to hexadecimal code 9F, in order to provide a
+ unique character mapping in both directions)
+
+ So the old condition can be simplified to !isPRINT(c) */
if (!isPRINT(c)) {
if (c < 256) {
Perl_sv_catpvf(aTHX_ sv, "\\x%02x", c);
@@ -11919,8 +15521,8 @@
SV* sv, I32 indent, U32 depth)
{
dVAR;
- register U8 op = PSEUDO; /* Arbitrary non-END op. */
- register const regnode *next;
+ U8 op = PSEUDO; /* Arbitrary non-END op. */
+ const regnode *next;
const regnode *optstart= NULL;
RXi_GET_DECL(r,ri);
@@ -11952,7 +15554,7 @@
goto after_print;
} else
CLEAR_OPTSTART;
-
+
regprop(r, sv, node);
PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
(int)(2*indent + 1), "", SvPVX_const(sv));
@@ -11971,9 +15573,9 @@
if (PL_regkind[(U8)op] == BRANCHJ) {
assert(next);
{
- register const regnode *nnode = (OP(next) == LONGJMP
- ? regnext((regnode *)next)
- : next);
+ const regnode *nnode = (OP(next) == LONGJMP
+ ? regnext((regnode *)next)
+ : next);
if (last && nnode > last)
nnode = last;
DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
@@ -12000,7 +15602,7 @@
sv_setpvs(sv, "");
for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
-
+
PerlIO_printf(Perl_debug_log, "%*s%s ",
(int)(2*(indent+3)), "",
elem_ptr ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr), SvCUR(*elem_ptr), 60,
@@ -12073,8 +15675,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/regcomp.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.4
\ No newline at end of property
Modified: trunk/contrib/perl/regcomp.h
===================================================================
--- trunk/contrib/perl/regcomp.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/regcomp.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -9,9 +9,6 @@
*/
#include "regcharclass.h"
-typedef OP OP_4tree; /* Will be redefined later. */
-
-
/* Convert branch sequences to more efficient trie ops? */
#define PERL_ENABLE_TRIE_OPTIMISATION 1
@@ -121,6 +118,8 @@
Used to make it easier to clone and free arbitrary
data that the regops need. Often the ARG field of
a regop is an index into this structure */
+ struct reg_code_block *code_blocks;/* positions of literal (?{}) */
+ int num_code_blocks; /* size of code_blocks[] */
regnode program[1]; /* Unwarranted chumminess with compiler. */
} regexp_internal;
@@ -138,6 +137,7 @@
#define PREGf_NAUGHTY 0x00000004 /* how exponential is this pattern? */
#define PREGf_VERBARG_SEEN 0x00000008
#define PREGf_CUTGROUP_SEEN 0x00000010
+#define PREGf_USE_RE_EVAL 0x00000020 /* compiled with "use re 'eval'" */
/* this is where the old regcomp.h started */
@@ -178,7 +178,6 @@
#define ANYOF_BITMAP_SIZE 32 /* 256 b/(8 b/B) */
-#define ANYOF_CLASSBITMAP_SIZE 4 /* up to 32 (8*4) named classes */
/* also used by trie */
struct regnode_charclass {
@@ -196,7 +195,7 @@
U16 next_off;
U32 arg1; /* used as ptr in S_regclass */
char bitmap[ANYOF_BITMAP_SIZE]; /* both compile-time */
- char classflags[ANYOF_CLASSBITMAP_SIZE]; /* and run-time */
+ U32 classflags; /* and run-time */
};
/* XXX fix this description.
@@ -307,26 +306,24 @@
* ANYOF_NONBITMAP_NON_UTF8 bit is also set. */
#define ANYOF_NONBITMAP(node) (ARG(node) != ANYOF_NONBITMAP_EMPTY)
-/* Flags for node->flags of ANYOF. These are in short supply, so some games
- * are done to share them, as described below. If necessary, the ANYOF_LOCALE
- * and ANYOF_CLASS bits could be shared with a space penalty for locale nodes,
- * but this isn't quite so easy, as the optimizer also uses ANYOF_CLASS.
- * Once the planned change to compile all the above-latin1 code points is done,
- * then the UNICODE_ALL bit can be freed up, with a small performance penalty.
- * If flags need to be added that are applicable to the synthetic start class
- * only, with some work, they could be put in the next-node field, or in an
- * unused bit of the classflags field. */
+/* Flags for node->flags of ANYOF. These are in short supply, but there is one
+ * currently available. If more than this are needed, the ANYOF_LOCALE and
+ * ANYOF_CLASS bits could be shared, making a space penalty for all locale nodes.
+ * Also, the UNICODE_ALL bit could be freed up by resorting to creating a swash
+ * containing everything above 255. This introduces a performance penalty.
+ * Better would be to split it off into a separate node, which actually would
+ * improve performance a bit by allowing regexec.c to test for a UTF-8
+ * character being above 255 without having to call a function nor calculate
+ * its code point value. However, this solution might need to have a second
+ * node type, ANYOF_SYNTHETIC_ABOVE_LATIN1_ALL */
#define ANYOF_LOCALE 0x01 /* /l modifier */
/* The fold is calculated and stored in the bitmap where possible at compile
- * time. However there are two cases where it isn't possible. These share
- * this bit: 1) under locale, where the actual folding varies depending on
- * what the locale is at the time of execution; and 2) where the folding is
- * specified in a swash, not the bitmap, such as characters which aren't
- * specified in the bitmap, or properties that aren't looked at at compile time
- */
-#define ANYOF_LOC_NONBITMAP_FOLD 0x02
+ * time. However under locale, the actual folding varies depending on
+ * what the locale is at the time of execution, so it has to be deferred until
+ * then */
+#define ANYOF_LOC_FOLD 0x02
#define ANYOF_INVERT 0x04
@@ -333,23 +330,13 @@
/* Set if this is a struct regnode_charclass_class vs a regnode_charclass. This
* is used for runtime \d, \w, [:posix:], ..., which are used only in locale
* and the optimizer's synthetic start class. Non-locale \d, etc are resolved
- * at compile-time */
-#define ANYOF_CLASS 0x08
-#define ANYOF_LARGE ANYOF_CLASS /* Same; name retained for back compat */
+ * at compile-time. Could be shared with ANYOF_LOCALE, forcing all locale
+ * nodes to be large */
+#define ANYOF_CLASS 0x08
+#define ANYOF_LARGE ANYOF_CLASS /* Same; name retained for back compat */
-/* EOS, meaning that it can match an empty string too, is used for the
- * synthetic start class only. */
-#define ANYOF_EOS 0x10
+/* Unused: 0x10. When using, be sure to change ANYOF_FLAGS_ALL below */
-/* ? Is this node the synthetic start class (ssc). This bit is shared with
- * ANYOF_EOS, as the latter is used only for the ssc, and then not used by
- * regexec.c. And, the code is structured so that if it is set, the ssc is
- * not used, so it is guaranteed to be 0 for the ssc by the time regexec.c
- * gets executed, and 0 for a non-ssc ANYOF node, as it only ever gets set for
- * a potential ssc candidate. Thus setting it to 1 after it has been
- * determined that the ssc will be used is not ambiguous */
-#define ANYOF_IS_SYNTHETIC ANYOF_EOS
-
/* Can match something outside the bitmap that isn't in utf8 */
#define ANYOF_NONBITMAP_NON_UTF8 0x20
@@ -360,7 +347,7 @@
* in utf8. */
#define ANYOF_NON_UTF8_LATIN1_ALL 0x80
-#define ANYOF_FLAGS_ALL 0xff
+#define ANYOF_FLAGS_ALL (0xff & ~0x10)
/* These are the flags that ANYOF_INVERT being set or not doesn't affect
* whether they are operative or not. e.g., the node still has LOCALE
@@ -367,56 +354,74 @@
* regardless of being inverted; whereas ANYOF_UNICODE_ALL means something
* different if inverted */
#define INVERSION_UNAFFECTED_FLAGS (ANYOF_LOCALE \
- |ANYOF_LOC_NONBITMAP_FOLD \
+ |ANYOF_LOC_FOLD \
|ANYOF_CLASS \
- |ANYOF_EOS \
|ANYOF_NONBITMAP_NON_UTF8)
/* Character classes for node->classflags of ANYOF */
/* Should be synchronized with a table in regprop() */
-/* 2n should pair with 2n+1 */
+/* 2n should be the normal one, paired with its complement at 2n+1 */
-#define ANYOF_ALNUM 0 /* \w, PL_utf8_alnum, utf8::IsWord, ALNUM */
-#define ANYOF_NALNUM 1
-#define ANYOF_SPACE 2 /* \s */
-#define ANYOF_NSPACE 3
-#define ANYOF_DIGIT 4 /* \d */
-#define ANYOF_NDIGIT 5
-#define ANYOF_ALNUMC 6 /* [[:alnum:]] isalnum(3), utf8::IsAlnum, ALNUMC */
-#define ANYOF_NALNUMC 7
-#define ANYOF_ALPHA 8
-#define ANYOF_NALPHA 9
-#define ANYOF_ASCII 10
-#define ANYOF_NASCII 11
-#define ANYOF_CNTRL 12
-#define ANYOF_NCNTRL 13
-#define ANYOF_GRAPH 14
-#define ANYOF_NGRAPH 15
-#define ANYOF_LOWER 16
-#define ANYOF_NLOWER 17
-#define ANYOF_PRINT 18
-#define ANYOF_NPRINT 19
-#define ANYOF_PUNCT 20
-#define ANYOF_NPUNCT 21
-#define ANYOF_UPPER 22
-#define ANYOF_NUPPER 23
-#define ANYOF_XDIGIT 24
-#define ANYOF_NXDIGIT 25
-#define ANYOF_PSXSPC 26 /* POSIX space: \s plus the vertical tab */
-#define ANYOF_NPSXSPC 27
-#define ANYOF_BLANK 28 /* GNU extension: space and tab: non-vertical space */
-#define ANYOF_NBLANK 29
+#define ANYOF_ALPHA ((_CC_ALPHA) * 2)
+#define ANYOF_NALPHA ((ANYOF_ALPHA) + 1)
+#define ANYOF_ALPHANUMERIC ((_CC_ALPHANUMERIC) * 2) /* [[:alnum:]] isalnum(3), utf8::IsAlnum */
+#define ANYOF_NALPHANUMERIC ((ANYOF_ALPHANUMERIC) + 1)
+#define ANYOF_ASCII ((_CC_ASCII) * 2)
+#define ANYOF_NASCII ((ANYOF_ASCII) + 1)
+#define ANYOF_BLANK ((_CC_BLANK) * 2) /* GNU extension: space and tab: non-vertical space */
+#define ANYOF_NBLANK ((ANYOF_BLANK) + 1)
+#define ANYOF_CASED ((_CC_CASED) * 2) /* Pseudo class for [:lower:] or
+ [:upper:] under /i */
+#define ANYOF_NCASED ((ANYOF_CASED) + 1)
+#define ANYOF_CNTRL ((_CC_CNTRL) * 2)
+#define ANYOF_NCNTRL ((ANYOF_CNTRL) + 1)
+#define ANYOF_DIGIT ((_CC_DIGIT) * 2) /* \d */
+#define ANYOF_NDIGIT ((ANYOF_DIGIT) + 1)
+#define ANYOF_GRAPH ((_CC_GRAPH) * 2)
+#define ANYOF_NGRAPH ((ANYOF_GRAPH) + 1)
+#define ANYOF_LOWER ((_CC_LOWER) * 2)
+#define ANYOF_NLOWER ((ANYOF_LOWER) + 1)
+#define ANYOF_PRINT ((_CC_PRINT) * 2)
+#define ANYOF_NPRINT ((ANYOF_PRINT) + 1)
+#define ANYOF_PSXSPC ((_CC_PSXSPC) * 2) /* POSIX space: \s plus the vertical tab */
+#define ANYOF_NPSXSPC ((ANYOF_PSXSPC) + 1)
+#define ANYOF_PUNCT ((_CC_PUNCT) * 2)
+#define ANYOF_NPUNCT ((ANYOF_PUNCT) + 1)
+#define ANYOF_SPACE ((_CC_SPACE) * 2) /* \s */
+#define ANYOF_NSPACE ((ANYOF_SPACE) + 1)
+#define ANYOF_UPPER ((_CC_UPPER) * 2)
+#define ANYOF_NUPPER ((ANYOF_UPPER) + 1)
+#define ANYOF_WORDCHAR ((_CC_WORDCHAR) * 2) /* \w, PL_utf8_alnum, utf8::IsWord, ALNUM */
+#define ANYOF_NWORDCHAR ((ANYOF_WORDCHAR) + 1)
+#define ANYOF_XDIGIT ((_CC_XDIGIT) * 2)
+#define ANYOF_NXDIGIT ((ANYOF_XDIGIT) + 1)
-#define ANYOF_MAX 32
-
-/* pseudo classes, not stored in the class bitmap, but used as flags
+/* pseudo classes below this, not stored in the class bitmap, but used as flags
during compilation of char classes */
-#define ANYOF_VERTWS (ANYOF_MAX+1)
-#define ANYOF_NVERTWS (ANYOF_MAX+2)
-#define ANYOF_HORIZWS (ANYOF_MAX+3)
-#define ANYOF_NHORIZWS (ANYOF_MAX+4)
+#define ANYOF_VERTWS ((_CC_VERTSPACE) * 2)
+#define ANYOF_NVERTWS ((ANYOF_VERTWS)+1)
+/* It is best if this is the last one, as all above it are stored as bits in a
+ * bitmap, and it isn't part of that bitmap */
+#if _CC_VERTSPACE != _HIGHEST_REGCOMP_DOT_H_SYNC
+# error Problem with handy.h _HIGHEST_REGCOMP_DOT_H_SYNC #define
+#endif
+
+#define ANYOF_MAX (ANYOF_VERTWS) /* So upper loop limit is written:
+ * '< ANYOF_MAX'
+ * Hence doesn't include VERTWS, as that
+ * is a pseudo class */
+#if (ANYOF_MAX > 32) /* Must fit in 32-bit word */
+# error Problem with handy.h _CC_foo #defines
+#endif
+
+#define ANYOF_HORIZWS ((ANYOF_MAX)+2) /* = (ANYOF_NVERTWS + 1) */
+#define ANYOF_NHORIZWS ((ANYOF_MAX)+3)
+
+#define ANYOF_UNIPROP ((ANYOF_MAX)+4) /* Used to indicate a Unicode
+ property: \p{} or \P{} */
+
/* Backward source code compatibility. */
#define ANYOF_ALNUML ANYOF_ALNUM
@@ -423,6 +428,8 @@
#define ANYOF_NALNUML ANYOF_NALNUM
#define ANYOF_SPACEL ANYOF_SPACE
#define ANYOF_NSPACEL ANYOF_NSPACE
+#define ANYOF_ALNUM ANYOF_WORDCHAR
+#define ANYOF_NALNUM ANYOF_NWORDCHAR
/* Utility macros for the bitmap and classes of ANYOF */
@@ -433,16 +440,18 @@
#define ANYOF_BIT(c) (1 << ((c) & 7))
-#define ANYOF_CLASS_BYTE(p, c) (((struct regnode_charclass_class*)(p))->classflags[((c) >> 3) & 3])
-#define ANYOF_CLASS_SET(p, c) (ANYOF_CLASS_BYTE(p, c) |= ANYOF_BIT(c))
-#define ANYOF_CLASS_CLEAR(p, c) (ANYOF_CLASS_BYTE(p, c) &= ~ANYOF_BIT(c))
-#define ANYOF_CLASS_TEST(p, c) (ANYOF_CLASS_BYTE(p, c) & ANYOF_BIT(c))
+#define ANYOF_CLASS_SET(p, c) (((struct regnode_charclass_class*) (p))->classflags |= (1U << (c)))
+#define ANYOF_CLASS_CLEAR(p, c) (((struct regnode_charclass_class*) (p))->classflags &= ~ (1U <<(c)))
+#define ANYOF_CLASS_TEST(p, c) (((struct regnode_charclass_class*) (p))->classflags & (1U << (c)))
-#define ANYOF_CLASS_ZERO(ret) Zero(((struct regnode_charclass_class*)(ret))->classflags, ANYOF_CLASSBITMAP_SIZE, char)
-#define ANYOF_CLASS_SETALL(ret) \
- memset (((struct regnode_charclass_class*)(ret))->classflags, 255, ANYOF_CLASSBITMAP_SIZE)
+#define ANYOF_CLASS_ZERO(ret) STMT_START { ((struct regnode_charclass_class*) (ret))->classflags = 0; } STMT_END
+
+/* Shifts a bit to get, eg. 0x4000_0000, then subtracts 1 to get 0x3FFF_FFFF */
+#define ANYOF_CLASS_SETALL(ret) STMT_START { ((struct regnode_charclass_class*) (ret))->classflags = ((1U << ((ANYOF_MAX) - 1))) - 1; } STMT_END
+
+#define ANYOF_CLASS_OR(source, dest) STMT_START { (dest)->classflags |= source->classflags ; } STMT_END
+
#define ANYOF_BITMAP_ZERO(ret) Zero(((struct regnode_charclass*)(ret))->bitmap, ANYOF_BITMAP_SIZE, char)
-
#define ANYOF_BITMAP(p) (((struct regnode_charclass*)(p))->bitmap)
#define ANYOF_BITMAP_BYTE(p, c) (ANYOF_BITMAP(p)[(((U8)(c)) >> 3) & 31])
#define ANYOF_BITMAP_SET(p, c) (ANYOF_BITMAP_BYTE(p, c) |= ANYOF_BIT(c))
@@ -460,12 +469,9 @@
#define ANYOF_SKIP ((ANYOF_SIZE - 1)/sizeof(regnode))
#define ANYOF_CLASS_SKIP ((ANYOF_CLASS_SIZE - 1)/sizeof(regnode))
-#if ANYOF_CLASSBITMAP_SIZE != 4
-# error ANYOF_CLASSBITMAP_SIZE is expected to be 4
-#endif
-#define ANYOF_CLASS_TEST_ANY_SET(p) ((ANYOF_FLAGS(p) & ANYOF_CLASS) \
- && memNE (((struct regnode_charclass_class*)(p))->classflags, \
- "\0\0\0\0", ANYOF_CLASSBITMAP_SIZE))
+#define ANYOF_CLASS_TEST_ANY_SET(p) \
+ ((ANYOF_FLAGS(p) & ANYOF_CLASS) \
+ && (((struct regnode_charclass_class*)(p))->classflags))
/*#define ANYOF_CLASS_ADD_SKIP (ANYOF_CLASS_SKIP - ANYOF_SKIP)
* */
@@ -484,7 +490,7 @@
#define REG_SEEN_ZERO_LEN 0x00000001
#define REG_SEEN_LOOKBEHIND 0x00000002
#define REG_SEEN_GPOS 0x00000004
-#define REG_SEEN_EVAL 0x00000008
+/* spare */
#define REG_SEEN_CANY 0x00000010
#define REG_SEEN_SANY REG_SEEN_CANY /* src bckwrd cmpt */
#define REG_SEEN_RECURSE 0x00000020
@@ -492,6 +498,7 @@
#define REG_SEEN_VERBARG 0x00000080
#define REG_SEEN_CUTGROUP 0x00000100
#define REG_SEEN_RUN_ON_COMMENT 0x00000200
+#define REG_SEEN_EXACTF_SHARP_S 0x00000400
START_EXTERN_C
@@ -518,8 +525,9 @@
Perl_reg_named_buff_iter,
Perl_reg_qr_package,
#if defined(USE_ITHREADS)
- Perl_regdupe_internal
+ Perl_regdupe_internal,
#endif
+ Perl_re_op_compile
};
#endif /* DOINIT */
#endif /* PLUGGABLE_RE_EXTENSION */
@@ -532,9 +540,9 @@
* The character describes the function of the corresponding .data item:
* a - AV for paren_name_list under DEBUGGING
* f - start-class data for regstclass optimization
- * n - Root of op tree for (?{EVAL}) item
- * o - Start op for (?{EVAL}) item
- * p - Pad for (?{EVAL}) item
+ * l - start op for literal (?{EVAL}) item
+ * L - start op for literal (?{EVAL}) item, with separate CV (qr//)
+ * r - pointer to an embedded code-containing qr, e.g. /ab$qr/
* s - swash for Unicode-style character class, and the multicharacter
* strings resulting from casefolding the single-character entries
* in the character class
@@ -571,10 +579,10 @@
#define check_offset_max substrs->data[2].max_offset
#define check_end_shift substrs->data[2].end_shift
-#define RX_ANCHORED_SUBSTR(rx) (((struct regexp *)SvANY(rx))->anchored_substr)
-#define RX_ANCHORED_UTF8(rx) (((struct regexp *)SvANY(rx))->anchored_utf8)
-#define RX_FLOAT_SUBSTR(rx) (((struct regexp *)SvANY(rx))->float_substr)
-#define RX_FLOAT_UTF8(rx) (((struct regexp *)SvANY(rx))->float_utf8)
+#define RX_ANCHORED_SUBSTR(rx) (ReANY(rx)->anchored_substr)
+#define RX_ANCHORED_UTF8(rx) (ReANY(rx)->anchored_utf8)
+#define RX_FLOAT_SUBSTR(rx) (ReANY(rx)->float_substr)
+#define RX_FLOAT_UTF8(rx) (ReANY(rx)->float_utf8)
/* trie related stuff */
@@ -821,11 +829,9 @@
if (re_debug_flags & RE_DEBUG_EXTRA_GPOS) x )
/* initialization */
-/* get_sv() can return NULL during global destruction. re_debug_flags can get
- * clobbered by a longjmp, so must be initialized */
+/* get_sv() can return NULL during global destruction. */
#define GET_RE_DEBUG_FLAGS DEBUG_r({ \
SV * re_debug_flags_sv = NULL; \
- re_debug_flags = 0; \
re_debug_flags_sv = get_sv(RE_DEBUG_FLAGS, 1); \
if (re_debug_flags_sv) { \
if (!SvIOK(re_debug_flags_sv)) \
@@ -836,7 +842,8 @@
#ifdef DEBUGGING
-#define GET_RE_DEBUG_FLAGS_DECL VOL IV re_debug_flags = 0; GET_RE_DEBUG_FLAGS;
+#define GET_RE_DEBUG_FLAGS_DECL VOL IV re_debug_flags = 0; \
+ PERL_UNUSED_VAR(re_debug_flags); GET_RE_DEBUG_FLAGS;
#define RE_PV_COLOR_DECL(rpv,rlen,isuni,dsv,pv,l,m,c1,c2) \
const char * const rpv = \
@@ -877,8 +884,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/regcomp.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/regen.pl
===================================================================
--- trunk/contrib/perl/regen.pl 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/regen.pl 2013-12-02 21:18:17 UTC (rev 6438)
@@ -16,6 +16,7 @@
# Which scripts to run.
my @scripts = qw(
+mg_vtable.pl
opcode.pl
overload.pl
reentr.pl
@@ -22,6 +23,7 @@
regcomp.pl
warnings.pl
embed.pl
+feature.pl
);
my $tap = $ARGV[0] && $ARGV[0] eq '--tap' ? '# ' : '';
Property changes on: trunk/contrib/perl/regen.pl
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/regen_perly.pl
===================================================================
--- trunk/contrib/perl/regen_perly.pl 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/regen_perly.pl 2013-12-02 21:18:17 UTC (rev 6438)
@@ -2,7 +2,7 @@
#
# regen_perly.pl, DAPM 12-Feb-04
#
-# Copyright (c) 2004, 2005 Larry Wall
+# Copyright (c) 2004, 2005, 2006, 2009, 2010, 2011 Larry Wall
#
# Given an input file perly.y, run bison on it and produce
# the following output files:
@@ -73,16 +73,21 @@
Could not find a version of bison in your path. Please install bison.
EOF
-unless ($version =~ /\b(1\.875[a-z]?|2\.[0134])\b/) { die <<EOF; }
+# Don't change this to add new bison versions without testing that the generated
+# files actually work :-) Win32 in particular may not like them. :-(
+unless ($version =~ /\b(1\.875[a-z]?|2\.[0134567])\b/) { die <<EOF; }
You have the wrong version of bison in your path; currently 1.875
-2.0, 2.1, 2.3 or 2.4 is required. Try installing
- http://ftp.gnu.org/gnu/bison/bison-2.4.1.tar.gz
+2.0, 2.1, 2.3, 2.4, 2.5, 2.6 or 2.7 is required. Try installing
+ http://ftp.gnu.org/gnu/bison/bison-2.5.1.tar.gz
or similar. Your bison identifies itself as:
$version
EOF
+# bison's version number, not the entire string, is most useful later on.
+$version = $1;
+
# creates $tmpc_file and $tmph_file
my_system("$bison -d -o $tmpc_file $y_file");
@@ -95,15 +100,16 @@
my ($actlines, $tablines) = extract($clines);
+our %tokens;
$tablines .= make_type_tab($y_file, $tablines);
-my $read_only = read_only_top(lang => 'C', by => $0, from => $y_file);
+my ($act_fh, $tab_fh, $h_fh) = map {
+ open_new($_, '>', { by => $0, from => $y_file });
+} $act_file, $tab_file, $h_file;
-my $act_fh = safer_open("$act_file-new", $act_file);
-print $act_fh $read_only, $actlines;
+print $act_fh $actlines;
-my $tab_fh = safer_open("$tab_file-new", $tab_file);
-print $tab_fh $read_only, $tablines;
+print $tab_fh $tablines;
unlink $tmpc_file;
@@ -112,18 +118,35 @@
# C<#line 188 "perlytmp.h"> gets picked up by make depend, so remove them.
open my $tmph_fh, '<', $tmph_file or die "Can't open $tmph_file: $!\n";
-my $h_fh = safer_open("$h_file-new", $h_file);
-print $h_fh $read_only;
-
my $endcore_done = 0;
-# Token macros need to be generated manually on bison 2.4
-my $gather_tokens = ($version =~ /\b2\.4\b/ ? undef : 0);
+# Token macros need to be generated manually from bison 2.4 on
+my $gather_tokens = $version >= 2.4 ? undef : 0;
my $tokens;
while (<$tmph_fh>) {
+ # bison 2.6 adds header guards, which break things because of where we
+ # insert #ifdef PERL_CORE, so strip them because they aren't important
+ next if /YY_PERLYTMP_H/;
+
print $h_fh "#ifdef PERL_CORE\n" if $. == 1;
if (!$endcore_done and /YYSTYPE_IS_DECLARED/) {
- print $h_fh "#endif /* PERL_CORE */\n";
+ print $h_fh <<h;
+#ifdef PERL_IN_TOKE_C
+static bool
+S_is_opval_token(int type) {
+ switch (type) {
+h
+ print $h_fh <<i for sort grep $tokens{$_} eq 'opval', keys %tokens;
+ case $_:
+i
+ print $h_fh <<j;
+ return 1;
+ }
+ return 0;
+}
+#endif /* PERL_IN_TOKE_C */
+#endif /* PERL_CORE */
+j
$endcore_done = 1;
}
next if /^#line \d+ ".*"/;
@@ -243,6 +266,7 @@
sub make_type_tab {
my ($y_file, $tablines) = @_;
+ my %just_tokens;
my %tokens;
my %types;
my $default_token;
@@ -262,16 +286,22 @@
}
next unless /^%(token|type)/;
- s/^%(token|type)\s+<(\w+)>\s+//
+ s/^%((token)|type)\s+<(\w+)>\s+//
or die "$y_file: unparseable token/type line: $_";
- $tokens{$_} = $2 for (split ' ', $_);
- $types{$2} = 1;
+ for (split ' ', $_) {
+ $tokens{$_} = $3;
+ if ($2) {
+ $just_tokens{$_} = $3;
+ }
+ }
+ $types{$3} = 1;
}
+ *tokens = \%just_tokens; # perly.h needs this
die "$y_file: no __DEFAULT__ token defined\n" unless $default_token;
$types{$default_token} = 1;
$tablines =~ /^\Qstatic const char *const yytname[] =\E\n
- {\n
+ \{\n
(.*?)
^};
/xsm
@@ -281,7 +311,7 @@
{ "toketype_" .
(defined $tokens{$1} ? $tokens{$1} : $default_token)
}ge;
- $fields =~ s/, \s* 0 \s* $//x
+ $fields =~ s/, \s* (?:0|YY_NULL) \s* $//x
or die "make_type_tab: couldn't delete trailing ',0'\n";
return
Property changes on: trunk/contrib/perl/regen_perly.pl
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/regexec.c
===================================================================
--- trunk/contrib/perl/regexec.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/regexec.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -37,6 +37,16 @@
#include "re_top.h"
#endif
+/* At least one required character in the target string is expressible only in
+ * UTF-8. */
+static const char* const non_utf8_target_but_utf8_required
+ = "Can't match, because target string needs to be in UTF-8\n";
+
+#define NON_UTF8_TARGET_BUT_UTF8_REQUIRED(target) STMT_START { \
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s", non_utf8_target_but_utf8_required));\
+ goto target; \
+} STMT_END
+
/*
* pregcomp and pregexec -- regsub and regerror are not used in perl
*
@@ -80,24 +90,19 @@
# include "regcomp.h"
#endif
-#define RF_tainted 1 /* tainted information used? e.g. locale */
-#define RF_warned 2 /* warned about big count? */
+#include "inline_invlist.c"
+#include "unicode_constants.h"
-#define RF_utf8 8 /* Pattern contains multibyte chars? */
+#define HAS_NONLATIN1_FOLD_CLOSURE(i) _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)
-#define UTF_PATTERN ((PL_reg_flags & RF_utf8) != 0)
-
-#define RS_init 1 /* eval environment created */
-#define RS_set 2 /* replsv value is set */
-
#ifndef STATIC
#define STATIC static
#endif
-/* Valid for non-utf8 strings, non-ANYOFV nodes only: avoids the reginclass
+/* Valid for non-utf8 strings: avoids the reginclass
* call if there are no complications: i.e., if everything matchable is
* straight forward in the bitmap */
-#define REGINCLASS(prog,p,c) (ANYOF_FLAGS(p) ? reginclass(prog,p,c,0,0) \
+#define REGINCLASS(prog,p,c) (ANYOF_FLAGS(p) ? reginclass(prog,p,c,0) \
: ANYOF_BITMAP_TEST(p,*(c)))
/*
@@ -121,145 +126,57 @@
#define HOP3(pos,off,lim) (PL_reg_match_utf8 ? reghop3((U8*)(pos), off, (U8*)(lim)) : (U8*)(pos + off))
#define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim))
-/* these are unrolled below in the CCC_TRY_XXX defined */
-#define LOAD_UTF8_CHARCLASS(class,str) STMT_START { \
- if (!CAT2(PL_utf8_,class)) { bool ok; ENTER; save_re_context(); ok=CAT2(is_utf8_,class)((const U8*)str); assert(ok); LEAVE; } } STMT_END
-/* Doesn't do an assert to verify that is correct */
-#define LOAD_UTF8_CHARCLASS_NO_CHECK(class) STMT_START { \
- if (!CAT2(PL_utf8_,class)) { bool throw_away; ENTER; save_re_context(); throw_away = CAT2(is_utf8_,class)((const U8*)" "); LEAVE; } } STMT_END
+#define NEXTCHR_EOS -10 /* nextchr has fallen off the end */
+#define NEXTCHR_IS_EOS (nextchr < 0)
-#define LOAD_UTF8_CHARCLASS_ALNUM() LOAD_UTF8_CHARCLASS(alnum,"a")
-#define LOAD_UTF8_CHARCLASS_DIGIT() LOAD_UTF8_CHARCLASS(digit,"0")
-#define LOAD_UTF8_CHARCLASS_SPACE() LOAD_UTF8_CHARCLASS(space," ")
+#define SET_nextchr \
+ nextchr = ((locinput < PL_regeol) ? UCHARAT(locinput) : NEXTCHR_EOS)
-#define LOAD_UTF8_CHARCLASS_GCB() /* Grapheme cluster boundaries */ \
- LOAD_UTF8_CHARCLASS(X_begin, " "); \
- LOAD_UTF8_CHARCLASS(X_non_hangul, "A"); \
- /* These are utf8 constants, and not utf-ebcdic constants, so the \
- * assert should likely and hopefully fail on an EBCDIC machine */ \
- LOAD_UTF8_CHARCLASS(X_extend, "\xcc\x80"); /* U+0300 */ \
- \
- /* No asserts are done for these, in case called on an early \
- * Unicode version in which they map to nothing */ \
- LOAD_UTF8_CHARCLASS_NO_CHECK(X_prepend);/* U+0E40 "\xe0\xb9\x80" */ \
- LOAD_UTF8_CHARCLASS_NO_CHECK(X_L); /* U+1100 "\xe1\x84\x80" */ \
- LOAD_UTF8_CHARCLASS_NO_CHECK(X_LV); /* U+AC00 "\xea\xb0\x80" */ \
- LOAD_UTF8_CHARCLASS_NO_CHECK(X_LVT); /* U+AC01 "\xea\xb0\x81" */ \
- LOAD_UTF8_CHARCLASS_NO_CHECK(X_LV_LVT_V);/* U+AC01 "\xea\xb0\x81" */\
- LOAD_UTF8_CHARCLASS_NO_CHECK(X_T); /* U+11A8 "\xe1\x86\xa8" */ \
- LOAD_UTF8_CHARCLASS_NO_CHECK(X_V) /* U+1160 "\xe1\x85\xa0" */
+#define SET_locinput(p) \
+ locinput = (p); \
+ SET_nextchr
-#define PLACEHOLDER /* Something for the preprocessor to grab onto */
-/* The actual code for CCC_TRY, which uses several variables from the routine
- * it's callable from. It is designed to be the bulk of a case statement.
- * FUNC is the macro or function to call on non-utf8 targets that indicate if
- * nextchr matches the class.
- * UTF8_TEST is the whole test string to use for utf8 targets
- * LOAD is what to use to test, and if not present to load in the swash for the
- * class
- * POS_OR_NEG is either empty or ! to complement the results of FUNC or
- * UTF8_TEST test.
- * The logic is: Fail if we're at the end-of-string; otherwise if the target is
- * utf8 and a variant, load the swash if necessary and test using the utf8
- * test. Advance to the next character if test is ok, otherwise fail; If not
- * utf8 or an invariant under utf8, use the non-utf8 test, and fail if it
- * fails, or advance to the next character */
+#define LOAD_UTF8_CHARCLASS(swash_ptr, property_name) STMT_START { \
+ if (!swash_ptr) { \
+ U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST; \
+ swash_ptr = _core_swash_init("utf8", property_name, &PL_sv_undef, \
+ 1, 0, NULL, &flags); \
+ assert(swash_ptr); \
+ } \
+ } STMT_END
-#define _CCC_TRY_CODE(POS_OR_NEG, FUNC, UTF8_TEST, CLASS, STR) \
- if (locinput >= PL_regeol) { \
- sayNO; \
- } \
- if (utf8_target && UTF8_IS_CONTINUED(nextchr)) { \
- LOAD_UTF8_CHARCLASS(CLASS, STR); \
- if (POS_OR_NEG (UTF8_TEST)) { \
- sayNO; \
- } \
- locinput += PL_utf8skip[nextchr]; \
- nextchr = UCHARAT(locinput); \
- break; \
- } \
- if (POS_OR_NEG (FUNC(nextchr))) { \
- sayNO; \
- } \
- nextchr = UCHARAT(++locinput); \
- break;
+/* If in debug mode, we test that a known character properly matches */
+#ifdef DEBUGGING
+# define LOAD_UTF8_CHARCLASS_DEBUG_TEST(swash_ptr, \
+ property_name, \
+ utf8_char_in_property) \
+ LOAD_UTF8_CHARCLASS(swash_ptr, property_name); \
+ assert(swash_fetch(swash_ptr, (U8 *) utf8_char_in_property, TRUE));
+#else
+# define LOAD_UTF8_CHARCLASS_DEBUG_TEST(swash_ptr, \
+ property_name, \
+ utf8_char_in_property) \
+ LOAD_UTF8_CHARCLASS(swash_ptr, property_name)
+#endif
-/* Handle the non-locale cases for a character class and its complement. It
- * calls _CCC_TRY_CODE with a ! to complement the test for the character class.
- * This is because that code fails when the test succeeds, so we want to have
- * the test fail so that the code succeeds. The swash is stored in a
- * predictable PL_ place */
-#define _CCC_TRY_NONLOCALE(NAME, NNAME, FUNC, \
- CLASS, STR) \
- case NAME: \
- _CCC_TRY_CODE( !, FUNC, \
- cBOOL(swash_fetch(CAT2(PL_utf8_,CLASS), \
- (U8*)locinput, TRUE)), \
- CLASS, STR) \
- case NNAME: \
- _CCC_TRY_CODE( PLACEHOLDER , FUNC, \
- cBOOL(swash_fetch(CAT2(PL_utf8_,CLASS), \
- (U8*)locinput, TRUE)), \
- CLASS, STR) \
+#define LOAD_UTF8_CHARCLASS_ALNUM() LOAD_UTF8_CHARCLASS_DEBUG_TEST( \
+ PL_utf8_swash_ptrs[_CC_WORDCHAR], \
+ swash_property_names[_CC_WORDCHAR], \
+ GREEK_SMALL_LETTER_IOTA_UTF8)
-/* Generate the case statements for both locale and non-locale character
- * classes in regmatch for classes that don't have special unicode semantics.
- * Locales don't use an immediate swash, but an intermediary special locale
- * function that is called on the pointer to the current place in the input
- * string. That function will resolve to needing the same swash. One might
- * think that because we don't know what the locale will match, we shouldn't
- * check with the swash loading function that it loaded properly; ie, that we
- * should use LOAD_UTF8_CHARCLASS_NO_CHECK for those, but what is passed to the
- * regular LOAD_UTF8_CHARCLASS is in non-locale terms, and so locale is
- * irrelevant here */
-#define CCC_TRY(NAME, NNAME, FUNC, \
- NAMEL, NNAMEL, LCFUNC, LCFUNC_utf8, \
- NAMEA, NNAMEA, FUNCA, \
- CLASS, STR) \
- case NAMEL: \
- PL_reg_flags |= RF_tainted; \
- _CCC_TRY_CODE( !, LCFUNC, LCFUNC_utf8((U8*)locinput), CLASS, STR) \
- case NNAMEL: \
- PL_reg_flags |= RF_tainted; \
- _CCC_TRY_CODE( PLACEHOLDER, LCFUNC, LCFUNC_utf8((U8*)locinput), \
- CLASS, STR) \
- case NAMEA: \
- if (locinput >= PL_regeol || ! FUNCA(nextchr)) { \
- sayNO; \
- } \
- /* Matched a utf8-invariant, so don't have to worry about utf8 */ \
- nextchr = UCHARAT(++locinput); \
- break; \
- case NNAMEA: \
- if (locinput >= PL_regeol || FUNCA(nextchr)) { \
- sayNO; \
- } \
- if (utf8_target) { \
- locinput += PL_utf8skip[nextchr]; \
- nextchr = UCHARAT(locinput); \
- } \
- else { \
- nextchr = UCHARAT(++locinput); \
- } \
- break; \
- /* Generate the non-locale cases */ \
- _CCC_TRY_NONLOCALE(NAME, NNAME, FUNC, CLASS, STR)
+#define LOAD_UTF8_CHARCLASS_GCB() /* Grapheme cluster boundaries */ \
+ STMT_START { \
+ LOAD_UTF8_CHARCLASS_DEBUG_TEST(PL_utf8_X_regular_begin, \
+ "_X_regular_begin", \
+ GREEK_SMALL_LETTER_IOTA_UTF8); \
+ LOAD_UTF8_CHARCLASS_DEBUG_TEST(PL_utf8_X_extend, \
+ "_X_extend", \
+ COMBINING_GRAVE_ACCENT_UTF8); \
+ } STMT_END
-/* This is like CCC_TRY, but has an extra set of parameters for generating case
- * statements to handle separate Unicode semantics nodes */
-#define CCC_TRY_U(NAME, NNAME, FUNC, \
- NAMEL, NNAMEL, LCFUNC, LCFUNC_utf8, \
- NAMEU, NNAMEU, FUNCU, \
- NAMEA, NNAMEA, FUNCA, \
- CLASS, STR) \
- CCC_TRY(NAME, NNAME, FUNC, \
- NAMEL, NNAMEL, LCFUNC, LCFUNC_utf8, \
- NAMEA, NNAMEA, FUNCA, \
- CLASS, STR) \
- _CCC_TRY_NONLOCALE(NAMEU, NNAMEU, FUNCU, CLASS, STR)
-
+#define PLACEHOLDER /* Something for the preprocessor to grab onto */
/* TODO: Combine JUMPABLE and HAS_TEXT to cache OP(rn) */
/* for use after a quantifier and before an EXACT-like node -- japhy */
@@ -289,13 +206,13 @@
/* Currently these are only used when PL_regkind[OP(rn)] == EXACT so
we don't need this definition. */
#define IS_TEXT(rn) ( OP(rn)==EXACT || OP(rn)==REF || OP(rn)==NREF )
-#define IS_TEXTF(rn) ( (OP(rn)==EXACTFU || OP(rn)==EXACTFA || OP(rn)==EXACTF) || OP(rn)==REFF || OP(rn)==NREFF )
+#define IS_TEXTF(rn) ( OP(rn)==EXACTFU || OP(rn)==EXACTFU_SS || OP(rn)==EXACTFU_TRICKYFOLD || OP(rn)==EXACTFA || OP(rn)==EXACTF || OP(rn)==REFF || OP(rn)==NREFF )
#define IS_TEXTFL(rn) ( OP(rn)==EXACTFL || OP(rn)==REFFL || OP(rn)==NREFFL )
#else
/* ... so we use this as its faster. */
#define IS_TEXT(rn) ( OP(rn)==EXACT )
-#define IS_TEXTFU(rn) ( OP(rn)==EXACTFU || OP(rn) == EXACTFA)
+#define IS_TEXTFU(rn) ( OP(rn)==EXACTFU || OP(rn)==EXACTFU_SS || OP(rn)==EXACTFU_TRICKYFOLD || OP(rn) == EXACTFA)
#define IS_TEXTF(rn) ( OP(rn)==EXACTF )
#define IS_TEXTFL(rn) ( OP(rn)==EXACTFL )
@@ -318,55 +235,76 @@
} \
} STMT_END
+/* These constants are for finding GCB=LV and GCB=LVT in the CLUMP regnode.
+ * These are for the pre-composed Hangul syllables, which are all in a
+ * contiguous block and arranged there in such a way so as to facilitate
+ * alorithmic determination of their characteristics. As such, they don't need
+ * a swash, but can be determined by simple arithmetic. Almost all are
+ * GCB=LVT, but every 28th one is a GCB=LV */
+#define SBASE 0xAC00 /* Start of block */
+#define SCount 11172 /* Length of block */
+#define TCount 28
static void restore_pos(pTHX_ void *arg);
-#define REGCP_PAREN_ELEMS 4
-#define REGCP_OTHER_ELEMS 5
+#define REGCP_PAREN_ELEMS 3
+#define REGCP_OTHER_ELEMS 3
#define REGCP_FRAME_ELEMS 1
/* REGCP_FRAME_ELEMS are not part of the REGCP_OTHER_ELEMS and
* are needed for the regexp context stack bookkeeping. */
STATIC CHECKPOINT
-S_regcppush(pTHX_ I32 parenfloor)
+S_regcppush(pTHX_ const regexp *rex, I32 parenfloor, U32 maxopenparen)
{
dVAR;
const int retval = PL_savestack_ix;
- const int paren_elems_to_push = (PL_regsize - parenfloor) * REGCP_PAREN_ELEMS;
+ const int paren_elems_to_push =
+ (maxopenparen - parenfloor) * REGCP_PAREN_ELEMS;
const UV total_elems = paren_elems_to_push + REGCP_OTHER_ELEMS;
const UV elems_shifted = total_elems << SAVE_TIGHT_SHIFT;
- int p;
+ I32 p;
GET_RE_DEBUG_FLAGS_DECL;
+ PERL_ARGS_ASSERT_REGCPPUSH;
+
if (paren_elems_to_push < 0)
- Perl_croak(aTHX_ "panic: paren_elems_to_push < 0");
+ Perl_croak(aTHX_ "panic: paren_elems_to_push, %i < 0",
+ paren_elems_to_push);
if ((elems_shifted >> SAVE_TIGHT_SHIFT) != total_elems)
Perl_croak(aTHX_ "panic: paren_elems_to_push offset %"UVuf
" out of range (%lu-%ld)",
- total_elems, (unsigned long)PL_regsize, (long)parenfloor);
+ total_elems,
+ (unsigned long)maxopenparen,
+ (long)parenfloor);
SSGROW(total_elems + REGCP_FRAME_ELEMS);
- for (p = PL_regsize; p > parenfloor; p--) {
+ DEBUG_BUFFERS_r(
+ if ((int)maxopenparen > (int)parenfloor)
+ PerlIO_printf(Perl_debug_log,
+ "rex=0x%"UVxf" offs=0x%"UVxf": saving capture indices:\n",
+ PTR2UV(rex),
+ PTR2UV(rex->offs)
+ );
+ );
+ for (p = parenfloor+1; p <= (I32)maxopenparen; p++) {
/* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */
- SSPUSHINT(PL_regoffs[p].end);
- SSPUSHINT(PL_regoffs[p].start);
- SSPUSHPTR(PL_reg_start_tmp[p]);
- SSPUSHINT(p);
+ SSPUSHINT(rex->offs[p].end);
+ SSPUSHINT(rex->offs[p].start);
+ SSPUSHINT(rex->offs[p].start_tmp);
DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
- " saving \\%"UVuf" %"IVdf"(%"IVdf")..%"IVdf"\n",
- (UV)p, (IV)PL_regoffs[p].start,
- (IV)(PL_reg_start_tmp[p] - PL_bostr),
- (IV)PL_regoffs[p].end
+ " \\%"UVuf": %"IVdf"(%"IVdf")..%"IVdf"\n",
+ (UV)p,
+ (IV)rex->offs[p].start,
+ (IV)rex->offs[p].start_tmp,
+ (IV)rex->offs[p].end
));
}
/* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */
- SSPUSHPTR(PL_regoffs);
- SSPUSHINT(PL_regsize);
- SSPUSHINT(*PL_reglastparen);
- SSPUSHINT(*PL_reglastcloseparen);
- SSPUSHPTR(PL_reginput);
+ SSPUSHINT(maxopenparen);
+ SSPUSHINT(rex->lastparen);
+ SSPUSHINT(rex->lastcloseparen);
SSPUSHUV(SAVEt_REGCONTEXT | elems_shifted); /* Magic cookie. */
return retval;
@@ -388,12 +326,19 @@
(IV)(cp), (IV)PL_savestack_ix)); \
regcpblow(cp)
-STATIC char *
-S_regcppop(pTHX_ const regexp *rex)
+#define UNWIND_PAREN(lp, lcp) \
+ for (n = rex->lastparen; n > lp; n--) \
+ rex->offs[n].end = -1; \
+ rex->lastparen = n; \
+ rex->lastcloseparen = lcp;
+
+
+STATIC void
+S_regcppop(pTHX_ regexp *rex, U32 *maxopenparen_p)
{
dVAR;
UV i;
- char *input;
+ U32 paren;
GET_RE_DEBUG_FLAGS_DECL;
PERL_ARGS_ASSERT_REGCPPOP;
@@ -402,38 +347,38 @@
i = SSPOPUV;
assert((i & SAVE_MASK) == SAVEt_REGCONTEXT); /* Check that the magic cookie is there. */
i >>= SAVE_TIGHT_SHIFT; /* Parentheses elements to pop. */
- input = (char *) SSPOPPTR;
- *PL_reglastcloseparen = SSPOPINT;
- *PL_reglastparen = SSPOPINT;
- PL_regsize = SSPOPINT;
- PL_regoffs=(regexp_paren_pair *) SSPOPPTR;
+ rex->lastcloseparen = SSPOPINT;
+ rex->lastparen = SSPOPINT;
+ *maxopenparen_p = SSPOPINT;
i -= REGCP_OTHER_ELEMS;
/* Now restore the parentheses context. */
+ DEBUG_BUFFERS_r(
+ if (i || rex->lastparen + 1 <= rex->nparens)
+ PerlIO_printf(Perl_debug_log,
+ "rex=0x%"UVxf" offs=0x%"UVxf": restoring capture indices to:\n",
+ PTR2UV(rex),
+ PTR2UV(rex->offs)
+ );
+ );
+ paren = *maxopenparen_p;
for ( ; i > 0; i -= REGCP_PAREN_ELEMS) {
I32 tmps;
- U32 paren = (U32)SSPOPINT;
- PL_reg_start_tmp[paren] = (char *) SSPOPPTR;
- PL_regoffs[paren].start = SSPOPINT;
+ rex->offs[paren].start_tmp = SSPOPINT;
+ rex->offs[paren].start = SSPOPINT;
tmps = SSPOPINT;
- if (paren <= *PL_reglastparen)
- PL_regoffs[paren].end = tmps;
- DEBUG_BUFFERS_r(
- PerlIO_printf(Perl_debug_log,
- " restoring \\%"UVuf" to %"IVdf"(%"IVdf")..%"IVdf"%s\n",
- (UV)paren, (IV)PL_regoffs[paren].start,
- (IV)(PL_reg_start_tmp[paren] - PL_bostr),
- (IV)PL_regoffs[paren].end,
- (paren > *PL_reglastparen ? "(no)" : ""));
+ if (paren <= rex->lastparen)
+ rex->offs[paren].end = tmps;
+ DEBUG_BUFFERS_r( PerlIO_printf(Perl_debug_log,
+ " \\%"UVuf": %"IVdf"(%"IVdf")..%"IVdf"%s\n",
+ (UV)paren,
+ (IV)rex->offs[paren].start,
+ (IV)rex->offs[paren].start_tmp,
+ (IV)rex->offs[paren].end,
+ (paren > rex->lastparen ? "(skipped)" : ""));
);
+ paren--;
}
- DEBUG_BUFFERS_r(
- if (*PL_reglastparen + 1 <= rex->nparens) {
- PerlIO_printf(Perl_debug_log,
- " restoring \\%"IVdf"..\\%"IVdf" to undef\n",
- (IV)(*PL_reglastparen + 1), (IV)rex->nparens);
- }
- );
#if 1
/* It would seem that the similar code in regtry()
* already takes care of this, and in fact it is in
@@ -444,17 +389,127 @@
* this code seems to be necessary or otherwise
* this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
* --jhi updated by dapm */
- for (i = *PL_reglastparen + 1; i <= rex->nparens; i++) {
- if (i > PL_regsize)
- PL_regoffs[i].start = -1;
- PL_regoffs[i].end = -1;
+ for (i = rex->lastparen + 1; i <= rex->nparens; i++) {
+ if (i > *maxopenparen_p)
+ rex->offs[i].start = -1;
+ rex->offs[i].end = -1;
+ DEBUG_BUFFERS_r( PerlIO_printf(Perl_debug_log,
+ " \\%"UVuf": %s ..-1 undeffing\n",
+ (UV)i,
+ (i > *maxopenparen_p) ? "-1" : " "
+ ));
}
#endif
- return input;
}
+/* restore the parens and associated vars at savestack position ix,
+ * but without popping the stack */
+
+STATIC void
+S_regcp_restore(pTHX_ regexp *rex, I32 ix, U32 *maxopenparen_p)
+{
+ I32 tmpix = PL_savestack_ix;
+ PL_savestack_ix = ix;
+ regcppop(rex, maxopenparen_p);
+ PL_savestack_ix = tmpix;
+}
+
#define regcpblow(cp) LEAVE_SCOPE(cp) /* Ignores regcppush()ed data. */
+STATIC bool
+S_isFOO_lc(pTHX_ const U8 classnum, const U8 character)
+{
+ /* Returns a boolean as to whether or not 'character' is a member of the
+ * Posix character class given by 'classnum' that should be equivalent to a
+ * value in the typedef '_char_class_number'.
+ *
+ * Ideally this could be replaced by a just an array of function pointers
+ * to the C library functions that implement the macros this calls.
+ * However, to compile, the precise function signatures are required, and
+ * these may vary from platform to to platform. To avoid having to figure
+ * out what those all are on each platform, I (khw) am using this method,
+ * which adds an extra layer of function call overhead (unless the C
+ * optimizer strips it away). But we don't particularly care about
+ * performance with locales anyway. */
+
+ switch ((_char_class_number) classnum) {
+ case _CC_ENUM_ALPHANUMERIC: return isALPHANUMERIC_LC(character);
+ case _CC_ENUM_ALPHA: return isALPHA_LC(character);
+ case _CC_ENUM_ASCII: return isASCII_LC(character);
+ case _CC_ENUM_BLANK: return isBLANK_LC(character);
+ case _CC_ENUM_CASED: return isLOWER_LC(character)
+ || isUPPER_LC(character);
+ case _CC_ENUM_CNTRL: return isCNTRL_LC(character);
+ case _CC_ENUM_DIGIT: return isDIGIT_LC(character);
+ case _CC_ENUM_GRAPH: return isGRAPH_LC(character);
+ case _CC_ENUM_LOWER: return isLOWER_LC(character);
+ case _CC_ENUM_PRINT: return isPRINT_LC(character);
+ case _CC_ENUM_PSXSPC: return isPSXSPC_LC(character);
+ case _CC_ENUM_PUNCT: return isPUNCT_LC(character);
+ case _CC_ENUM_SPACE: return isSPACE_LC(character);
+ case _CC_ENUM_UPPER: return isUPPER_LC(character);
+ case _CC_ENUM_WORDCHAR: return isWORDCHAR_LC(character);
+ case _CC_ENUM_XDIGIT: return isXDIGIT_LC(character);
+ default: /* VERTSPACE should never occur in locales */
+ Perl_croak(aTHX_ "panic: isFOO_lc() has an unexpected character class '%d'", classnum);
+ }
+
+ assert(0); /* NOTREACHED */
+ return FALSE;
+}
+
+STATIC bool
+S_isFOO_utf8_lc(pTHX_ const U8 classnum, const U8* character)
+{
+ /* Returns a boolean as to whether or not the (well-formed) UTF-8-encoded
+ * 'character' is a member of the Posix character class given by 'classnum'
+ * that should be equivalent to a value in the typedef
+ * '_char_class_number'.
+ *
+ * This just calls isFOO_lc on the code point for the character if it is in
+ * the range 0-255. Outside that range, all characters avoid Unicode
+ * rules, ignoring any locale. So use the Unicode function if this class
+ * requires a swash, and use the Unicode macro otherwise. */
+
+ PERL_ARGS_ASSERT_ISFOO_UTF8_LC;
+
+ if (UTF8_IS_INVARIANT(*character)) {
+ return isFOO_lc(classnum, *character);
+ }
+ else if (UTF8_IS_DOWNGRADEABLE_START(*character)) {
+ return isFOO_lc(classnum,
+ TWO_BYTE_UTF8_TO_UNI(*character, *(character + 1)));
+ }
+
+ if (classnum < _FIRST_NON_SWASH_CC) {
+
+ /* Initialize the swash unless done already */
+ if (! PL_utf8_swash_ptrs[classnum]) {
+ U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
+ PL_utf8_swash_ptrs[classnum] = _core_swash_init("utf8",
+ swash_property_names[classnum], &PL_sv_undef, 1, 0, NULL, &flags);
+ }
+
+ return cBOOL(swash_fetch(PL_utf8_swash_ptrs[classnum], (U8 *)
+ character,
+ TRUE /* is UTF */ ));
+ }
+
+ switch ((_char_class_number) classnum) {
+ case _CC_ENUM_SPACE:
+ case _CC_ENUM_PSXSPC: return is_XPERLSPACE_high(character);
+
+ case _CC_ENUM_BLANK: return is_HORIZWS_high(character);
+ case _CC_ENUM_XDIGIT: return is_XDIGIT_high(character);
+ case _CC_ENUM_VERTSPACE: return is_VERTWS_high(character);
+ default: return 0; /* Things like CNTRL are always
+ below 256 */
+ }
+
+ assert(0); /* NOTREACHED */
+ return FALSE;
+}
+
/*
* pregexec and friends
*/
@@ -464,12 +519,15 @@
- pregexec - match a regexp against a string
*/
I32
-Perl_pregexec(pTHX_ REGEXP * const prog, char* stringarg, register char *strend,
+Perl_pregexec(pTHX_ REGEXP * const prog, char* stringarg, char *strend,
char *strbeg, I32 minend, SV *screamer, U32 nosave)
-/* strend: pointer to null at end of string */
-/* strbeg: real beginning of string */
-/* minend: end of match must be >=minend after stringarg. */
-/* nosave: For optimizations. */
+/* stringarg: the point in the string at which to begin matching */
+/* strend: pointer to null at end of string */
+/* strbeg: real beginning of string */
+/* minend: end of match must be >= minend bytes after stringarg. */
+/* screamer: SV being matched: only used for utf8 flag, pos() etc; string
+ * itself is accessed via the pointers above */
+/* nosave: For optimizations. */
{
PERL_ARGS_ASSERT_PREGEXEC;
@@ -513,7 +571,7 @@
/* A failure to find a constant substring means that there is no need to make
an expensive call to REx engine, thus we celebrate a failure. Similarly,
- finding a substring too deep into the string means that less calls to
+ finding a substring too deep into the string means that fewer calls to
regtry() should be needed.
REx compiler's optimizer found 4 possible hints:
@@ -534,20 +592,22 @@
char *strend, const U32 flags, re_scream_pos_data *data)
{
dVAR;
- struct regexp *const prog = (struct regexp *)SvANY(rx);
- register I32 start_shift = 0;
+ struct regexp *const prog = ReANY(rx);
+ I32 start_shift = 0;
/* Should be nonnegative! */
- register I32 end_shift = 0;
- register char *s;
- register SV *check;
+ I32 end_shift = 0;
+ char *s;
+ SV *check;
char *strbeg;
char *t;
const bool utf8_target = (sv && SvUTF8(sv)) ? 1 : 0; /* if no sv we have to assume bytes */
I32 ml_anch;
- register char *other_last = NULL; /* other substr checked before this */
+ char *other_last = NULL; /* other substr checked before this */
char *check_at = NULL; /* check substr found at this pos */
+ char *checked_upto = NULL; /* how far into the string we have already checked using find_byclass*/
const I32 multiline = prog->extflags & RXf_PMf_MULTILINE;
RXi_GET_DECL(prog,progi);
+ bool is_utf8_pat;
#ifdef DEBUGGING
const char * const i_strpos = strpos;
#endif
@@ -554,12 +614,13 @@
GET_RE_DEBUG_FLAGS_DECL;
PERL_ARGS_ASSERT_RE_INTUIT_START;
+ PERL_UNUSED_ARG(flags);
+ PERL_UNUSED_ARG(data);
RX_MATCH_UTF8_set(rx,utf8_target);
- if (RX_UTF8(rx)) {
- PL_reg_flags |= RF_utf8;
- }
+ is_utf8_pat = cBOOL(RX_UTF8(rx));
+
DEBUG_EXECUTE_r(
debug_start_match(rx, utf8_target, strpos, strend,
sv ? "Guessing start of match in sv for"
@@ -572,8 +633,22 @@
"String too short... [re_intuit_start]\n"));
goto fail;
}
-
- strbeg = (sv && SvPOK(sv)) ? strend - SvCUR(sv) : strpos;
+
+ /* XXX we need to pass strbeg as a separate arg: the following is
+ * guesswork and can be wrong... */
+ if (sv && SvPOK(sv)) {
+ char * p = SvPVX(sv);
+ STRLEN cur = SvCUR(sv);
+ if (p <= strpos && strpos < p + cur) {
+ strbeg = p;
+ assert(p <= strend && strend <= p + cur);
+ }
+ else
+ strbeg = strend - cur;
+ }
+ else
+ strbeg = strpos;
+
PL_regeol = strend;
if (utf8_target) {
if (!prog->check_utf8 && prog->check_substr)
@@ -580,15 +655,13 @@
to_utf8_substr(prog);
check = prog->check_utf8;
} else {
- if (!prog->check_substr && prog->check_utf8)
- to_byte_substr(prog);
+ if (!prog->check_substr && prog->check_utf8) {
+ if (! to_byte_substr(prog)) {
+ NON_UTF8_TARGET_BUT_UTF8_REQUIRED(fail);
+ }
+ }
check = prog->check_substr;
}
- if (check == &PL_sv_undef) {
- DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
- "Non-utf8 string cannot match utf8 check string\n"));
- goto fail;
- }
if (prog->extflags & RXf_ANCH) { /* Match at beg-of-str or after \n */
ml_anch = !( (prog->extflags & RXf_ANCH_SINGLE)
|| ( (prog->extflags & RXf_ANCH_BOL)
@@ -603,8 +676,12 @@
DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not at start...\n"));
goto fail;
}
- if (prog->check_offset_min == prog->check_offset_max &&
- !(prog->extflags & RXf_CANY_SEEN)) {
+ if (prog->check_offset_min == prog->check_offset_max
+ && !(prog->extflags & RXf_CANY_SEEN)
+ && ! multiline) /* /m can cause \n's to match that aren't
+ accounted for in the string max length.
+ See [perl #115242] */
+ {
/* Substring at constant offset from beg-of-str... */
I32 slen;
@@ -672,6 +749,8 @@
{
I32 srch_start_shift = start_shift;
I32 srch_end_shift = end_shift;
+ U8* start_point;
+ U8* end_point;
if (srch_start_shift < 0 && strbeg - s > srch_start_shift) {
srch_end_shift -= ((strbeg - s) - srch_start_shift);
srch_start_shift = strbeg - s;
@@ -684,27 +763,6 @@
(IV)prog->check_end_shift);
});
- if (flags & REXEC_SCREAM) {
- I32 p = -1; /* Internal iterator of scream. */
- I32 * const pp = data ? data->scream_pos : &p;
-
- if (PL_screamfirst[BmRARE(check)] >= 0
- || ( BmRARE(check) == '\n'
- && (BmPREVIOUS(check) == SvCUR(check) - 1)
- && SvTAIL(check) ))
- s = screaminstr(sv, check,
- srch_start_shift + (s - strbeg), srch_end_shift, pp, 0);
- else
- goto fail_finish;
- /* we may be pointing at the wrong string */
- if (s && RXp_MATCH_COPIED(prog))
- s = strbeg + (s - SvPVX_const(sv));
- if (data)
- *data->scream_olds = s;
- }
- else {
- U8* start_point;
- U8* end_point;
if (prog->extflags & RXf_CANY_SEEN) {
start_point= (U8*)(s + srch_start_shift);
end_point= (U8*)(strend - srch_end_shift);
@@ -722,7 +780,6 @@
s = fbm_instr( start_point, end_point,
check, multiline ? FBMrf_MULTILINE : 0);
}
- }
/* Update the count-of-usability, remove useless subpatterns,
unshift s. */
@@ -1060,12 +1117,17 @@
else
endpos= strend;
- DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "start_shift: %"IVdf" check_at: %"IVdf" s: %"IVdf" endpos: %"IVdf"\n",
- (IV)start_shift, (IV)(check_at - strbeg), (IV)(s - strbeg), (IV)(endpos - strbeg)));
-
+ if (checked_upto < s)
+ checked_upto = s;
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "start_shift: %"IVdf" check_at: %"IVdf" s: %"IVdf" endpos: %"IVdf" checked_upto: %"IVdf"\n",
+ (IV)start_shift, (IV)(check_at - strbeg), (IV)(s - strbeg), (IV)(endpos - strbeg), (IV)(checked_upto- strbeg)));
+
t = s;
- s = find_byclass(prog, progi->regstclass, s, endpos, NULL);
- if (!s) {
+ s = find_byclass(prog, progi->regstclass, checked_upto, endpos,
+ NULL, is_utf8_pat);
+ if (s) {
+ checked_upto = s;
+ } else {
#ifdef DEBUGGING
const char *what = NULL;
#endif
@@ -1078,6 +1140,9 @@
"This position contradicts STCLASS...\n") );
if ((prog->extflags & RXf_ANCH) && !ml_anch)
goto fail;
+ checked_upto = HOPBACKc(endpos, start_shift);
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "start_shift: %"IVdf" check_at: %"IVdf" endpos: %"IVdf" checked_upto: %"IVdf"\n",
+ (IV)start_shift, (IV)(check_at - strbeg), (IV)(endpos - strbeg), (IV)(checked_upto- strbeg)));
/* Contradict one of substrings */
if (prog->anchored_substr || prog->anchored_utf8) {
if ((utf8_target ? prog->anchored_utf8 : prog->anchored_substr) == check) {
@@ -1157,58 +1222,61 @@
#define DECL_TRIE_TYPE(scan) \
const enum { trie_plain, trie_utf8, trie_utf8_fold, trie_latin_utf8_fold } \
- trie_type = (scan->flags != EXACT) \
- ? (utf8_target ? trie_utf8_fold : (UTF_PATTERN ? trie_latin_utf8_fold : trie_plain)) \
- : (utf8_target ? trie_utf8 : trie_plain)
+ trie_type = ((scan->flags == EXACT) \
+ ? (utf8_target ? trie_utf8 : trie_plain) \
+ : (utf8_target ? trie_utf8_fold : trie_latin_utf8_fold))
-#define REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc, uscan, len, \
-uvc, charid, foldlen, foldbuf, uniflags) STMT_START { \
- switch (trie_type) { \
- case trie_utf8_fold: \
- if ( foldlen>0 ) { \
- uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags ); \
- foldlen -= len; \
- uscan += len; \
- len=0; \
- } else { \
- uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags ); \
- uvc = to_uni_fold( uvc, foldbuf, &foldlen ); \
- foldlen -= UNISKIP( uvc ); \
- uscan = foldbuf + UNISKIP( uvc ); \
- } \
- break; \
- case trie_latin_utf8_fold: \
- if ( foldlen>0 ) { \
- uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags ); \
- foldlen -= len; \
- uscan += len; \
- len=0; \
- } else { \
- len = 1; \
- uvc = to_uni_fold( *(U8*)uc, foldbuf, &foldlen ); \
- foldlen -= UNISKIP( uvc ); \
- uscan = foldbuf + UNISKIP( uvc ); \
- } \
- break; \
- case trie_utf8: \
- uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags ); \
- break; \
- case trie_plain: \
- uvc = (UV)*uc; \
- len = 1; \
- } \
- if (uvc < 256) { \
- charid = trie->charmap[ uvc ]; \
- } \
- else { \
- charid = 0; \
- if (widecharmap) { \
- SV** const svpp = hv_fetch(widecharmap, \
- (char*)&uvc, sizeof(UV), 0); \
- if (svpp) \
- charid = (U16)SvIV(*svpp); \
- } \
- } \
+#define REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc, uscan, len, uvc, charid, foldlen, foldbuf, uniflags) \
+STMT_START { \
+ STRLEN skiplen; \
+ switch (trie_type) { \
+ case trie_utf8_fold: \
+ if ( foldlen>0 ) { \
+ uvc = utf8n_to_uvuni( (const U8*) uscan, UTF8_MAXLEN, &len, uniflags ); \
+ foldlen -= len; \
+ uscan += len; \
+ len=0; \
+ } else { \
+ uvc = to_utf8_fold( (const U8*) uc, foldbuf, &foldlen ); \
+ len = UTF8SKIP(uc); \
+ skiplen = UNISKIP( uvc ); \
+ foldlen -= skiplen; \
+ uscan = foldbuf + skiplen; \
+ } \
+ break; \
+ case trie_latin_utf8_fold: \
+ if ( foldlen>0 ) { \
+ uvc = utf8n_to_uvuni( (const U8*) uscan, UTF8_MAXLEN, &len, uniflags ); \
+ foldlen -= len; \
+ uscan += len; \
+ len=0; \
+ } else { \
+ len = 1; \
+ uvc = _to_fold_latin1( (U8) *uc, foldbuf, &foldlen, 1); \
+ skiplen = UNISKIP( uvc ); \
+ foldlen -= skiplen; \
+ uscan = foldbuf + skiplen; \
+ } \
+ break; \
+ case trie_utf8: \
+ uvc = utf8n_to_uvuni( (const U8*) uc, UTF8_MAXLEN, &len, uniflags ); \
+ break; \
+ case trie_plain: \
+ uvc = (UV)*uc; \
+ len = 1; \
+ } \
+ if (uvc < 256) { \
+ charid = trie->charmap[ uvc ]; \
+ } \
+ else { \
+ charid = 0; \
+ if (widecharmap) { \
+ SV** const svpp = hv_fetch(widecharmap, \
+ (char*)&uvc, sizeof(UV), 0); \
+ if (svpp) \
+ charid = (U16)SvIV(*svpp); \
+ } \
+ } \
} STMT_END
#define REXEC_FBC_EXACTISH_SCAN(CoNd) \
@@ -1224,9 +1292,9 @@
#define REXEC_FBC_UTF8_SCAN(CoDe) \
STMT_START { \
- while (s + (uskip = UTF8SKIP(s)) <= strend) { \
+ while (s < strend) { \
CoDe \
- s += uskip; \
+ s += UTF8SKIP(s); \
} \
} STMT_END
@@ -1241,7 +1309,7 @@
#define REXEC_FBC_UTF8_CLASS_SCAN(CoNd) \
REXEC_FBC_UTF8_SCAN( \
if (CoNd) { \
- if (tmp && (!reginfo || regtry(reginfo, &s))) \
+ if (tmp && (!reginfo || regtry(reginfo, &s))) \
goto got_it; \
else \
tmp = doevery; \
@@ -1274,24 +1342,6 @@
REXEC_FBC_CLASS_SCAN(CoNd); \
}
-#define REXEC_FBC_CSCAN_PRELOAD(UtFpReLoAd,CoNdUtF8,CoNd) \
- if (utf8_target) { \
- UtFpReLoAd; \
- REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8); \
- } \
- else { \
- REXEC_FBC_CLASS_SCAN(CoNd); \
- }
-
-#define REXEC_FBC_CSCAN_TAINT(CoNdUtF8,CoNd) \
- PL_reg_flags |= RF_tainted; \
- if (utf8_target) { \
- REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8); \
- } \
- else { \
- REXEC_FBC_CLASS_SCAN(CoNd); \
- }
-
#define DUMP_EXEC_POS(li,s,doutf8) \
dump_exec_pos(li,s,(PL_regeol),(PL_bostr),(PL_reg_starttry),doutf8)
@@ -1382,581 +1432,611 @@
STATIC char *
S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s,
- const char *strend, regmatch_info *reginfo)
+ const char *strend, regmatch_info *reginfo, bool is_utf8_pat)
{
- dVAR;
- const I32 doevery = (prog->intflags & PREGf_SKIP) == 0;
- char *pat_string; /* The pattern's exactish string */
- char *pat_end; /* ptr to end char of pat_string */
- re_fold_t folder; /* Function for computing non-utf8 folds */
- const U8 *fold_array; /* array for folding ords < 256 */
- STRLEN ln;
- STRLEN lnc;
- register STRLEN uskip;
- U8 c1;
- U8 c2;
- char *e;
- register I32 tmp = 1; /* Scratch variable? */
- register const bool utf8_target = PL_reg_match_utf8;
- UV utf8_fold_flags = 0;
- RXi_GET_DECL(prog,progi);
+ dVAR;
+ const I32 doevery = (prog->intflags & PREGf_SKIP) == 0;
+ char *pat_string; /* The pattern's exactish string */
+ char *pat_end; /* ptr to end char of pat_string */
+ re_fold_t folder; /* Function for computing non-utf8 folds */
+ const U8 *fold_array; /* array for folding ords < 256 */
+ STRLEN ln;
+ STRLEN lnc;
+ U8 c1;
+ U8 c2;
+ char *e;
+ I32 tmp = 1; /* Scratch variable? */
+ const bool utf8_target = PL_reg_match_utf8;
+ UV utf8_fold_flags = 0;
+ bool to_complement = FALSE; /* Invert the result? Taking the xor of this
+ with a result inverts that result, as 0^1 =
+ 1 and 1^1 = 0 */
+ _char_class_number classnum;
- PERL_ARGS_ASSERT_FIND_BYCLASS;
-
- /* We know what class it must start with. */
- switch (OP(c)) {
- case ANYOFV:
- case ANYOF:
- if (utf8_target || OP(c) == ANYOFV) {
- STRLEN inclasslen = strend - s;
- REXEC_FBC_UTF8_CLASS_SCAN(
- reginclass(prog, c, (U8*)s, &inclasslen, utf8_target));
- }
- else {
- REXEC_FBC_CLASS_SCAN(REGINCLASS(prog, c, (U8*)s));
- }
- break;
- case CANY:
- REXEC_FBC_SCAN(
- if (tmp && (!reginfo || regtry(reginfo, &s)))
- goto got_it;
- else
- tmp = doevery;
- );
- break;
+ RXi_GET_DECL(prog,progi);
- case EXACTFA:
- if (UTF_PATTERN || utf8_target) {
- utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII;
- goto do_exactf_utf8;
- }
- fold_array = PL_fold_latin1; /* Latin1 folds are not affected by */
- folder = foldEQ_latin1; /* /a, except the sharp s one which */
- goto do_exactf_non_utf8; /* isn't dealt with by these */
+ PERL_ARGS_ASSERT_FIND_BYCLASS;
- case EXACTFU:
- if (UTF_PATTERN || utf8_target) {
- utf8_fold_flags = 0;
- goto do_exactf_utf8;
- }
- fold_array = PL_fold_latin1;
- folder = foldEQ_latin1;
- /* XXX This uses the full utf8 fold because if the pattern contains
- * 'ss' it could match LATIN_SMALL_LETTER SHARP_S in the string.
- * There could be a new node type, say EXACTFU_SS, which is
- * generated by regcomp only if there is an 'ss', and then every
- * other case could goto do_exactf_non_utf8;*/
- goto do_exactf_utf8;
+ /* We know what class it must start with. */
+ switch (OP(c)) {
+ case ANYOF:
+ case ANYOF_SYNTHETIC:
+ case ANYOF_WARN_SUPER:
+ if (utf8_target) {
+ REXEC_FBC_UTF8_CLASS_SCAN(
+ reginclass(prog, c, (U8*)s, utf8_target));
+ }
+ else {
+ REXEC_FBC_CLASS_SCAN(REGINCLASS(prog, c, (U8*)s));
+ }
+ break;
+ case CANY:
+ REXEC_FBC_SCAN(
+ if (tmp && (!reginfo || regtry(reginfo, &s)))
+ goto got_it;
+ else
+ tmp = doevery;
+ );
+ break;
- case EXACTF:
- if (UTF_PATTERN || utf8_target) {
- utf8_fold_flags = 0;
- goto do_exactf_utf8;
- }
- fold_array = PL_fold;
- folder = foldEQ;
- goto do_exactf_non_utf8;
+ case EXACTFA:
+ if (is_utf8_pat || utf8_target) {
+ utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII;
+ goto do_exactf_utf8;
+ }
+ fold_array = PL_fold_latin1; /* Latin1 folds are not affected by */
+ folder = foldEQ_latin1; /* /a, except the sharp s one which */
+ goto do_exactf_non_utf8; /* isn't dealt with by these */
- case EXACTFL:
- if (UTF_PATTERN || utf8_target) {
- utf8_fold_flags = FOLDEQ_UTF8_LOCALE;
- goto do_exactf_utf8;
- }
- fold_array = PL_fold_locale;
- folder = foldEQ_locale;
+ case EXACTF:
+ if (utf8_target) {
- /* FALL THROUGH */
+ /* regcomp.c already folded this if pattern is in UTF-8 */
+ utf8_fold_flags = 0;
+ goto do_exactf_utf8;
+ }
+ fold_array = PL_fold;
+ folder = foldEQ;
+ goto do_exactf_non_utf8;
- do_exactf_non_utf8: /* Neither pattern nor string are UTF8 */
+ case EXACTFL:
+ if (is_utf8_pat || utf8_target) {
+ utf8_fold_flags = FOLDEQ_UTF8_LOCALE;
+ goto do_exactf_utf8;
+ }
+ fold_array = PL_fold_locale;
+ folder = foldEQ_locale;
+ goto do_exactf_non_utf8;
- /* The idea in the non-utf8 EXACTF* cases is to first find the
- * first character of the EXACTF* node and then, if necessary,
- * case-insensitively compare the full text of the node. c1 is the
- * first character. c2 is its fold. This logic will not work for
- * Unicode semantics and the german sharp ss, which hence should
- * not be compiled into a node that gets here. */
- pat_string = STRING(c);
- ln = STR_LEN(c); /* length to match in octets/bytes */
+ case EXACTFU_SS:
+ if (is_utf8_pat) {
+ utf8_fold_flags = FOLDEQ_S2_ALREADY_FOLDED;
+ }
+ goto do_exactf_utf8;
- e = HOP3c(strend, -((I32)ln), s);
+ case EXACTFU_TRICKYFOLD:
+ case EXACTFU:
+ if (is_utf8_pat || utf8_target) {
+ utf8_fold_flags = is_utf8_pat ? FOLDEQ_S2_ALREADY_FOLDED : 0;
+ goto do_exactf_utf8;
+ }
- if (!reginfo && e < s) {
- e = s; /* Due to minlen logic of intuit() */
- }
+ /* Any 'ss' in the pattern should have been replaced by regcomp,
+ * so we don't have to worry here about this single special case
+ * in the Latin1 range */
+ fold_array = PL_fold_latin1;
+ folder = foldEQ_latin1;
- c1 = *pat_string;
- c2 = fold_array[c1];
- if (c1 == c2) { /* If char and fold are the same */
- REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1);
- }
- else {
- REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1 || *(U8*)s == c2);
- }
- break;
+ /* FALL THROUGH */
- do_exactf_utf8:
+ do_exactf_non_utf8: /* Neither pattern nor string are UTF8, and there
+ are no glitches with fold-length differences
+ between the target string and pattern */
- /* If one of the operands is in utf8, we can't use the simpler
- * folding above, due to the fact that many different characters
- * can have the same fold, or portion of a fold, or different-
- * length fold */
- pat_string = STRING(c);
- ln = STR_LEN(c); /* length to match in octets/bytes */
- pat_end = pat_string + ln;
- lnc = (UTF_PATTERN) /* length to match in characters */
- ? utf8_length((U8 *) pat_string, (U8 *) pat_end)
- : ln;
+ /* The idea in the non-utf8 EXACTF* cases is to first find the
+ * first character of the EXACTF* node and then, if necessary,
+ * case-insensitively compare the full text of the node. c1 is the
+ * first character. c2 is its fold. This logic will not work for
+ * Unicode semantics and the german sharp ss, which hence should
+ * not be compiled into a node that gets here. */
+ pat_string = STRING(c);
+ ln = STR_LEN(c); /* length to match in octets/bytes */
- e = HOP3c(strend, -((I32)lnc), s);
+ /* We know that we have to match at least 'ln' bytes (which is the
+ * same as characters, since not utf8). If we have to match 3
+ * characters, and there are only 2 availabe, we know without
+ * trying that it will fail; so don't start a match past the
+ * required minimum number from the far end */
+ e = HOP3c(strend, -((I32)ln), s);
- if (!reginfo && e < s) {
- e = s; /* Due to minlen logic of intuit() */
- }
+ if (!reginfo && e < s) {
+ e = s; /* Due to minlen logic of intuit() */
+ }
- while (s <= e) {
- char *my_strend= (char *)strend;
- if (foldEQ_utf8_flags(s, &my_strend, 0, utf8_target,
- pat_string, NULL, ln, cBOOL(UTF_PATTERN), utf8_fold_flags)
- && (!reginfo || regtry(reginfo, &s)) )
- {
- goto got_it;
- }
- s += UTF8SKIP(s);
- }
- break;
- case BOUNDL:
- PL_reg_flags |= RF_tainted;
- FBC_BOUND(isALNUM_LC,
- isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp)),
- isALNUM_LC_utf8((U8*)s));
- break;
- case NBOUNDL:
- PL_reg_flags |= RF_tainted;
- FBC_NBOUND(isALNUM_LC,
- isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp)),
- isALNUM_LC_utf8((U8*)s));
- break;
- case BOUND:
- FBC_BOUND(isWORDCHAR,
- isALNUM_uni(tmp),
- cBOOL(swash_fetch(PL_utf8_alnum, (U8*)s, utf8_target)));
- break;
- case BOUNDA:
- FBC_BOUND_NOLOAD(isWORDCHAR_A,
- isWORDCHAR_A(tmp),
- isWORDCHAR_A((U8*)s));
- break;
- case NBOUND:
- FBC_NBOUND(isWORDCHAR,
- isALNUM_uni(tmp),
- cBOOL(swash_fetch(PL_utf8_alnum, (U8*)s, utf8_target)));
- break;
- case NBOUNDA:
- FBC_NBOUND_NOLOAD(isWORDCHAR_A,
- isWORDCHAR_A(tmp),
- isWORDCHAR_A((U8*)s));
- break;
- case BOUNDU:
- FBC_BOUND(isWORDCHAR_L1,
- isALNUM_uni(tmp),
- cBOOL(swash_fetch(PL_utf8_alnum, (U8*)s, utf8_target)));
- break;
- case NBOUNDU:
- FBC_NBOUND(isWORDCHAR_L1,
- isALNUM_uni(tmp),
- cBOOL(swash_fetch(PL_utf8_alnum, (U8*)s, utf8_target)));
- break;
- case ALNUML:
- REXEC_FBC_CSCAN_TAINT(
- isALNUM_LC_utf8((U8*)s),
- isALNUM_LC(*s)
- );
- break;
- case ALNUMU:
- REXEC_FBC_CSCAN_PRELOAD(
- LOAD_UTF8_CHARCLASS_ALNUM(),
- swash_fetch(PL_utf8_alnum,(U8*)s, utf8_target),
- isWORDCHAR_L1((U8) *s)
- );
- break;
- case ALNUM:
- REXEC_FBC_CSCAN_PRELOAD(
- LOAD_UTF8_CHARCLASS_ALNUM(),
- swash_fetch(PL_utf8_alnum,(U8*)s, utf8_target),
- isWORDCHAR((U8) *s)
- );
- break;
- case ALNUMA:
- /* Don't need to worry about utf8, as it can match only a single
- * byte invariant character */
- REXEC_FBC_CLASS_SCAN( isWORDCHAR_A(*s));
- break;
- case NALNUMU:
- REXEC_FBC_CSCAN_PRELOAD(
- LOAD_UTF8_CHARCLASS_ALNUM(),
- !swash_fetch(PL_utf8_alnum,(U8*)s, utf8_target),
- ! isWORDCHAR_L1((U8) *s)
- );
- break;
- case NALNUM:
- REXEC_FBC_CSCAN_PRELOAD(
- LOAD_UTF8_CHARCLASS_ALNUM(),
- !swash_fetch(PL_utf8_alnum, (U8*)s, utf8_target),
- ! isALNUM(*s)
- );
- break;
- case NALNUMA:
- REXEC_FBC_CSCAN(
- !isWORDCHAR_A(*s),
- !isWORDCHAR_A(*s)
- );
- break;
- case NALNUML:
- REXEC_FBC_CSCAN_TAINT(
- !isALNUM_LC_utf8((U8*)s),
- !isALNUM_LC(*s)
- );
- break;
- case SPACEU:
- REXEC_FBC_CSCAN_PRELOAD(
- LOAD_UTF8_CHARCLASS_SPACE(),
- *s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, utf8_target),
- isSPACE_L1((U8) *s)
- );
- break;
- case SPACE:
- REXEC_FBC_CSCAN_PRELOAD(
- LOAD_UTF8_CHARCLASS_SPACE(),
- *s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, utf8_target),
- isSPACE((U8) *s)
- );
- break;
- case SPACEA:
- /* Don't need to worry about utf8, as it can match only a single
- * byte invariant character */
- REXEC_FBC_CLASS_SCAN( isSPACE_A(*s));
- break;
- case SPACEL:
- REXEC_FBC_CSCAN_TAINT(
- isSPACE_LC_utf8((U8*)s),
- isSPACE_LC(*s)
- );
- break;
- case NSPACEU:
- REXEC_FBC_CSCAN_PRELOAD(
- LOAD_UTF8_CHARCLASS_SPACE(),
- !( *s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, utf8_target)),
- ! isSPACE_L1((U8) *s)
- );
- break;
- case NSPACE:
- REXEC_FBC_CSCAN_PRELOAD(
- LOAD_UTF8_CHARCLASS_SPACE(),
- !(*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, utf8_target)),
- ! isSPACE((U8) *s)
- );
- break;
- case NSPACEA:
- REXEC_FBC_CSCAN(
- !isSPACE_A(*s),
- !isSPACE_A(*s)
- );
- break;
- case NSPACEL:
- REXEC_FBC_CSCAN_TAINT(
- !isSPACE_LC_utf8((U8*)s),
- !isSPACE_LC(*s)
- );
- break;
- case DIGIT:
- REXEC_FBC_CSCAN_PRELOAD(
- LOAD_UTF8_CHARCLASS_DIGIT(),
- swash_fetch(PL_utf8_digit,(U8*)s, utf8_target),
- isDIGIT(*s)
- );
- break;
- case DIGITA:
- /* Don't need to worry about utf8, as it can match only a single
- * byte invariant character */
- REXEC_FBC_CLASS_SCAN( isDIGIT_A(*s));
- break;
- case DIGITL:
- REXEC_FBC_CSCAN_TAINT(
- isDIGIT_LC_utf8((U8*)s),
- isDIGIT_LC(*s)
- );
- break;
- case NDIGIT:
- REXEC_FBC_CSCAN_PRELOAD(
- LOAD_UTF8_CHARCLASS_DIGIT(),
- !swash_fetch(PL_utf8_digit,(U8*)s, utf8_target),
- !isDIGIT(*s)
- );
- break;
- case NDIGITA:
- REXEC_FBC_CSCAN(
- !isDIGIT_A(*s),
- !isDIGIT_A(*s)
- );
- break;
- case NDIGITL:
- REXEC_FBC_CSCAN_TAINT(
- !isDIGIT_LC_utf8((U8*)s),
- !isDIGIT_LC(*s)
- );
- break;
- case LNBREAK:
- REXEC_FBC_CSCAN(
- is_LNBREAK_utf8(s),
- is_LNBREAK_latin1(s)
- );
- break;
- case VERTWS:
- REXEC_FBC_CSCAN(
- is_VERTWS_utf8(s),
- is_VERTWS_latin1(s)
- );
- break;
- case NVERTWS:
- REXEC_FBC_CSCAN(
- !is_VERTWS_utf8(s),
- !is_VERTWS_latin1(s)
- );
- break;
- case HORIZWS:
- REXEC_FBC_CSCAN(
- is_HORIZWS_utf8(s),
- is_HORIZWS_latin1(s)
- );
- break;
- case NHORIZWS:
- REXEC_FBC_CSCAN(
- !is_HORIZWS_utf8(s),
- !is_HORIZWS_latin1(s)
- );
- break;
- case AHOCORASICKC:
- case AHOCORASICK:
- {
- DECL_TRIE_TYPE(c);
- /* what trie are we using right now */
- reg_ac_data *aho
- = (reg_ac_data*)progi->data->data[ ARG( c ) ];
- reg_trie_data *trie
- = (reg_trie_data*)progi->data->data[ aho->trie ];
- HV *widecharmap = MUTABLE_HV(progi->data->data[ aho->trie + 1 ]);
+ c1 = *pat_string;
+ c2 = fold_array[c1];
+ if (c1 == c2) { /* If char and fold are the same */
+ REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1);
+ }
+ else {
+ REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1 || *(U8*)s == c2);
+ }
+ break;
- const char *last_start = strend - trie->minlen;
+ do_exactf_utf8:
+ {
+ unsigned expansion;
+
+ /* If one of the operands is in utf8, we can't use the simpler folding
+ * above, due to the fact that many different characters can have the
+ * same fold, or portion of a fold, or different- length fold */
+ pat_string = STRING(c);
+ ln = STR_LEN(c); /* length to match in octets/bytes */
+ pat_end = pat_string + ln;
+ lnc = is_utf8_pat /* length to match in characters */
+ ? utf8_length((U8 *) pat_string, (U8 *) pat_end)
+ : ln;
+
+ /* We have 'lnc' characters to match in the pattern, but because of
+ * multi-character folding, each character in the target can match
+ * up to 3 characters (Unicode guarantees it will never exceed
+ * this) if it is utf8-encoded; and up to 2 if not (based on the
+ * fact that the Latin 1 folds are already determined, and the
+ * only multi-char fold in that range is the sharp-s folding to
+ * 'ss'. Thus, a pattern character can match as little as 1/3 of a
+ * string character. Adjust lnc accordingly, rounding up, so that
+ * if we need to match at least 4+1/3 chars, that really is 5. */
+ expansion = (utf8_target) ? UTF8_MAX_FOLD_CHAR_EXPAND : 2;
+ lnc = (lnc + expansion - 1) / expansion;
+
+ /* As in the non-UTF8 case, if we have to match 3 characters, and
+ * only 2 are left, it's guaranteed to fail, so don't start a
+ * match that would require us to go beyond the end of the string
+ */
+ e = HOP3c(strend, -((I32)lnc), s);
+
+ if (!reginfo && e < s) {
+ e = s; /* Due to minlen logic of intuit() */
+ }
+
+ /* XXX Note that we could recalculate e to stop the loop earlier,
+ * as the worst case expansion above will rarely be met, and as we
+ * go along we would usually find that e moves further to the left.
+ * This would happen only after we reached the point in the loop
+ * where if there were no expansion we should fail. Unclear if
+ * worth the expense */
+
+ while (s <= e) {
+ char *my_strend= (char *)strend;
+ if (foldEQ_utf8_flags(s, &my_strend, 0, utf8_target,
+ pat_string, NULL, ln, is_utf8_pat, utf8_fold_flags)
+ && (!reginfo || regtry(reginfo, &s)) )
+ {
+ goto got_it;
+ }
+ s += (utf8_target) ? UTF8SKIP(s) : 1;
+ }
+ break;
+ }
+ case BOUNDL:
+ RXp_MATCH_TAINTED_on(prog);
+ FBC_BOUND(isWORDCHAR_LC,
+ isWORDCHAR_LC_uvchr(UNI_TO_NATIVE(tmp)),
+ isWORDCHAR_LC_utf8((U8*)s));
+ break;
+ case NBOUNDL:
+ RXp_MATCH_TAINTED_on(prog);
+ FBC_NBOUND(isWORDCHAR_LC,
+ isWORDCHAR_LC_uvchr(UNI_TO_NATIVE(tmp)),
+ isWORDCHAR_LC_utf8((U8*)s));
+ break;
+ case BOUND:
+ FBC_BOUND(isWORDCHAR,
+ isWORDCHAR_uni(tmp),
+ cBOOL(swash_fetch(PL_utf8_swash_ptrs[_CC_WORDCHAR], (U8*)s, utf8_target)));
+ break;
+ case BOUNDA:
+ FBC_BOUND_NOLOAD(isWORDCHAR_A,
+ isWORDCHAR_A(tmp),
+ isWORDCHAR_A((U8*)s));
+ break;
+ case NBOUND:
+ FBC_NBOUND(isWORDCHAR,
+ isWORDCHAR_uni(tmp),
+ cBOOL(swash_fetch(PL_utf8_swash_ptrs[_CC_WORDCHAR], (U8*)s, utf8_target)));
+ break;
+ case NBOUNDA:
+ FBC_NBOUND_NOLOAD(isWORDCHAR_A,
+ isWORDCHAR_A(tmp),
+ isWORDCHAR_A((U8*)s));
+ break;
+ case BOUNDU:
+ FBC_BOUND(isWORDCHAR_L1,
+ isWORDCHAR_uni(tmp),
+ cBOOL(swash_fetch(PL_utf8_swash_ptrs[_CC_WORDCHAR], (U8*)s, utf8_target)));
+ break;
+ case NBOUNDU:
+ FBC_NBOUND(isWORDCHAR_L1,
+ isWORDCHAR_uni(tmp),
+ cBOOL(swash_fetch(PL_utf8_swash_ptrs[_CC_WORDCHAR], (U8*)s, utf8_target)));
+ break;
+ case LNBREAK:
+ REXEC_FBC_CSCAN(is_LNBREAK_utf8_safe(s, strend),
+ is_LNBREAK_latin1_safe(s, strend)
+ );
+ break;
+
+ /* The argument to all the POSIX node types is the class number to pass to
+ * _generic_isCC() to build a mask for searching in PL_charclass[] */
+
+ case NPOSIXL:
+ to_complement = 1;
+ /* FALLTHROUGH */
+
+ case POSIXL:
+ RXp_MATCH_TAINTED_on(prog);
+ REXEC_FBC_CSCAN(to_complement ^ cBOOL(isFOO_utf8_lc(FLAGS(c), (U8 *) s)),
+ to_complement ^ cBOOL(isFOO_lc(FLAGS(c), *s)));
+ break;
+
+ case NPOSIXD:
+ to_complement = 1;
+ /* FALLTHROUGH */
+
+ case POSIXD:
+ if (utf8_target) {
+ goto posix_utf8;
+ }
+ goto posixa;
+
+ case NPOSIXA:
+ if (utf8_target) {
+ /* The complement of something that matches only ASCII matches all
+ * UTF-8 variant code points, plus everything in ASCII that isn't
+ * in the class */
+ REXEC_FBC_UTF8_CLASS_SCAN(! UTF8_IS_INVARIANT(*s)
+ || ! _generic_isCC_A(*s, FLAGS(c)));
+ break;
+ }
+
+ to_complement = 1;
+ /* FALLTHROUGH */
+
+ case POSIXA:
+ posixa:
+ /* Don't need to worry about utf8, as it can match only a single
+ * byte invariant character. */
+ REXEC_FBC_CLASS_SCAN(
+ to_complement ^ cBOOL(_generic_isCC_A(*s, FLAGS(c))));
+ break;
+
+ case NPOSIXU:
+ to_complement = 1;
+ /* FALLTHROUGH */
+
+ case POSIXU:
+ if (! utf8_target) {
+ REXEC_FBC_CLASS_SCAN(to_complement ^ cBOOL(_generic_isCC(*s,
+ FLAGS(c))));
+ }
+ else {
+
+ posix_utf8:
+ classnum = (_char_class_number) FLAGS(c);
+ if (classnum < _FIRST_NON_SWASH_CC) {
+ while (s < strend) {
+
+ /* We avoid loading in the swash as long as possible, but
+ * should we have to, we jump to a separate loop. This
+ * extra 'if' statement is what keeps this code from being
+ * just a call to REXEC_FBC_UTF8_CLASS_SCAN() */
+ if (UTF8_IS_ABOVE_LATIN1(*s)) {
+ goto found_above_latin1;
+ }
+ if ((UTF8_IS_INVARIANT(*s)
+ && to_complement ^ cBOOL(_generic_isCC((U8) *s,
+ classnum)))
+ || (UTF8_IS_DOWNGRADEABLE_START(*s)
+ && to_complement ^ cBOOL(
+ _generic_isCC(TWO_BYTE_UTF8_TO_UNI(*s, *(s + 1)),
+ classnum))))
+ {
+ if (tmp && (!reginfo || regtry(reginfo, &s)))
+ goto got_it;
+ else {
+ tmp = doevery;
+ }
+ }
+ else {
+ tmp = 1;
+ }
+ s += UTF8SKIP(s);
+ }
+ }
+ else switch (classnum) { /* These classes are implemented as
+ macros */
+ case _CC_ENUM_SPACE: /* XXX would require separate code if we
+ revert the change of \v matching this */
+ /* FALL THROUGH */
+
+ case _CC_ENUM_PSXSPC:
+ REXEC_FBC_UTF8_CLASS_SCAN(
+ to_complement ^ cBOOL(isSPACE_utf8(s)));
+ break;
+
+ case _CC_ENUM_BLANK:
+ REXEC_FBC_UTF8_CLASS_SCAN(
+ to_complement ^ cBOOL(isBLANK_utf8(s)));
+ break;
+
+ case _CC_ENUM_XDIGIT:
+ REXEC_FBC_UTF8_CLASS_SCAN(
+ to_complement ^ cBOOL(isXDIGIT_utf8(s)));
+ break;
+
+ case _CC_ENUM_VERTSPACE:
+ REXEC_FBC_UTF8_CLASS_SCAN(
+ to_complement ^ cBOOL(isVERTWS_utf8(s)));
+ break;
+
+ case _CC_ENUM_CNTRL:
+ REXEC_FBC_UTF8_CLASS_SCAN(
+ to_complement ^ cBOOL(isCNTRL_utf8(s)));
+ break;
+
+ default:
+ Perl_croak(aTHX_ "panic: find_byclass() node %d='%s' has an unexpected character class '%d'", OP(c), PL_reg_name[OP(c)], classnum);
+ assert(0); /* NOTREACHED */
+ }
+ }
+ break;
+
+ found_above_latin1: /* Here we have to load a swash to get the result
+ for the current code point */
+ if (! PL_utf8_swash_ptrs[classnum]) {
+ U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
+ PL_utf8_swash_ptrs[classnum] =
+ _core_swash_init("utf8", swash_property_names[classnum],
+ &PL_sv_undef, 1, 0, NULL, &flags);
+ }
+
+ /* This is a copy of the loop above for swash classes, though using the
+ * FBC macro instead of being expanded out. Since we've loaded the
+ * swash, we don't have to check for that each time through the loop */
+ REXEC_FBC_UTF8_CLASS_SCAN(
+ to_complement ^ cBOOL(_generic_utf8(
+ classnum,
+ s,
+ swash_fetch(PL_utf8_swash_ptrs[classnum],
+ (U8 *) s, TRUE))));
+ break;
+
+ case AHOCORASICKC:
+ case AHOCORASICK:
+ {
+ DECL_TRIE_TYPE(c);
+ /* what trie are we using right now */
+ reg_ac_data *aho = (reg_ac_data*)progi->data->data[ ARG( c ) ];
+ reg_trie_data *trie = (reg_trie_data*)progi->data->data[ aho->trie ];
+ HV *widecharmap = MUTABLE_HV(progi->data->data[ aho->trie + 1 ]);
+
+ const char *last_start = strend - trie->minlen;
#ifdef DEBUGGING
- const char *real_start = s;
+ const char *real_start = s;
#endif
- STRLEN maxlen = trie->maxlen;
- SV *sv_points;
- U8 **points; /* map of where we were in the input string
- when reading a given char. For ASCII this
- is unnecessary overhead as the relationship
- is always 1:1, but for Unicode, especially
- case folded Unicode this is not true. */
- U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
- U8 *bitmap=NULL;
+ STRLEN maxlen = trie->maxlen;
+ SV *sv_points;
+ U8 **points; /* map of where we were in the input string
+ when reading a given char. For ASCII this
+ is unnecessary overhead as the relationship
+ is always 1:1, but for Unicode, especially
+ case folded Unicode this is not true. */
+ U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
+ U8 *bitmap=NULL;
- GET_RE_DEBUG_FLAGS_DECL;
+ GET_RE_DEBUG_FLAGS_DECL;
- /* We can't just allocate points here. We need to wrap it in
- * an SV so it gets freed properly if there is a croak while
- * running the match */
- ENTER;
- SAVETMPS;
- sv_points=newSV(maxlen * sizeof(U8 *));
- SvCUR_set(sv_points,
- maxlen * sizeof(U8 *));
- SvPOK_on(sv_points);
- sv_2mortal(sv_points);
- points=(U8**)SvPV_nolen(sv_points );
- if ( trie_type != trie_utf8_fold
- && (trie->bitmap || OP(c)==AHOCORASICKC) )
- {
- if (trie->bitmap)
- bitmap=(U8*)trie->bitmap;
- else
- bitmap=(U8*)ANYOF_BITMAP(c);
- }
- /* this is the Aho-Corasick algorithm modified a touch
- to include special handling for long "unknown char"
- sequences. The basic idea being that we use AC as long
- as we are dealing with a possible matching char, when
- we encounter an unknown char (and we have not encountered
- an accepting state) we scan forward until we find a legal
- starting char.
- AC matching is basically that of trie matching, except
- that when we encounter a failing transition, we fall back
- to the current states "fail state", and try the current char
- again, a process we repeat until we reach the root state,
- state 1, or a legal transition. If we fail on the root state
- then we can either terminate if we have reached an accepting
- state previously, or restart the entire process from the beginning
- if we have not.
+ /* We can't just allocate points here. We need to wrap it in
+ * an SV so it gets freed properly if there is a croak while
+ * running the match */
+ ENTER;
+ SAVETMPS;
+ sv_points=newSV(maxlen * sizeof(U8 *));
+ SvCUR_set(sv_points,
+ maxlen * sizeof(U8 *));
+ SvPOK_on(sv_points);
+ sv_2mortal(sv_points);
+ points=(U8**)SvPV_nolen(sv_points );
+ if ( trie_type != trie_utf8_fold
+ && (trie->bitmap || OP(c)==AHOCORASICKC) )
+ {
+ if (trie->bitmap)
+ bitmap=(U8*)trie->bitmap;
+ else
+ bitmap=(U8*)ANYOF_BITMAP(c);
+ }
+ /* this is the Aho-Corasick algorithm modified a touch
+ to include special handling for long "unknown char" sequences.
+ The basic idea being that we use AC as long as we are dealing
+ with a possible matching char, when we encounter an unknown char
+ (and we have not encountered an accepting state) we scan forward
+ until we find a legal starting char.
+ AC matching is basically that of trie matching, except that when
+ we encounter a failing transition, we fall back to the current
+ states "fail state", and try the current char again, a process
+ we repeat until we reach the root state, state 1, or a legal
+ transition. If we fail on the root state then we can either
+ terminate if we have reached an accepting state previously, or
+ restart the entire process from the beginning if we have not.
- */
- while (s <= last_start) {
- const U32 uniflags = UTF8_ALLOW_DEFAULT;
- U8 *uc = (U8*)s;
- U16 charid = 0;
- U32 base = 1;
- U32 state = 1;
- UV uvc = 0;
- STRLEN len = 0;
- STRLEN foldlen = 0;
- U8 *uscan = (U8*)NULL;
- U8 *leftmost = NULL;
-#ifdef DEBUGGING
- U32 accepted_word= 0;
+ */
+ while (s <= last_start) {
+ const U32 uniflags = UTF8_ALLOW_DEFAULT;
+ U8 *uc = (U8*)s;
+ U16 charid = 0;
+ U32 base = 1;
+ U32 state = 1;
+ UV uvc = 0;
+ STRLEN len = 0;
+ STRLEN foldlen = 0;
+ U8 *uscan = (U8*)NULL;
+ U8 *leftmost = NULL;
+#ifdef DEBUGGING
+ U32 accepted_word= 0;
#endif
- U32 pointpos = 0;
+ U32 pointpos = 0;
- while ( state && uc <= (U8*)strend ) {
- int failed=0;
- U32 word = aho->states[ state ].wordnum;
+ while ( state && uc <= (U8*)strend ) {
+ int failed=0;
+ U32 word = aho->states[ state ].wordnum;
- if( state==1 ) {
- if ( bitmap ) {
- DEBUG_TRIE_EXECUTE_r(
- if ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
- dump_exec_pos( (char *)uc, c, strend, real_start,
- (char *)uc, utf8_target );
- PerlIO_printf( Perl_debug_log,
- " Scanning for legal start char...\n");
- }
- );
- if (utf8_target) {
- while ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
- uc += UTF8SKIP(uc);
- }
- } else {
- while ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
- uc++;
- }
- }
- s= (char *)uc;
+ if( state==1 ) {
+ if ( bitmap ) {
+ DEBUG_TRIE_EXECUTE_r(
+ if ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
+ dump_exec_pos( (char *)uc, c, strend, real_start,
+ (char *)uc, utf8_target );
+ PerlIO_printf( Perl_debug_log,
+ " Scanning for legal start char...\n");
+ }
+ );
+ if (utf8_target) {
+ while ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
+ uc += UTF8SKIP(uc);
+ }
+ } else {
+ while ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
+ uc++;
+ }
}
- if (uc >(U8*)last_start) break;
+ s= (char *)uc;
}
-
- if ( word ) {
- U8 *lpos= points[ (pointpos - trie->wordinfo[word].len) % maxlen ];
- if (!leftmost || lpos < leftmost) {
- DEBUG_r(accepted_word=word);
- leftmost= lpos;
- }
- if (base==0) break;
-
+ if (uc >(U8*)last_start) break;
+ }
+
+ if ( word ) {
+ U8 *lpos= points[ (pointpos - trie->wordinfo[word].len) % maxlen ];
+ if (!leftmost || lpos < leftmost) {
+ DEBUG_r(accepted_word=word);
+ leftmost= lpos;
}
- points[pointpos++ % maxlen]= uc;
- REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
- uscan, len, uvc, charid, foldlen,
- foldbuf, uniflags);
+ if (base==0) break;
+
+ }
+ points[pointpos++ % maxlen]= uc;
+ if (foldlen || uc < (U8*)strend) {
+ REXEC_TRIE_READ_CHAR(trie_type, trie,
+ widecharmap, uc,
+ uscan, len, uvc, charid, foldlen,
+ foldbuf, uniflags);
DEBUG_TRIE_EXECUTE_r({
- dump_exec_pos( (char *)uc, c, strend, real_start,
- s, utf8_target );
+ dump_exec_pos( (char *)uc, c, strend,
+ real_start, s, utf8_target);
PerlIO_printf(Perl_debug_log,
" Charid:%3u CP:%4"UVxf" ",
charid, uvc);
});
+ }
+ else {
+ len = 0;
+ charid = 0;
+ }
- do {
+
+ do {
#ifdef DEBUGGING
- word = aho->states[ state ].wordnum;
+ word = aho->states[ state ].wordnum;
#endif
- base = aho->states[ state ].trans.base;
+ base = aho->states[ state ].trans.base;
- DEBUG_TRIE_EXECUTE_r({
- if (failed)
- dump_exec_pos( (char *)uc, c, strend, real_start,
- s, utf8_target );
- PerlIO_printf( Perl_debug_log,
- "%sState: %4"UVxf", word=%"UVxf,
- failed ? " Fail transition to " : "",
- (UV)state, (UV)word);
- });
- if ( base ) {
- U32 tmp;
- I32 offset;
- if (charid &&
- ( ((offset = base + charid
- - 1 - trie->uniquecharcount)) >= 0)
- && ((U32)offset < trie->lasttrans)
- && trie->trans[offset].check == state
- && (tmp=trie->trans[offset].next))
- {
- DEBUG_TRIE_EXECUTE_r(
- PerlIO_printf( Perl_debug_log," - legal\n"));
- state = tmp;
- break;
- }
- else {
- DEBUG_TRIE_EXECUTE_r(
- PerlIO_printf( Perl_debug_log," - fail\n"));
- failed = 1;
- state = aho->fail[state];
- }
+ DEBUG_TRIE_EXECUTE_r({
+ if (failed)
+ dump_exec_pos( (char *)uc, c, strend, real_start,
+ s, utf8_target );
+ PerlIO_printf( Perl_debug_log,
+ "%sState: %4"UVxf", word=%"UVxf,
+ failed ? " Fail transition to " : "",
+ (UV)state, (UV)word);
+ });
+ if ( base ) {
+ U32 tmp;
+ I32 offset;
+ if (charid &&
+ ( ((offset = base + charid
+ - 1 - trie->uniquecharcount)) >= 0)
+ && ((U32)offset < trie->lasttrans)
+ && trie->trans[offset].check == state
+ && (tmp=trie->trans[offset].next))
+ {
+ DEBUG_TRIE_EXECUTE_r(
+ PerlIO_printf( Perl_debug_log," - legal\n"));
+ state = tmp;
+ break;
}
else {
- /* we must be accepting here */
DEBUG_TRIE_EXECUTE_r(
- PerlIO_printf( Perl_debug_log," - accepting\n"));
+ PerlIO_printf( Perl_debug_log," - fail\n"));
failed = 1;
- break;
+ state = aho->fail[state];
}
- } while(state);
- uc += len;
- if (failed) {
- if (leftmost)
- break;
- if (!state) state = 1;
}
- }
- if ( aho->states[ state ].wordnum ) {
- U8 *lpos = points[ (pointpos - trie->wordinfo[aho->states[ state ].wordnum].len) % maxlen ];
- if (!leftmost || lpos < leftmost) {
- DEBUG_r(accepted_word=aho->states[ state ].wordnum);
- leftmost = lpos;
+ else {
+ /* we must be accepting here */
+ DEBUG_TRIE_EXECUTE_r(
+ PerlIO_printf( Perl_debug_log," - accepting\n"));
+ failed = 1;
+ break;
}
+ } while(state);
+ uc += len;
+ if (failed) {
+ if (leftmost)
+ break;
+ if (!state) state = 1;
}
- if (leftmost) {
- s = (char*)leftmost;
- DEBUG_TRIE_EXECUTE_r({
- PerlIO_printf(
- Perl_debug_log,"Matches word #%"UVxf" at position %"IVdf". Trying full pattern...\n",
- (UV)accepted_word, (IV)(s - real_start)
- );
- });
- if (!reginfo || regtry(reginfo, &s)) {
- FREETMPS;
- LEAVE;
- goto got_it;
- }
- s = HOPc(s,1);
- DEBUG_TRIE_EXECUTE_r({
- PerlIO_printf( Perl_debug_log,"Pattern failed. Looking for new start point...\n");
- });
- } else {
- DEBUG_TRIE_EXECUTE_r(
- PerlIO_printf( Perl_debug_log,"No match.\n"));
- break;
+ }
+ if ( aho->states[ state ].wordnum ) {
+ U8 *lpos = points[ (pointpos - trie->wordinfo[aho->states[ state ].wordnum].len) % maxlen ];
+ if (!leftmost || lpos < leftmost) {
+ DEBUG_r(accepted_word=aho->states[ state ].wordnum);
+ leftmost = lpos;
}
}
- FREETMPS;
- LEAVE;
- }
- break;
- default:
- Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
- break;
- }
- return 0;
- got_it:
- return s;
+ if (leftmost) {
+ s = (char*)leftmost;
+ DEBUG_TRIE_EXECUTE_r({
+ PerlIO_printf(
+ Perl_debug_log,"Matches word #%"UVxf" at position %"IVdf". Trying full pattern...\n",
+ (UV)accepted_word, (IV)(s - real_start)
+ );
+ });
+ if (!reginfo || regtry(reginfo, &s)) {
+ FREETMPS;
+ LEAVE;
+ goto got_it;
+ }
+ s = HOPc(s,1);
+ DEBUG_TRIE_EXECUTE_r({
+ PerlIO_printf( Perl_debug_log,"Pattern failed. Looking for new start point...\n");
+ });
+ } else {
+ DEBUG_TRIE_EXECUTE_r(
+ PerlIO_printf( Perl_debug_log,"No match.\n"));
+ break;
+ }
+ }
+ FREETMPS;
+ LEAVE;
+ }
+ break;
+ default:
+ Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
+ break;
+ }
+ return 0;
+ got_it:
+ return s;
}
@@ -1964,21 +2044,25 @@
- regexec_flags - match a regexp against a string
*/
I32
-Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, register char *strend,
+Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend,
char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
-/* strend: pointer to null at end of string */
-/* strbeg: real beginning of string */
-/* minend: end of match must be >=minend after stringarg. */
-/* data: May be used for some additional optimizations.
- Currently its only used, with a U32 cast, for transmitting
- the ganch offset when doing a /g match. This will change */
-/* nosave: For optimizations. */
+/* stringarg: the point in the string at which to begin matching */
+/* strend: pointer to null at end of string */
+/* strbeg: real beginning of string */
+/* minend: end of match must be >= minend bytes after stringarg. */
+/* sv: SV being matched: only used for utf8 flag, pos() etc; string
+ * itself is accessed via the pointers above */
+/* data: May be used for some additional optimizations.
+ Currently its only used, with a U32 cast, for transmitting
+ the ganch offset when doing a /g match. This will change */
+/* nosave: For optimizations. */
+
{
dVAR;
- struct regexp *const prog = (struct regexp *)SvANY(rx);
- /*register*/ char *s;
- register regnode *c;
- /*register*/ char *startpos = stringarg;
+ struct regexp *const prog = ReANY(rx);
+ char *s;
+ regnode *c;
+ char *startpos = stringarg;
I32 minlen; /* must match at least this many chars */
I32 dontbother = 0; /* how many characters not to try at end */
I32 end_shift = 0; /* Same for the end. */ /* CC */
@@ -2023,13 +2107,12 @@
Perl_croak(aTHX_ "corrupted regexp program");
}
- PL_reg_flags = 0;
- PL_reg_eval_set = 0;
+ RX_MATCH_TAINTED_off(rx);
+ PL_reg_state.re_state_eval_setup_done = FALSE;
PL_reg_maxiter = 0;
- if (RX_UTF8(rx))
- PL_reg_flags |= RF_utf8;
-
+ reginfo.is_utf8_pat = cBOOL(RX_UTF8(rx));
+ reginfo.warned = FALSE;
/* Mark beginning of line for ^ and lookbehind. */
reginfo.bol = startpos; /* XXX not used ??? */
PL_bostr = strbeg;
@@ -2084,12 +2167,18 @@
was from this regex we don't want a subsequent partially
successful match to clobber the old results.
So when we detect this possibility we add a swap buffer
- to the re, and switch the buffer each match. If we fail
- we switch it back, otherwise we leave it swapped.
+ to the re, and switch the buffer each match. If we fail,
+ we switch it back; otherwise we leave it swapped.
*/
swap = prog->offs;
/* do we need a save destructor here for eval dies? */
Newxz(prog->offs, (prog->nparens + 1), regexp_paren_pair);
+ DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
+ "rex=0x%"UVxf" saving offs: orig=0x%"UVxf" new=0x%"UVxf"\n",
+ PTR2UV(prog),
+ PTR2UV(swap),
+ PTR2UV(prog->offs)
+ ));
}
if (!(flags & REXEC_CHECKED) && (prog->check_substr != NULL || prog->check_utf8 != NULL)) {
re_scream_pos_data d;
@@ -2173,8 +2262,8 @@
/*XXX: The s-- is almost definitely wrong here under unicode - demeprhq*/
s--;
}
- /* We can use a more efficient search as newlines are the same in unicode as they are in latin */
- while (s < end) {
+ /* We can use a more efficient search as newlines are the same in unicode as they are in latin */
+ while (s <= end) { /* note it could be possible to match at the end of the string */
if (*s++ == '\n') { /* don't need PL_utf8skip here */
if (regtry(®info, &s))
goto got_it;
@@ -2198,16 +2287,16 @@
/* Messy cases: unanchored match. */
if ((prog->anchored_substr || prog->anchored_utf8) && prog->intflags & PREGf_SKIP) {
/* we have /x+whatever/ */
- /* it must be a one character string (XXXX Except UTF_PATTERN?) */
+ /* it must be a one character string (XXXX Except is_utf8_pat?) */
char ch;
#ifdef DEBUGGING
int did_match = 0;
#endif
- if (!(utf8_target ? prog->anchored_utf8 : prog->anchored_substr))
- utf8_target ? to_utf8_substr(prog) : to_byte_substr(prog);
- ch = SvPVX_const(utf8_target ? prog->anchored_utf8 : prog->anchored_substr)[0];
-
if (utf8_target) {
+ if (! prog->anchored_utf8) {
+ to_utf8_substr(prog);
+ }
+ ch = SvPVX_const(prog->anchored_utf8)[0];
REXEC_FBC_SCAN(
if (*s == ch) {
DEBUG_EXECUTE_r( did_match = 1 );
@@ -2217,8 +2306,15 @@
s += UTF8SKIP(s);
}
);
+
}
else {
+ if (! prog->anchored_substr) {
+ if (! to_byte_substr(prog)) {
+ NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
+ }
+ }
+ ch = SvPVX_const(prog->anchored_substr)[0];
REXEC_FBC_SCAN(
if (*s == ch) {
DEBUG_EXECUTE_r( did_match = 1 );
@@ -2247,23 +2343,40 @@
int did_match = 0;
#endif
if (prog->anchored_substr || prog->anchored_utf8) {
- if (!(utf8_target ? prog->anchored_utf8 : prog->anchored_substr))
- utf8_target ? to_utf8_substr(prog) : to_byte_substr(prog);
- must = utf8_target ? prog->anchored_utf8 : prog->anchored_substr;
+ if (utf8_target) {
+ if (! prog->anchored_utf8) {
+ to_utf8_substr(prog);
+ }
+ must = prog->anchored_utf8;
+ }
+ else {
+ if (! prog->anchored_substr) {
+ if (! to_byte_substr(prog)) {
+ NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
+ }
+ }
+ must = prog->anchored_substr;
+ }
back_max = back_min = prog->anchored_offset;
} else {
- if (!(utf8_target ? prog->float_utf8 : prog->float_substr))
- utf8_target ? to_utf8_substr(prog) : to_byte_substr(prog);
- must = utf8_target ? prog->float_utf8 : prog->float_substr;
+ if (utf8_target) {
+ if (! prog->float_utf8) {
+ to_utf8_substr(prog);
+ }
+ must = prog->float_utf8;
+ }
+ else {
+ if (! prog->float_substr) {
+ if (! to_byte_substr(prog)) {
+ NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
+ }
+ }
+ must = prog->float_substr;
+ }
back_max = prog->float_max_offset;
back_min = prog->float_min_offset;
}
-
- if (must == &PL_sv_undef)
- /* could not downgrade utf8 check substring, so must fail */
- goto phooey;
-
if (back_min<0) {
last = strend;
} else {
@@ -2282,15 +2395,9 @@
dontbother = end_shift;
strend = HOPc(strend, -dontbother);
while ( (s <= last) &&
- ((flags & REXEC_SCREAM)
- ? (s = screaminstr(sv, must, HOP3c(s, back_min, (back_min<0 ? strbeg : strend)) - strbeg,
- end_shift, &scream_pos, 0))
- : (s = fbm_instr((unsigned char*)HOP3(s, back_min, (back_min<0 ? strbeg : strend)),
+ (s = fbm_instr((unsigned char*)HOP3(s, back_min, (back_min<0 ? strbeg : strend)),
(unsigned char*)strend, must,
- multiline ? FBMrf_MULTILINE : 0))) ) {
- /* we may be pointing at the wrong string */
- if ((flags & REXEC_SCREAM) && RXp_MATCH_COPIED(prog))
- s = strbeg + (s - SvPVX_const(sv));
+ multiline ? FBMrf_MULTILINE : 0)) ) {
DEBUG_EXECUTE_r( did_match = 1 );
if (HOPc(s, -back_max) > last1) {
last1 = HOPc(s, -back_min);
@@ -2306,7 +2413,11 @@
while (s <= last1) {
if (regtry(®info, &s))
goto got_it;
- s += UTF8SKIP(s);
+ if (s >= last1) {
+ s++; /* to break out of outer loop */
+ break;
+ }
+ s += UTF8SKIP(s);
}
}
else {
@@ -2346,7 +2457,7 @@
quoted, (int)(strend - s));
}
});
- if (find_byclass(prog, c, s, strend, ®info))
+ if (find_byclass(prog, c, s, strend, ®info, reginfo.is_utf8_pat))
goto got_it;
DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass... [regexec_flags]\n"));
}
@@ -2354,48 +2465,97 @@
dontbother = 0;
if (prog->float_substr != NULL || prog->float_utf8 != NULL) {
/* Trim the end. */
- char *last;
+ char *last= NULL;
SV* float_real;
+ STRLEN len;
+ const char *little;
- if (!(utf8_target ? prog->float_utf8 : prog->float_substr))
- utf8_target ? to_utf8_substr(prog) : to_byte_substr(prog);
- float_real = utf8_target ? prog->float_utf8 : prog->float_substr;
+ if (utf8_target) {
+ if (! prog->float_utf8) {
+ to_utf8_substr(prog);
+ }
+ float_real = prog->float_utf8;
+ }
+ else {
+ if (! prog->float_substr) {
+ if (! to_byte_substr(prog)) {
+ NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
+ }
+ }
+ float_real = prog->float_substr;
+ }
- if (flags & REXEC_SCREAM) {
- last = screaminstr(sv, float_real, s - strbeg,
- end_shift, &scream_pos, 1); /* last one */
- if (!last)
- last = scream_olds; /* Only one occurrence. */
- /* we may be pointing at the wrong string */
- else if (RXp_MATCH_COPIED(prog))
- s = strbeg + (s - SvPVX_const(sv));
- }
- else {
- STRLEN len;
- const char * const little = SvPV_const(float_real, len);
-
- if (SvTAIL(float_real)) {
- if (memEQ(strend - len + 1, little, len - 1))
- last = strend - len + 1;
- else if (!multiline)
- last = memEQ(strend - len, little, len)
- ? strend - len : NULL;
- else
+ little = SvPV_const(float_real, len);
+ if (SvTAIL(float_real)) {
+ /* This means that float_real contains an artificial \n on
+ * the end due to the presence of something like this:
+ * /foo$/ where we can match both "foo" and "foo\n" at the
+ * end of the string. So we have to compare the end of the
+ * string first against the float_real without the \n and
+ * then against the full float_real with the string. We
+ * have to watch out for cases where the string might be
+ * smaller than the float_real or the float_real without
+ * the \n. */
+ char *checkpos= strend - len;
+ DEBUG_OPTIMISE_r(
+ PerlIO_printf(Perl_debug_log,
+ "%sChecking for float_real.%s\n",
+ PL_colors[4], PL_colors[5]));
+ if (checkpos + 1 < strbeg) {
+ /* can't match, even if we remove the trailing \n
+ * string is too short to match */
+ DEBUG_EXECUTE_r(
+ PerlIO_printf(Perl_debug_log,
+ "%sString shorter than required trailing substring, cannot match.%s\n",
+ PL_colors[4], PL_colors[5]));
+ goto phooey;
+ } else if (memEQ(checkpos + 1, little, len - 1)) {
+ /* can match, the end of the string matches without the
+ * "\n" */
+ last = checkpos + 1;
+ } else if (checkpos < strbeg) {
+ /* cant match, string is too short when the "\n" is
+ * included */
+ DEBUG_EXECUTE_r(
+ PerlIO_printf(Perl_debug_log,
+ "%sString does not contain required trailing substring, cannot match.%s\n",
+ PL_colors[4], PL_colors[5]));
+ goto phooey;
+ } else if (!multiline) {
+ /* non multiline match, so compare with the "\n" at the
+ * end of the string */
+ if (memEQ(checkpos, little, len)) {
+ last= checkpos;
+ } else {
+ DEBUG_EXECUTE_r(
+ PerlIO_printf(Perl_debug_log,
+ "%sString does not contain required trailing substring, cannot match.%s\n",
+ PL_colors[4], PL_colors[5]));
+ goto phooey;
+ }
+ } else {
+ /* multiline match, so we have to search for a place
+ * where the full string is located */
goto find_last;
- } else {
+ }
+ } else {
find_last:
if (len)
last = rninstr(s, strend, little, little + len);
else
last = strend; /* matching "$" */
- }
}
- if (last == NULL) {
+ if (!last) {
+ /* at one point this block contained a comment which was
+ * probably incorrect, which said that this was a "should not
+ * happen" case. Even if it was true when it was written I am
+ * pretty sure it is not anymore, so I have removed the comment
+ * and replaced it with this one. Yves */
DEBUG_EXECUTE_r(
PerlIO_printf(Perl_debug_log,
- "%sCan't trim the tail, match fails (should not happen)%s\n",
- PL_colors[4], PL_colors[5]));
- goto phooey; /* Should not happen! */
+ "String does not contain required substring, cannot match.\n"
+ ));
+ goto phooey;
}
dontbother = strend - last + prog->float_min_offset;
}
@@ -2424,10 +2584,17 @@
goto phooey;
got_it:
+ DEBUG_BUFFERS_r(
+ if (swap)
+ PerlIO_printf(Perl_debug_log,
+ "rex=0x%"UVxf" freeing offs: 0x%"UVxf"\n",
+ PTR2UV(prog),
+ PTR2UV(swap)
+ );
+ );
Safefree(swap);
- RX_MATCH_TAINTED_set(rx, PL_reg_flags & RF_tainted);
- if (PL_reg_eval_set)
+ if (PL_reg_state.re_state_eval_setup_done)
restore_pos(aTHX_ prog);
if (RXp_PAREN_NAMES(prog))
(void)hv_iterinit(RXp_PAREN_NAMES(prog));
@@ -2434,31 +2601,117 @@
/* make sure $`, $&, $', and $digit will work later */
if ( !(flags & REXEC_NOT_FIRST) ) {
- RX_MATCH_COPY_FREE(rx);
if (flags & REXEC_COPY_STR) {
- const I32 i = PL_regeol - startpos + (stringarg - strbeg);
-#ifdef PERL_OLD_COPY_ON_WRITE
- if ((SvIsCOW(sv)
- || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) {
+#ifdef PERL_ANY_COW
+ if (SvCANCOW(sv)) {
if (DEBUG_C_TEST) {
PerlIO_printf(Perl_debug_log,
"Copy on write: regexp capture, type %d\n",
(int) SvTYPE(sv));
}
+ RX_MATCH_COPY_FREE(rx);
prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
assert (SvPOKp(prog->saved_copy));
+ prog->sublen = PL_regeol - strbeg;
+ prog->suboffset = 0;
+ prog->subcoffset = 0;
} else
#endif
{
- RX_MATCH_COPIED_on(rx);
- s = savepvn(strbeg, i);
- prog->subbeg = s;
+ I32 min = 0;
+ I32 max = PL_regeol - strbeg;
+ I32 sublen;
+
+ if ( (flags & REXEC_COPY_SKIP_POST)
+ && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) /* //p */
+ && !(PL_sawampersand & SAWAMPERSAND_RIGHT)
+ ) { /* don't copy $' part of string */
+ U32 n = 0;
+ max = -1;
+ /* calculate the right-most part of the string covered
+ * by a capture. Due to look-ahead, this may be to
+ * the right of $&, so we have to scan all captures */
+ while (n <= prog->lastparen) {
+ if (prog->offs[n].end > max)
+ max = prog->offs[n].end;
+ n++;
+ }
+ if (max == -1)
+ max = (PL_sawampersand & SAWAMPERSAND_LEFT)
+ ? prog->offs[0].start
+ : 0;
+ assert(max >= 0 && max <= PL_regeol - strbeg);
+ }
+
+ if ( (flags & REXEC_COPY_SKIP_PRE)
+ && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) /* //p */
+ && !(PL_sawampersand & SAWAMPERSAND_LEFT)
+ ) { /* don't copy $` part of string */
+ U32 n = 0;
+ min = max;
+ /* calculate the left-most part of the string covered
+ * by a capture. Due to look-behind, this may be to
+ * the left of $&, so we have to scan all captures */
+ while (min && n <= prog->lastparen) {
+ if ( prog->offs[n].start != -1
+ && prog->offs[n].start < min)
+ {
+ min = prog->offs[n].start;
+ }
+ n++;
+ }
+ if ((PL_sawampersand & SAWAMPERSAND_RIGHT)
+ && min > prog->offs[0].end
+ )
+ min = prog->offs[0].end;
+
+ }
+
+ assert(min >= 0 && min <= max && min <= PL_regeol - strbeg);
+ sublen = max - min;
+
+ if (RX_MATCH_COPIED(rx)) {
+ if (sublen > prog->sublen)
+ prog->subbeg =
+ (char*)saferealloc(prog->subbeg, sublen+1);
+ }
+ else
+ prog->subbeg = (char*)safemalloc(sublen+1);
+ Copy(strbeg + min, prog->subbeg, sublen, char);
+ prog->subbeg[sublen] = '\0';
+ prog->suboffset = min;
+ prog->sublen = sublen;
+ RX_MATCH_COPIED_on(rx);
}
- prog->sublen = i;
+ prog->subcoffset = prog->suboffset;
+ if (prog->suboffset && utf8_target) {
+ /* Convert byte offset to chars.
+ * XXX ideally should only compute this if @-/@+
+ * has been seen, a la PL_sawampersand ??? */
+
+ /* If there's a direct correspondence between the
+ * string which we're matching and the original SV,
+ * then we can use the utf8 len cache associated with
+ * the SV. In particular, it means that under //g,
+ * sv_pos_b2u() will use the previously cached
+ * position to speed up working out the new length of
+ * subcoffset, rather than counting from the start of
+ * the string each time. This stops
+ * $x = "\x{100}" x 1E6; 1 while $x =~ /(.)/g;
+ * from going quadratic */
+ if (SvPOKp(sv) && SvPVX(sv) == strbeg)
+ sv_pos_b2u(sv, &(prog->subcoffset));
+ else
+ prog->subcoffset = utf8_length((U8*)strbeg,
+ (U8*)(strbeg+prog->suboffset));
+ }
}
else {
+ RX_MATCH_COPY_FREE(rx);
prog->subbeg = strbeg;
+ prog->suboffset = 0;
+ prog->subcoffset = 0;
prog->sublen = PL_regeol - strbeg; /* strend may have been modified */
}
}
@@ -2468,28 +2721,44 @@
phooey:
DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
PL_colors[4], PL_colors[5]));
- if (PL_reg_eval_set)
+ if (PL_reg_state.re_state_eval_setup_done)
restore_pos(aTHX_ prog);
if (swap) {
/* we failed :-( roll it back */
+ DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
+ "rex=0x%"UVxf" rolling back offs: freeing=0x%"UVxf" restoring=0x%"UVxf"\n",
+ PTR2UV(prog),
+ PTR2UV(prog->offs),
+ PTR2UV(swap)
+ ));
Safefree(prog->offs);
prog->offs = swap;
}
-
return 0;
}
+/* Set which rex is pointed to by PL_reg_state, handling ref counting.
+ * Do inc before dec, in case old and new rex are the same */
+#define SET_reg_curpm(Re2) \
+ if (PL_reg_state.re_state_eval_setup_done) { \
+ (void)ReREFCNT_inc(Re2); \
+ ReREFCNT_dec(PM_GETRE(PL_reg_curpm)); \
+ PM_SETRE((PL_reg_curpm), (Re2)); \
+ }
+
+
/*
- regtry - try match at specific point
*/
STATIC I32 /* 0 failure, 1 success */
-S_regtry(pTHX_ regmatch_info *reginfo, char **startpos)
+S_regtry(pTHX_ regmatch_info *reginfo, char **startposp)
{
dVAR;
CHECKPOINT lastcp;
REGEXP *const rx = reginfo->prog;
- regexp *const prog = (struct regexp *)SvANY(rx);
+ regexp *const prog = ReANY(rx);
+ I32 result;
RXi_GET_DECL(prog,progi);
GET_RE_DEBUG_FLAGS_DECL;
@@ -2497,22 +2766,12 @@
reginfo->cutpoint=NULL;
- if ((prog->extflags & RXf_EVAL_SEEN) && !PL_reg_eval_set) {
+ if ((prog->extflags & RXf_EVAL_SEEN)
+ && !PL_reg_state.re_state_eval_setup_done)
+ {
MAGIC *mg;
- PL_reg_eval_set = RS_init;
- DEBUG_EXECUTE_r(DEBUG_s(
- PerlIO_printf(Perl_debug_log, " setting stack tmpbase at %"IVdf"\n",
- (IV)(PL_stack_sp - PL_stack_base));
- ));
- SAVESTACK_CXPOS();
- cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
- /* Otherwise OP_NEXTSTATE will free whatever on stack now. */
- SAVETMPS;
- /* Apparently this is not needed, judging by wantarray. */
- /* SAVEI8(cxstack[cxstack_ix].blk_gimme);
- cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
-
+ PL_reg_state.re_state_eval_setup_done = TRUE;
if (reginfo->sv) {
/* Make $_ available to executed code. */
if (reginfo->sv != DEFSV) {
@@ -2548,16 +2807,7 @@
}
#endif
}
-#ifdef USE_ITHREADS
- /* It seems that non-ithreads works both with and without this code.
- So for efficiency reasons it seems best not to have the code
- compiled when it is not needed. */
- /* This is safe against NULLs: */
- ReREFCNT_dec(PM_GETRE(PL_reg_curpm));
- /* PM_reg_curpm owns a reference to this regexp. */
- (void)ReREFCNT_inc(rx);
-#endif
- PM_SETRE(PL_reg_curpm, rx);
+ SET_reg_curpm(rx);
PL_reg_oldcurpm = PL_curpm;
PL_curpm = PL_reg_curpm;
if (RXp_MATCH_COPIED(prog)) {
@@ -2566,7 +2816,9 @@
$` inside (?{}) could fail... */
PL_reg_oldsaved = prog->subbeg;
PL_reg_oldsavedlen = prog->sublen;
-#ifdef PERL_OLD_COPY_ON_WRITE
+ PL_reg_oldsavedoffset = prog->suboffset;
+ PL_reg_oldsavedcoffset = prog->suboffset;
+#ifdef PERL_ANY_COW
PL_nrs = prog->saved_copy;
#endif
RXp_MATCH_COPIED_off(prog);
@@ -2574,32 +2826,24 @@
else
PL_reg_oldsaved = NULL;
prog->subbeg = PL_bostr;
+ prog->suboffset = 0;
+ prog->subcoffset = 0;
prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
}
- DEBUG_EXECUTE_r(PL_reg_starttry = *startpos);
- prog->offs[0].start = *startpos - PL_bostr;
- PL_reginput = *startpos;
- PL_reglastparen = &prog->lastparen;
- PL_reglastcloseparen = &prog->lastcloseparen;
+#ifdef DEBUGGING
+ PL_reg_starttry = *startposp;
+#endif
+ prog->offs[0].start = *startposp - PL_bostr;
prog->lastparen = 0;
prog->lastcloseparen = 0;
- PL_regsize = 0;
- PL_regoffs = prog->offs;
- if (PL_reg_start_tmpl <= prog->nparens) {
- PL_reg_start_tmpl = prog->nparens*3/2 + 3;
- if(PL_reg_start_tmp)
- Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
- else
- Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
- }
/* XXXX What this code is doing here?!!! There should be no need
- to do this again and again, PL_reglastparen should take care of
+ to do this again and again, prog->lastparen should take care of
this! --ilya*/
/* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
* Actually, the code in regcppop() (which Ilya may be meaning by
- * PL_reglastparen), is not needed at all by the test suite
+ * prog->lastparen), is not needed at all by the test suite
* (op/regexp, op/pat, op/split), but that code is needed otherwise
* this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
* Meanwhile, this code *is* needed for the
@@ -2608,9 +2852,9 @@
* --jhi updated by dapm */
#if 1
if (prog->nparens) {
- regexp_paren_pair *pp = PL_regoffs;
- register I32 i;
- for (i = prog->nparens; i > (I32)*PL_reglastparen; i--) {
+ regexp_paren_pair *pp = prog->offs;
+ I32 i;
+ for (i = prog->nparens; i > (I32)prog->lastparen; i--) {
++pp;
pp->start = -1;
pp->end = -1;
@@ -2618,12 +2862,13 @@
}
#endif
REGCP_SET(lastcp);
- if (regmatch(reginfo, progi->program + 1)) {
- PL_regoffs[0].end = PL_reginput - PL_bostr;
+ result = regmatch(reginfo, *startposp, progi->program + 1);
+ if (result != -1) {
+ prog->offs[0].end = result;
return 1;
}
if (reginfo->cutpoint)
- *startpos= reginfo->cutpoint;
+ *startposp= reginfo->cutpoint;
REGCP_UNWIND(lastcp);
return 0;
}
@@ -2649,6 +2894,8 @@
#define CHRTEST_UNINIT -1001 /* c1/c2 haven't been calculated yet */
#define CHRTEST_VOID -1000 /* the c1/c2 "next char" test should be skipped */
+#define CHRTEST_NOT_A_CP_1 -999
+#define CHRTEST_NOT_A_CP_2 -998
#define SLAB_FIRST(s) (&(s)->states[0])
#define SLAB_LAST(s) (&(s)->states[PERL_REGMATCH_SLAB_SLOTS-1])
@@ -2675,7 +2922,8 @@
/* push a new state then goto it */
-#define PUSH_STATE_GOTO(state, node) \
+#define PUSH_STATE_GOTO(state, node, input) \
+ pushinput = input; \
scan = node; \
st->resume_state = state; \
goto push_state;
@@ -2682,7 +2930,8 @@
/* push a new state with success backtracking, then goto it */
-#define PUSH_YES_STATE_GOTO(state, node) \
+#define PUSH_YES_STATE_GOTO(state, node, input) \
+ pushinput = input; \
scan = node; \
st->resume_state = state; \
goto push_yes_state;
@@ -2689,6 +2938,7 @@
+
/*
regmatch() - main matching routine
@@ -2754,7 +3004,7 @@
// push a yes backtrack state with a resume value of
// IFMATCH_A/IFMATCH_A_fail, then continue execution at the
// first node of A:
- PUSH_YES_STATE_GOTO(IFMATCH_A, A);
+ PUSH_YES_STATE_GOTO(IFMATCH_A, A, newinput);
// NOTREACHED
case IFMATCH_A: // we have successfully executed A; now continue with B
@@ -2791,8 +3041,8 @@
want to claim it, populate any ST.foo fields in it with values you wish to
save, then do one of
- PUSH_STATE_GOTO(resume_state, node);
- PUSH_YES_STATE_GOTO(resume_state, node);
+ PUSH_STATE_GOTO(resume_state, node, newinput);
+ PUSH_YES_STATE_GOTO(resume_state, node, newinput);
which sets that backtrack state's resume value to 'resume_state', pushes a
new free entry to the top of the backtrack stack, then goes to 'node'.
@@ -2955,8 +3205,8 @@
PERL_ARGS_ASSERT_REG_CHECK_NAMED_BUFF_MATCHED;
for ( n=0; n<SvIVX(sv_dat); n++ ) {
- if ((I32)*PL_reglastparen >= nums[n] &&
- PL_regoffs[nums[n]].end != -1)
+ if ((I32)rex->lastparen >= nums[n] &&
+ rex->offs[nums[n]].end != -1)
{
return nums[n];
}
@@ -2982,34 +3232,286 @@
Safefree(osl);
}
}
+static bool
+S_setup_EXACTISH_ST_c1_c2(pTHX_ const regnode * const text_node, int *c1p,
+ U8* c1_utf8, int *c2p, U8* c2_utf8, bool is_utf8_pat)
+{
+ /* This function determines if there are one or two characters that match
+ * the first character of the passed-in EXACTish node <text_node>, and if
+ * so, returns them in the passed-in pointers.
+ *
+ * If it determines that no possible character in the target string can
+ * match, it returns FALSE; otherwise TRUE. (The FALSE situation occurs if
+ * the first character in <text_node> requires UTF-8 to represent, and the
+ * target string isn't in UTF-8.)
+ *
+ * If there are more than two characters that could match the beginning of
+ * <text_node>, or if more context is required to determine a match or not,
+ * it sets both *<c1p> and *<c2p> to CHRTEST_VOID.
+ *
+ * The motiviation behind this function is to allow the caller to set up
+ * tight loops for matching. If <text_node> is of type EXACT, there is
+ * only one possible character that can match its first character, and so
+ * the situation is quite simple. But things get much more complicated if
+ * folding is involved. It may be that the first character of an EXACTFish
+ * node doesn't participate in any possible fold, e.g., punctuation, so it
+ * can be matched only by itself. The vast majority of characters that are
+ * in folds match just two things, their lower and upper-case equivalents.
+ * But not all are like that; some have multiple possible matches, or match
+ * sequences of more than one character. This function sorts all that out.
+ *
+ * Consider the patterns A*B or A*?B where A and B are arbitrary. In a
+ * loop of trying to match A*, we know we can't exit where the thing
+ * following it isn't a B. And something can't be a B unless it is the
+ * beginning of B. By putting a quick test for that beginning in a tight
+ * loop, we can rule out things that can't possibly be B without having to
+ * break out of the loop, thus avoiding work. Similarly, if A is a single
+ * character, we can make a tight loop matching A*, using the outputs of
+ * this function.
+ *
+ * If the target string to match isn't in UTF-8, and there aren't
+ * complications which require CHRTEST_VOID, *<c1p> and *<c2p> are set to
+ * the one or two possible octets (which are characters in this situation)
+ * that can match. In all cases, if there is only one character that can
+ * match, *<c1p> and *<c2p> will be identical.
+ *
+ * If the target string is in UTF-8, the buffers pointed to by <c1_utf8>
+ * and <c2_utf8> will contain the one or two UTF-8 sequences of bytes that
+ * can match the beginning of <text_node>. They should be declared with at
+ * least length UTF8_MAXBYTES+1. (If the target string isn't in UTF-8, it is
+ * undefined what these contain.) If one or both of the buffers are
+ * invariant under UTF-8, *<c1p>, and *<c2p> will also be set to the
+ * corresponding invariant. If variant, the corresponding *<c1p> and/or
+ * *<c2p> will be set to a negative number(s) that shouldn't match any code
+ * point (unless inappropriately coerced to unsigned). *<c1p> will equal
+ * *<c2p> if and only if <c1_utf8> and <c2_utf8> are the same. */
+ const bool utf8_target = PL_reg_match_utf8;
-#define SETREX(Re1,Re2) \
- if (PL_reg_eval_set) PM_SETRE((PL_reg_curpm), (Re2)); \
- Re1 = (Re2)
+ UV c1 = CHRTEST_NOT_A_CP_1;
+ UV c2 = CHRTEST_NOT_A_CP_2;
+ bool use_chrtest_void = FALSE;
-STATIC I32 /* 0 failure, 1 success */
-S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
+ /* Used when we have both utf8 input and utf8 output, to avoid converting
+ * to/from code points */
+ bool utf8_has_been_setup = FALSE;
+
+ dVAR;
+
+ U8 *pat = (U8*)STRING(text_node);
+
+ if (OP(text_node) == EXACT) {
+
+ /* In an exact node, only one thing can be matched, that first
+ * character. If both the pat and the target are UTF-8, we can just
+ * copy the input to the output, avoiding finding the code point of
+ * that character */
+ if (!is_utf8_pat) {
+ c2 = c1 = *pat;
+ }
+ else if (utf8_target) {
+ Copy(pat, c1_utf8, UTF8SKIP(pat), U8);
+ Copy(pat, c2_utf8, UTF8SKIP(pat), U8);
+ utf8_has_been_setup = TRUE;
+ }
+ else {
+ c2 = c1 = valid_utf8_to_uvchr(pat, NULL);
+ }
+ }
+ else /* an EXACTFish node */
+ if ((is_utf8_pat
+ && is_MULTI_CHAR_FOLD_utf8_safe(pat,
+ pat + STR_LEN(text_node)))
+ || (!is_utf8_pat
+ && is_MULTI_CHAR_FOLD_latin1_safe(pat,
+ pat + STR_LEN(text_node))))
+ {
+ /* Multi-character folds require more context to sort out. Also
+ * PL_utf8_foldclosures used below doesn't handle them, so have to be
+ * handled outside this routine */
+ use_chrtest_void = TRUE;
+ }
+ else { /* an EXACTFish node which doesn't begin with a multi-char fold */
+ c1 = is_utf8_pat ? valid_utf8_to_uvchr(pat, NULL) : *pat;
+ if (c1 > 256) {
+ /* Load the folds hash, if not already done */
+ SV** listp;
+ if (! PL_utf8_foldclosures) {
+ if (! PL_utf8_tofold) {
+ U8 dummy[UTF8_MAXBYTES+1];
+
+ /* Force loading this by folding an above-Latin1 char */
+ to_utf8_fold((U8*) HYPHEN_UTF8, dummy, NULL);
+ assert(PL_utf8_tofold); /* Verify that worked */
+ }
+ PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
+ }
+
+ /* The fold closures data structure is a hash with the keys being
+ * the UTF-8 of every character that is folded to, like 'k', and
+ * the values each an array of all code points that fold to its
+ * key. e.g. [ 'k', 'K', KELVIN_SIGN ]. Multi-character folds are
+ * not included */
+ if ((! (listp = hv_fetch(PL_utf8_foldclosures,
+ (char *) pat,
+ UTF8SKIP(pat),
+ FALSE))))
+ {
+ /* Not found in the hash, therefore there are no folds
+ * containing it, so there is only a single character that
+ * could match */
+ c2 = c1;
+ }
+ else { /* Does participate in folds */
+ AV* list = (AV*) *listp;
+ if (av_len(list) != 1) {
+
+ /* If there aren't exactly two folds to this, it is outside
+ * the scope of this function */
+ use_chrtest_void = TRUE;
+ }
+ else { /* There are two. Get them */
+ SV** c_p = av_fetch(list, 0, FALSE);
+ if (c_p == NULL) {
+ Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
+ }
+ c1 = SvUV(*c_p);
+
+ c_p = av_fetch(list, 1, FALSE);
+ if (c_p == NULL) {
+ Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
+ }
+ c2 = SvUV(*c_p);
+
+ /* Folds that cross the 255/256 boundary are forbidden if
+ * EXACTFL, or EXACTFA and one is ASCIII. Since the
+ * pattern character is above 256, and its only other match
+ * is below 256, the only legal match will be to itself.
+ * We have thrown away the original, so have to compute
+ * which is the one above 255 */
+ if ((c1 < 256) != (c2 < 256)) {
+ if (OP(text_node) == EXACTFL
+ || (OP(text_node) == EXACTFA
+ && (isASCII(c1) || isASCII(c2))))
+ {
+ if (c1 < 256) {
+ c1 = c2;
+ }
+ else {
+ c2 = c1;
+ }
+ }
+ }
+ }
+ }
+ }
+ else /* Here, c1 is < 255 */
+ if (utf8_target
+ && HAS_NONLATIN1_FOLD_CLOSURE(c1)
+ && OP(text_node) != EXACTFL
+ && (OP(text_node) != EXACTFA || ! isASCII(c1)))
+ {
+ /* Here, there could be something above Latin1 in the target which
+ * folds to this character in the pattern. All such cases except
+ * LATIN SMALL LETTER Y WITH DIAERESIS have more than two characters
+ * involved in their folds, so are outside the scope of this
+ * function */
+ if (UNLIKELY(c1 == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
+ c2 = LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS;
+ }
+ else {
+ use_chrtest_void = TRUE;
+ }
+ }
+ else { /* Here nothing above Latin1 can fold to the pattern character */
+ switch (OP(text_node)) {
+
+ case EXACTFL: /* /l rules */
+ c2 = PL_fold_locale[c1];
+ break;
+
+ case EXACTF:
+ if (! utf8_target) { /* /d rules */
+ c2 = PL_fold[c1];
+ break;
+ }
+ /* FALLTHROUGH */
+ /* /u rules for all these. This happens to work for
+ * EXACTFA as nothing in Latin1 folds to ASCII */
+ case EXACTFA:
+ case EXACTFU_TRICKYFOLD:
+ case EXACTFU_SS:
+ case EXACTFU:
+ c2 = PL_fold_latin1[c1];
+ break;
+
+ default:
+ Perl_croak(aTHX_ "panic: Unexpected op %u", OP(text_node));
+ assert(0); /* NOTREACHED */
+ }
+ }
+ }
+
+ /* Here have figured things out. Set up the returns */
+ if (use_chrtest_void) {
+ *c2p = *c1p = CHRTEST_VOID;
+ }
+ else if (utf8_target) {
+ if (! utf8_has_been_setup) { /* Don't have the utf8; must get it */
+ uvchr_to_utf8(c1_utf8, c1);
+ uvchr_to_utf8(c2_utf8, c2);
+ }
+
+ /* Invariants are stored in both the utf8 and byte outputs; Use
+ * negative numbers otherwise for the byte ones. Make sure that the
+ * byte ones are the same iff the utf8 ones are the same */
+ *c1p = (UTF8_IS_INVARIANT(*c1_utf8)) ? *c1_utf8 : CHRTEST_NOT_A_CP_1;
+ *c2p = (UTF8_IS_INVARIANT(*c2_utf8))
+ ? *c2_utf8
+ : (c1 == c2)
+ ? CHRTEST_NOT_A_CP_1
+ : CHRTEST_NOT_A_CP_2;
+ }
+ else if (c1 > 255) {
+ if (c2 > 255) { /* both possibilities are above what a non-utf8 string
+ can represent */
+ return FALSE;
+ }
+
+ *c1p = *c2p = c2; /* c2 is the only representable value */
+ }
+ else { /* c1 is representable; see about c2 */
+ *c1p = c1;
+ *c2p = (c2 < 256) ? c2 : c1;
+ }
+
+ return TRUE;
+}
+
+/* returns -1 on failure, $+[0] on success */
+STATIC I32
+S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
{
#if PERL_VERSION < 9 && !defined(PERL_CORE)
dMY_CXT;
#endif
dVAR;
- register const bool utf8_target = PL_reg_match_utf8;
+ const bool utf8_target = PL_reg_match_utf8;
const U32 uniflags = UTF8_ALLOW_DEFAULT;
REGEXP *rex_sv = reginfo->prog;
- regexp *rex = (struct regexp *)SvANY(rex_sv);
+ regexp *rex = ReANY(rex_sv);
RXi_GET_DECL(rex,rexi);
I32 oldsave;
/* the current state. This is a cached copy of PL_regmatch_state */
- register regmatch_state *st;
+ regmatch_state *st;
/* cache heavy used fields of st in registers */
- register regnode *scan;
- register regnode *next;
- register U32 n = 0; /* general value; init to avoid compiler warning */
- register I32 ln = 0; /* len or last; init to avoid compiler warning */
- register char *locinput = PL_reginput;
- register I32 nextchr; /* is always set to UCHARAT(locinput) */
+ regnode *scan;
+ regnode *next;
+ U32 n = 0; /* general value; init to avoid compiler warning */
+ I32 ln = 0; /* len or last; init to avoid compiler warning */
+ char *locinput = startpos;
+ char *pushinput; /* where to continue after a PUSH */
+ I32 nextchr; /* is always set to UCHARAT(locinput) */
bool result = 0; /* return value of S_regmatch */
int depth = 0; /* depth of backtrack stack */
@@ -3027,7 +3529,7 @@
U32 state_num;
bool no_final = 0; /* prevent failure from backtracking? */
bool do_cutgroup = 0; /* no_final only until next branch/trie entry */
- char *startpoint = PL_reginput;
+ char *startpoint = locinput;
SV *popmark = NULL; /* are we looking for a mark? */
SV *sv_commit = NULL; /* last mark name seen in failure */
SV *sv_yes_mark = NULL; /* last mark name we have seen
@@ -3049,10 +3551,29 @@
false: plain (?=foo)
true: used as a condition: (?(?=foo))
*/
+ PAD* last_pad = NULL;
+ dMULTICALL;
+ I32 gimme = G_SCALAR;
+ CV *caller_cv = NULL; /* who called us */
+ CV *last_pushed_cv = NULL; /* most recently called (?{}) CV */
+ CHECKPOINT runops_cp; /* savestack position before executing EVAL */
+ U32 maxopenparen = 0; /* max '(' index seen so far */
+ int to_complement; /* Invert the result? */
+ _char_class_number classnum;
+ bool is_utf8_pat = reginfo->is_utf8_pat;
+
#ifdef DEBUGGING
GET_RE_DEBUG_FLAGS_DECL;
#endif
+ /* shut up 'may be used uninitialized' compiler warnings for dMULTICALL */
+ multicall_oldcatch = 0;
+ multicall_cv = NULL;
+ cx = NULL;
+ PERL_UNUSED_VAR(multicall_cop);
+ PERL_UNUSED_VAR(newsp);
+
+
PERL_ARGS_ASSERT_REGMATCH;
DEBUG_OPTIMISE_r( DEBUG_EXECUTE_r({
@@ -3077,7 +3598,7 @@
st = PL_regmatch_state = S_push_slab(aTHX);
/* Note that nextchr is a byte even in UTF */
- nextchr = UCHARAT(locinput);
+ SET_nextchr;
scan = prog;
while (scan != NULL) {
@@ -3101,13 +3622,13 @@
state_num = OP(scan);
reenter_switch:
+ to_complement = 0;
- assert(PL_reglastparen == &rex->lastparen);
- assert(PL_reglastcloseparen == &rex->lastcloseparen);
- assert(PL_regoffs == rex->offs);
+ SET_nextchr;
+ assert(nextchr < 256 && (nextchr >= 0 || nextchr == NEXTCHR_EOS));
switch (state_num) {
- case BOL:
+ case BOL: /* /^../ */
if (locinput == PL_bostr)
{
/* reginfo->till = reginfo->bol; */
@@ -3114,100 +3635,92 @@
break;
}
sayNO;
- case MBOL:
+
+ case MBOL: /* /^../m */
if (locinput == PL_bostr ||
- ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
+ (!NEXTCHR_IS_EOS && locinput[-1] == '\n'))
{
break;
}
sayNO;
- case SBOL:
+
+ case SBOL: /* /^../s */
if (locinput == PL_bostr)
break;
sayNO;
- case GPOS:
+
+ case GPOS: /* \G */
if (locinput == reginfo->ganch)
break;
sayNO;
- case KEEPS:
+ case KEEPS: /* \K */
/* update the startpoint */
- st->u.keeper.val = PL_regoffs[0].start;
- PL_reginput = locinput;
- PL_regoffs[0].start = locinput - PL_bostr;
- PUSH_STATE_GOTO(KEEPS_next, next);
- /*NOT-REACHED*/
+ st->u.keeper.val = rex->offs[0].start;
+ rex->offs[0].start = locinput - PL_bostr;
+ PUSH_STATE_GOTO(KEEPS_next, next, locinput);
+ assert(0); /*NOTREACHED*/
case KEEPS_next_fail:
/* rollback the start point change */
- PL_regoffs[0].start = st->u.keeper.val;
+ rex->offs[0].start = st->u.keeper.val;
sayNO_SILENT;
- /*NOT-REACHED*/
- case EOL:
+ assert(0); /*NOTREACHED*/
+
+ case EOL: /* /..$/ */
goto seol;
- case MEOL:
- if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
+
+ case MEOL: /* /..$/m */
+ if (!NEXTCHR_IS_EOS && nextchr != '\n')
sayNO;
break;
- case SEOL:
+
+ case SEOL: /* /..$/s */
seol:
- if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
+ if (!NEXTCHR_IS_EOS && nextchr != '\n')
sayNO;
if (PL_regeol - locinput > 1)
sayNO;
break;
- case EOS:
- if (PL_regeol != locinput)
+
+ case EOS: /* \z */
+ if (!NEXTCHR_IS_EOS)
sayNO;
break;
- case SANY:
- if (!nextchr && locinput >= PL_regeol)
+
+ case SANY: /* /./s */
+ if (NEXTCHR_IS_EOS)
sayNO;
- if (utf8_target) {
- locinput += PL_utf8skip[nextchr];
- if (locinput > PL_regeol)
- sayNO;
- nextchr = UCHARAT(locinput);
- }
- else
- nextchr = UCHARAT(++locinput);
- break;
- case CANY:
- if (!nextchr && locinput >= PL_regeol)
+ goto increment_locinput;
+
+ case CANY: /* \C */
+ if (NEXTCHR_IS_EOS)
sayNO;
- nextchr = UCHARAT(++locinput);
+ locinput++;
break;
- case REG_ANY:
- if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
+
+ case REG_ANY: /* /./ */
+ if ((NEXTCHR_IS_EOS) || nextchr == '\n')
sayNO;
- if (utf8_target) {
- locinput += PL_utf8skip[nextchr];
- if (locinput > PL_regeol)
- sayNO;
- nextchr = UCHARAT(locinput);
- }
- else
- nextchr = UCHARAT(++locinput);
- break;
+ goto increment_locinput;
+
#undef ST
#define ST st->u.trie
- case TRIEC:
+ case TRIEC: /* (ab|cd) with known charclass */
/* In this case the charclass data is available inline so
we can fail fast without a lot of extra overhead.
*/
- if (scan->flags == EXACT || !utf8_target) {
- if(!ANYOF_BITMAP_TEST(scan, *locinput)) {
- DEBUG_EXECUTE_r(
- PerlIO_printf(Perl_debug_log,
- "%*s %sfailed to match trie start class...%s\n",
- REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
- );
- sayNO_SILENT;
- /* NOTREACHED */
- }
+ if(!NEXTCHR_IS_EOS && !ANYOF_BITMAP_TEST(scan, nextchr)) {
+ DEBUG_EXECUTE_r(
+ PerlIO_printf(Perl_debug_log,
+ "%*s %sfailed to match trie start class...%s\n",
+ REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
+ );
+ sayNO_SILENT;
+ assert(0); /* NOTREACHED */
}
/* FALL THROUGH */
- case TRIE:
+ case TRIE: /* (ab|cd) */
/* the basic plan of execution of the trie is:
* At the beginning, run though all the states, and
* find the longest-matching word. Also remember the position
@@ -3216,7 +3729,7 @@
* ab|a|x|abcd|abc
* when matched against the string "abcde", will generate
* accept states for all words except 3, with the longest
- * matching word being 4, and the shortest being 1 (with
+ * matching word being 4, and the shortest being 2 (with
* the position being after char 1 of the string).
*
* Then for each matching word, in word order (i.e. 1,2,4,5),
@@ -3262,9 +3775,9 @@
HV * widecharmap = MUTABLE_HV(rexi->data->data[ ARG( scan ) + 1 ]);
U32 state = trie->startstate;
- if (trie->bitmap && trie_type != trie_utf8_fold &&
- !TRIE_BITMAP_TEST(trie,*locinput)
- ) {
+ if ( trie->bitmap
+ && (NEXTCHR_IS_EOS || !TRIE_BITMAP_TEST(trie, nextchr)))
+ {
if (trie->states[ state ].wordnum) {
DEBUG_EXECUTE_r(
PerlIO_printf(Perl_debug_log,
@@ -3293,7 +3806,6 @@
U32 charcount = 0; /* how many input chars we have matched */
U32 accepted = 0; /* have we seen any accepting states? */
- ST.B = next;
ST.jump = trie->jump;
ST.me = scan;
ST.firstpos = NULL;
@@ -3338,7 +3850,7 @@
});
/* read a char and goto next state */
- if ( base ) {
+ if ( base && (foldlen || uc < (U8*)PL_regeol)) {
I32 offset;
REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
uscan, len, uvc, charid, foldlen,
@@ -3392,14 +3904,14 @@
);
goto trie_first_try; /* jump into the fail handler */
}}
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
case TRIE_next_fail: /* we failed - try next alternative */
+ {
+ U8 *uc;
if ( ST.jump) {
REGCP_UNWIND(ST.cp);
- for (n = *PL_reglastparen; n > ST.lastparen; n--)
- PL_regoffs[n].end = -1;
- *PL_reglastparen = n;
+ UNWIND_PAREN(ST.lastparen, ST.lastcloseparen);
}
if (!--ST.accepted) {
DEBUG_EXECUTE_r({
@@ -3414,10 +3926,10 @@
{
/* Find next-highest word to process. Note that this code
* is O(N^2) per trie run (O(N) per branch), so keep tight */
- register U16 min = 0;
- register U16 word;
- register U16 const nextword = ST.nextword;
- register reg_trie_wordinfo * const wordinfo
+ U16 min = 0;
+ U16 word;
+ U16 const nextword = ST.nextword;
+ reg_trie_wordinfo * const wordinfo
= ((reg_trie_data*)rexi->data->data[ARG(ST.me)])->wordinfo;
for (word=ST.topword; word; word=wordinfo[word].prev) {
if (word > nextword && (!min || word < min))
@@ -3433,7 +3945,8 @@
}
if ( ST.jump) {
- ST.lastparen = *PL_reglastparen;
+ ST.lastparen = rex->lastparen;
+ ST.lastcloseparen = rex->lastcloseparen;
REGCP_SET(ST.cp);
}
@@ -3440,7 +3953,6 @@
/* find start char of end of current word */
{
U32 chars; /* how many chars to skip */
- U8 *uc = ST.firstpos;
reg_trie_data * const trie
= (reg_trie_data*)rexi->data->data[ARG(ST.me)];
@@ -3448,6 +3960,7 @@
>= ST.firstchars);
chars = (trie->wordinfo[ST.nextword].len - trie->prefixlen)
- ST.firstchars;
+ uc = ST.firstpos;
if (ST.longfold) {
/* the hard option - fold each char in turn and find
@@ -3487,12 +4000,11 @@
else
uc += chars;
}
- PL_reginput = (char *)uc;
}
- scan = (ST.jump && ST.jump[ST.nextword])
- ? ST.me + ST.jump[ST.nextword]
- : ST.B;
+ scan = ST.me + ((ST.jump && ST.jump[ST.nextword])
+ ? ST.jump[ST.nextword]
+ : NEXT_OFF(ST.me));
DEBUG_EXECUTE_r({
PerlIO_printf( Perl_debug_log,
@@ -3505,8 +4017,8 @@
});
if (ST.accepted > 1 || has_cutgroup) {
- PUSH_STATE_GOTO(TRIE_next, scan);
- /* NOTREACHED */
+ PUSH_STATE_GOTO(TRIE_next, scan, (char*)uc);
+ assert(0); /* NOTREACHED */
}
/* only one choice left - just continue */
DEBUG_EXECUTE_r({
@@ -3528,89 +4040,114 @@
PL_colors[5] );
});
- locinput = PL_reginput;
- nextchr = UCHARAT(locinput);
+ locinput = (char*)uc;
continue; /* execute rest of RE */
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
+ }
#undef ST
- case EXACT: {
+ case EXACT: { /* /abc/ */
char *s = STRING(scan);
ln = STR_LEN(scan);
- if (utf8_target != UTF_PATTERN) {
+ if (utf8_target != is_utf8_pat) {
/* The target and the pattern have differing utf8ness. */
char *l = locinput;
const char * const e = s + ln;
if (utf8_target) {
- /* The target is utf8, the pattern is not utf8. */
+ /* The target is utf8, the pattern is not utf8.
+ * Above-Latin1 code points can't match the pattern;
+ * invariants match exactly, and the other Latin1 ones need
+ * to be downgraded to a single byte in order to do the
+ * comparison. (If we could be confident that the target
+ * is not malformed, this could be refactored to have fewer
+ * tests by just assuming that if the first bytes match, it
+ * is an invariant, but there are tests in the test suite
+ * dealing with (??{...}) which violate this) */
while (s < e) {
- STRLEN ulen;
- if (l >= PL_regeol)
- sayNO;
- if (NATIVE_TO_UNI(*(U8*)s) !=
- utf8n_to_uvuni((U8*)l, UTF8_MAXBYTES, &ulen,
- uniflags))
- sayNO;
- l += ulen;
- s ++;
+ if (l >= PL_regeol || UTF8_IS_ABOVE_LATIN1(* (U8*) l)) {
+ sayNO;
+ }
+ if (UTF8_IS_INVARIANT(*(U8*)l)) {
+ if (*l != *s) {
+ sayNO;
+ }
+ l++;
+ }
+ else {
+ if (TWO_BYTE_UTF8_TO_UNI(*l, *(l+1)) != * (U8*) s) {
+ sayNO;
+ }
+ l += 2;
+ }
+ s++;
}
}
else {
/* The target is not utf8, the pattern is utf8. */
while (s < e) {
- STRLEN ulen;
- if (l >= PL_regeol)
- sayNO;
- if (NATIVE_TO_UNI(*((U8*)l)) !=
- utf8n_to_uvuni((U8*)s, UTF8_MAXBYTES, &ulen,
- uniflags))
- sayNO;
- s += ulen;
- l ++;
+ if (l >= PL_regeol || UTF8_IS_ABOVE_LATIN1(* (U8*) s))
+ {
+ sayNO;
+ }
+ if (UTF8_IS_INVARIANT(*(U8*)s)) {
+ if (*s != *l) {
+ sayNO;
+ }
+ s++;
+ }
+ else {
+ if (TWO_BYTE_UTF8_TO_UNI(*s, *(s+1)) != * (U8*) l) {
+ sayNO;
+ }
+ s += 2;
+ }
+ l++;
}
}
locinput = l;
- nextchr = UCHARAT(locinput);
- break;
}
- /* The target and the pattern have the same utf8ness. */
- /* Inline the first character, for speed. */
- if (UCHARAT(s) != nextchr)
- sayNO;
- if (PL_regeol - locinput < ln)
- sayNO;
- if (ln > 1 && memNE(s, locinput, ln))
- sayNO;
- locinput += ln;
- nextchr = UCHARAT(locinput);
+ else {
+ /* The target and the pattern have the same utf8ness. */
+ /* Inline the first character, for speed. */
+ if (PL_regeol - locinput < ln
+ || UCHARAT(s) != nextchr
+ || (ln > 1 && memNE(s, locinput, ln)))
+ {
+ sayNO;
+ }
+ locinput += ln;
+ }
break;
}
- case EXACTFL: {
+
+ case EXACTFL: { /* /abc/il */
re_fold_t folder;
const U8 * fold_array;
const char * s;
U32 fold_utf8_flags;
- PL_reg_flags |= RF_tainted;
- folder = foldEQ_locale;
- fold_array = PL_fold_locale;
+ RX_MATCH_TAINTED_on(reginfo->prog);
+ folder = foldEQ_locale;
+ fold_array = PL_fold_locale;
fold_utf8_flags = FOLDEQ_UTF8_LOCALE;
goto do_exactf;
- case EXACTFU:
+ case EXACTFU_SS: /* /\x{df}/iu */
+ case EXACTFU_TRICKYFOLD: /* /\x{390}/iu */
+ case EXACTFU: /* /abc/iu */
folder = foldEQ_latin1;
fold_array = PL_fold_latin1;
- fold_utf8_flags = 0;
+ fold_utf8_flags = is_utf8_pat ? FOLDEQ_S1_ALREADY_FOLDED : 0;
goto do_exactf;
- case EXACTFA:
+ case EXACTFA: /* /abc/iaa */
folder = foldEQ_latin1;
fold_array = PL_fold_latin1;
fold_utf8_flags = FOLDEQ_UTF8_NOMIX_ASCII;
goto do_exactf;
- case EXACTF:
+ case EXACTF: /* /abc/i */
folder = foldEQ;
fold_array = PL_fold;
fold_utf8_flags = 0;
@@ -3619,24 +4156,25 @@
s = STRING(scan);
ln = STR_LEN(scan);
- if (utf8_target || UTF_PATTERN) {
- /* Either target or the pattern are utf8. */
+ if (utf8_target || is_utf8_pat || state_num == EXACTFU_SS) {
+ /* Either target or the pattern are utf8, or has the issue where
+ * the fold lengths may differ. */
const char * const l = locinput;
char *e = PL_regeol;
- if (! foldEQ_utf8_flags(s, 0, ln, cBOOL(UTF_PATTERN),
- l, &e, 0, utf8_target, fold_utf8_flags))
+ if (! foldEQ_utf8_flags(s, 0, ln, is_utf8_pat,
+ l, &e, 0, utf8_target, fold_utf8_flags))
{
sayNO;
}
locinput = e;
- nextchr = UCHARAT(locinput);
break;
}
/* Neither the target nor the pattern are utf8 */
- if (UCHARAT(s) != nextchr &&
- UCHARAT(s) != fold_array[nextchr])
+ if (UCHARAT(s) != nextchr
+ && !NEXTCHR_IS_EOS
+ && UCHARAT(s) != fold_array[nextchr])
{
sayNO;
}
@@ -3645,7 +4183,6 @@
if (ln > 1 && ! folder(s, locinput, ln))
sayNO;
locinput += ln;
- nextchr = UCHARAT(locinput);
break;
}
@@ -3652,16 +4189,16 @@
/* XXX Could improve efficiency by separating these all out using a
* macro or in-line function. At that point regcomp.c would no longer
* have to set the FLAGS fields of these */
- case BOUNDL:
- case NBOUNDL:
- PL_reg_flags |= RF_tainted;
+ case BOUNDL: /* /\b/l */
+ case NBOUNDL: /* /\B/l */
+ RX_MATCH_TAINTED_on(reginfo->prog);
/* FALL THROUGH */
- case BOUND:
- case BOUNDU:
- case BOUNDA:
- case NBOUND:
- case NBOUNDU:
- case NBOUNDA:
+ case BOUND: /* /\b/ */
+ case BOUNDU: /* /\b/u */
+ case BOUNDA: /* /\b/a */
+ case NBOUND: /* /\B/ */
+ case NBOUNDU: /* /\B/u */
+ case NBOUNDA: /* /\B/a */
/* was last char in word? */
if (utf8_target
&& FLAGS(scan) != REGEX_ASCII_RESTRICTED_CHARSET
@@ -3675,13 +4212,18 @@
ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags);
}
if (FLAGS(scan) != REGEX_LOCALE_CHARSET) {
- ln = isALNUM_uni(ln);
- LOAD_UTF8_CHARCLASS_ALNUM();
- n = swash_fetch(PL_utf8_alnum, (U8*)locinput, utf8_target);
+ ln = isWORDCHAR_uni(ln);
+ if (NEXTCHR_IS_EOS)
+ n = 0;
+ else {
+ LOAD_UTF8_CHARCLASS_ALNUM();
+ n = swash_fetch(PL_utf8_swash_ptrs[_CC_WORDCHAR], (U8*)locinput,
+ utf8_target);
+ }
}
else {
- ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(ln));
- n = isALNUM_LC_utf8((U8*)locinput);
+ ln = isWORDCHAR_LC_uvchr(UNI_TO_NATIVE(ln));
+ n = NEXTCHR_IS_EOS ? 0 : isWORDCHAR_LC_utf8((U8*)locinput);
}
}
else {
@@ -3702,20 +4244,20 @@
switch (FLAGS(scan)) {
case REGEX_UNICODE_CHARSET:
ln = isWORDCHAR_L1(ln);
- n = isWORDCHAR_L1(nextchr);
+ n = NEXTCHR_IS_EOS ? 0 : isWORDCHAR_L1(nextchr);
break;
case REGEX_LOCALE_CHARSET:
- ln = isALNUM_LC(ln);
- n = isALNUM_LC(nextchr);
+ ln = isWORDCHAR_LC(ln);
+ n = NEXTCHR_IS_EOS ? 0 : isWORDCHAR_LC(nextchr);
break;
case REGEX_DEPENDS_CHARSET:
- ln = isALNUM(ln);
- n = isALNUM(nextchr);
+ ln = isWORDCHAR(ln);
+ n = NEXTCHR_IS_EOS ? 0 : isWORDCHAR(nextchr);
break;
case REGEX_ASCII_RESTRICTED_CHARSET:
case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
ln = isWORDCHAR_A(ln);
- n = isWORDCHAR_A(nextchr);
+ n = NEXTCHR_IS_EOS ? 0 : isWORDCHAR_A(nextchr);
break;
default:
Perl_croak(aTHX_ "panic: Unexpected FLAGS %u in op %u", FLAGS(scan), OP(scan));
@@ -3727,106 +4269,237 @@
if (((!ln) == (!n)) == (OP(scan) < NBOUND))
sayNO;
break;
- case ANYOFV:
- case ANYOF:
- if (utf8_target || state_num == ANYOFV) {
- STRLEN inclasslen = PL_regeol - locinput;
- if (locinput >= PL_regeol)
- sayNO;
- if (!reginclass(rex, scan, (U8*)locinput, &inclasslen, utf8_target))
+ case ANYOF: /* /[abc]/ */
+ case ANYOF_WARN_SUPER:
+ if (NEXTCHR_IS_EOS)
+ sayNO;
+ if (utf8_target) {
+ if (!reginclass(rex, scan, (U8*)locinput, utf8_target))
sayNO;
- locinput += inclasslen;
- nextchr = UCHARAT(locinput);
- break;
+ locinput += UTF8SKIP(locinput);
}
else {
- if (nextchr < 0)
- nextchr = UCHARAT(locinput);
- if (!nextchr && locinput >= PL_regeol)
- sayNO;
if (!REGINCLASS(rex, scan, (U8*)locinput))
sayNO;
- nextchr = UCHARAT(++locinput);
- break;
+ locinput++;
}
break;
- /* Special char classes - The defines start on line 129 or so */
- CCC_TRY_U(ALNUM, NALNUM, isWORDCHAR,
- ALNUML, NALNUML, isALNUM_LC, isALNUM_LC_utf8,
- ALNUMU, NALNUMU, isWORDCHAR_L1,
- ALNUMA, NALNUMA, isWORDCHAR_A,
- alnum, "a");
- CCC_TRY_U(SPACE, NSPACE, isSPACE,
- SPACEL, NSPACEL, isSPACE_LC, isSPACE_LC_utf8,
- SPACEU, NSPACEU, isSPACE_L1,
- SPACEA, NSPACEA, isSPACE_A,
- space, " ");
+ /* The argument (FLAGS) to all the POSIX node types is the class number
+ * */
- CCC_TRY(DIGIT, NDIGIT, isDIGIT,
- DIGITL, NDIGITL, isDIGIT_LC, isDIGIT_LC_utf8,
- DIGITA, NDIGITA, isDIGIT_A,
- digit, "0");
+ case NPOSIXL: /* \W or [:^punct:] etc. under /l */
+ to_complement = 1;
+ /* FALLTHROUGH */
+ case POSIXL: /* \w or [:punct:] etc. under /l */
+ if (NEXTCHR_IS_EOS)
+ sayNO;
+
+ /* The locale hasn't influenced the outcome before this, so defer
+ * tainting until now */
+ RX_MATCH_TAINTED_on(reginfo->prog);
+
+ /* Use isFOO_lc() for characters within Latin1. (Note that
+ * UTF8_IS_INVARIANT works even on non-UTF-8 strings, or else
+ * wouldn't be invariant) */
+ if (UTF8_IS_INVARIANT(nextchr) || ! utf8_target) {
+ if (! (to_complement ^ cBOOL(isFOO_lc(FLAGS(scan), (U8) nextchr)))) {
+ sayNO;
+ }
+ }
+ else if (UTF8_IS_DOWNGRADEABLE_START(nextchr)) {
+ if (! (to_complement ^ cBOOL(isFOO_lc(FLAGS(scan),
+ (U8) TWO_BYTE_UTF8_TO_UNI(nextchr,
+ *(locinput + 1))))))
+ {
+ sayNO;
+ }
+ }
+ else { /* Here, must be an above Latin-1 code point */
+ goto utf8_posix_not_eos;
+ }
+
+ /* Here, must be utf8 */
+ locinput += UTF8SKIP(locinput);
+ break;
+
+ case NPOSIXD: /* \W or [:^punct:] etc. under /d */
+ to_complement = 1;
+ /* FALLTHROUGH */
+
+ case POSIXD: /* \w or [:punct:] etc. under /d */
+ if (utf8_target) {
+ goto utf8_posix;
+ }
+ goto posixa;
+
+ case NPOSIXA: /* \W or [:^punct:] etc. under /a */
+
+ if (NEXTCHR_IS_EOS) {
+ sayNO;
+ }
+
+ /* All UTF-8 variants match */
+ if (! UTF8_IS_INVARIANT(nextchr)) {
+ goto increment_locinput;
+ }
+
+ to_complement = 1;
+ /* FALLTHROUGH */
+
+ case POSIXA: /* \w or [:punct:] etc. under /a */
+
+ posixa:
+ /* We get here through POSIXD, NPOSIXD, and NPOSIXA when not in
+ * UTF-8, and also from NPOSIXA even in UTF-8 when the current
+ * character is a single byte */
+
+ if (NEXTCHR_IS_EOS
+ || ! (to_complement ^ cBOOL(_generic_isCC_A(nextchr,
+ FLAGS(scan)))))
+ {
+ sayNO;
+ }
+
+ /* Here we are either not in utf8, or we matched a utf8-invariant,
+ * so the next char is the next byte */
+ locinput++;
+ break;
+
+ case NPOSIXU: /* \W or [:^punct:] etc. under /u */
+ to_complement = 1;
+ /* FALLTHROUGH */
+
+ case POSIXU: /* \w or [:punct:] etc. under /u */
+ utf8_posix:
+ if (NEXTCHR_IS_EOS) {
+ sayNO;
+ }
+ utf8_posix_not_eos:
+
+ /* Use _generic_isCC() for characters within Latin1. (Note that
+ * UTF8_IS_INVARIANT works even on non-UTF-8 strings, or else
+ * wouldn't be invariant) */
+ if (UTF8_IS_INVARIANT(nextchr) || ! utf8_target) {
+ if (! (to_complement ^ cBOOL(_generic_isCC(nextchr,
+ FLAGS(scan)))))
+ {
+ sayNO;
+ }
+ locinput++;
+ }
+ else if (UTF8_IS_DOWNGRADEABLE_START(nextchr)) {
+ if (! (to_complement
+ ^ cBOOL(_generic_isCC(TWO_BYTE_UTF8_TO_UNI(nextchr,
+ *(locinput + 1)),
+ FLAGS(scan)))))
+ {
+ sayNO;
+ }
+ locinput += 2;
+ }
+ else { /* Handle above Latin-1 code points */
+ classnum = (_char_class_number) FLAGS(scan);
+ if (classnum < _FIRST_NON_SWASH_CC) {
+
+ /* Here, uses a swash to find such code points. Load if if
+ * not done already */
+ if (! PL_utf8_swash_ptrs[classnum]) {
+ U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
+ PL_utf8_swash_ptrs[classnum]
+ = _core_swash_init("utf8",
+ swash_property_names[classnum],
+ &PL_sv_undef, 1, 0, NULL, &flags);
+ }
+ if (! (to_complement
+ ^ cBOOL(swash_fetch(PL_utf8_swash_ptrs[classnum],
+ (U8 *) locinput, TRUE))))
+ {
+ sayNO;
+ }
+ }
+ else { /* Here, uses macros to find above Latin-1 code points */
+ switch (classnum) {
+ case _CC_ENUM_SPACE: /* XXX would require separate
+ code if we revert the change
+ of \v matching this */
+ case _CC_ENUM_PSXSPC:
+ if (! (to_complement
+ ^ cBOOL(is_XPERLSPACE_high(locinput))))
+ {
+ sayNO;
+ }
+ break;
+ case _CC_ENUM_BLANK:
+ if (! (to_complement
+ ^ cBOOL(is_HORIZWS_high(locinput))))
+ {
+ sayNO;
+ }
+ break;
+ case _CC_ENUM_XDIGIT:
+ if (! (to_complement
+ ^ cBOOL(is_XDIGIT_high(locinput))))
+ {
+ sayNO;
+ }
+ break;
+ case _CC_ENUM_VERTSPACE:
+ if (! (to_complement
+ ^ cBOOL(is_VERTWS_high(locinput))))
+ {
+ sayNO;
+ }
+ break;
+ default: /* The rest, e.g. [:cntrl:], can't match
+ above Latin1 */
+ if (! to_complement) {
+ sayNO;
+ }
+ break;
+ }
+ }
+ locinput += UTF8SKIP(locinput);
+ }
+ break;
+
case CLUMP: /* Match \X: logical Unicode character. This is defined as
a Unicode extended Grapheme Cluster */
/* From http://www.unicode.org/reports/tr29 (5.2 version). An
extended Grapheme Cluster is:
- CR LF
- | Prepend* Begin Extend*
- | .
+ CR LF
+ | Prepend* Begin Extend*
+ | .
- Begin is (Hangul-syllable | ! Control)
- Extend is (Grapheme_Extend | Spacing_Mark)
- Control is [ GCB_Control CR LF ]
+ Begin is: ( Special_Begin | ! Control )
+ Special_Begin is: ( Regional-Indicator+ | Hangul-syllable )
+ Extend is: ( Grapheme_Extend | Spacing_Mark )
+ Control is: [ GCB_Control | CR | LF ]
+ Hangul-syllable is: ( T+ | ( L* ( L | ( LVT | ( V | LV ) V* ) T* ) ))
- The discussion below shows how the code for CLUMP is derived
- from this regex. Note that most of these concepts are from
- property values of the Grapheme Cluster Boundary (GCB) property.
- No code point can have multiple property values for a given
- property. Thus a code point in Prepend can't be in Control, but
- it must be in !Control. This is why Control above includes
- GCB_Control plus CR plus LF. The latter two are used in the GCB
- property separately, and so can't be in GCB_Control, even though
- they logically are controls. Control is not the same as gc=cc,
- but includes format and other characters as well.
+ If we create a 'Regular_Begin' = Begin - Special_Begin, then
+ we can rewrite
- The Unicode definition of Hangul-syllable is:
- L+
- | (L* ( ( V | LV ) V* | LVT ) T*)
- | T+
- )
- Each of these is a value for the GCB property, and hence must be
- disjoint, so the order they are tested is immaterial, so the
- above can safely be changed to
- T+
- | L+
- | (L* ( LVT | ( V | LV ) V*) T*)
+ Begin is ( Regular_Begin + Special Begin )
- The last two terms can be combined like this:
- L* ( L
- | (( LVT | ( V | LV ) V*) T*))
+ It turns out that 98.4% of all Unicode code points match
+ Regular_Begin. Doing it this way eliminates a table match in
+ the previous implementation for almost all Unicode code points.
- And refactored into this:
- L* (L | LVT T* | V V* T* | LV V* T*)
-
- That means that if we have seen any L's at all we can quit
- there, but if the next character is a LVT, a V or and LV we
- should keep going.
-
There is a subtlety with Prepend* which showed up in testing.
Note that the Begin, and only the Begin is required in:
| Prepend* Begin Extend*
- Also, Begin contains '! Control'. A Prepend must be a '!
- Control', which means it must be a Begin. What it comes down to
- is that if we match Prepend* and then find no suitable Begin
- afterwards, that if we backtrack the last Prepend, that one will
- be a suitable Begin.
+ Also, Begin contains '! Control'. A Prepend must be a
+ '! Control', which means it must also be a Begin. What it
+ comes down to is that if we match Prepend* and then find no
+ suitable Begin afterwards, that if we backtrack the last
+ Prepend, that one will be a suitable Begin.
*/
- if (locinput >= PL_regeol)
+ if (NEXTCHR_IS_EOS)
sayNO;
if (! utf8_target) {
@@ -3833,34 +4506,41 @@
/* Match either CR LF or '.', as all the other possibilities
* require utf8 */
locinput++; /* Match the . or CR */
- if (nextchr == '\r'
+ if (nextchr == '\r' /* And if it was CR, and the next is LF,
+ match the LF */
&& locinput < PL_regeol
- && UCHARAT(locinput) == '\n') locinput++;
+ && UCHARAT(locinput) == '\n')
+ {
+ locinput++;
+ }
}
else {
/* Utf8: See if is ( CR LF ); already know that locinput <
* PL_regeol, so locinput+1 is in bounds */
- if (nextchr == '\r' && UCHARAT(locinput + 1) == '\n') {
+ if ( nextchr == '\r' && locinput+1 < PL_regeol
+ && UCHARAT(locinput + 1) == '\n')
+ {
locinput += 2;
}
else {
+ STRLEN len;
+
/* In case have to backtrack to beginning, then match '.' */
char *starting = locinput;
/* In case have to backtrack the last prepend */
- char *previous_prepend = 0;
+ char *previous_prepend = NULL;
LOAD_UTF8_CHARCLASS_GCB();
- /* Match (prepend)* */
- while (locinput < PL_regeol
- && swash_fetch(PL_utf8_X_prepend,
- (U8*)locinput, utf8_target))
- {
- previous_prepend = locinput;
- locinput += UTF8SKIP(locinput);
- }
+ /* Match (prepend)* */
+ while (locinput < PL_regeol
+ && (len = is_GCB_Prepend_utf8(locinput)))
+ {
+ previous_prepend = locinput;
+ locinput += len;
+ }
/* As noted above, if we matched a prepend character, but
* the next thing won't match, back off the last prepend we
@@ -3867,8 +4547,10 @@
* matched, as it is guaranteed to match the begin */
if (previous_prepend
&& (locinput >= PL_regeol
- || ! swash_fetch(PL_utf8_X_begin,
- (U8*)locinput, utf8_target)))
+ || (! swash_fetch(PL_utf8_X_regular_begin,
+ (U8*)locinput, utf8_target)
+ && ! is_GCB_SPECIAL_BEGIN_START_utf8(locinput)))
+ )
{
locinput = previous_prepend;
}
@@ -3878,111 +4560,107 @@
* moved locinput forward, we tested the result just above
* and it either passed, or we backed off so that it will
* now pass */
- if (! swash_fetch(PL_utf8_X_begin, (U8*)locinput, utf8_target)) {
+ if (swash_fetch(PL_utf8_X_regular_begin,
+ (U8*)locinput, utf8_target)) {
+ locinput += UTF8SKIP(locinput);
+ }
+ else if (! is_GCB_SPECIAL_BEGIN_START_utf8(locinput)) {
/* Here did not match the required 'Begin' in the
* second term. So just match the very first
* character, the '.' of the final term of the regex */
locinput = starting + UTF8SKIP(starting);
+ goto exit_utf8;
} else {
- /* Here is the beginning of a character that can have
- * an extender. It is either a hangul syllable, or a
- * non-control */
- if (swash_fetch(PL_utf8_X_non_hangul,
- (U8*)locinput, utf8_target))
- {
+ /* Here is a special begin. It can be composed of
+ * several individual characters. One possibility is
+ * RI+ */
+ if ((len = is_GCB_RI_utf8(locinput))) {
+ locinput += len;
+ while (locinput < PL_regeol
+ && (len = is_GCB_RI_utf8(locinput)))
+ {
+ locinput += len;
+ }
+ } else if ((len = is_GCB_T_utf8(locinput))) {
+ /* Another possibility is T+ */
+ locinput += len;
+ while (locinput < PL_regeol
+ && (len = is_GCB_T_utf8(locinput)))
+ {
+ locinput += len;
+ }
+ } else {
- /* Here not a Hangul syllable, must be a
- * ('! * Control') */
- locinput += UTF8SKIP(locinput);
- } else {
+ /* Here, neither RI+ nor T+; must be some other
+ * Hangul. That means it is one of the others: L,
+ * LV, LVT or V, and matches:
+ * L* (L | LVT T* | V * V* T* | LV V* T*) */
- /* Here is a Hangul syllable. It can be composed
- * of several individual characters. One
- * possibility is T+ */
- if (swash_fetch(PL_utf8_X_T,
- (U8*)locinput, utf8_target))
- {
- while (locinput < PL_regeol
- && swash_fetch(PL_utf8_X_T,
- (U8*)locinput, utf8_target))
- {
- locinput += UTF8SKIP(locinput);
- }
- } else {
+ /* Match L* */
+ while (locinput < PL_regeol
+ && (len = is_GCB_L_utf8(locinput)))
+ {
+ locinput += len;
+ }
- /* Here, not T+, but is a Hangul. That means
- * it is one of the others: L, LV, LVT or V,
- * and matches:
- * L* (L | LVT T* | V V* T* | LV V* T*) */
+ /* Here, have exhausted L*. If the next character
+ * is not an LV, LVT nor V, it means we had to have
+ * at least one L, so matches L+ in the original
+ * equation, we have a complete hangul syllable.
+ * Are done. */
- /* Match L* */
- while (locinput < PL_regeol
- && swash_fetch(PL_utf8_X_L,
- (U8*)locinput, utf8_target))
- {
- locinput += UTF8SKIP(locinput);
- }
+ if (locinput < PL_regeol
+ && is_GCB_LV_LVT_V_utf8(locinput))
+ {
+ /* Otherwise keep going. Must be LV, LVT or V.
+ * See if LVT, by first ruling out V, then LV */
+ if (! is_GCB_V_utf8(locinput)
+ /* All but every TCount one is LV */
+ && (valid_utf8_to_uvchr((U8 *) locinput,
+ NULL)
+ - SBASE)
+ % TCount != 0)
+ {
+ locinput += UTF8SKIP(locinput);
+ } else {
- /* Here, have exhausted L*. If the next
- * character is not an LV, LVT nor V, it means
- * we had to have at least one L, so matches L+
- * in the original equation, we have a complete
- * hangul syllable. Are done. */
+ /* Must be V or LV. Take it, then match
+ * V* */
+ locinput += UTF8SKIP(locinput);
+ while (locinput < PL_regeol
+ && (len = is_GCB_V_utf8(locinput)))
+ {
+ locinput += len;
+ }
+ }
- if (locinput < PL_regeol
- && swash_fetch(PL_utf8_X_LV_LVT_V,
- (U8*)locinput, utf8_target))
- {
+ /* And any of LV, LVT, or V can be followed
+ * by T* */
+ while (locinput < PL_regeol
+ && (len = is_GCB_T_utf8(locinput)))
+ {
+ locinput += len;
+ }
+ }
+ }
+ }
- /* Otherwise keep going. Must be LV, LVT
- * or V. See if LVT */
- if (swash_fetch(PL_utf8_X_LVT,
- (U8*)locinput, utf8_target))
- {
- locinput += UTF8SKIP(locinput);
- } else {
-
- /* Must be V or LV. Take it, then
- * match V* */
- locinput += UTF8SKIP(locinput);
- while (locinput < PL_regeol
- && swash_fetch(PL_utf8_X_V,
- (U8*)locinput, utf8_target))
- {
- locinput += UTF8SKIP(locinput);
- }
- }
-
- /* And any of LV, LVT, or V can be followed
- * by T* */
- while (locinput < PL_regeol
- && swash_fetch(PL_utf8_X_T,
- (U8*)locinput,
- utf8_target))
- {
- locinput += UTF8SKIP(locinput);
- }
- }
- }
- }
-
- /* Match any extender */
- while (locinput < PL_regeol
- && swash_fetch(PL_utf8_X_extend,
- (U8*)locinput, utf8_target))
- {
- locinput += UTF8SKIP(locinput);
- }
- }
+ /* Match any extender */
+ while (locinput < PL_regeol
+ && swash_fetch(PL_utf8_X_extend,
+ (U8*)locinput, utf8_target))
+ {
+ locinput += UTF8SKIP(locinput);
+ }
}
+ exit_utf8:
if (locinput > PL_regeol) sayNO;
}
- nextchr = UCHARAT(locinput);
break;
- case NREFFL:
+ case NREFFL: /* /\g{name}/il */
{ /* The capture buffer cases. The ones beginning with N for the
named buffers just convert to the equivalent numbered and
pretend they were called as the corresponding numbered buffer
@@ -3995,7 +4673,7 @@
const U8 *fold_array;
UV utf8_fold_flags;
- PL_reg_flags |= RF_tainted;
+ RX_MATCH_TAINTED_on(reginfo->prog);
folder = foldEQ_locale;
fold_array = PL_fold_locale;
type = REFFL;
@@ -4002,7 +4680,7 @@
utf8_fold_flags = FOLDEQ_UTF8_LOCALE;
goto do_nref;
- case NREFFA:
+ case NREFFA: /* /\g{name}/iaa */
folder = foldEQ_latin1;
fold_array = PL_fold_latin1;
type = REFFA;
@@ -4009,7 +4687,7 @@
utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII;
goto do_nref;
- case NREFFU:
+ case NREFFU: /* /\g{name}/iu */
folder = foldEQ_latin1;
fold_array = PL_fold_latin1;
type = REFFU;
@@ -4016,7 +4694,7 @@
utf8_fold_flags = 0;
goto do_nref;
- case NREFF:
+ case NREFF: /* /\g{name}/i */
folder = foldEQ;
fold_array = PL_fold;
type = REFF;
@@ -4023,7 +4701,7 @@
utf8_fold_flags = 0;
goto do_nref;
- case NREF:
+ case NREF: /* /\g{name}/ */
type = REF;
folder = NULL;
fold_array = NULL;
@@ -4039,32 +4717,32 @@
}
goto do_nref_ref_common;
- case REFFL:
- PL_reg_flags |= RF_tainted;
+ case REFFL: /* /\1/il */
+ RX_MATCH_TAINTED_on(reginfo->prog);
folder = foldEQ_locale;
fold_array = PL_fold_locale;
utf8_fold_flags = FOLDEQ_UTF8_LOCALE;
goto do_ref;
- case REFFA:
+ case REFFA: /* /\1/iaa */
folder = foldEQ_latin1;
fold_array = PL_fold_latin1;
utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII;
goto do_ref;
- case REFFU:
+ case REFFU: /* /\1/iu */
folder = foldEQ_latin1;
fold_array = PL_fold_latin1;
utf8_fold_flags = 0;
goto do_ref;
- case REFF:
+ case REFF: /* /\1/i */
folder = foldEQ;
fold_array = PL_fold;
utf8_fold_flags = 0;
goto do_ref;
- case REF:
+ case REF: /* /\1/ */
folder = NULL;
fold_array = NULL;
utf8_fold_flags = 0;
@@ -4074,11 +4752,11 @@
n = ARG(scan); /* which paren pair */
do_nref_ref_common:
- ln = PL_regoffs[n].start;
+ ln = rex->offs[n].start;
PL_reg_leftiter = PL_reg_maxiter; /* Void cache */
- if (*PL_reglastparen < n || ln == -1)
+ if (rex->lastparen < n || ln == -1)
sayNO; /* Do not match unless seen CLOSEn. */
- if (ln == PL_regoffs[n].end)
+ if (ln == rex->offs[n].end)
break;
s = PL_bostr + ln;
@@ -4090,24 +4768,24 @@
/* This call case insensitively compares the entire buffer
* at s, with the current input starting at locinput, but
* not going off the end given by PL_regeol, and returns in
- * limit upon success, how much of the current input was
+ * <limit> upon success, how much of the current input was
* matched */
- if (! foldEQ_utf8_flags(s, NULL, PL_regoffs[n].end - ln, utf8_target,
+ if (! foldEQ_utf8_flags(s, NULL, rex->offs[n].end - ln, utf8_target,
locinput, &limit, 0, utf8_target, utf8_fold_flags))
{
sayNO;
}
locinput = limit;
- nextchr = UCHARAT(locinput);
break;
}
/* Not utf8: Inline the first character, for speed. */
- if (UCHARAT(s) != nextchr &&
+ if (!NEXTCHR_IS_EOS &&
+ UCHARAT(s) != nextchr &&
(type == REF ||
UCHARAT(s) != fold_array[nextchr]))
sayNO;
- ln = PL_regoffs[n].end - ln;
+ ln = rex->offs[n].end - ln;
if (locinput + ln > PL_regeol)
sayNO;
if (ln > 1 && (type == REF
@@ -4115,15 +4793,18 @@
: ! folder(s, locinput, ln)))
sayNO;
locinput += ln;
- nextchr = UCHARAT(locinput);
break;
}
- case NOTHING:
- case TAIL:
+
+ case NOTHING: /* null op; e.g. the 'nothing' following
+ * the '*' in m{(a+|b)*}' */
break;
- case BACK:
+ case TAIL: /* placeholder while compiling (A|B|C) */
break;
+ case BACK: /* ??? doesn't appear to be used ??? */
+ break;
+
#undef ST
#define ST st->u.eval
{
@@ -4133,7 +4814,7 @@
regexp_internal *rei;
regnode *startpoint;
- case GOSTART:
+ case GOSTART: /* (?R) */
case GOSUB: /* /(...(?1))/ /(...(?&foo))/ */
if (cur_eval && cur_eval->locinput==locinput) {
if (cur_eval->u.eval.close_paren == (U32)ARG(scan))
@@ -4148,7 +4829,6 @@
re_sv = rex_sv;
re = rex;
rei = rexi;
- (void)ReREFCNT_inc(rex_sv);
if (OP(scan)==GOSUB) {
startpoint = scan + ARG2L(scan);
ST.close_paren = ARG(scan);
@@ -4157,7 +4837,8 @@
ST.close_paren = 0;
}
goto eval_recurse_doit;
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
+
case EVAL: /* /(?{A})B/ /(??{A})B/ and /(?(?{A})X|Y)B/ */
if (cur_eval && cur_eval->locinput==locinput) {
if ( ++nochange_depth > max_nochange_depth )
@@ -4167,14 +4848,20 @@
}
{
/* execute the code in the {...} */
+
dSP;
- SV ** const before = SP;
- OP_4tree * const oop = PL_op;
+ IV before;
+ OP * const oop = PL_op;
COP * const ocurcop = PL_curcop;
- PAD *old_comppad;
+ OP *nop;
char *saved_regeol = PL_regeol;
struct re_save_state saved_state;
+ CV *newcv;
+ /* save *all* paren positions */
+ regcppush(rex, 0, maxopenparen);
+ REGCP_SET(runops_cp);
+
/* To not corrupt the existing regex state while executing the
* eval we would normally put it on the save stack, like with
* save_re_context. However, re-evals have a weird scoping so we
@@ -4191,21 +4878,107 @@
*/
Copy(&PL_reg_state, &saved_state, 1, struct re_save_state);
+ if (!caller_cv)
+ caller_cv = find_runcv(NULL);
+
n = ARG(scan);
- PL_op = (OP_4tree*)rexi->data->data[n];
+
+ if (rexi->data->what[n] == 'r') { /* code from an external qr */
+ newcv = (ReANY(
+ (REGEXP*)(rexi->data->data[n])
+ ))->qr_anoncv
+ ;
+ nop = (OP*)rexi->data->data[n+1];
+ }
+ else if (rexi->data->what[n] == 'l') { /* literal code */
+ newcv = caller_cv;
+ nop = (OP*)rexi->data->data[n];
+ assert(CvDEPTH(newcv));
+ }
+ else {
+ /* literal with own CV */
+ assert(rexi->data->what[n] == 'L');
+ newcv = rex->qr_anoncv;
+ nop = (OP*)rexi->data->data[n];
+ }
+
+ /* normally if we're about to execute code from the same
+ * CV that we used previously, we just use the existing
+ * CX stack entry. However, its possible that in the
+ * meantime we may have backtracked, popped from the save
+ * stack, and undone the SAVECOMPPAD(s) associated with
+ * PUSH_MULTICALL; in which case PL_comppad no longer
+ * points to newcv's pad. */
+ if (newcv != last_pushed_cv || PL_comppad != last_pad)
+ {
+ U8 flags = (CXp_SUB_RE |
+ ((newcv == caller_cv) ? CXp_SUB_RE_FAKE : 0));
+ if (last_pushed_cv) {
+ CHANGE_MULTICALL_FLAGS(newcv, flags);
+ }
+ else {
+ PUSH_MULTICALL_FLAGS(newcv, flags);
+ }
+ last_pushed_cv = newcv;
+ }
+ else {
+ /* these assignments are just to silence compiler
+ * warnings */
+ multicall_cop = NULL;
+ newsp = NULL;
+ }
+ last_pad = PL_comppad;
+
+ /* the initial nextstate you would normally execute
+ * at the start of an eval (which would cause error
+ * messages to come from the eval), may be optimised
+ * away from the execution path in the regex code blocks;
+ * so manually set PL_curcop to it initially */
+ {
+ OP *o = cUNOPx(nop)->op_first;
+ assert(o->op_type == OP_NULL);
+ if (o->op_targ == OP_SCOPE) {
+ o = cUNOPo->op_first;
+ }
+ else {
+ assert(o->op_targ == OP_LEAVE);
+ o = cUNOPo->op_first;
+ assert(o->op_type == OP_ENTER);
+ o = o->op_sibling;
+ }
+
+ if (o->op_type != OP_STUB) {
+ assert( 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;
+ }
+ }
+ nop = nop->op_next;
+
DEBUG_STATE_r( PerlIO_printf(Perl_debug_log,
- " re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
- PAD_SAVE_LOCAL(old_comppad, (PAD*)rexi->data->data[n + 2]);
- PL_regoffs[0].end = PL_reg_magic->mg_len = locinput - PL_bostr;
+ " re EVAL PL_op=0x%"UVxf"\n", PTR2UV(nop)) );
+ rex->offs[0].end = PL_reg_magic->mg_len = locinput - PL_bostr;
+
if (sv_yes_mark) {
SV *sv_mrk = get_sv("REGMARK", 1);
sv_setsv(sv_mrk, sv_yes_mark);
}
+ /* we don't use MULTICALL here as we want to call the
+ * first op of the block of interest, rather than the
+ * first op of the sub */
+ before = (IV)(SP-PL_stack_base);
+ PL_op = nop;
CALLRUNOPS(aTHX); /* Scalar context. */
SPAGAIN;
- if (SP == before)
+ if ((IV)(SP-PL_stack_base) == before)
ret = &PL_sv_undef; /* protect against empty (?{}) blocks. */
else {
ret = POPs;
@@ -4212,78 +4985,91 @@
PUTBACK;
}
+ /* before restoring everything, evaluate the returned
+ * value, so that 'uninit' warnings don't use the wrong
+ * PL_op or pad. Also need to process any magic vars
+ * (e.g. $1) *before* parentheses are restored */
+
+ PL_op = NULL;
+
+ re_sv = NULL;
+ if (logical == 0) /* (?{})/ */
+ sv_setsv(save_scalar(PL_replgv), ret); /* $^R */
+ else if (logical == 1) { /* /(?(?{...})X|Y)/ */
+ sw = cBOOL(SvTRUE(ret));
+ logical = 0;
+ }
+ else { /* /(??{}) */
+ /* if its overloaded, let the regex compiler handle
+ * it; otherwise extract regex, or stringify */
+ if (!SvAMAGIC(ret)) {
+ SV *sv = ret;
+ if (SvROK(sv))
+ sv = SvRV(sv);
+ if (SvTYPE(sv) == SVt_REGEXP)
+ re_sv = (REGEXP*) sv;
+ else if (SvSMAGICAL(sv)) {
+ MAGIC *mg = mg_find(sv, PERL_MAGIC_qr);
+ if (mg)
+ re_sv = (REGEXP *) mg->mg_obj;
+ }
+
+ /* force any magic, undef warnings here */
+ if (!re_sv) {
+ ret = sv_mortalcopy(ret);
+ (void) SvPV_force_nolen(ret);
+ }
+ }
+
+ }
+
Copy(&saved_state, &PL_reg_state, 1, struct re_save_state);
+ /* *** Note that at this point we don't restore
+ * PL_comppad, (or pop the CxSUB) on the assumption it may
+ * be used again soon. This is safe as long as nothing
+ * in the regexp code uses the pad ! */
PL_op = oop;
- PAD_RESTORE_LOCAL(old_comppad);
PL_curcop = ocurcop;
PL_regeol = saved_regeol;
- if (!logical) {
- /* /(?{...})/ */
- sv_setsv(save_scalar(PL_replgv), ret);
+ S_regcp_restore(aTHX_ rex, runops_cp, &maxopenparen);
+
+ if (logical != 2)
break;
- }
}
- if (logical == 2) { /* Postponed subexpression: /(??{...})/ */
+
+ /* only /(??{})/ from now on */
logical = 0;
{
/* extract RE object from returned value; compiling if
* necessary */
- MAGIC *mg = NULL;
- REGEXP *rx = NULL;
- if (SvROK(ret)) {
- SV *const sv = SvRV(ret);
-
- if (SvTYPE(sv) == SVt_REGEXP) {
- rx = (REGEXP*) sv;
- } else if (SvSMAGICAL(sv)) {
- mg = mg_find(sv, PERL_MAGIC_qr);
- assert(mg);
- }
- } else if (SvTYPE(ret) == SVt_REGEXP) {
- rx = (REGEXP*) ret;
- } else if (SvSMAGICAL(ret)) {
- if (SvGMAGICAL(ret)) {
- /* I don't believe that there is ever qr magic
- here. */
- assert(!mg_find(ret, PERL_MAGIC_qr));
- sv_unmagic(ret, PERL_MAGIC_qr);
- }
- else {
- mg = mg_find(ret, PERL_MAGIC_qr);
- /* testing suggests mg only ends up non-NULL for
- scalars who were upgraded and compiled in the
- else block below. In turn, this is only
- triggered in the "postponed utf8 string" tests
- in t/op/pat.t */
- }
+ if (re_sv) {
+ re_sv = reg_temp_copy(NULL, re_sv);
}
-
- if (mg) {
- rx = (REGEXP *) mg->mg_obj; /*XXX:dmq*/
- assert(rx);
- }
- if (rx) {
- rx = reg_temp_copy(NULL, rx);
- }
else {
U32 pm_flags = 0;
- const I32 osize = PL_regsize;
- if (DO_UTF8(ret)) {
- assert (SvUTF8(ret));
- } else if (SvUTF8(ret)) {
- /* Not doing UTF-8, despite what the SV says. Is
- this only if we're trapped in use 'bytes'? */
- /* Make a copy of the octet sequence, but without
- the flag on, as the compiler now honours the
- SvUTF8 flag on ret. */
+ if (SvUTF8(ret) && IN_BYTES) {
+ /* In use 'bytes': make a copy of the octet
+ * sequence, but without the flag on */
STRLEN len;
const char *const p = SvPV(ret, len);
ret = newSVpvn_flags(p, len, SVs_TEMP);
}
- rx = CALLREGCOMP(ret, pm_flags);
+ if (rex->intflags & PREGf_USE_RE_EVAL)
+ pm_flags |= PMf_USE_RE_EVAL;
+
+ /* if we got here, it should be an engine which
+ * supports compiling code blocks and stuff */
+ assert(rex->engine && rex->engine->op_comp);
+ assert(!(scan->flags & ~RXf_PMf_COMPILETIME));
+ re_sv = rex->engine->op_comp(aTHX_ &ret, 1, NULL,
+ rex->engine, NULL, NULL,
+ /* copy /msix etc to inner pattern */
+ scan->flags,
+ pm_flags);
+
if (!(SvFLAGS(ret)
& (SVs_TEMP | SVs_PADTMP | SVf_READONLY
| SVs_GMG))) {
@@ -4290,16 +5076,21 @@
/* This isn't a first class regexp. Instead, it's
caching a regexp onto an existing, Perl visible
scalar. */
- sv_magic(ret, MUTABLE_SV(rx), PERL_MAGIC_qr, 0, 0);
+ sv_magic(ret, MUTABLE_SV(re_sv), PERL_MAGIC_qr, 0, 0);
}
- PL_regsize = osize;
+ /* safe to do now that any $1 etc has been
+ * interpolated into the new pattern string and
+ * compiled */
+ S_regcp_restore(aTHX_ rex, runops_cp, &maxopenparen);
}
- re_sv = rx;
- re = (struct regexp *)SvANY(rx);
+ SAVEFREESV(re_sv);
+ re = ReANY(re_sv);
}
RXp_MATCH_COPIED_off(re);
re->subbeg = rex->subbeg;
re->sublen = rex->sublen;
+ re->suboffset = rex->suboffset;
+ re->subcoffset = rex->subcoffset;
rei = RXi_GET(re);
DEBUG_EXECUTE_r(
debug_start_match(re_sv, utf8_target, locinput, PL_regeol,
@@ -4307,44 +5098,29 @@
);
startpoint = rei->program + 1;
ST.close_paren = 0; /* only used for GOSUB */
- /* borrowed from regtry */
- if (PL_reg_start_tmpl <= re->nparens) {
- PL_reg_start_tmpl = re->nparens*3/2 + 3;
- if(PL_reg_start_tmp)
- Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
- else
- Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
- }
eval_recurse_doit: /* Share code with GOSUB below this line */
/* run the pattern returned from (??{...}) */
- ST.cp = regcppush(0); /* Save *all* the positions. */
+
+ /* Save *all* the positions. */
+ ST.cp = regcppush(rex, 0, maxopenparen);
REGCP_SET(ST.lastcp);
- PL_regoffs = re->offs; /* essentially NOOP on GOSUB */
-
- /* see regtry, specifically PL_reglast(?:close)?paren is a pointer! (i dont know why) :dmq */
- PL_reglastparen = &re->lastparen;
- PL_reglastcloseparen = &re->lastcloseparen;
re->lastparen = 0;
re->lastcloseparen = 0;
- PL_reginput = locinput;
- PL_regsize = 0;
+ maxopenparen = 0;
/* XXXX This is too dramatic a measure... */
PL_reg_maxiter = 0;
- ST.toggle_reg_flags = PL_reg_flags;
- if (RX_UTF8(re_sv))
- PL_reg_flags |= RF_utf8;
- else
- PL_reg_flags &= ~RF_utf8;
- ST.toggle_reg_flags ^= PL_reg_flags; /* diff of old and new */
+ ST.saved_utf8_pat = is_utf8_pat;
+ is_utf8_pat = cBOOL(RX_UTF8(re_sv));
ST.prev_rex = rex_sv;
ST.prev_curlyx = cur_curlyx;
- SETREX(rex_sv,re_sv);
+ rex_sv = re_sv;
+ SET_reg_curpm(rex_sv);
rex = re;
rexi = rei;
cur_curlyx = NULL;
@@ -4352,32 +5128,21 @@
ST.prev_eval = cur_eval;
cur_eval = st;
/* now continue from first node in postoned RE */
- PUSH_YES_STATE_GOTO(EVAL_AB, startpoint);
- /* NOTREACHED */
- }
- /* logical is 1, /(?(?{...})X|Y)/ */
- sw = cBOOL(SvTRUE(ret));
- logical = 0;
- break;
+ PUSH_YES_STATE_GOTO(EVAL_AB, startpoint, locinput);
+ assert(0); /* NOTREACHED */
}
case EVAL_AB: /* cleanup after a successful (??{A})B */
/* note: this is called twice; first after popping B, then A */
- PL_reg_flags ^= ST.toggle_reg_flags;
- ReREFCNT_dec(rex_sv);
- SETREX(rex_sv,ST.prev_rex);
- rex = (struct regexp *)SvANY(rex_sv);
+ is_utf8_pat = ST.saved_utf8_pat;
+ rex_sv = ST.prev_rex;
+ SET_reg_curpm(rex_sv);
+ rex = ReANY(rex_sv);
rexi = RXi_GET(rex);
regcpblow(ST.cp);
cur_eval = ST.prev_eval;
cur_curlyx = ST.prev_curlyx;
- /* rex was changed so update the pointer in PL_reglastparen and PL_reglastcloseparen */
- PL_reglastparen = &rex->lastparen;
- PL_reglastcloseparen = &rex->lastcloseparen;
- /* also update PL_regoffs */
- PL_regoffs = rex->offs;
-
/* XXXX This is too dramatic a measure... */
PL_reg_maxiter = 0;
if ( nochange_depth )
@@ -4387,18 +5152,14 @@
case EVAL_AB_fail: /* unsuccessfully ran A or B in (??{A})B */
/* note: this is called twice; first after popping B, then A */
- PL_reg_flags ^= ST.toggle_reg_flags;
- ReREFCNT_dec(rex_sv);
- SETREX(rex_sv,ST.prev_rex);
- rex = (struct regexp *)SvANY(rex_sv);
+ is_utf8_pat = ST.saved_utf8_pat;
+ rex_sv = ST.prev_rex;
+ SET_reg_curpm(rex_sv);
+ rex = ReANY(rex_sv);
rexi = RXi_GET(rex);
- /* rex was changed so update the pointer in PL_reglastparen and PL_reglastcloseparen */
- PL_reglastparen = &rex->lastparen;
- PL_reglastcloseparen = &rex->lastcloseparen;
- PL_reginput = locinput;
REGCP_UNWIND(ST.lastcp);
- regcppop(rex);
+ regcppop(rex, &maxopenparen);
cur_eval = ST.prev_eval;
cur_curlyx = ST.prev_curlyx;
/* XXXX This is too dramatic a measure... */
@@ -4408,27 +5169,47 @@
sayNO_SILENT;
#undef ST
- case OPEN:
+ case OPEN: /* ( */
n = ARG(scan); /* which paren pair */
- PL_reg_start_tmp[n] = locinput;
- if (n > PL_regsize)
- PL_regsize = n;
+ rex->offs[n].start_tmp = locinput - PL_bostr;
+ if (n > maxopenparen)
+ maxopenparen = n;
+ DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
+ "rex=0x%"UVxf" offs=0x%"UVxf": \\%"UVuf": set %"IVdf" tmp; maxopenparen=%"UVuf"\n",
+ PTR2UV(rex),
+ PTR2UV(rex->offs),
+ (UV)n,
+ (IV)rex->offs[n].start_tmp,
+ (UV)maxopenparen
+ ));
lastopen = n;
break;
- case CLOSE:
+
+/* XXX really need to log other places start/end are set too */
+#define CLOSE_CAPTURE \
+ rex->offs[n].start = rex->offs[n].start_tmp; \
+ rex->offs[n].end = locinput - PL_bostr; \
+ DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log, \
+ "rex=0x%"UVxf" offs=0x%"UVxf": \\%"UVuf": set %"IVdf"..%"IVdf"\n", \
+ PTR2UV(rex), \
+ PTR2UV(rex->offs), \
+ (UV)n, \
+ (IV)rex->offs[n].start, \
+ (IV)rex->offs[n].end \
+ ))
+
+ case CLOSE: /* ) */
n = ARG(scan); /* which paren pair */
- PL_regoffs[n].start = PL_reg_start_tmp[n] - PL_bostr;
- PL_regoffs[n].end = locinput - PL_bostr;
- /*if (n > PL_regsize)
- PL_regsize = n;*/
- if (n > *PL_reglastparen)
- *PL_reglastparen = n;
- *PL_reglastcloseparen = n;
+ CLOSE_CAPTURE;
+ if (n > rex->lastparen)
+ rex->lastparen = n;
+ rex->lastcloseparen = n;
if (cur_eval && cur_eval->u.eval.close_paren == n) {
goto fake_end;
}
break;
- case ACCEPT:
+
+ case ACCEPT: /* (*ACCEPT) */
if (ARG(scan)){
regnode *cursor;
for (cursor=scan;
@@ -4438,14 +5219,10 @@
if ( OP(cursor)==CLOSE ){
n = ARG(cursor);
if ( n <= lastopen ) {
- PL_regoffs[n].start
- = PL_reg_start_tmp[n] - PL_bostr;
- PL_regoffs[n].end = locinput - PL_bostr;
- /*if (n > PL_regsize)
- PL_regsize = n;*/
- if (n > *PL_reglastparen)
- *PL_reglastparen = n;
- *PL_reglastcloseparen = n;
+ CLOSE_CAPTURE;
+ if (n > rex->lastparen)
+ rex->lastparen = n;
+ rex->lastcloseparen = n;
if ( n == ARG(scan) || (cur_eval &&
cur_eval->u.eval.close_paren == n))
break;
@@ -4455,22 +5232,27 @@
}
goto fake_end;
/*NOTREACHED*/
- case GROUPP:
+
+ case GROUPP: /* (?(1)) */
n = ARG(scan); /* which paren pair */
- sw = cBOOL(*PL_reglastparen >= n && PL_regoffs[n].end != -1);
+ sw = cBOOL(rex->lastparen >= n && rex->offs[n].end != -1);
break;
- case NGROUPP:
+
+ case NGROUPP: /* (?(<name>)) */
/* reg_check_named_buff_matched returns 0 for no match */
sw = cBOOL(0 < reg_check_named_buff_matched(rex,scan));
break;
- case INSUBP:
+
+ case INSUBP: /* (?(R)) */
n = ARG(scan);
sw = (cur_eval && (!n || cur_eval->u.eval.close_paren == n));
break;
- case DEFINEP:
+
+ case DEFINEP: /* (?(DEFINE)) */
sw = 0;
break;
- case IFTHEN:
+
+ case IFTHEN: /* (?(cond)A|B) */
PL_reg_leftiter = PL_reg_maxiter; /* Void cache */
if (sw)
next = NEXTOPER(NEXTOPER(scan));
@@ -4480,7 +5262,8 @@
next = NEXTOPER(NEXTOPER(next));
}
break;
- case LOGICAL:
+
+ case LOGICAL: /* modifier for EVAL and IFMATCH */
logical = scan->flags;
break;
@@ -4579,9 +5362,9 @@
next += ARG(next);
/* XXXX Probably it is better to teach regpush to support
- parenfloor > PL_regsize... */
- if (parenfloor > (I32)*PL_reglastparen)
- parenfloor = *PL_reglastparen; /* Pessimization... */
+ parenfloor > maxopenparen ... */
+ if (parenfloor > (I32)rex->lastparen)
+ parenfloor = rex->lastparen; /* Pessimization... */
ST.prev_curlyx= cur_curlyx;
cur_curlyx = st;
@@ -4597,21 +5380,20 @@
ST.count = -1; /* this will be updated by WHILEM */
ST.lastloc = NULL; /* this will be updated by WHILEM */
- PL_reginput = locinput;
- PUSH_YES_STATE_GOTO(CURLYX_end, PREVOPER(next));
- /* NOTREACHED */
+ PUSH_YES_STATE_GOTO(CURLYX_end, PREVOPER(next), locinput);
+ assert(0); /* NOTREACHED */
}
case CURLYX_end: /* just finished matching all of A*B */
cur_curlyx = ST.prev_curlyx;
sayYES;
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
case CURLYX_end_fail: /* just failed to match all of A*B */
regcpblow(ST.cp);
cur_curlyx = ST.prev_curlyx;
sayNO;
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
#undef ST
@@ -4631,7 +5413,6 @@
ST.cache_offset = 0;
ST.cache_mask = 0;
- PL_reginput = locinput;
DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
"%*s whilem: matched %ld out of %d..%d\n",
@@ -4641,12 +5422,13 @@
/* First just match a string of min A's. */
if (n < min) {
- ST.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
+ ST.cp = regcppush(rex, cur_curlyx->u.curlyx.parenfloor,
+ maxopenparen);
cur_curlyx->u.curlyx.lastloc = locinput;
REGCP_SET(ST.lastcp);
- PUSH_STATE_GOTO(WHILEM_A_pre, A);
- /* NOTREACHED */
+ PUSH_STATE_GOTO(WHILEM_A_pre, A, locinput);
+ assert(0); /* NOTREACHED */
}
/* If degenerate A matches "", assume A done. */
@@ -4717,30 +5499,33 @@
if (cur_curlyx->u.curlyx.minmod) {
ST.save_curlyx = cur_curlyx;
cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
- ST.cp = regcppush(ST.save_curlyx->u.curlyx.parenfloor);
+ ST.cp = regcppush(rex, ST.save_curlyx->u.curlyx.parenfloor,
+ maxopenparen);
REGCP_SET(ST.lastcp);
- PUSH_YES_STATE_GOTO(WHILEM_B_min, ST.save_curlyx->u.curlyx.B);
- /* NOTREACHED */
+ PUSH_YES_STATE_GOTO(WHILEM_B_min, ST.save_curlyx->u.curlyx.B,
+ locinput);
+ assert(0); /* NOTREACHED */
}
/* Prefer A over B for maximal matching. */
if (n < max) { /* More greed allowed? */
- ST.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
+ ST.cp = regcppush(rex, cur_curlyx->u.curlyx.parenfloor,
+ maxopenparen);
cur_curlyx->u.curlyx.lastloc = locinput;
REGCP_SET(ST.lastcp);
- PUSH_STATE_GOTO(WHILEM_A_max, A);
- /* NOTREACHED */
+ PUSH_STATE_GOTO(WHILEM_A_max, A, locinput);
+ assert(0); /* NOTREACHED */
}
goto do_whilem_B_max;
}
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
case WHILEM_B_min: /* just matched B in a minimal match */
case WHILEM_B_max: /* just matched B in a maximal match */
cur_curlyx = ST.save_curlyx;
sayYES;
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
case WHILEM_B_max_fail: /* just failed to match B in a maximal match */
cur_curlyx = ST.save_curlyx;
@@ -4747,22 +5532,21 @@
cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
cur_curlyx->u.curlyx.count--;
CACHEsayNO;
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
case WHILEM_A_min_fail: /* just failed to match A in a minimal match */
/* FALL THROUGH */
case WHILEM_A_pre_fail: /* just failed to match even minimal A */
REGCP_UNWIND(ST.lastcp);
- regcppop(rex);
+ regcppop(rex, &maxopenparen);
cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
cur_curlyx->u.curlyx.count--;
CACHEsayNO;
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
case WHILEM_A_max_fail: /* just failed to match A in a maximal match */
REGCP_UNWIND(ST.lastcp);
- regcppop(rex); /* Restore some previous $<digit>s? */
- PL_reginput = locinput;
+ regcppop(rex, &maxopenparen); /* Restore some previous $<digit>s? */
DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
"%*s whilem: failed, trying continuation...\n",
REPORT_CODE_OFF+depth*2, "")
@@ -4770,11 +5554,12 @@
do_whilem_B_max:
if (cur_curlyx->u.curlyx.count >= REG_INFTY
&& ckWARN(WARN_REGEXP)
- && !(PL_reg_flags & RF_warned))
+ && !reginfo->warned)
{
- PL_reg_flags |= RF_warned;
- Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
- "Complex regular subexpression recursion",
+ reginfo->warned = TRUE;
+ Perl_warner(aTHX_ packWARN(WARN_REGEXP),
+ "Complex regular subexpression recursion limit (%d) "
+ "exceeded",
REG_INFTY - 1);
}
@@ -4781,24 +5566,25 @@
/* now try B */
ST.save_curlyx = cur_curlyx;
cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
- PUSH_YES_STATE_GOTO(WHILEM_B_max, ST.save_curlyx->u.curlyx.B);
- /* NOTREACHED */
+ PUSH_YES_STATE_GOTO(WHILEM_B_max, ST.save_curlyx->u.curlyx.B,
+ locinput);
+ assert(0); /* NOTREACHED */
case WHILEM_B_min_fail: /* just failed to match B in a minimal match */
cur_curlyx = ST.save_curlyx;
REGCP_UNWIND(ST.lastcp);
- regcppop(rex);
+ regcppop(rex, &maxopenparen);
if (cur_curlyx->u.curlyx.count >= /*max*/ARG2(cur_curlyx->u.curlyx.me)) {
/* Maximum greed exceeded */
if (cur_curlyx->u.curlyx.count >= REG_INFTY
&& ckWARN(WARN_REGEXP)
- && !(PL_reg_flags & RF_warned))
+ && !reginfo->warned)
{
- PL_reg_flags |= RF_warned;
+ reginfo->warned = TRUE;
Perl_warner(aTHX_ packWARN(WARN_REGEXP),
- "%s limit (%d) exceeded",
- "Complex regular subexpression recursion",
+ "Complex regular subexpression recursion "
+ "limit (%d) exceeded",
REG_INFTY - 1);
}
cur_curlyx->u.curlyx.count--;
@@ -4809,13 +5595,14 @@
"%*s trying longer...\n", REPORT_CODE_OFF+depth*2, "")
);
/* Try grabbing another A and see if it helps. */
- PL_reginput = locinput;
cur_curlyx->u.curlyx.lastloc = locinput;
- ST.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
+ ST.cp = regcppush(rex, cur_curlyx->u.curlyx.parenfloor,
+ maxopenparen);
REGCP_SET(ST.lastcp);
PUSH_STATE_GOTO(WHILEM_A_min,
- /*A*/ NEXTOPER(ST.save_curlyx->u.curlyx.me) + EXTRA_STEP_2ARGS);
- /* NOTREACHED */
+ /*A*/ NEXTOPER(ST.save_curlyx->u.curlyx.me) + EXTRA_STEP_2ARGS,
+ locinput);
+ assert(0); /* NOTREACHED */
#undef ST
#define ST st->u.branch
@@ -4829,24 +5616,25 @@
case BRANCH: /* /(...|A|...)/ */
scan = NEXTOPER(scan); /* scan now points to inner node */
- ST.lastparen = *PL_reglastparen;
+ ST.lastparen = rex->lastparen;
+ ST.lastcloseparen = rex->lastcloseparen;
ST.next_branch = next;
REGCP_SET(ST.cp);
- PL_reginput = locinput;
/* Now go into the branch */
if (has_cutgroup) {
- PUSH_YES_STATE_GOTO(BRANCH_next, scan);
+ PUSH_YES_STATE_GOTO(BRANCH_next, scan, locinput);
} else {
- PUSH_STATE_GOTO(BRANCH_next, scan);
+ PUSH_STATE_GOTO(BRANCH_next, scan, locinput);
}
- /* NOTREACHED */
- case CUTGROUP:
- PL_reginput = locinput;
+ assert(0); /* NOTREACHED */
+
+ case CUTGROUP: /* /(*THEN)/ */
sv_yes_mark = st->u.mark.mark_name = scan->flags ? NULL :
MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
- PUSH_STATE_GOTO(CUTGROUP_next,next);
- /* NOTREACHED */
+ PUSH_STATE_GOTO(CUTGROUP_next, next, locinput);
+ assert(0); /* NOTREACHED */
+
case CUTGROUP_next_fail:
do_cutgroup = 1;
no_final = 1;
@@ -4853,10 +5641,12 @@
if (st->u.mark.mark_name)
sv_commit = st->u.mark.mark_name;
sayNO;
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
+
case BRANCH_next:
sayYES;
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
+
case BRANCH_next_fail: /* that branch failed; try the next, if any */
if (do_cutgroup) {
do_cutgroup = 0;
@@ -4863,10 +5653,7 @@
no_final = 0;
}
REGCP_UNWIND(ST.cp);
- for (n = *PL_reglastparen; n > ST.lastparen; n--)
- PL_regoffs[n].end = -1;
- *PL_reglastparen = n;
- /*dmq: *PL_reglastcloseparen = n; */
+ UNWIND_PAREN(ST.lastparen, ST.lastcloseparen);
scan = ST.next_branch;
/* no more branches? */
if (!scan || (OP(scan) != BRANCH && OP(scan) != BRANCHJ)) {
@@ -4880,9 +5667,9 @@
sayNO_SILENT;
}
continue; /* execute next BRANCH[J] op */
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
- case MINMOD:
+ case MINMOD: /* next op will be non-greedy, e.g. A*? */
minmod = 1;
break;
@@ -4900,13 +5687,14 @@
ST.me = scan;
scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
+ ST.lastparen = rex->lastparen;
+ ST.lastcloseparen = rex->lastcloseparen;
+
/* if paren positive, emulate an OPEN/CLOSE around A */
if (ST.me->flags) {
U32 paren = ST.me->flags;
- if (paren > PL_regsize)
- PL_regsize = paren;
- if (paren > *PL_reglastparen)
- *PL_reglastparen = paren;
+ if (paren > maxopenparen)
+ maxopenparen = paren;
scan += NEXT_OFF(scan); /* Skip former OPEN. */
}
ST.A = scan;
@@ -4922,26 +5710,22 @@
goto curlym_do_B;
curlym_do_A: /* execute the A in /A{m,n}B/ */
- PL_reginput = locinput;
- PUSH_YES_STATE_GOTO(CURLYM_A, ST.A); /* match A */
- /* NOTREACHED */
+ PUSH_YES_STATE_GOTO(CURLYM_A, ST.A, locinput); /* match A */
+ assert(0); /* NOTREACHED */
case CURLYM_A: /* we've just matched an A */
- locinput = st->locinput;
- nextchr = UCHARAT(locinput);
-
ST.count++;
/* after first match, determine A's length: u.curlym.alen */
if (ST.count == 1) {
if (PL_reg_match_utf8) {
- char *s = locinput;
- while (s < PL_reginput) {
+ char *s = st->locinput;
+ while (s < locinput) {
ST.alen++;
s += UTF8SKIP(s);
}
}
else {
- ST.alen = PL_reginput - locinput;
+ ST.alen = locinput - st->locinput;
}
if (ST.alen == 0)
ST.count = ST.minmod ? ARG1(ST.me) : ARG2(ST.me);
@@ -4953,8 +5737,6 @@
(IV) ST.count, (IV)ST.alen)
);
- locinput = PL_reginput;
-
if (cur_eval && cur_eval->u.eval.close_paren &&
cur_eval->u.eval.close_paren == (U32)ST.me->flags)
goto fake_end;
@@ -4975,7 +5757,6 @@
sayNO;
curlym_do_B: /* execute the B in /A{m,n}B/ */
- PL_reginput = locinput;
if (ST.c1 == CHRTEST_UNINIT) {
/* calculate c1 and c2 for possible match of 1st char
* following curly */
@@ -4993,17 +5774,13 @@
if this changes back then the macro for
IS_TEXT and friends need to change.
*/
- if (PL_regkind[OP(text_node)] == EXACT)
- {
-
- ST.c1 = (U8)*STRING(text_node);
- switch (OP(text_node)) {
- case EXACTF: ST.c2 = PL_fold[ST.c1]; break;
- case EXACTFA:
- case EXACTFU: ST.c2 = PL_fold_latin1[ST.c1]; break;
- case EXACTFL: ST.c2 = PL_fold_locale[ST.c1]; break;
- default: ST.c2 = ST.c1;
- }
+ if (PL_regkind[OP(text_node)] == EXACT) {
+ if (! S_setup_EXACTISH_ST_c1_c2(aTHX_
+ text_node, &ST.c1, ST.c1_utf8, &ST.c2, ST.c2_utf8,
+ is_utf8_pat))
+ {
+ sayNO;
+ }
}
}
}
@@ -5014,32 +5791,50 @@
(int)(REPORT_CODE_OFF+(depth*2)),
"", (IV)ST.count)
);
- if (ST.c1 != CHRTEST_VOID
- && UCHARAT(PL_reginput) != ST.c1
- && UCHARAT(PL_reginput) != ST.c2)
- {
- /* simulate B failing */
- DEBUG_OPTIMISE_r(
- PerlIO_printf(Perl_debug_log,
- "%*s CURLYM Fast bail c1=%"IVdf" c2=%"IVdf"\n",
- (int)(REPORT_CODE_OFF+(depth*2)),"",
- (IV)ST.c1,(IV)ST.c2
- ));
- state_num = CURLYM_B_fail;
- goto reenter_switch;
- }
+ if (! NEXTCHR_IS_EOS && ST.c1 != CHRTEST_VOID) {
+ if (! UTF8_IS_INVARIANT(nextchr) && utf8_target) {
+ if (memNE(locinput, ST.c1_utf8, UTF8SKIP(locinput))
+ && memNE(locinput, ST.c2_utf8, UTF8SKIP(locinput)))
+ {
+ /* simulate B failing */
+ DEBUG_OPTIMISE_r(
+ PerlIO_printf(Perl_debug_log,
+ "%*s CURLYM Fast bail next target=U+%"UVXf" c1=U+%"UVXf" c2=U+%"UVXf"\n",
+ (int)(REPORT_CODE_OFF+(depth*2)),"",
+ valid_utf8_to_uvchr((U8 *) locinput, NULL),
+ valid_utf8_to_uvchr(ST.c1_utf8, NULL),
+ valid_utf8_to_uvchr(ST.c2_utf8, NULL))
+ );
+ state_num = CURLYM_B_fail;
+ goto reenter_switch;
+ }
+ }
+ else if (nextchr != ST.c1 && nextchr != ST.c2) {
+ /* simulate B failing */
+ DEBUG_OPTIMISE_r(
+ PerlIO_printf(Perl_debug_log,
+ "%*s CURLYM Fast bail next target=U+%X c1=U+%X c2=U+%X\n",
+ (int)(REPORT_CODE_OFF+(depth*2)),"",
+ (int) nextchr, ST.c1, ST.c2)
+ );
+ state_num = CURLYM_B_fail;
+ goto reenter_switch;
+ }
+ }
if (ST.me->flags) {
- /* mark current A as captured */
+ /* emulate CLOSE: mark current A as captured */
I32 paren = ST.me->flags;
if (ST.count) {
- PL_regoffs[paren].start
- = HOPc(PL_reginput, -ST.alen) - PL_bostr;
- PL_regoffs[paren].end = PL_reginput - PL_bostr;
- /*dmq: *PL_reglastcloseparen = paren; */
+ rex->offs[paren].start
+ = HOPc(locinput, -ST.alen) - PL_bostr;
+ rex->offs[paren].end = locinput - PL_bostr;
+ if ((U32)paren > rex->lastparen)
+ rex->lastparen = paren;
+ rex->lastcloseparen = paren;
}
else
- PL_regoffs[paren].end = -1;
+ rex->offs[paren].end = -1;
if (cur_eval && cur_eval->u.eval.close_paren &&
cur_eval->u.eval.close_paren == (U32)ST.me->flags)
{
@@ -5050,11 +5845,12 @@
}
}
- PUSH_STATE_GOTO(CURLYM_B, ST.B); /* match B */
- /* NOTREACHED */
+ PUSH_STATE_GOTO(CURLYM_B, ST.B, locinput); /* match B */
+ assert(0); /* NOTREACHED */
case CURLYM_B_fail: /* just failed to match a B */
REGCP_UNWIND(ST.cp);
+ UNWIND_PAREN(ST.lastparen, ST.lastcloseparen);
if (ST.minmod) {
I32 max = ARG2(ST.me);
if (max != REG_INFTY && ST.count == max)
@@ -5065,7 +5861,7 @@
if (ST.count == ARG1(ST.me) /* min */)
sayNO;
ST.count--;
- locinput = HOPc(locinput, -ST.alen);
+ SET_locinput(HOPc(locinput, -ST.alen));
goto curlym_do_B; /* try to match B */
#undef ST
@@ -5074,32 +5870,39 @@
#define CURLY_SETPAREN(paren, success) \
if (paren) { \
if (success) { \
- PL_regoffs[paren].start = HOPc(locinput, -1) - PL_bostr; \
- PL_regoffs[paren].end = locinput - PL_bostr; \
- *PL_reglastcloseparen = paren; \
+ rex->offs[paren].start = HOPc(locinput, -1) - PL_bostr; \
+ rex->offs[paren].end = locinput - PL_bostr; \
+ if (paren > rex->lastparen) \
+ rex->lastparen = paren; \
+ rex->lastcloseparen = paren; \
} \
- else \
- PL_regoffs[paren].end = -1; \
+ else { \
+ rex->offs[paren].end = -1; \
+ rex->lastparen = ST.lastparen; \
+ rex->lastcloseparen = ST.lastcloseparen; \
+ } \
}
- case STAR: /* /A*B/ where A is width 1 */
+ case STAR: /* /A*B/ where A is width 1 char */
ST.paren = 0;
ST.min = 0;
ST.max = REG_INFTY;
scan = NEXTOPER(scan);
goto repeat;
- case PLUS: /* /A+B/ where A is width 1 */
+
+ case PLUS: /* /A+B/ where A is width 1 char */
ST.paren = 0;
ST.min = 1;
ST.max = REG_INFTY;
scan = NEXTOPER(scan);
goto repeat;
- case CURLYN: /* /(A){m,n}B/ where A is width 1 */
- ST.paren = scan->flags; /* Which paren to set */
- if (ST.paren > PL_regsize)
- PL_regsize = ST.paren;
- if (ST.paren > *PL_reglastparen)
- *PL_reglastparen = ST.paren;
+
+ case CURLYN: /* /(A){m,n}B/ where A is width 1 char */
+ ST.paren = scan->flags; /* Which paren to set */
+ ST.lastparen = rex->lastparen;
+ ST.lastcloseparen = rex->lastcloseparen;
+ if (ST.paren > maxopenparen)
+ maxopenparen = ST.paren;
ST.min = ARG1(scan); /* min to match */
ST.max = ARG2(scan); /* max to match */
if (cur_eval && cur_eval->u.eval.close_paren &&
@@ -5109,7 +5912,8 @@
}
scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
goto repeat;
- case CURLY: /* /A{m,n}B/ where A is width 1 */
+
+ case CURLY: /* /A{m,n}B/ where A is width 1 char */
ST.paren = 0;
ST.min = ARG1(scan); /* min to match */
ST.max = ARG2(scan); /* max to match */
@@ -5124,10 +5928,11 @@
* of the quantifier and the EXACT-like node. -- japhy
*/
- if (ST.min > ST.max) /* XXX make this a compile-time check? */
- sayNO;
- if (HAS_TEXT(next) || JUMPABLE(next)) {
- U8 *s;
+ assert(ST.min <= ST.max);
+ if (! HAS_TEXT(next) && ! JUMPABLE(next)) {
+ ST.c1 = ST.c2 = CHRTEST_VOID;
+ }
+ else {
regnode *text_node = next;
if (! HAS_TEXT(text_node))
@@ -5138,10 +5943,8 @@
else {
if ( PL_regkind[OP(text_node)] != EXACT ) {
ST.c1 = ST.c2 = CHRTEST_VOID;
- goto assume_ok_easy;
}
- else
- s = (U8*)STRING(text_node);
+ else {
/* Currently we only get here when
@@ -5149,58 +5952,27 @@
if this changes back then the macro for IS_TEXT and
friends need to change. */
- if (!UTF_PATTERN) {
- ST.c1 = *s;
- switch (OP(text_node)) {
- case EXACTF: ST.c2 = PL_fold[ST.c1]; break;
- case EXACTFA:
- case EXACTFU: ST.c2 = PL_fold_latin1[ST.c1]; break;
- case EXACTFL: ST.c2 = PL_fold_locale[ST.c1]; break;
- default: ST.c2 = ST.c1; break;
- }
- }
- else { /* UTF_PATTERN */
- if (IS_TEXTFU(text_node) || IS_TEXTF(text_node)) {
- STRLEN ulen1, ulen2;
- U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
- U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
-
- to_utf8_lower((U8*)s, tmpbuf1, &ulen1);
- to_utf8_upper((U8*)s, tmpbuf2, &ulen2);
-#ifdef EBCDIC
- ST.c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXLEN, 0,
- ckWARN(WARN_UTF8) ?
- 0 : UTF8_ALLOW_ANY);
- ST.c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXLEN, 0,
- ckWARN(WARN_UTF8) ?
- 0 : UTF8_ALLOW_ANY);
-#else
- ST.c1 = utf8n_to_uvuni(tmpbuf1, UTF8_MAXBYTES, 0,
- uniflags);
- ST.c2 = utf8n_to_uvuni(tmpbuf2, UTF8_MAXBYTES, 0,
- uniflags);
-#endif
- }
- else {
- ST.c2 = ST.c1 = utf8n_to_uvchr(s, UTF8_MAXBYTES, 0,
- uniflags);
- }
- }
+ if (! S_setup_EXACTISH_ST_c1_c2(aTHX_
+ text_node, &ST.c1, ST.c1_utf8, &ST.c2, ST.c2_utf8,
+ is_utf8_pat))
+ {
+ sayNO;
+ }
+ }
}
}
- else
- ST.c1 = ST.c2 = CHRTEST_VOID;
- assume_ok_easy:
ST.A = scan;
ST.B = next;
- PL_reginput = locinput;
if (minmod) {
+ char *li = locinput;
minmod = 0;
- if (ST.min && regrepeat(rex, ST.A, ST.min, depth) < ST.min)
+ if (ST.min &&
+ regrepeat(rex, &li, ST.A, ST.min, depth, is_utf8_pat)
+ < ST.min)
sayNO;
+ SET_locinput(li);
ST.count = ST.min;
- locinput = PL_reginput;
REGCP_SET(ST.cp);
if (ST.c1 == CHRTEST_VOID)
goto curly_try_B_min;
@@ -5218,7 +5990,7 @@
else if (utf8_target) {
int m = ST.max - ST.min;
for (ST.maxpos = locinput;
- m >0 && ST.maxpos + UTF8SKIP(ST.maxpos) <= PL_regeol; m--)
+ m >0 && ST.maxpos < PL_regeol; m--)
ST.maxpos += UTF8SKIP(ST.maxpos);
}
else {
@@ -5230,10 +6002,14 @@
}
else {
- ST.count = regrepeat(rex, ST.A, ST.max, depth);
- locinput = PL_reginput;
+ /* avoid taking address of locinput, so it can remain
+ * a register var */
+ char *li = locinput;
+ ST.count = regrepeat(rex, &li, ST.A, ST.max, depth,
+ is_utf8_pat);
if (ST.count < ST.min)
sayNO;
+ SET_locinput(li);
if ((ST.count > ST.min)
&& (PL_regkind[OP(ST.B)] == EOL) && (OP(ST.B) != MEOL))
{
@@ -5243,22 +6019,22 @@
/* ...except that $ and \Z can match before *and* after
newline at the end. Consider "\n\n" =~ /\n+\Z\n/.
We may back off by one in this case. */
- if (UCHARAT(PL_reginput - 1) == '\n' && OP(ST.B) != EOS)
+ if (UCHARAT(locinput - 1) == '\n' && OP(ST.B) != EOS)
ST.min--;
}
REGCP_SET(ST.cp);
goto curly_try_B_max;
}
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
case CURLY_B_min_known_fail:
/* failed to find B in a non-greedy match where c1,c2 valid */
- if (ST.paren && ST.count)
- PL_regoffs[ST.paren].end = -1;
- PL_reginput = locinput; /* Could be reset... */
REGCP_UNWIND(ST.cp);
+ if (ST.paren) {
+ UNWIND_PAREN(ST.lastparen, ST.lastcloseparen);
+ }
/* Couldn't or didn't -- move forward. */
ST.oldloc = locinput;
if (utf8_target)
@@ -5273,31 +6049,26 @@
if (utf8_target) {
n = (ST.oldloc == locinput) ? 0 : 1;
if (ST.c1 == ST.c2) {
- STRLEN len;
/* set n to utf8_distance(oldloc, locinput) */
- while (locinput <= ST.maxpos &&
- utf8n_to_uvchr((U8*)locinput,
- UTF8_MAXBYTES, &len,
- uniflags) != (UV)ST.c1) {
- locinput += len;
+ while (locinput <= ST.maxpos
+ && memNE(locinput, ST.c1_utf8, UTF8SKIP(locinput)))
+ {
+ locinput += UTF8SKIP(locinput);
n++;
}
}
else {
/* set n to utf8_distance(oldloc, locinput) */
- while (locinput <= ST.maxpos) {
- STRLEN len;
- const UV c = utf8n_to_uvchr((U8*)locinput,
- UTF8_MAXBYTES, &len,
- uniflags);
- if (c == (UV)ST.c1 || c == (UV)ST.c2)
- break;
- locinput += len;
+ while (locinput <= ST.maxpos
+ && memNE(locinput, ST.c1_utf8, UTF8SKIP(locinput))
+ && memNE(locinput, ST.c2_utf8, UTF8SKIP(locinput)))
+ {
+ locinput += UTF8SKIP(locinput);
n++;
}
}
}
- else {
+ else { /* Not utf8_target */
if (ST.c1 == ST.c2) {
while (locinput <= ST.maxpos &&
UCHARAT(locinput) != ST.c1)
@@ -5313,34 +6084,43 @@
}
if (locinput > ST.maxpos)
sayNO;
- /* PL_reginput == oldloc now */
if (n) {
+ /* In /a{m,n}b/, ST.oldloc is at "a" x m, locinput is
+ * at b; check that everything between oldloc and
+ * locinput matches */
+ char *li = ST.oldloc;
ST.count += n;
- if (regrepeat(rex, ST.A, n, depth) < n)
+ if (regrepeat(rex, &li, ST.A, n, depth, is_utf8_pat) < n)
sayNO;
+ assert(n == REG_INFTY || locinput == li);
}
- PL_reginput = locinput;
CURLY_SETPAREN(ST.paren, ST.count);
if (cur_eval && cur_eval->u.eval.close_paren &&
cur_eval->u.eval.close_paren == (U32)ST.paren) {
goto fake_end;
}
- PUSH_STATE_GOTO(CURLY_B_min_known, ST.B);
+ PUSH_STATE_GOTO(CURLY_B_min_known, ST.B, locinput);
}
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
case CURLY_B_min_fail:
/* failed to find B in a non-greedy match where c1,c2 invalid */
- if (ST.paren && ST.count)
- PL_regoffs[ST.paren].end = -1;
REGCP_UNWIND(ST.cp);
+ if (ST.paren) {
+ UNWIND_PAREN(ST.lastparen, ST.lastcloseparen);
+ }
/* failed -- move forward one */
- PL_reginput = locinput;
- if (regrepeat(rex, ST.A, 1, depth)) {
+ {
+ char *li = locinput;
+ if (!regrepeat(rex, &li, ST.A, 1, depth, is_utf8_pat)) {
+ sayNO;
+ }
+ locinput = li;
+ }
+ {
ST.count++;
- locinput = PL_reginput;
if (ST.count <= ST.max || (ST.max == REG_INFTY &&
ST.count > 0)) /* count overflow ? */
{
@@ -5350,11 +6130,11 @@
cur_eval->u.eval.close_paren == (U32)ST.paren) {
goto fake_end;
}
- PUSH_STATE_GOTO(CURLY_B_min, ST.B);
+ PUSH_STATE_GOTO(CURLY_B_min, ST.B, locinput);
}
}
- sayNO;
- /* NOTREACHED */
+ sayNO;
+ assert(0); /* NOTREACHED */
curly_try_B_max:
@@ -5364,63 +6144,70 @@
goto fake_end;
}
{
- UV c = 0;
- if (ST.c1 != CHRTEST_VOID)
- c = utf8_target ? utf8n_to_uvchr((U8*)PL_reginput,
- UTF8_MAXBYTES, 0, uniflags)
- : (UV) UCHARAT(PL_reginput);
+ bool could_match = locinput < PL_regeol;
+
/* If it could work, try it. */
- if (ST.c1 == CHRTEST_VOID || c == (UV)ST.c1 || c == (UV)ST.c2) {
+ if (ST.c1 != CHRTEST_VOID && could_match) {
+ if (! UTF8_IS_INVARIANT(UCHARAT(locinput)) && utf8_target)
+ {
+ could_match = memEQ(locinput,
+ ST.c1_utf8,
+ UTF8SKIP(locinput))
+ || memEQ(locinput,
+ ST.c2_utf8,
+ UTF8SKIP(locinput));
+ }
+ else {
+ could_match = UCHARAT(locinput) == ST.c1
+ || UCHARAT(locinput) == ST.c2;
+ }
+ }
+ if (ST.c1 == CHRTEST_VOID || could_match) {
CURLY_SETPAREN(ST.paren, ST.count);
- PUSH_STATE_GOTO(CURLY_B_max, ST.B);
- /* NOTREACHED */
+ PUSH_STATE_GOTO(CURLY_B_max, ST.B, locinput);
+ assert(0); /* NOTREACHED */
}
}
/* FALL THROUGH */
+
case CURLY_B_max_fail:
/* failed to find B in a greedy match */
- if (ST.paren && ST.count)
- PL_regoffs[ST.paren].end = -1;
REGCP_UNWIND(ST.cp);
+ if (ST.paren) {
+ UNWIND_PAREN(ST.lastparen, ST.lastcloseparen);
+ }
/* back up. */
if (--ST.count < ST.min)
sayNO;
- PL_reginput = locinput = HOPc(locinput, -1);
+ locinput = HOPc(locinput, -1);
goto curly_try_B_max;
#undef ST
- case END:
+ case END: /* last op of main pattern */
fake_end:
if (cur_eval) {
/* we've just finished A in /(??{A})B/; now continue with B */
- I32 tmpix;
- st->u.eval.toggle_reg_flags
- = cur_eval->u.eval.toggle_reg_flags;
- PL_reg_flags ^= st->u.eval.toggle_reg_flags;
+ st->u.eval.saved_utf8_pat = is_utf8_pat;
+ is_utf8_pat = cur_eval->u.eval.saved_utf8_pat;
st->u.eval.prev_rex = rex_sv; /* inner */
- SETREX(rex_sv,cur_eval->u.eval.prev_rex);
- rex = (struct regexp *)SvANY(rex_sv);
+
+ /* Save *all* the positions. */
+ st->u.eval.cp = regcppush(rex, 0, maxopenparen);
+ rex_sv = cur_eval->u.eval.prev_rex;
+ SET_reg_curpm(rex_sv);
+ rex = ReANY(rex_sv);
rexi = RXi_GET(rex);
cur_curlyx = cur_eval->u.eval.prev_curlyx;
- (void)ReREFCNT_inc(rex_sv);
- st->u.eval.cp = regcppush(0); /* Save *all* the positions. */
- /* rex was changed so update the pointer in PL_reglastparen and PL_reglastcloseparen */
- PL_reglastparen = &rex->lastparen;
- PL_reglastcloseparen = &rex->lastcloseparen;
-
REGCP_SET(st->u.eval.lastcp);
- PL_reginput = locinput;
/* Restore parens of the outer rex without popping the
* savestack */
- tmpix = PL_savestack_ix;
- PL_savestack_ix = cur_eval->u.eval.lastcp;
- regcppop(rex);
- PL_savestack_ix = tmpix;
+ S_regcp_restore(aTHX_ rex, cur_eval->u.eval.lastcp,
+ &maxopenparen);
st->u.eval.prev_eval = cur_eval;
cur_eval = cur_eval->u.eval.prev_eval;
@@ -5430,8 +6217,8 @@
if ( nochange_depth )
nochange_depth--;
- PUSH_YES_STATE_GOTO(EVAL_AB,
- st->u.eval.prev_eval->u.eval.B); /* match B */
+ PUSH_YES_STATE_GOTO(EVAL_AB, st->u.eval.prev_eval->u.eval.B,
+ locinput); /* match B */
}
if (locinput < reginfo->till) {
@@ -5444,7 +6231,6 @@
sayNO_SILENT; /* Cannot match: too short. */
}
- PL_reginput = locinput; /* put where regtry can find it */
sayYES; /* Success! */
case SUCCEED: /* successful SUSPEND/UNLESSM/IFMATCH/CURLYM */
@@ -5452,15 +6238,17 @@
PerlIO_printf(Perl_debug_log,
"%*s %ssubpattern success...%s\n",
REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5]));
- PL_reginput = locinput; /* put where regtry can find it */
sayYES; /* Success! */
#undef ST
#define ST st->u.ifmatch
+ {
+ char *newstart;
+
case SUSPEND: /* (?>A) */
ST.wanted = 1;
- PL_reginput = locinput;
+ newstart = locinput;
goto do_ifmatch;
case UNLESSM: /* -ve lookaround: (?!A), or with flags, (?<!A) */
@@ -5485,10 +6273,10 @@
next = NULL;
break;
}
- PL_reginput = s;
+ newstart = s;
}
else
- PL_reginput = locinput;
+ newstart = locinput;
do_ifmatch:
ST.me = scan;
@@ -5496,8 +6284,9 @@
logical = 0; /* XXX: reset state of logical once it has been saved into ST */
/* execute body of (?...A) */
- PUSH_YES_STATE_GOTO(IFMATCH_A, NEXTOPER(NEXTOPER(scan)));
- /* NOTREACHED */
+ PUSH_YES_STATE_GOTO(IFMATCH_A, NEXTOPER(NEXTOPER(scan)), newstart);
+ assert(0); /* NOTREACHED */
+ }
case IFMATCH_A_fail: /* body of (?...A) failed */
ST.wanted = !ST.wanted;
@@ -5510,11 +6299,9 @@
else if (!ST.wanted)
sayNO;
- if (OP(ST.me) == SUSPEND)
- locinput = PL_reginput;
- else {
- locinput = PL_reginput = st->locinput;
- nextchr = UCHARAT(locinput);
+ if (OP(ST.me) != SUSPEND) {
+ /* restore old position except for (?>...) */
+ locinput = st->locinput;
}
scan = ST.me + ARG(ST.me);
if (scan == ST.me)
@@ -5523,40 +6310,46 @@
#undef ST
- case LONGJMP:
+ case LONGJMP: /* alternative with many branches compiles to
+ * (BRANCHJ; EXACT ...; LONGJMP ) x N */
next = scan + ARG(scan);
if (next == scan)
next = NULL;
break;
- case COMMIT:
+
+ case COMMIT: /* (*COMMIT) */
reginfo->cutpoint = PL_regeol;
/* FALLTHROUGH */
- case PRUNE:
- PL_reginput = locinput;
+
+ case PRUNE: /* (*PRUNE) */
if (!scan->flags)
sv_yes_mark = sv_commit = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
- PUSH_STATE_GOTO(COMMIT_next,next);
- /* NOTREACHED */
+ PUSH_STATE_GOTO(COMMIT_next, next, locinput);
+ assert(0); /* NOTREACHED */
+
case COMMIT_next_fail:
no_final = 1;
/* FALLTHROUGH */
- case OPFAIL:
+
+ case OPFAIL: /* (*FAIL) */
sayNO;
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
#define ST st->u.mark
- case MARKPOINT:
+ case MARKPOINT: /* (*MARK:foo) */
ST.prev_mark = mark_state;
ST.mark_name = sv_commit = sv_yes_mark
= MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
mark_state = st;
- ST.mark_loc = PL_reginput = locinput;
- PUSH_YES_STATE_GOTO(MARKPOINT_next,next);
- /* NOTREACHED */
+ ST.mark_loc = locinput;
+ PUSH_YES_STATE_GOTO(MARKPOINT_next, next, locinput);
+ assert(0); /* NOTREACHED */
+
case MARKPOINT_next:
mark_state = ST.prev_mark;
sayYES;
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
+
case MARKPOINT_next_fail:
if (popmark && sv_eq(ST.mark_name,popmark))
{
@@ -5576,14 +6369,14 @@
sv_yes_mark = mark_state ?
mark_state->u.mark.mark_name : NULL;
sayNO;
- /* NOTREACHED */
- case SKIP:
- PL_reginput = locinput;
+ assert(0); /* NOTREACHED */
+
+ case SKIP: /* (*SKIP) */
if (scan->flags) {
/* (*SKIP) : if we fail we cut here*/
ST.mark_name = NULL;
ST.mark_loc = locinput;
- PUSH_STATE_GOTO(SKIP_next,next);
+ PUSH_STATE_GOTO(SKIP_next,next, locinput);
} else {
/* (*SKIP:NAME) : if there is a (*MARK:NAME) fail where it was,
otherwise do nothing. Meaning we need to scan
@@ -5596,7 +6389,7 @@
find ) )
{
ST.mark_name = find;
- PUSH_STATE_GOTO( SKIP_next, next );
+ PUSH_STATE_GOTO( SKIP_next, next, locinput);
}
cur = cur->u.mark.prev_mark;
}
@@ -5603,6 +6396,7 @@
}
/* Didn't find our (*MARK:NAME) so ignore this (*SKIP:NAME) */
break;
+
case SKIP_next_fail:
if (ST.mark_name) {
/* (*CUT:NAME) - Set up to search for the name as we
@@ -5620,62 +6414,34 @@
}
no_final = 1;
sayNO;
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
#undef ST
- case FOLDCHAR:
- n = ARG(scan);
- if ( n == (U32)what_len_TRICKYFOLD(locinput,utf8_target,ln) ) {
- locinput += ln;
- } else if ( LATIN_SMALL_LETTER_SHARP_S == n && !utf8_target && !UTF_PATTERN ) {
- sayNO;
- } else {
- U8 folded[UTF8_MAXBYTES_CASE+1];
- STRLEN foldlen;
- const char * const l = locinput;
- char *e = PL_regeol;
- to_uni_fold(n, folded, &foldlen);
- if (! foldEQ_utf8((const char*) folded, 0, foldlen, 1,
- l, &e, 0, utf8_target)) {
- sayNO;
- }
- locinput = e;
- }
- nextchr = UCHARAT(locinput);
- break;
- case LNBREAK:
- if ((n=is_LNBREAK(locinput,utf8_target))) {
+ case LNBREAK: /* \R */
+ if ((n=is_LNBREAK_safe(locinput, PL_regeol, utf8_target))) {
locinput += n;
- nextchr = UCHARAT(locinput);
} else
sayNO;
break;
-#define CASE_CLASS(nAmE) \
- case nAmE: \
- if ((n=is_##nAmE(locinput,utf8_target))) { \
- locinput += n; \
- nextchr = UCHARAT(locinput); \
- } else \
- sayNO; \
- break; \
- case N##nAmE: \
- if ((n=is_##nAmE(locinput,utf8_target))) { \
- sayNO; \
- } else { \
- locinput += UTF8SKIP(locinput); \
- nextchr = UCHARAT(locinput); \
- } \
- break
-
- CASE_CLASS(VERTWS);
- CASE_CLASS(HORIZWS);
-#undef CASE_CLASS
-
default:
PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
PTR2UV(scan), OP(scan));
Perl_croak(aTHX_ "regexp memory corruption");
+
+ /* this is a point to jump to in order to increment
+ * locinput by one character */
+ increment_locinput:
+ assert(!NEXTCHR_IS_EOS);
+ if (utf8_target) {
+ locinput += PL_utf8skip[nextchr];
+ /* locinput is allowed to go 1 char off the end, but not 2+ */
+ if (locinput > PL_regeol)
+ sayNO;
+ }
+ else
+ locinput++;
+ break;
} /* end switch */
@@ -5682,7 +6448,7 @@
/* switch break jumps here */
scan = next; /* prepare to execute the next op and ... */
continue; /* ... jump back to the top, reusing st */
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
push_yes_state:
/* push a state that backtracks on success */
@@ -5722,11 +6488,10 @@
newst = S_push_slab(aTHX);
PL_regmatch_state = newst;
- locinput = PL_reginput;
- nextchr = UCHARAT(locinput);
+ locinput = pushinput;
st = newst;
continue;
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
}
}
@@ -5774,10 +6539,8 @@
yes_state = st->u.yes.prev_yes_state;
PL_regmatch_state = st;
- if (no_final) {
+ if (no_final)
locinput= st->locinput;
- nextchr = UCHARAT(locinput);
- }
state_num = st->resume_state + no_final;
goto reenter_switch;
}
@@ -5785,7 +6548,7 @@
DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
PL_colors[4], PL_colors[5]));
- if (PL_reg_eval_set) {
+ if (PL_reg_state.re_state_eval_setup_done) {
/* each successfully executed (?{...}) block does the equivalent of
* local $^R = do {...}
* When popping the save stack, all these locals would be undone;
@@ -5822,7 +6585,6 @@
}
PL_regmatch_state = st;
locinput= st->locinput;
- nextchr = UCHARAT(locinput);
DEBUG_STATE_pp("pop");
depth--;
@@ -5851,30 +6613,46 @@
sv_setsv(sv_mrk, sv_yes_mark);
}
+
+ if (last_pushed_cv) {
+ dSP;
+ POP_MULTICALL;
+ PERL_UNUSED_VAR(SP);
+ }
+
/* clean up; in particular, free all slabs above current one */
LEAVE_SCOPE(oldsave);
- return result;
+ assert(!result || locinput - PL_bostr >= 0);
+ return result ? locinput - PL_bostr : -1;
}
/*
- regrepeat - repeatedly match something simple, report how many
+ *
+ * What 'simple' means is a node which can be the operand of a quantifier like
+ * '+', or {1,3}
+ *
+ * startposp - pointer a pointer to the start position. This is updated
+ * to point to the byte following the highest successful
+ * match.
+ * p - the regnode to be repeatedly matched against.
+ * max - maximum number of things to match.
+ * depth - (for debugging) backtracking depth.
*/
-/*
- * [This routine now assumes that it will only match on things of length 1.
- * That was true before, but now we assume scan - reginput is the count,
- * rather than incrementing count on every character. [Er, except utf8.]]
- */
STATIC I32
-S_regrepeat(pTHX_ const regexp *prog, const regnode *p, I32 max, int depth)
+S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p,
+ I32 max, int depth, bool is_utf8_pat)
{
dVAR;
- register char *scan;
- register I32 c;
- register char *loceol = PL_regeol;
- register I32 hardcount = 0;
- register bool utf8_target = PL_reg_match_utf8;
+ char *scan; /* Pointer to current position in target string */
+ I32 c;
+ char *loceol = PL_regeol; /* local version */
+ I32 hardcount = 0; /* How many matches so far */
+ bool utf8_target = PL_reg_match_utf8;
+ int to_complement = 0; /* Invert the result? */
UV utf8_flags;
+ _char_class_number classnum;
#ifndef DEBUGGING
PERL_UNUSED_ARG(depth);
#endif
@@ -5881,15 +6659,38 @@
PERL_ARGS_ASSERT_REGREPEAT;
- scan = PL_reginput;
+ scan = *startposp;
if (max == REG_INFTY)
max = I32_MAX;
- else if (max < loceol - scan)
+ else if (! utf8_target && loceol - scan > max)
loceol = scan + max;
+
+ /* Here, for the case of a non-UTF-8 target we have adjusted <loceol> down
+ * to the maximum of how far we should go in it (leaving it set to the real
+ * end, if the maximum permissible would take us beyond that). This allows
+ * us to make the loop exit condition that we haven't gone past <loceol> to
+ * also mean that we haven't exceeded the max permissible count, saving a
+ * test each time through the loop. But it assumes that the OP matches a
+ * single byte, which is true for most of the OPs below when applied to a
+ * non-UTF-8 target. Those relatively few OPs that don't have this
+ * characteristic will have to compensate.
+ *
+ * There is no adjustment for UTF-8 targets, as the number of bytes per
+ * character varies. OPs will have to test both that the count is less
+ * than the max permissible (using <hardcount> to keep track), and that we
+ * are still within the bounds of the string (using <loceol>. A few OPs
+ * match a single byte no matter what the encoding. They can omit the max
+ * test if, for the UTF-8 case, they do the adjustment that was skipped
+ * above.
+ *
+ * Thus, the code above sets things up for the common case; and exceptional
+ * cases need extra work; the common case is to make sure <scan> doesn't
+ * go past <loceol>, and for UTF-8 to also use <hardcount> to make sure the
+ * count doesn't exceed the maximum permissible */
+
switch (OP(p)) {
case REG_ANY:
if (utf8_target) {
- loceol = PL_regeol;
while (scan < loceol && hardcount < max && *scan != '\n') {
scan += UTF8SKIP(scan);
hardcount++;
@@ -5901,7 +6702,6 @@
break;
case SANY:
if (utf8_target) {
- loceol = PL_regeol;
while (scan < loceol && hardcount < max) {
scan += UTF8SKIP(scan);
hardcount++;
@@ -5910,35 +6710,69 @@
else
scan = loceol;
break;
- case CANY:
- scan = loceol;
+ case CANY: /* Move <scan> forward <max> bytes, unless goes off end */
+ if (utf8_target && loceol - scan > max) {
+
+ /* <loceol> hadn't been adjusted in the UTF-8 case */
+ scan += max;
+ }
+ else {
+ scan = loceol;
+ }
break;
case EXACT:
- /* To get here, EXACTish nodes must have *byte* length == 1. That
- * means they match only characters in the string that can be expressed
- * as a single byte. For non-utf8 strings, that means a simple match.
- * For utf8 strings, the character matched must be an invariant, or
- * downgradable to a single byte. The pattern's utf8ness is
- * irrelevant, as since it's a single byte, it either isn't utf8, or if
- * it is, it's an invariant */
+ assert(STR_LEN(p) == is_utf8_pat ? UTF8SKIP(STRING(p)) : 1);
c = (U8)*STRING(p);
- assert(! UTF_PATTERN || UNI_IS_INVARIANT(c));
- if (! utf8_target || UNI_IS_INVARIANT(c)) {
+ /* Can use a simple loop if the pattern char to match on is invariant
+ * under UTF-8, or both target and pattern aren't UTF-8. Note that we
+ * can use UTF8_IS_INVARIANT() even if the pattern isn't UTF-8, as it's
+ * true iff it doesn't matter if the argument is in UTF-8 or not */
+ if (UTF8_IS_INVARIANT(c) || (! utf8_target && ! is_utf8_pat)) {
+ if (utf8_target && loceol - scan > max) {
+ /* We didn't adjust <loceol> because is UTF-8, but ok to do so,
+ * since here, to match at all, 1 char == 1 byte */
+ loceol = scan + max;
+ }
while (scan < loceol && UCHARAT(scan) == c) {
scan++;
}
}
- else {
+ else if (is_utf8_pat) {
+ if (utf8_target) {
+ STRLEN scan_char_len;
- /* Here, the string is utf8, and the pattern char is different
- * in utf8 than not, so can't compare them directly. Outside the
- * loop, find find the two utf8 bytes that represent c, and then
- * look for those in sequence in the utf8 string */
+ /* When both target and pattern are UTF-8, we have to do
+ * string EQ */
+ while (hardcount < max
+ && scan < loceol
+ && (scan_char_len = UTF8SKIP(scan)) <= STR_LEN(p)
+ && memEQ(scan, STRING(p), scan_char_len))
+ {
+ scan += scan_char_len;
+ hardcount++;
+ }
+ }
+ else if (! UTF8_IS_ABOVE_LATIN1(c)) {
+
+ /* Target isn't utf8; convert the character in the UTF-8
+ * pattern to non-UTF8, and do a simple loop */
+ c = TWO_BYTE_UTF8_TO_UNI(c, *(STRING(p) + 1));
+ while (scan < loceol && UCHARAT(scan) == c) {
+ scan++;
+ }
+ } /* else pattern char is above Latin1, can't possibly match the
+ non-UTF-8 target */
+ }
+ else {
+
+ /* Here, the string must be utf8; pattern isn't, and <c> is
+ * different in utf8 than not, so can't compare them directly.
+ * Outside the loop, find the two utf8 bytes that represent c, and
+ * then look for those in sequence in the utf8 string */
U8 high = UTF8_TWO_BYTE_HI(c);
U8 low = UTF8_TWO_BYTE_LO(c);
- loceol = PL_regeol;
while (hardcount < max
&& scan + 1 < loceol
@@ -5950,79 +6784,92 @@
}
}
break;
+
case EXACTFA:
utf8_flags = FOLDEQ_UTF8_NOMIX_ASCII;
goto do_exactf;
case EXACTFL:
- PL_reg_flags |= RF_tainted;
+ RXp_MATCH_TAINTED_on(prog);
utf8_flags = FOLDEQ_UTF8_LOCALE;
goto do_exactf;
case EXACTF:
+ utf8_flags = 0;
+ goto do_exactf;
+
+ case EXACTFU_SS:
+ case EXACTFU_TRICKYFOLD:
case EXACTFU:
- utf8_flags = 0;
+ utf8_flags = is_utf8_pat ? FOLDEQ_S2_ALREADY_FOLDED : 0;
- /* The comments for the EXACT case above apply as well to these fold
- * ones */
+ do_exactf: {
+ int c1, c2;
+ U8 c1_utf8[UTF8_MAXBYTES+1], c2_utf8[UTF8_MAXBYTES+1];
- do_exactf:
- c = (U8)*STRING(p);
- assert(! UTF_PATTERN || UNI_IS_INVARIANT(c));
+ assert(STR_LEN(p) == is_utf8_pat ? UTF8SKIP(STRING(p)) : 1);
- if (utf8_target) { /* Use full Unicode fold matching */
- char *tmpeol = loceol;
- while (hardcount < max
- && foldEQ_utf8_flags(scan, &tmpeol, 0, utf8_target,
- STRING(p), NULL, 1, cBOOL(UTF_PATTERN), utf8_flags))
- {
- scan = tmpeol;
- tmpeol = loceol;
- hardcount++;
- }
-
- /* XXX Note that the above handles properly the German sharp s in
- * the pattern matching ss in the string. But it doesn't handle
- * properly cases where the string contains say 'LIGATURE ff' and
- * the pattern is 'f+'. This would require, say, a new function or
- * revised interface to foldEQ_utf8(), in which the maximum number
- * of characters to match could be passed and it would return how
- * many actually did. This is just one of many cases where
- * multi-char folds don't work properly, and so the fix is being
- * deferred */
+ if (S_setup_EXACTISH_ST_c1_c2(aTHX_ p, &c1, c1_utf8, &c2, c2_utf8,
+ is_utf8_pat))
+ {
+ if (c1 == CHRTEST_VOID) {
+ /* Use full Unicode fold matching */
+ char *tmpeol = PL_regeol;
+ STRLEN pat_len = is_utf8_pat ? UTF8SKIP(STRING(p)) : 1;
+ while (hardcount < max
+ && foldEQ_utf8_flags(scan, &tmpeol, 0, utf8_target,
+ STRING(p), NULL, pat_len,
+ is_utf8_pat, utf8_flags))
+ {
+ scan = tmpeol;
+ tmpeol = PL_regeol;
+ hardcount++;
+ }
+ }
+ else if (utf8_target) {
+ if (c1 == c2) {
+ while (scan < loceol
+ && hardcount < max
+ && memEQ(scan, c1_utf8, UTF8SKIP(scan)))
+ {
+ scan += UTF8SKIP(scan);
+ hardcount++;
+ }
+ }
+ else {
+ while (scan < loceol
+ && hardcount < max
+ && (memEQ(scan, c1_utf8, UTF8SKIP(scan))
+ || memEQ(scan, c2_utf8, UTF8SKIP(scan))))
+ {
+ scan += UTF8SKIP(scan);
+ hardcount++;
+ }
+ }
+ }
+ else if (c1 == c2) {
+ while (scan < loceol && UCHARAT(scan) == c1) {
+ scan++;
+ }
+ }
+ else {
+ while (scan < loceol &&
+ (UCHARAT(scan) == c1 || UCHARAT(scan) == c2))
+ {
+ scan++;
+ }
+ }
}
- else {
- U8 folded;
-
- /* Here, the string isn't utf8 and c is a single byte; and either
- * the pattern isn't utf8 or c is an invariant, so its utf8ness
- * doesn't affect c. Can just do simple comparisons for exact or
- * fold matching. */
- switch (OP(p)) {
- case EXACTF: folded = PL_fold[c]; break;
- case EXACTFA:
- case EXACTFU: folded = PL_fold_latin1[c]; break;
- case EXACTFL: folded = PL_fold_locale[c]; break;
- default: Perl_croak(aTHX_ "panic: Unexpected op %u", OP(p));
- }
- while (scan < loceol &&
- (UCHARAT(scan) == c || UCHARAT(scan) == folded))
- {
- scan++;
- }
- }
break;
- case ANYOFV:
+ }
case ANYOF:
- if (utf8_target || OP(p) == ANYOFV) {
- STRLEN inclasslen;
- loceol = PL_regeol;
- inclasslen = loceol - scan;
+ case ANYOF_WARN_SUPER:
+ if (utf8_target) {
while (hardcount < max
- && ((inclasslen = loceol - scan) > 0)
- && reginclass(prog, p, (U8*)scan, &inclasslen, utf8_target))
+ && scan < loceol
+ && reginclass(prog, p, (U8*)scan, utf8_target))
{
- scan += inclasslen;
+ scan += UTF8SKIP(scan);
hardcount++;
}
} else {
@@ -6030,359 +6877,261 @@
scan++;
}
break;
- case ALNUMU:
- if (utf8_target) {
- utf8_wordchar:
- loceol = PL_regeol;
- LOAD_UTF8_CHARCLASS_ALNUM();
- while (hardcount < max && scan < loceol &&
- swash_fetch(PL_utf8_alnum, (U8*)scan, utf8_target))
+
+ /* The argument (FLAGS) to all the POSIX node types is the class number */
+
+ case NPOSIXL:
+ to_complement = 1;
+ /* FALLTHROUGH */
+
+ case POSIXL:
+ RXp_MATCH_TAINTED_on(prog);
+ if (! utf8_target) {
+ while (scan < loceol && to_complement ^ cBOOL(isFOO_lc(FLAGS(p),
+ *scan)))
{
- scan += UTF8SKIP(scan);
- hardcount++;
- }
- } else {
- while (scan < loceol && isWORDCHAR_L1((U8) *scan)) {
- scan++;
+ scan++;
}
- }
- break;
- case ALNUM:
- if (utf8_target)
- goto utf8_wordchar;
- while (scan < loceol && isALNUM((U8) *scan)) {
- scan++;
- }
- break;
- case ALNUMA:
- while (scan < loceol && isWORDCHAR_A((U8) *scan)) {
- scan++;
- }
- break;
- case ALNUML:
- PL_reg_flags |= RF_tainted;
- if (utf8_target) {
- loceol = PL_regeol;
- while (hardcount < max && scan < loceol &&
- isALNUM_LC_utf8((U8*)scan)) {
- scan += UTF8SKIP(scan);
+ } else {
+ while (hardcount < max && scan < loceol
+ && to_complement ^ cBOOL(isFOO_utf8_lc(FLAGS(p),
+ (U8 *) scan)))
+ {
+ scan += UTF8SKIP(scan);
hardcount++;
}
- } else {
- while (scan < loceol && isALNUM_LC(*scan))
- scan++;
}
break;
- case NALNUMU:
- if (utf8_target) {
- utf8_Nwordchar:
+ case POSIXD:
+ if (utf8_target) {
+ goto utf8_posix;
+ }
+ /* FALLTHROUGH */
- loceol = PL_regeol;
- LOAD_UTF8_CHARCLASS_ALNUM();
- while (hardcount < max && scan < loceol &&
- ! swash_fetch(PL_utf8_alnum, (U8*)scan, utf8_target))
- {
- scan += UTF8SKIP(scan);
- hardcount++;
- }
- } else {
- while (scan < loceol && ! isWORDCHAR_L1((U8) *scan)) {
- scan++;
- }
- }
- break;
- case NALNUM:
- if (utf8_target)
- goto utf8_Nwordchar;
- while (scan < loceol && ! isALNUM((U8) *scan)) {
+ case POSIXA:
+ if (utf8_target && loceol - scan > max) {
+
+ /* We didn't adjust <loceol> at the beginning of this routine
+ * because is UTF-8, but it is actually ok to do so, since here, to
+ * match, 1 char == 1 byte. */
+ loceol = scan + max;
+ }
+ while (scan < loceol && _generic_isCC_A((U8) *scan, FLAGS(p))) {
scan++;
}
break;
- case NALNUMA:
- if (utf8_target) {
- while (scan < loceol && ! isWORDCHAR_A((U8) *scan)) {
- scan += UTF8SKIP(scan);
- }
- }
- else {
- while (scan < loceol && ! isWORDCHAR_A((U8) *scan)) {
- scan++;
- }
- }
- break;
- case NALNUML:
- PL_reg_flags |= RF_tainted;
- if (utf8_target) {
- loceol = PL_regeol;
- while (hardcount < max && scan < loceol &&
- !isALNUM_LC_utf8((U8*)scan)) {
- scan += UTF8SKIP(scan);
- hardcount++;
- }
- } else {
- while (scan < loceol && !isALNUM_LC(*scan))
- scan++;
- }
- break;
- case SPACEU:
- if (utf8_target) {
- utf8_space:
+ case NPOSIXD:
+ if (utf8_target) {
+ to_complement = 1;
+ goto utf8_posix;
+ }
+ /* FALL THROUGH */
- loceol = PL_regeol;
- LOAD_UTF8_CHARCLASS_SPACE();
- while (hardcount < max && scan < loceol &&
- (*scan == ' ' ||
- swash_fetch(PL_utf8_space,(U8*)scan, utf8_target)))
- {
- scan += UTF8SKIP(scan);
- hardcount++;
- }
- break;
- }
- else {
- while (scan < loceol && isSPACE_L1((U8) *scan)) {
+ case NPOSIXA:
+ if (! utf8_target) {
+ while (scan < loceol && ! _generic_isCC_A((U8) *scan, FLAGS(p))) {
scan++;
}
- break;
- }
- case SPACE:
- if (utf8_target)
- goto utf8_space;
+ }
+ else {
- while (scan < loceol && isSPACE((U8) *scan)) {
- scan++;
- }
- break;
- case SPACEA:
- while (scan < loceol && isSPACE_A((U8) *scan)) {
- scan++;
- }
- break;
- case SPACEL:
- PL_reg_flags |= RF_tainted;
- if (utf8_target) {
- loceol = PL_regeol;
- while (hardcount < max && scan < loceol &&
- isSPACE_LC_utf8((U8*)scan)) {
- scan += UTF8SKIP(scan);
+ /* The complement of something that matches only ASCII matches all
+ * UTF-8 variant code points, plus everything in ASCII that isn't
+ * in the class. */
+ while (hardcount < max && scan < loceol
+ && (! UTF8_IS_INVARIANT(*scan)
+ || ! _generic_isCC_A((U8) *scan, FLAGS(p))))
+ {
+ scan += UTF8SKIP(scan);
hardcount++;
}
- } else {
- while (scan < loceol && isSPACE_LC(*scan))
- scan++;
- }
- break;
- case NSPACEU:
- if (utf8_target) {
+ }
+ break;
- utf8_Nspace:
+ case NPOSIXU:
+ to_complement = 1;
+ /* FALLTHROUGH */
- loceol = PL_regeol;
- LOAD_UTF8_CHARCLASS_SPACE();
- while (hardcount < max && scan < loceol &&
- ! (*scan == ' ' ||
- swash_fetch(PL_utf8_space,(U8*)scan, utf8_target)))
+ case POSIXU:
+ if (! utf8_target) {
+ while (scan < loceol && to_complement
+ ^ cBOOL(_generic_isCC((U8) *scan, FLAGS(p))))
{
- scan += UTF8SKIP(scan);
- hardcount++;
- }
- break;
+ scan++;
+ }
}
else {
- while (scan < loceol && ! isSPACE_L1((U8) *scan)) {
- scan++;
+ utf8_posix:
+ classnum = (_char_class_number) FLAGS(p);
+ if (classnum < _FIRST_NON_SWASH_CC) {
+
+ /* Here, a swash is needed for above-Latin1 code points.
+ * Process as many Latin1 code points using the built-in rules.
+ * Go to another loop to finish processing upon encountering
+ * the first Latin1 code point. We could do that in this loop
+ * as well, but the other way saves having to test if the swash
+ * has been loaded every time through the loop: extra space to
+ * save a test. */
+ while (hardcount < max && scan < loceol) {
+ if (UTF8_IS_INVARIANT(*scan)) {
+ if (! (to_complement ^ cBOOL(_generic_isCC((U8) *scan,
+ classnum))))
+ {
+ break;
+ }
+ scan++;
+ }
+ else if (UTF8_IS_DOWNGRADEABLE_START(*scan)) {
+ if (! (to_complement
+ ^ cBOOL(_generic_isCC(TWO_BYTE_UTF8_TO_UNI(*scan,
+ *(scan + 1)),
+ classnum))))
+ {
+ break;
+ }
+ scan += 2;
+ }
+ else {
+ goto found_above_latin1;
+ }
+
+ hardcount++;
+ }
}
+ else {
+ /* For these character classes, the knowledge of how to handle
+ * every code point is compiled in to Perl via a macro. This
+ * code is written for making the loops as tight as possible.
+ * It could be refactored to save space instead */
+ switch (classnum) {
+ case _CC_ENUM_SPACE: /* XXX would require separate code
+ if we revert the change of \v
+ matching this */
+ /* FALL THROUGH */
+ case _CC_ENUM_PSXSPC:
+ while (hardcount < max
+ && scan < loceol
+ && (to_complement ^ cBOOL(isSPACE_utf8(scan))))
+ {
+ scan += UTF8SKIP(scan);
+ hardcount++;
+ }
+ break;
+ case _CC_ENUM_BLANK:
+ while (hardcount < max
+ && scan < loceol
+ && (to_complement ^ cBOOL(isBLANK_utf8(scan))))
+ {
+ scan += UTF8SKIP(scan);
+ hardcount++;
+ }
+ break;
+ case _CC_ENUM_XDIGIT:
+ while (hardcount < max
+ && scan < loceol
+ && (to_complement ^ cBOOL(isXDIGIT_utf8(scan))))
+ {
+ scan += UTF8SKIP(scan);
+ hardcount++;
+ }
+ break;
+ case _CC_ENUM_VERTSPACE:
+ while (hardcount < max
+ && scan < loceol
+ && (to_complement ^ cBOOL(isVERTWS_utf8(scan))))
+ {
+ scan += UTF8SKIP(scan);
+ hardcount++;
+ }
+ break;
+ case _CC_ENUM_CNTRL:
+ while (hardcount < max
+ && scan < loceol
+ && (to_complement ^ cBOOL(isCNTRL_utf8(scan))))
+ {
+ scan += UTF8SKIP(scan);
+ hardcount++;
+ }
+ break;
+ default:
+ Perl_croak(aTHX_ "panic: regrepeat() node %d='%s' has an unexpected character class '%d'", OP(p), PL_reg_name[OP(p)], classnum);
+ }
+ }
}
- break;
- case NSPACE:
- if (utf8_target)
- goto utf8_Nspace;
+ break;
- while (scan < loceol && ! isSPACE((U8) *scan)) {
- scan++;
- }
- break;
- case NSPACEA:
- if (utf8_target) {
- while (scan < loceol && ! isSPACE_A((U8) *scan)) {
- scan += UTF8SKIP(scan);
- }
- }
- else {
- while (scan < loceol && ! isSPACE_A((U8) *scan)) {
- scan++;
- }
- }
- break;
- case NSPACEL:
- PL_reg_flags |= RF_tainted;
- if (utf8_target) {
- loceol = PL_regeol;
- while (hardcount < max && scan < loceol &&
- !isSPACE_LC_utf8((U8*)scan)) {
- scan += UTF8SKIP(scan);
- hardcount++;
- }
- } else {
- while (scan < loceol && !isSPACE_LC(*scan))
- scan++;
- }
- break;
- case DIGIT:
- if (utf8_target) {
- loceol = PL_regeol;
- LOAD_UTF8_CHARCLASS_DIGIT();
- while (hardcount < max && scan < loceol &&
- swash_fetch(PL_utf8_digit, (U8*)scan, utf8_target)) {
- scan += UTF8SKIP(scan);
- hardcount++;
- }
- } else {
- while (scan < loceol && isDIGIT(*scan))
- scan++;
- }
- break;
- case DIGITA:
- while (scan < loceol && isDIGIT_A((U8) *scan)) {
- scan++;
- }
- break;
- case DIGITL:
- PL_reg_flags |= RF_tainted;
- if (utf8_target) {
- loceol = PL_regeol;
- while (hardcount < max && scan < loceol &&
- isDIGIT_LC_utf8((U8*)scan)) {
- scan += UTF8SKIP(scan);
- hardcount++;
- }
- } else {
- while (scan < loceol && isDIGIT_LC(*scan))
- scan++;
- }
- break;
- case NDIGIT:
- if (utf8_target) {
- loceol = PL_regeol;
- LOAD_UTF8_CHARCLASS_DIGIT();
- while (hardcount < max && scan < loceol &&
- !swash_fetch(PL_utf8_digit, (U8*)scan, utf8_target)) {
- scan += UTF8SKIP(scan);
- hardcount++;
- }
- } else {
- while (scan < loceol && !isDIGIT(*scan))
- scan++;
- }
- break;
- case NDIGITA:
- if (utf8_target) {
- while (scan < loceol && ! isDIGIT_A((U8) *scan)) {
- scan += UTF8SKIP(scan);
- }
- }
- else {
- while (scan < loceol && ! isDIGIT_A((U8) *scan)) {
- scan++;
- }
- }
- break;
- case NDIGITL:
- PL_reg_flags |= RF_tainted;
- if (utf8_target) {
- loceol = PL_regeol;
- while (hardcount < max && scan < loceol &&
- !isDIGIT_LC_utf8((U8*)scan)) {
- scan += UTF8SKIP(scan);
- hardcount++;
- }
- } else {
- while (scan < loceol && !isDIGIT_LC(*scan))
- scan++;
- }
- break;
+ found_above_latin1: /* Continuation of POSIXU and NPOSIXU */
+
+ /* Load the swash if not already present */
+ if (! PL_utf8_swash_ptrs[classnum]) {
+ U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
+ PL_utf8_swash_ptrs[classnum] = _core_swash_init(
+ "utf8", swash_property_names[classnum],
+ &PL_sv_undef, 1, 0, NULL, &flags);
+ }
+
+ while (hardcount < max && scan < loceol
+ && to_complement ^ cBOOL(_generic_utf8(
+ classnum,
+ scan,
+ swash_fetch(PL_utf8_swash_ptrs[classnum],
+ (U8 *) scan,
+ TRUE))))
+ {
+ scan += UTF8SKIP(scan);
+ hardcount++;
+ }
+ break;
+
case LNBREAK:
if (utf8_target) {
- loceol = PL_regeol;
- while (hardcount < max && scan < loceol && (c=is_LNBREAK_utf8(scan))) {
+ while (hardcount < max && scan < loceol &&
+ (c=is_LNBREAK_utf8_safe(scan, loceol))) {
scan += c;
hardcount++;
}
} else {
- /*
- LNBREAK can match two latin chars, which is ok,
- because we have a null terminated string, but we
- have to use hardcount in this situation
- */
- while (scan < loceol && (c=is_LNBREAK_latin1(scan))) {
+ /* LNBREAK can match one or two latin chars, which is ok, but we
+ * have to use hardcount in this situation, and throw away the
+ * adjustment to <loceol> done before the switch statement */
+ loceol = PL_regeol;
+ while (scan < loceol && (c=is_LNBREAK_latin1_safe(scan, loceol))) {
scan+=c;
hardcount++;
}
- }
+ }
break;
- case HORIZWS:
- if (utf8_target) {
- loceol = PL_regeol;
- while (hardcount < max && scan < loceol && (c=is_HORIZWS_utf8(scan))) {
- scan += c;
- hardcount++;
- }
- } else {
- while (scan < loceol && is_HORIZWS_latin1(scan))
- scan++;
- }
- break;
- case NHORIZWS:
- if (utf8_target) {
- loceol = PL_regeol;
- while (hardcount < max && scan < loceol && !is_HORIZWS_utf8(scan)) {
- scan += UTF8SKIP(scan);
- hardcount++;
- }
- } else {
- while (scan < loceol && !is_HORIZWS_latin1(scan))
- scan++;
- }
- break;
- case VERTWS:
- if (utf8_target) {
- loceol = PL_regeol;
- while (hardcount < max && scan < loceol && (c=is_VERTWS_utf8(scan))) {
- scan += c;
- hardcount++;
- }
- } else {
- while (scan < loceol && is_VERTWS_latin1(scan))
- scan++;
+ case BOUND:
+ case BOUNDA:
+ case BOUNDL:
+ case BOUNDU:
+ case EOS:
+ case GPOS:
+ case KEEPS:
+ case NBOUND:
+ case NBOUNDA:
+ case NBOUNDL:
+ case NBOUNDU:
+ case OPFAIL:
+ case SBOL:
+ case SEOL:
+ /* These are all 0 width, so match right here or not at all. */
+ break;
- }
- break;
- case NVERTWS:
- if (utf8_target) {
- loceol = PL_regeol;
- while (hardcount < max && scan < loceol && !is_VERTWS_utf8(scan)) {
- scan += UTF8SKIP(scan);
- hardcount++;
- }
- } else {
- while (scan < loceol && !is_VERTWS_latin1(scan))
- scan++;
-
- }
- break;
+ default:
+ Perl_croak(aTHX_ "panic: regrepeat() called with unrecognized node type %d='%s'", OP(p), PL_reg_name[OP(p)]);
+ assert(0); /* NOTREACHED */
- default: /* Called on something of 0 width. */
- break; /* So match right here or not at all. */
}
if (hardcount)
c = hardcount;
else
- c = scan - PL_reginput;
- PL_reginput = scan;
+ c = scan - *startposp;
+ *startposp = scan;
DEBUG_r({
GET_RE_DEBUG_FLAGS_DECL;
@@ -6401,20 +7150,42 @@
#if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
/*
-- regclass_swash - prepare the utf8 swash
-*/
-
+- regclass_swash - prepare the utf8 swash. Wraps the shared core version to
+create a copy so that changes the caller makes won't change the shared one.
+If <altsvp> is non-null, will return NULL in it, for back-compat.
+ */
SV *
-Perl_regclass_swash(pTHX_ const regexp *prog, register const regnode* node, bool doinit, SV** listsvp, SV **altsvp)
+Perl_regclass_swash(pTHX_ const regexp *prog, const regnode* node, bool doinit, SV** listsvp, SV **altsvp)
{
+ PERL_ARGS_ASSERT_REGCLASS_SWASH;
+
+ if (altsvp) {
+ *altsvp = NULL;
+ }
+
+ return newSVsv(core_regclass_swash(prog, node, doinit, listsvp));
+}
+#endif
+
+STATIC SV *
+S_core_regclass_swash(pTHX_ const regexp *prog, const regnode* node, bool doinit, SV** listsvp)
+{
+ /* Returns the swash for the input 'node' in the regex 'prog'.
+ * If <doinit> is true, will attempt to create the swash if not already
+ * done.
+ * If <listsvp> is non-null, will return the swash initialization string in
+ * it.
+ * Tied intimately to how regcomp.c sets up the data structure */
+
dVAR;
SV *sw = NULL;
SV *si = NULL;
- SV *alt = NULL;
+ SV* invlist = NULL;
+
RXi_GET_DECL(prog,progi);
const struct reg_data * const data = prog ? progi->data : NULL;
- PERL_ARGS_ASSERT_REGCLASS_SWASH;
+ PERL_ARGS_ASSERT_CORE_REGCLASS_SWASH;
assert(ANYOF_NONBITMAP(node));
@@ -6425,34 +7196,65 @@
SV * const rv = MUTABLE_SV(data->data[n]);
AV * const av = MUTABLE_AV(SvRV(rv));
SV **const ary = AvARRAY(av);
- SV **a, **b;
+ U8 swash_init_flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
- /* See the end of regcomp.c:S_regclass() for
- * documentation of these array elements. */
+ si = *ary; /* ary[0] = the string to initialize the swash with */
- si = *ary;
- a = SvROK(ary[1]) ? &ary[1] : NULL;
- b = SvTYPE(ary[2]) == SVt_PVAV ? &ary[2] : NULL;
+ /* Elements 2 and 3 are either both present or both absent. [2] is
+ * any inversion list generated at compile time; [3] indicates if
+ * that inversion list has any user-defined properties in it. */
+ if (av_len(av) >= 2) {
+ invlist = ary[2];
+ if (SvUV(ary[3])) {
+ swash_init_flags |= _CORE_SWASH_INIT_USER_DEFINED_PROPERTY;
+ }
+ }
+ else {
+ invlist = NULL;
+ }
- if (a)
- sw = *a;
+ /* Element [1] is reserved for the set-up swash. If already there,
+ * return it; if not, create it and store it there */
+ if (SvROK(ary[1])) {
+ sw = ary[1];
+ }
else if (si && doinit) {
- sw = swash_init("utf8", "", si, 1, 0);
+
+ sw = _core_swash_init("utf8", /* the utf8 package */
+ "", /* nameless */
+ si,
+ 1, /* binary */
+ 0, /* not from tr/// */
+ invlist,
+ &swash_init_flags);
(void)av_store(av, 1, sw);
}
- if (b)
- alt = *b;
}
}
- if (listsvp)
- *listsvp = si;
- if (altsvp)
- *altsvp = alt;
+ if (listsvp) {
+ SV* matches_string = newSVpvn("", 0);
+ /* Use the swash, if any, which has to have incorporated into it all
+ * possibilities */
+ if ((! sw || (invlist = _get_swash_invlist(sw)) == NULL)
+ && (si && si != &PL_sv_undef))
+ {
+
+ /* If no swash, use the input initialization string, if available */
+ sv_catsv(matches_string, si);
+ }
+
+ /* Add the inversion list to whatever we have. This may have come from
+ * the swash, or from an input parameter */
+ if (invlist) {
+ sv_catsv(matches_string, _invlist_contents(invlist));
+ }
+ *listsvp = matches_string;
+ }
+
return sw;
}
-#endif
/*
- reginclass - determine if a character falls into a character class
@@ -6459,15 +7261,9 @@
n is the ANYOF regnode
p is the target string
- lenp is pointer to the maximum number of bytes of how far to go in p
- (This is assumed wthout checking to always be at least the current
- character's size)
utf8_target tells whether p is in UTF-8.
- Returns true if matched; false otherwise. If lenp is not NULL, on return
- from a successful match, the value it points to will be updated to how many
- bytes in p were matched. If there was no match, the value is undefined,
- possibly changed from the input.
+ Returns true if matched; false otherwise.
Note that this can be a synthetic start class, a combination of various
nodes, so things you think might be mutually exclusive, such as locale,
@@ -6476,19 +7272,19 @@
*/
STATIC bool
-S_reginclass(pTHX_ const regexp * const prog, register const regnode * const n, register const U8* const p, STRLEN* lenp, register const bool utf8_target)
+S_reginclass(pTHX_ regexp * const prog, const regnode * const n, const U8* const p, const bool utf8_target)
{
dVAR;
const char flags = ANYOF_FLAGS(n);
bool match = FALSE;
UV c = *p;
- STRLEN c_len = 0;
- STRLEN maxlen;
PERL_ARGS_ASSERT_REGINCLASS;
- /* If c is not already the code point, get it */
- if (utf8_target && !UTF8_IS_INVARIANT(c)) {
+ /* If c is not already the code point, get it. Note that
+ * UTF8_IS_INVARIANT() works even if not in UTF-8 */
+ if (! UTF8_IS_INVARIANT(c) && utf8_target) {
+ STRLEN c_len = 0;
c = utf8n_to_uvchr(p, UTF8_MAXBYTES, &c_len,
(UTF8_ALLOW_DEFAULT & UTF8_ALLOW_ANYUV)
| UTF8_ALLOW_FFFF | UTF8_CHECK_ONLY);
@@ -6497,22 +7293,7 @@
if (c_len == (STRLEN)-1)
Perl_croak(aTHX_ "Malformed UTF-8 character (fatal)");
}
- else {
- c_len = 1;
- }
- /* Use passed in max length, or one character if none passed in or less
- * than one character. And assume will match just one character. This is
- * overwritten later if matched more. */
- if (lenp) {
- maxlen = (*lenp > c_len) ? *lenp : c_len;
- *lenp = c_len;
-
- }
- else {
- maxlen = c_len;
- }
-
/* If this character is potentially in the bitmap, check it */
if (c < 256) {
if (ANYOF_BITMAP_TEST(n, c))
@@ -6523,55 +7304,64 @@
{
match = TRUE;
}
-
else if (flags & ANYOF_LOCALE) {
- PL_reg_flags |= RF_tainted;
+ RXp_MATCH_TAINTED_on(prog);
- if ((flags & ANYOF_LOC_NONBITMAP_FOLD)
+ if ((flags & ANYOF_LOC_FOLD)
&& ANYOF_BITMAP_TEST(n, PL_fold_locale[c]))
{
match = TRUE;
}
- else if (ANYOF_CLASS_TEST_ANY_SET(n) &&
- ((ANYOF_CLASS_TEST(n, ANYOF_ALNUM) && isALNUM_LC(c)) ||
- (ANYOF_CLASS_TEST(n, ANYOF_NALNUM) && !isALNUM_LC(c)) ||
- (ANYOF_CLASS_TEST(n, ANYOF_SPACE) && isSPACE_LC(c)) ||
- (ANYOF_CLASS_TEST(n, ANYOF_NSPACE) && !isSPACE_LC(c)) ||
- (ANYOF_CLASS_TEST(n, ANYOF_DIGIT) && isDIGIT_LC(c)) ||
- (ANYOF_CLASS_TEST(n, ANYOF_NDIGIT) && !isDIGIT_LC(c)) ||
- (ANYOF_CLASS_TEST(n, ANYOF_ALNUMC) && isALNUMC_LC(c)) ||
- (ANYOF_CLASS_TEST(n, ANYOF_NALNUMC) && !isALNUMC_LC(c)) ||
- (ANYOF_CLASS_TEST(n, ANYOF_ALPHA) && isALPHA_LC(c)) ||
- (ANYOF_CLASS_TEST(n, ANYOF_NALPHA) && !isALPHA_LC(c)) ||
- (ANYOF_CLASS_TEST(n, ANYOF_ASCII) && isASCII(c)) ||
- (ANYOF_CLASS_TEST(n, ANYOF_NASCII) && !isASCII(c)) ||
- (ANYOF_CLASS_TEST(n, ANYOF_CNTRL) && isCNTRL_LC(c)) ||
- (ANYOF_CLASS_TEST(n, ANYOF_NCNTRL) && !isCNTRL_LC(c)) ||
- (ANYOF_CLASS_TEST(n, ANYOF_GRAPH) && isGRAPH_LC(c)) ||
- (ANYOF_CLASS_TEST(n, ANYOF_NGRAPH) && !isGRAPH_LC(c)) ||
- (ANYOF_CLASS_TEST(n, ANYOF_LOWER) && isLOWER_LC(c)) ||
- (ANYOF_CLASS_TEST(n, ANYOF_NLOWER) && !isLOWER_LC(c)) ||
- (ANYOF_CLASS_TEST(n, ANYOF_PRINT) && isPRINT_LC(c)) ||
- (ANYOF_CLASS_TEST(n, ANYOF_NPRINT) && !isPRINT_LC(c)) ||
- (ANYOF_CLASS_TEST(n, ANYOF_PUNCT) && isPUNCT_LC(c)) ||
- (ANYOF_CLASS_TEST(n, ANYOF_NPUNCT) && !isPUNCT_LC(c)) ||
- (ANYOF_CLASS_TEST(n, ANYOF_UPPER) && isUPPER_LC(c)) ||
- (ANYOF_CLASS_TEST(n, ANYOF_NUPPER) && !isUPPER_LC(c)) ||
- (ANYOF_CLASS_TEST(n, ANYOF_XDIGIT) && isXDIGIT(c)) ||
- (ANYOF_CLASS_TEST(n, ANYOF_NXDIGIT) && !isXDIGIT(c)) ||
- (ANYOF_CLASS_TEST(n, ANYOF_PSXSPC) && isPSXSPC(c)) ||
- (ANYOF_CLASS_TEST(n, ANYOF_NPSXSPC) && !isPSXSPC(c)) ||
- (ANYOF_CLASS_TEST(n, ANYOF_BLANK) && isBLANK(c)) ||
- (ANYOF_CLASS_TEST(n, ANYOF_NBLANK) && !isBLANK(c))
- ) /* How's that for a conditional? */
- ) {
- match = TRUE;
+ else if (ANYOF_CLASS_TEST_ANY_SET(n)) {
+
+ /* The data structure is arranged so bits 0, 2, 4, ... are set
+ * if the class includes the Posix character class given by
+ * bit/2; and 1, 3, 5, ... are set if the class includes the
+ * complemented Posix class given by int(bit/2). So we loop
+ * through the bits, each time changing whether we complement
+ * the result or not. Suppose for the sake of illustration
+ * that bits 0-3 mean respectively, \w, \W, \s, \S. If bit 0
+ * is set, it means there is a match for this ANYOF node if the
+ * character is in the class given by the expression (0 / 2 = 0
+ * = \w). If it is in that class, isFOO_lc() will return 1,
+ * and since 'to_complement' is 0, the result will stay TRUE,
+ * and we exit the loop. Suppose instead that bit 0 is 0, but
+ * bit 1 is 1. That means there is a match if the character
+ * matches \W. We won't bother to call isFOO_lc() on bit 0,
+ * but will on bit 1. On the second iteration 'to_complement'
+ * will be 1, so the exclusive or will reverse things, so we
+ * are testing for \W. On the third iteration, 'to_complement'
+ * will be 0, and we would be testing for \s; the fourth
+ * iteration would test for \S, etc.
+ *
+ * Note that this code assumes that all the classes are closed
+ * under folding. For example, if a character matches \w, then
+ * its fold does too; and vice versa. This should be true for
+ * any well-behaved locale for all the currently defined Posix
+ * classes, except for :lower: and :upper:, which are handled
+ * by the pseudo-class :cased: which matches if either of the
+ * other two does. To get rid of this assumption, an outer
+ * loop could be used below to iterate over both the source
+ * character, and its fold (if different) */
+
+ int count = 0;
+ int to_complement = 0;
+ while (count < ANYOF_MAX) {
+ if (ANYOF_CLASS_TEST(n, count)
+ && to_complement ^ cBOOL(isFOO_lc(count/2, (U8) c)))
+ {
+ match = TRUE;
+ break;
+ }
+ count++;
+ to_complement ^= 1;
+ }
}
}
}
/* If the bitmap didn't (or couldn't) match, and something outside the
- * bitmap could match, try that. Locale nodes specifiy completely the
+ * bitmap could match, try that. Locale nodes specify completely the
* behavior of code points in the bit map (otherwise, a utf8 target would
* cause them to be treated as Unicode and not locale), except in
* the very unlikely event when this node is a synthetic start class, which
@@ -6588,182 +7378,47 @@
|| (utf8_target
&& (c >=256
|| (! (flags & ANYOF_LOCALE))
- || (flags & ANYOF_IS_SYNTHETIC)))))
+ || OP(n) == ANYOF_SYNTHETIC))))
{
- AV *av;
- SV * const sw = regclass_swash(prog, n, TRUE, 0, (SV**)&av);
-
+ SV * const sw = core_regclass_swash(prog, n, TRUE, 0);
if (sw) {
U8 * utf8_p;
if (utf8_target) {
utf8_p = (U8 *) p;
- } else {
-
- /* Not utf8. Convert as much of the string as available up
- * to the limit of how far the (single) character in the
- * pattern can possibly match (no need to go further). If
- * the node is a straight ANYOF or not folding, it can't
- * match more than one. Otherwise, It can match up to how
- * far a single char can fold to. Since not utf8, each
- * character is a single byte, so the max it can be in
- * bytes is the same as the max it can be in characters */
- STRLEN len = (OP(n) == ANYOF
- || ! (flags & ANYOF_LOC_NONBITMAP_FOLD))
- ? 1
- : (maxlen < UTF8_MAX_FOLD_CHAR_EXPAND)
- ? maxlen
- : UTF8_MAX_FOLD_CHAR_EXPAND;
+ } else { /* Convert to utf8 */
+ STRLEN len = 1;
utf8_p = bytes_to_utf8(p, &len);
}
- if (swash_fetch(sw, utf8_p, TRUE))
+ if (swash_fetch(sw, utf8_p, TRUE)) {
match = TRUE;
- else if (flags & ANYOF_LOC_NONBITMAP_FOLD) {
+ }
- /* Here, we need to test if the fold of the target string
- * matches. The non-multi char folds have all been moved to
- * the compilation phase, and the multi-char folds have
- * been stored by regcomp into 'av'; we linearly check to
- * see if any match the target string (folded). We know
- * that the originals were each one character, but we don't
- * currently know how many characters/bytes each folded to,
- * except we do know that there are small limits imposed by
- * Unicode. XXX A performance enhancement would be to have
- * regcomp.c store the max number of chars/bytes that are
- * in an av entry, as, say the 0th element. Even better
- * would be to have a hash of the few characters that can
- * start a multi-char fold to the max number of chars of
- * those folds.
- *
- * If there is a match, we will need to advance (if lenp is
- * specified) the match pointer in the target string. But
- * what we are comparing here isn't that string directly,
- * but its fold, whose length may differ from the original.
- * As we go along in constructing the fold, therefore, we
- * create a map so that we know how many bytes in the
- * source to advance given that we have matched a certain
- * number of bytes in the fold. This map is stored in
- * 'map_fold_len_back'. Let n mean the number of bytes in
- * the fold of the first character that we are folding.
- * Then map_fold_len_back[n] is set to the number of bytes
- * in that first character. Similarly let m be the
- * corresponding number for the second character to be
- * folded. Then map_fold_len_back[n+m] is set to the
- * number of bytes occupied by the first two source
- * characters. ... */
- U8 map_fold_len_back[UTF8_MAXBYTES_CASE+1] = { 0 };
- U8 folded[UTF8_MAXBYTES_CASE+1];
- STRLEN foldlen = 0; /* num bytes in fold of 1st char */
- STRLEN total_foldlen = 0; /* num bytes in fold of all
- chars */
-
- if (OP(n) == ANYOF || maxlen == 1 || ! lenp || ! av) {
-
- /* Here, only need to fold the first char of the target
- * string. It the source wasn't utf8, is 1 byte long */
- to_utf8_fold(utf8_p, folded, &foldlen);
- total_foldlen = foldlen;
- map_fold_len_back[foldlen] = (utf8_target)
- ? UTF8SKIP(utf8_p)
- : 1;
- }
- else {
-
- /* Here, need to fold more than the first char. Do so
- * up to the limits */
- U8* source_ptr = utf8_p; /* The source for the fold
- is the regex target
- string */
- U8* folded_ptr = folded;
- U8* e = utf8_p + maxlen; /* Can't go beyond last
- available byte in the
- target string */
- U8 i;
- for (i = 0;
- i < UTF8_MAX_FOLD_CHAR_EXPAND && source_ptr < e;
- i++)
- {
-
- /* Fold the next character */
- U8 this_char_folded[UTF8_MAXBYTES_CASE+1];
- STRLEN this_char_foldlen;
- to_utf8_fold(source_ptr,
- this_char_folded,
- &this_char_foldlen);
-
- /* Bail if it would exceed the byte limit for
- * folding a single char. */
- if (this_char_foldlen + folded_ptr - folded >
- UTF8_MAXBYTES_CASE)
- {
- break;
- }
-
- /* Add the fold of this character */
- Copy(this_char_folded,
- folded_ptr,
- this_char_foldlen,
- U8);
- source_ptr += UTF8SKIP(source_ptr);
- folded_ptr += this_char_foldlen;
- total_foldlen = folded_ptr - folded;
-
- /* Create map from the number of bytes in the fold
- * back to the number of bytes in the source. If
- * the source isn't utf8, the byte count is just
- * the number of characters so far */
- map_fold_len_back[total_foldlen]
- = (utf8_target)
- ? source_ptr - utf8_p
- : i + 1;
- }
- *folded_ptr = '\0';
- }
-
-
- /* Do the linear search to see if the fold is in the list
- * of multi-char folds. */
- if (av) {
- I32 i;
- for (i = 0; i <= av_len(av); i++) {
- SV* const sv = *av_fetch(av, i, FALSE);
- STRLEN len;
- const char * const s = SvPV_const(sv, len);
-
- if (len <= total_foldlen
- && memEQ(s, (char*)folded, len)
-
- /* If 0, means matched a partial char. See
- * [perl #90536] */
- && map_fold_len_back[len])
- {
-
- /* Advance the target string ptr to account for
- * this fold, but have to translate from the
- * folded length to the corresponding source
- * length. */
- if (lenp) {
- *lenp = map_fold_len_back[len];
- }
- match = TRUE;
- break;
- }
- }
- }
- }
-
/* If we allocated a string above, free it */
if (! utf8_target) Safefree(utf8_p);
}
}
+
+ if (UNICODE_IS_SUPER(c)
+ && OP(n) == ANYOF_WARN_SUPER
+ && ckWARN_d(WARN_NON_UNICODE))
+ {
+ Perl_warner(aTHX_ packWARN(WARN_NON_UNICODE),
+ "Code point 0x%04"UVXf" is not Unicode, all \\p{} matches fail; all \\P{} matches succeed", c);
+ }
}
- return (flags & ANYOF_INVERT) ? !match : match;
+ /* The xor complements the return if to invert: 1^1 = 0, 1^0 = 1 */
+ return cBOOL(flags & ANYOF_INVERT) ^ match;
}
STATIC U8 *
S_reghop3(U8 *s, I32 off, const U8* lim)
{
+ /* return the position 'off' UTF-8 characters away from 's', forward if
+ * 'off' >= 0, backwards if negative. But don't go outside of position
+ * 'lim', which better be < s if off < 0 */
+
dVAR;
PERL_ARGS_ASSERT_REGHOP3;
@@ -6854,24 +7509,29 @@
{
dVAR;
regexp * const rex = (regexp *)arg;
- if (PL_reg_eval_set) {
+ if (PL_reg_state.re_state_eval_setup_done) {
if (PL_reg_oldsaved) {
rex->subbeg = PL_reg_oldsaved;
rex->sublen = PL_reg_oldsavedlen;
-#ifdef PERL_OLD_COPY_ON_WRITE
+ rex->suboffset = PL_reg_oldsavedoffset;
+ rex->subcoffset = PL_reg_oldsavedcoffset;
+#ifdef PERL_ANY_COW
rex->saved_copy = PL_nrs;
#endif
RXp_MATCH_COPIED_on(rex);
}
PL_reg_magic->mg_len = PL_reg_oldpos;
- PL_reg_eval_set = 0;
+ PL_reg_state.re_state_eval_setup_done = FALSE;
PL_curpm = PL_reg_oldcurpm;
}
}
STATIC void
-S_to_utf8_substr(pTHX_ register regexp *prog)
+S_to_utf8_substr(pTHX_ regexp *prog)
{
+ /* Converts substr fields in prog from bytes to UTF-8, calling fbm_compile
+ * on the converted value */
+
int i = 1;
PERL_ARGS_ASSERT_TO_UTF8_SUBSTR;
@@ -6883,8 +7543,7 @@
prog->substrs->data[i].utf8_substr = sv;
sv_utf8_upgrade(sv);
if (SvVALID(prog->substrs->data[i].substr)) {
- const U8 flags = BmFLAGS(prog->substrs->data[i].substr);
- if (flags & FBMcf_TAIL) {
+ if (SvTAIL(prog->substrs->data[i].substr)) {
/* Trim the trailing \n that fbm_compile added last
time. */
SvCUR_set(sv, SvCUR(sv) - 1);
@@ -6891,8 +7550,9 @@
/* Whilst this makes the SV technically "invalid" (as its
buffer is no longer followed by "\0") when fbm_compile()
adds the "\n" back, a "\0" is restored. */
- }
- fbm_compile(sv, flags);
+ fbm_compile(sv, FBMcf_TAIL);
+ } else
+ fbm_compile(sv, 0);
}
if (prog->substrs->data[i].substr == prog->check_substr)
prog->check_utf8 = sv;
@@ -6900,9 +7560,12 @@
} while (i--);
}
-STATIC void
-S_to_byte_substr(pTHX_ register regexp *prog)
+STATIC bool
+S_to_byte_substr(pTHX_ regexp *prog)
{
+ /* Converts substr fields in prog from UTF-8 to bytes, calling fbm_compile
+ * on the converted value; returns FALSE if can't be converted. */
+
dVAR;
int i = 1;
@@ -6912,26 +7575,25 @@
if (prog->substrs->data[i].utf8_substr
&& !prog->substrs->data[i].substr) {
SV* sv = newSVsv(prog->substrs->data[i].utf8_substr);
- if (sv_utf8_downgrade(sv, TRUE)) {
- if (SvVALID(prog->substrs->data[i].utf8_substr)) {
- const U8 flags
- = BmFLAGS(prog->substrs->data[i].utf8_substr);
- if (flags & FBMcf_TAIL) {
- /* Trim the trailing \n that fbm_compile added last
- time. */
- SvCUR_set(sv, SvCUR(sv) - 1);
- }
- fbm_compile(sv, flags);
- }
- } else {
- SvREFCNT_dec(sv);
- sv = &PL_sv_undef;
- }
+ if (! sv_utf8_downgrade(sv, TRUE)) {
+ return FALSE;
+ }
+ if (SvVALID(prog->substrs->data[i].utf8_substr)) {
+ if (SvTAIL(prog->substrs->data[i].utf8_substr)) {
+ /* Trim the trailing \n that fbm_compile added last
+ time. */
+ SvCUR_set(sv, SvCUR(sv) - 1);
+ fbm_compile(sv, FBMcf_TAIL);
+ } else
+ fbm_compile(sv, 0);
+ }
prog->substrs->data[i].substr = sv;
if (prog->substrs->data[i].utf8_substr == prog->check_utf8)
prog->check_substr = sv;
}
} while (i--);
+
+ return TRUE;
}
/*
@@ -6938,8 +7600,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/regexec.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.4
\ No newline at end of property
Modified: trunk/contrib/perl/regexp.h
===================================================================
--- trunk/contrib/perl/regexp.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/regexp.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -18,6 +18,8 @@
/* we don't want to include this stuff if we are inside of
an external regex engine based on the core one - like re 'debug'*/
+#include "utf8.h"
+
struct regnode {
U8 flags;
U8 type;
@@ -44,17 +46,45 @@
struct reg_substr_datum data[3]; /* Actual array */
};
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
#define SV_SAVED_COPY SV *saved_copy; /* If non-NULL, SV which is COW from original */
#else
#define SV_SAVED_COPY
#endif
+/* offsets within a string of a particular /(.)/ capture */
+
typedef struct regexp_paren_pair {
I32 start;
I32 end;
+ /* 'start_tmp' records a new opening position before the matching end
+ * has been found, so that the old start and end values are still
+ * valid, e.g.
+ * "abc" =~ /(.(?{print "[$1]"}))+/
+ *outputs [][a][b]
+ * This field is not part of the API. */
+ I32 start_tmp;
} regexp_paren_pair;
+#if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_UTF8_C)
+#define _invlist_union(a, b, output) _invlist_union_maybe_complement_2nd(a, b, FALSE, output)
+#define _invlist_intersection(a, b, output) _invlist_intersection_maybe_complement_2nd(a, b, FALSE, output)
+
+/* Subtracting b from a leaves in a everything that was there that isn't in b,
+ * that is the intersection of a with b's complement */
+#define _invlist_subtract(a, b, output) _invlist_intersection_maybe_complement_2nd(a, b, TRUE, output)
+#endif
+
+/* record the position of a (?{...}) within a pattern */
+
+struct reg_code_block {
+ STRLEN start;
+ STRLEN end;
+ OP *block;
+ REGEXP *src_regex;
+};
+
+
/*
The regexp/REGEXP struct, see L<perlreapi> for further documentation
on the individual fields. The struct is ordered so that the most
@@ -74,8 +104,8 @@
/* Information about the match that the perl core uses to */ \
/* manage things */ \
U32 extflags; /* Flags used both externally and internally */ \
- I32 minlen; /* mininum possible length of string to match */\
- I32 minlenret; /* mininum possible length of $& */ \
+ I32 minlen; /* mininum possible number of chars in string to match */\
+ I32 minlenret; /* mininum possible number of chars in $& */ \
U32 gofs; /* chars left of pos that we search from */ \
/* substring data about strings that must appear in the */ \
/* final match, used for optimisations */ \
@@ -89,7 +119,6 @@
/* during matching */ \
U32 lastparen; /* last open paren matched */ \
U32 lastcloseparen; /* last close paren matched */ \
- regexp_paren_pair *swap; /* Unused: 5.10.1 and later */ \
/* Array of offsets for (@-) and (@+) */ \
regexp_paren_pair *offs; \
/* saved or original string so \digit works forever. */ \
@@ -96,11 +125,15 @@
char *subbeg; \
SV_SAVED_COPY /* If non-NULL, SV which is COW from original */\
I32 sublen; /* Length of string pointed by subbeg */ \
+ I32 suboffset; /* byte offset of subbeg from logical start of str */ \
+ I32 subcoffset; /* suboffset equiv, but in chars (for @-/@+) */ \
/* Information about the match that isn't often used */ \
/* offset from wrapped to the start of precomp */ \
PERL_BITFIELD32 pre_prefix:4; \
- /* number of eval groups in the pattern - for security checks */\
- PERL_BITFIELD32 seen_evals:28
+ /* original flags used to compile the pattern, may differ */ \
+ /* from extflags in various ways */ \
+ PERL_BITFIELD32 compflags:9; \
+ CV *qr_anoncv /* the anon sub wrapped round qr/(?{..})/ */
typedef struct regexp {
_XPV_HEAD;
@@ -143,6 +176,10 @@
#ifdef USE_ITHREADS
void* (*dupe) (pTHX_ REGEXP * const rx, CLONE_PARAMS *param);
#endif
+ REGEXP* (*op_comp) (pTHX_ SV ** const patternp, int pat_count,
+ OP *expr, const struct regexp_engine* eng,
+ REGEXP *VOL old_re,
+ bool *is_bare_re, U32 orig_rx_flags, U32 pm_flags);
} regexp_engine;
/*
@@ -150,9 +187,12 @@
paren name. >= 1 is reserved for actual numbered captures, i.e. $1,
$2 etc.
*/
-#define RX_BUFF_IDX_PREMATCH -2 /* $` / ${^PREMATCH} */
-#define RX_BUFF_IDX_POSTMATCH -1 /* $' / ${^POSTMATCH} */
-#define RX_BUFF_IDX_FULLMATCH 0 /* $& / ${^MATCH} */
+#define RX_BUFF_IDX_CARET_PREMATCH -5 /* ${^PREMATCH} */
+#define RX_BUFF_IDX_CARET_POSTMATCH -4 /* ${^POSTMATCH} */
+#define RX_BUFF_IDX_CARET_FULLMATCH -3 /* ${^MATCH} */
+#define RX_BUFF_IDX_PREMATCH -2 /* $` */
+#define RX_BUFF_IDX_POSTMATCH -1 /* $' */
+#define RX_BUFF_IDX_FULLMATCH 0 /* $& */
/*
Flags that are passed to the named_buff and named_buff_iter
@@ -296,11 +336,22 @@
/* Leave some space, so future bit allocations can go either in the shared or
* unshared area without affecting binary compatibility */
-#define RXf_BASE_SHIFT (_RXf_PMf_SHIFT_NEXT+1)
+#define RXf_BASE_SHIFT (_RXf_PMf_SHIFT_NEXT)
-/* embed.pl doesn't yet know how to handle static inline functions, so
- manually decorate them here with gcc-style attributes.
+/*
+ Set in Perl_pmruntime if op_flags & OPf_SPECIAL, i.e. split. Will
+ be used by regex engines to check whether they should set
+ RXf_SKIPWHITE
*/
+#define RXf_SPLIT (1<<(RXf_BASE_SHIFT-1))
+#if RXf_SPLIT != RXf_PMf_SPLIT
+# error "RXf_SPLIT does not match RXf_PMf_SPLIT"
+#endif
+
+/* Manually decorate this function with gcc-style attributes just to
+ * avoid having to restructure the header files and their called order,
+ * as proto.h would have to be included before this file, and isn't */
+
PERL_STATIC_INLINE const char *
get_regex_charset_name(const U32 flags, STRLEN* const lenp)
__attribute__warn_unused_result__;
@@ -326,7 +377,6 @@
default:
return "?"; /* Unknown */
}
- return "?"; /* Unknown */
}
/* Anchor and GPOS related stuff */
@@ -342,7 +392,7 @@
#define RXf_ANCH_SINGLE (RXf_ANCH_SBOL|RXf_ANCH_GPOS)
/* What we have seen */
-#define RXf_LOOKBEHIND_SEEN (1<<(RXf_BASE_SHIFT+6))
+#define RXf_NO_INPLACE_SUBST (1<<(RXf_BASE_SHIFT+6))
#define RXf_EVAL_SEEN (1<<(RXf_BASE_SHIFT+7))
#define RXf_CANY_SEEN (1<<(RXf_BASE_SHIFT+8))
@@ -357,14 +407,6 @@
#define RXf_USE_INTUIT_NOML (1<<(RXf_BASE_SHIFT+12))
#define RXf_USE_INTUIT_ML (1<<(RXf_BASE_SHIFT+13))
#define RXf_INTUIT_TAIL (1<<(RXf_BASE_SHIFT+14))
-
-/*
- Set in Perl_pmruntime if op_flags & OPf_SPECIAL, i.e. split. Will
- be used by regex engines to check whether they should set
- RXf_SKIPWHITE
-*/
-#define RXf_SPLIT (1<<(RXf_BASE_SHIFT+15))
-
#define RXf_USE_INTUIT (RXf_USE_INTUIT_NOML|RXf_USE_INTUIT_ML)
/* Copy and tainted info */
@@ -378,9 +420,9 @@
/* Flags indicating special patterns */
#define RXf_START_ONLY (1<<(RXf_BASE_SHIFT+19)) /* Pattern is /^/ */
-#define RXf_SKIPWHITE (1<<(RXf_BASE_SHIFT+20)) /* Pattern is for a split / / */
+#define RXf_SKIPWHITE (1<<(RXf_BASE_SHIFT+20)) /* Pattern is for a split " " */
#define RXf_WHITE (1<<(RXf_BASE_SHIFT+21)) /* Pattern is /\s+/ */
-#define RXf_NULL (1<<(RXf_BASE_SHIFT+22)) /* Pattern is // */
+#define RXf_NULL (1U<<(RXf_BASE_SHIFT+22)) /* Pattern is // */
#if RXf_BASE_SHIFT+22 > 31
# error Too many RXf_PMf bits used. See regnodes.h for any spare in middle
#endif
@@ -391,11 +433,25 @@
*
*/
+#if NO_TAINT_SUPPORT
+# define RX_ISTAINTED(prog) 0
+# define RX_TAINT_on(prog) NOOP
+# define RXp_MATCH_TAINTED(prog) 0
+# define RX_MATCH_TAINTED(prog) 0
+# define RXp_MATCH_TAINTED_on(prog) NOOP
+# define RX_MATCH_TAINTED_on(prog) NOOP
+# define RX_MATCH_TAINTED_off(prog) NOOP
+#else
+# define RX_ISTAINTED(prog) (RX_EXTFLAGS(prog) & RXf_TAINTED)
+# define RX_TAINT_on(prog) (RX_EXTFLAGS(prog) |= RXf_TAINTED)
+# define RXp_MATCH_TAINTED(prog) (RXp_EXTFLAGS(prog) & RXf_TAINTED_SEEN)
+# define RX_MATCH_TAINTED(prog) (RX_EXTFLAGS(prog) & RXf_TAINTED_SEEN)
+# define RXp_MATCH_TAINTED_on(prog) (RXp_EXTFLAGS(prog) |= RXf_TAINTED_SEEN)
+# define RX_MATCH_TAINTED_on(prog) (RX_EXTFLAGS(prog) |= RXf_TAINTED_SEEN)
+# define RX_MATCH_TAINTED_off(prog) (RX_EXTFLAGS(prog) &= ~RXf_TAINTED_SEEN)
+#endif
+
#define RX_HAS_CUTGROUP(prog) ((prog)->intflags & PREGf_CUTGROUP_SEEN)
-#define RXp_MATCH_TAINTED(prog) (RXp_EXTFLAGS(prog) & RXf_TAINTED_SEEN)
-#define RX_MATCH_TAINTED(prog) (RX_EXTFLAGS(prog) & RXf_TAINTED_SEEN)
-#define RX_MATCH_TAINTED_on(prog) (RX_EXTFLAGS(prog) |= RXf_TAINTED_SEEN)
-#define RX_MATCH_TAINTED_off(prog) (RX_EXTFLAGS(prog) &= ~RXf_TAINTED_SEEN)
#define RX_MATCH_TAINTED_set(prog, t) ((t) \
? RX_MATCH_TAINTED_on(prog) \
: RX_MATCH_TAINTED_off(prog))
@@ -411,71 +467,41 @@
: RX_MATCH_COPIED_off(prog))
#define RXp_EXTFLAGS(rx) ((rx)->extflags)
+#define RXp_COMPFLAGS(rx) ((rx)->compflags)
/* For source compatibility. We used to store these explicitly. */
-#define RX_PRECOMP(prog) (RX_WRAPPED(prog) + ((struct regexp *)SvANY(prog))->pre_prefix)
-#define RX_PRECOMP_const(prog) (RX_WRAPPED_const(prog) + ((struct regexp *)SvANY(prog))->pre_prefix)
+#define RX_PRECOMP(prog) (RX_WRAPPED(prog) + ReANY(prog)->pre_prefix)
+#define RX_PRECOMP_const(prog) (RX_WRAPPED_const(prog) + ReANY(prog)->pre_prefix)
/* FIXME? Are we hardcoding too much here and constraining plugin extension
writers? Specifically, the value 1 assumes that the wrapped version always
has exactly one character at the end, a ')'. Will that always be true? */
-#define RX_PRELEN(prog) (RX_WRAPLEN(prog) - ((struct regexp *)SvANY(prog))->pre_prefix - 1)
-#define RX_WRAPPED(prog) SvPVX(prog)
-#define RX_WRAPPED_const(prog) SvPVX_const(prog)
+#define RX_PRELEN(prog) (RX_WRAPLEN(prog) - ReANY(prog)->pre_prefix - 1)
+#define RX_WRAPPED(prog) ReANY(prog)->xpv_len_u.xpvlenu_pv
+#define RX_WRAPPED_const(prog) ((const char *)RX_WRAPPED(prog))
#define RX_WRAPLEN(prog) SvCUR(prog)
-#define RX_CHECK_SUBSTR(prog) (((struct regexp *)SvANY(prog))->check_substr)
+#define RX_CHECK_SUBSTR(prog) (ReANY(prog)->check_substr)
#define RX_REFCNT(prog) SvREFCNT(prog)
-#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
-# define RX_EXTFLAGS(prog) \
- (*({ \
- const REGEXP *const _rx_extflags = (prog); \
- assert(SvTYPE(_rx_extflags) == SVt_REGEXP); \
- &RXp_EXTFLAGS(SvANY(_rx_extflags)); \
- }))
-# define RX_ENGINE(prog) \
- (*({ \
- const REGEXP *const _rx_engine = (prog); \
- assert(SvTYPE(_rx_engine) == SVt_REGEXP); \
- &SvANY(_rx_engine)->engine; \
- }))
-# define RX_SUBBEG(prog) \
- (*({ \
- const REGEXP *const _rx_subbeg = (prog); \
- assert(SvTYPE(_rx_subbeg) == SVt_REGEXP); \
- &SvANY(_rx_subbeg)->subbeg; \
- }))
-# define RX_OFFS(prog) \
- (*({ \
- const REGEXP *const _rx_offs = (prog); \
- assert(SvTYPE(_rx_offs) == SVt_REGEXP); \
- &SvANY(_rx_offs)->offs; \
- }))
-# define RX_NPARENS(prog) \
- (*({ \
- const REGEXP *const _rx_nparens = (prog); \
- assert(SvTYPE(_rx_nparens) == SVt_REGEXP); \
- &SvANY(_rx_nparens)->nparens; \
- }))
-#else
-# define RX_EXTFLAGS(prog) RXp_EXTFLAGS((struct regexp *)SvANY(prog))
-# define RX_ENGINE(prog) (((struct regexp *)SvANY(prog))->engine)
-# define RX_SUBBEG(prog) (((struct regexp *)SvANY(prog))->subbeg)
-# define RX_OFFS(prog) (((struct regexp *)SvANY(prog))->offs)
-# define RX_NPARENS(prog) (((struct regexp *)SvANY(prog))->nparens)
-#endif
-#define RX_SUBLEN(prog) (((struct regexp *)SvANY(prog))->sublen)
-#define RX_MINLEN(prog) (((struct regexp *)SvANY(prog))->minlen)
-#define RX_MINLENRET(prog) (((struct regexp *)SvANY(prog))->minlenret)
-#define RX_GOFS(prog) (((struct regexp *)SvANY(prog))->gofs)
-#define RX_LASTPAREN(prog) (((struct regexp *)SvANY(prog))->lastparen)
-#define RX_LASTCLOSEPAREN(prog) (((struct regexp *)SvANY(prog))->lastcloseparen)
-#define RX_SEEN_EVALS(prog) (((struct regexp *)SvANY(prog))->seen_evals)
-#define RX_SAVED_COPY(prog) (((struct regexp *)SvANY(prog))->saved_copy)
+#define RX_EXTFLAGS(prog) RXp_EXTFLAGS(ReANY(prog))
+#define RX_COMPFLAGS(prog) RXp_COMPFLAGS(ReANY(prog))
+#define RX_ENGINE(prog) (ReANY(prog)->engine)
+#define RX_SUBBEG(prog) (ReANY(prog)->subbeg)
+#define RX_SUBOFFSET(prog) (ReANY(prog)->suboffset)
+#define RX_SUBCOFFSET(prog) (ReANY(prog)->subcoffset)
+#define RX_OFFS(prog) (ReANY(prog)->offs)
+#define RX_NPARENS(prog) (ReANY(prog)->nparens)
+#define RX_SUBLEN(prog) (ReANY(prog)->sublen)
+#define RX_MINLEN(prog) (ReANY(prog)->minlen)
+#define RX_MINLENRET(prog) (ReANY(prog)->minlenret)
+#define RX_GOFS(prog) (ReANY(prog)->gofs)
+#define RX_LASTPAREN(prog) (ReANY(prog)->lastparen)
+#define RX_LASTCLOSEPAREN(prog) (ReANY(prog)->lastcloseparen)
+#define RX_SAVED_COPY(prog) (ReANY(prog)->saved_copy)
#endif /* PLUGGABLE_RE_EXTENSION */
/* Stuff that needs to be included in the pluggable extension goes below here */
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
#define RX_MATCH_COPY_FREE(rx) \
STMT_START {if (RX_SAVED_COPY(rx)) { \
SV_CHECK_THINKFIRST_COW_DROP(RX_SAVED_COPY(rx)); \
@@ -508,6 +534,11 @@
#define REXEC_SCREAM 0x04 /* use scream table. */
#define REXEC_IGNOREPOS 0x08 /* \G matches at start. */
#define REXEC_NOT_FIRST 0x10 /* This is another iteration of //g. */
+ /* under REXEC_COPY_STR, it's ok for the
+ * engine (modulo PL_sawamperand etc)
+ * to skip copying ... */
+#define REXEC_COPY_SKIP_PRE 0x20 /* ...the $` part of the string, or */
+#define REXEC_COPY_SKIP_POST 0x40 /* ...the $' part of the string */
#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
# define ReREFCNT_inc(re) \
@@ -528,6 +559,7 @@
# define ReREFCNT_dec(re) SvREFCNT_dec(re)
# define ReREFCNT_inc(re) ((REGEXP *) SvREFCNT_inc(re))
#endif
+#define ReANY(re) S_ReANY((const REGEXP *)(re))
/* FIXME for plugins. */
@@ -549,6 +581,8 @@
SV *sv;
char *ganch;
char *cutpoint;
+ bool is_utf8_pat;
+ bool warned; /* we have issued a recursion warning; no need for more */
} regmatch_info;
@@ -580,6 +614,7 @@
/* this first element must match u.yes */
struct regmatch_state *prev_yes_state;
U32 lastparen;
+ U32 lastcloseparen;
CHECKPOINT cp;
} branchlike;
@@ -588,6 +623,7 @@
/* the first elements must match u.branchlike */
struct regmatch_state *prev_yes_state;
U32 lastparen;
+ U32 lastcloseparen;
CHECKPOINT cp;
regnode *next_branch; /* next branch node */
@@ -597,17 +633,17 @@
/* the first elements must match u.branchlike */
struct regmatch_state *prev_yes_state;
U32 lastparen;
+ U32 lastcloseparen;
CHECKPOINT cp;
U32 accepted; /* how many accepting states left */
+ bool longfold;/* saw a fold with a 1->n char mapping */
U16 *jump; /* positive offsets from me */
- regnode *B; /* node following the trie */
regnode *me; /* Which node am I - needed for jump tries*/
U8 *firstpos;/* pos in string of first trie match */
U32 firstchars;/* len in chars of firstpos from start */
U16 nextword;/* next word to try */
U16 topword; /* longest accepted word */
- bool longfold;/* saw a fold with a 1->n char mapping */
} trie;
/* special types - these members are used to store state for special
@@ -618,9 +654,7 @@
struct regmatch_state *prev_eval;
struct regmatch_state *prev_curlyx;
REGEXP *prev_rex;
- U32 toggle_reg_flags; /* what bits in PL_reg_flags to
- flip when transitioning between
- inner and outer rexen */
+ bool saved_utf8_pat; /* saved copy of is_utf8_pat */
CHECKPOINT cp; /* remember current savestack indexes */
CHECKPOINT lastcp;
U32 close_paren; /* which close bracket is our end */
@@ -678,24 +712,32 @@
struct {
/* this first element must match u.yes */
struct regmatch_state *prev_yes_state;
- I32 c1, c2; /* case fold search */
+ int c1, c2; /* case fold search */
CHECKPOINT cp;
+ U32 lastparen;
+ U32 lastcloseparen;
I32 alen; /* length of first-matched A string */
I32 count;
bool minmod;
regnode *A, *B; /* the nodes corresponding to /A*B/ */
regnode *me; /* the curlym node */
+ U8 c1_utf8[UTF8_MAXBYTES+1]; /* */
+ U8 c2_utf8[UTF8_MAXBYTES+1];
} curlym;
struct {
U32 paren;
CHECKPOINT cp;
- I32 c1, c2; /* case fold search */
+ U32 lastparen;
+ U32 lastcloseparen;
+ int c1, c2; /* case fold search */
char *maxpos; /* highest possible point in string to match */
char *oldloc; /* the previous locinput */
int count;
int min, max; /* {m,n} */
regnode *A, *B; /* the nodes corresponding to /A*B/ */
+ U8 c1_utf8[UTF8_MAXBYTES+1]; /* */
+ U8 c2_utf8[UTF8_MAXBYTES+1];
} curly; /* and CURLYN/PLUS/STAR */
} u;
@@ -713,16 +755,8 @@
struct regmatch_slab *prev, *next;
} regmatch_slab;
-#define PL_reg_flags PL_reg_state.re_state_reg_flags
#define PL_bostr PL_reg_state.re_state_bostr
-#define PL_reginput PL_reg_state.re_state_reginput
#define PL_regeol PL_reg_state.re_state_regeol
-#define PL_regoffs PL_reg_state.re_state_regoffs
-#define PL_reglastparen PL_reg_state.re_state_reglastparen
-#define PL_reglastcloseparen PL_reg_state.re_state_reglastcloseparen
-#define PL_reg_start_tmp PL_reg_state.re_state_reg_start_tmp
-#define PL_reg_start_tmpl PL_reg_state.re_state_reg_start_tmpl
-#define PL_reg_eval_set PL_reg_state.re_state_reg_eval_set
#define PL_reg_match_utf8 PL_reg_state.re_state_reg_match_utf8
#define PL_reg_magic PL_reg_state.re_state_reg_magic
#define PL_reg_oldpos PL_reg_state.re_state_reg_oldpos
@@ -730,39 +764,35 @@
#define PL_reg_curpm PL_reg_state.re_state_reg_curpm
#define PL_reg_oldsaved PL_reg_state.re_state_reg_oldsaved
#define PL_reg_oldsavedlen PL_reg_state.re_state_reg_oldsavedlen
+#define PL_reg_oldsavedoffset PL_reg_state.re_state_reg_oldsavedoffset
+#define PL_reg_oldsavedcoffset PL_reg_state.re_state_reg_oldsavedcoffset
#define PL_reg_maxiter PL_reg_state.re_state_reg_maxiter
#define PL_reg_leftiter PL_reg_state.re_state_reg_leftiter
#define PL_reg_poscache PL_reg_state.re_state_reg_poscache
#define PL_reg_poscache_size PL_reg_state.re_state_reg_poscache_size
-#define PL_regsize PL_reg_state.re_state_regsize
#define PL_reg_starttry PL_reg_state.re_state_reg_starttry
#define PL_nrs PL_reg_state.re_state_nrs
struct re_save_state {
- U32 re_state_reg_flags; /* from regexec.c */
- U32 re_state_reg_start_tmpl; /* from regexec.c */
- I32 re_state_reg_eval_set; /* from regexec.c */
+ bool re_state_eval_setup_done; /* from regexec.c */
bool re_state_reg_match_utf8; /* from regexec.c */
+ /* Space for U8 */
+ I32 re_state_reg_oldpos; /* from regexec.c */
+ I32 re_state_reg_maxiter; /* max wait until caching pos */
+ I32 re_state_reg_leftiter; /* wait until caching pos */
char *re_state_bostr;
- char *re_state_reginput; /* String-input pointer. */
char *re_state_regeol; /* End of input, for $ check. */
- regexp_paren_pair *re_state_regoffs; /* Pointer to start/end pairs */
- U32 *re_state_reglastparen; /* Similarly for lastparen. */
- U32 *re_state_reglastcloseparen; /* Similarly for lastcloseparen. */
- char **re_state_reg_start_tmp; /* from regexec.c */
MAGIC *re_state_reg_magic; /* from regexec.c */
PMOP *re_state_reg_oldcurpm; /* from regexec.c */
PMOP *re_state_reg_curpm; /* from regexec.c */
char *re_state_reg_oldsaved; /* old saved substr during match */
STRLEN re_state_reg_oldsavedlen; /* old length of saved substr during match */
+ STRLEN re_state_reg_oldsavedoffset; /* old offset of saved substr during match */
+ STRLEN re_state_reg_oldsavedcoffset;/* old coffset of saved substr during match */
STRLEN re_state_reg_poscache_size; /* size of pos cache of WHILEM */
- I32 re_state_reg_oldpos; /* from regexec.c */
- I32 re_state_reg_maxiter; /* max wait until caching pos */
- I32 re_state_reg_leftiter; /* wait until caching pos */
- U32 re_state_regsize; /* from regexec.c */
char *re_state_reg_poscache; /* cache of pos of WHILEM */
char *re_state_reg_starttry; /* from regexec.c */
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
SV *re_state_nrs; /* was placeholder: unused since 5.8.0 (5.7.2 patch #12027 for bug ID 20010815.012). Used to save rx->saved_copy */
#endif
};
@@ -774,8 +804,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/regexp.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.4
\ No newline at end of property
Modified: trunk/contrib/perl/regnodes.h
===================================================================
--- trunk/contrib/perl/regnodes.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/regnodes.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -6,8 +6,8 @@
/* Regops and State definitions */
-#define REGNODE_MAX 111
-#define REGMATCH_STATE_MAX 151
+#define REGNODE_MAX 95
+#define REGMATCH_STATE_MAX 135
#define END 0 /* 0000 End of program. */
#define SUCCEED 1 /* 0x01 Return from a subroutine, basically. */
@@ -31,96 +31,80 @@
#define SANY 19 /* 0x13 Match any one character. */
#define CANY 20 /* 0x14 Match any one byte. */
#define ANYOF 21 /* 0x15 Match character in (or not in) this class, single char match only */
-#define ANYOFV 22 /* 0x16 Match character in (or not in) this class, can match-multiple chars */
-#define ALNUM 23 /* 0x17 Match any alphanumeric character using native charset semantics for non-utf8 */
-#define ALNUML 24 /* 0x18 Match any alphanumeric char in locale */
-#define ALNUMU 25 /* 0x19 Match any alphanumeric char using Unicode semantics */
-#define ALNUMA 26 /* 0x1a Match [A-Za-z_0-9] */
-#define NALNUM 27 /* 0x1b Match any non-alphanumeric character using native charset semantics for non-utf8 */
-#define NALNUML 28 /* 0x1c Match any non-alphanumeric char in locale */
-#define NALNUMU 29 /* 0x1d Match any non-alphanumeric char using Unicode semantics */
-#define NALNUMA 30 /* 0x1e Match [^A-Za-z_0-9] */
-#define SPACE 31 /* 0x1f Match any whitespace character using native charset semantics for non-utf8 */
-#define SPACEL 32 /* 0x20 Match any whitespace char in locale */
-#define SPACEU 33 /* 0x21 Match any whitespace char using Unicode semantics */
-#define SPACEA 34 /* 0x22 Match [ \t\n\f\r] */
-#define NSPACE 35 /* 0x23 Match any non-whitespace character using native charset semantics for non-utf8 */
-#define NSPACEL 36 /* 0x24 Match any non-whitespace char in locale */
-#define NSPACEU 37 /* 0x25 Match any non-whitespace char using Unicode semantics */
-#define NSPACEA 38 /* 0x26 Match [^ \t\n\f\r] */
-#define DIGIT 39 /* 0x27 Match any numeric character using native charset semantics for non-utf8 */
-#define DIGITL 40 /* 0x28 Match any numeric character in locale */
-#define DIGITA 41 /* 0x29 Match [0-9] */
-#define NDIGIT 42 /* 0x2a Match any non-numeric character using native charset semantics for non-utf8 */
-#define NDIGITL 43 /* 0x2b Match any non-numeric character in locale */
-#define NDIGITA 44 /* 0x2c Match [^0-9] */
-#define CLUMP 45 /* 0x2d Match any extended grapheme cluster sequence */
-#define BRANCH 46 /* 0x2e Match this alternative, or the next... */
-#define BACK 47 /* 0x2f Match "", "next" ptr points backward. */
-#define EXACT 48 /* 0x30 Match this string (preceded by length). */
-#define EXACTF 49 /* 0x31 Match this string, folded, native charset semantics for non-utf8 (prec. by length). */
-#define EXACTFL 50 /* 0x32 Match this string, folded in locale (w/len). */
-#define EXACTFU 51 /* 0x33 Match this string, folded, Unicode semantics for non-utf8 (prec. by length). */
-#define EXACTFA 52 /* 0x34 Match this string, folded, Unicode semantics for non-utf8, but no ASCII-range character matches outside ASCII (prec. by length),. */
-#define NOTHING 53 /* 0x35 Match empty string. */
-#define TAIL 54 /* 0x36 Match empty string. Can jump here from outside. */
-#define STAR 55 /* 0x37 Match this (simple) thing 0 or more times. */
-#define PLUS 56 /* 0x38 Match this (simple) thing 1 or more times. */
-#define CURLY 57 /* 0x39 Match this simple thing {n,m} times. */
-#define CURLYN 58 /* 0x3a Capture next-after-this simple thing */
-#define CURLYM 59 /* 0x3b Capture this medium-complex thing {n,m} times. */
-#define CURLYX 60 /* 0x3c Match this complex thing {n,m} times. */
-#define WHILEM 61 /* 0x3d Do curly processing and see if rest matches. */
-#define OPEN 62 /* 0x3e Mark this point in input as start of */
-#define CLOSE 63 /* 0x3f Analogous to OPEN. */
-#define REF 64 /* 0x40 Match some already matched string */
-#define REFF 65 /* 0x41 Match already matched string, folded using native charset semantics for non-utf8 */
-#define REFFL 66 /* 0x42 Match already matched string, folded in loc. */
-#define REFFU 67 /* 0x43 Match already matched string, folded using unicode semantics for non-utf8 */
-#define REFFA 68 /* 0x44 Match already matched string, folded using unicode semantics for non-utf8, no mixing ASCII, non-ASCII */
-#define NREF 69 /* 0x45 Match some already matched string */
-#define NREFF 70 /* 0x46 Match already matched string, folded using native charset semantics for non-utf8 */
-#define NREFFL 71 /* 0x47 Match already matched string, folded in loc. */
-#define NREFFU 72 /* 0x48 Match already matched string, folded using unicode semantics for non-utf8 */
-#define NREFFA 73 /* 0x49 Match already matched string, folded using unicode semantics for non-utf8, no mixing ASCII, non-ASCII */
-#define IFMATCH 74 /* 0x4a Succeeds if the following matches. */
-#define UNLESSM 75 /* 0x4b Fails if the following matches. */
-#define SUSPEND 76 /* 0x4c "Independent" sub-RE. */
-#define IFTHEN 77 /* 0x4d Switch, should be preceded by switcher . */
-#define GROUPP 78 /* 0x4e Whether the group matched. */
-#define LONGJMP 79 /* 0x4f Jump far away. */
-#define BRANCHJ 80 /* 0x50 BRANCH with long offset. */
-#define EVAL 81 /* 0x51 Execute some Perl code. */
-#define MINMOD 82 /* 0x52 Next operator is not greedy. */
-#define LOGICAL 83 /* 0x53 Next opcode should set the flag only. */
-#define RENUM 84 /* 0x54 Group with independently numbered parens. */
-#define TRIE 85 /* 0x55 Match many EXACT(F[ALU]?)? at once. flags==type */
-#define TRIEC 86 /* 0x56 Same as TRIE, but with embedded charclass data */
-#define AHOCORASICK 87 /* 0x57 Aho Corasick stclass. flags==type */
-#define AHOCORASICKC 88 /* 0x58 Same as AHOCORASICK, but with embedded charclass data */
-#define GOSUB 89 /* 0x59 recurse to paren arg1 at (signed) ofs arg2 */
-#define GOSTART 90 /* 0x5a recurse to start of pattern */
-#define NGROUPP 91 /* 0x5b Whether the group matched. */
-#define INSUBP 92 /* 0x5c Whether we are in a specific recurse. */
-#define DEFINEP 93 /* 0x5d Never execute directly. */
-#define ENDLIKE 94 /* 0x5e Used only for the type field of verbs */
-#define OPFAIL 95 /* 0x5f Same as (?!) */
-#define ACCEPT 96 /* 0x60 Accepts the current matched string. */
-#define VERB 97 /* 0x61 Used only for the type field of verbs */
-#define PRUNE 98 /* 0x62 Pattern fails at this startpoint if no-backtracking through this */
-#define MARKPOINT 99 /* 0x63 Push the current location for rollback by cut. */
-#define SKIP 100 /* 0x64 On failure skip forward (to the mark) before retrying */
-#define COMMIT 101 /* 0x65 Pattern fails outright if backtracking through this */
-#define CUTGROUP 102 /* 0x66 On failure go to the next alternation in the group */
-#define KEEPS 103 /* 0x67 $& begins here. */
-#define LNBREAK 104 /* 0x68 generic newline pattern */
-#define VERTWS 105 /* 0x69 vertical whitespace (Perl 6) */
-#define NVERTWS 106 /* 0x6a not vertical whitespace (Perl 6) */
-#define HORIZWS 107 /* 0x6b horizontal whitespace (Perl 6) */
-#define NHORIZWS 108 /* 0x6c not horizontal whitespace (Perl 6) */
-#define FOLDCHAR 109 /* 0x6d codepoint with tricky case folding properties. */
-#define OPTIMIZED 110 /* 0x6e Placeholder for dump. */
-#define PSEUDO 111 /* 0x6f Pseudo opcode for internal use. */
+#define ANYOF_WARN_SUPER 22 /* 0x16 Match character in (or not in) this class, warn (if enabled) upon matching a char above Unicode max; */
+#define ANYOF_SYNTHETIC 23 /* 0x17 Synthetic start class */
+#define POSIXD 24 /* 0x18 Some [[:class:]] under /d; the FLAGS field gives which one */
+#define POSIXL 25 /* 0x19 Some [[:class:]] under /l; the FLAGS field gives which one */
+#define POSIXU 26 /* 0x1a Some [[:class:]] under /u; the FLAGS field gives which one */
+#define POSIXA 27 /* 0x1b Some [[:class:]] under /a; the FLAGS field gives which one */
+#define NPOSIXD 28 /* 0x1c complement of POSIXD, [[:^class:]] */
+#define NPOSIXL 29 /* 0x1d complement of POSIXL, [[:^class:]] */
+#define NPOSIXU 30 /* 0x1e complement of POSIXU, [[:^class:]] */
+#define NPOSIXA 31 /* 0x1f complement of POSIXA, [[:^class:]] */
+#define CLUMP 32 /* 0x20 Match any extended grapheme cluster sequence */
+#define BRANCH 33 /* 0x21 Match this alternative, or the next... */
+#define BACK 34 /* 0x22 Match "", "next" ptr points backward. */
+#define EXACT 35 /* 0x23 Match this string (preceded by length). */
+#define EXACTF 36 /* 0x24 Match this non-UTF-8 string (not guaranteed to be folded) using /id rules (w/len). */
+#define EXACTFL 37 /* 0x25 Match this string (not guaranteed to be folded) using /il rules (w/len). */
+#define EXACTFU 38 /* 0x26 Match this string (folded iff in UTF-8, length in folding doesn't change if not in UTF-8) using /iu rules (w/len). */
+#define EXACTFA 39 /* 0x27 Match this string (not guaranteed to be folded) using /iaa rules (w/len). */
+#define EXACTFU_SS 40 /* 0x28 Match this string (folded iff in UTF-8, length in folding may change even if not in UTF-8) using /iu rules (w/len). */
+#define EXACTFU_TRICKYFOLD 41 /* 0x29 Match this folded UTF-8 string using /iu rules */
+#define NOTHING 42 /* 0x2a Match empty string. */
+#define TAIL 43 /* 0x2b Match empty string. Can jump here from outside. */
+#define STAR 44 /* 0x2c Match this (simple) thing 0 or more times. */
+#define PLUS 45 /* 0x2d Match this (simple) thing 1 or more times. */
+#define CURLY 46 /* 0x2e Match this simple thing {n,m} times. */
+#define CURLYN 47 /* 0x2f Capture next-after-this simple thing */
+#define CURLYM 48 /* 0x30 Capture this medium-complex thing {n,m} times. */
+#define CURLYX 49 /* 0x31 Match this complex thing {n,m} times. */
+#define WHILEM 50 /* 0x32 Do curly processing and see if rest matches. */
+#define OPEN 51 /* 0x33 Mark this point in input as start of #n. */
+#define CLOSE 52 /* 0x34 Analogous to OPEN. */
+#define REF 53 /* 0x35 Match some already matched string */
+#define REFF 54 /* 0x36 Match already matched string, folded using native charset semantics for non-utf8 */
+#define REFFL 55 /* 0x37 Match already matched string, folded in loc. */
+#define REFFU 56 /* 0x38 Match already matched string, folded using unicode semantics for non-utf8 */
+#define REFFA 57 /* 0x39 Match already matched string, folded using unicode semantics for non-utf8, no mixing ASCII, non-ASCII */
+#define NREF 58 /* 0x3a Match some already matched string */
+#define NREFF 59 /* 0x3b Match already matched string, folded using native charset semantics for non-utf8 */
+#define NREFFL 60 /* 0x3c Match already matched string, folded in loc. */
+#define NREFFU 61 /* 0x3d Match already matched string, folded using unicode semantics for non-utf8 */
+#define NREFFA 62 /* 0x3e Match already matched string, folded using unicode semantics for non-utf8, no mixing ASCII, non-ASCII */
+#define IFMATCH 63 /* 0x3f Succeeds if the following matches. */
+#define UNLESSM 64 /* 0x40 Fails if the following matches. */
+#define SUSPEND 65 /* 0x41 "Independent" sub-RE. */
+#define IFTHEN 66 /* 0x42 Switch, should be preceded by switcher. */
+#define GROUPP 67 /* 0x43 Whether the group matched. */
+#define LONGJMP 68 /* 0x44 Jump far away. */
+#define BRANCHJ 69 /* 0x45 BRANCH with long offset. */
+#define EVAL 70 /* 0x46 Execute some Perl code. */
+#define MINMOD 71 /* 0x47 Next operator is not greedy. */
+#define LOGICAL 72 /* 0x48 Next opcode should set the flag only. */
+#define RENUM 73 /* 0x49 Group with independently numbered parens. */
+#define TRIE 74 /* 0x4a Match many EXACT(F[ALU]?)? at once. flags==type */
+#define TRIEC 75 /* 0x4b Same as TRIE, but with embedded charclass data */
+#define AHOCORASICK 76 /* 0x4c Aho Corasick stclass. flags==type */
+#define AHOCORASICKC 77 /* 0x4d Same as AHOCORASICK, but with embedded charclass data */
+#define GOSUB 78 /* 0x4e recurse to paren arg1 at (signed) ofs arg2 */
+#define GOSTART 79 /* 0x4f recurse to start of pattern */
+#define NGROUPP 80 /* 0x50 Whether the group matched. */
+#define INSUBP 81 /* 0x51 Whether we are in a specific recurse. */
+#define DEFINEP 82 /* 0x52 Never execute directly. */
+#define ENDLIKE 83 /* 0x53 Used only for the type field of verbs */
+#define OPFAIL 84 /* 0x54 Same as (?!) */
+#define ACCEPT 85 /* 0x55 Accepts the current matched string. */
+#define VERB 86 /* 0x56 Used only for the type field of verbs */
+#define PRUNE 87 /* 0x57 Pattern fails at this startpoint if no-backtracking through this */
+#define MARKPOINT 88 /* 0x58 Push the current location for rollback by cut. */
+#define SKIP 89 /* 0x59 On failure skip forward (to the mark) before retrying */
+#define COMMIT 90 /* 0x5a Pattern fails outright if backtracking through this */
+#define CUTGROUP 91 /* 0x5b On failure go to the next alternation in the group */
+#define KEEPS 92 /* 0x5c $& begins here. */
+#define LNBREAK 93 /* 0x5d generic newline pattern */
+#define OPTIMIZED 94 /* 0x5e Placeholder for dump. */
+#define PSEUDO 95 /* 0x5f Pseudo opcode for internal use. */
/* ------------ States ------------- */
#define TRIE_next (REGNODE_MAX + 1) /* state for TRIE */
#define TRIE_next_fail (REGNODE_MAX + 2) /* state for TRIE */
@@ -191,29 +175,16 @@
REG_ANY, /* SANY */
REG_ANY, /* CANY */
ANYOF, /* ANYOF */
- ANYOF, /* ANYOFV */
- ALNUM, /* ALNUM */
- ALNUM, /* ALNUML */
- ALNUM, /* ALNUMU */
- ALNUM, /* ALNUMA */
- NALNUM, /* NALNUM */
- NALNUM, /* NALNUML */
- NALNUM, /* NALNUMU */
- NALNUM, /* NALNUMA */
- SPACE, /* SPACE */
- SPACE, /* SPACEL */
- SPACE, /* SPACEU */
- SPACE, /* SPACEA */
- NSPACE, /* NSPACE */
- NSPACE, /* NSPACEL */
- NSPACE, /* NSPACEU */
- NSPACE, /* NSPACEA */
- DIGIT, /* DIGIT */
- DIGIT, /* DIGITL */
- DIGIT, /* DIGITA */
- NDIGIT, /* NDIGIT */
- NDIGIT, /* NDIGITL */
- NDIGIT, /* NDIGITA */
+ ANYOF, /* ANYOF_WARN_SUPER */
+ ANYOF, /* ANYOF_SYNTHETIC */
+ POSIXD, /* POSIXD */
+ POSIXD, /* POSIXL */
+ POSIXD, /* POSIXU */
+ POSIXD, /* POSIXA */
+ NPOSIXD, /* NPOSIXD */
+ NPOSIXD, /* NPOSIXL */
+ NPOSIXD, /* NPOSIXU */
+ NPOSIXD, /* NPOSIXA */
CLUMP, /* CLUMP */
BRANCH, /* BRANCH */
BACK, /* BACK */
@@ -222,6 +193,8 @@
EXACT, /* EXACTFL */
EXACT, /* EXACTFU */
EXACT, /* EXACTFA */
+ EXACT, /* EXACTFU_SS */
+ EXACT, /* EXACTFU_TRICKYFOLD */
NOTHING, /* NOTHING */
NOTHING, /* TAIL */
STAR, /* STAR */
@@ -274,11 +247,6 @@
VERB, /* CUTGROUP */
KEEPS, /* KEEPS */
LNBREAK, /* LNBREAK */
- VERTWS, /* VERTWS */
- NVERTWS, /* NVERTWS */
- HORIZWS, /* HORIZWS */
- NHORIZWS, /* NHORIZWS */
- FOLDCHAR, /* FOLDCHAR */
NOTHING, /* OPTIMIZED */
PSEUDO, /* PSEUDO */
/* ------------ States ------------- */
@@ -351,29 +319,16 @@
0, /* SANY */
0, /* CANY */
0, /* ANYOF */
- 0, /* ANYOFV */
- 0, /* ALNUM */
- 0, /* ALNUML */
- 0, /* ALNUMU */
- 0, /* ALNUMA */
- 0, /* NALNUM */
- 0, /* NALNUML */
- 0, /* NALNUMU */
- 0, /* NALNUMA */
- 0, /* SPACE */
- 0, /* SPACEL */
- 0, /* SPACEU */
- 0, /* SPACEA */
- 0, /* NSPACE */
- 0, /* NSPACEL */
- 0, /* NSPACEU */
- 0, /* NSPACEA */
- 0, /* DIGIT */
- 0, /* DIGITL */
- 0, /* DIGITA */
- 0, /* NDIGIT */
- 0, /* NDIGITL */
- 0, /* NDIGITA */
+ 0, /* ANYOF_WARN_SUPER */
+ 0, /* ANYOF_SYNTHETIC */
+ 0, /* POSIXD */
+ 0, /* POSIXL */
+ 0, /* POSIXU */
+ 0, /* POSIXA */
+ 0, /* NPOSIXD */
+ 0, /* NPOSIXL */
+ 0, /* NPOSIXU */
+ 0, /* NPOSIXA */
0, /* CLUMP */
0, /* BRANCH */
0, /* BACK */
@@ -382,6 +337,8 @@
0, /* EXACTFL */
0, /* EXACTFU */
0, /* EXACTFA */
+ 0, /* EXACTFU_SS */
+ 0, /* EXACTFU_TRICKYFOLD */
0, /* NOTHING */
0, /* TAIL */
0, /* STAR */
@@ -434,11 +391,6 @@
EXTRA_SIZE(struct regnode_1), /* CUTGROUP */
0, /* KEEPS */
0, /* LNBREAK */
- 0, /* VERTWS */
- 0, /* NVERTWS */
- 0, /* HORIZWS */
- 0, /* NHORIZWS */
- EXTRA_SIZE(struct regnode_1), /* FOLDCHAR */
0, /* OPTIMIZED */
0, /* PSEUDO */
};
@@ -468,29 +420,16 @@
0, /* SANY */
0, /* CANY */
0, /* ANYOF */
- 0, /* ANYOFV */
- 0, /* ALNUM */
- 0, /* ALNUML */
- 0, /* ALNUMU */
- 0, /* ALNUMA */
- 0, /* NALNUM */
- 0, /* NALNUML */
- 0, /* NALNUMU */
- 0, /* NALNUMA */
- 0, /* SPACE */
- 0, /* SPACEL */
- 0, /* SPACEU */
- 0, /* SPACEA */
- 0, /* NSPACE */
- 0, /* NSPACEL */
- 0, /* NSPACEU */
- 0, /* NSPACEA */
- 0, /* DIGIT */
- 0, /* DIGITL */
- 0, /* DIGITA */
- 0, /* NDIGIT */
- 0, /* NDIGITL */
- 0, /* NDIGITA */
+ 0, /* ANYOF_WARN_SUPER */
+ 0, /* ANYOF_SYNTHETIC */
+ 0, /* POSIXD */
+ 0, /* POSIXL */
+ 0, /* POSIXU */
+ 0, /* POSIXA */
+ 0, /* NPOSIXD */
+ 0, /* NPOSIXL */
+ 0, /* NPOSIXU */
+ 0, /* NPOSIXA */
0, /* CLUMP */
0, /* BRANCH */
0, /* BACK */
@@ -499,6 +438,8 @@
0, /* EXACTFL */
0, /* EXACTFU */
0, /* EXACTFA */
+ 0, /* EXACTFU_SS */
+ 0, /* EXACTFU_TRICKYFOLD */
0, /* NOTHING */
0, /* TAIL */
0, /* STAR */
@@ -551,11 +492,6 @@
0, /* CUTGROUP */
0, /* KEEPS */
0, /* LNBREAK */
- 0, /* VERTWS */
- 0, /* NVERTWS */
- 0, /* HORIZWS */
- 0, /* NHORIZWS */
- 0, /* FOLDCHAR */
0, /* OPTIMIZED */
0, /* PSEUDO */
};
@@ -590,96 +526,80 @@
"SANY", /* 0x13 */
"CANY", /* 0x14 */
"ANYOF", /* 0x15 */
- "ANYOFV", /* 0x16 */
- "ALNUM", /* 0x17 */
- "ALNUML", /* 0x18 */
- "ALNUMU", /* 0x19 */
- "ALNUMA", /* 0x1a */
- "NALNUM", /* 0x1b */
- "NALNUML", /* 0x1c */
- "NALNUMU", /* 0x1d */
- "NALNUMA", /* 0x1e */
- "SPACE", /* 0x1f */
- "SPACEL", /* 0x20 */
- "SPACEU", /* 0x21 */
- "SPACEA", /* 0x22 */
- "NSPACE", /* 0x23 */
- "NSPACEL", /* 0x24 */
- "NSPACEU", /* 0x25 */
- "NSPACEA", /* 0x26 */
- "DIGIT", /* 0x27 */
- "DIGITL", /* 0x28 */
- "DIGITA", /* 0x29 */
- "NDIGIT", /* 0x2a */
- "NDIGITL", /* 0x2b */
- "NDIGITA", /* 0x2c */
- "CLUMP", /* 0x2d */
- "BRANCH", /* 0x2e */
- "BACK", /* 0x2f */
- "EXACT", /* 0x30 */
- "EXACTF", /* 0x31 */
- "EXACTFL", /* 0x32 */
- "EXACTFU", /* 0x33 */
- "EXACTFA", /* 0x34 */
- "NOTHING", /* 0x35 */
- "TAIL", /* 0x36 */
- "STAR", /* 0x37 */
- "PLUS", /* 0x38 */
- "CURLY", /* 0x39 */
- "CURLYN", /* 0x3a */
- "CURLYM", /* 0x3b */
- "CURLYX", /* 0x3c */
- "WHILEM", /* 0x3d */
- "OPEN", /* 0x3e */
- "CLOSE", /* 0x3f */
- "REF", /* 0x40 */
- "REFF", /* 0x41 */
- "REFFL", /* 0x42 */
- "REFFU", /* 0x43 */
- "REFFA", /* 0x44 */
- "NREF", /* 0x45 */
- "NREFF", /* 0x46 */
- "NREFFL", /* 0x47 */
- "NREFFU", /* 0x48 */
- "NREFFA", /* 0x49 */
- "IFMATCH", /* 0x4a */
- "UNLESSM", /* 0x4b */
- "SUSPEND", /* 0x4c */
- "IFTHEN", /* 0x4d */
- "GROUPP", /* 0x4e */
- "LONGJMP", /* 0x4f */
- "BRANCHJ", /* 0x50 */
- "EVAL", /* 0x51 */
- "MINMOD", /* 0x52 */
- "LOGICAL", /* 0x53 */
- "RENUM", /* 0x54 */
- "TRIE", /* 0x55 */
- "TRIEC", /* 0x56 */
- "AHOCORASICK", /* 0x57 */
- "AHOCORASICKC", /* 0x58 */
- "GOSUB", /* 0x59 */
- "GOSTART", /* 0x5a */
- "NGROUPP", /* 0x5b */
- "INSUBP", /* 0x5c */
- "DEFINEP", /* 0x5d */
- "ENDLIKE", /* 0x5e */
- "OPFAIL", /* 0x5f */
- "ACCEPT", /* 0x60 */
- "VERB", /* 0x61 */
- "PRUNE", /* 0x62 */
- "MARKPOINT", /* 0x63 */
- "SKIP", /* 0x64 */
- "COMMIT", /* 0x65 */
- "CUTGROUP", /* 0x66 */
- "KEEPS", /* 0x67 */
- "LNBREAK", /* 0x68 */
- "VERTWS", /* 0x69 */
- "NVERTWS", /* 0x6a */
- "HORIZWS", /* 0x6b */
- "NHORIZWS", /* 0x6c */
- "FOLDCHAR", /* 0x6d */
- "OPTIMIZED", /* 0x6e */
- "PSEUDO", /* 0x6f */
+ "ANYOF_WARN_SUPER", /* 0x16 */
+ "ANYOF_SYNTHETIC", /* 0x17 */
+ "POSIXD", /* 0x18 */
+ "POSIXL", /* 0x19 */
+ "POSIXU", /* 0x1a */
+ "POSIXA", /* 0x1b */
+ "NPOSIXD", /* 0x1c */
+ "NPOSIXL", /* 0x1d */
+ "NPOSIXU", /* 0x1e */
+ "NPOSIXA", /* 0x1f */
+ "CLUMP", /* 0x20 */
+ "BRANCH", /* 0x21 */
+ "BACK", /* 0x22 */
+ "EXACT", /* 0x23 */
+ "EXACTF", /* 0x24 */
+ "EXACTFL", /* 0x25 */
+ "EXACTFU", /* 0x26 */
+ "EXACTFA", /* 0x27 */
+ "EXACTFU_SS", /* 0x28 */
+ "EXACTFU_TRICKYFOLD", /* 0x29 */
+ "NOTHING", /* 0x2a */
+ "TAIL", /* 0x2b */
+ "STAR", /* 0x2c */
+ "PLUS", /* 0x2d */
+ "CURLY", /* 0x2e */
+ "CURLYN", /* 0x2f */
+ "CURLYM", /* 0x30 */
+ "CURLYX", /* 0x31 */
+ "WHILEM", /* 0x32 */
+ "OPEN", /* 0x33 */
+ "CLOSE", /* 0x34 */
+ "REF", /* 0x35 */
+ "REFF", /* 0x36 */
+ "REFFL", /* 0x37 */
+ "REFFU", /* 0x38 */
+ "REFFA", /* 0x39 */
+ "NREF", /* 0x3a */
+ "NREFF", /* 0x3b */
+ "NREFFL", /* 0x3c */
+ "NREFFU", /* 0x3d */
+ "NREFFA", /* 0x3e */
+ "IFMATCH", /* 0x3f */
+ "UNLESSM", /* 0x40 */
+ "SUSPEND", /* 0x41 */
+ "IFTHEN", /* 0x42 */
+ "GROUPP", /* 0x43 */
+ "LONGJMP", /* 0x44 */
+ "BRANCHJ", /* 0x45 */
+ "EVAL", /* 0x46 */
+ "MINMOD", /* 0x47 */
+ "LOGICAL", /* 0x48 */
+ "RENUM", /* 0x49 */
+ "TRIE", /* 0x4a */
+ "TRIEC", /* 0x4b */
+ "AHOCORASICK", /* 0x4c */
+ "AHOCORASICKC", /* 0x4d */
+ "GOSUB", /* 0x4e */
+ "GOSTART", /* 0x4f */
+ "NGROUPP", /* 0x50 */
+ "INSUBP", /* 0x51 */
+ "DEFINEP", /* 0x52 */
+ "ENDLIKE", /* 0x53 */
+ "OPFAIL", /* 0x54 */
+ "ACCEPT", /* 0x55 */
+ "VERB", /* 0x56 */
+ "PRUNE", /* 0x57 */
+ "MARKPOINT", /* 0x58 */
+ "SKIP", /* 0x59 */
+ "COMMIT", /* 0x5a */
+ "CUTGROUP", /* 0x5b */
+ "KEEPS", /* 0x5c */
+ "LNBREAK", /* 0x5d */
+ "OPTIMIZED", /* 0x5e */
+ "PSEUDO", /* 0x5f */
/* ------------ States ------------- */
"TRIE_next", /* REGNODE_MAX +0x01 */
"TRIE_next_fail", /* REGNODE_MAX +0x02 */
@@ -730,16 +650,16 @@
EXTCONST char * PL_reg_extflags_name[];
#else
EXTCONST char * const PL_reg_extflags_name[] = {
- /* Bits in extflags defined: 11111111111111111111111011111111 */
+ /* Bits in extflags defined: 11111110111111111111111111111111 */
"MULTILINE", /* 0x00000001 */
"SINGLELINE", /* 0x00000002 */
"FOLD", /* 0x00000004 */
"EXTENDED", /* 0x00000008 */
"KEEPCOPY", /* 0x00000010 */
- "CHARSET", /* 0x000000e0 */
- "CHARSET", /* 0x000000e0 */
- "CHARSET", /* 0x000000e0 */
- "UNUSED_BIT_8", /* 0x00000100 */
+ "CHARSET0", /* 0x00000020 : "CHARSET" - 0x000000e0 */
+ "CHARSET1", /* 0x00000040 : "CHARSET" - 0x000000e0 */
+ "CHARSET2", /* 0x00000080 : "CHARSET" - 0x000000e0 */
+ "SPLIT", /* 0x00000100 */
"ANCH_BOL", /* 0x00000200 */
"ANCH_MBOL", /* 0x00000400 */
"ANCH_SBOL", /* 0x00000800 */
@@ -746,7 +666,7 @@
"ANCH_GPOS", /* 0x00001000 */
"GPOS_SEEN", /* 0x00002000 */
"GPOS_FLOAT", /* 0x00004000 */
- "LOOKBEHIND_SEEN", /* 0x00008000 */
+ "NO_INPLACE_SUBST", /* 0x00008000 */
"EVAL_SEEN", /* 0x00010000 */
"CANY_SEEN", /* 0x00020000 */
"NOSCAN", /* 0x00040000 */
@@ -755,7 +675,7 @@
"USE_INTUIT_NOML", /* 0x00200000 */
"USE_INTUIT_ML", /* 0x00400000 */
"INTUIT_TAIL", /* 0x00800000 */
- "SPLIT", /* 0x01000000 */
+ "UNUSED_BIT_24", /* 0x01000000 */
"COPY_DONE", /* 0x02000000 */
"TAINTED_SEEN", /* 0x04000000 */
"TAINTED", /* 0x08000000 */
@@ -773,9 +693,9 @@
EXTCONST U8 PL_varies[] __attribute__deprecated__;
#else
EXTCONST U8 PL_varies[] __attribute__deprecated__ = {
- ANYOFV, CLUMP, BRANCH, BACK, STAR, PLUS, CURLY, CURLYN, CURLYM, CURLYX,
- WHILEM, REF, REFF, REFFL, REFFU, REFFA, NREF, NREFF, NREFFL, NREFFU,
- NREFFA, SUSPEND, IFTHEN, BRANCHJ,
+ CLUMP, BRANCH, BACK, STAR, PLUS, CURLY, CURLYN, CURLYM, CURLYX, WHILEM,
+ REF, REFF, REFFL, REFFU, REFFA, NREF, NREFF, NREFFL, NREFFU, NREFFA,
+ SUSPEND, IFTHEN, BRANCHJ,
0
};
#endif /* DOINIT */
@@ -784,7 +704,7 @@
EXTCONST U8 PL_varies_bitmask[];
#else
EXTCONST U8 PL_varies_bitmask[] = {
- 0x00, 0x00, 0x40, 0x00, 0x00, 0xE0, 0x80, 0x3F, 0xFF, 0x33, 0x01, 0x00, 0x00, 0x00
+ 0x00, 0x00, 0x00, 0x00, 0x07, 0xF0, 0xE7, 0x7F, 0x26, 0x00, 0x00, 0x00
};
#endif /* DOINIT */
@@ -796,10 +716,8 @@
EXTCONST U8 PL_simple[] __attribute__deprecated__;
#else
EXTCONST U8 PL_simple[] __attribute__deprecated__ = {
- REG_ANY, SANY, CANY, ANYOF, ALNUM, ALNUML, ALNUMU, ALNUMA, NALNUM,
- NALNUML, NALNUMU, NALNUMA, SPACE, SPACEL, SPACEU, SPACEA, NSPACE,
- NSPACEL, NSPACEU, NSPACEA, DIGIT, DIGITL, DIGITA, NDIGIT, NDIGITL,
- NDIGITA, VERTWS, NVERTWS, HORIZWS, NHORIZWS,
+ REG_ANY, SANY, CANY, ANYOF, ANYOF_WARN_SUPER, ANYOF_SYNTHETIC, POSIXD,
+ POSIXL, POSIXU, POSIXA, NPOSIXD, NPOSIXL, NPOSIXU, NPOSIXA,
0
};
#endif /* DOINIT */
@@ -808,7 +726,7 @@
EXTCONST U8 PL_simple_bitmask[];
#else
EXTCONST U8 PL_simple_bitmask[] = {
- 0x00, 0x00, 0xBC, 0xFF, 0xFF, 0x1F, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x1E
+ 0x00, 0x00, 0xFC, 0xFF, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00
};
#endif /* DOINIT */
Property changes on: trunk/contrib/perl/regnodes.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/run.c
===================================================================
--- trunk/contrib/perl/run.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/run.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -30,7 +30,7 @@
* Now we are come to the lands where you were foaled, and every stone you
* know. Run now! Hope is in speed!' --Gandalf
*
- * [p.600 of _The Lord of the Rings_, III/xi: "The Palant\xEDr"]
+ * [p.600 of _The Lord of the Rings_, III/xi: "The PalantÃr"]
*/
int
@@ -37,9 +37,12 @@
Perl_runops_standard(pTHX)
{
dVAR;
- register OP *op = PL_op;
+ OP *op = PL_op;
+ OP_ENTRY_PROBE(OP_NAME(op));
while ((PL_op = op = op->op_ppaddr(aTHX))) {
+ OP_ENTRY_PROBE(OP_NAME(op));
}
+ PERL_ASYNC_CHECK();
TAINT_NOT;
return 0;
@@ -49,8 +52,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/run.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/runtests.SH
===================================================================
--- trunk/contrib/perl/runtests.SH 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/runtests.SH 2013-12-02 21:18:17 UTC (rev 6438)
@@ -1,3 +1,5 @@
+#!/bin/sh
+
case $PERL_CONFIG_SH in
'')
if test ! -f config.sh; then
Property changes on: trunk/contrib/perl/runtests.SH
___________________________________________________________________
Deleted: svn:executable
## -1 +0,0 ##
-*
\ No newline at end of property
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/scope.c
===================================================================
--- trunk/contrib/perl/scope.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/scope.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -160,11 +160,13 @@
/* XXX should tmps_floor live in cxstack? */
const I32 myfloor = PL_tmps_floor;
while (PL_tmps_ix > myfloor) { /* clean up after last statement */
- SV* const sv = PL_tmps_stack[PL_tmps_ix];
- PL_tmps_stack[PL_tmps_ix--] = NULL;
+ SV* const sv = PL_tmps_stack[PL_tmps_ix--];
+#ifdef PERL_POISON
+ PoisonWith(PL_tmps_stack + PL_tmps_ix + 1, 1, SV *, 0xAB);
+#endif
if (sv && sv != &PL_sv_undef) {
SvTEMP_off(sv);
- SvREFCNT_dec(sv); /* note, can modify tmps_ix!!! */
+ SvREFCNT_dec_NN(sv); /* note, can modify tmps_ix!!! */
}
}
}
@@ -174,7 +176,7 @@
{
dVAR;
SV * osv;
- register SV *sv;
+ SV *sv;
PERL_ARGS_ASSERT_SAVE_SCALAR_AT;
@@ -181,7 +183,7 @@
osv = *sptr;
sv = (flags & SAVEf_KEEPOLDELEM) ? osv : (*sptr = newSV(0));
- if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv) && SvTYPE(osv) != SVt_PVGV) {
+ if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv)) {
if (SvGMAGICAL(osv)) {
SvFLAGS(osv) |= (SvFLAGS(osv) &
(SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
@@ -197,10 +199,11 @@
Perl_save_pushptrptr(pTHX_ void *const ptr1, void *const ptr2, const int type)
{
dVAR;
- SSCHECK(3);
- SSPUSHPTR(ptr1);
- SSPUSHPTR(ptr2);
- SSPUSHUV(type);
+ dSS_ADD;
+ SS_ADD_PTR(ptr1);
+ SS_ADD_PTR(ptr2);
+ SS_ADD_UV(type);
+ SS_ADD_END(3);
}
SV *
@@ -211,9 +214,11 @@
PERL_ARGS_ASSERT_SAVE_SCALAR;
- PL_localizing = 1;
- SvGETMAGIC(*sptr);
- PL_localizing = 0;
+ if (SvGMAGICAL(*sptr)) {
+ PL_localizing = 1;
+ (void)mg_get(*sptr);
+ PL_localizing = 0;
+ }
save_pushptrptr(SvREFCNT_inc_simple(gv), SvREFCNT_inc(*sptr), SAVEt_SV);
return save_scalar_at(sptr, SAVEf_SETMAGIC); /* XXX - FIXME - see #60360 */
}
@@ -262,14 +267,15 @@
Perl_save_set_svflags(pTHX_ SV* sv, U32 mask, U32 val)
{
dVAR;
+ dSS_ADD;
PERL_ARGS_ASSERT_SAVE_SET_SVFLAGS;
- SSCHECK(4);
- SSPUSHPTR(sv);
- SSPUSHINT(mask);
- SSPUSHINT(val);
- SSPUSHUV(SAVEt_SET_SVFLAGS);
+ SS_ADD_PTR(sv);
+ SS_ADD_INT(mask);
+ SS_ADD_INT(val);
+ SS_ADD_UV(SAVEt_SET_SVFLAGS);
+ SS_ADD_END(4);
}
void
@@ -283,22 +289,22 @@
if (empty) {
GP *gp = Perl_newGP(aTHX_ gv);
+ HV * const stash = GvSTASH(gv);
+ bool isa_changed = 0;
- if (GvCVu(gv))
- mro_method_changed_in(GvSTASH(gv)); /* taking a method out of circulation ("local")*/
+ if (stash && HvENAME(stash)) {
+ if (GvNAMELEN(gv) == 3 && strnEQ(GvNAME(gv), "ISA", 3))
+ isa_changed = TRUE;
+ else if (GvCVu(gv))
+ /* taking a method out of circulation ("local")*/
+ mro_method_changed_in(stash);
+ }
if (GvIOp(gv) && (IoFLAGS(GvIOp(gv)) & IOf_ARGV)) {
gp->gp_io = newIO();
IoFLAGS(gp->gp_io) |= IOf_ARGV|IOf_START;
}
-#ifdef PERL_DONT_CREATE_GVSV
- if (gv == PL_errgv) {
- /* We could scatter this logic everywhere by changing the
- definition of ERRSV from GvSV() to GvSVn(), but it seems more
- efficient to do this check once here. */
- gp->gp_sv = newSV(0);
- }
-#endif
GvGP_set(gv,gp);
+ if (isa_changed) mro_isa_changed_in(stash);
}
else {
gp_ref(GvGP(gv));
@@ -317,7 +323,7 @@
if (!AvREAL(oav) && AvREIFY(oav))
av_reify(oav);
- save_pushptrptr(gv, oav, SAVEt_AV);
+ save_pushptrptr(SvREFCNT_inc_simple_NN(gv), oav, SAVEt_AV);
GvAV(gv) = NULL;
av = GvAVn(gv);
@@ -334,7 +340,9 @@
PERL_ARGS_ASSERT_SAVE_HASH;
- save_pushptrptr(gv, (ohv = GvHVn(gv)), SAVEt_HV);
+ save_pushptrptr(
+ SvREFCNT_inc_simple_NN(gv), (ohv = GvHVn(gv)), SAVEt_HV
+ );
GvHV(gv) = NULL;
hv = GvHVn(gv);
@@ -344,10 +352,10 @@
}
void
-Perl_save_item(pTHX_ register SV *item)
+Perl_save_item(pTHX_ SV *item)
{
dVAR;
- register SV * const sv = newSVsv(item);
+ SV * const sv = newSVsv(item);
PERL_ARGS_ASSERT_SAVE_ITEM;
@@ -360,12 +368,13 @@
Perl_save_bool(pTHX_ bool *boolp)
{
dVAR;
+ dSS_ADD;
PERL_ARGS_ASSERT_SAVE_BOOL;
- SSCHECK(2);
- SSPUSHPTR(boolp);
- SSPUSHUV(SAVEt_BOOL | (*boolp << 8));
+ SS_ADD_PTR(boolp);
+ SS_ADD_UV(SAVEt_BOOL | (*boolp << 8));
+ SS_ADD_END(2);
}
void
@@ -372,10 +381,12 @@
Perl_save_pushi32ptr(pTHX_ const I32 i, void *const ptr, const int type)
{
dVAR;
- SSCHECK(3);
- SSPUSHINT(i);
- SSPUSHPTR(ptr);
- SSPUSHUV(type);
+ dSS_ADD;
+
+ SS_ADD_INT(i);
+ SS_ADD_PTR(ptr);
+ SS_ADD_UV(type);
+ SS_ADD_END(3);
}
void
@@ -382,16 +393,21 @@
Perl_save_int(pTHX_ int *intp)
{
dVAR;
- const UV shifted = (UV)*intp << SAVE_TIGHT_SHIFT;
+ const int i = *intp;
+ UV type = ((UV)((UV)i << SAVE_TIGHT_SHIFT) | SAVEt_INT_SMALL);
+ int size = 2;
+ dSS_ADD;
PERL_ARGS_ASSERT_SAVE_INT;
- if ((int)(shifted >> SAVE_TIGHT_SHIFT) == *intp) {
- SSCHECK(2);
- SSPUSHPTR(intp);
- SSPUSHUV(SAVEt_INT_SMALL | shifted);
- } else
- save_pushi32ptr(*intp, intp, SAVEt_INT);
+ if ((int)(type >> SAVE_TIGHT_SHIFT) != i) {
+ SS_ADD_INT(i);
+ type = SAVEt_INT;
+ size++;
+ }
+ SS_ADD_PTR(intp);
+ SS_ADD_UV(type);
+ SS_ADD_END(size);
}
void
@@ -398,12 +414,13 @@
Perl_save_I8(pTHX_ I8 *bytep)
{
dVAR;
+ dSS_ADD;
PERL_ARGS_ASSERT_SAVE_I8;
- SSCHECK(2);
- SSPUSHPTR(bytep);
- SSPUSHUV(SAVEt_I8 | ((UV)*bytep << 8));
+ SS_ADD_PTR(bytep);
+ SS_ADD_UV(SAVEt_I8 | ((UV)*bytep << 8));
+ SS_ADD_END(2);
}
void
@@ -410,12 +427,13 @@
Perl_save_I16(pTHX_ I16 *intp)
{
dVAR;
+ dSS_ADD;
PERL_ARGS_ASSERT_SAVE_I16;
- SSCHECK(2);
- SSPUSHPTR(intp);
- SSPUSHUV(SAVEt_I16 | ((UV)*intp << 8));
+ SS_ADD_PTR(intp);
+ SS_ADD_UV(SAVEt_I16 | ((UV)*intp << 8));
+ SS_ADD_END(2);
}
void
@@ -422,16 +440,21 @@
Perl_save_I32(pTHX_ I32 *intp)
{
dVAR;
- const UV shifted = (UV)*intp << SAVE_TIGHT_SHIFT;
+ const I32 i = *intp;
+ UV type = ((I32)((U32)i << SAVE_TIGHT_SHIFT) | SAVEt_I32_SMALL);
+ int size = 2;
+ dSS_ADD;
PERL_ARGS_ASSERT_SAVE_I32;
- if ((I32)(shifted >> SAVE_TIGHT_SHIFT) == *intp) {
- SSCHECK(2);
- SSPUSHPTR(intp);
- SSPUSHUV(SAVEt_I32_SMALL | shifted);
- } else
- save_pushi32ptr(*intp, intp, SAVEt_I32);
+ if ((I32)(type >> SAVE_TIGHT_SHIFT) != i) {
+ SS_ADD_INT(i);
+ type = SAVEt_I32;
+ size++;
+ }
+ SS_ADD_PTR(intp);
+ SS_ADD_UV(type);
+ SS_ADD_END(size);
}
/* Cannot use save_sptr() to store a char* since the SV** cast will
@@ -471,12 +494,14 @@
Perl_save_padsv_and_mortalize(pTHX_ PADOFFSET off)
{
dVAR;
- SSCHECK(4);
+ dSS_ADD;
+
ASSERT_CURPAD_ACTIVE("save_padsv");
- SSPUSHPTR(SvREFCNT_inc_simple_NN(PL_curpad[off]));
- SSPUSHPTR(PL_comppad);
- SSPUSHLONG((long)off);
- SSPUSHUV(SAVEt_PADSV_AND_MORTALIZE);
+ SS_ADD_PTR(SvREFCNT_inc_simple_NN(PL_curpad[off]));
+ SS_ADD_PTR(PL_comppad);
+ SS_ADD_UV((UV)off);
+ SS_ADD_UV(SAVEt_PADSV_AND_MORTALIZE);
+ SS_ADD_END(4);
}
void
@@ -503,9 +528,10 @@
Perl_save_pushptr(pTHX_ void *const ptr, const int type)
{
dVAR;
- SSCHECK(2);
- SSPUSHPTR(ptr);
- SSPUSHUV(type);
+ dSS_ADD;
+ SS_ADD_PTR(ptr);
+ SS_ADD_UV(type);
+ SS_ADD_END(2);
}
void
@@ -518,13 +544,17 @@
PERL_ARGS_ASSERT_SAVE_CLEARSV;
ASSERT_CURPAD_ACTIVE("save_clearsv");
- if ((offset_shifted >> SAVE_TIGHT_SHIFT) != offset)
+ SvPADSTALE_off(*svp); /* mark lexical as active */
+ if ((offset_shifted >> SAVE_TIGHT_SHIFT) != offset) {
Perl_croak(aTHX_ "panic: pad offset %"UVuf" out of range (%p-%p)",
offset, svp, PL_curpad);
+ }
- SSCHECK(1);
- SSPUSHUV(offset_shifted | SAVEt_CLEARSV);
- SvPADSTALE_off(*svp); /* mark lexical as active */
+ {
+ dSS_ADD;
+ SS_ADD_UV(offset_shifted | SAVEt_CLEARSV);
+ SS_ADD_END(1);
+ }
}
void
@@ -567,13 +597,14 @@
Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p)
{
dVAR;
+ dSS_ADD;
PERL_ARGS_ASSERT_SAVE_DESTRUCTOR;
- SSCHECK(3);
- SSPUSHDPTR(f);
- SSPUSHPTR(p);
- SSPUSHUV(SAVEt_DESTRUCTOR);
+ SS_ADD_DPTR(f);
+ SS_ADD_PTR(p);
+ SS_ADD_UV(SAVEt_DESTRUCTOR);
+ SS_ADD_END(3);
}
void
@@ -580,10 +611,12 @@
Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p)
{
dVAR;
- SSCHECK(3);
- SSPUSHDXPTR(f);
- SSPUSHPTR(p);
- SSPUSHUV(SAVEt_DESTRUCTOR_X);
+ dSS_ADD;
+
+ SS_ADD_DXPTR(f);
+ SS_ADD_PTR(p);
+ SS_ADD_UV(SAVEt_DESTRUCTOR_X);
+ SS_ADD_END(3);
}
void
@@ -592,8 +625,10 @@
dVAR;
COPHH *save_cophh = cophh_copy(CopHINTHASH_get(&PL_compiling));
if (PL_hints & HINT_LOCALIZE_HH) {
- save_pushptri32ptr(GvHV(PL_hintgv), PL_hints, save_cophh, SAVEt_HINTS);
- GvHV(PL_hintgv) = hv_copy_hints_hv(GvHV(PL_hintgv));
+ HV *oldhh = GvHV(PL_hintgv);
+ save_pushptri32ptr(oldhh, PL_hints, save_cophh, SAVEt_HINTS);
+ GvHV(PL_hintgv) = NULL; /* in case copying dies */
+ GvHV(PL_hintgv) = hv_copy_hints_hv(oldhh);
} else {
save_pushi32ptr(PL_hints, save_cophh, SAVEt_HINTS);
}
@@ -603,11 +638,12 @@
S_save_pushptri32ptr(pTHX_ void *const ptr1, const I32 i, void *const ptr2,
const int type)
{
- SSCHECK(4);
- SSPUSHPTR(ptr1);
- SSPUSHINT(i);
- SSPUSHPTR(ptr2);
- SSPUSHUV(type);
+ dSS_ADD;
+ SS_ADD_PTR(ptr1);
+ SS_ADD_INT(i);
+ SS_ADD_PTR(ptr2);
+ SS_ADD_UV(type);
+ SS_ADD_END(4);
}
void
@@ -621,9 +657,10 @@
SvGETMAGIC(*sptr);
save_pushptri32ptr(SvREFCNT_inc_simple(av), idx, SvREFCNT_inc(*sptr),
SAVEt_AELEM);
- /* if it gets reified later, the restore will have the wrong refcnt */
+ /* The array needs to hold a reference count on its new element, so it
+ must be AvREAL. */
if (!AvREAL(av) && AvREIFY(av))
- SvREFCNT_inc_void(*sptr);
+ av_reify(av);
save_scalar_at(sptr, flags); /* XXX - FIXME - see #60360 */
if (flags & SAVEf_KEEPOLDELEM)
return;
@@ -645,11 +682,14 @@
PERL_ARGS_ASSERT_SAVE_HELEM_FLAGS;
SvGETMAGIC(*sptr);
- SSCHECK(4);
- SSPUSHPTR(SvREFCNT_inc_simple(hv));
- SSPUSHPTR(newSVsv(key));
- SSPUSHPTR(SvREFCNT_inc(*sptr));
- SSPUSHUV(SAVEt_HELEM);
+ {
+ dSS_ADD;
+ SS_ADD_PTR(SvREFCNT_inc_simple(hv));
+ SS_ADD_PTR(newSVsv(key));
+ SS_ADD_PTR(SvREFCNT_inc(*sptr));
+ SS_ADD_UV(SAVEt_HELEM);
+ SS_ADD_END(4);
+ }
save_scalar_at(sptr, flags);
if (flags & SAVEf_KEEPOLDELEM)
return;
@@ -678,14 +718,15 @@
Perl_save_alloc(pTHX_ I32 size, I32 pad)
{
dVAR;
- register const I32 start = pad + ((char*)&PL_savestack[PL_savestack_ix]
- - (char*)PL_savestack);
+ const I32 start = pad + ((char*)&PL_savestack[PL_savestack_ix]
+ - (char*)PL_savestack);
const UV elems = 1 + ((size + pad - 1) / sizeof(*PL_savestack));
const UV elems_shifted = elems << SAVE_TIGHT_SHIFT;
if ((elems_shifted >> SAVE_TIGHT_SHIFT) != elems)
- Perl_croak(aTHX_ "panic: save_alloc elems %"UVuf" out of range (%ld-%ld)",
- elems, size, pad);
+ Perl_croak(aTHX_
+ "panic: save_alloc elems %"UVuf" out of range (%"IVdf"-%"IVdf")",
+ elems, (IV)size, (IV)pad);
SSGROW(elems + 1);
@@ -694,262 +735,366 @@
return start;
}
+
+
+#define ARG0_SV MUTABLE_SV(arg0.any_ptr)
+#define ARG0_AV MUTABLE_AV(arg0.any_ptr)
+#define ARG0_HV MUTABLE_HV(arg0.any_ptr)
+#define ARG0_PTR arg0.any_ptr
+#define ARG0_PV (char*)(arg0.any_ptr)
+#define ARG0_PVP (char**)(arg0.any_ptr)
+#define ARG0_I32 (arg0.any_i32)
+
+#define ARG1_SV MUTABLE_SV(arg1.any_ptr)
+#define ARG1_AV MUTABLE_AV(arg1.any_ptr)
+#define ARG1_GV MUTABLE_GV(arg1.any_ptr)
+#define ARG1_SVP (SV**)(arg1.any_ptr)
+#define ARG1_PVP (char**)(arg1.any_ptr)
+#define ARG1_PTR arg1.any_ptr
+#define ARG1_PV (char*)(arg1.any_ptr)
+#define ARG1_I32 (arg1.any_i32)
+
+#define ARG2_SV MUTABLE_SV(arg2.any_ptr)
+#define ARG2_AV MUTABLE_AV(arg2.any_ptr)
+#define ARG2_HV MUTABLE_HV(arg2.any_ptr)
+#define ARG2_GV MUTABLE_GV(arg2.any_ptr)
+#define ARG2_PV (char*)(arg2.any_ptr)
+
void
Perl_leave_scope(pTHX_ I32 base)
{
dVAR;
- register SV *sv;
- register SV *value;
- register GV *gv;
- register AV *av;
- register HV *hv;
- void* ptr;
- register char* str;
- I32 i;
+
/* Localise the effects of the TAINT_NOT inside the loop. */
- const bool was = PL_tainted;
+ bool was = TAINT_get;
+ ANY arg0, arg1, arg2;
+
+ /* these initialisations are logically unnecessary, but they shut up
+ * spurious 'may be used uninitialized' compiler warnings */
+ arg0.any_ptr = NULL;
+ arg1.any_ptr = NULL;
+ arg2.any_ptr = NULL;
+
if (base < -1)
- Perl_croak(aTHX_ "panic: corrupt saved stack index");
+ Perl_croak(aTHX_ "panic: corrupt saved stack index %ld", (long) base);
DEBUG_l(Perl_deb(aTHX_ "savestack: releasing items %ld -> %ld\n",
(long)PL_savestack_ix, (long)base));
while (PL_savestack_ix > base) {
- UV uv = SSPOPUV;
- const U8 type = (U8)uv & SAVE_MASK;
+ UV uv;
+ U8 type;
+
+ SV *refsv;
+ SV **svp;
+
TAINT_NOT;
+ {
+ I32 ix = PL_savestack_ix - 1;
+ ANY *p = &PL_savestack[ix];
+ uv = p->any_uv;
+ type = (U8)uv & SAVE_MASK;
+ if (type > SAVEt_ARG0_MAX) {
+ ANY *p0 = p;
+ arg0 = *--p;
+ if (type > SAVEt_ARG1_MAX) {
+ arg1 = *--p;
+ if (type > SAVEt_ARG2_MAX) {
+ arg2 = *--p;
+ }
+ }
+ ix -= (p0 - p);
+ }
+ PL_savestack_ix = ix;
+ }
+
switch (type) {
case SAVEt_ITEM: /* normal string */
- value = MUTABLE_SV(SSPOPPTR);
- sv = MUTABLE_SV(SSPOPPTR);
- sv_replace(sv,value);
- PL_localizing = 2;
- SvSETMAGIC(sv);
- PL_localizing = 0;
+ sv_replace(ARG1_SV, ARG0_SV);
+ if (SvSMAGICAL(ARG1_SV)) {
+ PL_localizing = 2;
+ mg_set(ARG1_SV);
+ PL_localizing = 0;
+ }
break;
+
+ /* This would be a mathom, but Perl_save_svref() calls a static
+ function, S_save_scalar_at(), so has to stay in this file. */
+ case SAVEt_SVREF: /* scalar reference */
+ svp = ARG1_SVP;
+ refsv = NULL; /* what to refcnt_dec */
+ goto restore_sv;
+
case SAVEt_SV: /* scalar reference */
- value = MUTABLE_SV(SSPOPPTR);
- gv = MUTABLE_GV(SSPOPPTR);
- ptr = &GvSV(gv);
- av = MUTABLE_AV(gv); /* what to refcnt_dec */
+ svp = &GvSV(ARG1_GV);
+ refsv = ARG1_SV; /* what to refcnt_dec */
restore_sv:
- sv = *(SV**)ptr;
- *(SV**)ptr = value;
+ {
+ SV * const sv = *svp;
+ *svp = ARG0_SV;
SvREFCNT_dec(sv);
- PL_localizing = 2;
- SvSETMAGIC(value);
- PL_localizing = 0;
- SvREFCNT_dec(value);
- if (av) /* actually an av, hv or gv */
- SvREFCNT_dec(av);
+ if (SvSMAGICAL(ARG0_SV)) {
+ PL_localizing = 2;
+ mg_set(ARG0_SV);
+ PL_localizing = 0;
+ }
+ SvREFCNT_dec_NN(ARG0_SV);
+ SvREFCNT_dec(refsv);
break;
+ }
case SAVEt_GENERIC_PVREF: /* generic pv */
- ptr = SSPOPPTR;
- str = (char*)SSPOPPTR;
- if (*(char**)ptr != str) {
- Safefree(*(char**)ptr);
- *(char**)ptr = str;
+ if (*ARG0_PVP != ARG1_PV) {
+ Safefree(*ARG0_PVP);
+ *ARG0_PVP = ARG1_PV;
}
break;
case SAVEt_SHARED_PVREF: /* shared pv */
- str = (char*)SSPOPPTR;
- ptr = SSPOPPTR;
- if (*(char**)ptr != str) {
+ if (*ARG1_PVP != ARG0_PV) {
#ifdef NETWARE
- PerlMem_free(*(char**)ptr);
+ PerlMem_free(*ARG1_PVP);
#else
- PerlMemShared_free(*(char**)ptr);
+ PerlMemShared_free(*ARG1_PVP);
#endif
- *(char**)ptr = str;
+ *ARG1_PVP = ARG0_PV;
}
break;
case SAVEt_GVSV: /* scalar slot in GV */
- value = MUTABLE_SV(SSPOPPTR);
- gv = MUTABLE_GV(SSPOPPTR);
- ptr = &GvSV(gv);
+ svp = &GvSV(ARG1_GV);
goto restore_svp;
case SAVEt_GENERIC_SVREF: /* generic sv */
- value = MUTABLE_SV(SSPOPPTR);
- ptr = SSPOPPTR;
+ svp = ARG1_SVP;
restore_svp:
- sv = *(SV**)ptr;
- *(SV**)ptr = value;
+ {
+ SV * const sv = *svp;
+ *svp = ARG0_SV;
SvREFCNT_dec(sv);
- SvREFCNT_dec(value);
+ SvREFCNT_dec(ARG0_SV);
break;
+ }
+ case SAVEt_GVSLOT: /* any slot in GV */
+ {
+ HV *const hv = GvSTASH(ARG2_GV);
+ svp = ARG1_SVP;
+ if (hv && HvENAME(hv) && (
+ (ARG0_SV && SvTYPE(ARG0_SV) == SVt_PVCV)
+ || (*svp && SvTYPE(*svp) == SVt_PVCV)
+ ))
+ {
+ if ((char *)svp < (char *)GvGP(ARG2_GV)
+ || (char *)svp > (char *)GvGP(ARG2_GV) + sizeof(struct gp)
+ || GvREFCNT(ARG2_GV) > 1)
+ PL_sub_generation++;
+ else mro_method_changed_in(hv);
+ }
+ goto restore_svp;
+ }
case SAVEt_AV: /* array reference */
- av = MUTABLE_AV(SSPOPPTR);
- gv = MUTABLE_GV(SSPOPPTR);
- SvREFCNT_dec(GvAV(gv));
- GvAV(gv) = av;
- if (SvMAGICAL(av)) {
- PL_localizing = 2;
- SvSETMAGIC(MUTABLE_SV(av));
- PL_localizing = 0;
- }
+ SvREFCNT_dec(GvAV(ARG1_GV));
+ GvAV(ARG1_GV) = ARG0_AV;
+ if (SvSMAGICAL(ARG0_SV)) {
+ PL_localizing = 2;
+ mg_set(ARG0_SV);
+ PL_localizing = 0;
+ }
+ SvREFCNT_dec_NN(ARG1_GV);
break;
case SAVEt_HV: /* hash reference */
- hv = MUTABLE_HV(SSPOPPTR);
- gv = MUTABLE_GV(SSPOPPTR);
- SvREFCNT_dec(GvHV(gv));
- GvHV(gv) = hv;
- if (SvMAGICAL(hv)) {
- PL_localizing = 2;
- SvSETMAGIC(MUTABLE_SV(hv));
- PL_localizing = 0;
- }
+ SvREFCNT_dec(GvHV(ARG1_GV));
+ GvHV(ARG1_GV) = ARG0_HV;
+ if (SvSMAGICAL(ARG0_SV)) {
+ PL_localizing = 2;
+ mg_set(ARG0_SV);
+ PL_localizing = 0;
+ }
+ SvREFCNT_dec_NN(ARG1_GV);
break;
case SAVEt_INT_SMALL:
- ptr = SSPOPPTR;
- *(int*)ptr = (int)(uv >> SAVE_TIGHT_SHIFT);
+ *(int*)ARG0_PTR = (int)(uv >> SAVE_TIGHT_SHIFT);
break;
case SAVEt_INT: /* int reference */
- ptr = SSPOPPTR;
- *(int*)ptr = (int)SSPOPINT;
+ *(int*)ARG0_PTR = (int)ARG1_I32;
break;
case SAVEt_BOOL: /* bool reference */
- ptr = SSPOPPTR;
- *(bool*)ptr = cBOOL(uv >> 8);
+ *(bool*)ARG0_PTR = cBOOL(uv >> 8);
+#ifdef NO_TAINT_SUPPORT
+ PERL_UNUSED_VAR(was);
+#else
+ if (ARG0_PTR == &(TAINT_get)) {
+ /* If we don't update <was>, to reflect what was saved on the
+ * stack for PL_tainted, then we will overwrite this attempt to
+ * restore it when we exit this routine. Note that this won't
+ * work if this value was saved in a wider-than necessary type,
+ * such as I32 */
+ was = *(bool*)ARG0_PTR;
+ }
+#endif
break;
case SAVEt_I32_SMALL:
- ptr = SSPOPPTR;
- *(I32*)ptr = (I32)(uv >> SAVE_TIGHT_SHIFT);
+ *(I32*)ARG0_PTR = (I32)(uv >> SAVE_TIGHT_SHIFT);
break;
case SAVEt_I32: /* I32 reference */
- ptr = SSPOPPTR;
#ifdef PERL_DEBUG_READONLY_OPS
- {
- const I32 val = SSPOPINT;
- if (*(I32*)ptr != val)
- *(I32*)ptr = val;
- }
-#else
- *(I32*)ptr = (I32)SSPOPINT;
+ if (*(I32*)ARG0_PTR != ARG1_I32)
#endif
+ *(I32*)ARG0_PTR = ARG1_I32;
break;
case SAVEt_SPTR: /* SV* reference */
- ptr = SSPOPPTR;
- *(SV**)ptr = MUTABLE_SV(SSPOPPTR);
+ *(SV**)(ARG0_PTR)= ARG1_SV;
break;
case SAVEt_VPTR: /* random* reference */
case SAVEt_PPTR: /* char* reference */
- ptr = SSPOPPTR;
- *(char**)ptr = (char*)SSPOPPTR;
+ *ARG0_PVP = ARG1_PV;
break;
case SAVEt_HPTR: /* HV* reference */
- ptr = SSPOPPTR;
- *(HV**)ptr = MUTABLE_HV(SSPOPPTR);
+ *(HV**)ARG0_PTR = MUTABLE_HV(ARG1_PTR);
break;
case SAVEt_APTR: /* AV* reference */
- ptr = SSPOPPTR;
- *(AV**)ptr = MUTABLE_AV(SSPOPPTR);
+ *(AV**)ARG0_PTR = ARG1_AV;
break;
case SAVEt_GP: /* scalar reference */
- ptr = SSPOPPTR;
- gv = MUTABLE_GV(SSPOPPTR);
- gp_free(gv);
- GvGP_set(gv, (GP*)ptr);
- /* putting a method back into circulation ("local")*/
- if (GvCVu(gv) && (hv=GvSTASH(gv)) && HvENAME_get(hv))
- mro_method_changed_in(hv);
- SvREFCNT_dec(gv);
+ {
+ HV *hv;
+ /* possibly taking a method out of circulation */
+ const bool had_method = !!GvCVu(ARG1_GV);
+ gp_free(ARG1_GV);
+ GvGP_set(ARG1_GV, (GP*)ARG0_PTR);
+ if ((hv=GvSTASH(ARG1_GV)) && HvENAME_get(hv)) {
+ if ( GvNAMELEN(ARG1_GV) == 3
+ && strnEQ(GvNAME(ARG1_GV), "ISA", 3)
+ )
+ mro_isa_changed_in(hv);
+ else if (had_method || GvCVu(ARG1_GV))
+ /* putting a method back into circulation ("local")*/
+ gv_method_changed(ARG1_GV);
+ }
+ SvREFCNT_dec_NN(ARG1_GV);
break;
+ }
case SAVEt_FREESV:
- ptr = SSPOPPTR;
- SvREFCNT_dec(MUTABLE_SV(ptr));
+ SvREFCNT_dec(ARG0_SV);
break;
case SAVEt_FREECOPHH:
- ptr = SSPOPPTR;
- cophh_free((COPHH *)ptr);
+ cophh_free((COPHH *)ARG0_PTR);
break;
case SAVEt_MORTALIZESV:
- ptr = SSPOPPTR;
- sv_2mortal(MUTABLE_SV(ptr));
+ sv_2mortal(ARG0_SV);
break;
case SAVEt_FREEOP:
- ptr = SSPOPPTR;
- ASSERT_CURPAD_LEGAL("SAVEt_FREEOP"); /* XXX DAPM tmp */
- op_free((OP*)ptr);
+ ASSERT_CURPAD_LEGAL("SAVEt_FREEOP");
+ op_free((OP*)ARG0_PTR);
break;
case SAVEt_FREEPV:
- ptr = SSPOPPTR;
- Safefree(ptr);
+ Safefree(ARG0_PTR);
break;
+
+ {
+ SV **svp;
+ I32 i;
+ SV *sv;
+
+ case SAVEt_CLEARPADRANGE:
+ i = (I32)((uv >> SAVE_TIGHT_SHIFT) & OPpPADRANGE_COUNTMASK);
+ svp = &PL_curpad[uv >>
+ (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT)] + i - 1;
+ goto clearsv;
case SAVEt_CLEARSV:
- ptr = (void*)&PL_curpad[uv >> SAVE_TIGHT_SHIFT];
- sv = *(SV**)ptr;
+ svp = &PL_curpad[uv >> SAVE_TIGHT_SHIFT];
+ i = 1;
+ clearsv:
+ for (; i; i--, svp--) {
+ sv = *svp;
- DEBUG_Xv(PerlIO_printf(Perl_debug_log,
- "Pad 0x%"UVxf"[0x%"UVxf"] clearsv: %ld sv=0x%"UVxf"<%"IVdf"> %s\n",
- PTR2UV(PL_comppad), PTR2UV(PL_curpad),
- (long)((SV **)ptr-PL_curpad), PTR2UV(sv), (IV)SvREFCNT(sv),
- (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) ? "clear" : "abandon"
- ));
+ DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+ "Pad 0x%"UVxf"[0x%"UVxf"] clearsv: %ld sv=0x%"UVxf"<%"IVdf"> %s\n",
+ PTR2UV(PL_comppad), PTR2UV(PL_curpad),
+ (long)(svp-PL_curpad), PTR2UV(sv), (IV)SvREFCNT(sv),
+ (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) ? "clear" : "abandon"
+ ));
- /* Can clear pad variable in place? */
- if (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) {
- /*
- * if a my variable that was made readonly is going out of
- * scope, we want to remove the readonlyness so that it can
- * go out of scope quietly
- */
- if (SvPADMY(sv) && !SvFAKE(sv))
- SvREADONLY_off(sv);
+ /* Can clear pad variable in place? */
+ if (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) {
+ /*
+ * if a my variable that was made readonly is going out of
+ * scope, we want to remove the readonlyness so that it can
+ * go out of scope quietly
+ */
+ if (SvPADMY(sv) && !SvFAKE(sv))
+ SvREADONLY_off(sv);
- if (SvTHINKFIRST(sv))
- sv_force_normal_flags(sv, SV_IMMEDIATE_UNREF);
- if (SvMAGICAL(sv))
- mg_free(sv);
+ if (SvTHINKFIRST(sv))
+ sv_force_normal_flags(sv, SV_IMMEDIATE_UNREF
+ |SV_COW_DROP_PV);
+ if (SvTYPE(sv) == SVt_PVHV)
+ Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
+ if (SvMAGICAL(sv))
+ {
+ sv_unmagic(sv, PERL_MAGIC_backref);
+ if (SvTYPE(sv) != SVt_PVCV)
+ mg_free(sv);
+ }
- switch (SvTYPE(sv)) {
- case SVt_NULL:
- break;
- case SVt_PVAV:
- av_clear(MUTABLE_AV(sv));
- break;
- case SVt_PVHV:
- hv_clear(MUTABLE_HV(sv));
- break;
- case SVt_PVCV:
- Perl_croak(aTHX_ "panic: leave_scope pad code");
- default:
- SvOK_off(sv);
- break;
- }
- SvPADSTALE_on(sv); /* mark as no longer live */
- }
- else { /* Someone has a claim on this, so abandon it. */
- const U32 padflags = SvFLAGS(sv) & (SVs_PADMY|SVs_PADTMP);
- switch (SvTYPE(sv)) { /* Console ourselves with a new value */
- case SVt_PVAV: *(SV**)ptr = MUTABLE_SV(newAV()); break;
- case SVt_PVHV: *(SV**)ptr = MUTABLE_SV(newHV()); break;
- default: *(SV**)ptr = newSV(0); break;
- }
- SvREFCNT_dec(sv); /* Cast current value to the winds. */
- /* preserve pad nature, but also mark as not live
- * for any closure capturing */
- SvFLAGS(*(SV**)ptr) |= padflags | SVs_PADSTALE;
- }
+ switch (SvTYPE(sv)) {
+ case SVt_NULL:
+ break;
+ case SVt_PVAV:
+ av_clear(MUTABLE_AV(sv));
+ break;
+ case SVt_PVHV:
+ hv_clear(MUTABLE_HV(sv));
+ break;
+ case SVt_PVCV:
+ {
+ HEK * const hek = CvNAME_HEK((CV *)sv);
+ assert(hek);
+ share_hek_hek(hek);
+ cv_undef((CV *)sv);
+ CvNAME_HEK_set(sv, hek);
+ break;
+ }
+ default:
+ SvOK_off(sv);
+ break;
+ }
+ SvPADSTALE_on(sv); /* mark as no longer live */
+ }
+ else { /* Someone has a claim on this, so abandon it. */
+ assert( SvFLAGS(sv) & SVs_PADMY);
+ 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;
+ case SVt_PVCV:
+ {
+ /* Create a stub */
+ *svp = newSV_type(SVt_PVCV);
+
+ /* Share name */
+ assert(CvNAMED(sv));
+ CvNAME_HEK_set(*svp,
+ share_hek_hek(CvNAME_HEK((CV *)sv)));
+ break;
+ }
+ default: *svp = newSV(0); break;
+ }
+ SvREFCNT_dec_NN(sv); /* Cast current value to the winds. */
+ /* preserve pad nature, but also mark as not live
+ * for any closure capturing */
+ SvFLAGS(*svp) |= (SVs_PADMY|SVs_PADSTALE);
+ }
+ }
break;
+ }
case SAVEt_DELETE:
- ptr = SSPOPPTR;
- hv = MUTABLE_HV(ptr);
- i = SSPOPINT;
- ptr = SSPOPPTR;
- (void)hv_delete(hv, (char*)ptr, i, G_DISCARD);
- SvREFCNT_dec(hv);
- Safefree(ptr);
+ (void)hv_delete(ARG0_HV, ARG2_PV, ARG1_I32, G_DISCARD);
+ SvREFCNT_dec(ARG0_HV);
+ Safefree(arg2.any_ptr);
break;
case SAVEt_ADELETE:
- ptr = SSPOPPTR;
- av = MUTABLE_AV(ptr);
- i = SSPOPINT;
- (void)av_delete(av, i, G_DISCARD);
- SvREFCNT_dec(av);
+ (void)av_delete(ARG0_AV, ARG1_I32, G_DISCARD);
+ SvREFCNT_dec(ARG0_AV);
break;
case SAVEt_DESTRUCTOR_X:
- ptr = SSPOPPTR;
- (*SSPOPDXPTR)(aTHX_ ptr);
+ (*arg1.any_dxptr)(aTHX_ ARG0_PTR);
break;
case SAVEt_REGCONTEXT:
/* regexp must have croaked */
@@ -957,81 +1102,66 @@
PL_savestack_ix -= uv >> SAVE_TIGHT_SHIFT;
break;
case SAVEt_STACK_POS: /* Position on Perl stack */
- i = SSPOPINT;
- PL_stack_sp = PL_stack_base + i;
+ PL_stack_sp = PL_stack_base + arg0.any_i32;
break;
case SAVEt_STACK_CXPOS: /* blk_oldsp on context stack */
- i = SSPOPINT;
- cxstack[i].blk_oldsp = SSPOPINT;
+ cxstack[ARG0_I32].blk_oldsp = ARG1_I32;
break;
case SAVEt_AELEM: /* array element */
- value = MUTABLE_SV(SSPOPPTR);
- i = SSPOPINT;
- av = MUTABLE_AV(SSPOPPTR);
- ptr = av_fetch(av,i,1);
- if (!AvREAL(av) && AvREIFY(av)) /* undo reify guard */
- SvREFCNT_dec(value);
- if (ptr) {
- sv = *(SV**)ptr;
+ svp = av_fetch(ARG2_AV, ARG1_I32, 1);
+ if (!AvREAL(ARG2_AV) && AvREIFY(ARG2_AV)) /* undo reify guard */
+ SvREFCNT_dec(ARG0_SV);
+ if (svp) {
+ SV * const sv = *svp;
if (sv && sv != &PL_sv_undef) {
- if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
+ if (SvTIED_mg((const SV *)ARG2_AV, PERL_MAGIC_tied))
SvREFCNT_inc_void_NN(sv);
+ refsv = ARG2_SV;
goto restore_sv;
}
}
- SvREFCNT_dec(av);
- SvREFCNT_dec(value);
+ SvREFCNT_dec(ARG2_AV);
+ SvREFCNT_dec(ARG0_SV);
break;
case SAVEt_HELEM: /* hash element */
- value = MUTABLE_SV(SSPOPPTR);
- sv = MUTABLE_SV(SSPOPPTR);
- hv = MUTABLE_HV(SSPOPPTR);
- ptr = hv_fetch_ent(hv, sv, 1, 0);
- SvREFCNT_dec(sv);
- if (ptr) {
- const SV * const oval = HeVAL((HE*)ptr);
+ {
+ HE * const he = hv_fetch_ent(ARG2_HV, ARG1_SV, 1, 0);
+ SvREFCNT_dec(ARG1_SV);
+ if (he) {
+ const SV * const oval = HeVAL(he);
if (oval && oval != &PL_sv_undef) {
- ptr = &HeVAL((HE*)ptr);
- if (SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
- SvREFCNT_inc_void(*(SV**)ptr);
- av = MUTABLE_AV(hv); /* what to refcnt_dec */
+ svp = &HeVAL(he);
+ if (SvTIED_mg((const SV *)ARG2_HV, PERL_MAGIC_tied))
+ SvREFCNT_inc_void(*svp);
+ refsv = ARG2_SV; /* what to refcnt_dec */
goto restore_sv;
}
}
- SvREFCNT_dec(hv);
- SvREFCNT_dec(value);
+ SvREFCNT_dec(ARG2_HV);
+ SvREFCNT_dec(ARG0_SV);
break;
+ }
case SAVEt_OP:
- PL_op = (OP*)SSPOPPTR;
+ PL_op = (OP*)ARG0_PTR;
break;
case SAVEt_HINTS:
- if ((PL_hints & HINT_LOCALIZE_HH) && GvHV(PL_hintgv)) {
- SvREFCNT_dec(MUTABLE_SV(GvHV(PL_hintgv)));
+ if ((PL_hints & HINT_LOCALIZE_HH)) {
+ while (GvHV(PL_hintgv)) {
+ HV *hv = GvHV(PL_hintgv);
GvHV(PL_hintgv) = NULL;
+ SvREFCNT_dec(MUTABLE_SV(hv));
+ }
}
cophh_free(CopHINTHASH_get(&PL_compiling));
- CopHINTHASH_set(&PL_compiling, (COPHH*)SSPOPPTR);
- *(I32*)&PL_hints = (I32)SSPOPINT;
+ CopHINTHASH_set(&PL_compiling, (COPHH*)ARG0_PTR);
+ *(I32*)&PL_hints = ARG1_I32;
if (PL_hints & HINT_LOCALIZE_HH) {
SvREFCNT_dec(MUTABLE_SV(GvHV(PL_hintgv)));
GvHV(PL_hintgv) = MUTABLE_HV(SSPOPPTR);
- assert(GvHV(PL_hintgv));
- } else if (!GvHV(PL_hintgv)) {
- /* Need to add a new one manually, else gv_fetchpv() can
- add one in this code:
-
- if (SvTYPE(gv) == SVt_PVGV) {
- if (add) {
- GvMULTI_on(gv);
- gv_init_sv(gv, sv_type);
- if (*name=='!' && sv_type == SVt_PVHV && len==1)
- require_errno(gv);
- }
- return gv;
- }
-
- and it won't have the magic set. */
-
+ }
+ if (!GvHV(PL_hintgv)) {
+ /* Need to add a new one manually, else rv2hv can
+ add one via GvHVn and it won't have the magic set. */
HV *const hv = newHV();
hv_magic(hv, NULL, PERL_MAGIC_hints);
GvHV(PL_hintgv) = hv;
@@ -1039,7 +1169,7 @@
assert(GvHV(PL_hintgv));
break;
case SAVEt_COMPPAD:
- PL_comppad = (PAD*)SSPOPPTR;
+ PL_comppad = (PAD*)ARG0_PTR;
if (PL_comppad)
PL_curpad = AvARRAY(PL_comppad);
else
@@ -1047,83 +1177,53 @@
break;
case SAVEt_PADSV_AND_MORTALIZE:
{
- const PADOFFSET off = (PADOFFSET)SSPOPLONG;
SV **svp;
- ptr = SSPOPPTR;
- assert (ptr);
- svp = AvARRAY((PAD*)ptr) + off;
+ assert (ARG1_PTR);
+ svp = AvARRAY((PAD*)ARG1_PTR) + (PADOFFSET)arg0.any_uv;
/* This mortalizing used to be done by POPLOOP() via itersave.
But as we have all the information here, we can do it here,
save even having to have itersave in the struct. */
sv_2mortal(*svp);
- *svp = MUTABLE_SV(SSPOPPTR);
+ *svp = ARG2_SV;
}
break;
case SAVEt_SAVESWITCHSTACK:
{
dSP;
- AV *const t = MUTABLE_AV(SSPOPPTR);
- AV *const f = MUTABLE_AV(SSPOPPTR);
- SWITCHSTACK(t,f);
- PL_curstackinfo->si_stack = f;
+ SWITCHSTACK(ARG0_AV, ARG1_AV);
+ PL_curstackinfo->si_stack = ARG1_AV;
}
break;
case SAVEt_SET_SVFLAGS:
- {
- const U32 val = (U32)SSPOPINT;
- const U32 mask = (U32)SSPOPINT;
- sv = MUTABLE_SV(SSPOPPTR);
- SvFLAGS(sv) &= ~mask;
- SvFLAGS(sv) |= val;
- }
+ SvFLAGS(ARG2_SV) &= ~((U32)ARG1_I32);
+ SvFLAGS(ARG2_SV) |= (U32)ARG0_I32;
break;
- /* This would be a mathom, but Perl_save_svref() calls a static
- function, S_save_scalar_at(), so has to stay in this file. */
- case SAVEt_SVREF: /* scalar reference */
- value = MUTABLE_SV(SSPOPPTR);
- ptr = SSPOPPTR;
- av = NULL; /* what to refcnt_dec */
- goto restore_sv;
-
/* These are only saved in mathoms.c */
case SAVEt_NSTAB:
- gv = MUTABLE_GV(SSPOPPTR);
- (void)sv_clear(MUTABLE_SV(gv));
+ (void)sv_clear(ARG0_SV);
break;
case SAVEt_LONG: /* long reference */
- ptr = SSPOPPTR;
- *(long*)ptr = (long)SSPOPLONG;
+ *(long*)ARG0_PTR = arg1.any_long;
break;
case SAVEt_IV: /* IV reference */
- ptr = SSPOPPTR;
- *(IV*)ptr = (IV)SSPOPIV;
+ *(IV*)ARG0_PTR = arg1.any_iv;
break;
case SAVEt_I16: /* I16 reference */
- ptr = SSPOPPTR;
- *(I16*)ptr = (I16)(uv >> 8);
+ *(I16*)ARG0_PTR = (I16)(uv >> 8);
break;
case SAVEt_I8: /* I8 reference */
- ptr = SSPOPPTR;
- *(I8*)ptr = (I8)(uv >> 8);
+ *(I8*)ARG0_PTR = (I8)(uv >> 8);
break;
case SAVEt_DESTRUCTOR:
- ptr = SSPOPPTR;
- (*SSPOPDPTR)(ptr);
+ (*arg1.any_dptr)(ARG0_PTR);
break;
- case SAVEt_COP_ARYBASE:
- ptr = SSPOPPTR;
- i = SSPOPINT;
- CopARYBASE_set((COP *)ptr, i);
- break;
case SAVEt_COMPILE_WARNINGS:
- ptr = SSPOPPTR;
-
if (!specialWARN(PL_compiling.cop_warnings))
PerlMemShared_free(PL_compiling.cop_warnings);
- PL_compiling.cop_warnings = (STRLEN*)ptr;
+ PL_compiling.cop_warnings = (STRLEN*)ARG0_PTR;
break;
case SAVEt_RE_STATE:
{
@@ -1133,9 +1233,6 @@
- SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
PL_savestack_ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
- if (PL_reg_start_tmp != state->re_state_reg_start_tmp) {
- Safefree(PL_reg_start_tmp);
- }
if (PL_reg_poscache != state->re_state_reg_poscache) {
Safefree(PL_reg_poscache);
}
@@ -1143,17 +1240,14 @@
}
break;
case SAVEt_PARSER:
- ptr = SSPOPPTR;
- parser_free((yy_parser *) ptr);
+ parser_free((yy_parser *) ARG0_PTR);
break;
default:
- Perl_croak(aTHX_ "panic: leave_scope inconsistency");
+ Perl_croak(aTHX_ "panic: leave_scope inconsistency %u", type);
}
}
- PL_tainted = was;
-
- PERL_ASYNC_CHECK();
+ TAINT_set(was);
}
void
@@ -1166,6 +1260,7 @@
#ifdef DEBUGGING
PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), PL_block_type[CxTYPE(cx)]);
if (CxTYPE(cx) != CXt_SUBST) {
+ const char *gimme_text;
PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp);
PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%"UVxf"\n",
PTR2UV(cx->blk_oldcop));
@@ -1173,7 +1268,21 @@
PerlIO_printf(Perl_debug_log, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp);
PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%"UVxf"\n",
PTR2UV(cx->blk_oldpm));
- PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", cx->blk_gimme ? "LIST" : "SCALAR");
+ switch (cx->blk_gimme) {
+ case G_VOID:
+ gimme_text = "VOID";
+ break;
+ case G_SCALAR:
+ gimme_text = "SCALAR";
+ break;
+ case G_ARRAY:
+ gimme_text = "LIST";
+ break;
+ default:
+ gimme_text = "UNKNOWN";
+ break;
+ }
+ PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", gimme_text);
}
switch (CxTYPE(cx)) {
case CXt_NULL:
@@ -1270,8 +1379,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/scope.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/scope.h
===================================================================
--- trunk/contrib/perl/scope.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/scope.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -8,58 +8,78 @@
*
*/
-#define SAVEt_ITEM 0
-#define SAVEt_SV 1
-#define SAVEt_AV 2
-#define SAVEt_HV 3
-#define SAVEt_INT 4
-#define SAVEt_LONG 5
-#define SAVEt_I32 6
-#define SAVEt_IV 7
-#define SAVEt_SPTR 8
-#define SAVEt_APTR 9
-#define SAVEt_HPTR 10
-#define SAVEt_PPTR 11
-#define SAVEt_NSTAB 12
-#define SAVEt_SVREF 13
-#define SAVEt_GP 14
-#define SAVEt_FREESV 15
-#define SAVEt_FREEOP 16
-#define SAVEt_FREEPV 17
-#define SAVEt_CLEARSV 18
-#define SAVEt_DELETE 19
-#define SAVEt_DESTRUCTOR 20
-#define SAVEt_REGCONTEXT 21
-#define SAVEt_STACK_POS 22
-#define SAVEt_I16 23
-#define SAVEt_AELEM 24
-#define SAVEt_HELEM 25
-#define SAVEt_OP 26
-#define SAVEt_HINTS 27
-#define SAVEt_ALLOC 28
-#define SAVEt_GENERIC_SVREF 29
-#define SAVEt_DESTRUCTOR_X 30
-#define SAVEt_VPTR 31
-#define SAVEt_I8 32
-#define SAVEt_COMPPAD 33
-#define SAVEt_GENERIC_PVREF 34
-#define SAVEt_PADSV_AND_MORTALIZE 35
-#define SAVEt_MORTALIZESV 36
-#define SAVEt_SHARED_PVREF 37
-#define SAVEt_BOOL 38
-#define SAVEt_SET_SVFLAGS 39
-#define SAVEt_SAVESWITCHSTACK 40
-#define SAVEt_COP_ARYBASE 41
-#define SAVEt_RE_STATE 42
-#define SAVEt_COMPILE_WARNINGS 43
-#define SAVEt_STACK_CXPOS 44
-#define SAVEt_PARSER 45
-#define SAVEt_ADELETE 46
-#define SAVEt_I32_SMALL 47
-#define SAVEt_INT_SMALL 48
-#define SAVEt_GVSV 49
-#define SAVEt_FREECOPHH 50
+/* *** these are ordered by number of of auto-popped args */
+/* zero args */
+
+#define SAVEt_ALLOC 0
+#define SAVEt_CLEARPADRANGE 1
+#define SAVEt_CLEARSV 2
+#define SAVEt_REGCONTEXT 3
+#define SAVEt_RE_STATE 4
+
+#define SAVEt_ARG0_MAX 4
+
+/* one arg */
+
+#define SAVEt_BOOL 5
+#define SAVEt_COMPILE_WARNINGS 6
+#define SAVEt_COMPPAD 7
+#define SAVEt_FREECOPHH 8
+#define SAVEt_FREEOP 9
+#define SAVEt_FREEPV 10
+#define SAVEt_FREESV 11
+#define SAVEt_I16 12
+#define SAVEt_I32_SMALL 13
+#define SAVEt_I8 14
+#define SAVEt_INT_SMALL 15
+#define SAVEt_MORTALIZESV 16
+#define SAVEt_NSTAB 17
+#define SAVEt_OP 18
+#define SAVEt_PARSER 19
+#define SAVEt_STACK_POS 20
+
+#define SAVEt_ARG1_MAX 20
+
+/* two args */
+
+#define SAVEt_ADELETE 21
+#define SAVEt_APTR 22
+#define SAVEt_AV 23
+#define SAVEt_DESTRUCTOR 24
+#define SAVEt_DESTRUCTOR_X 25
+#define SAVEt_GENERIC_PVREF 26
+#define SAVEt_GENERIC_SVREF 27
+#define SAVEt_GP 28
+#define SAVEt_GVSV 29
+#define SAVEt_HINTS 30
+#define SAVEt_HPTR 31
+#define SAVEt_HV 32
+#define SAVEt_I32 33
+#define SAVEt_INT 34
+#define SAVEt_ITEM 35
+#define SAVEt_IV 36
+#define SAVEt_LONG 37
+#define SAVEt_PPTR 38
+#define SAVEt_SAVESWITCHSTACK 39
+#define SAVEt_SHARED_PVREF 40
+#define SAVEt_SPTR 41
+#define SAVEt_STACK_CXPOS 42
+#define SAVEt_SV 43
+#define SAVEt_SVREF 44
+#define SAVEt_VPTR 45
+
+#define SAVEt_ARG2_MAX 45
+
+/* three args */
+
+#define SAVEt_AELEM 46
+#define SAVEt_DELETE 47
+#define SAVEt_HELEM 48
+#define SAVEt_PADSV_AND_MORTALIZE 49
+#define SAVEt_SET_SVFLAGS 50
+#define SAVEt_GVSLOT 51
+
#define SAVEf_SETMAGIC 1
#define SAVEf_KEEPOLDELEM 2
@@ -73,8 +93,12 @@
#define SCOPE_SAVES_SIGNAL_MASK 0
#endif
-#define SSCHECK(need) if (PL_savestack_ix + (I32)(need) > PL_savestack_max) savestack_grow()
-#define SSGROW(need) if (PL_savestack_ix + (I32)(need) > PL_savestack_max) savestack_grow_cnt(need)
+/* the maximum number of entries that might be pushed using the SS_ADD*
+ * macros */
+#define SS_MAXPUSH 4
+
+#define SSCHECK(need) if (PL_savestack_ix + (I32)(need) + SS_MAXPUSH > PL_savestack_max) savestack_grow()
+#define SSGROW(need) if (PL_savestack_ix + (I32)(need) + SS_MAXPUSH > PL_savestack_max) savestack_grow_cnt(need + SS_MAXPUSH)
#define SSPUSHINT(i) (PL_savestack[PL_savestack_ix++].any_i32 = (I32)(i))
#define SSPUSHLONG(i) (PL_savestack[PL_savestack_ix++].any_long = (long)(i))
#define SSPUSHBOOL(p) (PL_savestack[PL_savestack_ix++].any_bool = (p))
@@ -83,6 +107,40 @@
#define SSPUSHPTR(p) (PL_savestack[PL_savestack_ix++].any_ptr = (void*)(p))
#define SSPUSHDPTR(p) (PL_savestack[PL_savestack_ix++].any_dptr = (p))
#define SSPUSHDXPTR(p) (PL_savestack[PL_savestack_ix++].any_dxptr = (p))
+
+/* SS_ADD*: newer, faster versions of the above. Don't mix the two sets of
+ * macros. These are fast because they save reduce accesses to the PL_
+ * vars and move the size check to the end. Doing the check last means
+ * that values in registers will have been pushed and no longer needed, so
+ * don't need saving around the call to grow. Also, tail-call elimination
+ * of the grow() can be done. These changes reduce the code of something
+ * like save_pushptrptr() to half its former size.
+ * Of course, doing the size check *after* pushing means we must always
+ * ensure there are SS_MAXPUSH free slots on the savestack
+ *
+ * These are for internal core use only and are subject to change */
+
+#define dSS_ADD \
+ I32 ix = PL_savestack_ix; \
+ ANY *ssp = &PL_savestack[ix];
+
+#define SS_ADD_END(need) \
+ assert((need) <= SS_MAXPUSH); \
+ ix += (need); \
+ PL_savestack_ix = ix; \
+ assert(ix <= PL_savestack_max); \
+ if ((ix + SS_MAXPUSH) > PL_savestack_max) savestack_grow(); \
+ assert(PL_savestack_ix + SS_MAXPUSH <= PL_savestack_max);
+
+#define SS_ADD_INT(i) ((ssp++)->any_i32 = (I32)(i))
+#define SS_ADD_LONG(i) ((ssp++)->any_long = (long)(i))
+#define SS_ADD_BOOL(p) ((ssp++)->any_bool = (p))
+#define SS_ADD_IV(i) ((ssp++)->any_iv = (IV)(i))
+#define SS_ADD_UV(u) ((ssp++)->any_uv = (UV)(u))
+#define SS_ADD_PTR(p) ((ssp++)->any_ptr = (void*)(p))
+#define SS_ADD_DPTR(p) ((ssp++)->any_dptr = (p))
+#define SS_ADD_DXPTR(p) ((ssp++)->any_dxptr = (p))
+
#define SSPOPINT (PL_savestack[--PL_savestack_ix].any_i32)
#define SSPOPLONG (PL_savestack[--PL_savestack_ix].any_long)
#define SSPOPBOOL (PL_savestack[--PL_savestack_ix].any_bool)
@@ -92,6 +150,7 @@
#define SSPOPDPTR (PL_savestack[--PL_savestack_ix].any_dptr)
#define SSPOPDXPTR (PL_savestack[--PL_savestack_ix].any_dxptr)
+
/*
=head1 Callback Functions
@@ -163,7 +222,9 @@
#define ENTER_with_name(name) ENTER
#define LEAVE_with_name(name) LEAVE
#endif
-#define LEAVE_SCOPE(old) if (PL_savestack_ix > old) leave_scope(old)
+#define LEAVE_SCOPE(old) STMT_START { \
+ if (PL_savestack_ix > old) leave_scope(old); \
+ } STMT_END
#define SAVEI8(i) save_I8((I8*)&(i))
#define SAVEI16(i) save_I16((I16*)&(i))
@@ -199,10 +260,11 @@
save_destructor_x((DESTRUCTORFUNC_t)(f), (void*)(p))
#define SAVESTACK_POS() \
- STMT_START { \
- SSCHECK(2); \
- SSPUSHINT(PL_stack_sp - PL_stack_base); \
- SSPUSHUV(SAVEt_STACK_POS); \
+ STMT_START { \
+ dSS_ADD; \
+ SS_ADD_INT(PL_stack_sp - PL_stack_base); \
+ SS_ADD_UV(SAVEt_STACK_POS); \
+ SS_ADD_END(2); \
} STMT_END
#define SAVEOP() save_op()
@@ -218,8 +280,6 @@
PL_curstackinfo->si_stack = (t); \
} STMT_END
-#define SAVECOPARYBASE(c) save_pushi32ptr(CopARYBASE_get(c), c, SAVEt_COP_ARYBASE);
-
/* Need to do the cop warnings like this, rather than a "SAVEFREESHAREDPV",
because realloc() means that the value can actually change. Possibly
could have done savefreesharedpvREF, but this way actually seems cleaner,
@@ -228,23 +288,23 @@
#define SAVECOMPILEWARNINGS() save_pushptr(PL_compiling.cop_warnings, SAVEt_COMPILE_WARNINGS)
#define SAVESTACK_CXPOS() \
- STMT_START { \
- SSCHECK(3); \
- SSPUSHINT(cxstack[cxstack_ix].blk_oldsp); \
- SSPUSHINT(cxstack_ix); \
- SSPUSHUV(SAVEt_STACK_CXPOS); \
+ STMT_START { \
+ dSS_ADD; \
+ SS_ADD_INT(cxstack[cxstack_ix].blk_oldsp); \
+ SS_ADD_INT(cxstack_ix); \
+ SS_ADD_UV(SAVEt_STACK_CXPOS); \
+ SS_ADD_END(3); \
} STMT_END
#define SAVEPARSER(p) save_pushptr((p), SAVEt_PARSER)
#ifdef USE_ITHREADS
-# define SAVECOPSTASH(c) SAVEPPTR(CopSTASHPV(c))
-# define SAVECOPSTASH_FREE(c) SAVESHAREDPV(CopSTASHPV(c))
+# define SAVECOPSTASH_FREE(c) SAVEIV((c)->cop_stashoff)
# define SAVECOPFILE(c) SAVEPPTR(CopFILE(c))
# define SAVECOPFILE_FREE(c) SAVESHAREDPV(CopFILE(c))
#else
-# define SAVECOPSTASH(c) SAVESPTR(CopSTASH(c))
-# define SAVECOPSTASH_FREE(c) SAVECOPSTASH(c) /* XXX not refcounted */
+# /* XXX not refcounted */
+# define SAVECOPSTASH_FREE(c) SAVESPTR(CopSTASH(c))
# define SAVECOPFILE(c) SAVESPTR(CopFILEGV(c))
# define SAVECOPFILE_FREE(c) SAVEGENERICSV(CopFILEGV(c))
#endif
@@ -273,7 +333,14 @@
#define save_freesv(op) save_pushptr((void *)(op), SAVEt_FREESV)
#define save_mortalizesv(op) save_pushptr((void *)(op), SAVEt_MORTALIZESV)
-#define save_freeop(op) save_pushptr((void *)(op), SAVEt_FREEOP)
+
+# define save_freeop(op) \
+STMT_START { \
+ OP * const _o = (OP *)(op); \
+ assert(!_o->op_savefree); \
+ _o->op_savefree = 1; \
+ save_pushptr((void *)(_o), SAVEt_FREEOP); \
+ } STMT_END
#define save_freepv(pv) save_pushptr((void *)(pv), SAVEt_FREEPV)
#define save_op() save_pushptr((void *)(PL_op), SAVEt_OP)
@@ -281,8 +348,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/scope.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/sv.c
===================================================================
--- trunk/contrib/perl/sv.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/sv.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -66,8 +66,6 @@
#ifdef PERL_OLD_COPY_ON_WRITE
#define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
#define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
-/* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
- on-write. */
#endif
/* ============================================================================
@@ -133,10 +131,12 @@
dump all remaining SVs (debugging aid)
sv_clean_objs() / do_clean_objs(),do_clean_named_objs(),
- do_clean_named_io_objs()
+ do_clean_named_io_objs(),do_curse()
Attempt to free all objects pointed to by RVs,
- and try to do the same for all objects indirectly
- referenced by typeglobs too. Called once from
+ try to do the same for all objects indir-
+ ectly referenced by typeglobs too, and
+ then do a final sweep, cursing any
+ objects that remain. Called once from
perl_destruct(), prior to calling sv_clean_all()
below.
@@ -182,7 +182,9 @@
#endif
#ifdef DEBUG_LEAKING_SCALARS
-# define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
+# define FREE_SV_DEBUG_FILE(sv) STMT_START { \
+ if ((sv)->sv_debug_file) PerlMemShared_free((sv)->sv_debug_file); \
+ } STMT_END
# define DEBUG_SV_SERIAL(sv) \
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n", \
PTR2UV(sv), (long)(sv)->sv_debug_serial))
@@ -275,7 +277,7 @@
);
sv->sv_debug_inpad = 0;
sv->sv_debug_parent = NULL;
- sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
+ sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
sv->sv_debug_serial = PL_sv_serial++;
@@ -365,8 +367,8 @@
{
dVAR;
SV *const sva = MUTABLE_SV(ptr);
- register SV* sv;
- register SV* svend;
+ SV* sv;
+ SV* svend;
PERL_ARGS_ASSERT_SV_ADD_ARENA;
@@ -410,10 +412,10 @@
PERL_ARGS_ASSERT_VISIT;
for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
- register const SV * const svend = &sva[SvREFCNT(sva)];
- register SV* sv;
+ const SV * const svend = &sva[SvREFCNT(sva)];
+ SV* sv;
for (sv = sva + 1; sv < svend; ++sv) {
- if (SvTYPE(sv) != SVTYPEMASK
+ if (SvTYPE(sv) != (svtype)SVTYPEMASK
&& (sv->sv_flags & mask) == flags
&& SvREFCNT(sv))
{
@@ -432,7 +434,7 @@
static void
do_report_used(pTHX_ SV *const sv)
{
- if (SvTYPE(sv) != SVTYPEMASK) {
+ if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
PerlIO_printf(Perl_debug_log, "****\n");
sv_dump(sv);
}
@@ -442,7 +444,7 @@
/*
=for apidoc sv_report_used
-Dump the contents of all SVs not yet freed. (Debugging aid).
+Dump the contents of all SVs not yet freed (debugging aid).
=cut
*/
@@ -475,12 +477,10 @@
} else {
SvROK_off(ref);
SvRV_set(ref, NULL);
- SvREFCNT_dec(target);
+ SvREFCNT_dec_NN(target);
}
}
}
-
- /* XXX Might want to check arrays, etc. */
}
@@ -505,27 +505,27 @@
DEBUG_D((PerlIO_printf(Perl_debug_log,
"Cleaning named glob SV object:\n "), sv_dump(obj)));
GvSV(sv) = NULL;
- SvREFCNT_dec(obj);
+ SvREFCNT_dec_NN(obj);
}
if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) {
DEBUG_D((PerlIO_printf(Perl_debug_log,
"Cleaning named glob AV object:\n "), sv_dump(obj)));
GvAV(sv) = NULL;
- SvREFCNT_dec(obj);
+ SvREFCNT_dec_NN(obj);
}
if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) {
DEBUG_D((PerlIO_printf(Perl_debug_log,
"Cleaning named glob HV object:\n "), sv_dump(obj)));
GvHV(sv) = NULL;
- SvREFCNT_dec(obj);
+ SvREFCNT_dec_NN(obj);
}
if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) {
DEBUG_D((PerlIO_printf(Perl_debug_log,
"Cleaning named glob CV object:\n "), sv_dump(obj)));
GvCV_set(sv, NULL);
- SvREFCNT_dec(obj);
+ SvREFCNT_dec_NN(obj);
}
- SvREFCNT_dec(sv); /* undo the inc above */
+ SvREFCNT_dec_NN(sv); /* undo the inc above */
}
/* clear any IO slots in a GV which hold objects (except stderr, defout);
@@ -546,13 +546,12 @@
DEBUG_D((PerlIO_printf(Perl_debug_log,
"Cleaning named glob IO object:\n "), sv_dump(obj)));
GvIOp(sv) = NULL;
- SvREFCNT_dec(obj);
+ SvREFCNT_dec_NN(obj);
}
- SvREFCNT_dec(sv); /* undo the inc above */
+ SvREFCNT_dec_NN(sv); /* undo the inc above */
}
/* Void wrapper to pass to visit() */
-/* XXX
static void
do_curse(pTHX_ SV * const sv) {
if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv)
@@ -560,12 +559,11 @@
return;
(void)curse(sv, 0);
}
-*/
/*
=for apidoc sv_clean_objs
-Attempt to destroy all objects not yet freed
+Attempt to destroy all objects not yet freed.
=cut
*/
@@ -584,9 +582,7 @@
visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
/* And if there are some very tenacious barnacles clinging to arrays,
closures, or what have you.... */
- /* XXX This line breaks Tk and Gtk2. See [perl #82542].
visit(do_curse, SVs_OBJECT, SVs_OBJECT);
- */
olddef = PL_defoutgv;
PL_defoutgv = NULL; /* disable skip of PL_defoutgv */
if (olddef && isGV_with_GP(olddef))
@@ -611,7 +607,7 @@
}
DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
SvFLAGS(sv) |= SVf_BREAK;
- SvREFCNT_dec(sv);
+ SvREFCNT_dec_NN(sv);
}
/*
@@ -618,7 +614,7 @@
=for apidoc sv_clean_all
Decrement the refcnt of each remaining SV, possibly triggering a
-cleanup. This function may have to be called multiple times to free
+cleanup. This function may have to be called multiple times to free
SVs which are in complex self-referential hierarchies.
=cut
@@ -674,7 +670,7 @@
/*
=for apidoc sv_free_arenas
-Deallocate the memory used by all arenas. Note that all the individual SV
+Deallocate the memory used by all arenas. Note that all the individual SV
heads and bodies within the arenas must already have been freed.
=cut
@@ -897,12 +893,10 @@
NOARENA /* IVS don't need an arena */, 0
},
- /* 8 bytes on most ILP32 with IEEE doubles */
{ sizeof(NV), sizeof(NV),
STRUCT_OFFSET(XPVNV, xnv_u),
SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
- /* 8 bytes on most ILP32 with IEEE doubles */
{ sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
+ STRUCT_OFFSET(XPV, xpv_cur),
@@ -909,7 +903,6 @@
SVt_PV, FALSE, NONV, HASARENA,
FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
- /* 12 */
{ sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
+ STRUCT_OFFSET(XPV, xpv_cur),
@@ -916,7 +909,6 @@
SVt_PVIV, FALSE, NONV, HASARENA,
FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) },
- /* 20 */
{ sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur),
copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur),
+ STRUCT_OFFSET(XPV, xpv_cur),
@@ -923,11 +915,9 @@
SVt_PVNV, FALSE, HADNV, HASARENA,
FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) },
- /* 28 */
{ sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,
HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
- /* something big */
{ sizeof(regexp),
sizeof(regexp),
0,
@@ -935,11 +925,9 @@
FIT_ARENA(0, sizeof(regexp))
},
- /* 48 */
{ sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
- /* 64 */
{ sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
@@ -955,7 +943,6 @@
SVt_PVHV, TRUE, NONV, HASARENA,
FIT_ARENA(0, sizeof(XPVHV)) },
- /* 56 */
{ sizeof(XPVCV),
sizeof(XPVCV),
0,
@@ -968,7 +955,6 @@
SVt_PVFM, TRUE, NONV, NOARENA,
FIT_ARENA(20, sizeof(XPVFM)) },
- /* XPVIO is 84 bytes, fits 48x */
{ sizeof(XPVIO),
sizeof(XPVIO),
0,
@@ -1141,13 +1127,16 @@
Upgrade an SV to a more complex form. Generally adds a new body type to the
SV, then copies across as much information as possible from the old body.
-You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
+It croaks if the SV is already in a more complex form than requested. You
+generally want to use the C<SvUPGRADE> macro wrapper, which checks the type
+before calling C<sv_upgrade>, and hence does not croak. See also
+C<svtype>.
=cut
*/
void
-Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
+Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type)
{
dVAR;
void* old_body;
@@ -1172,7 +1161,7 @@
no longer need to unshare so as to free up the IVX slot for its proper
purpose. So it's safe to move the early return earlier. */
- if (new_type != SVt_PV && SvIsCOW(sv)) {
+ if (new_type > SVt_PVMG && SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
}
@@ -1257,12 +1246,12 @@
assert(!SvPAD_TYPED(sv));
break;
default:
- if (old_type_details->cant_upgrade)
+ if (UNLIKELY(old_type_details->cant_upgrade))
Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
}
- if (old_type > new_type)
+ if (UNLIKELY(old_type > new_type))
Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
(int)old_type, (int)new_type);
@@ -1340,11 +1329,6 @@
}
break;
-
- case SVt_REGEXP:
- /* This ensures that SvTHINKFIRST(sv) is true, and hence that
- sv_force_normal_flags(sv) is called. */
- SvFAKE_on(sv);
case SVt_PVIV:
/* XXX Is this still needed? Was it ever needed? Surely as there is
no route from NV to PVIV, NOK can never be true */
@@ -1355,6 +1339,7 @@
case SVt_PVGV:
case SVt_PVCV:
case SVt_PVLV:
+ case SVt_REGEXP:
case SVt_PVMG:
case SVt_PVNV:
case SVt_PV:
@@ -1401,7 +1386,7 @@
SvNV_set(sv, 0);
#endif
- if (new_type == SVt_PVIO) {
+ if (UNLIKELY(new_type == SVt_PVIO)) {
IO * const io = MUTABLE_IO(sv);
GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
@@ -1408,12 +1393,15 @@
SvOBJECT_on(io);
/* Clear the stashcache because a new IO could overrule a package
name */
+ DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n"));
hv_clear(PL_stashcache);
SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
IoPAGE_LEN(sv) = 60;
}
- if (old_type < SVt_PV) {
+ if (UNLIKELY(new_type == SVt_REGEXP))
+ sv->sv_u.svu_rx = (regexp *)new_body;
+ else if (old_type < SVt_PV) {
/* referant will be NULL unless the old type was SVt_IV emulating
SVt_RV */
sv->sv_u.svu_rv = referant;
@@ -1441,7 +1429,7 @@
/*
=for apidoc sv_backoff
-Remove any string offset. You should normally use the C<SvOOK_off> macro
+Remove any string offset. You should normally use the C<SvOOK_off> macro
wrapper instead.
=cut
@@ -1448,7 +1436,7 @@
*/
int
-Perl_sv_backoff(pTHX_ register SV *const sv)
+Perl_sv_backoff(pTHX_ SV *const sv)
{
STRLEN delta;
const char * const s = SvPVX_const(sv);
@@ -1480,9 +1468,9 @@
*/
char *
-Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen)
+Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen)
{
- register char *s;
+ char *s;
PERL_ARGS_ASSERT_SV_GROW;
@@ -1514,7 +1502,10 @@
#endif
}
else
+ {
+ if (SvIsCOW(sv)) sv_force_normal(sv);
s = SvPVX_mutable(sv);
+ }
if (newlen > SvLEN(sv)) { /* need more room? */
STRLEN minlen = SvCUR(sv);
@@ -1556,7 +1547,7 @@
*/
void
-Perl_sv_setiv(pTHX_ register SV *const sv, const IV i)
+Perl_sv_setiv(pTHX_ SV *const sv, const IV i)
{
dVAR;
@@ -1599,7 +1590,7 @@
*/
void
-Perl_sv_setiv_mg(pTHX_ register SV *const sv, const IV i)
+Perl_sv_setiv_mg(pTHX_ SV *const sv, const IV i)
{
PERL_ARGS_ASSERT_SV_SETIV_MG;
@@ -1617,17 +1608,20 @@
*/
void
-Perl_sv_setuv(pTHX_ register SV *const sv, const UV u)
+Perl_sv_setuv(pTHX_ SV *const sv, const UV u)
{
PERL_ARGS_ASSERT_SV_SETUV;
- /* With these two if statements:
+ /* With the if statement to ensure that integers are stored as IVs whenever
+ possible:
u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
without
u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
- If you wish to remove them, please benchmark to see what the effect is
+ If you wish to remove the following if statement, so that this routine
+ (and its callers) always return UVs, please benchmark to see what the
+ effect is. Modern CPUs may be different. Or may not :-)
*/
if (u <= (UV)IV_MAX) {
sv_setiv(sv, (IV)u);
@@ -1647,7 +1641,7 @@
*/
void
-Perl_sv_setuv_mg(pTHX_ register SV *const sv, const UV u)
+Perl_sv_setuv_mg(pTHX_ SV *const sv, const UV u)
{
PERL_ARGS_ASSERT_SV_SETUV_MG;
@@ -1665,7 +1659,7 @@
*/
void
-Perl_sv_setnv(pTHX_ register SV *const sv, const NV num)
+Perl_sv_setnv(pTHX_ SV *const sv, const NV num)
{
dVAR;
@@ -1709,7 +1703,7 @@
*/
void
-Perl_sv_setnv_mg(pTHX_ register SV *const sv, const NV num)
+Perl_sv_setnv_mg(pTHX_ SV *const sv, const NV num)
{
PERL_ARGS_ASSERT_SV_SETNV_MG;
@@ -1733,7 +1727,7 @@
if (DO_UTF8(sv)) {
dsv = newSVpvs_flags("", SVs_TEMP);
- pv = sv_uni_display(dsv, sv, 10, 0);
+ pv = sv_uni_display(dsv, sv, 10, UNI_DISPLAY_ISPRINT);
} else {
char *d = tmpbuf;
const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
@@ -1787,10 +1781,12 @@
if (PL_op)
Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
+ /* diag_listed_as: Argument "%s" isn't numeric%s */
"Argument \"%s\" isn't numeric in %s", pv,
OP_DESC(PL_op));
else
Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
+ /* diag_listed_as: Argument "%s" isn't numeric%s */
"Argument \"%s\" isn't numeric", pv);
}
@@ -1799,7 +1795,8 @@
Test if the content of an SV looks like a number (or is a number).
C<Inf> and C<Infinity> are treated as numbers (so will not issue a
-non-numeric warning), even if your atof() doesn't grok them.
+non-numeric warning), even if your atof() doesn't grok them. Get-magic is
+ignored.
=cut
*/
@@ -1807,17 +1804,14 @@
I32
Perl_looks_like_number(pTHX_ SV *const sv)
{
- register const char *sbegin;
+ const char *sbegin;
STRLEN len;
PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
- if (SvPOK(sv)) {
- sbegin = SvPVX_const(sv);
- len = SvCUR(sv);
+ if (SvPOK(sv) || SvPOKp(sv)) {
+ sbegin = SvPV_nomg_const(sv, len);
}
- else if (SvPOKp(sv))
- sbegin = SvPV_const(sv, len);
else
return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
return grok_number(sbegin, len, NULL);
@@ -1826,21 +1820,16 @@
STATIC bool
S_glob_2number(pTHX_ GV * const gv)
{
- const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
- SV *const buffer = sv_newmortal();
-
PERL_ARGS_ASSERT_GLOB_2NUMBER;
- /* FAKE globs can get coerced, so need to turn this off temporarily if it
- is on. */
- SvFAKE_off(gv);
- gv_efullname3(buffer, gv, "*");
- SvFLAGS(gv) |= wasfake;
-
/* We know that all GVs stringify to something that is not-a-number,
so no need to test that. */
if (ckWARN(WARN_NUMERIC))
+ {
+ SV *const buffer = sv_newmortal();
+ gv_efullname3(buffer, gv, "*");
not_a_number(buffer);
+ }
/* We just want something true to return, so that S_sv_2iuv_common
can tail call us and return true. */
return TRUE;
@@ -1931,7 +1920,7 @@
/* For sv_2nv these three cases are "SvNOK and don't bother casting" */
STATIC int
-S_sv_2iuv_non_preserve(pTHX_ register SV *const sv
+S_sv_2iuv_non_preserve(pTHX_ SV *const sv
# ifdef DEBUGGING
, I32 numtype
# endif
@@ -2079,7 +2068,7 @@
SvUVX(sv)));
}
}
- else if (SvPOKp(sv) && SvLEN(sv)) {
+ else if (SvPOKp(sv)) {
UV value;
const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
/* We want to avoid a possible problem when we cache an IV/ a UV which
@@ -2242,7 +2231,7 @@
if (isGV_with_GP(sv))
return glob_2number(MUTABLE_GV(sv));
- if (!(SvFLAGS(sv) & SVs_PADTMP)) {
+ if (!SvPADTMP(sv)) {
if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
}
@@ -2266,27 +2255,45 @@
*/
IV
-Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
+Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags)
{
dVAR;
+
if (!sv)
return 0;
- if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
- /* FBMs use the same flag bit as SVf_IVisUV, so must let them
- cache IVs just in case. In practice it seems that they never
- actually anywhere accessible by user Perl code, let alone get used
- in anything other than a string context. */
- if (flags & SV_GMAGIC)
- mg_get(sv);
- if (SvIOKp(sv))
- return SvIVX(sv);
- if (SvNOKp(sv)) {
- return I_V(SvNVX(sv));
+
+ if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
+ mg_get(sv);
+
+ if (SvROK(sv)) {
+ if (SvAMAGIC(sv)) {
+ SV * tmpstr;
+ if (flags & SV_SKIP_OVERLOAD)
+ return 0;
+ tmpstr = AMG_CALLunary(sv, numer_amg);
+ if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
+ return SvIV(tmpstr);
+ }
}
- if (SvPOKp(sv) && SvLEN(sv)) {
+ return PTR2IV(SvRV(sv));
+ }
+
+ if (SvVALID(sv) || isREGEXP(sv)) {
+ /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
+ the same flag bit as SVf_IVisUV, so must not let them cache IVs.
+ In practice they are extremely unlikely to actually get anywhere
+ accessible by user Perl code - the only way that I'm aware of is when
+ a constant subroutine which is used as the second argument to index.
+
+ Regexps have no SvIVX and SvNVX fields.
+ */
+ assert(isREGEXP(sv) || SvPOKp(sv));
+ {
UV value;
+ const char * const ptr =
+ isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
const int numtype
- = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
+ = grok_number(ptr, SvCUR(sv), &value);
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
== IS_NUMBER_IN_UV) {
@@ -2303,30 +2310,16 @@
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
}
- return I_V(Atof(SvPVX_const(sv)));
+ return I_V(Atof(ptr));
}
- if (SvROK(sv)) {
- goto return_rok;
- }
- assert(SvTYPE(sv) >= SVt_PVMG);
- /* This falls through to the report_uninit inside S_sv_2iuv_common. */
- } else if (SvTHINKFIRST(sv)) {
- if (SvROK(sv)) {
- return_rok:
- if (SvAMAGIC(sv)) {
- SV * tmpstr;
- if (flags & SV_SKIP_OVERLOAD)
- return 0;
- tmpstr = AMG_CALLunary(sv, numer_amg);
- if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
- return SvIV(tmpstr);
- }
- }
- return PTR2IV(SvRV(sv));
- }
+ }
+
+ if (SvTHINKFIRST(sv)) {
+#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
}
+#endif
if (SvREADONLY(sv) && !SvOK(sv)) {
if (ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
@@ -2333,10 +2326,12 @@
return 0;
}
}
+
if (!SvIOKp(sv)) {
if (S_sv_2iuv_common(aTHX_ sv))
return 0;
}
+
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
PTR2UV(sv),SvIVX(sv)));
return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
@@ -2353,24 +2348,40 @@
*/
UV
-Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
+Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags)
{
dVAR;
+
if (!sv)
return 0;
- if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
- /* FBMs use the same flag bit as SVf_IVisUV, so must let them
- cache IVs just in case. */
- if (flags & SV_GMAGIC)
- mg_get(sv);
- if (SvIOKp(sv))
- return SvUVX(sv);
- if (SvNOKp(sv))
- return U_V(SvNVX(sv));
- if (SvPOKp(sv) && SvLEN(sv)) {
+
+ if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
+ mg_get(sv);
+
+ if (SvROK(sv)) {
+ if (SvAMAGIC(sv)) {
+ SV *tmpstr;
+ if (flags & SV_SKIP_OVERLOAD)
+ return 0;
+ tmpstr = AMG_CALLunary(sv, numer_amg);
+ if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
+ return SvUV(tmpstr);
+ }
+ }
+ return PTR2UV(SvRV(sv));
+ }
+
+ if (SvVALID(sv) || isREGEXP(sv)) {
+ /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
+ the same flag bit as SVf_IVisUV, so must not let them cache IVs.
+ Regexps have no SvIVX and SvNVX fields. */
+ assert(isREGEXP(sv) || SvPOKp(sv));
+ {
UV value;
+ const char * const ptr =
+ isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
const int numtype
- = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
+ = grok_number(ptr, SvCUR(sv), &value);
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
== IS_NUMBER_IN_UV) {
@@ -2382,30 +2393,16 @@
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
}
- return U_V(Atof(SvPVX_const(sv)));
+ return U_V(Atof(ptr));
}
- if (SvROK(sv)) {
- goto return_rok;
- }
- assert(SvTYPE(sv) >= SVt_PVMG);
- /* This falls through to the report_uninit inside S_sv_2iuv_common. */
- } else if (SvTHINKFIRST(sv)) {
- if (SvROK(sv)) {
- return_rok:
- if (SvAMAGIC(sv)) {
- SV *tmpstr;
- if (flags & SV_SKIP_OVERLOAD)
- return 0;
- tmpstr = AMG_CALLunary(sv, numer_amg);
- if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
- return SvUV(tmpstr);
- }
- }
- return PTR2UV(SvRV(sv));
- }
+ }
+
+ if (SvTHINKFIRST(sv)) {
+#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
}
+#endif
if (SvREADONLY(sv) && !SvOK(sv)) {
if (ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
@@ -2412,6 +2409,7 @@
return 0;
}
}
+
if (!SvIOKp(sv)) {
if (S_sv_2iuv_common(aTHX_ sv))
return 0;
@@ -2426,7 +2424,7 @@
=for apidoc sv_2nv_flags
Return the num value of an SV, doing any necessary string or integer
-conversion. If flags includes SV_GMAGIC, does an mg_get() first.
+conversion. If flags includes SV_GMAGIC, does an mg_get() first.
Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
=cut
@@ -2433,23 +2431,27 @@
*/
NV
-Perl_sv_2nv_flags(pTHX_ register SV *const sv, const I32 flags)
+Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags)
{
dVAR;
if (!sv)
return 0.0;
- if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
- /* FBMs use the same flag bit as SVf_IVisUV, so must let them
- cache IVs just in case. */
+ if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) {
+ /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
+ the same flag bit as SVf_IVisUV, so must not let them cache NVs.
+ Regexps have no SvIVX and SvNVX fields. */
+ const char *ptr;
if (flags & SV_GMAGIC)
mg_get(sv);
if (SvNOKp(sv))
return SvNVX(sv);
- if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) {
+ if (SvPOKp(sv) && !SvIOKp(sv)) {
+ ptr = SvPVX_const(sv);
+ grokpv:
if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
- !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
+ !grok_number(ptr, SvCUR(sv), NULL))
not_a_number(sv);
- return Atof(SvPVX_const(sv));
+ return Atof(ptr);
}
if (SvIOKp(sv)) {
if (SvIsUV(sv))
@@ -2460,6 +2462,10 @@
if (SvROK(sv)) {
goto return_rok;
}
+ if (isREGEXP(sv)) {
+ ptr = RX_WRAPPED((REGEXP *)sv);
+ goto grokpv;
+ }
assert(SvTYPE(sv) >= SVt_PVMG);
/* This falls through to the report_uninit near the end of the
function. */
@@ -2477,9 +2483,11 @@
}
return PTR2NV(SvRV(sv));
}
+#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
}
+#endif
if (SvREADONLY(sv) && !SvOK(sv)) {
if (ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
@@ -2529,7 +2537,7 @@
SvNOKp_on(sv);
#endif
}
- else if (SvPOKp(sv) && SvLEN(sv)) {
+ else if (SvPOKp(sv)) {
UV value;
const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
@@ -2625,7 +2633,7 @@
return 0.0;
}
- if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
+ if (!PL_localizing && !SvPADTMP(sv) && ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
assert (SvTYPE(sv) >= SVt_NV);
/* Typically the caller expects that sv_any is not NULL now. */
@@ -2662,7 +2670,7 @@
*/
SV *
-Perl_sv_2num(pTHX_ register SV *const sv)
+Perl_sv_2num(pTHX_ SV *const sv)
{
PERL_ARGS_ASSERT_SV_2NUM;
@@ -2715,19 +2723,18 @@
=for apidoc sv_2pv_flags
Returns a pointer to the string value of an SV, and sets *lp to its length.
-If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
-if necessary.
-Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
-usually end up here too.
+If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a
+string if necessary. Normally invoked via the C<SvPV_flags> macro.
+C<sv_2pv()> and C<sv_2pv_nomg> usually end up here too.
=cut
*/
char *
-Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags)
+Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
{
dVAR;
- register char *s;
+ char *s;
if (!sv) {
if (lp)
@@ -2734,191 +2741,143 @@
*lp = 0;
return (char *)"";
}
- if (SvGMAGICAL(sv)) {
- if (flags & SV_GMAGIC)
- mg_get(sv);
- if (SvPOKp(sv)) {
- if (lp)
- *lp = SvCUR(sv);
- if (flags & SV_MUTABLE_RETURN)
- return SvPVX_mutable(sv);
- if (flags & SV_CONST_RETURN)
- return (char *)SvPVX_const(sv);
- return SvPVX(sv);
- }
- if (SvIOKp(sv) || SvNOKp(sv)) {
- char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
- STRLEN len;
+ if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
+ mg_get(sv);
+ if (SvROK(sv)) {
+ if (SvAMAGIC(sv)) {
+ SV *tmpstr;
+ if (flags & SV_SKIP_OVERLOAD)
+ return NULL;
+ tmpstr = AMG_CALLunary(sv, string_amg);
+ TAINT_IF(tmpstr && SvTAINTED(tmpstr));
+ if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
+ /* Unwrap this: */
+ /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
+ */
- if (SvIOKp(sv)) {
- len = SvIsUV(sv)
- ? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv))
- : my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv));
- } else if(SvNVX(sv) == 0.0) {
- tbuf[0] = '0';
- tbuf[1] = 0;
- len = 1;
- } else {
- Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
- len = strlen(tbuf);
- }
- assert(!SvROK(sv));
- {
- dVAR;
-
- SvUPGRADE(sv, SVt_PV);
- if (lp)
- *lp = len;
- s = SvGROW_mutable(sv, len + 1);
- SvCUR_set(sv, len);
- SvPOKp_on(sv);
- return (char*)memcpy(s, tbuf, len + 1);
- }
- }
- if (SvROK(sv)) {
- goto return_rok;
- }
- assert(SvTYPE(sv) >= SVt_PVMG);
- /* This falls through to the report_uninit near the end of the
- function. */
- } else if (SvTHINKFIRST(sv)) {
- if (SvROK(sv)) {
- return_rok:
- if (SvAMAGIC(sv)) {
- SV *tmpstr;
- if (flags & SV_SKIP_OVERLOAD)
- return NULL;
- tmpstr = AMG_CALLunary(sv, string_amg);
- TAINT_IF(tmpstr && SvTAINTED(tmpstr));
- if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
- /* Unwrap this: */
- /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
- */
-
- char *pv;
- if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
- if (flags & SV_CONST_RETURN) {
- pv = (char *) SvPVX_const(tmpstr);
- } else {
- pv = (flags & SV_MUTABLE_RETURN)
- ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
- }
- if (lp)
- *lp = SvCUR(tmpstr);
+ char *pv;
+ if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
+ if (flags & SV_CONST_RETURN) {
+ pv = (char *) SvPVX_const(tmpstr);
} else {
- pv = sv_2pv_flags(tmpstr, lp, flags);
+ pv = (flags & SV_MUTABLE_RETURN)
+ ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
}
- if (SvUTF8(tmpstr))
- SvUTF8_on(sv);
- else
- SvUTF8_off(sv);
- return pv;
+ if (lp)
+ *lp = SvCUR(tmpstr);
+ } else {
+ pv = sv_2pv_flags(tmpstr, lp, flags);
}
+ if (SvUTF8(tmpstr))
+ SvUTF8_on(sv);
+ else
+ SvUTF8_off(sv);
+ return pv;
}
- {
- STRLEN len;
- char *retval;
- char *buffer;
- SV *const referent = SvRV(sv);
+ }
+ {
+ STRLEN len;
+ char *retval;
+ char *buffer;
+ SV *const referent = SvRV(sv);
- if (!referent) {
- len = 7;
- retval = buffer = savepvn("NULLREF", len);
- } else if (SvTYPE(referent) == SVt_REGEXP) {
- REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
- I32 seen_evals = 0;
+ if (!referent) {
+ len = 7;
+ retval = buffer = savepvn("NULLREF", len);
+ } else if (SvTYPE(referent) == SVt_REGEXP &&
+ (!(PL_curcop->cop_hints & HINT_NO_AMAGIC) ||
+ amagic_is_enabled(string_amg))) {
+ REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
- assert(re);
+ assert(re);
- /* If the regex is UTF-8 we want the containing scalar to
- have an UTF-8 flag too */
- if (RX_UTF8(re))
- SvUTF8_on(sv);
- else
- SvUTF8_off(sv);
+ /* If the regex is UTF-8 we want the containing scalar to
+ have an UTF-8 flag too */
+ if (RX_UTF8(re))
+ SvUTF8_on(sv);
+ else
+ SvUTF8_off(sv);
- if ((seen_evals = RX_SEEN_EVALS(re)))
- PL_reginterp_cnt += seen_evals;
-
- if (lp)
- *lp = RX_WRAPLEN(re);
+ if (lp)
+ *lp = RX_WRAPLEN(re);
- return RX_WRAPPED(re);
- } else {
- const char *const typestr = sv_reftype(referent, 0);
- const STRLEN typelen = strlen(typestr);
- UV addr = PTR2UV(referent);
- const char *stashname = NULL;
- STRLEN stashnamelen = 0; /* hush, gcc */
- const char *buffer_end;
+ return RX_WRAPPED(re);
+ } else {
+ const char *const typestr = sv_reftype(referent, 0);
+ const STRLEN typelen = strlen(typestr);
+ UV addr = PTR2UV(referent);
+ const char *stashname = NULL;
+ STRLEN stashnamelen = 0; /* hush, gcc */
+ const char *buffer_end;
- if (SvOBJECT(referent)) {
- const HEK *const name = HvNAME_HEK(SvSTASH(referent));
+ if (SvOBJECT(referent)) {
+ const HEK *const name = HvNAME_HEK(SvSTASH(referent));
- if (name) {
- stashname = HEK_KEY(name);
- stashnamelen = HEK_LEN(name);
+ if (name) {
+ stashname = HEK_KEY(name);
+ stashnamelen = HEK_LEN(name);
- if (HEK_UTF8(name)) {
- SvUTF8_on(sv);
- } else {
- SvUTF8_off(sv);
- }
+ if (HEK_UTF8(name)) {
+ SvUTF8_on(sv);
} else {
- stashname = "__ANON__";
- stashnamelen = 8;
+ SvUTF8_off(sv);
}
- len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
- + 2 * sizeof(UV) + 2 /* )\0 */;
} else {
- len = typelen + 3 /* (0x */
- + 2 * sizeof(UV) + 2 /* )\0 */;
+ stashname = "__ANON__";
+ stashnamelen = 8;
}
+ len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
+ + 2 * sizeof(UV) + 2 /* )\0 */;
+ } else {
+ len = typelen + 3 /* (0x */
+ + 2 * sizeof(UV) + 2 /* )\0 */;
+ }
- Newx(buffer, len, char);
- buffer_end = retval = buffer + len;
+ Newx(buffer, len, char);
+ buffer_end = retval = buffer + len;
- /* Working backwards */
- *--retval = '\0';
- *--retval = ')';
- do {
- *--retval = PL_hexdigit[addr & 15];
- } while (addr >>= 4);
- *--retval = 'x';
- *--retval = '0';
- *--retval = '(';
+ /* Working backwards */
+ *--retval = '\0';
+ *--retval = ')';
+ do {
+ *--retval = PL_hexdigit[addr & 15];
+ } while (addr >>= 4);
+ *--retval = 'x';
+ *--retval = '0';
+ *--retval = '(';
- retval -= typelen;
- memcpy(retval, typestr, typelen);
+ retval -= typelen;
+ memcpy(retval, typestr, typelen);
- if (stashname) {
- *--retval = '=';
- retval -= stashnamelen;
- memcpy(retval, stashname, stashnamelen);
- }
- /* retval may not necessarily have reached the start of the
- buffer here. */
- assert (retval >= buffer);
+ if (stashname) {
+ *--retval = '=';
+ retval -= stashnamelen;
+ memcpy(retval, stashname, stashnamelen);
+ }
+ /* retval may not necessarily have reached the start of the
+ buffer here. */
+ assert (retval >= buffer);
- len = buffer_end - retval - 1; /* -1 for that \0 */
- }
- if (lp)
- *lp = len;
- SAVEFREEPV(buffer);
- return retval;
+ len = buffer_end - retval - 1; /* -1 for that \0 */
}
- }
- if (SvREADONLY(sv) && !SvOK(sv)) {
if (lp)
- *lp = 0;
- if (flags & SV_UNDEF_RETURNS_NULL)
- return NULL;
- if (ckWARN(WARN_UNINITIALIZED))
- report_uninit(sv);
- return (char *)"";
+ *lp = len;
+ SAVEFREEPV(buffer);
+ return retval;
}
}
- if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
+
+ if (SvPOKp(sv)) {
+ if (lp)
+ *lp = SvCUR(sv);
+ if (flags & SV_MUTABLE_RETURN)
+ return SvPVX_mutable(sv);
+ if (flags & SV_CONST_RETURN)
+ return (char *)SvPVX_const(sv);
+ return SvPVX(sv);
+ }
+
+ if (SvIOK(sv)) {
/* I'm assuming that if both IV and NV are equally valid then
converting the IV is going to be more efficient */
const U32 isUIOK = SvIsUV(sv);
@@ -2936,7 +2895,7 @@
s += len;
*s = '\0';
}
- else if (SvNOKp(sv)) {
+ else if (SvNOK(sv)) {
if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
if (SvNVX(sv) == 0.0) {
@@ -2957,42 +2916,36 @@
*--s = '\0';
#endif
}
- else {
- if (isGV_with_GP(sv)) {
- GV *const gv = MUTABLE_GV(sv);
- const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
- SV *const buffer = sv_newmortal();
+ else if (isGV_with_GP(sv)) {
+ GV *const gv = MUTABLE_GV(sv);
+ SV *const buffer = sv_newmortal();
- /* FAKE globs can get coerced, so need to turn this off temporarily
- if it is on. */
- SvFAKE_off(gv);
- gv_efullname3(buffer, gv, "*");
- SvFLAGS(gv) |= wasfake;
+ gv_efullname3(buffer, gv, "*");
- if (SvPOK(buffer)) {
- if (lp) {
- *lp = SvCUR(buffer);
- }
- return SvPVX(buffer);
- }
- else {
- if (lp)
- *lp = 0;
- return (char *)"";
- }
- }
-
+ assert(SvPOK(buffer));
+ if (SvUTF8(buffer))
+ SvUTF8_on(sv);
if (lp)
+ *lp = SvCUR(buffer);
+ return SvPVX(buffer);
+ }
+ else if (isREGEXP(sv)) {
+ if (lp) *lp = RX_WRAPLEN((REGEXP *)sv);
+ return RX_WRAPPED((REGEXP *)sv);
+ }
+ else {
+ if (lp)
*lp = 0;
if (flags & SV_UNDEF_RETURNS_NULL)
return NULL;
- if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
+ if (!PL_localizing && !SvPADTMP(sv) && ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
- if (SvTYPE(sv) < SVt_PV)
- /* Typically the caller expects that sv_any is not NULL now. */
+ /* Typically the caller expects that sv_any is not NULL now. */
+ if (!SvREADONLY(sv) && SvTYPE(sv) < SVt_PV)
sv_upgrade(sv, SVt_PV);
return (char *)"";
}
+
{
const STRLEN len = s - SvPVX_const(sv);
if (lp)
@@ -3020,17 +2973,37 @@
string. Mostly uses sv_2pv_flags to do its work, except when that
would lose the UTF-8'ness of the PV.
+=for apidoc sv_copypv_nomg
+
+Like sv_copypv, but doesn't invoke get magic first.
+
+=for apidoc sv_copypv_flags
+
+Implementation of sv_copypv and sv_copypv_nomg. Calls get magic iff flags
+include SV_GMAGIC.
+
=cut
*/
void
-Perl_sv_copypv(pTHX_ SV *const dsv, register SV *const ssv)
+Perl_sv_copypv(pTHX_ SV *const dsv, SV *const ssv)
{
+ PERL_ARGS_ASSERT_SV_COPYPV;
+
+ sv_copypv_flags(dsv, ssv, 0);
+}
+
+void
+Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
+{
STRLEN len;
- const char * const s = SvPV_const(ssv,len);
+ const char *s;
- PERL_ARGS_ASSERT_SV_COPYPV;
+ PERL_ARGS_ASSERT_SV_COPYPV_FLAGS;
+ if ((flags & SV_GMAGIC) && SvGMAGICAL(ssv))
+ mg_get(ssv);
+ s = SvPV_nomg_const(ssv,len);
sv_setpvn(dsv,s,len);
if (SvUTF8(ssv))
SvUTF8_on(dsv);
@@ -3051,11 +3024,17 @@
*/
char *
-Perl_sv_2pvbyte(pTHX_ register SV *const sv, STRLEN *const lp)
+Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp)
{
PERL_ARGS_ASSERT_SV_2PVBYTE;
- SvGETMAGIC(sv);
+ if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
+ || isGV_with_GP(sv) || SvROK(sv)) {
+ SV *sv2 = sv_newmortal();
+ sv_copypv(sv2,sv);
+ sv = sv2;
+ }
+ else SvGETMAGIC(sv);
sv_utf8_downgrade(sv,0);
return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
}
@@ -3072,12 +3051,17 @@
*/
char *
-Perl_sv_2pvutf8(pTHX_ register SV *const sv, STRLEN *const lp)
+Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp)
{
PERL_ARGS_ASSERT_SV_2PVUTF8;
- sv_utf8_upgrade(sv);
- return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
+ if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
+ || isGV_with_GP(sv) || SvROK(sv))
+ sv = sv_mortalcopy(sv);
+ else
+ SvGETMAGIC(sv);
+ sv_utf8_upgrade_nomg(sv);
+ return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
}
@@ -3091,7 +3075,7 @@
=for apidoc sv_2bool_flags
This function is only used by sv_true() and friends, and only if
-the latter's argument is neither SvPOK, SvIOK nor SvNOK. If the flags
+the latter's argument is neither SvPOK, SvIOK nor SvNOK. If the flags
contain SV_GMAGIC, then it does an mg_get() first.
@@ -3099,7 +3083,7 @@
*/
bool
-Perl_sv_2bool_flags(pTHX_ register SV *const sv, const I32 flags)
+Perl_sv_2bool_flags(pTHX_ SV *const sv, const I32 flags)
{
dVAR;
@@ -3117,30 +3101,7 @@
}
return SvRV(sv) != 0;
}
- if (SvPOKp(sv)) {
- register XPV* const Xpvtmp = (XPV*)SvANY(sv);
- if (Xpvtmp &&
- (*sv->sv_u.svu_pv > '0' ||
- Xpvtmp->xpv_cur > 1 ||
- (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
- return 1;
- else
- return 0;
- }
- else {
- if (SvIOKp(sv))
- return SvIVX(sv) != 0;
- else {
- if (SvNOKp(sv))
- return SvNVX(sv) != 0.0;
- else {
- if (isGV_with_GP(sv))
- return TRUE;
- else
- return FALSE;
- }
- }
- }
+ return SvTRUE_common(sv, isGV_with_GP(sv) ? 1 : 0);
}
/*
@@ -3153,12 +3114,12 @@
if the whole string is the same in UTF-8 as not.
Returns the number of bytes in the converted string
-This is not as a general purpose byte encoding to Unicode interface:
+This is not a general purpose byte encoding to Unicode interface:
use the Encode extension for that.
=for apidoc sv_utf8_upgrade_nomg
-Like sv_utf8_upgrade, but doesn't do magic on C<sv>
+Like sv_utf8_upgrade, but doesn't do magic on C<sv>.
=for apidoc sv_utf8_upgrade_flags
@@ -3165,13 +3126,14 @@
Converts the PV of an SV to its UTF-8-encoded form.
Forces the SV to string form if it is not already.
Always sets the SvUTF8 flag to avoid future validity checks even
-if all the bytes are invariant in UTF-8. If C<flags> has C<SV_GMAGIC> bit set,
+if all the bytes are invariant in UTF-8.
+If C<flags> has C<SV_GMAGIC> bit set,
will C<mg_get> on C<sv> if appropriate, else not.
Returns the number of bytes in the converted string
C<sv_utf8_upgrade> and
C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
-This is not as a general purpose byte encoding to Unicode interface:
+This is not a general purpose byte encoding to Unicode interface:
use the Encode extension for that.
=cut
@@ -3208,7 +3170,7 @@
*/
STRLEN
-Perl_sv_utf8_upgrade_flags_grow(pTHX_ register SV *const sv, const I32 flags, STRLEN extra)
+Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra)
{
dVAR;
@@ -3216,7 +3178,7 @@
if (sv == &PL_sv_undef)
return 0;
- if (!SvPOK(sv)) {
+ if (!SvPOK_nog(sv)) {
STRLEN len = 0;
if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
(void) sv_2pv_flags(sv,&len, flags);
@@ -3275,6 +3237,7 @@
/* utf8 conversion not needed because all are invariants. Mark as
* UTF-8 even if no variant - saves scanning loop */
SvUTF8_on(sv);
+ if (extra) SvGROW(sv, SvCUR(sv) + extra);
return SvCUR(sv);
must_be_utf8:
@@ -3473,7 +3436,7 @@
in this case, either returns false or, if C<fail_ok> is not
true, croaks.
-This is not as a general purpose Unicode to byte encoding interface:
+This is not a general purpose Unicode to byte encoding interface:
use the Encode extension for that.
=cut
@@ -3480,7 +3443,7 @@
*/
bool
-Perl_sv_utf8_downgrade(pTHX_ register SV *const sv, const bool fail_ok)
+Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok)
{
dVAR;
@@ -3540,15 +3503,12 @@
*/
void
-Perl_sv_utf8_encode(pTHX_ register SV *const sv)
+Perl_sv_utf8_encode(pTHX_ SV *const sv)
{
PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
- if (SvIsCOW(sv)) {
- sv_force_normal_flags(sv, 0);
- }
if (SvREADONLY(sv)) {
- Perl_croak_no_modify(aTHX);
+ sv_force_normal_flags(sv, 0);
}
(void) sv_utf8_upgrade(sv);
SvUTF8_off(sv);
@@ -3559,8 +3519,8 @@
If the PV of the SV is an octet sequence in UTF-8
and contains a multiple-byte character, the C<SvUTF8> flag is turned on
-so that it looks like a character. If the PV contains only single-byte
-characters, the C<SvUTF8> flag stays being off.
+so that it looks like a character. If the PV contains only single-byte
+characters, the C<SvUTF8> flag stays off.
Scans PV for validity and returns false if the PV is invalid UTF-8.
=cut
@@ -3567,7 +3527,7 @@
*/
bool
-Perl_sv_utf8_decode(pTHX_ register SV *const sv)
+Perl_sv_utf8_decode(pTHX_ SV *const sv)
{
PERL_ARGS_ASSERT_SV_UTF8_DECODE;
@@ -3585,7 +3545,7 @@
* we want to make sure everything inside is valid utf8 first.
*/
c = start = (const U8 *) SvPVX_const(sv);
- if (!is_utf8_string(c, SvCUR(sv)+1))
+ if (!is_utf8_string(c, SvCUR(sv)))
return FALSE;
e = (const U8 *) SvEND(sv);
while (c < e) {
@@ -3620,7 +3580,7 @@
Copies the contents of the source SV C<ssv> into the destination SV
C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
-function if the source SV needs to be reused. Does not handle 'set' magic.
+function if the source SV needs to be reused. Does not handle 'set' magic.
Loosely speaking, it performs a copy-by-value, obliterating any previous
content of the destination.
@@ -3632,12 +3592,13 @@
Copies the contents of the source SV C<ssv> into the destination SV
C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
-function if the source SV needs to be reused. Does not handle 'set' magic.
+function if the source SV needs to be reused. Does not handle 'set' magic.
Loosely speaking, it performs a copy-by-value, obliterating any previous
content of the destination.
If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
-C<ssv> if appropriate, else not. If the C<flags> parameter has the
-C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
+C<ssv> if appropriate, else not. If the C<flags>
+parameter has the C<NOSTEAL> bit set then the
+buffers of temps will not be stolen. <sv_setsv>
and C<sv_setsv_nomg> are implemented in terms of this function.
You probably want to use one of the assortment of wrappers, such as
@@ -3670,14 +3631,15 @@
}
SvUPGRADE(dstr, SVt_PVGV);
(void)SvOK_off(dstr);
- /* FIXME - why are we doing this, then turning it off and on again
- below? */
+ /* We have to turn this on here, even though we turn it off
+ below, as GvSTASH will fail an assertion otherwise. */
isGV_with_GP_on(dstr);
}
GvSTASH(dstr) = GvSTASH(sstr);
if (GvSTASH(dstr))
Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
- gv_name_set(MUTABLE_GV(dstr), name, len, GV_ADD);
+ gv_name_set(MUTABLE_GV(dstr), name, len,
+ GV_ADD | (GvNAMEUTF8(sstr) ? SVf_UTF8 : 0 ));
SvFAKE_on(dstr); /* can coerce to non-glob */
}
@@ -3705,7 +3667,7 @@
mro_changes = 1;
}
- /* We don’t need to check the name of the destination if it was not a
+ /* We don't need to check the name of the destination if it was not a
glob to begin with. */
if(dtype == SVt_PVGV) {
const char * const name = GvNAME((const GV *)dstr);
@@ -3714,7 +3676,6 @@
/* The stash may have been detached from the symbol table, so
check its name. */
&& GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
- && GvAV((const GV *)sstr)
)
mro_changes = 2;
else {
@@ -3735,7 +3696,7 @@
}
gp_free(MUTABLE_GV(dstr));
- isGV_with_GP_off(dstr);
+ isGV_with_GP_off(dstr); /* SvOK_off does not like globs. */
(void)SvOK_off(dstr);
isGV_with_GP_on(dstr);
GvINTRO_off(dstr); /* one-shot flag */
@@ -3749,6 +3710,7 @@
}
GvMULTI_on(dstr);
if(mro_changes == 2) {
+ if (GvAV((const GV *)sstr)) {
MAGIC *mg;
SV * const sref = (SV *)GvAV((const GV *)dstr);
if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
@@ -3760,7 +3722,8 @@
av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dstr));
}
else sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
- mro_isa_changed_in(GvSTASH(dstr));
+ }
+ mro_isa_changed_in(GvSTASH(dstr));
}
else if(mro_changes == 3) {
HV * const stash = GvHV(dstr);
@@ -3777,8 +3740,8 @@
static void
S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
{
- SV * const sref = SvREFCNT_inc(SvRV(sstr));
- SV *dref = NULL;
+ SV * const sref = SvRV(sstr);
+ SV *dref;
const int intro = GvINTRO(dstr);
SV **location;
U8 import_flag = 0;
@@ -3824,54 +3787,62 @@
GvCVGEN(dstr) = 0; /* Switch off cacheness. */
}
}
- SAVEGENERICSV(*location);
+ /* SAVEt_GVSLOT takes more room on the savestack and has more
+ overhead in leave_scope than SAVEt_GENERIC_SV. But for CVs
+ leave_scope needs access to the GV so it can reset method
+ caches. We must use SAVEt_GVSLOT whenever the type is
+ SVt_PVCV, even if the stash is anonymous, as the stash may
+ gain a name somehow before leave_scope. */
+ if (stype == SVt_PVCV) {
+ /* There is no save_pushptrptrptr. Creating it for this
+ one call site would be overkill. So inline the ss add
+ routines here. */
+ dSS_ADD;
+ SS_ADD_PTR(dstr);
+ SS_ADD_PTR(location);
+ SS_ADD_PTR(SvREFCNT_inc(*location));
+ SS_ADD_UV(SAVEt_GVSLOT);
+ SS_ADD_END(4);
+ }
+ else SAVEGENERICSV(*location);
}
- else
- dref = *location;
+ dref = *location;
if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
CV* const cv = MUTABLE_CV(*location);
if (cv) {
if (!GvCVGEN((const GV *)dstr) &&
- (CvROOT(cv) || CvXSUB(cv)))
+ (CvROOT(cv) || CvXSUB(cv)) &&
+ /* redundant check that avoids creating the extra SV
+ most of the time: */
+ (CvCONST(cv) || ckWARN(WARN_REDEFINE)))
{
- /* Redefining a sub - warning is mandatory if
- it was a const and its value changed. */
- if (CvCONST(cv) && CvCONST((const CV *)sref)
- && cv_const_sv(cv)
- == cv_const_sv((const CV *)sref)) {
- NOOP;
- /* They are 2 constant subroutines generated from
- the same constant. This probably means that
- they are really the "same" proxy subroutine
- instantiated in 2 places. Most likely this is
- when a constant is exported twice. Don't warn.
- */
- }
- else if (ckWARN(WARN_REDEFINE)
- || (CvCONST(cv)
- && (!CvCONST((const CV *)sref)
- || sv_cmp(cv_const_sv(cv),
- cv_const_sv((const CV *)
- sref))))) {
- Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
- (const char *)
- (CvCONST(cv)
- ? "Constant subroutine %s::%s redefined"
- : "Subroutine %s::%s redefined"),
- HvNAME_get(GvSTASH((const GV *)dstr)),
- GvENAME(MUTABLE_GV(dstr)));
- }
+ SV * const new_const_sv =
+ CvCONST((const CV *)sref)
+ ? cv_const_sv((const CV *)sref)
+ : NULL;
+ report_redefined_cv(
+ sv_2mortal(Perl_newSVpvf(aTHX_
+ "%"HEKf"::%"HEKf,
+ HEKfARG(
+ HvNAME_HEK(GvSTASH((const GV *)dstr))
+ ),
+ HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr)))
+ )),
+ cv,
+ CvCONST((const CV *)sref) ? &new_const_sv : NULL
+ );
}
if (!intro)
- cv_ckproto_len(cv, (const GV *)dstr,
- SvPOK(sref) ? SvPVX_const(sref) : NULL,
- SvPOK(sref) ? SvCUR(sref) : 0);
+ cv_ckproto_len_flags(cv, (const GV *)dstr,
+ SvPOK(sref) ? CvPROTO(sref) : NULL,
+ SvPOK(sref) ? CvPROTOLEN(sref) : 0,
+ SvPOK(sref) ? SvUTF8(sref) : 0);
}
GvCVGEN(dstr) = 0; /* Switch off cacheness. */
GvASSUMECV_on(dstr);
- if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
+ if(GvSTASH(dstr)) gv_method_changed(dstr); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
}
- *location = sref;
+ *location = SvREFCNT_inc_simple_NN(sref);
if (import_flag && !(GvFLAGS(dstr) & import_flag)
&& CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
GvFLAGS(dstr) |= import_flag;
@@ -3936,27 +3907,48 @@
mg = mg_find(sref, PERL_MAGIC_isa);
}
/* Since the *ISA assignment could have affected more than
- one stash, don’t call mro_isa_changed_in directly, but let
+ one stash, don't call mro_isa_changed_in directly, but let
magic_clearisa do it for us, as it already has the logic for
dealing with globs vs arrays of globs. */
assert(mg);
Perl_magic_clearisa(aTHX_ NULL, mg);
}
+ else if (stype == SVt_PVIO) {
+ DEBUG_o(Perl_deb(aTHX_ "glob_assign_ref clearing PL_stashcache\n"));
+ /* It's a cache. It will rebuild itself quite happily.
+ It's a lot of effort to work out exactly which key (or keys)
+ might be invalidated by the creation of the this file handle.
+ */
+ hv_clear(PL_stashcache);
+ }
break;
}
- SvREFCNT_dec(dref);
+ if (!intro) SvREFCNT_dec(dref);
if (SvTAINTED(sstr))
SvTAINT(dstr);
return;
}
+/* Work around compiler warnings about unsigned >= THRESHOLD when thres-
+ hold is 0. */
+#if SV_COW_THRESHOLD
+# define GE_COW_THRESHOLD(len) ((len) >= SV_COW_THRESHOLD)
+#else
+# define GE_COW_THRESHOLD(len) 1
+#endif
+#if SV_COWBUF_THRESHOLD
+# define GE_COWBUF_THRESHOLD(len) ((len) >= SV_COWBUF_THRESHOLD)
+#else
+# define GE_COWBUF_THRESHOLD(len) 1
+#endif
+
void
-Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
+Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
{
dVAR;
- register U32 sflags;
- register int dtype;
- register svtype stype;
+ U32 sflags;
+ int dtype;
+ svtype stype;
PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
@@ -3977,13 +3969,6 @@
stype = SvTYPE(sstr);
dtype = SvTYPE(dstr);
- (void)SvAMAGIC_off(dstr);
- if ( SvVOK(dstr) )
- {
- /* need to nuke the magic */
- mg_free(dstr);
- }
-
/* There's a lot of redundancy below but we're going for speed here */
switch (stype) {
@@ -4051,15 +4036,6 @@
}
goto undef_sstr;
- case SVt_PVFM:
-#ifdef PERL_OLD_COPY_ON_WRITE
- if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
- if (dtype < SVt_PVIV)
- sv_upgrade(dstr, SVt_PVIV);
- break;
- }
- /* Fall through */
-#endif
case SVt_PV:
if (dtype < SVt_PV)
sv_upgrade(dstr, SVt_PV);
@@ -4076,6 +4052,7 @@
{
const char * const type = sv_reftype(sstr,0);
if (PL_op)
+ /* diag_listed_as: Bizarre copy of %s */
Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
else
Perl_croak(aTHX_ "Bizarre copy of %s", type);
@@ -4083,15 +4060,22 @@
break;
case SVt_REGEXP:
+ upgregexp:
if (dtype < SVt_REGEXP)
+ {
+ if (dtype >= SVt_PV) {
+ SvPV_free(dstr);
+ SvPV_set(dstr, 0);
+ SvLEN_set(dstr, 0);
+ SvCUR_set(dstr, 0);
+ }
sv_upgrade(dstr, SVt_REGEXP);
+ }
break;
/* case SVt_BIND: */
case SVt_PVLV:
case SVt_PVGV:
- /* SvVALID means that this PVGV is playing at being an FBM. */
-
case SVt_PVMG:
if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
mg_get(sstr);
@@ -4103,7 +4087,10 @@
return;
}
if (stype == SVt_PVLV)
+ {
+ if (isREGEXP(sstr)) goto upgregexp;
SvUPGRADE(dstr, SVt_PVNV);
+ }
else
SvUPGRADE(dstr, (svtype)stype);
}
@@ -4113,7 +4100,7 @@
dtype = SvTYPE(dstr);
sflags = SvFLAGS(sstr);
- if (dtype == SVt_PVCV || dtype == SVt_PVFM) {
+ if (dtype == SVt_PVCV) {
/* Assigning to a subroutine sets the prototype. */
if (SvOK(sstr)) {
STRLEN len;
@@ -4124,12 +4111,15 @@
SvCUR_set(dstr, len);
SvPOK_only(dstr);
SvFLAGS(dstr) |= sflags & SVf_UTF8;
+ CvAUTOLOAD_off(dstr);
} else {
SvOK_off(dstr);
}
- } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) {
+ }
+ else if (dtype == SVt_PVAV || dtype == SVt_PVHV || dtype == SVt_PVFM) {
const char * const type = sv_reftype(dstr,0);
if (PL_op)
+ /* diag_listed_as: Cannot copy to %s */
Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
else
Perl_croak(aTHX_ "Cannot copy to %s", type);
@@ -4175,7 +4165,7 @@
"Undefined value assigned to typeglob");
}
else {
- GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
+ GV *gv = gv_fetchsv_nomg(sstr, GV_ADD, SVt_PVGV);
if (dstr != (const SV *)gv) {
const char * const name = GvNAME((const GV *)dstr);
const STRLEN len = GvNAMELEN(dstr);
@@ -4211,11 +4201,14 @@
}
}
}
- else if (dtype == SVt_REGEXP && stype == SVt_REGEXP) {
+ else if ((dtype == SVt_REGEXP || dtype == SVt_PVLV)
+ && (stype == SVt_REGEXP || isREGEXP(sstr))) {
reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
}
else if (sflags & SVp_POK) {
bool isSwipe = 0;
+ const STRLEN cur = SvCUR(sstr);
+ const STRLEN len = SvLEN(sstr);
/*
* Check to see if we can just swipe the string. If so, it's a
@@ -4238,13 +4231,20 @@
shared hash keys then we don't do the COW setup, even if the
source scalar is a shared hash key scalar. */
(((flags & SV_COW_SHARED_HASH_KEYS)
- ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY)
+ ? !(sflags & SVf_IsCOW)
+#ifdef PERL_NEW_COPY_ON_WRITE
+ || (len &&
+ ((!GE_COWBUF_THRESHOLD(cur) && SvLEN(dstr) > cur)
+ /* If this is a regular (non-hek) COW, only so many COW
+ "copies" are possible. */
+ || CowREFCNT(sstr) == SV_COW_REFCNT_MAX))
+#endif
: 1 /* If making a COW copy is forbidden then the behaviour we
desire is as if the source SV isn't actually already
COW, even if it is. So we act as if the source flags
are not COW, rather than actually testing them. */
)
-#ifndef PERL_OLD_COPY_ON_WRITE
+#ifndef PERL_ANY_COW
/* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
Conceptually PERL_OLD_COPY_ON_WRITE being defined should
@@ -4254,31 +4254,43 @@
in a newer implementation. */
/* If we are COW and dstr is a suitable target then we drop down
into the else and make dest a COW of us. */
- || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
+ || (SvFLAGS(dstr) & SVf_BREAK)
#endif
)
&&
!(isSwipe =
+#ifdef PERL_NEW_COPY_ON_WRITE
+ /* slated for free anyway (and not COW)? */
+ (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP &&
+#else
(sflags & SVs_TEMP) && /* slated for free anyway? */
+#endif
!(sflags & SVf_OOK) && /* and not involved in OOK hack? */
(!(flags & SV_NOSTEAL)) &&
/* and we're allowed to steal temps */
SvREFCNT(sstr) == 1 && /* and no other references to it? */
- SvLEN(sstr)) /* and really is a string */
-#ifdef PERL_OLD_COPY_ON_WRITE
+ len) /* and really is a string */
+#ifdef PERL_ANY_COW
&& ((flags & SV_COW_SHARED_HASH_KEYS)
? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
+# ifdef PERL_OLD_COPY_ON_WRITE
&& (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
- && SvTYPE(sstr) >= SVt_PVIV && SvTYPE(sstr) != SVt_PVFM))
+ && SvTYPE(sstr) >= SVt_PVIV
+# else
+ && !(SvFLAGS(dstr) & SVf_BREAK)
+ && !(sflags & SVf_IsCOW)
+ && GE_COW_THRESHOLD(cur) && cur+1 < len
+ && (GE_COWBUF_THRESHOLD(cur) || SvLEN(dstr) < cur+1)
+# endif
+ ))
: 1)
#endif
) {
/* Failed the swipe test, and it's not a shared hash key either.
Have to copy the string. */
- STRLEN len = SvCUR(sstr);
- SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
- Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
- SvCUR_set(dstr, len);
+ SvGROW(dstr, cur + 1); /* inlined from sv_setpvn */
+ Move(SvPVX_const(sstr),SvPVX(dstr),cur,char);
+ SvCUR_set(dstr, cur);
*SvEND(dstr) = '\0';
} else {
/* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
@@ -4290,15 +4302,17 @@
sv_dump(sstr);
sv_dump(dstr);
}
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
if (!isSwipe) {
- if ((sflags & (SVf_FAKE | SVf_READONLY))
- != (SVf_FAKE | SVf_READONLY)) {
- SvREADONLY_on(sstr);
- SvFAKE_on(sstr);
+ if (!(sflags & SVf_IsCOW)) {
+ SvIsCOW_on(sstr);
+# ifdef PERL_OLD_COPY_ON_WRITE
/* Make the source SV into a loop of 1.
(about to become 2) */
SV_COW_NEXT_SV_SET(sstr, sstr);
+# else
+ CowREFCNT(sstr) = 0;
+# endif
}
}
#endif
@@ -4309,15 +4323,17 @@
if (!isSwipe) {
/* making another shared SV. */
- STRLEN cur = SvCUR(sstr);
- STRLEN len = SvLEN(sstr);
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
if (len) {
+# ifdef PERL_OLD_COPY_ON_WRITE
assert (SvTYPE(dstr) >= SVt_PVIV);
/* SvIsCOW_normal */
/* splice us in between source and next-after-source. */
SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
SV_COW_NEXT_SV_SET(sstr, dstr);
+# else
+ CowREFCNT(sstr)++;
+# endif
SvPV_set(dstr, SvPVX_mutable(sstr));
} else
#endif
@@ -4332,8 +4348,7 @@
}
SvLEN_set(dstr, len);
SvCUR_set(dstr, cur);
- SvREADONLY_on(dstr);
- SvFAKE_on(dstr);
+ SvIsCOW_on(dstr);
}
else
{ /* Passes the swipe test. */
@@ -4382,15 +4397,7 @@
}
else {
if (isGV_with_GP(sstr)) {
- /* This stringification rule for globs is spread in 3 places.
- This feels bad. FIXME. */
- const U32 wasfake = sflags & SVf_FAKE;
-
- /* FAKE globs can get coerced, so need to turn this off
- temporarily if it is on. */
- SvFAKE_off(sstr);
gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
- SvFLAGS(sstr) |= wasfake;
}
else
(void)SvOK_off(dstr);
@@ -4408,7 +4415,7 @@
*/
void
-Perl_sv_setsv_mg(pTHX_ SV *const dstr, register SV *const sstr)
+Perl_sv_setsv_mg(pTHX_ SV *const dstr, SV *const sstr)
{
PERL_ARGS_ASSERT_SV_SETSV_MG;
@@ -4416,13 +4423,18 @@
SvSETMAGIC(dstr);
}
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
+# ifdef PERL_OLD_COPY_ON_WRITE
+# define SVt_COW SVt_PVIV
+# else
+# define SVt_COW SVt_PV
+# endif
SV *
Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
{
STRLEN cur = SvCUR(sstr);
STRLEN len = SvLEN(sstr);
- register char *new_pv;
+ char *new_pv;
PERL_ARGS_ASSERT_SV_SETSV_COW;
@@ -4438,18 +4450,20 @@
if (SvTHINKFIRST(dstr))
sv_force_normal_flags(dstr, SV_COW_DROP_PV);
else if (SvPVX_const(dstr))
- Safefree(SvPVX_const(dstr));
+ Safefree(SvPVX_mutable(dstr));
}
else
new_SV(dstr);
- SvUPGRADE(dstr, SVt_PVIV);
+ SvUPGRADE(dstr, SVt_COW);
assert (SvPOK(sstr));
assert (SvPOKp(sstr));
+# ifdef PERL_OLD_COPY_ON_WRITE
assert (!SvIOK(sstr));
assert (!SvIOKp(sstr));
assert (!SvNOK(sstr));
assert (!SvNOKp(sstr));
+# endif
if (SvIsCOW(sstr)) {
@@ -4460,22 +4474,34 @@
new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
goto common_exit;
}
+# ifdef PERL_OLD_COPY_ON_WRITE
SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
+# else
+ assert(SvCUR(sstr)+1 < SvLEN(sstr));
+ assert(CowREFCNT(sstr) < SV_COW_REFCNT_MAX);
+# endif
} else {
assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
- SvUPGRADE(sstr, SVt_PVIV);
- SvREADONLY_on(sstr);
- SvFAKE_on(sstr);
+ SvUPGRADE(sstr, SVt_COW);
+ SvIsCOW_on(sstr);
DEBUG_C(PerlIO_printf(Perl_debug_log,
"Fast copy on write: Converting sstr to COW\n"));
+# ifdef PERL_OLD_COPY_ON_WRITE
SV_COW_NEXT_SV_SET(dstr, sstr);
+# else
+ CowREFCNT(sstr) = 0;
+# endif
}
+# ifdef PERL_OLD_COPY_ON_WRITE
SV_COW_NEXT_SV_SET(sstr, dstr);
+# else
+ CowREFCNT(sstr)++;
+# endif
new_pv = SvPVX_mutable(sstr);
common_exit:
SvPV_set(dstr, new_pv);
- SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
+ SvFLAGS(dstr) = (SVt_COW|SVf_POK|SVp_POK|SVf_IsCOW);
if (SvUTF8(sstr))
SvUTF8_on(dstr);
SvLEN_set(dstr, len);
@@ -4498,10 +4524,10 @@
*/
void
-Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
+Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
{
dVAR;
- register char *dptr;
+ char *dptr;
PERL_ARGS_ASSERT_SV_SETPVN;
@@ -4514,7 +4540,8 @@
/* len is STRLEN which is unsigned, need to copy to signed */
const IV iv = len;
if (iv < 0)
- Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
+ Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen %"
+ IVdf, iv);
}
SvUPGRADE(sv, SVt_PV);
@@ -4524,6 +4551,7 @@
SvCUR_set(sv, len);
(void)SvPOK_only_UTF8(sv); /* validate pointer */
SvTAINT(sv);
+ if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
}
/*
@@ -4535,7 +4563,7 @@
*/
void
-Perl_sv_setpvn_mg(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
+Perl_sv_setpvn_mg(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
{
PERL_ARGS_ASSERT_SV_SETPVN_MG;
@@ -4553,10 +4581,10 @@
*/
void
-Perl_sv_setpv(pTHX_ register SV *const sv, register const char *const ptr)
+Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr)
{
dVAR;
- register STRLEN len;
+ STRLEN len;
PERL_ARGS_ASSERT_SV_SETPV;
@@ -4573,6 +4601,7 @@
SvCUR_set(sv, len);
(void)SvPOK_only_UTF8(sv); /* validate pointer */
SvTAINT(sv);
+ if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
}
/*
@@ -4584,7 +4613,7 @@
*/
void
-Perl_sv_setpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
+Perl_sv_setpv_mg(pTHX_ SV *const sv, const char *const ptr)
{
PERL_ARGS_ASSERT_SV_SETPV_MG;
@@ -4592,6 +4621,53 @@
SvSETMAGIC(sv);
}
+void
+Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek)
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT_SV_SETHEK;
+
+ if (!hek) {
+ return;
+ }
+
+ if (HEK_LEN(hek) == HEf_SVKEY) {
+ sv_setsv(sv, *(SV**)HEK_KEY(hek));
+ return;
+ } else {
+ const int flags = HEK_FLAGS(hek);
+ if (flags & HVhek_WASUTF8) {
+ STRLEN utf8_len = HEK_LEN(hek);
+ char *as_utf8 = (char *)bytes_to_utf8((U8*)HEK_KEY(hek), &utf8_len);
+ sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
+ SvUTF8_on(sv);
+ return;
+ } else if (flags & HVhek_UNSHARED) {
+ sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek));
+ if (HEK_UTF8(hek))
+ SvUTF8_on(sv);
+ else SvUTF8_off(sv);
+ return;
+ }
+ {
+ SV_CHECK_THINKFIRST_COW_DROP(sv);
+ SvUPGRADE(sv, SVt_PV);
+ Safefree(SvPVX(sv));
+ SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek)));
+ SvCUR_set(sv, HEK_LEN(hek));
+ SvLEN_set(sv, 0);
+ SvIsCOW_on(sv);
+ SvPOK_on(sv);
+ if (HEK_UTF8(hek))
+ SvUTF8_on(sv);
+ else SvUTF8_off(sv);
+ return;
+ }
+ }
+}
+
+
/*
=for apidoc sv_usepvn_flags
@@ -4598,16 +4674,18 @@
Tells an SV to use C<ptr> to find its string value. Normally the
string is stored inside the SV but sv_usepvn allows the SV to use an
outside string. The C<ptr> should point to memory that was allocated
-by C<malloc>. The string length, C<len>, must be supplied. By default
+by C<malloc>. It must be the start of a mallocked block
+of memory, and not a pointer to the middle of it. The
+string length, C<len>, must be supplied. By default
this function will realloc (i.e. move) the memory pointed to by C<ptr>,
so that pointer should not be freed or used by the programmer after
giving it to sv_usepvn, and neither should any pointers from "behind"
that pointer (e.g. ptr + 1) be used.
-If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
+If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
-will be skipped. (i.e. the buffer is actually at least 1 byte longer than
-C<len>, and already meets the requirements for storing in C<SvPVX>)
+will be skipped (i.e. the buffer is actually at least 1 byte longer than
+C<len>, and already meets the requirements for storing in C<SvPVX>).
=cut
*/
@@ -4681,7 +4759,7 @@
(which it can do by means other than releasing copy-on-write Svs)
or by changing the other copy-on-write SVs in the loop. */
STATIC void
-S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after)
+S_sv_release_COW(pTHX_ SV *sv, const char *pvx, SV *after)
{
PERL_ARGS_ASSERT_SV_RELEASE_COW;
@@ -4693,8 +4771,7 @@
/* The SV we point to points back to us (there were only two of us
in the loop.)
Hence other SV is no longer copy on write either. */
- SvFAKE_off(after);
- SvREADONLY_off(after);
+ SvIsCOW_off(after);
} else {
/* We need to follow the pointers around the loop. */
SV *next;
@@ -4715,14 +4792,17 @@
/*
=for apidoc sv_force_normal_flags
-Undo various types of fakery on an SV: if the PV is a shared string, make
+Undo various types of fakery on an SV, where fakery means
+"more than" a string: if the PV is a shared string, make
a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
-we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
+we do the copy, and is also used locally; if this is a
+vstring, drop the vstring magic. If C<SV_COW_DROP_PV> is set
then a copy-on-write scalar drops its PV buffer (if any) and becomes
-SvPOK_off rather than making a copy. (Used where this scalar is about to be
-set to some other value.) In addition, the C<flags> parameter gets passed to
-C<sv_unref_flags()> when unreffing. C<sv_force_normal> calls this function
+SvPOK_off rather than making a copy. (Used where this
+scalar is about to be set to some other value.) In addition,
+the C<flags> parameter gets passed to C<sv_unref_flags()>
+when unreffing. C<sv_force_normal> calls this function
with flags set to 0.
=cut
@@ -4729,32 +4809,48 @@
*/
void
-Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
+Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags)
{
dVAR;
PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
if (SvREADONLY(sv)) {
- if (SvFAKE(sv)) {
- const char * const pvx = SvPVX_const(sv);
- const STRLEN len = SvLEN(sv);
- const STRLEN cur = SvCUR(sv);
- /* next COW sv in the loop. If len is 0 then this is a shared-hash
- key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
- we'll fail an assertion. */
- SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
+ if (IN_PERL_RUNTIME)
+ Perl_croak_no_modify();
+ }
+ else if (SvIsCOW(sv)) {
+ const char * const pvx = SvPVX_const(sv);
+ const STRLEN len = SvLEN(sv);
+ const STRLEN cur = SvCUR(sv);
+# ifdef PERL_OLD_COPY_ON_WRITE
+ /* next COW sv in the loop. If len is 0 then this is a shared-hash
+ key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
+ we'll fail an assertion. */
+ SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
+# endif
- if (DEBUG_C_TEST) {
+ if (DEBUG_C_TEST) {
PerlIO_printf(Perl_debug_log,
"Copy on write: Force normal %ld\n",
(long) flags);
sv_dump(sv);
- }
- SvFAKE_off(sv);
- SvREADONLY_off(sv);
+ }
+ SvIsCOW_off(sv);
+# ifdef PERL_NEW_COPY_ON_WRITE
+ if (len && CowREFCNT(sv) == 0)
+ /* We own the buffer ourselves. */
+ NOOP;
+ else
+# endif
+ {
+
/* This SV doesn't own the buffer, so need to Newx() a new one: */
+# ifdef PERL_NEW_COPY_ON_WRITE
+ /* Must do this first, since the macro uses SvPVX. */
+ if (len) CowREFCNT(sv)--;
+# endif
SvPV_set(sv, NULL);
SvLEN_set(sv, 0);
if (flags & SV_COW_DROP_PV) {
@@ -4767,7 +4863,9 @@
*SvEND(sv) = '\0';
}
if (len) {
+# ifdef PERL_OLD_COPY_ON_WRITE
sv_release_COW(sv, pvx, next);
+# endif
} else {
unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
}
@@ -4775,37 +4873,42 @@
sv_dump(sv);
}
}
- else if (IN_PERL_RUNTIME)
- Perl_croak_no_modify(aTHX);
}
#else
if (SvREADONLY(sv)) {
- if (SvFAKE(sv) && !isGV_with_GP(sv)) {
+ if (IN_PERL_RUNTIME)
+ Perl_croak_no_modify();
+ }
+ else
+ if (SvIsCOW(sv)) {
const char * const pvx = SvPVX_const(sv);
const STRLEN len = SvCUR(sv);
- SvFAKE_off(sv);
- SvREADONLY_off(sv);
+ SvIsCOW_off(sv);
SvPV_set(sv, NULL);
SvLEN_set(sv, 0);
- SvGROW(sv, len + 1);
- Move(pvx,SvPVX(sv),len,char);
- *SvEND(sv) = '\0';
+ if (flags & SV_COW_DROP_PV) {
+ /* OK, so we don't need to copy our buffer. */
+ SvPOK_off(sv);
+ } else {
+ SvGROW(sv, len + 1);
+ Move(pvx,SvPVX(sv),len,char);
+ *SvEND(sv) = '\0';
+ }
unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
}
- else if (IN_PERL_RUNTIME)
- Perl_croak_no_modify(aTHX);
- }
#endif
if (SvROK(sv))
sv_unref_flags(sv, flags);
else if (SvFAKE(sv) && isGV_with_GP(sv))
- sv_unglob(sv);
- else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) {
+ sv_unglob(sv, flags);
+ else if (SvFAKE(sv) && isREGEXP(sv)) {
/* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous
to sv_unglob. We only need it here, so inline it. */
- const svtype new_type = SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
+ const bool islv = SvTYPE(sv) == SVt_PVLV;
+ const svtype new_type =
+ islv ? SVt_NULL : SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
SV *const temp = newSV_type(new_type);
- void *const temp_p = SvANY(sv);
+ regexp *const temp_p = ReANY((REGEXP *)sv);
if (new_type == SVt_PVMG) {
SvMAGIC_set(temp, SvMAGIC(sv));
@@ -4813,32 +4916,41 @@
SvSTASH_set(temp, SvSTASH(sv));
SvSTASH_set(sv, NULL);
}
- SvCUR_set(temp, SvCUR(sv));
- /* Remember that SvPVX is in the head, not the body. */
- if (SvLEN(temp)) {
- SvLEN_set(temp, SvLEN(sv));
- /* This signals "buffer is owned by someone else" in sv_clear,
- which is the least effort way to stop it freeing the buffer.
- */
- SvLEN_set(sv, SvLEN(sv)+1);
- } else {
- /* Their buffer is already owned by someone else. */
- SvPVX(sv) = savepvn(SvPVX(sv), SvCUR(sv));
- SvLEN_set(temp, SvCUR(sv)+1);
+ if (!islv) SvCUR_set(temp, SvCUR(sv));
+ /* Remember that SvPVX is in the head, not the body. But
+ RX_WRAPPED is in the body. */
+ assert(ReANY((REGEXP *)sv)->mother_re);
+ /* Their buffer is already owned by someone else. */
+ if (flags & SV_COW_DROP_PV) {
+ /* SvLEN is already 0. For SVt_REGEXP, we have a brand new
+ zeroed body. For SVt_PVLV, it should have been set to 0
+ before turning into a regexp. */
+ assert(!SvLEN(islv ? sv : temp));
+ sv->sv_u.svu_pv = 0;
}
+ else {
+ sv->sv_u.svu_pv = savepvn(RX_WRAPPED((REGEXP *)sv), SvCUR(sv));
+ SvLEN_set(islv ? sv : temp, SvCUR(sv)+1);
+ SvPOK_on(sv);
+ }
/* Now swap the rest of the bodies. */
- SvFLAGS(sv) &= ~(SVf_FAKE|SVTYPEMASK);
- SvFLAGS(sv) |= new_type;
- SvANY(sv) = SvANY(temp);
+ SvFAKE_off(sv);
+ if (!islv) {
+ SvFLAGS(sv) &= ~SVTYPEMASK;
+ SvFLAGS(sv) |= new_type;
+ SvANY(sv) = SvANY(temp);
+ }
SvFLAGS(temp) &= ~(SVTYPEMASK);
SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
SvANY(temp) = temp_p;
+ temp->sv_u.svu_rx = (regexp *)temp_p;
- SvREFCNT_dec(temp);
+ SvREFCNT_dec_NN(temp);
}
+ else if (SvVOK(sv)) sv_unmagic(sv, PERL_MAGIC_vstring);
}
/*
@@ -4845,23 +4957,30 @@
=for apidoc sv_chop
Efficient removal of characters from the beginning of the string buffer.
-SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
-the string buffer. The C<ptr> becomes the first character of the adjusted
-string. Uses the "OOK hack".
+SvPOK(sv), or at least SvPOKp(sv), must be true and the C<ptr> must be a
+pointer to somewhere inside the string buffer. The C<ptr> becomes the first
+character of the adjusted string. Uses the "OOK hack". On return, only
+SvPOK(sv) and SvPOKp(sv) among the OK flags will be true.
+
Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
refer to the same chunk of data.
+The unfortunate similarity of this function's name to that of Perl's C<chop>
+operator is strictly coincidental. This function works from the left;
+C<chop> works from the right.
+
=cut
*/
void
-Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr)
+Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr)
{
STRLEN delta;
STRLEN old_delta;
U8 *p;
#ifdef DEBUGGING
- const U8 *real_start;
+ const U8 *evacp;
+ STRLEN evacn;
#endif
STRLEN max_delta;
@@ -4874,17 +4993,13 @@
/* Nothing to do. */
return;
}
- /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), but after this line,
- nothing uses the value of ptr any more. */
max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
- if (ptr <= SvPVX_const(sv))
+ if (delta > max_delta)
Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
+ /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), so don't use ptr any more */
SV_CHECK_THINKFIRST(sv);
- if (delta > max_delta)
- Perl_croak(aTHX_ "panic: sv_chop ptr=%p (was %p), start=%p, end=%p",
- SvPVX_const(sv) + delta, ptr, SvPVX_const(sv),
- SvPVX_const(sv) + max_delta);
+ SvPOK_only_UTF8(sv);
if (!SvOOK(sv)) {
if (!SvLEN(sv)) { /* make copy of shared string */
@@ -4894,7 +5009,7 @@
Move(pvx,SvPVX(sv),len,char);
*SvEND(sv) = '\0';
}
- SvFLAGS(sv) |= SVf_OOK;
+ SvOOK_on(sv);
old_delta = 0;
} else {
SvOOK_offset(sv, old_delta);
@@ -4905,12 +5020,18 @@
p = (U8 *)SvPVX_const(sv);
- delta += old_delta;
-
#ifdef DEBUGGING
- real_start = p - delta;
+ /* how many bytes were evacuated? we will fill them with sentinel
+ bytes, except for the part holding the new offset of course. */
+ evacn = delta;
+ if (old_delta)
+ evacn += (old_delta < 0x100 ? 1 : 1 + sizeof(STRLEN));
+ assert(evacn);
+ assert(evacn <= delta + old_delta);
+ evacp = p - evacn;
#endif
+ delta += old_delta;
assert(delta);
if (delta < 0x100) {
*--p = (U8) delta;
@@ -4923,7 +5044,7 @@
#ifdef DEBUGGING
/* Fill the preceding buffer with sentinals to verify that no-one is
using it. */
- while (p > real_start) {
+ while (p > evacp) {
--p;
*p = (U8)PTR2UV(p);
}
@@ -4943,8 +5064,9 @@
Concatenates the string onto the end of the string which is in the SV. The
C<len> indicates number of bytes to copy. If the SV has the UTF-8
status set, then the bytes appended should be valid UTF-8.
-If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
-appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
+If C<flags> has the C<SV_SMAGIC> bit set, will
+C<mg_set> on C<dsv> afterwards if appropriate.
+C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
in terms of this function.
=cut
@@ -4951,7 +5073,7 @@
*/
void
-Perl_sv_catpvn_flags(pTHX_ register SV *const dsv, register const char *sstr, register const STRLEN slen, const I32 flags)
+Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const char *sstr, const STRLEN slen, const I32 flags)
{
dVAR;
STRLEN dlen;
@@ -4958,12 +5080,43 @@
const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
+ assert((flags & (SV_CATBYTES|SV_CATUTF8)) != (SV_CATBYTES|SV_CATUTF8));
- SvGROW(dsv, dlen + slen + 1);
- if (sstr == dstr)
+ if (!(flags & SV_CATBYTES) || !SvUTF8(dsv)) {
+ if (flags & SV_CATUTF8 && !SvUTF8(dsv)) {
+ sv_utf8_upgrade_flags_grow(dsv, 0, slen + 1);
+ dlen = SvCUR(dsv);
+ }
+ else SvGROW(dsv, dlen + slen + 1);
+ if (sstr == dstr)
sstr = SvPVX_const(dsv);
- Move(sstr, SvPVX(dsv) + dlen, slen, char);
- SvCUR_set(dsv, SvCUR(dsv) + slen);
+ Move(sstr, SvPVX(dsv) + dlen, slen, char);
+ SvCUR_set(dsv, SvCUR(dsv) + slen);
+ }
+ else {
+ /* We inline bytes_to_utf8, to avoid an extra malloc. */
+ const char * const send = sstr + slen;
+ U8 *d;
+
+ /* Something this code does not account for, which I think is
+ impossible; it would require the same pv to be treated as
+ bytes *and* utf8, which would indicate a bug elsewhere. */
+ assert(sstr != dstr);
+
+ SvGROW(dsv, dlen + slen * 2 + 1);
+ d = (U8 *)SvPVX(dsv) + dlen;
+
+ while (sstr < send) {
+ const UV uv = NATIVE_TO_ASCII((U8)*sstr++);
+ if (UNI_IS_INVARIANT(uv))
+ *d++ = (U8)UTF_TO_NATIVE(uv);
+ else {
+ *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
+ *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
+ }
+ }
+ SvCUR_set(dsv, d-(const U8 *)SvPVX(dsv));
+ }
*SvEND(dsv) = '\0';
(void)SvPOK_only_UTF8(dsv); /* validate pointer */
SvTAINT(dsv);
@@ -4974,61 +5127,41 @@
/*
=for apidoc sv_catsv
-Concatenates the string from SV C<ssv> onto the end of the string in
-SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
-not 'set' magic. See C<sv_catsv_mg>.
+Concatenates the string from SV C<ssv> onto the end of the string in SV
+C<dsv>. If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
+Handles 'get' magic on both SVs, but no 'set' magic. See C<sv_catsv_mg> and
+C<sv_catsv_nomg>.
=for apidoc sv_catsv_flags
-Concatenates the string from SV C<ssv> onto the end of the string in
-SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
-bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
-and C<sv_catsv_nomg> are implemented in terms of this function.
+Concatenates the string from SV C<ssv> onto the end of the string in SV
+C<dsv>. If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
+If C<flags> include C<SV_GMAGIC> bit set, will call C<mg_get> on both SVs if
+appropriate. If C<flags> include C<SV_SMAGIC>, C<mg_set> will be called on
+the modified SV afterward, if appropriate. C<sv_catsv>, C<sv_catsv_nomg>,
+and C<sv_catsv_mg> are implemented in terms of this function.
=cut */
void
-Perl_sv_catsv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags)
+Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
{
dVAR;
PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
- if (ssv) {
+ if (ssv) {
STRLEN slen;
const char *spv = SvPV_flags_const(ssv, slen, flags);
if (spv) {
- /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
- gcc version 2.95.2 20000220 (Debian GNU/Linux) for
- Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
- get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
- dsv->sv_flags doesn't have that bit set.
- Andy Dougherty 12 Oct 2001
- */
- const I32 sutf8 = DO_UTF8(ssv);
- I32 dutf8;
-
- if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
- mg_get(dsv);
- dutf8 = DO_UTF8(dsv);
-
- if (dutf8 != sutf8) {
- if (dutf8) {
- /* Not modifying source SV, so taking a temporary copy. */
- SV* const csv = newSVpvn_flags(spv, slen, SVs_TEMP);
-
- sv_utf8_upgrade(csv);
- spv = SvPV_const(csv, slen);
- }
- else
- /* Leave enough space for the cat that's about to happen */
- sv_utf8_upgrade_flags_grow(dsv, 0, slen);
- }
- sv_catpvn_nomg(dsv, spv, slen);
- }
+ if (flags & SV_GMAGIC)
+ SvGETMAGIC(dsv);
+ sv_catpvn_flags(dsv, spv, slen,
+ DO_UTF8(ssv) ? SV_CATUTF8 : SV_CATBYTES);
+ if (flags & SV_SMAGIC)
+ SvSETMAGIC(dsv);
+ }
}
- if (flags & SV_SMAGIC)
- SvSETMAGIC(dsv);
}
/*
@@ -5041,10 +5174,10 @@
=cut */
void
-Perl_sv_catpv(pTHX_ register SV *const sv, register const char *ptr)
+Perl_sv_catpv(pTHX_ SV *const sv, const char *ptr)
{
dVAR;
- register STRLEN len;
+ STRLEN len;
STRLEN tlen;
char *junk;
@@ -5068,8 +5201,8 @@
Concatenates the string onto the end of the string which is in the SV.
If the SV has the UTF-8 status set, then the bytes appended should
-be valid UTF-8. If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get>
-on the SVs if appropriate, else not.
+be valid UTF-8. If C<flags> has the C<SV_SMAGIC> bit set, will C<mg_set>
+on the modified SV if appropriate.
=cut
*/
@@ -5090,7 +5223,7 @@
*/
void
-Perl_sv_catpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
+Perl_sv_catpv_mg(pTHX_ SV *const sv, const char *const ptr)
{
PERL_ARGS_ASSERT_SV_CATPV_MG;
@@ -5109,7 +5242,7 @@
In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
parameter, I<x>, a debug aid which allowed callers to identify themselves.
This aid has been superseded by a new build option, PERL_MEM_LOG (see
-L<perlhack/PERL_MEM_LOG>). The older API is still there for use in XS
+L<perlhacktips/PERL_MEM_LOG>). The older API is still there for use in XS
modules supporting older perls.
=cut
@@ -5119,7 +5252,7 @@
Perl_newSV(pTHX_ const STRLEN len)
{
dVAR;
- register SV *sv;
+ SV *sv;
new_SV(sv);
if (len) {
@@ -5131,7 +5264,7 @@
/*
=for apidoc sv_magicext
-Adds magic to an SV, upgrading it if necessary. Applies the
+Adds magic to an SV, upgrading it if necessary. Applies the
supplied vtable and returns a pointer to the magic added.
Note that C<sv_magicext> will allow things that C<sv_magic> will not.
@@ -5216,8 +5349,6 @@
mg->mg_virtual = (MGVTBL *) vtable;
mg_magical(sv);
- if (SvGMAGICAL(sv))
- SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
return mg;
}
@@ -5224,8 +5355,9 @@
/*
=for apidoc sv_magic
-Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
-then adds a new magic item of type C<how> to the head of the magic list.
+Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if
+necessary, then adds a new magic item of type C<how> to the head of the
+magic list.
See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
handling of the C<name> and C<namlen> arguments.
@@ -5237,34 +5369,45 @@
*/
void
-Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
+Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how,
const char *const name, const I32 namlen)
{
dVAR;
const MGVTBL *vtable;
MAGIC* mg;
+ unsigned int flags;
+ unsigned int vtable_index;
PERL_ARGS_ASSERT_SV_MAGIC;
-#ifdef PERL_OLD_COPY_ON_WRITE
+ if (how < 0 || (unsigned)how > C_ARRAY_LENGTH(PL_magic_data)
+ || ((flags = PL_magic_data[how]),
+ (vtable_index = flags & PERL_MAGIC_VTABLE_MASK)
+ > magic_vtable_max))
+ Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
+
+ /* PERL_MAGIC_ext is reserved for use by extensions not perl internals.
+ Useful for attaching extension internal data to perl vars.
+ Note that multiple extensions may clash if magical scalars
+ etc holding private data from one are passed to another. */
+
+ vtable = (vtable_index == magic_vtable_max)
+ ? NULL : PL_magic_vtables + vtable_index;
+
+#ifdef PERL_ANY_COW
if (SvIsCOW(sv))
sv_force_normal_flags(sv, 0);
#endif
if (SvREADONLY(sv)) {
if (
- /* its okay to attach magic to shared strings; the subsequent
- * upgrade to PVMG will unshare the string */
- !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
+ /* its okay to attach magic to shared strings */
+ !SvIsCOW(sv)
&& IN_PERL_RUNTIME
- && how != PERL_MAGIC_regex_global
- && how != PERL_MAGIC_bm
- && how != PERL_MAGIC_fm
- && how != PERL_MAGIC_sv
- && how != PERL_MAGIC_backref
+ && !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how)
)
{
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
}
}
if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
@@ -5272,138 +5415,12 @@
/* sv_magic() refuses to add a magic of the same 'how' as an
existing one
*/
- if (how == PERL_MAGIC_taint) {
+ if (how == PERL_MAGIC_taint)
mg->mg_len |= 1;
- /* Any scalar which already had taint magic on which someone
- (erroneously?) did SvIOK_on() or similar will now be
- incorrectly sporting public "OK" flags. */
- SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
- }
return;
}
}
- switch (how) {
- case PERL_MAGIC_sv:
- vtable = &PL_vtbl_sv;
- break;
- case PERL_MAGIC_overload:
- vtable = &PL_vtbl_amagic;
- break;
- case PERL_MAGIC_overload_elem:
- vtable = &PL_vtbl_amagicelem;
- break;
- case PERL_MAGIC_overload_table:
- vtable = &PL_vtbl_ovrld;
- break;
- case PERL_MAGIC_bm:
- vtable = &PL_vtbl_bm;
- break;
- case PERL_MAGIC_regdata:
- vtable = &PL_vtbl_regdata;
- break;
- case PERL_MAGIC_regdatum:
- vtable = &PL_vtbl_regdatum;
- break;
- case PERL_MAGIC_env:
- vtable = &PL_vtbl_env;
- break;
- case PERL_MAGIC_fm:
- vtable = &PL_vtbl_fm;
- break;
- case PERL_MAGIC_envelem:
- vtable = &PL_vtbl_envelem;
- break;
- case PERL_MAGIC_regex_global:
- vtable = &PL_vtbl_mglob;
- break;
- case PERL_MAGIC_isa:
- vtable = &PL_vtbl_isa;
- break;
- case PERL_MAGIC_isaelem:
- vtable = &PL_vtbl_isaelem;
- break;
- case PERL_MAGIC_nkeys:
- vtable = &PL_vtbl_nkeys;
- break;
- case PERL_MAGIC_dbfile:
- vtable = NULL;
- break;
- case PERL_MAGIC_dbline:
- vtable = &PL_vtbl_dbline;
- break;
-#ifdef USE_LOCALE_COLLATE
- case PERL_MAGIC_collxfrm:
- vtable = &PL_vtbl_collxfrm;
- break;
-#endif /* USE_LOCALE_COLLATE */
- case PERL_MAGIC_tied:
- vtable = &PL_vtbl_pack;
- break;
- case PERL_MAGIC_tiedelem:
- case PERL_MAGIC_tiedscalar:
- vtable = &PL_vtbl_packelem;
- break;
- case PERL_MAGIC_qr:
- vtable = &PL_vtbl_regexp;
- break;
- case PERL_MAGIC_sig:
- vtable = &PL_vtbl_sig;
- break;
- case PERL_MAGIC_sigelem:
- vtable = &PL_vtbl_sigelem;
- break;
- case PERL_MAGIC_taint:
- vtable = &PL_vtbl_taint;
- break;
- case PERL_MAGIC_uvar:
- vtable = &PL_vtbl_uvar;
- break;
- case PERL_MAGIC_vec:
- vtable = &PL_vtbl_vec;
- break;
- case PERL_MAGIC_arylen_p:
- case PERL_MAGIC_rhash:
- case PERL_MAGIC_symtab:
- case PERL_MAGIC_vstring:
- case PERL_MAGIC_checkcall:
- vtable = NULL;
- break;
- case PERL_MAGIC_utf8:
- vtable = &PL_vtbl_utf8;
- break;
- case PERL_MAGIC_substr:
- vtable = &PL_vtbl_substr;
- break;
- case PERL_MAGIC_defelem:
- vtable = &PL_vtbl_defelem;
- break;
- case PERL_MAGIC_arylen:
- vtable = &PL_vtbl_arylen;
- break;
- case PERL_MAGIC_pos:
- vtable = &PL_vtbl_pos;
- break;
- case PERL_MAGIC_backref:
- vtable = &PL_vtbl_backref;
- break;
- case PERL_MAGIC_hintselem:
- vtable = &PL_vtbl_hintselem;
- break;
- case PERL_MAGIC_hints:
- vtable = &PL_vtbl_hints;
- break;
- case PERL_MAGIC_ext:
- /* Reserved for use by extensions not perl internals. */
- /* Useful for attaching extension internal data to perl vars. */
- /* Note that multiple extensions may clash if magical scalars */
- /* etc holding private data from one are passed to another. */
- vtable = NULL;
- break;
- default:
- Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
- }
-
/* Rest of work is done else where */
mg = sv_magicext(sv,obj,how,vtable,name,namlen);
@@ -5418,7 +5435,7 @@
}
}
-int
+static int
S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, MGVTBL *vtbl, const U32 flags)
{
MAGIC* mg;
@@ -5497,7 +5514,7 @@
Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
push a back-reference to this RV onto the array of backreferences
-associated with that magic. If the RV is magical, set magic will be
+associated with that magic. If the RV is magical, set magic will be
called after the RV is cleared.
=cut
@@ -5518,10 +5535,11 @@
Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
return sv;
}
+ else if (SvREADONLY(sv)) croak_no_modify();
tsv = SvRV(sv);
Perl_sv_add_backref(aTHX_ tsv, sv);
SvWEAKREF_on(sv);
- SvREFCNT_dec(tsv);
+ SvREFCNT_dec_NN(tsv);
return sv;
}
@@ -5532,16 +5550,13 @@
* store it directly in the HvAUX or mg_obj slot, avoiding the need to
* allocate an AV. (Whether the slot holds an AV tells us whether this is
* active.)
- *
- * If an HV's backref is stored in magic, it is moved back to HvAUX.
*/
/* A discussion about the backreferences array and its refcount:
*
* The AV holding the backreferences is pointed to either as the mg_obj of
- * PERL_MAGIC_backref, or in the specific case of a HV that has the hv_aux
- * structure, from the xhv_backreferences field. (A HV without hv_aux will
- * have the standard magic instead.) The array is created with a refcount
+ * PERL_MAGIC_backref, or in the specific case of a HV, from the
+ * xhv_backreferences field. The array is created with a refcount
* of 2. This means that if during global destruction the array gets
* picked on before its parent to have its refcount decremented by the
* random zapper, it won't actually be freed, meaning it's still there for
@@ -5569,21 +5584,6 @@
if (SvTYPE(tsv) == SVt_PVHV) {
svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
-
- if (!*svp) {
- if ((mg = mg_find(tsv, PERL_MAGIC_backref))) {
- /* Aha. They've got it stowed in magic instead.
- * Move it back to xhv_backreferences */
- *svp = mg->mg_obj;
- /* Stop mg_free decreasing the reference count. */
- mg->mg_obj = NULL;
- /* Stop mg_free even calling the destructor, given that
- there's no AV to free up. */
- mg->mg_virtual = 0;
- sv_unmagic(tsv, PERL_MAGIC_backref);
- mg = NULL;
- }
- }
} else {
if (! ((mg =
(SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL))))
@@ -5641,17 +5641,52 @@
PERL_ARGS_ASSERT_SV_DEL_BACKREF;
- if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
- svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
+ if (SvTYPE(tsv) == SVt_PVHV) {
+ if (SvOOK(tsv))
+ svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
}
- if (!svp || !*svp) {
+ else if (SvIS_FREED(tsv) && PL_phase == PERL_PHASE_DESTRUCT) {
+ /* It's possible for the the last (strong) reference to tsv to have
+ become freed *before* the last thing holding a weak reference.
+ If both survive longer than the backreferences array, then when
+ the referent's reference count drops to 0 and it is freed, it's
+ not able to chase the backreferences, so they aren't NULLed.
+
+ For example, a CV holds a weak reference to its stash. If both the
+ CV and the stash survive longer than the backreferences array,
+ and the CV gets picked for the SvBREAK() treatment first,
+ *and* it turns out that the stash is only being kept alive because
+ of an our variable in the pad of the CV, then midway during CV
+ destruction the stash gets freed, but CvSTASH() isn't set to NULL.
+ It ends up pointing to the freed HV. Hence it's chased in here, and
+ if this block wasn't here, it would hit the !svp panic just below.
+
+ I don't believe that "better" destruction ordering is going to help
+ here - during global destruction there's always going to be the
+ chance that something goes out of order. We've tried to make it
+ foolproof before, and it only resulted in evolutionary pressure on
+ fools. Which made us look foolish for our hubris. :-(
+ */
+ return;
+ }
+ else {
MAGIC *const mg
= SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
svp = mg ? &(mg->mg_obj) : NULL;
}
- if (!svp || !*svp)
- Perl_croak(aTHX_ "panic: del_backref");
+ if (!svp)
+ Perl_croak(aTHX_ "panic: del_backref, svp=0");
+ if (!*svp) {
+ /* It's possible that sv is being freed recursively part way through the
+ freeing of tsv. If this happens, the backreferences array of tsv has
+ already been freed, and so svp will be NULL. If this is the case,
+ we should not panic. Instead, nothing needs doing, so return. */
+ if (PL_phase == PERL_PHASE_DESTRUCT && SvREFCNT(tsv) == 0)
+ return;
+ Perl_croak(aTHX_ "panic: del_backref, *svp=%p phase=%s refcnt=%" UVuf,
+ *svp, PL_phase_names[PL_phase], (UV)SvREFCNT(tsv));
+ }
if (SvTYPE(*svp) == SVt_PVAV) {
#ifdef DEBUGGING
@@ -5703,10 +5738,13 @@
assert(count ==1);
AvFILLp(av) = fill-1;
}
+ else if (SvIS_FREED(*svp) && PL_phase == PERL_PHASE_DESTRUCT) {
+ /* freed AV; skip */
+ }
else {
/* optimisation: only a single backref, stored directly */
if (*svp != sv)
- Perl_croak(aTHX_ "panic: del_backref");
+ Perl_croak(aTHX_ "panic: del_backref, *svp=%p, sv=%p", *svp, sv);
*svp = NULL;
}
@@ -5724,7 +5762,7 @@
if (!av)
return;
- /* after multiple passes through Perl_sv_clean_all() for a thinngy
+ /* after multiple passes through Perl_sv_clean_all() for a thingy
* that has badly leaked, the backref array may have gotten freed,
* since we only protect it against 1 round of cleanup */
if (SvIS_FREED(av)) {
@@ -5797,7 +5835,7 @@
}
if (is_array) {
AvFILLp(av) = -1;
- SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
+ SvREFCNT_dec_NN(av); /* remove extra count added by sv_add_backref() */
}
return;
}
@@ -5805,12 +5843,13 @@
/*
=for apidoc sv_insert
-Inserts a string at the specified offset/length within the SV. Similar to
-the Perl substr() function. Handles get magic.
+Inserts a string at the specified offset/length within the SV. Similar to
+the Perl substr() function. Handles get magic.
=for apidoc sv_insert_flags
-Same as C<sv_insert>, but the extra C<flags> are passed the C<SvPV_force_flags> that applies to C<bigstr>.
+Same as C<sv_insert>, but the extra C<flags> are passed to the
+C<SvPV_force_flags> that applies to C<bigstr>.
=cut
*/
@@ -5819,17 +5858,17 @@
Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
{
dVAR;
- register char *big;
- register char *mid;
- register char *midend;
- register char *bigend;
- register I32 i;
+ char *big;
+ char *mid;
+ char *midend;
+ char *bigend;
+ SSize_t i; /* better be sizeof(STRLEN) or bad things happen */
STRLEN curlen;
PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
if (!bigstr)
- Perl_croak(aTHX_ "Can't modify non-existent substring");
+ Perl_croak(aTHX_ "Can't modify nonexistent substring");
SvPV_force_flags(bigstr, curlen, flags);
(void)SvPOK_only_UTF8(bigstr);
if (offset + len > curlen) {
@@ -5865,7 +5904,8 @@
bigend = big + SvCUR(bigstr);
if (midend > bigend)
- Perl_croak(aTHX_ "panic: sv_insert");
+ Perl_croak(aTHX_ "panic: sv_insert, midend=%p, bigend=%p",
+ midend, bigend);
if (mid - big > bigend - midend) { /* faster to shorten from end */
if (littlelen) {
@@ -5913,7 +5953,7 @@
*/
void
-Perl_sv_replace(pTHX_ register SV *const sv, register SV *const nsv)
+Perl_sv_replace(pTHX_ SV *const sv, SV *const nsv)
{
dVAR;
const U32 refcnt = SvREFCNT(sv);
@@ -5987,7 +6027,6 @@
STATIC void
S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
{
- char *stash;
SV *gvname;
GV *anongv;
@@ -5999,24 +6038,25 @@
assert(GvGP(gv));
assert(!CvANON(cv));
assert(CvGV(cv) == gv);
+ assert(!CvNAMED(cv));
/* will the CV shortly be freed by gp_free() ? */
if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) {
- SvANY(cv)->xcv_gv = NULL;
+ SvANY(cv)->xcv_gv_u.xcv_gv = NULL;
return;
}
/* if not, anonymise: */
- stash = GvSTASH(gv) && HvNAME(GvSTASH(gv))
- ? HvENAME(GvSTASH(gv)) : NULL;
- gvname = Perl_newSVpvf(aTHX_ "%s::__ANON__",
- stash ? stash : "__ANON__");
+ gvname = (GvSTASH(gv) && HvNAME(GvSTASH(gv)) && HvENAME(GvSTASH(gv)))
+ ? newSVhek(HvENAME_HEK(GvSTASH(gv)))
+ : newSVpvn_flags( "__ANON__", 8, 0 );
+ sv_catpvs(gvname, "::__ANON__");
anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
- SvREFCNT_dec(gvname);
+ SvREFCNT_dec_NN(gvname);
CvANON_on(cv);
CvCVGV_RC_on(cv);
- SvANY(cv)->xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
+ SvANY(cv)->xcv_gv_u.xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
}
@@ -6024,10 +6064,10 @@
=for apidoc sv_clear
Clear an SV: call any destructors, free up any memory used by the body,
-and free the body itself. The SV's head is I<not> freed, although
+and free the body itself. The SV's head is I<not> freed, although
its type is set to all 1's so that it won't inadvertently be assumed
to be live during global destruction etc.
-This function should only be called when REFCNT is zero. Most of the time
+This function should only be called when REFCNT is zero. Most of the time
you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
instead.
@@ -6043,7 +6083,8 @@
const struct body_details *sv_type_details;
SV* iter_sv = NULL;
SV* next_sv = NULL;
- register SV *sv = orig_sv;
+ SV *sv = orig_sv;
+ STRLEN hash_index;
PERL_ARGS_ASSERT_SV_CLEAR;
@@ -6056,7 +6097,7 @@
type = SvTYPE(sv);
assert(SvREFCNT(sv) == 0);
- assert(SvTYPE(sv) != SVTYPEMASK);
+ assert(SvTYPE(sv) != (svtype)SVTYPEMASK);
if (type <= SVt_IV) {
/* See the comment in sv.h about the collusion between this
@@ -6069,15 +6110,21 @@
goto free_head;
}
- if (SvOBJECT(sv)) {
- if (!curse(sv, 1)) goto get_next_sv;
- }
+ assert(!SvOBJECT(sv) || type >= SVt_PVMG); /* objs are always >= MG */
+
if (type >= SVt_PVMG) {
+ if (SvOBJECT(sv)) {
+ if (!curse(sv, 1)) goto get_next_sv;
+ type = SvTYPE(sv); /* destructor may have changed it */
+ }
/* Free back-references before magic, in case the magic calls
* Perl code that has weak references to sv. */
- if (type == SVt_PVHV)
+ if (type == SVt_PVHV) {
Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
- if (type == SVt_PVMG && SvPAD_OUR(sv)) {
+ if (SvMAGIC(sv))
+ mg_free(sv);
+ }
+ else if (type == SVt_PVMG && SvPAD_OUR(sv)) {
SvREFCNT_dec(SvOURSTASH(sv));
} else if (SvMAGIC(sv)) {
/* Free back-references before other types of magic. */
@@ -6084,6 +6131,7 @@
sv_unmagic(sv, PERL_MAGIC_backref);
mg_free(sv);
}
+ SvMAGICAL_off(sv);
if (type == SVt_PVMG && SvPAD_TYPED(sv))
SvREFCNT_dec(SvSTASH(sv));
}
@@ -6104,9 +6152,12 @@
Safefree(IoTOP_NAME(sv));
Safefree(IoFMT_NAME(sv));
Safefree(IoBOTTOM_NAME(sv));
+ if ((const GV *)sv == PL_statgv)
+ PL_statgv = NULL;
goto freescalar;
case SVt_REGEXP:
/* FIXME for plugins */
+ freeregexp:
pregfree2((REGEXP*) sv);
goto freescalar;
case SVt_PVCV:
@@ -6122,7 +6173,39 @@
if (PL_last_swash_hv == (const HV *)sv) {
PL_last_swash_hv = NULL;
}
+ if (HvTOTALKEYS((HV*)sv) > 0) {
+ const char *name;
+ /* this statement should match the one at the beginning of
+ * hv_undef_flags() */
+ if ( PL_phase != PERL_PHASE_DESTRUCT
+ && (name = HvNAME((HV*)sv)))
+ {
+ if (PL_stashcache) {
+ DEBUG_o(Perl_deb(aTHX_ "sv_clear clearing PL_stashcache for '%"SVf"'\n",
+ sv));
+ (void)hv_delete(PL_stashcache, name,
+ HvNAMEUTF8((HV*)sv) ? -HvNAMELEN_get((HV*)sv) : HvNAMELEN_get((HV*)sv), G_DISCARD);
+ }
+ hv_name_set((HV*)sv, NULL, 0, 0);
+ }
+
+ /* save old iter_sv in unused SvSTASH field */
+ assert(!SvOBJECT(sv));
+ SvSTASH(sv) = (HV*)iter_sv;
+ iter_sv = sv;
+
+ /* save old hash_index in unused SvMAGIC field */
+ assert(!SvMAGICAL(sv));
+ assert(!SvMAGIC(sv));
+ ((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index = hash_index;
+ hash_index = 0;
+
+ next_sv = Perl_hfree_next_entry(aTHX_ (HV*)sv, &hash_index);
+ goto get_next_sv; /* process this new sv */
+ }
+ /* free empty hash */
Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
+ assert(!HvARRAY((HV*)sv));
break;
case SVt_PVAV:
{
@@ -6151,6 +6234,7 @@
}
else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
SvREFCNT_dec(LvTARG(sv));
+ if (isREGEXP(sv)) goto freeregexp;
case SVt_PVGV:
if (isGV_with_GP(sv)) {
if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
@@ -6168,8 +6252,13 @@
/* FIXME. There are probably more unreferenced pointers to SVs
* in the interpreter struct that we should check and tidy in
* a similar fashion to this: */
+ /* See also S_sv_unglob, which does the same thing. */
if ((const GV *)sv == PL_last_in_gv)
PL_last_in_gv = NULL;
+ else if ((const GV *)sv == PL_statgv)
+ PL_statgv = NULL;
+ else if ((const GV *)sv == PL_stderrgv)
+ PL_stderrgv = NULL;
case SVt_PVMG:
case SVt_PVNV:
case SVt_PVIV:
@@ -6193,7 +6282,7 @@
next_sv = target;
}
}
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
else if (SvPVX_const(sv)
&& !(SvTYPE(sv) == SVt_PVIO
&& !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
@@ -6204,15 +6293,25 @@
sv_dump(sv);
}
if (SvLEN(sv)) {
+# ifdef PERL_OLD_COPY_ON_WRITE
sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
+# else
+ if (CowREFCNT(sv)) {
+ CowREFCNT(sv)--;
+ SvLEN_set(sv, 0);
+ }
+# endif
} else {
unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
}
- SvFAKE_off(sv);
- } else if (SvLEN(sv)) {
- Safefree(SvPVX_const(sv));
}
+# ifdef PERL_OLD_COPY_ON_WRITE
+ else
+# endif
+ if (SvLEN(sv)) {
+ Safefree(SvPVX_mutable(sv));
+ }
}
#else
else if (SvPVX_const(sv) && SvLEN(sv)
@@ -6219,9 +6318,8 @@
&& !(SvTYPE(sv) == SVt_PVIO
&& !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
Safefree(SvPVX_mutable(sv));
- else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
+ else if (SvPVX_const(sv) && SvIsCOW(sv)) {
unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
- SvFAKE_off(sv);
}
#endif
break;
@@ -6271,6 +6369,28 @@
Safefree(AvALLOC(av));
goto free_body;
}
+ } else if (SvTYPE(iter_sv) == SVt_PVHV) {
+ sv = Perl_hfree_next_entry(aTHX_ (HV*)iter_sv, &hash_index);
+ if (!sv && !HvTOTALKEYS((HV *)iter_sv)) {
+ /* no more elements of current HV to free */
+ sv = iter_sv;
+ type = SvTYPE(sv);
+ /* Restore previous values of iter_sv and hash_index,
+ * squirrelled away */
+ assert(!SvOBJECT(sv));
+ iter_sv = (SV*)SvSTASH(sv);
+ assert(!SvMAGICAL(sv));
+ hash_index = ((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index;
+#ifdef DEBUGGING
+ /* perl -DA does not like rubbish in SvMAGIC. */
+ SvMAGIC_set(sv, 0);
+#endif
+
+ /* free any remaining detritus from the hash struct */
+ Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
+ assert(!HvARRAY((HV*)sv));
+ goto free_body;
+ }
}
/* unrolled SvREFCNT_dec and sv_free2 follows: */
@@ -6291,9 +6411,9 @@
continue;
}
#endif
- if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
+ if (SvIMMORTAL(sv)) {
/* make sure SvREFCNT(sv)==0 happens very seldom */
- SvREFCNT(sv) = (~(U32)0)/2;
+ SvREFCNT(sv) = SvREFCNT_IMMORTAL;
continue;
}
break;
@@ -6318,18 +6438,38 @@
dSP;
HV* stash;
do {
- CV* destructor;
- stash = SvSTASH(sv);
- destructor = StashHANDLER(stash,DESTROY);
- if (destructor
+ stash = SvSTASH(sv);
+ assert(SvTYPE(stash) == SVt_PVHV);
+ if (HvNAME(stash)) {
+ CV* destructor = NULL;
+ if (!SvOBJECT(stash)) destructor = (CV *)SvSTASH(stash);
+ if (!destructor) {
+ GV * const gv =
+ gv_fetchmeth_autoload(stash, "DESTROY", 7, 0);
+ if (gv) destructor = GvCV(gv);
+ if (!SvOBJECT(stash))
+ SvSTASH(stash) =
+ destructor ? (HV *)destructor : ((HV *)0)+1;
+ }
+ assert(!destructor || destructor == ((CV *)0)+1
+ || SvTYPE(destructor) == SVt_PVCV);
+ if (destructor && destructor != ((CV *)0)+1
/* A constant subroutine can have no side effects, so
don't bother calling it. */
&& !CvCONST(destructor)
- /* Don't bother calling an empty destructor */
+ /* Don't bother calling an empty destructor or one that
+ returns immediately. */
&& (CvISXSUB(destructor)
|| (CvSTART(destructor)
&& (CvSTART(destructor)->op_next->op_type
- != OP_LEAVESUB))))
+ != OP_LEAVESUB)
+ && (CvSTART(destructor)->op_next->op_type
+ != OP_PUSHMARK
+ || CvSTART(destructor)->op_next->op_next->op_type
+ != OP_RETURN
+ )
+ ))
+ )
{
SV* const tmpref = newRV(sv);
SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
@@ -6350,8 +6490,9 @@
SvRV_set(tmpref, NULL);
SvROK_off(tmpref);
}
- SvREFCNT_dec(tmpref);
+ SvREFCNT_dec_NN(tmpref);
}
+ }
} while (SvOBJECT(sv) && SvSTASH(sv) != stash);
@@ -6358,8 +6499,8 @@
if (check_refcnt && SvREFCNT(sv)) {
if (PL_in_clean_objs)
Perl_croak(aTHX_
- "DESTROY created new reference to dead object '%s'",
- HvNAME_get(stash));
+ "DESTROY created new reference to dead object '%"HEKf"'",
+ HEKfARG(HvNAME_HEK(stash)));
/* DESTROY gave object new lease on life */
return FALSE;
}
@@ -6366,10 +6507,12 @@
}
if (SvOBJECT(sv)) {
- SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
+ HV * const stash = SvSTASH(sv);
+ /* Curse before freeing the stash, as freeing the stash could cause
+ a recursive call into S_curse. */
SvOBJECT_off(sv); /* Curse the object. */
- if (SvTYPE(sv) != SVt_PVIO)
- --PL_sv_objcount;/* XXX Might want something more general */
+ SvSTASH_set(sv,0); /* SvREFCNT_dec may try to read this */
+ SvREFCNT_dec(stash); /* possibly of changed persuasion */
}
return TRUE;
}
@@ -6377,7 +6520,7 @@
/*
=for apidoc sv_newref
-Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
+Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
instead.
=cut
@@ -6406,87 +6549,97 @@
void
Perl_sv_free(pTHX_ SV *const sv)
{
- dVAR;
- if (!sv)
- return;
- if (SvREFCNT(sv) == 0) {
- if (SvFLAGS(sv) & SVf_BREAK)
- /* this SV's refcnt has been artificially decremented to
- * trigger cleanup */
- return;
- if (PL_in_clean_all) /* All is fair */
- return;
- if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
- /* make sure SvREFCNT(sv)==0 happens very seldom */
- SvREFCNT(sv) = (~(U32)0)/2;
- return;
- }
- if (ckWARN_d(WARN_INTERNAL)) {
-#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
- Perl_dump_sv_child(aTHX_ sv);
-#else
- #ifdef DEBUG_LEAKING_SCALARS
- sv_dump(sv);
- #endif
-#ifdef DEBUG_LEAKING_SCALARS_ABORT
- if (PL_warnhook == PERL_WARNHOOK_FATAL
- || ckDEAD(packWARN(WARN_INTERNAL))) {
- /* Don't let Perl_warner cause us to escape our fate: */
- abort();
- }
-#endif
- /* This may not return: */
- Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
- "Attempt to free unreferenced scalar: SV 0x%"UVxf
- pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
-#endif
- }
-#ifdef DEBUG_LEAKING_SCALARS_ABORT
- abort();
-#endif
- return;
- }
- if (--(SvREFCNT(sv)) > 0)
- return;
- Perl_sv_free2(aTHX_ sv);
+ SvREFCNT_dec(sv);
}
+
+/* Private helper function for SvREFCNT_dec().
+ * Called with rc set to original SvREFCNT(sv), where rc == 0 or 1 */
+
void
-Perl_sv_free2(pTHX_ SV *const sv)
+Perl_sv_free2(pTHX_ SV *const sv, const U32 rc)
{
dVAR;
PERL_ARGS_ASSERT_SV_FREE2;
+ if (rc == 1) {
+ /* normal case */
+ SvREFCNT(sv) = 0;
+
#ifdef DEBUGGING
- if (SvTEMP(sv)) {
- Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
- "Attempt to free temp prematurely: SV 0x%"UVxf
- pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
- return;
+ if (SvTEMP(sv)) {
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
+ "Attempt to free temp prematurely: SV 0x%"UVxf
+ pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
+ return;
+ }
+#endif
+ if (SvIMMORTAL(sv)) {
+ /* make sure SvREFCNT(sv)==0 happens very seldom */
+ SvREFCNT(sv) = SvREFCNT_IMMORTAL;
+ return;
+ }
+ sv_clear(sv);
+ if (! SvREFCNT(sv)) /* may have have been resurrected */
+ del_SV(sv);
+ return;
}
+
+ /* handle exceptional cases */
+
+ assert(rc == 0);
+
+ if (SvFLAGS(sv) & SVf_BREAK)
+ /* this SV's refcnt has been artificially decremented to
+ * trigger cleanup */
+ return;
+ if (PL_in_clean_all) /* All is fair */
+ return;
+ if (SvIMMORTAL(sv)) {
+ /* make sure SvREFCNT(sv)==0 happens very seldom */
+ SvREFCNT(sv) = SvREFCNT_IMMORTAL;
+ return;
+ }
+ if (ckWARN_d(WARN_INTERNAL)) {
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+ Perl_dump_sv_child(aTHX_ sv);
+#else
+ #ifdef DEBUG_LEAKING_SCALARS
+ sv_dump(sv);
+ #endif
+#ifdef DEBUG_LEAKING_SCALARS_ABORT
+ if (PL_warnhook == PERL_WARNHOOK_FATAL
+ || ckDEAD(packWARN(WARN_INTERNAL))) {
+ /* Don't let Perl_warner cause us to escape our fate: */
+ abort();
+ }
#endif
- if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
- /* make sure SvREFCNT(sv)==0 happens very seldom */
- SvREFCNT(sv) = (~(U32)0)/2;
- return;
+ /* This may not return: */
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
+ "Attempt to free unreferenced scalar: SV 0x%"UVxf
+ pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
+#endif
}
- sv_clear(sv);
- if (! SvREFCNT(sv))
- del_SV(sv);
+#ifdef DEBUG_LEAKING_SCALARS_ABORT
+ abort();
+#endif
+
}
+
/*
=for apidoc sv_len
-Returns the length of the string in the SV. Handles magic and type
-coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
+Returns the length of the string in the SV. Handles magic and type
+coercion and sets the UTF8 flag appropriately. See also C<SvCUR>, which
+gives raw access to the xpv_cur slot.
=cut
*/
STRLEN
-Perl_sv_len(pTHX_ register SV *const sv)
+Perl_sv_len(pTHX_ SV *const sv)
{
STRLEN len;
@@ -6493,10 +6646,7 @@
if (!sv)
return 0;
- if (SvGMAGICAL(sv))
- len = mg_length(sv);
- else
- (void)SvPV_const(sv, len);
+ (void)SvPV_const(sv, len);
return len;
}
@@ -6504,7 +6654,7 @@
=for apidoc sv_len_utf8
Returns the number of characters in the string in an SV, counting wide
-UTF-8 bytes as a single character. Handles magic and type coercion.
+UTF-8 bytes as a single character. Handles magic and type coercion.
=cut
*/
@@ -6519,19 +6669,25 @@
*/
STRLEN
-Perl_sv_len_utf8(pTHX_ register SV *const sv)
+Perl_sv_len_utf8(pTHX_ SV *const sv)
{
if (!sv)
return 0;
- if (SvGMAGICAL(sv))
- return mg_length(sv);
- else
- {
- STRLEN len;
- const U8 *s = (U8*)SvPV_const(sv, len);
+ SvGETMAGIC(sv);
+ return sv_len_utf8_nomg(sv);
+}
- if (PL_utf8cache) {
+STRLEN
+Perl_sv_len_utf8_nomg(pTHX_ SV * const sv)
+{
+ dVAR;
+ STRLEN len;
+ const U8 *s = (U8*)SvPV_nomg_const(sv, len);
+
+ PERL_ARGS_ASSERT_SV_LEN_UTF8_NOMG;
+
+ if (PL_utf8cache && SvUTF8(sv)) {
STRLEN ulen;
MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
@@ -6557,9 +6713,8 @@
utf8_mg_len_cache_update(sv, &mg, ulen);
}
return ulen;
- }
- return Perl_utf8_length(aTHX_ s, s + len);
}
+ return SvUTF8(sv) ? Perl_utf8_length(aTHX_ s, s + len) : len;
}
/* Walk forwards to find the byte corresponding to the passed in UTF-8
@@ -6647,7 +6802,7 @@
if (!uoffset)
return 0;
- if (!SvREADONLY(sv)
+ if (!SvREADONLY(sv) && !SvGMAGICAL(sv) && SvPOK(sv)
&& PL_utf8cache
&& (*mgp || (SvTYPE(sv) >= SVt_PVMG &&
(*mgp = mg_find(sv, PERL_MAGIC_utf8))))) {
@@ -6730,7 +6885,7 @@
boffset = real_boffset;
}
- if (PL_utf8cache) {
+ if (PL_utf8cache && !SvGMAGICAL(sv) && SvPOK(sv)) {
if (at_end)
utf8_mg_len_cache_update(sv, mgp, uoffset);
else
@@ -6746,7 +6901,8 @@
Converts the value pointed to by offsetp from a count of UTF-8 chars from
the start of the string, to a count of the equivalent number of bytes; if
lenp is non-zero, it does the same to lenp, but this time starting from
-the offset, rather than from the start of the string. Handles type coercion.
+the offset, rather than from the start
+of the string. Handles type coercion.
I<flags> is passed to C<SvPV_flags>, and usually should be
C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
@@ -6802,7 +6958,7 @@
Converts the value pointed to by offsetp from a count of UTF-8 chars from
the start of the string, to a count of the equivalent number of bytes; if
lenp is non-zero, it does the same to lenp, but this time starting from
-the offset, rather than from the start of the string. Handles magic and
+the offset, rather than from the start of the string. Handles magic and
type coercion.
Use C<sv_pos_u2b_flags> in preference, which correctly handles strings longer
@@ -6821,7 +6977,7 @@
/* This function is subject to size and sign problems */
void
-Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp)
+Perl_sv_pos_u2b(pTHX_ SV *const sv, I32 *const offsetp, I32 *const lenp)
{
PERL_ARGS_ASSERT_SV_POS_U2B;
@@ -6841,7 +6997,7 @@
const STRLEN ulen)
{
PERL_ARGS_ASSERT_UTF8_MG_LEN_CACHE_UPDATE;
- if (SvREADONLY(sv))
+ if (SvREADONLY(sv) || SvGMAGICAL(sv) || !SvPOK(sv))
return;
if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
@@ -6948,7 +7104,6 @@
calculation in bytes simply because we always know the byte
length. squareroot has the same ordering as the positive value,
so don't bother with the actual square root. */
- const float existing = THREEWAY_SQUARE(0, cache[3], cache[1], blen);
if (byte > cache[1]) {
/* New position is after the existing pair of pairs. */
const float keep_earlier
@@ -6957,18 +7112,14 @@
= THREEWAY_SQUARE(0, cache[1], byte, blen);
if (keep_later < keep_earlier) {
- if (keep_later < existing) {
- cache[2] = cache[0];
- cache[3] = cache[1];
- cache[0] = utf8;
- cache[1] = byte;
- }
+ cache[2] = cache[0];
+ cache[3] = cache[1];
+ cache[0] = utf8;
+ cache[1] = byte;
}
else {
- if (keep_earlier < existing) {
- cache[0] = utf8;
- cache[1] = byte;
- }
+ cache[0] = utf8;
+ cache[1] = byte;
}
}
else if (byte > cache[3]) {
@@ -6979,16 +7130,12 @@
= THREEWAY_SQUARE(0, byte, cache[1], blen);
if (keep_later < keep_earlier) {
- if (keep_later < existing) {
- cache[2] = utf8;
- cache[3] = byte;
- }
+ cache[2] = utf8;
+ cache[3] = byte;
}
else {
- if (keep_earlier < existing) {
- cache[0] = utf8;
- cache[1] = byte;
- }
+ cache[0] = utf8;
+ cache[1] = byte;
}
}
else {
@@ -6999,18 +7146,14 @@
= THREEWAY_SQUARE(0, byte, cache[1], blen);
if (keep_later < keep_earlier) {
- if (keep_later < existing) {
- cache[2] = utf8;
- cache[3] = byte;
- }
+ cache[2] = utf8;
+ cache[3] = byte;
}
else {
- if (keep_earlier < existing) {
- cache[0] = cache[2];
- cache[1] = cache[3];
- cache[2] = utf8;
- cache[3] = byte;
- }
+ cache[0] = cache[2];
+ cache[1] = cache[3];
+ cache[2] = utf8;
+ cache[3] = byte;
}
}
}
@@ -7060,7 +7203,7 @@
*
*/
void
-Perl_sv_pos_b2u(pTHX_ register SV *const sv, I32 *const offsetp)
+Perl_sv_pos_b2u(pTHX_ SV *const sv, I32 *const offsetp)
{
const U8* s;
const STRLEN byte = *offsetp;
@@ -7078,7 +7221,8 @@
s = (const U8*)SvPV_const(sv, blen);
if (blen < byte)
- Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
+ Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset, blen=%"UVuf
+ ", byte=%"UVuf, (UV)blen, (UV)byte);
send = s + byte;
@@ -7173,20 +7317,20 @@
=for apidoc sv_eq
Returns a boolean indicating whether the strings in the two SVs are
-identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
+identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
coerce its args to strings if necessary.
=for apidoc sv_eq_flags
Returns a boolean indicating whether the strings in the two SVs are
-identical. Is UTF-8 and 'use bytes' aware and coerces its args to strings
-if necessary. If the flags include SV_GMAGIC, it handles get-magic, too.
+identical. Is UTF-8 and 'use bytes' aware and coerces its args to strings
+if necessary. If the flags include SV_GMAGIC, it handles get-magic, too.
=cut
*/
I32
-Perl_sv_eq_flags(pTHX_ register SV *sv1, register SV *sv2, const U32 flags)
+Perl_sv_eq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags)
{
dVAR;
const char *pv1;
@@ -7194,7 +7338,6 @@
const char *pv2;
STRLEN cur2;
I32 eq = 0;
- char *tpv = NULL;
SV* svrecode = NULL;
if (!sv1) {
@@ -7236,7 +7379,7 @@
}
/* Now both are in UTF-8. */
if (cur1 != cur2) {
- SvREFCNT_dec(svrecode);
+ SvREFCNT_dec_NN(svrecode);
return FALSE;
}
}
@@ -7258,8 +7401,6 @@
eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
SvREFCNT_dec(svrecode);
- if (tpv)
- Safefree(tpv);
return eq;
}
@@ -7269,7 +7410,7 @@
Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
string in C<sv1> is less than, equal to, or greater than the string in
-C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
+C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
coerce its args to strings if necessary. See also C<sv_cmp_locale>.
=for apidoc sv_cmp_flags
@@ -7276,8 +7417,8 @@
Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
string in C<sv1> is less than, equal to, or greater than the string in
-C<sv2>. Is UTF-8 and 'use bytes' aware and will coerce its args to strings
-if necessary. If the flags include SV_GMAGIC, it handles get magic. See
+C<sv2>. Is UTF-8 and 'use bytes' aware and will coerce its args to strings
+if necessary. If the flags include SV_GMAGIC, it handles get magic. See
also C<sv_cmp_locale_flags>.
=cut
@@ -7284,19 +7425,18 @@
*/
I32
-Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2)
+Perl_sv_cmp(pTHX_ SV *const sv1, SV *const sv2)
{
return sv_cmp_flags(sv1, sv2, SV_GMAGIC);
}
I32
-Perl_sv_cmp_flags(pTHX_ register SV *const sv1, register SV *const sv2,
+Perl_sv_cmp_flags(pTHX_ SV *const sv1, SV *const sv2,
const U32 flags)
{
dVAR;
STRLEN cur1, cur2;
const char *pv1, *pv2;
- char *tpv = NULL;
I32 cmp;
SV *svrecode = NULL;
@@ -7360,8 +7500,6 @@
}
SvREFCNT_dec(svrecode);
- if (tpv)
- Safefree(tpv);
return cmp;
}
@@ -7369,27 +7507,27 @@
/*
=for apidoc sv_cmp_locale
-Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
+Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
'use bytes' aware, handles get magic, and will coerce its args to strings
if necessary. See also C<sv_cmp>.
=for apidoc sv_cmp_locale_flags
-Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
-'use bytes' aware and will coerce its args to strings if necessary. If the
-flags contain SV_GMAGIC, it handles get magic. See also C<sv_cmp_flags>.
+Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
+'use bytes' aware and will coerce its args to strings if necessary. If the
+flags contain SV_GMAGIC, it handles get magic. See also C<sv_cmp_flags>.
=cut
*/
I32
-Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2)
+Perl_sv_cmp_locale(pTHX_ SV *const sv1, SV *const sv2)
{
return sv_cmp_locale_flags(sv1, sv2, SV_GMAGIC);
}
I32
-Perl_sv_cmp_locale_flags(pTHX_ register SV *const sv1, register SV *const sv2,
+Perl_sv_cmp_locale_flags(pTHX_ SV *const sv1, SV *const sv2,
const U32 flags)
{
dVAR;
@@ -7444,12 +7582,12 @@
/*
=for apidoc sv_collxfrm
-This calls C<sv_collxfrm_flags> with the SV_GMAGIC flag. See
+This calls C<sv_collxfrm_flags> with the SV_GMAGIC flag. See
C<sv_collxfrm_flags>.
=for apidoc sv_collxfrm_flags
-Add Collate Transform magic to an SV if it doesn't already have it. If the
+Add Collate Transform magic to an SV if it doesn't already have it. If the
flags contain SV_GMAGIC, it handles get-magic.
Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
@@ -7526,29 +7664,111 @@
static char *
S_sv_gets_read_record(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
{
- I32 bytesread;
- const U32 recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
+ SSize_t bytesread;
+ const STRLEN recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
/* Grab the size of the record we're getting */
- char *const buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
+ char *buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
+
+ /* Go yank in */
#ifdef VMS
+#include <rms.h>
int fd;
-#endif
+ Stat_t st;
- /* Go yank in */
-#ifdef VMS
- /* VMS wants read instead of fread, because fread doesn't respect */
- /* RMS record boundaries. This is not necessarily a good thing to be */
- /* doing, but we've got no other real choice - except avoid stdio
- as implementation - perhaps write a :vms layer ?
- */
+ /* With a true, record-oriented file on VMS, we need to use read directly
+ * to ensure that we respect RMS record boundaries. The user is responsible
+ * for providing a PL_rs value that corresponds to the FAB$W_MRS (maximum
+ * record size) field. N.B. This is likely to produce invalid results on
+ * varying-width character data when a record ends mid-character.
+ */
fd = PerlIO_fileno(fp);
- if (fd != -1) {
+ if (fd != -1
+ && PerlLIO_fstat(fd, &st) == 0
+ && (st.st_fab_rfm == FAB$C_VAR
+ || st.st_fab_rfm == FAB$C_VFC
+ || st.st_fab_rfm == FAB$C_FIX)) {
+
bytesread = PerlLIO_read(fd, buffer, recsize);
}
- else /* in-memory file from PerlIO::Scalar */
+ else /* in-memory file from PerlIO::Scalar
+ * or not a record-oriented file
+ */
#endif
{
bytesread = PerlIO_read(fp, buffer, recsize);
+
+ /* At this point, the logic in sv_get() means that sv will
+ be treated as utf-8 if the handle is utf8.
+ */
+ if (PerlIO_isutf8(fp) && bytesread > 0) {
+ char *bend = buffer + bytesread;
+ char *bufp = buffer;
+ size_t charcount = 0;
+ bool charstart = TRUE;
+ STRLEN skip = 0;
+
+ while (charcount < recsize) {
+ /* count accumulated characters */
+ while (bufp < bend) {
+ if (charstart) {
+ skip = UTF8SKIP(bufp);
+ }
+ if (bufp + skip > bend) {
+ /* partial at the end */
+ charstart = FALSE;
+ break;
+ }
+ else {
+ ++charcount;
+ bufp += skip;
+ charstart = TRUE;
+ }
+ }
+
+ if (charcount < recsize) {
+ STRLEN readsize;
+ STRLEN bufp_offset = bufp - buffer;
+ SSize_t morebytesread;
+
+ /* originally I read enough to fill any incomplete
+ character and the first byte of the next
+ character if needed, but if there's many
+ multi-byte encoded characters we're going to be
+ making a read call for every character beyond
+ the original read size.
+
+ So instead, read the rest of the character if
+ any, and enough bytes to match at least the
+ start bytes for each character we're going to
+ read.
+ */
+ if (charstart)
+ readsize = recsize - charcount;
+ else
+ readsize = skip - (bend - bufp) + recsize - charcount - 1;
+ buffer = SvGROW(sv, append + bytesread + readsize + 1) + append;
+ bend = buffer + bytesread;
+ morebytesread = PerlIO_read(fp, bend, readsize);
+ if (morebytesread <= 0) {
+ /* we're done, if we still have incomplete
+ characters the check code in sv_gets() will
+ warn about them.
+
+ I'd originally considered doing
+ PerlIO_ungetc() on all but the lead
+ character of the incomplete character, but
+ read() doesn't do that, so I don't.
+ */
+ break;
+ }
+
+ /* prepare to scan some more */
+ bytesread += morebytesread;
+ bend = buffer + bytesread;
+ bufp = buffer + bufp_offset;
+ }
+ }
+ }
}
if (bytesread < 0)
@@ -7562,20 +7782,23 @@
=for apidoc sv_gets
Get a line from the filehandle and store it into the SV, optionally
-appending to the currently-stored string.
+appending to the currently-stored string. If C<append> is not 0, the
+line is appended to the SV instead of overwriting it. C<append> should
+be set to the byte offset that the appended string should start at
+in the SV (typically, C<SvCUR(sv)> is a suitable choice).
=cut
*/
char *
-Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append)
+Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
{
dVAR;
const char *rsptr;
STRLEN rslen;
- register STDCHAR rslast;
- register STDCHAR *bp;
- register I32 cnt;
+ STDCHAR rslast;
+ STDCHAR *bp;
+ I32 cnt;
I32 i = 0;
I32 rspara = 0;
@@ -7590,8 +7813,6 @@
Swings and roundabouts. */
SvUPGRADE(sv, SVt_PV);
- SvSCREAM_off(sv);
-
if (append) {
if (PerlIO_isutf8(fp)) {
if (!SvUTF8(sv)) {
@@ -7684,7 +7905,7 @@
* We're going to steal some values from the stdio struct
* and put EVERYTHING in the innermost loop into registers.
*/
- register STDCHAR *ptr;
+ STDCHAR *ptr;
STRLEN bpx;
I32 shortbuffered;
@@ -7830,7 +8051,7 @@
screamer2:
if (rslen) {
- register const STDCHAR * const bpe = buf + sizeof(buf);
+ const STDCHAR * const bpe = buf + sizeof(buf);
bp = buf;
while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
; /* keep reading */
@@ -7850,9 +8071,9 @@
if (cnt < 0)
cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
if (append)
- sv_catpvn(sv, (char *) buf, cnt);
+ sv_catpvn_nomg(sv, (char *) buf, cnt);
else
- sv_setpvn(sv, (char *) buf, cnt);
+ sv_setpvn(sv, (char *) buf, cnt); /* "nomg" is implied */
if (i != EOF && /* joy */
(!rslen ||
@@ -7897,13 +8118,13 @@
=for apidoc sv_inc
Auto-increment of the value in the SV, doing string to numeric conversion
-if necessary. Handles 'get' magic and operator overloading.
+if necessary. Handles 'get' magic and operator overloading.
=cut
*/
void
-Perl_sv_inc(pTHX_ register SV *const sv)
+Perl_sv_inc(pTHX_ SV *const sv)
{
if (!sv)
return;
@@ -7915,26 +8136,26 @@
=for apidoc sv_inc_nomg
Auto-increment of the value in the SV, doing string to numeric conversion
-if necessary. Handles operator overloading. Skips handling 'get' magic.
+if necessary. Handles operator overloading. Skips handling 'get' magic.
=cut
*/
void
-Perl_sv_inc_nomg(pTHX_ register SV *const sv)
+Perl_sv_inc_nomg(pTHX_ SV *const sv)
{
dVAR;
- register char *d;
+ char *d;
int flags;
if (!sv)
return;
if (SvTHINKFIRST(sv)) {
- if (SvIsCOW(sv))
+ if (SvIsCOW(sv) || isGV_with_GP(sv))
sv_force_normal_flags(sv, 0);
if (SvREADONLY(sv)) {
if (IN_PERL_RUNTIME)
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
}
if (SvROK(sv)) {
IV i;
@@ -7977,6 +8198,7 @@
const NV was = SvNVX(sv);
if (NV_OVERFLOWS_INTEGERS_AT &&
was >= NV_OVERFLOWS_INTEGERS_AT) {
+ /* diag_listed_as: Lost precision when %s %f by 1 */
Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
"Lost precision when incrementing %" NVff " by 1",
was);
@@ -8078,13 +8300,13 @@
=for apidoc sv_dec
Auto-decrement of the value in the SV, doing string to numeric conversion
-if necessary. Handles 'get' magic and operator overloading.
+if necessary. Handles 'get' magic and operator overloading.
=cut
*/
void
-Perl_sv_dec(pTHX_ register SV *const sv)
+Perl_sv_dec(pTHX_ SV *const sv)
{
dVAR;
if (!sv)
@@ -8097,13 +8319,13 @@
=for apidoc sv_dec_nomg
Auto-decrement of the value in the SV, doing string to numeric conversion
-if necessary. Handles operator overloading. Skips handling 'get' magic.
+if necessary. Handles operator overloading. Skips handling 'get' magic.
=cut
*/
void
-Perl_sv_dec_nomg(pTHX_ register SV *const sv)
+Perl_sv_dec_nomg(pTHX_ SV *const sv)
{
dVAR;
int flags;
@@ -8111,11 +8333,11 @@
if (!sv)
return;
if (SvTHINKFIRST(sv)) {
- if (SvIsCOW(sv))
+ if (SvIsCOW(sv) || isGV_with_GP(sv))
sv_force_normal_flags(sv, 0);
if (SvREADONLY(sv)) {
if (IN_PERL_RUNTIME)
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
}
if (SvROK(sv)) {
IV i;
@@ -8161,6 +8383,7 @@
const NV was = SvNVX(sv);
if (NV_OVERFLOWS_INTEGERS_AT &&
was <= -NV_OVERFLOWS_INTEGERS_AT) {
+ /* diag_listed_as: Lost precision when %s %f by 1 */
Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
"Lost precision when decrementing %" NVff " by 1",
was);
@@ -8228,7 +8451,7 @@
=for apidoc sv_mortalcopy
Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
-The new SV is marked as mortal. It will be destroyed "soon", either by an
+The new SV is marked as mortal. It will be destroyed "soon", either by an
explicit call to FREETMPS, or by an implicit call at places such as
statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
@@ -8241,13 +8464,15 @@
* permanent location. */
SV *
-Perl_sv_mortalcopy(pTHX_ SV *const oldstr)
+Perl_sv_mortalcopy_flags(pTHX_ SV *const oldstr, U32 flags)
{
dVAR;
- register SV *sv;
+ SV *sv;
+ if (flags & SV_GMAGIC)
+ SvGETMAGIC(oldstr); /* before new_SV, in case it dies */
new_SV(sv);
- sv_setsv(sv,oldstr);
+ sv_setsv_flags(sv,oldstr,flags & ~SV_GMAGIC);
PUSH_EXTEND_MORTAL__SV_C(sv);
SvTEMP_on(sv);
return sv;
@@ -8257,7 +8482,7 @@
=for apidoc sv_newmortal
Creates a new null SV which is mortal. The reference count of the SV is
-set to 1. It will be destroyed "soon", either by an explicit call to
+set to 1. It will be destroyed "soon", either by an explicit call to
FREETMPS, or by an implicit call at places such as statement boundaries.
See also C<sv_mortalcopy> and C<sv_2mortal>.
@@ -8268,7 +8493,7 @@
Perl_sv_newmortal(pTHX)
{
dVAR;
- register SV *sv;
+ SV *sv;
new_SV(sv);
SvFLAGS(sv) = SVs_TEMP;
@@ -8286,7 +8511,8 @@
C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>.
If C<SVs_TEMP> is set, then C<sv_2mortal()> is called on the result before
-returning. If C<SVf_UTF8> is set, C<s> is considered to be in UTF-8 and the
+returning. If C<SVf_UTF8> is set, C<s>
+is considered to be in UTF-8 and the
C<SVf_UTF8> flag will be set on the new SV.
C<newSVpvn_utf8()> is a convenience wrapper for this function, defined as
@@ -8300,7 +8526,7 @@
Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags)
{
dVAR;
- register SV *sv;
+ SV *sv;
/* All the flags we don't support must be zero.
And we're new code so I'm going to assert this from the start. */
@@ -8331,7 +8557,7 @@
Marks an existing SV as mortal. The SV will be destroyed "soon", either
by an explicit call to FREETMPS, or by an implicit call at places such as
statement boundaries. SvTEMP() is turned on which means that the SV's
-string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
+string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
and C<sv_mortalcopy>.
=cut
@@ -8338,12 +8564,12 @@
*/
SV *
-Perl_sv_2mortal(pTHX_ register SV *const sv)
+Perl_sv_2mortal(pTHX_ SV *const sv)
{
dVAR;
if (!sv)
return NULL;
- if (SvREADONLY(sv) && SvIMMORTAL(sv))
+ if (SvIMMORTAL(sv))
return sv;
PUSH_EXTEND_MORTAL__SV_C(sv);
SvTEMP_on(sv);
@@ -8364,7 +8590,7 @@
Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
{
dVAR;
- register SV *sv;
+ SV *sv;
new_SV(sv);
sv_setpvn(sv, s, len || s == NULL ? len : strlen(s));
@@ -8374,22 +8600,24 @@
/*
=for apidoc newSVpvn
-Creates a new SV and copies a string into it. The reference count for the
-SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
-string. You are responsible for ensuring that the source string is at least
-C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
+Creates a new SV and copies a buffer into it, which may contain NUL characters
+(C<\0>) and other binary data. The reference count for the SV is set to 1.
+Note that if C<len> is zero, Perl will create a zero length (Perl) string. You
+are responsible for ensuring that the source buffer is at least
+C<len> bytes long. If the C<buffer> argument is NULL the new SV will be
+undefined.
=cut
*/
SV *
-Perl_newSVpvn(pTHX_ const char *const s, const STRLEN len)
+Perl_newSVpvn(pTHX_ const char *const buffer, const STRLEN len)
{
dVAR;
- register SV *sv;
+ SV *sv;
new_SV(sv);
- sv_setpvn(sv,s,len);
+ sv_setpvn(sv,buffer,len);
return sv;
}
@@ -8397,7 +8625,7 @@
=for apidoc newSVhek
Creates a new SV from the hash key structure. It will generate scalars that
-point to the shared string table where possible. Returns a new (undefined)
+point to the shared string table where possible. Returns a new (undefined)
SV if the hek is NULL.
=cut
@@ -8429,15 +8657,10 @@
sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
SvUTF8_on (sv);
return sv;
- } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
- /* We don't have a pointer to the hv, so we have to replicate the
- flag into every HEK. This hv is using custom a hasing
- algorithm. Hence we can't return a shared string scalar, as
- that would contain the (wrong) hash value, and might get passed
- into an hv routine with a regular hash.
- Similarly, a hash that isn't using shared hash keys has to have
+ } else if (flags & HVhek_UNSHARED) {
+ /* A hash that isn't using shared hash keys has to have
the flag in every key so that we know not to try to call
- share_hek_kek on it. */
+ share_hek_hek on it. */
SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
if (HEK_UTF8(hek))
@@ -8455,8 +8678,7 @@
SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
SvCUR_set(sv, HEK_LEN(hek));
SvLEN_set(sv, 0);
- SvREADONLY_on(sv);
- SvFAKE_on(sv);
+ SvIsCOW_on(sv);
SvPOK_on(sv);
if (HEK_UTF8(hek))
SvUTF8_on(sv);
@@ -8469,10 +8691,12 @@
=for apidoc newSVpvn_share
Creates a new SV with its SvPVX_const pointing to a shared string in the string
-table. If the string does not already exist in the table, it is created
-first. Turns on READONLY and FAKE. If the C<hash> parameter is non-zero, that
-value is used; otherwise the hash is computed. The string's hash can be later
-be retrieved from the SV with the C<SvSHARED_HASH()> macro. The idea here is
+table. If the string does not already exist in the table, it is
+created first. Turns on the SvIsCOW flag (or READONLY
+and FAKE in 5.16 and earlier). If the C<hash> parameter
+is non-zero, that value is used; otherwise the hash is computed.
+The string's hash can later be retrieved from the SV
+with the C<SvSHARED_HASH()> macro. The idea here is
that as the string table is used for shared hash keys these strings will have
SvPVX_const == HeKEY and hash lookup will avoid string compare.
@@ -8483,7 +8707,7 @@
Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
{
dVAR;
- register SV *sv;
+ SV *sv;
bool is_utf8 = FALSE;
const char *const orig_src = src;
@@ -8503,8 +8727,7 @@
SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
SvCUR_set(sv, len);
SvLEN_set(sv, 0);
- SvREADONLY_on(sv);
- SvFAKE_on(sv);
+ SvIsCOW_on(sv);
SvPOK_on(sv);
if (is_utf8)
SvUTF8_on(sv);
@@ -8539,7 +8762,7 @@
Perl_newSVpvf_nocontext(const char *const pat, ...)
{
dTHX;
- register SV *sv;
+ SV *sv;
va_list args;
PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT;
@@ -8563,7 +8786,7 @@
SV *
Perl_newSVpvf(pTHX_ const char *const pat, ...)
{
- register SV *sv;
+ SV *sv;
va_list args;
PERL_ARGS_ASSERT_NEWSVPVF;
@@ -8580,7 +8803,7 @@
Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
{
dVAR;
- register SV *sv;
+ SV *sv;
PERL_ARGS_ASSERT_VNEWSVPVF;
@@ -8602,7 +8825,7 @@
Perl_newSVnv(pTHX_ const NV n)
{
dVAR;
- register SV *sv;
+ SV *sv;
new_SV(sv);
sv_setnv(sv,n);
@@ -8622,7 +8845,7 @@
Perl_newSViv(pTHX_ const IV i)
{
dVAR;
- register SV *sv;
+ SV *sv;
new_SV(sv);
sv_setiv(sv,i);
@@ -8642,7 +8865,7 @@
Perl_newSVuv(pTHX_ const UV u)
{
dVAR;
- register SV *sv;
+ SV *sv;
new_SV(sv);
sv_setuv(sv,u);
@@ -8661,7 +8884,7 @@
SV *
Perl_newSV_type(pTHX_ const svtype type)
{
- register SV *sv;
+ SV *sv;
new_SV(sv);
sv_upgrade(sv, type);
@@ -8681,7 +8904,7 @@
Perl_newRV_noinc(pTHX_ SV *const tmpRef)
{
dVAR;
- register SV *sv = newSV_type(SVt_IV);
+ SV *sv = newSV_type(SVt_IV);
PERL_ARGS_ASSERT_NEWRV_NOINC;
@@ -8709,28 +8932,29 @@
=for apidoc newSVsv
Creates a new SV which is an exact duplicate of the original SV.
-(Uses C<sv_setsv>).
+(Uses C<sv_setsv>.)
=cut
*/
SV *
-Perl_newSVsv(pTHX_ register SV *const old)
+Perl_newSVsv(pTHX_ SV *const old)
{
dVAR;
- register SV *sv;
+ SV *sv;
if (!old)
return NULL;
- if (SvTYPE(old) == SVTYPEMASK) {
+ if (SvTYPE(old) == (svtype)SVTYPEMASK) {
Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
return NULL;
}
+ /* Do this here, otherwise we leak the new SV if this croaks. */
+ SvGETMAGIC(old);
new_SV(sv);
- /* SV_GMAGIC is the default for sv_setv()
- SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
+ /* SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
- sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
+ sv_setsv_flags(sv, old, SV_NOSTEAL);
return sv;
}
@@ -8744,17 +8968,24 @@
*/
void
-Perl_sv_reset(pTHX_ register const char *s, HV *const stash)
+Perl_sv_reset(pTHX_ const char *s, HV *const stash)
{
+ PERL_ARGS_ASSERT_SV_RESET;
+
+ sv_resetpvn(*s ? s : NULL, strlen(s), stash);
+}
+
+void
+Perl_sv_resetpvn(pTHX_ const char *s, STRLEN len, HV * const stash)
+{
dVAR;
char todo[PERL_UCHAR_MAX+1];
+ const char *send;
- PERL_ARGS_ASSERT_SV_RESET;
-
if (!stash)
return;
- if (!*s) { /* reset ?? searches */
+ if (!s) { /* reset ?? searches */
MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab);
if (mg) {
const U32 count = mg->mg_len / sizeof(PMOP**);
@@ -8779,7 +9010,8 @@
return;
Zero(todo, 256, char);
- while (*s) {
+ send = s + len;
+ while (s < send) {
I32 max;
I32 i = (unsigned char)*s;
if (s[1] == '-') {
@@ -8795,8 +9027,8 @@
entry;
entry = HeNEXT(entry))
{
- register GV *gv;
- register SV *sv;
+ GV *gv;
+ SV *sv;
if (!todo[(U8)*HeKEY(entry)])
continue;
@@ -8844,6 +9076,9 @@
GV; or the recursive result if we're an RV; or the IO slot of the symbol
named after the PV if we're a string.
+'Get' magic is ignored on the sv passed in, but will be called on
+C<SvRV(sv)> if sv is an RV.
+
=cut
*/
@@ -8865,7 +9100,8 @@
gv = MUTABLE_GV(sv);
io = GvIO(gv);
if (!io)
- Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
+ Perl_croak(aTHX_ "Bad filehandle: %"HEKf,
+ HEKfARG(GvNAME_HEK(gv)));
break;
}
/* FALL THROUGH */
@@ -8872,15 +9108,23 @@
default:
if (!SvOK(sv))
Perl_croak(aTHX_ PL_no_usym, "filehandle");
- if (SvROK(sv))
+ if (SvROK(sv)) {
+ SvGETMAGIC(SvRV(sv));
return sv_2io(SvRV(sv));
- gv = gv_fetchsv(sv, 0, SVt_PVIO);
+ }
+ gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
if (gv)
io = GvIO(gv);
else
io = 0;
- if (!io)
- Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(sv));
+ if (!io) {
+ SV *newsv = sv;
+ if (SvGMAGICAL(sv)) {
+ newsv = sv_newmortal();
+ sv_setsv_nomg(newsv, sv);
+ }
+ Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(newsv));
+ }
break;
}
return io;
@@ -8920,22 +9164,11 @@
*st = NULL;
*gvp = NULL;
return NULL;
- case SVt_PVGV:
- if (isGV_with_GP(sv)) {
- gv = MUTABLE_GV(sv);
- *gvp = gv;
- *st = GvESTASH(gv);
- goto fix_gv;
- }
- /* FALL THROUGH */
-
default:
+ SvGETMAGIC(sv);
if (SvROK(sv)) {
- SvGETMAGIC(sv);
if (SvAMAGIC(sv))
sv = amagic_deref_call(sv, to_cv_amg);
- /* At this point I'd like to do SPAGAIN, but really I need to
- force it upon my callers. Hmmm. This is a mess... */
sv = SvRV(sv);
if (SvTYPE(sv) == SVt_PVCV) {
@@ -8944,17 +9177,17 @@
*st = CvSTASH(cv);
return cv;
}
- else if(isGV_with_GP(sv))
+ else if(SvGETMAGIC(sv), isGV_with_GP(sv))
gv = MUTABLE_GV(sv);
else
Perl_croak(aTHX_ "Not a subroutine reference");
}
else if (isGV_with_GP(sv)) {
- SvGETMAGIC(sv);
gv = MUTABLE_GV(sv);
}
- else
- gv = gv_fetchsv(sv, lref, SVt_PVCV); /* Calls get magic */
+ else {
+ gv = gv_fetchsv_nomg(sv, lref, SVt_PVCV);
+ }
*gvp = gv;
if (!gv) {
*st = NULL;
@@ -8966,22 +9199,11 @@
return NULL;
}
*st = GvESTASH(gv);
- fix_gv:
- if (lref && !GvCVu(gv)) {
- SV *tmpsv;
- ENTER;
- tmpsv = newSV(0);
- gv_efullname3(tmpsv, gv, NULL);
+ if (lref & ~GV_ADDMG && !GvCVu(gv)) {
/* XXX this is probably not what they think they're getting.
* It has the same effect as "sub name;", i.e. just a forward
* declaration! */
- newSUB(start_subparse(FALSE, 0),
- newSVOP(OP_CONST, 0, tmpsv),
- NULL, NULL);
- LEAVE;
- if (!GvCVu(gv))
- Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
- SVfARG(SvOK(sv) ? sv : &PL_sv_no));
+ newSTUB(gv,0);
}
return GvCVu(gv);
}
@@ -8998,12 +9220,12 @@
*/
I32
-Perl_sv_true(pTHX_ register SV *const sv)
+Perl_sv_true(pTHX_ SV *const sv)
{
if (!sv)
return 0;
if (SvPOK(sv)) {
- register const XPV* const tXpv = (XPV*)SvANY(sv);
+ const XPV* const tXpv = (XPV*)SvANY(sv);
if (tXpv &&
(tXpv->xpv_cur > 1 ||
(tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
@@ -9028,13 +9250,13 @@
Get a sensible string out of the SV somehow.
A private implementation of the C<SvPV_force> macro for compilers which
-can't cope with complex macro expressions. Always use the macro instead.
+can't cope with complex macro expressions. Always use the macro instead.
=for apidoc sv_pvn_force_flags
Get a sensible string out of the SV somehow.
If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
-appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
+appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
implemented in terms of this function.
You normally want to use the various wrapper macros instead: see
C<SvPV_force> and C<SvPV_force_nomg>
@@ -9049,6 +9271,7 @@
PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
+ if (flags & SV_GMAGIC) SvGETMAGIC(sv);
if (SvTHINKFIRST(sv) && !SvROK(sv))
sv_force_normal_flags(sv, 0);
@@ -9068,12 +9291,15 @@
else
Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
}
- if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
+ if (SvTYPE(sv) > SVt_PVLV
|| isGV_with_GP(sv))
/* diag_listed_as: Can't coerce %s to %s in %s */
Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
OP_DESC(PL_op));
- s = sv_2pv_flags(sv, &len, flags);
+ s = sv_2pv_flags(sv, &len, flags &~ SV_GMAGIC);
+ if (!s) {
+ s = (char *)"";
+ }
if (lp)
*lp = len;
@@ -9093,6 +9319,7 @@
PTR2UV(sv),SvPVX_const(sv)));
}
}
+ (void)SvPOK_only_UTF8(sv);
return SvPVX_mutable(sv);
}
@@ -9099,7 +9326,8 @@
/*
=for apidoc sv_pvbyten_force
-The backend for the C<SvPVbytex_force> macro. Always use the macro instead.
+The backend for the C<SvPVbytex_force> macro. Always use the macro
+instead.
=cut
*/
@@ -9118,7 +9346,8 @@
/*
=for apidoc sv_pvutf8n_force
-The backend for the C<SvPVutf8x_force> macro. Always use the macro instead.
+The backend for the C<SvPVutf8x_force> macro. Always use the macro
+instead.
=cut
*/
@@ -9128,8 +9357,8 @@
{
PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
- sv_pvn_force(sv,lp);
- sv_utf8_upgrade(sv);
+ sv_pvn_force(sv,0);
+ sv_utf8_upgrade_nomg(sv);
*lp = SvCUR(sv);
return SvPVX(sv);
}
@@ -9146,12 +9375,8 @@
Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
{
PERL_ARGS_ASSERT_SV_REFTYPE;
-
- /* The fact that I don't need to downcast to char * everywhere, only in ?:
- inside return suggests a const propagation bug in g++. */
if (ob && SvOBJECT(sv)) {
- char * const name = HvNAME_get(SvSTASH(sv));
- return name ? name : (char *) "__ANON__";
+ return SvPV_nolen_const(sv_ref(NULL, sv, ob));
}
else {
switch (SvTYPE(sv)) {
@@ -9189,6 +9414,34 @@
}
/*
+=for apidoc sv_ref
+
+Returns a SV describing what the SV passed in is a reference to.
+
+=cut
+*/
+
+SV *
+Perl_sv_ref(pTHX_ SV *dst, const SV *const sv, const int ob)
+{
+ PERL_ARGS_ASSERT_SV_REF;
+
+ if (!dst)
+ dst = sv_newmortal();
+
+ if (ob && SvOBJECT(sv)) {
+ HvNAME_get(SvSTASH(sv))
+ ? sv_sethek(dst, HvNAME_HEK(SvSTASH(sv)))
+ : sv_setpvn(dst, "__ANON__", 8);
+ }
+ else {
+ const char * reftype = sv_reftype(sv, 0);
+ sv_setpv(dst, reftype);
+ }
+ return dst;
+}
+
+/*
=for apidoc sv_isobject
Returns a boolean indicating whether the SV is an RV pointing to a blessed
@@ -9247,10 +9500,10 @@
/*
=for apidoc newSVrv
-Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
-it will be upgraded to one. If C<classname> is non-null then the new SV will
-be blessed in the specified package. The new SV is returned and its
-reference count is 1.
+Creates a new SV for the existing RV, C<rv>, to point to. If C<rv> is not an
+RV then it will be upgraded to one. If C<classname> is non-null then the new
+SV will be blessed in the specified package. The new SV is returned and its
+reference count is 1. The reference count 1 is owned by C<rv>.
=cut
*/
@@ -9266,7 +9519,6 @@
new_SV(sv);
SV_CHECK_THINKFIRST_COW_DROP(rv);
- (void)SvAMAGIC_off(rv);
if (SvTYPE(rv) >= SVt_PVMG) {
const U32 refcnt = SvREFCNT(rv);
@@ -9437,27 +9689,16 @@
Perl_croak(aTHX_ "Can't bless non-reference value");
tmpRef = SvRV(sv);
if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
- if (SvIsCOW(tmpRef))
- sv_force_normal_flags(tmpRef, 0);
- if (SvREADONLY(tmpRef))
- Perl_croak_no_modify(aTHX);
+ if (SvREADONLY(tmpRef) && !SvIsCOW(tmpRef))
+ Perl_croak_no_modify();
if (SvOBJECT(tmpRef)) {
- if (SvTYPE(tmpRef) != SVt_PVIO)
- --PL_sv_objcount;
SvREFCNT_dec(SvSTASH(tmpRef));
}
}
SvOBJECT_on(tmpRef);
- if (SvTYPE(tmpRef) != SVt_PVIO)
- ++PL_sv_objcount;
SvUPGRADE(tmpRef, SVt_PVMG);
SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
- if (Gv_AMG(stash))
- SvAMAGIC_on(sv);
- else
- (void)SvAMAGIC_off(sv);
-
if(SvSMAGICAL(tmpRef))
if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
mg_set(tmpRef);
@@ -9467,23 +9708,24 @@
return sv;
}
-/* Downgrades a PVGV to a PVMG. If it’s actually a PVLV, we leave the type
+/* Downgrades a PVGV to a PVMG. If it's actually a PVLV, we leave the type
* as it is after unglobbing it.
*/
-STATIC void
-S_sv_unglob(pTHX_ SV *const sv)
+PERL_STATIC_INLINE void
+S_sv_unglob(pTHX_ SV *const sv, U32 flags)
{
dVAR;
void *xpvmg;
HV *stash;
- SV * const temp = sv_newmortal();
+ SV * const temp = flags & SV_COW_DROP_PV ? NULL : sv_newmortal();
PERL_ARGS_ASSERT_SV_UNGLOB;
assert(SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV);
SvFAKE_off(sv);
- gv_efullname3(temp, MUTABLE_GV(sv), "*");
+ if (!(flags & SV_COW_DROP_PV))
+ gv_efullname3(temp, MUTABLE_GV(sv), "*");
if (GvGP(sv)) {
if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
@@ -9514,7 +9756,13 @@
/* Intentionally not calling any local SET magic, as this isn't so much a
set operation as merely an internal storage change. */
- sv_setsv_flags(sv, temp, 0);
+ if (flags & SV_COW_DROP_PV) SvOK_off(sv);
+ else sv_setsv_flags(sv, temp, 0);
+
+ if ((const GV *)sv == PL_last_in_gv)
+ PL_last_in_gv = NULL;
+ else if ((const GV *)sv == PL_statgv)
+ PL_statgv = NULL;
}
/*
@@ -9549,7 +9797,7 @@
/* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
assigned to as BEGIN {$a = \"Foo"} will fail. */
if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
- SvREFCNT_dec(target);
+ SvREFCNT_dec_NN(target);
else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
sv_2mortal(target); /* Schedule for freeing later */
}
@@ -9557,7 +9805,8 @@
/*
=for apidoc sv_untaint
-Untaint an SV. Use C<SvTAINTED_off> instead.
+Untaint an SV. Use C<SvTAINTED_off> instead.
+
=cut
*/
@@ -9576,7 +9825,8 @@
/*
=for apidoc sv_tainted
-Test an SV for taintedness. Use C<SvTAINTED> instead.
+Test an SV for taintedness. Use C<SvTAINTED> instead.
+
=cut
*/
@@ -9796,7 +10046,7 @@
(including, but not limited to, SVs with a UTF-8 PV formatted with %s,
and characters >255 formatted with %c), the original SV might get
upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
-C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
+C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
valid UTF-8; if the original SV was bytes, the pattern should be too.
=cut */
@@ -9889,7 +10139,7 @@
PERL_ARGS_ASSERT_SV_VSETPVFN;
sv_setpvs(sv, "");
- sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
+ sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, 0);
}
@@ -9963,6 +10213,8 @@
/*
=for apidoc sv_vcatpvfn
+=for apidoc sv_vcatpvfn_flags
+
Processes its arguments like C<vsprintf> and appends the formatted output
to an SV. Uses an array of SVs if the C style variable argument list is
missing (NULL). When running with taint checks enabled, indicates via
@@ -9969,12 +10221,13 @@
C<maybe_tainted> if results are untrustworthy (often due to the use of
locales).
+If called as C<sv_vcatpvfn> or flags include C<SV_GMAGIC>, calls get magic.
+
Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
=cut
*/
-
#define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
vecstr = (U8*)SvPV_const(vecsv,veclen);\
vec_utf8 = DO_UTF8(vecsv);
@@ -9985,6 +10238,16 @@
Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
{
+ PERL_ARGS_ASSERT_SV_VCATPVFN;
+
+ sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, SV_GMAGIC|SV_SMAGIC);
+}
+
+void
+Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
+ va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted,
+ const U32 flags)
+{
dVAR;
char *p;
char *q;
@@ -10003,11 +10266,14 @@
/* large enough for "%#.#f" --chip */
/* what about long double NVs? --jhi */
- PERL_ARGS_ASSERT_SV_VCATPVFN;
+ PERL_ARGS_ASSERT_SV_VCATPVFN_FLAGS;
PERL_UNUSED_ARG(maybe_tainted);
+ if (flags & SV_GMAGIC)
+ SvGETMAGIC(sv);
+
/* no matter what, this is a string now */
- (void)SvPV_force(sv, origlen);
+ (void)SvPV_force_nomg(sv, origlen);
/* special-case "", "%s", and "%-p" (SVf - see below) */
if (patlen == 0)
@@ -10015,10 +10281,12 @@
if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
if (args) {
const char * const s = va_arg(*args, char*);
- sv_catpv(sv, s ? s : nullstr);
+ sv_catpv_nomg(sv, s ? s : nullstr);
}
else if (svix < svmax) {
- sv_catsv(sv, *svargs);
+ /* we want get magic on the source but not the target. sv_catsv can't do that, though */
+ SvGETMAGIC(*svargs);
+ sv_catsv_nomg(sv, *svargs);
}
else
S_vcatpvfn_missing_argument(aTHX);
@@ -10027,7 +10295,7 @@
if (args && patlen == 3 && pat[0] == '%' &&
pat[1] == '-' && pat[2] == 'p') {
argsv = MUTABLE_SV(va_arg(*args, void*));
- sv_catsv(sv, argsv);
+ sv_catsv_nomg(sv, argsv);
return;
}
@@ -10050,7 +10318,7 @@
if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
/* 0, point, slack */
Gconvert(nv, (int)digits, 0, ebuf);
- sv_catpv(sv, ebuf);
+ sv_catpv_nomg(sv, ebuf);
if (*ebuf) /* May return an empty string for digits==0 */
return;
}
@@ -10058,7 +10326,7 @@
STRLEN l;
if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
- sv_catpvn(sv, p, l);
+ sv_catpvn_nomg(sv, p, l);
return;
}
}
@@ -10129,9 +10397,9 @@
for (q = p; q < patend && *q != '%'; ++q) ;
if (q > p) {
if (has_utf8 && !pat_utf8)
- sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
+ sv_catpvn_nomg_utf8_upgrade(sv, p, q - p, nsv);
else
- sv_catpvn(sv, p, q - p);
+ sv_catpvn_nomg(sv, p, q - p);
p = q;
}
if (q++ >= patend)
@@ -10163,9 +10431,12 @@
%p include pointer address (standard)
%-p (SVf) include an SV (previously %_)
%-<num>p include an SV with precision <num>
- %<num>p reserved for future extensions
+ %2p include a HEK
+ %3p include a HEK with precision of 256
+ %<num>p (where num != 2 or 3) reserved for future
+ extensions
- Robin Barker 2005-07-14
+ Robin Barker 2005-07-14 (but modified since)
%1p (VDf) removed. RMB 2007-10-19
*/
@@ -10187,6 +10458,14 @@
is_utf8 = TRUE;
goto string;
}
+ else if (n==2 || n==3) { /* HEKf */
+ HEK * const hek = va_arg(*args, HEK *);
+ eptr = HEK_KEY(hek);
+ elen = HEK_LEN(hek);
+ if (HEK_UTF8(hek)) is_utf8 = TRUE;
+ if (n==3) precis = 256, has_precis = TRUE;
+ goto string;
+ }
else if (n) {
Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
"internal %%<num>p might conflict with future printf extensions");
@@ -10339,21 +10618,21 @@
* back into v-string notation and then let the
* vectorize happen normally
*/
- if (sv_derived_from(vecsv, "version")) {
- char *version = savesvpv(vecsv);
+ if (sv_isobject(vecsv) && sv_derived_from(vecsv, "version")) {
if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
- Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_PRINTF),
"vector argument not supported with alpha versions");
- goto unknown;
+ goto vdblank;
}
vecsv = sv_newmortal();
- scan_vstring(version, version + veclen, vecsv);
+ scan_vstring((char *)vecstr, (char *)vecstr + veclen,
+ vecsv);
vecstr = (U8*)SvPV_const(vecsv, veclen);
vec_utf8 = DO_UTF8(vecsv);
- Safefree(version);
}
}
else {
+ vdblank:
vecstr = (U8*)"";
veclen = 0;
}
@@ -10364,7 +10643,7 @@
switch (*q) {
#ifdef WIN32
case 'I': /* Ix, I32x, and I64x */
-# ifdef WIN64
+# ifdef USE_64_BIT_INT
if (q[1] == '6' && q[2] == '4') {
q += 3;
intsize = 'q';
@@ -10375,7 +10654,7 @@
q += 3;
break;
}
-# ifdef WIN64
+# ifdef USE_64_BIT_INT
intsize = 'q';
# endif
q++;
@@ -10482,16 +10761,17 @@
if (DO_UTF8(argsv)) {
STRLEN old_precis = precis;
if (has_precis && precis < elen) {
- STRLEN ulen = sv_len_utf8(argsv);
- I32 p = precis > ulen ? ulen : precis;
- sv_pos_u2b(argsv, &p, 0); /* sticks at end */
- precis = p;
+ STRLEN ulen = sv_or_pv_len_utf8(argsv, eptr, elen);
+ STRLEN p = precis > ulen ? ulen : precis;
+ precis = sv_or_pv_pos_u2b(argsv, eptr, p, 0);
+ /* sticks at end */
}
if (width) { /* fudge width (can't fudge elen) */
if (has_precis && precis < elen)
width += precis - old_precis;
else
- width += elen - sv_len_utf8(argsv);
+ width +=
+ elen - sv_or_pv_len_utf8(argsv,eptr,elen);
}
is_utf8 = TRUE;
}
@@ -10974,7 +11254,7 @@
}
}
else
- sv_setuv_mg(argsv, (UV)i);
+ sv_setuv_mg(argsv, has_utf8 ? (UV)sv_len_utf8(sv) : (UV)i);
continue; /* not "break" */
/* UNKNOWN */
@@ -10994,7 +11274,7 @@
sv_catpvs(msg, "\"%");
for (f = fmtstart; f < fmtend; f++) {
if (isPRINT(*f)) {
- sv_catpvn(msg, f, 1);
+ sv_catpvn_nomg(msg, f, 1);
} else {
Perl_sv_catpvf(aTHX_ msg,
"\\%03"UVof, (UV)*f & 0xFF);
@@ -11045,13 +11325,13 @@
have = esignlen + zeros + elen;
if (have < zeros)
- Perl_croak_nocontext("%s", PL_memory_wrap);
+ Perl_croak_memory_wrap();
need = (have > width ? have : width);
gap = need - have;
if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
- Perl_croak_nocontext("%s", PL_memory_wrap);
+ Perl_croak_memory_wrap();
SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
p = SvEND(sv);
if (esignlen && fill == '0') {
@@ -11112,7 +11392,7 @@
The foo_dup() functions make an exact copy of an existing foo thingy.
During the course of a cloning, a hash table is used to map old addresses
-to new addresses. The table is created and manipulated with the
+to new addresses. The table is created and manipulated with the
ptr_table_* functions.
=cut
@@ -11196,7 +11476,6 @@
parser->multi_open = proto->multi_open;
parser->multi_start = proto->multi_start;
parser->multi_end = proto->multi_end;
- parser->pending_ident = proto->pending_ident;
parser->preambled = proto->preambled;
parser->sublex_info = proto->sublex_info; /* XXX not quite right */
parser->linestr = sv_dup_inc(proto->linestr, param);
@@ -11299,10 +11578,10 @@
#ifdef HAS_FCHDIR
DIR *pwd;
- register const Direntry_t *dirent;
+ const Direntry_t *dirent;
char smallbuf[256];
char *name = NULL;
- STRLEN len = -1;
+ STRLEN len = 0;
long pos;
#endif
@@ -11691,6 +11970,7 @@
{
PERL_ARGS_ASSERT_RVPV_DUP;
+ assert(!isREGEXP(sstr));
if (SvROK(sstr)) {
if (SvWEAKREF(sstr)) {
SvRV_set(dstr, sv_dup(SvRV_const(sstr), param));
@@ -11708,12 +11988,9 @@
if (SvLEN(sstr)) {
/* Normal PV - clone whole allocated space */
SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
- if (SvREADONLY(sstr) && SvFAKE(sstr)) {
- /* Not that normal - actually sstr is copy on write.
- But we are a true, independent SV, so: */
- SvREADONLY_off(dstr);
- SvFAKE_off(dstr);
- }
+ /* sstr may not be that normal, but actually copy on write.
+ But we are a true, independent SV, so: */
+ SvIsCOW_off(dstr);
}
else {
/* Special case - not normally malloced for some reason */
@@ -11720,7 +11997,7 @@
if (isGV_with_GP(sstr)) {
/* Don't need to do anything here. */
}
- else if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
+ else if ((SvIsCOW(sstr))) {
/* A "shared" PV - clone it as "shared" PV */
SvPV_set(dstr,
HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
@@ -11762,7 +12039,7 @@
PERL_ARGS_ASSERT_SV_DUP_COMMON;
- if (SvTYPE(sstr) == SVTYPEMASK) {
+ if (SvTYPE(sstr) == (svtype)SVTYPEMASK) {
#ifdef DEBUG_LEAKING_SCALARS_ABORT
abort();
#endif
@@ -11780,11 +12057,33 @@
const HEK * const hvname = HvNAME_HEK(sstr);
if (hvname) {
/** don't clone stashes if they already exist **/
- dstr = MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0));
+ dstr = MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname),
+ HEK_UTF8(hvname) ? SVf_UTF8 : 0));
ptr_table_store(PL_ptr_table, sstr, dstr);
return dstr;
}
}
+ else if (SvTYPE(sstr) == SVt_PVGV && !SvFAKE(sstr)) {
+ HV *stash = GvSTASH(sstr);
+ const HEK * hvname;
+ if (stash && (hvname = HvNAME_HEK(stash))) {
+ /** don't clone GVs if they already exist **/
+ SV **svp;
+ stash = gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname),
+ HEK_UTF8(hvname) ? SVf_UTF8 : 0);
+ svp = hv_fetch(
+ stash, GvNAME(sstr),
+ GvNAMEUTF8(sstr)
+ ? -GvNAMELEN(sstr)
+ : GvNAMELEN(sstr),
+ 0
+ );
+ if (svp && *svp && SvTYPE(*svp) == SVt_PVGV) {
+ ptr_table_store(PL_ptr_table, sstr, *svp);
+ return *svp;
+ }
+ }
+ }
}
/* create anew and remember what it is */
@@ -11796,7 +12095,7 @@
dstr->sv_debug_inpad = sstr->sv_debug_inpad;
dstr->sv_debug_parent = (SV*)sstr;
FREE_SV_DEBUG_FILE(dstr);
- dstr->sv_debug_file = savepv(sstr->sv_debug_file);
+ dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file);
#endif
ptr_table_store(PL_ptr_table, sstr, dstr);
@@ -11884,6 +12183,7 @@
if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
&& !isGV_with_GP(dstr)
+ && !isREGEXP(dstr)
&& !(sv_type == SVt_PVIO && !(IoFLAGS(dstr) & IOf_FAKE_DIRP)))
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
@@ -11897,8 +12197,9 @@
SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
} else if (SvMAGIC(dstr))
SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
- if (SvSTASH(dstr))
+ if (SvOBJECT(dstr) && SvSTASH(dstr))
SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
+ else SvSTASH_set(dstr, 0); /* don't copy DESTROY cache */
}
/* The cast silences a GCC warning about unhandled types. */
@@ -11912,7 +12213,9 @@
case SVt_PVMG:
break;
case SVt_REGEXP:
+ duprex:
/* FIXME for plugins */
+ dstr->sv_u.svu_rx = ((REGEXP *)dstr)->sv_any;
re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
break;
case SVt_PVLV:
@@ -11923,6 +12226,7 @@
LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param));
else
LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
+ if (isREGEXP(sstr)) goto duprex;
case SVt_PVGV:
/* non-GP case already handled above */
if(isGV_with_GP(sstr)) {
@@ -12021,8 +12325,7 @@
const struct xpvhv_aux * const saux = HvAUX(sstr);
struct xpvhv_aux * const daux = HvAUX(dstr);
/* This flag isn't copied. */
- /* SvOOK_on(hv) attacks the IV flags. */
- SvFLAGS(dstr) |= SVf_OOK;
+ SvOOK_on(dstr);
if (saux->xhv_name_count) {
HEK ** const sname = saux->xhv_name_u.xhvnameu_names;
@@ -12073,6 +12376,7 @@
daux->xhv_mro_meta = saux->xhv_mro_meta
? mro_meta_dup(saux->xhv_mro_meta, param)
: 0;
+ daux->xhv_super = NULL;
/* Record stashes for possible cloning in Perl_clone(). */
if (HvNAME(sstr))
@@ -12097,14 +12401,20 @@
OP_REFCNT_LOCK;
CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
OP_REFCNT_UNLOCK;
- CvFILE(dstr) = SAVEPV(CvFILE(dstr));
+ CvSLABBED_off(dstr);
} else if (CvCONST(dstr)) {
CvXSUBANY(dstr).any_ptr =
sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param);
}
+ assert(!CvSLABBED(dstr));
+ if (CvDYNFILE(dstr)) CvFILE(dstr) = SAVEPV(CvFILE(dstr));
+ if (CvNAMED(dstr))
+ SvANY((CV *)dstr)->xcv_gv_u.xcv_hek =
+ share_hek_hek(CvNAME_HEK((CV *)sstr));
/* don't dup if copying back - CvGV isn't refcounted, so the
* duped GV may never be freed. A bit of a hack! DAPM */
- SvANY(MUTABLE_CV(dstr))->xcv_gv =
+ else
+ SvANY(MUTABLE_CV(dstr))->xcv_gv_u.xcv_gv =
CvCVGV_RC(dstr)
? gv_dup_inc(CvGV(sstr), param)
: (param->flags & CLONEf_JOIN_IN)
@@ -12121,9 +12431,6 @@
}
}
- if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
- ++PL_sv_objcount;
-
return dstr;
}
@@ -12190,6 +12497,7 @@
Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
}
else {
+ ncx->blk_oldcop = (COP*)any_dup(ncx->blk_oldcop, param->proto_perl);
switch (CxTYPE(ncx)) {
case CXt_SUB:
ncx->blk_sub.cv = (ncx->blk_sub.olddepth == 0
@@ -12208,6 +12516,7 @@
ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,
param);
ncx->blk_eval.cur_text = sv_dup(ncx->blk_eval.cur_text, param);
+ ncx->blk_eval.cv = cv_dup(ncx->blk_eval.cv, param);
break;
case CXt_LOOP_LAZYSV:
ncx->blk_loop.state_u.lazysv.end
@@ -12241,6 +12550,8 @@
break;
case CXt_BLOCK:
case CXt_NULL:
+ case CXt_WHEN:
+ case CXt_GIVEN:
break;
}
}
@@ -12368,6 +12679,7 @@
TOPUV(nss,ix) = uv;
switch (type) {
case SAVEt_CLEARSV:
+ case SAVEt_CLEARPADRANGE:
break;
case SAVEt_HELEM: /* hash element */
sv = (const SV *)POPPTR(ss,ix);
@@ -12397,6 +12709,14 @@
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
break;
+ case SAVEt_GVSLOT: /* any slot in GV */
+ sv = (const SV *)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = sv_dup_inc(sv, param);
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
+ sv = (const SV *)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = sv_dup_inc(sv, param);
+ break;
case SAVEt_HV: /* hash reference */
case SAVEt_AV: /* array reference */
sv = (const SV *) POPPTR(ss,ix);
@@ -12420,7 +12740,6 @@
TOPLONG(nss,ix) = longval;
break;
case SAVEt_I32: /* I32 reference */
- case SAVEt_COP_ARYBASE: /* call CopARYBASE_set */
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
i = POPINT(ss,ix);
@@ -12583,33 +12902,9 @@
new_state->re_state_bostr
= pv_dup(old_state->re_state_bostr);
- new_state->re_state_reginput
- = pv_dup(old_state->re_state_reginput);
new_state->re_state_regeol
= pv_dup(old_state->re_state_regeol);
- new_state->re_state_regoffs
- = (regexp_paren_pair*)
- any_dup(old_state->re_state_regoffs, proto_perl);
- new_state->re_state_reglastparen
- = (U32*) any_dup(old_state->re_state_reglastparen,
- proto_perl);
- new_state->re_state_reglastcloseparen
- = (U32*)any_dup(old_state->re_state_reglastcloseparen,
- proto_perl);
- /* XXX This just has to be broken. The old save_re_context
- code did SAVEGENERICPV(PL_reg_start_tmp);
- PL_reg_start_tmp is char **.
- Look above to what the dup code does for
- SAVEt_GENERIC_PVREF
- It can never have worked.
- So this is merely a faithful copy of the exiting bug: */
- new_state->re_state_reg_start_tmp
- = (char **) pv_dup((char *)
- old_state->re_state_reg_start_tmp);
- /* I assume that it only ever "worked" because no-one called
- (pseudo)fork while the regexp engine had re-entered itself.
- */
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
new_state->re_state_nrs
= sv_dup(old_state->re_state_nrs, param);
#endif
@@ -12696,19 +12991,19 @@
The pseudo-fork code uses COPY_STACKS while the
threads->create doesn't.
-CLONEf_KEEP_PTR_TABLE
+CLONEf_KEEP_PTR_TABLE -
perl_clone keeps a ptr_table with the pointer of the old
variable as a key and the new variable as a value,
this allows it to check if something has been cloned and not
clone it again but rather just use the value and increase the
-refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
+refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
the ptr_table using the function
C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
reason to keep it around is if you want to dup some of your own
variable who are outside the graph perl scans, example of this
-code is in threads.xs create
+code is in threads.xs create.
-CLONEf_CLONE_HOST
+CLONEf_CLONE_HOST -
This is a win32 thing, it is ignored on unix, it tells perls
win32host code (which is c++) to clone itself, this is needed on
win32 if you want to run two threads at the same time,
@@ -12785,6 +13080,7 @@
PoisonNew(my_perl, 1, PerlInterpreter);
PL_op = NULL;
PL_curcop = NULL;
+ PL_defstash = NULL; /* may be used by perl malloc() */
PL_markstack = 0;
PL_scopestack = 0;
PL_scopestack_name = 0;
@@ -12814,6 +13110,7 @@
PL_Proc = ipP;
#endif /* PERL_IMPLICIT_SYS */
+
param->flags = flags;
/* Nothing in the core code uses this, but we make it available to
extensions (using mg_dup). */
@@ -12823,6 +13120,7 @@
param->new_perl = my_perl;
param->unreferenced = NULL;
+
INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
PL_body_arenas = NULL;
@@ -12829,15 +13127,237 @@
Zero(&PL_body_roots, 1, PL_body_roots);
PL_sv_count = 0;
- PL_sv_objcount = 0;
PL_sv_root = NULL;
PL_sv_arenaroot = NULL;
PL_debug = proto_perl->Idebug;
- PL_hash_seed = proto_perl->Ihash_seed;
- PL_rehash_seed = proto_perl->Irehash_seed;
+ /* dbargs array probably holds garbage */
+ PL_dbargs = NULL;
+ PL_compiling = proto_perl->Icompiling;
+
+ /* pseudo environmental stuff */
+ PL_origargc = proto_perl->Iorigargc;
+ PL_origargv = proto_perl->Iorigargv;
+
+#if !NO_TAINT_SUPPORT
+ /* Set tainting stuff before PerlIO_debug can possibly get called */
+ PL_tainting = proto_perl->Itainting;
+ PL_taint_warn = proto_perl->Itaint_warn;
+#else
+ PL_tainting = FALSE;
+ PL_taint_warn = FALSE;
+#endif
+
+ PL_minus_c = proto_perl->Iminus_c;
+
+ PL_localpatches = proto_perl->Ilocalpatches;
+ PL_splitstr = proto_perl->Isplitstr;
+ PL_minus_n = proto_perl->Iminus_n;
+ PL_minus_p = proto_perl->Iminus_p;
+ PL_minus_l = proto_perl->Iminus_l;
+ PL_minus_a = proto_perl->Iminus_a;
+ PL_minus_E = proto_perl->Iminus_E;
+ PL_minus_F = proto_perl->Iminus_F;
+ PL_doswitches = proto_perl->Idoswitches;
+ PL_dowarn = proto_perl->Idowarn;
+#ifdef PERL_SAWAMPERSAND
+ PL_sawampersand = proto_perl->Isawampersand;
+#endif
+ PL_unsafe = proto_perl->Iunsafe;
+ PL_perldb = proto_perl->Iperldb;
+ PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
+ PL_exit_flags = proto_perl->Iexit_flags;
+
+ /* XXX time(&PL_basetime) when asked for? */
+ PL_basetime = proto_perl->Ibasetime;
+
+ PL_maxsysfd = proto_perl->Imaxsysfd;
+ PL_statusvalue = proto_perl->Istatusvalue;
+#ifdef VMS
+ PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
+#else
+ PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
+#endif
+
+ /* RE engine related */
+ Zero(&PL_reg_state, 1, struct re_save_state);
+ PL_regmatch_slab = NULL;
+
+ PL_sub_generation = proto_perl->Isub_generation;
+
+ /* funky return mechanisms */
+ PL_forkprocess = proto_perl->Iforkprocess;
+
+ /* internal state */
+ PL_maxo = proto_perl->Imaxo;
+
+ PL_main_start = proto_perl->Imain_start;
+ PL_eval_root = proto_perl->Ieval_root;
+ PL_eval_start = proto_perl->Ieval_start;
+
+ PL_filemode = proto_perl->Ifilemode;
+ PL_lastfd = proto_perl->Ilastfd;
+ PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
+ PL_Argv = NULL;
+ PL_Cmd = NULL;
+ PL_gensym = proto_perl->Igensym;
+
+ PL_laststatval = proto_perl->Ilaststatval;
+ PL_laststype = proto_perl->Ilaststype;
+ PL_mess_sv = NULL;
+
+ PL_profiledata = NULL;
+
+ PL_generation = proto_perl->Igeneration;
+
+ PL_in_clean_objs = proto_perl->Iin_clean_objs;
+ PL_in_clean_all = proto_perl->Iin_clean_all;
+
+ PL_delaymagic_uid = proto_perl->Idelaymagic_uid;
+ PL_delaymagic_euid = proto_perl->Idelaymagic_euid;
+ PL_delaymagic_gid = proto_perl->Idelaymagic_gid;
+ PL_delaymagic_egid = proto_perl->Idelaymagic_egid;
+ PL_nomemok = proto_perl->Inomemok;
+ PL_an = proto_perl->Ian;
+ PL_evalseq = proto_perl->Ievalseq;
+ PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
+ PL_origalen = proto_perl->Iorigalen;
+
+ PL_sighandlerp = proto_perl->Isighandlerp;
+
+ PL_runops = proto_perl->Irunops;
+
+ PL_subline = proto_perl->Isubline;
+
+#ifdef FCRYPT
+ PL_cryptseen = proto_perl->Icryptseen;
+#endif
+
+ PL_hints = proto_perl->Ihints;
+
+#ifdef USE_LOCALE_COLLATE
+ PL_collation_ix = proto_perl->Icollation_ix;
+ PL_collation_standard = proto_perl->Icollation_standard;
+ PL_collxfrm_base = proto_perl->Icollxfrm_base;
+ PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
+#endif /* USE_LOCALE_COLLATE */
+
+#ifdef USE_LOCALE_NUMERIC
+ PL_numeric_standard = proto_perl->Inumeric_standard;
+ PL_numeric_local = proto_perl->Inumeric_local;
+#endif /* !USE_LOCALE_NUMERIC */
+
+ /* Did the locale setup indicate UTF-8? */
+ PL_utf8locale = proto_perl->Iutf8locale;
+ /* Unicode features (see perlrun/-C) */
+ PL_unicode = proto_perl->Iunicode;
+
+ /* Pre-5.8 signals control */
+ PL_signals = proto_perl->Isignals;
+
+ /* times() ticks per second */
+ PL_clocktick = proto_perl->Iclocktick;
+
+ /* Recursion stopper for PerlIO_find_layer */
+ PL_in_load_module = proto_perl->Iin_load_module;
+
+ /* sort() routine */
+ PL_sort_RealCmp = proto_perl->Isort_RealCmp;
+
+ /* Not really needed/useful since the reenrant_retint is "volatile",
+ * but do it for consistency's sake. */
+ PL_reentrant_retint = proto_perl->Ireentrant_retint;
+
+ /* Hooks to shared SVs and locks. */
+ PL_sharehook = proto_perl->Isharehook;
+ PL_lockhook = proto_perl->Ilockhook;
+ PL_unlockhook = proto_perl->Iunlockhook;
+ PL_threadhook = proto_perl->Ithreadhook;
+ PL_destroyhook = proto_perl->Idestroyhook;
+ PL_signalhook = proto_perl->Isignalhook;
+
+ PL_globhook = proto_perl->Iglobhook;
+
+ /* swatch cache */
+ PL_last_swash_hv = NULL; /* reinits on demand */
+ PL_last_swash_klen = 0;
+ PL_last_swash_key[0]= '\0';
+ PL_last_swash_tmps = (U8*)NULL;
+ PL_last_swash_slen = 0;
+
+ PL_srand_called = proto_perl->Isrand_called;
+
+ if (flags & CLONEf_COPY_STACKS) {
+ /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
+ PL_tmps_ix = proto_perl->Itmps_ix;
+ PL_tmps_max = proto_perl->Itmps_max;
+ PL_tmps_floor = proto_perl->Itmps_floor;
+
+ /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
+ * NOTE: unlike the others! */
+ PL_scopestack_ix = proto_perl->Iscopestack_ix;
+ PL_scopestack_max = proto_perl->Iscopestack_max;
+
+ /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
+ * NOTE: unlike the others! */
+ PL_savestack_ix = proto_perl->Isavestack_ix;
+ PL_savestack_max = proto_perl->Isavestack_max;
+ }
+
+ PL_start_env = proto_perl->Istart_env; /* XXXXXX */
+ PL_top_env = &PL_start_env;
+
+ PL_op = proto_perl->Iop;
+
+ PL_Sv = NULL;
+ PL_Xpv = (XPV*)NULL;
+ my_perl->Ina = proto_perl->Ina;
+
+ PL_statbuf = proto_perl->Istatbuf;
+ PL_statcache = proto_perl->Istatcache;
+
+#ifdef HAS_TIMES
+ PL_timesbuf = proto_perl->Itimesbuf;
+#endif
+
+#if !NO_TAINT_SUPPORT
+ PL_tainted = proto_perl->Itainted;
+#else
+ PL_tainted = FALSE;
+#endif
+ PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */
+
+ PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */
+
+ PL_restartjmpenv = proto_perl->Irestartjmpenv;
+ PL_restartop = proto_perl->Irestartop;
+ PL_in_eval = proto_perl->Iin_eval;
+ PL_delaymagic = proto_perl->Idelaymagic;
+ PL_phase = proto_perl->Iphase;
+ PL_localizing = proto_perl->Ilocalizing;
+
+ PL_hv_fetch_ent_mh = NULL;
+ PL_modcount = proto_perl->Imodcount;
+ PL_lastgotoprobe = NULL;
+ PL_dumpindent = proto_perl->Idumpindent;
+
+ PL_efloatbuf = NULL; /* reinits on demand */
+ PL_efloatsize = 0; /* reinits on demand */
+
+ /* regex stuff */
+
+ PL_regdummy = proto_perl->Iregdummy;
+ PL_colorset = 0; /* reinits PL_colors[] */
+ /*PL_colors[6] = {0,0,0,0,0,0};*/
+
+ /* Pluggable optimizer */
+ PL_peepp = proto_perl->Ipeepp;
+ PL_rpeepp = proto_perl->Irpeepp;
+ /* op_free() hook */
+ PL_opfreehook = proto_perl->Iopfreehook;
+
#ifdef USE_REENTRANT_API
/* XXX: things like -Dm will segfault here in perlio, but doing
* PERL_SET_CONTEXT(proto_perl);
@@ -12850,36 +13370,11 @@
PL_ptr_table = ptr_table_new();
/* initialize these special pointers as early as possible */
- SvANY(&PL_sv_undef) = NULL;
- SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
- SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
+ init_constants();
ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
-
- SvANY(&PL_sv_no) = new_XPVNV();
- SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
- SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
- |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
- SvPV_set(&PL_sv_no, savepvn(PL_No, 0));
- SvCUR_set(&PL_sv_no, 0);
- SvLEN_set(&PL_sv_no, 1);
- SvIV_set(&PL_sv_no, 0);
- SvNV_set(&PL_sv_no, 0);
ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
-
- SvANY(&PL_sv_yes) = new_XPVNV();
- SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
- SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
- |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
- SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1));
- SvCUR_set(&PL_sv_yes, 1);
- SvLEN_set(&PL_sv_yes, 2);
- SvIV_set(&PL_sv_yes, 1);
- SvNV_set(&PL_sv_yes, 1);
ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
- /* dbargs array probably holds garbage */
- PL_dbargs = NULL;
-
/* create (a non-shared!) shared string table */
PL_strtab = newHV();
HvSHAREKEYS_off(PL_strtab);
@@ -12886,12 +13381,7 @@
hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
- PL_compiling = proto_perl->Icompiling;
-
- /* These two PVs will be free'd special way so must set them same way op.c does */
- PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
- ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
-
+ /* This PV will be free'd special way so must set it same way op.c does */
PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
@@ -12899,15 +13389,7 @@
PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
CopHINTHASH_set(&PL_compiling, cophh_copy(CopHINTHASH_get(&PL_compiling)));
PL_curcop = (COP*)any_dup(proto_perl->Icurcop, proto_perl);
-#ifdef PERL_DEBUG_READONLY_OPS
- PL_slabs = NULL;
- PL_slab_count = 0;
-#endif
- /* pseudo environmental stuff */
- PL_origargc = proto_perl->Iorigargc;
- PL_origargv = proto_perl->Iorigargv;
-
param->stashes = newAV(); /* Setup array of objects to call clone on */
/* This makes no difference to the implementation, as it always pushes
and shifts pointers to other SVs without changing their reference
@@ -12921,10 +13403,6 @@
param->unreferenced = newAV();
}
- /* Set tainting stuff before PerlIO_debug can possibly get called */
- PL_tainting = proto_perl->Itainting;
- PL_taint_warn = proto_perl->Itaint_warn;
-
#ifdef PERLIO_LAYERS
/* Clone PerlIO tables as soon as we can handle general xx_dup() */
PerlIO_clone(aTHX_ proto_perl, param);
@@ -12938,39 +13416,13 @@
PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
/* switches */
- PL_minus_c = proto_perl->Iminus_c;
PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
PL_apiversion = sv_dup_inc(proto_perl->Iapiversion, param);
- PL_localpatches = proto_perl->Ilocalpatches;
- PL_splitstr = proto_perl->Isplitstr;
- PL_minus_n = proto_perl->Iminus_n;
- PL_minus_p = proto_perl->Iminus_p;
- PL_minus_l = proto_perl->Iminus_l;
- PL_minus_a = proto_perl->Iminus_a;
- PL_minus_E = proto_perl->Iminus_E;
- PL_minus_F = proto_perl->Iminus_F;
- PL_doswitches = proto_perl->Idoswitches;
- PL_dowarn = proto_perl->Idowarn;
- PL_sawampersand = proto_perl->Isawampersand;
- PL_unsafe = proto_perl->Iunsafe;
PL_inplace = SAVEPV(proto_perl->Iinplace);
PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
- PL_perldb = proto_perl->Iperldb;
- PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
- PL_exit_flags = proto_perl->Iexit_flags;
/* magical thingies */
- /* XXX time(&PL_basetime) when asked for? */
- PL_basetime = proto_perl->Ibasetime;
- PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
- PL_maxsysfd = proto_perl->Imaxsysfd;
- PL_statusvalue = proto_perl->Istatusvalue;
-#ifdef VMS
- PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
-#else
- PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
-#endif
PL_encoding = sv_dup(proto_perl->Iencoding, param);
sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */
@@ -12978,11 +13430,6 @@
sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */
- /* RE engine related */
- Zero(&PL_reg_state, 1, struct re_save_state);
- PL_reginterp_cnt = 0;
- PL_regmatch_slab = NULL;
-
/* Clone the regex array */
/* ORANGE FIXME for plugins, probably in the SV dup code.
newSViv(PTR2IV(CALLREGDUPE(
@@ -12991,6 +13438,15 @@
PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
PL_regex_pad = AvARRAY(PL_regex_padav);
+ PL_stashpadmax = proto_perl->Istashpadmax;
+ PL_stashpadix = proto_perl->Istashpadix ;
+ Newx(PL_stashpad, PL_stashpadmax, HV *);
+ {
+ PADOFFSET o = 0;
+ for (; o < PL_stashpadmax; ++o)
+ PL_stashpad[o] = hv_dup(proto_perl->Istashpad[o], param);
+ }
+
/* shortcuts to various I/O objects */
PL_ofsgv = gv_dup_inc(proto_perl->Iofsgv, param);
PL_stdingv = gv_dup(proto_perl->Istdingv, param);
@@ -13016,7 +13472,7 @@
/* symbol tables */
PL_defstash = hv_dup_inc(proto_perl->Idefstash, param);
- PL_curstash = hv_dup(proto_perl->Icurstash, param);
+ PL_curstash = hv_dup_inc(proto_perl->Icurstash, param);
PL_debstash = hv_dup(proto_perl->Idebstash, param);
PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
@@ -13030,17 +13486,11 @@
PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
PL_initav = av_dup_inc(proto_perl->Iinitav, param);
- PL_sub_generation = proto_perl->Isub_generation;
PL_isarev = hv_dup_inc(proto_perl->Iisarev, param);
- /* funky return mechanisms */
- PL_forkprocess = proto_perl->Iforkprocess;
-
/* subprocess state */
PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
- /* internal state */
- PL_maxo = proto_perl->Imaxo;
if (proto_perl->Iop_mask)
PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
else
@@ -13052,23 +13502,11 @@
OP_REFCNT_LOCK;
PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
OP_REFCNT_UNLOCK;
- PL_main_start = proto_perl->Imain_start;
- PL_eval_root = proto_perl->Ieval_root;
- PL_eval_start = proto_perl->Ieval_start;
/* runtime control stuff */
PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
- PL_filemode = proto_perl->Ifilemode;
- PL_lastfd = proto_perl->Ilastfd;
- PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
- PL_Argv = NULL;
- PL_Cmd = NULL;
- PL_gensym = proto_perl->Igensym;
PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
- PL_laststatval = proto_perl->Ilaststatval;
- PL_laststype = proto_perl->Ilaststype;
- PL_mess_sv = NULL;
PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
@@ -13101,8 +13539,6 @@
PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
PL_custom_ops = hv_dup_inc(proto_perl->Icustom_ops, param);
- PL_profiledata = NULL;
-
PL_compcv = cv_dup(proto_perl->Icompcv, param);
PAD_CLONE_VARS(proto_perl, param);
@@ -13111,30 +13547,12 @@
sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
#endif
- /* more statics moved here */
- PL_generation = proto_perl->Igeneration;
PL_DBcv = cv_dup(proto_perl->IDBcv, param);
- PL_in_clean_objs = proto_perl->Iin_clean_objs;
- PL_in_clean_all = proto_perl->Iin_clean_all;
-
- PL_uid = proto_perl->Iuid;
- PL_euid = proto_perl->Ieuid;
- PL_gid = proto_perl->Igid;
- PL_egid = proto_perl->Iegid;
- PL_nomemok = proto_perl->Inomemok;
- PL_an = proto_perl->Ian;
- PL_evalseq = proto_perl->Ievalseq;
- PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
- PL_origalen = proto_perl->Iorigalen;
#ifdef PERL_USES_PL_PIDSTATUS
PL_pidstatus = newHV(); /* XXX flag for cloning? */
#endif
PL_osname = SAVEPV(proto_perl->Iosname);
- PL_sighandlerp = proto_perl->Isighandlerp;
-
- PL_runops = proto_perl->Irunops;
-
PL_parser = parser_dup(proto_perl->Iparser, param);
/* XXX this only works if the saved cop has already been cloned */
@@ -13144,56 +13562,36 @@
proto_perl);
}
- PL_subline = proto_perl->Isubline;
PL_subname = sv_dup_inc(proto_perl->Isubname, param);
-#ifdef FCRYPT
- PL_cryptseen = proto_perl->Icryptseen;
-#endif
-
- PL_hints = proto_perl->Ihints;
-
- PL_amagic_generation = proto_perl->Iamagic_generation;
-
#ifdef USE_LOCALE_COLLATE
- PL_collation_ix = proto_perl->Icollation_ix;
PL_collation_name = SAVEPV(proto_perl->Icollation_name);
- PL_collation_standard = proto_perl->Icollation_standard;
- PL_collxfrm_base = proto_perl->Icollxfrm_base;
- PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
- PL_numeric_standard = proto_perl->Inumeric_standard;
- PL_numeric_local = proto_perl->Inumeric_local;
PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
#endif /* !USE_LOCALE_NUMERIC */
- /* utf8 character classes */
- PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
- PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
- PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
- PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
- PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
- PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
- PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
- PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
- PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
- PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
- PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
- PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
+ /* Unicode inversion lists */
+ PL_ASCII = sv_dup_inc(proto_perl->IASCII, param);
+ PL_Latin1 = sv_dup_inc(proto_perl->ILatin1, param);
+
+ PL_NonL1NonFinalFold = sv_dup_inc(proto_perl->INonL1NonFinalFold, param);
+ PL_HasMultiCharFold= sv_dup_inc(proto_perl->IHasMultiCharFold, param);
+
+ /* utf8 character class swashes */
+ for (i = 0; i < POSIX_SWASH_COUNT; i++) {
+ PL_utf8_swash_ptrs[i] = sv_dup_inc(proto_perl->Iutf8_swash_ptrs[i], param);
+ }
+ for (i = 0; i < POSIX_CC_COUNT; i++) {
+ PL_Posix_ptrs[i] = sv_dup_inc(proto_perl->IPosix_ptrs[i], param);
+ PL_L1Posix_ptrs[i] = sv_dup_inc(proto_perl->IL1Posix_ptrs[i], param);
+ PL_XPosix_ptrs[i] = sv_dup_inc(proto_perl->IXPosix_ptrs[i], param);
+ }
PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
- PL_utf8_X_begin = sv_dup_inc(proto_perl->Iutf8_X_begin, param);
+ PL_utf8_X_regular_begin = sv_dup_inc(proto_perl->Iutf8_X_regular_begin, param);
PL_utf8_X_extend = sv_dup_inc(proto_perl->Iutf8_X_extend, param);
- PL_utf8_X_prepend = sv_dup_inc(proto_perl->Iutf8_X_prepend, param);
- PL_utf8_X_non_hangul = sv_dup_inc(proto_perl->Iutf8_X_non_hangul, param);
- PL_utf8_X_L = sv_dup_inc(proto_perl->Iutf8_X_L, param);
- PL_utf8_X_LV = sv_dup_inc(proto_perl->Iutf8_X_LV, param);
- PL_utf8_X_LVT = sv_dup_inc(proto_perl->Iutf8_X_LVT, param);
- PL_utf8_X_T = sv_dup_inc(proto_perl->Iutf8_X_T, param);
- PL_utf8_X_V = sv_dup_inc(proto_perl->Iutf8_X_V, param);
- PL_utf8_X_LV_LVT_V = sv_dup_inc(proto_perl->Iutf8_X_LV_LVT_V, param);
PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
@@ -13200,53 +13598,17 @@
PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
PL_utf8_xidstart = sv_dup_inc(proto_perl->Iutf8_xidstart, param);
+ PL_utf8_perl_idstart = sv_dup_inc(proto_perl->Iutf8_perl_idstart, param);
+ PL_utf8_perl_idcont = sv_dup_inc(proto_perl->Iutf8_perl_idcont, param);
PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
PL_utf8_xidcont = sv_dup_inc(proto_perl->Iutf8_xidcont, param);
- PL_utf8_foldable = hv_dup_inc(proto_perl->Iutf8_foldable, param);
+ PL_utf8_foldable = sv_dup_inc(proto_perl->Iutf8_foldable, param);
+ PL_utf8_charname_begin = sv_dup_inc(proto_perl->Iutf8_charname_begin, param);
+ PL_utf8_charname_continue = sv_dup_inc(proto_perl->Iutf8_charname_continue, param);
+ PL_ASCII = sv_dup_inc(proto_perl->IASCII, param);
+ PL_AboveLatin1 = sv_dup_inc(proto_perl->IAboveLatin1, param);
+ PL_Latin1 = sv_dup_inc(proto_perl->ILatin1, param);
- /* Did the locale setup indicate UTF-8? */
- PL_utf8locale = proto_perl->Iutf8locale;
- /* Unicode features (see perlrun/-C) */
- PL_unicode = proto_perl->Iunicode;
-
- /* Pre-5.8 signals control */
- PL_signals = proto_perl->Isignals;
-
- /* times() ticks per second */
- PL_clocktick = proto_perl->Iclocktick;
-
- /* Recursion stopper for PerlIO_find_layer */
- PL_in_load_module = proto_perl->Iin_load_module;
-
- /* sort() routine */
- PL_sort_RealCmp = proto_perl->Isort_RealCmp;
-
- /* Not really needed/useful since the reenrant_retint is "volatile",
- * but do it for consistency's sake. */
- PL_reentrant_retint = proto_perl->Ireentrant_retint;
-
- /* Hooks to shared SVs and locks. */
- PL_sharehook = proto_perl->Isharehook;
- PL_lockhook = proto_perl->Ilockhook;
- PL_unlockhook = proto_perl->Iunlockhook;
- PL_threadhook = proto_perl->Ithreadhook;
- PL_destroyhook = proto_perl->Idestroyhook;
- PL_signalhook = proto_perl->Isignalhook;
-
-#ifdef THREADS_HAVE_PIDS
- PL_ppid = proto_perl->Ippid;
-#endif
-
- /* swatch cache */
- PL_last_swash_hv = NULL; /* reinits on demand */
- PL_last_swash_klen = 0;
- PL_last_swash_key[0]= '\0';
- PL_last_swash_tmps = (U8*)NULL;
- PL_last_swash_slen = 0;
-
- PL_glob_index = proto_perl->Iglob_index;
- PL_srand_called = proto_perl->Isrand_called;
-
if (proto_perl->Ipsig_pend) {
Newxz(PL_psig_pend, SIG_SIZE, int);
}
@@ -13265,13 +13627,7 @@
PL_psig_name = (SV**)NULL;
}
- /* intrpvar.h stuff */
-
if (flags & CLONEf_COPY_STACKS) {
- /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
- PL_tmps_ix = proto_perl->Itmps_ix;
- PL_tmps_max = proto_perl->Itmps_max;
- PL_tmps_floor = proto_perl->Itmps_floor;
Newx(PL_tmps_stack, PL_tmps_max, SV*);
sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack,
PL_tmps_ix+1, param);
@@ -13288,8 +13644,6 @@
/* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
* NOTE: unlike the others! */
- PL_scopestack_ix = proto_perl->Iscopestack_ix;
- PL_scopestack_max = proto_perl->Iscopestack_max;
Newxz(PL_scopestack, PL_scopestack_max, I32);
Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32);
@@ -13297,6 +13651,11 @@
Newxz(PL_scopestack_name, PL_scopestack_max, const char *);
Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *);
#endif
+ /* reset stack AV to correct length before its duped via
+ * PL_curstackinfo */
+ AvFILLp(proto_perl->Icurstack) =
+ proto_perl->Istack_sp - proto_perl->Istack_base;
+
/* NOTE: si_dup() looks at PL_markstack */
PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param);
@@ -13310,10 +13669,6 @@
- proto_perl->Istack_base);
PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
- /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
- * NOTE: unlike the others! */
- PL_savestack_ix = proto_perl->Isavestack_ix;
- PL_savestack_max = proto_perl->Isavestack_max;
/*Newxz(PL_savestack, PL_savestack_max, ANY);*/
PL_savestack = ss_dup(proto_perl, param);
}
@@ -13322,73 +13677,23 @@
ENTER; /* perl_destruct() wants to LEAVE; */
}
- PL_start_env = proto_perl->Istart_env; /* XXXXXX */
- PL_top_env = &PL_start_env;
-
- PL_op = proto_perl->Iop;
-
- PL_Sv = NULL;
- PL_Xpv = (XPV*)NULL;
- my_perl->Ina = proto_perl->Ina;
-
- PL_statbuf = proto_perl->Istatbuf;
- PL_statcache = proto_perl->Istatcache;
PL_statgv = gv_dup(proto_perl->Istatgv, param);
PL_statname = sv_dup_inc(proto_perl->Istatname, param);
-#ifdef HAS_TIMES
- PL_timesbuf = proto_perl->Itimesbuf;
-#endif
- PL_tainted = proto_perl->Itainted;
- PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */
PL_rs = sv_dup_inc(proto_perl->Irs, param);
PL_last_in_gv = gv_dup(proto_perl->Ilast_in_gv, param);
PL_defoutgv = gv_dup_inc(proto_perl->Idefoutgv, param);
- PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */
PL_toptarget = sv_dup_inc(proto_perl->Itoptarget, param);
PL_bodytarget = sv_dup_inc(proto_perl->Ibodytarget, param);
PL_formtarget = sv_dup(proto_perl->Iformtarget, param);
- PL_restartjmpenv = proto_perl->Irestartjmpenv;
- PL_restartop = proto_perl->Irestartop;
- PL_in_eval = proto_perl->Iin_eval;
- PL_delaymagic = proto_perl->Idelaymagic;
- PL_phase = proto_perl->Iphase;
- PL_localizing = proto_perl->Ilocalizing;
-
PL_errors = sv_dup_inc(proto_perl->Ierrors, param);
- PL_hv_fetch_ent_mh = NULL;
- PL_modcount = proto_perl->Imodcount;
- PL_lastgotoprobe = NULL;
- PL_dumpindent = proto_perl->Idumpindent;
PL_sortcop = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
PL_sortstash = hv_dup(proto_perl->Isortstash, param);
PL_firstgv = gv_dup(proto_perl->Ifirstgv, param);
PL_secondgv = gv_dup(proto_perl->Isecondgv, param);
- PL_efloatbuf = NULL; /* reinits on demand */
- PL_efloatsize = 0; /* reinits on demand */
- /* regex stuff */
-
- PL_screamfirst = NULL;
- PL_screamnext = NULL;
- PL_maxscream = -1; /* reinits on demand */
- PL_lastscream = NULL;
-
-
- PL_regdummy = proto_perl->Iregdummy;
- PL_colorset = 0; /* reinits PL_colors[] */
- /*PL_colors[6] = {0,0,0,0,0,0};*/
-
-
-
- /* Pluggable optimizer */
- PL_peepp = proto_perl->Ipeepp;
- PL_rpeepp = proto_perl->Irpeepp;
- /* op_free() hook */
- PL_opfreehook = proto_perl->Iopfreehook;
-
PL_stashcache = newHV();
PL_watchaddr = (char **) ptr_table_fetch(PL_ptr_table,
@@ -13485,7 +13790,7 @@
} while (++svp <= last);
AvREAL_off(unreferenced);
}
- SvREFCNT_dec(unreferenced);
+ SvREFCNT_dec_NN(unreferenced);
}
void
@@ -13549,6 +13854,38 @@
#endif /* USE_ITHREADS */
+void
+Perl_init_constants(pTHX)
+{
+ SvREFCNT(&PL_sv_undef) = SvREFCNT_IMMORTAL;
+ SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
+ SvANY(&PL_sv_undef) = NULL;
+
+ SvANY(&PL_sv_no) = new_XPVNV();
+ SvREFCNT(&PL_sv_no) = SvREFCNT_IMMORTAL;
+ SvFLAGS(&PL_sv_no) = SVt_PVNV|SVf_READONLY
+ |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
+ |SVp_POK|SVf_POK;
+
+ SvANY(&PL_sv_yes) = new_XPVNV();
+ SvREFCNT(&PL_sv_yes) = SvREFCNT_IMMORTAL;
+ SvFLAGS(&PL_sv_yes) = SVt_PVNV|SVf_READONLY
+ |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
+ |SVp_POK|SVf_POK;
+
+ SvPV_set(&PL_sv_no, (char*)PL_No);
+ SvCUR_set(&PL_sv_no, 0);
+ SvLEN_set(&PL_sv_no, 0);
+ SvIV_set(&PL_sv_no, 0);
+ SvNV_set(&PL_sv_no, 0);
+
+ SvPV_set(&PL_sv_yes, (char*)PL_Yes);
+ SvCUR_set(&PL_sv_yes, 1);
+ SvLEN_set(&PL_sv_yes, 0);
+ SvIV_set(&PL_sv_yes, 1);
+ SvNV_set(&PL_sv_yes, 1);
+}
+
/*
=head1 Unicode Support
@@ -13561,7 +13898,7 @@
If the sv already is UTF-8 (or if it is not POK), or if the encoding
is not a reference, nothing is done to the sv. If the encoding is not
an C<Encode::XS> Encoding object, bad things will happen.
-(See F<lib/encoding.pm> and L<Encode>).
+(See F<lib/encoding.pm> and L<Encode>.)
The PV of the sv is returned.
@@ -13584,8 +13921,8 @@
save_re_context();
PUSHMARK(sp);
EXTEND(SP, 3);
- XPUSHs(encoding);
- XPUSHs(sv);
+ PUSHs(encoding);
+ PUSHs(sv);
/*
NI-S 2002/07/09
Passing sv_yes is wrong - it needs to be or'ed set of constants
@@ -13631,7 +13968,7 @@
from the position which (PV + *offset) pointed to. The dsv will be
concatenated the decoded UTF-8 string from ssv. Decoding will terminate
when the string tstr appears in decoding output or the input ends on
-the PV of the ssv. The value which the offset points will be modified
+the PV of the ssv. The value which the offset points will be modified
to the last input position on the ssv.
Returns TRUE if the terminator was found, else returns FALSE.
@@ -13655,12 +13992,12 @@
save_re_context();
PUSHMARK(sp);
EXTEND(SP, 6);
- XPUSHs(encoding);
- XPUSHs(dsv);
- XPUSHs(ssv);
+ PUSHs(encoding);
+ PUSHs(dsv);
+ PUSHs(ssv);
offsv = newSViv(*offset);
- mXPUSHs(offsv);
- mXPUSHp(tstr, tlen);
+ mPUSHs(offsv);
+ mPUSHp(tstr, tlen);
PUTBACK;
call_method("cat_decode", G_SCALAR);
SPAGAIN;
@@ -13693,7 +14030,7 @@
S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val)
{
dVAR;
- register HE **array;
+ HE **array;
I32 i;
PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT;
@@ -13704,8 +14041,8 @@
array = HvARRAY(hv);
- for (i=HvMAX(hv); i>0; i--) {
- register HE *entry;
+ for (i=HvMAX(hv); i>=0; i--) {
+ HE *entry;
for (entry = array[i]; entry; entry = HeNEXT(entry)) {
if (HeVAL(entry) != val)
continue;
@@ -13747,7 +14084,7 @@
return -1;
}
-/* S_varname(): return the name of a variable, optionally with a subscript.
+/* varname(): return the name of a variable, optionally with a subscript.
* If gv is non-zero, use the name of that global, along with gvtype (one
* of "$", "@", "%"); otherwise use the name of the lexical at pad offset
* targ. Depending on the value of the subscript_type flag, return:
@@ -13758,13 +14095,13 @@
#define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
#define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
-STATIC SV*
-S_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ,
+SV*
+Perl_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ,
const SV *const keyname, I32 aindex, int subscript_type)
{
SV * const name = sv_newmortal();
- if (gv) {
+ if (gv && isGV(gv)) {
char buffer[2];
buffer[0] = gvtype;
buffer[1] = 0;
@@ -13783,15 +14120,17 @@
}
}
else {
- CV * const cv = find_runcv(NULL);
+ CV * const cv = gv ? ((CV *)gv) : find_runcv(NULL);
SV *sv;
AV *av;
+ assert(!cv || SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
+
if (!cv || !CvPADLIST(cv))
return NULL;
- av = MUTABLE_AV((*av_fetch(CvPADLIST(cv), 0, FALSE)));
+ av = *PadlistARRAY(CvPADLIST(cv));
sv = *av_fetch(av, targ, FALSE);
- sv_setpvn(name, SvPV_nolen_const(sv), SvCUR(sv));
+ sv_setsv_flags(name, sv, 0);
}
if (subscript_type == FUV_SUBSCRIPT_HASH) {
@@ -13798,8 +14137,9 @@
SV * const sv = newSV(0);
*SvPVX(name) = '$';
Perl_sv_catpvf(aTHX_ name, "{%s}",
- pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
- SvREFCNT_dec(sv);
+ pv_pretty(sv, SvPVX_const(keyname), SvCUR(keyname), 32, NULL, NULL,
+ PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_UNI_DETECT ));
+ SvREFCNT_dec_NN(sv);
}
else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
*SvPVX(name) = '$';
@@ -13817,12 +14157,12 @@
/*
=for apidoc find_uninit_var
-Find the name of the undefined variable (if any) that caused the operator o
+Find the name of the undefined variable (if any) that caused the operator
to issue a "Use of uninitialized value" warning.
-If match is true, only return a name if it's value matches uninit_sv.
+If match is true, only return a name if its value matches uninit_sv.
So roughly speaking, if a unary operator (such as OP_COS) generates a
warning, then following the direct child of the op may yield an
-OP_PADSV or OP_GV that gives the name of the undefined variable. On the
+OP_PADSV or OP_GV that gives the name of the undefined variable. On the
other hand, with OP_ADD there are two branches to follow, so we only print
the variable name if we get an exact match.
@@ -13854,8 +14194,16 @@
case OP_PADAV:
case OP_PADHV:
{
- const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
- const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
+ const bool pad = ( obase->op_type == OP_PADAV
+ || obase->op_type == OP_PADHV
+ || obase->op_type == OP_PADRANGE
+ );
+
+ const bool hash = ( obase->op_type == OP_PADHV
+ || obase->op_type == OP_RV2HV
+ || (obase->op_type == OP_PADRANGE
+ && SvTYPE(PAD_SVl(obase->op_targ)) == SVt_PVHV)
+ );
I32 index = 0;
SV *keysv = NULL;
int subscript_type = FUV_SUBSCRIPT_WITHIN;
@@ -13872,9 +14220,11 @@
break;
sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv));
}
- else /* @{expr}, %{expr} */
+ else if (obase == PL_op) /* @{expr}, %{expr} */
return find_uninit_var(cUNOPx(obase)->op_first,
uninit_sv, match);
+ else /* @{expr}, %{expr} as a sub-expression */
+ return NULL;
}
/* attempt to find a match within the aggregate */
@@ -13896,6 +14246,19 @@
keysv, index, subscript_type);
}
+ case OP_RV2SV:
+ if (cUNOPx(obase)->op_first->op_type == OP_GV) {
+ /* $global */
+ gv = cGVOPx_gv(cUNOPx(obase)->op_first);
+ if (!gv || !GvSTASH(gv))
+ break;
+ if (match && (GvSV(gv) != uninit_sv))
+ break;
+ return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
+ }
+ /* ${expr} */
+ return find_uninit_var(cUNOPx(obase)->op_first, uninit_sv, 1);
+
case OP_PADSV:
if (match && PAD_SVl(obase->op_targ) != uninit_sv)
break;
@@ -13908,21 +14271,20 @@
break;
return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
+ case OP_AELEMFAST_LEX:
+ if (match) {
+ SV **svp;
+ AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
+ if (!av || SvRMAGICAL(av))
+ break;
+ svp = av_fetch(av, (I32)obase->op_private, FALSE);
+ if (!svp || *svp != uninit_sv)
+ break;
+ }
+ return varname(NULL, '$', obase->op_targ,
+ NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
case OP_AELEMFAST:
- if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
- if (match) {
- SV **svp;
- AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
- if (!av || SvRMAGICAL(av))
- break;
- svp = av_fetch(av, (I32)obase->op_private, FALSE);
- if (!svp || *svp != uninit_sv)
- break;
- }
- return varname(NULL, '$', obase->op_targ,
- NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
- }
- else {
+ {
gv = cGVOPx_gv(obase);
if (!gv)
break;
@@ -13949,6 +14311,9 @@
case OP_AELEM:
case OP_HELEM:
+ {
+ bool negate = FALSE;
+
if (PL_op == obase)
/* $a[uninit_expr] or $h{uninit_expr} */
return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
@@ -13974,18 +14339,32 @@
if (!sv)
break;
+ if (kid && kid->op_type == OP_NEGATE) {
+ negate = TRUE;
+ kid = cUNOPx(kid)->op_first;
+ }
+
if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
/* index is constant */
+ SV* kidsv;
+ if (negate) {
+ kidsv = sv_2mortal(newSVpvs("-"));
+ sv_catsv(kidsv, cSVOPx_sv(kid));
+ }
+ else
+ kidsv = cSVOPx_sv(kid);
if (match) {
if (SvMAGICAL(sv))
break;
if (obase->op_type == OP_HELEM) {
- HE* he = hv_fetch_ent(MUTABLE_HV(sv), cSVOPx_sv(kid), 0, 0);
+ HE* he = hv_fetch_ent(MUTABLE_HV(sv), kidsv, 0, 0);
if (!he || HeVAL(he) != uninit_sv)
break;
}
else {
- SV * const * const svp = av_fetch(MUTABLE_AV(sv), SvIV(cSVOPx_sv(kid)), FALSE);
+ SV * const * const svp = av_fetch(MUTABLE_AV(sv),
+ negate ? - SvIV(cSVOPx_sv(kid)) : SvIV(cSVOPx_sv(kid)),
+ FALSE);
if (!svp || *svp != uninit_sv)
break;
}
@@ -13992,10 +14371,11 @@
}
if (obase->op_type == OP_HELEM)
return varname(gv, '%', o->op_targ,
- cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
+ kidsv, 0, FUV_SUBSCRIPT_HASH);
else
return varname(gv, '@', o->op_targ, NULL,
- SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
+ negate ? - SvIV(cSVOPx_sv(kid)) : SvIV(cSVOPx_sv(kid)),
+ FUV_SUBSCRIPT_ARRAY);
}
else {
/* index is an expression;
@@ -14021,6 +14401,7 @@
o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
}
break;
+ }
case OP_AASSIGN:
/* only examine RHS */
@@ -14028,7 +14409,9 @@
case OP_OPEN:
o = cUNOPx(obase)->op_first;
- if (o->op_type == OP_PUSHMARK)
+ if ( o->op_type == OP_PUSHMARK
+ || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK)
+ )
o = o->op_sibling;
if (!o->op_sibling) {
@@ -14051,6 +14434,7 @@
/* ops where $_ may be an implicit arg */
case OP_TRANS:
+ case OP_TRANSR:
case OP_SUBST:
case OP_MATCH:
if ( !(obase->op_flags & OPf_STACKED)) {
@@ -14071,13 +14455,15 @@
match = 1; /* print etc can return undef on defined args */
/* skip filehandle as it can't produce 'undef' warning */
o = cUNOPx(obase)->op_first;
- if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
+ if ((obase->op_flags & OPf_STACKED)
+ &&
+ ( o->op_type == OP_PUSHMARK
+ || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK)))
o = o->op_sibling->op_sibling;
goto do_op2;
case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */
- case OP_RV2SV:
case OP_CUSTOM: /* XS or custom code could trigger random warnings */
/* the following ops are capable of returning PL_sv_undef even for
@@ -14194,8 +14580,15 @@
if (!o)
break;
- /* if all except one arg are constant, or have no side-effects,
- * or are optimized away, then it's unambiguous */
+ /* This loop checks all the kid ops, skipping any that cannot pos-
+ * sibly be responsible for the uninitialized value; i.e., defined
+ * constants and ops that return nothing. If there is only one op
+ * left that is not skipped, then we *know* it is responsible for
+ * the uninitialized value. If there is more than one op left, we
+ * have to look for an exact match in the while() loop below.
+ * Note that we skip padrange, because the individual pad ops that
+ * it replaced are still in the tree, so we work on them instead.
+ */
o2 = NULL;
for (kid=o; kid; kid = kid->op_sibling) {
if (kid) {
@@ -14203,12 +14596,7 @@
if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
|| (type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
|| (type == OP_PUSHMARK)
- || (
- /* @$a and %$a, but not @a or %a */
- (type == OP_RV2AV || type == OP_RV2HV)
- && cUNOPx(kid)->op_first
- && cUNOPx(kid)->op_first->op_type != OP_GV
- )
+ || (type == OP_PADRANGE)
)
continue;
}
@@ -14237,7 +14625,7 @@
/*
=for apidoc report_uninit
-Print appropriate "Use of uninitialized variable" warning
+Print appropriate "Use of uninitialized variable" warning.
=cut
*/
@@ -14248,13 +14636,14 @@
dVAR;
if (PL_op) {
SV* varname = NULL;
- if (uninit_sv) {
+ if (uninit_sv && PL_curpad) {
varname = find_uninit_var(PL_op, uninit_sv,0);
if (varname)
sv_insert(varname, 0, 0, " ", 1);
}
- Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
- varname ? SvPV_nolen_const(varname) : "",
+ /* diag_listed_as: Use of uninitialized value%s */
+ Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit_sv,
+ SVfARG(varname ? varname : &PL_sv_no),
" in ", OP_DESC(PL_op));
}
else
@@ -14266,8 +14655,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/sv.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.4
\ No newline at end of property
Modified: trunk/contrib/perl/sv.h
===================================================================
--- trunk/contrib/perl/sv.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/sv.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -19,27 +19,102 @@
An enum of flags for Perl types. These are found in the file B<sv.h>
in the C<svtype> enum. Test these flags with the C<SvTYPE> macro.
-=for apidoc AmU||SVt_PV
-Pointer type flag for scalars. See C<svtype>.
+The types are:
+ SVt_NULL
+ SVt_BIND (unused)
+ SVt_IV
+ SVt_NV
+ SVt_RV
+ SVt_PV
+ SVt_PVIV
+ SVt_PVNV
+ SVt_PVMG
+ SVt_REGEXP
+ SVt_PVGV
+ SVt_PVLV
+ SVt_PVAV
+ SVt_PVHV
+ SVt_PVCV
+ SVt_PVFM
+ SVt_PVIO
+
+These are most easily explained from the bottom up.
+
+SVt_PVIO is for I/O objects, SVt_PVFM for formats, SVt_PVCV for
+subroutines, SVt_PVHV for hashes and SVt_PVAV for arrays.
+
+All the others are scalar types, that is, things that can be bound to a
+C<$> variable. For these, the internal types are mostly orthogonal to
+types in the Perl language.
+
+Hence, checking C<< SvTYPE(sv) < SVt_PVAV >> is the best way to see whether
+something is a scalar.
+
+SVt_PVGV represents a typeglob. If !SvFAKE(sv), then it is a real,
+incoercible typeglob. If SvFAKE(sv), then it is a scalar to which a
+typeglob has been assigned. Assigning to it again will stop it from being
+a typeglob. SVt_PVLV represents a scalar that delegates to another scalar
+behind the scenes. It is used, e.g., for the return value of C<substr> and
+for tied hash and array elements. It can hold any scalar value, including
+a typeglob. SVt_REGEXP is for regular expressions.
+
+SVt_PVMG represents a "normal" scalar (not a typeglob, regular expression,
+or delegate). Since most scalars do not need all the internal fields of a
+PVMG, we save memory by allocating smaller structs when possible. All the
+other types are just simpler forms of SVt_PVMG, with fewer internal fields.
+ SVt_NULL can only hold undef. SVt_IV can hold undef, an integer, or a
+reference. (SVt_RV is an alias for SVt_IV, which exists for backward
+compatibility.) SVt_NV can hold any of those or a double. SVt_PV can only
+hold undef or a string. SVt_PVIV is a superset of SVt_PV and SVt_IV.
+SVt_PVNV is similar. SVt_PVMG can hold anything SVt_PVNV can hold, but it
+can, but does not have to, be blessed or magical.
+
+=for apidoc AmU||SVt_NULL
+Type flag for scalars. See L</svtype>.
+
=for apidoc AmU||SVt_IV
-Integer type flag for scalars. See C<svtype>.
+Type flag for scalars. See L</svtype>.
=for apidoc AmU||SVt_NV
-Double type flag for scalars. See C<svtype>.
+Type flag for scalars. See L</svtype>.
+=for apidoc AmU||SVt_PV
+Type flag for scalars. See L</svtype>.
+
+=for apidoc AmU||SVt_PVIV
+Type flag for scalars. See L</svtype>.
+
+=for apidoc AmU||SVt_PVNV
+Type flag for scalars. See L</svtype>.
+
=for apidoc AmU||SVt_PVMG
-Type flag for blessed scalars. See C<svtype>.
+Type flag for scalars. See L</svtype>.
+=for apidoc AmU||SVt_REGEXP
+Type flag for regular expressions. See L</svtype>.
+
+=for apidoc AmU||SVt_PVGV
+Type flag for typeglobs. See L</svtype>.
+
+=for apidoc AmU||SVt_PVLV
+Type flag for scalars. See L</svtype>.
+
=for apidoc AmU||SVt_PVAV
-Type flag for arrays. See C<svtype>.
+Type flag for arrays. See L</svtype>.
=for apidoc AmU||SVt_PVHV
-Type flag for hashes. See C<svtype>.
+Type flag for hashes. See L</svtype>.
=for apidoc AmU||SVt_PVCV
-Type flag for code refs. See C<svtype>.
+Type flag for subroutines. See L</svtype>.
+=for apidoc AmU||SVt_PVFM
+Type flag for formats. See L</svtype>.
+
+=for apidoc AmU||SVt_PVIO
+Type flag for I/O objects. See L</svtype>.
+
=cut
*/
@@ -65,6 +140,11 @@
SVt_LAST /* keep last in enum. used to size arrays */
} svtype;
+/* *** any alterations to the SV types above need to be reflected in
+ * SVt_MASK and the various PL_valid_types_* tables */
+
+#define SVt_MASK 0xf /* smallest bitmask that covers all types */
+
#ifndef PERL_CORE
/* Although Fast Boyer Moore tables are now being stored in PVGVs, for most
purposes eternal code wanting to consider PVBM probably needs to think of
@@ -103,6 +183,7 @@
IV svu_iv; \
UV svu_uv; \
SV* svu_rv; /* pointer to another SV */ \
+ struct regexp* svu_rx; \
SV** svu_array; \
HE** svu_hash; \
GP* svu_gp; \
@@ -163,7 +244,7 @@
Returns the value of the object's reference count.
=for apidoc Am|SV*|SvREFCNT_inc|SV* sv
-Increments the reference count of the given SV.
+Increments the reference count of the given SV, returning the SV.
All of the following SvREFCNT_inc* macros are optimized versions of
SvREFCNT_inc, and can be replaced with SvREFCNT_inc.
@@ -203,8 +284,13 @@
and faster.
=for apidoc Am|void|SvREFCNT_dec|SV* sv
-Decrements the reference count of the given SV.
+Decrements the reference count of the given SV. I<sv> may be NULL.
+=for apidoc Am|void|SvREFCNT_dec_NN|SV* sv
+Same as SvREFCNT_dec, but can only be used if you know I<sv>
+is not NULL. Since we don't have to check the NULLness, it's faster
+and smaller.
+
=for apidoc Am|svtype|SvTYPE|SV* sv
Returns the type of the SV. See C<svtype>.
@@ -219,42 +305,10 @@
#define SvFLAGS(sv) (sv)->sv_flags
#define SvREFCNT(sv) (sv)->sv_refcnt
-#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
-# define SvREFCNT_inc(sv) \
- ({ \
- SV * const _sv = MUTABLE_SV(sv); \
- if (_sv) \
- (SvREFCNT(_sv))++; \
- _sv; \
- })
-# define SvREFCNT_inc_simple(sv) \
- ({ \
- if (sv) \
- (SvREFCNT(sv))++; \
- MUTABLE_SV(sv); \
- })
-# define SvREFCNT_inc_NN(sv) \
- ({ \
- SV * const _sv = MUTABLE_SV(sv); \
- SvREFCNT(_sv)++; \
- _sv; \
- })
-# define SvREFCNT_inc_void(sv) \
- ({ \
- SV * const _sv = MUTABLE_SV(sv); \
- if (_sv) \
- (void)(SvREFCNT(_sv)++); \
- })
-#else
-# define SvREFCNT_inc(sv) \
- ((PL_Sv=MUTABLE_SV(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL)
-# define SvREFCNT_inc_simple(sv) \
- ((sv) ? (SvREFCNT(sv)++,MUTABLE_SV(sv)) : NULL)
-# define SvREFCNT_inc_NN(sv) \
- (PL_Sv=MUTABLE_SV(sv),++(SvREFCNT(PL_Sv)),PL_Sv)
-# define SvREFCNT_inc_void(sv) \
- (void)((PL_Sv=MUTABLE_SV(sv)) ? ++(SvREFCNT(PL_Sv)) : 0)
-#endif
+#define SvREFCNT_inc(sv) S_SvREFCNT_inc(MUTABLE_SV(sv))
+#define SvREFCNT_inc_simple(sv) SvREFCNT_inc(sv)
+#define SvREFCNT_inc_NN(sv) S_SvREFCNT_inc_NN(MUTABLE_SV(sv))
+#define SvREFCNT_inc_void(sv) S_SvREFCNT_inc_void(MUTABLE_SV(sv))
/* These guys don't need the curly blocks */
#define SvREFCNT_inc_simple_void(sv) STMT_START { if (sv) SvREFCNT(sv)++; } STMT_END
@@ -262,22 +316,8 @@
#define SvREFCNT_inc_void_NN(sv) (void)(++SvREFCNT(MUTABLE_SV(sv)))
#define SvREFCNT_inc_simple_void_NN(sv) (void)(++SvREFCNT(MUTABLE_SV(sv)))
-#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
-# define SvREFCNT_dec(sv) \
- ({ \
- SV * const _sv = MUTABLE_SV(sv); \
- if (_sv) { \
- if (SvREFCNT(_sv)) { \
- if (--(SvREFCNT(_sv)) == 0) \
- Perl_sv_free2(aTHX_ _sv); \
- } else { \
- sv_free(_sv); \
- } \
- } \
- })
-#else
-#define SvREFCNT_dec(sv) sv_free(MUTABLE_SV(sv))
-#endif
+#define SvREFCNT_dec(sv) S_SvREFCNT_dec(aTHX_ MUTABLE_SV(sv))
+#define SvREFCNT_dec_NN(sv) S_SvREFCNT_dec_NN(aTHX_ MUTABLE_SV(sv))
#define SVTYPEMASK 0xff
#define SvTYPE(sv) ((svtype)((sv)->sv_flags & SVTYPEMASK))
@@ -287,7 +327,10 @@
them all by using a consistent macro. */
#define SvIS_FREED(sv) ((sv)->sv_flags == SVTYPEMASK)
-#define SvUPGRADE(sv, mt) (SvTYPE(sv) >= (mt) || (sv_upgrade(sv, mt), 1))
+/* this is defined in this peculiar way to avoid compiler warnings.
+ * See the <20121213131428.GD1842 at iabyn.com> thread in p5p */
+#define SvUPGRADE(sv, mt) \
+ ((void)(SvTYPE(sv) >= (mt) || (sv_upgrade(sv, mt),1)))
#define SVf_IOK 0x00000100 /* has valid public integer value */
#define SVf_NOK 0x00000200 /* has valid public numeric value */
@@ -297,17 +340,18 @@
#define SVp_IOK 0x00001000 /* has valid non-public integer value */
#define SVp_NOK 0x00002000 /* has valid non-public numeric value */
#define SVp_POK 0x00004000 /* has valid non-public pointer value */
-#define SVp_SCREAM 0x00008000 /* has been studied? */
+#define SVp_SCREAM 0x00008000 /* method name is DOES */
#define SVphv_CLONEABLE SVp_SCREAM /* PVHV (stashes) clone its objects */
#define SVpgv_GP SVp_SCREAM /* GV has a valid GP */
#define SVprv_PCS_IMPORTED SVp_SCREAM /* RV is a proxy for a constant
subroutine in another package. Set the
- CvIMPORTED_CV_ON() if it needs to be
+ GvIMPORTED_CV_on() if it needs to be
expanded to a real GV */
-
-#define SVs_PADSTALE 0x00010000 /* lexical has gone out of scope */
-#define SVpad_STATE 0x00010000 /* pad name is a "state" var */
-#define SVs_PADTMP 0x00020000 /* in use as tmp */
+#define SVf_IsCOW 0x00010000 /* copy on write (shared hash key if
+ SvLEN == 0) */
+#define SVs_PADTMP 0x00020000 /* in use as tmp; only if ! SVs_PADMY */
+#define SVs_PADSTALE 0x00020000 /* lexical has gone out of scope;
+ only valid for SVs_PADMY */
#define SVpad_TYPED 0x00020000 /* pad name is a Typed Lexical */
#define SVs_PADMY 0x00040000 /* in use a "my" variable */
#define SVpad_OUR 0x00040000 /* pad name is "our" instead of "my" */
@@ -317,20 +361,14 @@
#define SVs_SMG 0x00400000 /* has magical set method */
#define SVs_RMG 0x00800000 /* has random magical methods */
-#define SVf_FAKE 0x01000000 /* 0: glob or lexical is just a copy
+#define SVf_FAKE 0x01000000 /* 0: glob is just a copy
1: SV head arena wasn't malloc()ed
- 2: in conjunction with SVf_READONLY
- marks a shared hash key scalar
- (SvLEN == 0) or a copy on write
- string (SvLEN != 0) [SvIsCOW(sv)]
- 3: For PVCV, whether CvUNIQUE(cv)
+ 2: For PVCV, whether CvUNIQUE(cv)
refers to an eval or once only
[CvEVAL(cv), CvSPECIAL(cv)]
- 4: On a pad name SV, that slot in the
+ 3: On a pad name SV, that slot in the
frame AV is a REFCNT'ed reference
to a lexical from "outside". */
-#define SVphv_REHASH SVf_FAKE /* 5: On a PVHV, hash values are being
- recalculated */
#define SVf_OOK 0x02000000 /* has valid offset value. For a PVHV this
means that a hv_aux struct is present
after the main array */
@@ -343,7 +381,7 @@
-#define SVf_THINKFIRST (SVf_READONLY|SVf_ROK|SVf_FAKE)
+#define SVf_THINKFIRST (SVf_READONLY|SVf_ROK|SVf_FAKE|SVs_RMG|SVf_IsCOW)
#define SVf_OK (SVf_IOK|SVf_NOK|SVf_POK|SVf_ROK| \
SVp_IOK|SVp_NOK|SVp_POK|SVpgv_GP)
@@ -367,8 +405,21 @@
/* PVHV */
#define SVphv_SHAREKEYS 0x20000000 /* PVHV keys live on shared string table */
-/* PVNV, PVMG, presumably only inside pads */
-#define SVpad_NAME 0x40000000 /* This SV is a name in the PAD, so
+
+/* PVNV, PVMG only, and only used in pads. Should be safe to test on any scalar
+ SV, as the core is careful to avoid setting both.
+
+ SVf_POK, SVp_POK also set:
+ 0x00004400 Normal
+ 0x0000C400 method name for DOES (SvSCREAM)
+ 0x40004400 FBM compiled (SvVALID)
+ 0x4000C400 pad name.
+
+ 0x00008000 GV with GP
+ 0x00008800 RV with PCS imported
+*/
+#define SVpad_NAME (SVp_SCREAM|SVpbm_VALID)
+ /* This SV is a name in the PAD, so
SVpad_TYPED, SVpad_OUR and SVpad_STATE
apply */
/* PVAV */
@@ -378,11 +429,10 @@
/* This is only set true on a PVGV when it's playing "PVBM", but is tested for
on any regular scalar (anything <= PVLV) */
#define SVpbm_VALID 0x40000000
-/* ??? */
+/* Only used in toke.c on an SV stored in PL_lex_repl */
#define SVrepl_EVAL 0x40000000 /* Replacement part of s///e */
/* IV, PVIV, PVNV, PVMG, PVGV and (I assume) PVLV */
-/* Presumably IVs aren't stored in pads */
#define SVf_IVisUV 0x80000000 /* use XPVUV instead of XPVIV */
/* PVAV */
#define SVpav_REIFY 0x80000000 /* can become real */
@@ -392,13 +442,20 @@
#define SVpbm_TAIL 0x80000000
/* RV upwards. However, SVf_ROK and SVp_IOK are exclusive */
#define SVprv_WEAKREF 0x80000000 /* Weak reference */
+/* pad name vars only */
+#define SVpad_STATE 0x80000000 /* pad name is a "state" var */
#define _XPV_HEAD \
HV* xmg_stash; /* class package */ \
union _xmgu xmg_u; \
STRLEN xpv_cur; /* length of svu_pv as a C string */ \
- STRLEN xpv_len /* allocated size */
+ union { \
+ STRLEN xpvlenu_len; /* allocated size */ \
+ char * xpvlenu_pv; /* regexp string */ \
+ } xpv_len_u
+#define xpv_len xpv_len_u.xpvlenu_len
+
union _xnvu {
NV xnv_nv; /* numeric value, if any */
HV * xgv_stash;
@@ -407,8 +464,7 @@
U32 xhigh;
} xpad_cop_seq; /* used by pad.c for cop_sequence */
struct {
- U32 xbm_previous; /* how many characters in string before rare? */
- U8 xbm_flags;
+ I32 xbm_useful;
U8 xbm_rare; /* rarest character in string */
} xbm_s; /* fields from PVBM */
};
@@ -416,7 +472,6 @@
union _xivu {
IV xivu_iv; /* integer value */
UV xivu_uv;
- I32 xivu_i32; /* BmUSEFUL */
HEK * xivu_namehek; /* xpvlv, xpvgv: GvNAME */
};
@@ -423,6 +478,7 @@
union _xmgu {
MAGIC* xmg_magic; /* linked list of magicalness */
HV* xmg_ourstash; /* Stash for our (when SvPAD_OUR is true) */
+ STRLEN xmg_hash_index; /* used while freeing hash entries */
};
struct xpv {
@@ -465,6 +521,7 @@
SV* xlv_targ;
char xlv_type; /* k=keys .=pos x=substr v=vec /=join/re
* y=alem/helem/iter t=tie T=tied HE */
+ char xlv_flags; /* 1 = negative offset 2 = negative len */
};
/* This structure works in 3 ways - regular scalar, GV with GP, or fast
@@ -475,8 +532,6 @@
union _xnvu xnv_u;
};
-/* This structure must match XPVCV in cv.h */
-
typedef U16 cv_flags_t;
#define _XPVCV_COMMON \
@@ -489,19 +544,24 @@
OP * xcv_root; \
void (*xcv_xsub) (pTHX_ CV*); \
} xcv_root_u; \
- GV * xcv_gv; \
+ union { \
+ GV * xcv_gv; \
+ HEK * xcv_hek; \
+ } xcv_gv_u; \
char * xcv_file; \
- AV * xcv_padlist; \
+ PADLIST * xcv_padlist; \
CV * xcv_outside; \
U32 xcv_outside_seq; /* the COP sequence (at the point of our \
* compilation) in the lexically enclosing \
* sub */ \
- cv_flags_t xcv_flags
+ cv_flags_t xcv_flags; \
+ I32 xcv_depth /* >= 2 indicates recursive call */
+/* This structure must match XPVCV in cv.h */
+
struct xpvfm {
_XPV_HEAD;
_XPVCV_COMMON;
- IV xfm_lines;
};
@@ -592,13 +652,17 @@
Tells an SV that it is an integer and disables all other OK bits.
=for apidoc Am|void|SvIOK_only_UV|SV* sv
-Tells and SV that it is an unsigned integer and disables all other OK bits.
+Tells an SV that it is an unsigned integer and disables all other OK bits.
=for apidoc Am|bool|SvIOK_UV|SV* sv
-Returns a boolean indicating whether the SV contains an unsigned integer.
+Returns a boolean indicating whether the SV contains an integer that must be
+interpreted as unsigned. A non-negative integer whose value is within the
+range of both an IV and a UV may be be flagged as either SvUOK or SVIOK.
=for apidoc Am|bool|SvUOK|SV* sv
-Returns a boolean indicating whether the SV contains an unsigned integer.
+Returns a boolean indicating whether the SV contains an integer that must be
+interpreted as unsigned. A non-negative integer whose value is within the
+range of both an IV and a UV may be be flagged as either SvUOK or SVIOK.
=for apidoc Am|bool|SvIOK_notUV|SV* sv
Returns a boolean indicating whether the SV contains a signed integer.
@@ -654,20 +718,24 @@
=for apidoc Am|IV|SvIVX|SV* sv
Returns the raw value in the SV's IV slot, without checks or conversions.
-Only use when you are sure SvIOK is true. See also C<SvIV()>.
+Only use when you are sure SvIOK is true. See also C<SvIV()>.
=for apidoc Am|UV|SvUVX|SV* sv
Returns the raw value in the SV's UV slot, without checks or conversions.
-Only use when you are sure SvIOK is true. See also C<SvUV()>.
+Only use when you are sure SvIOK is true. See also C<SvUV()>.
=for apidoc Am|NV|SvNVX|SV* sv
Returns the raw value in the SV's NV slot, without checks or conversions.
-Only use when you are sure SvNOK is true. See also C<SvNV()>.
+Only use when you are sure SvNOK is true. See also C<SvNV()>.
=for apidoc Am|char*|SvPVX|SV* sv
Returns a pointer to the physical string in the SV. The SV must contain a
-string.
+string. Prior to 5.9.3 it is not safe to execute this macro unless the SV's
+type >= SVt_PV.
+This is also used to store the name of an autoloaded subroutine in an XS
+AUTOLOAD routine. See L<perlguts/Autoloading with XSUBs>.
+
=for apidoc Am|STRLEN|SvCUR|SV* sv
Returns the length of the string which is in the SV. See C<SvLEN>.
@@ -676,9 +744,14 @@
attributable to C<SvOOK>. See C<SvCUR>.
=for apidoc Am|char*|SvEND|SV* sv
-Returns a pointer to the last character in the string which is in the SV.
+Returns a pointer to the spot just after the last character in
+the string which is in the SV, where there is usually a trailing
+null (even though Perl scalars do not strictly require it).
See C<SvCUR>. Access the character as *(SvEND(sv)).
+Warning: If C<SvCUR> is equal to C<SvLEN>, then C<SvEND> points to
+unallocated memory.
+
=for apidoc Am|HV*|SvSTASH|SV* sv
Returns the stash of the SV.
@@ -692,8 +765,13 @@
Set the value of the NV pointer in sv to val. See C<SvIV_set>.
=for apidoc Am|void|SvPV_set|SV* sv|char* val
-Set the value of the PV pointer in sv to val. See C<SvIV_set>.
+Set the value of the PV pointer in sv to val. See also C<SvIV_set>.
+Beware that the existing pointer may be involved in copy-on-write or other
+mischief, so do C<SvOOK_off(sv)> and use C<sv_force_normal> or
+C<SvPV_force> (or check the SvIsCOW flag) first to make sure this
+modification is safe.
+
=for apidoc Am|void|SvUV_set|SV* sv|UV val
Set the value of the UV pointer in sv to val. See C<SvIV_set>.
@@ -721,17 +799,10 @@
#define SvNIOK_off(sv) (SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK| \
SVp_IOK|SVp_NOK|SVf_IVisUV))
-#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
-#define assert_not_ROK(sv) ({assert(!SvROK(sv) || !SvRV(sv));}),
-#define assert_not_glob(sv) ({assert(!isGV_with_GP(sv));}),
-#else
-#define assert_not_ROK(sv)
-#define assert_not_glob(sv)
-#endif
+#define assert_not_ROK(sv) assert_(!SvROK(sv) || !SvRV(sv))
+#define assert_not_glob(sv) assert_(!isGV_with_GP(sv))
-#define SvOK(sv) ((SvTYPE(sv) == SVt_BIND) \
- ? (SvFLAGS(SvRV(sv)) & SVf_OK) \
- : (SvFLAGS(sv) & SVf_OK))
+#define SvOK(sv) (SvFLAGS(sv) & SVf_OK || isREGEXP(sv))
#define SvOK_off(sv) (assert_not_ROK(sv) assert_not_glob(sv) \
SvFLAGS(sv) &= ~(SVf_OK| \
SVf_IVisUV|SVf_UTF8), \
@@ -779,9 +850,10 @@
/*
=for apidoc Am|U32|SvUTF8|SV* sv
-Returns a U32 value indicating whether the SV contains UTF-8 encoded data.
-Call this after SvPV() in case any call to string overloading updates the
-internal flag.
+Returns a U32 value indicating the UTF-8 status of an SV. If things are set-up
+properly, this indicates whether or not the SV contains UTF-8 encoded data.
+You should use this I<after> a call to SvPV() or one of its variants, in
+case any call to string overloading updates the internal flag.
=for apidoc Am|void|SvUTF8_on|SV *sv
Turn on the UTF-8 status of an SV (the data is not changed, just the flag).
@@ -788,7 +860,8 @@
Do not use frivolously.
=for apidoc Am|void|SvUTF8_off|SV *sv
-Unsets the UTF-8 status of an SV.
+Unsets the UTF-8 status of an SV (the data is not changed, just the flag).
+Do not use frivolously.
=for apidoc Am|void|SvPOK_only_UTF8|SV* sv
Tells an SV that it is a string and disables all other OK bits,
@@ -823,7 +896,7 @@
? mg_find(sv,PERL_MAGIC_vstring) : NULL)
#define SvOOK(sv) (SvFLAGS(sv) & SVf_OOK)
-#define SvOOK_on(sv) ((void)SvIOK_off(sv), SvFLAGS(sv) |= SVf_OOK)
+#define SvOOK_on(sv) (SvFLAGS(sv) |= SVf_OOK)
#define SvOOK_off(sv) ((void)(SvOOK(sv) && sv_backoff(sv)))
#define SvFAKE(sv) (SvFLAGS(sv) & SVf_FAKE)
@@ -850,29 +923,49 @@
#define SvRMAGICAL_on(sv) (SvFLAGS(sv) |= SVs_RMG)
#define SvRMAGICAL_off(sv) (SvFLAGS(sv) &= ~SVs_RMG)
-#define SvAMAGIC(sv) (SvROK(sv) && (SvFLAGS(SvRV(sv)) & SVf_AMAGIC))
-#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
-# define SvAMAGIC_on(sv) ({ SV * const kloink = sv; \
- assert(SvROK(kloink)); \
- SvFLAGS(SvRV(kloink)) |= SVf_AMAGIC; \
- })
-# define SvAMAGIC_off(sv) ({ SV * const kloink = sv; \
- if(SvROK(kloink)) \
- SvFLAGS(SvRV(kloink)) &= ~SVf_AMAGIC;\
- })
-#else
-# define SvAMAGIC_on(sv) (SvFLAGS(SvRV(sv)) |= SVf_AMAGIC)
-# define SvAMAGIC_off(sv) \
- (SvROK(sv) && (SvFLAGS(SvRV(sv)) &= ~SVf_AMAGIC))
-#endif
+#define SvAMAGIC(sv) (SvROK(sv) && SvOBJECT(SvRV(sv)) && \
+ HvAMAGIC(SvSTASH(SvRV(sv))))
+/* To be used on the stashes themselves: */
+#define HvAMAGIC(hv) (SvFLAGS(hv) & SVf_AMAGIC)
+#define HvAMAGIC_on(hv) (SvFLAGS(hv) |= SVf_AMAGIC)
+#define HvAMAGIC_off(hv) (SvFLAGS(hv) &=~ SVf_AMAGIC)
+
+
+#define SvPOK_nog(sv) ((SvFLAGS(sv) & (SVf_POK|SVs_GMG)) == SVf_POK)
+#define SvIOK_nog(sv) ((SvFLAGS(sv) & (SVf_IOK|SVs_GMG)) == SVf_IOK)
+#define SvUOK_nog(sv) ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV|SVs_GMG)) == (SVf_IOK|SVf_IVisUV))
+#define SvNOK_nog(sv) ((SvFLAGS(sv) & (SVf_NOK|SVs_GMG)) == SVf_NOK)
+#define SvNIOK_nog(sv) (SvNIOK(sv) && !(SvFLAGS(sv) & SVs_GMG))
+
+#define SvPOK_nogthink(sv) ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST|SVs_GMG)) == SVf_POK)
+#define SvIOK_nogthink(sv) ((SvFLAGS(sv) & (SVf_IOK|SVf_THINKFIRST|SVs_GMG)) == SVf_IOK)
+#define SvUOK_nogthink(sv) ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV|SVf_THINKFIRST|SVs_GMG)) == (SVf_IOK|SVf_IVisUV))
+#define SvNOK_nogthink(sv) ((SvFLAGS(sv) & (SVf_NOK|SVf_THINKFIRST|SVs_GMG)) == SVf_NOK)
+#define SvNIOK_nogthink(sv) (SvNIOK(sv) && !(SvFLAGS(sv) & (SVf_THINKFIRST|SVs_GMG)))
+
+#define SvPOK_utf8_nog(sv) ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8|SVs_GMG)) == (SVf_POK|SVf_UTF8))
+#define SvPOK_utf8_nogthink(sv) ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8|SVf_THINKFIRST|SVs_GMG)) == (SVf_POK|SVf_UTF8))
+
+#define SvPOK_byte_nog(sv) ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8|SVs_GMG)) == SVf_POK)
+#define SvPOK_byte_nogthink(sv) ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8|SVf_THINKFIRST|SVs_GMG)) == SVf_POK)
+
+#define SvPOK_pure_nogthink(sv) \
+ ((SvFLAGS(sv) & (SVf_POK|SVf_IOK|SVf_NOK|SVf_ROK|SVpgv_GP|SVf_THINKFIRST|SVs_GMG)) == SVf_POK)
+#define SvPOK_utf8_pure_nogthink(sv) \
+ ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8|SVf_IOK|SVf_NOK|SVf_ROK|SVpgv_GP|SVf_THINKFIRST|SVs_GMG)) == (SVf_POK|SVf_UTF8))
+#define SvPOK_byte_pure_nogthink(sv) \
+ ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8|SVf_IOK|SVf_NOK|SVf_ROK|SVpgv_GP|SVf_THINKFIRST|SVs_GMG)) == SVf_POK)
+
/*
=for apidoc Am|U32|SvGAMAGIC|SV* sv
-Returns true if the SV has get magic or overloading. If either is true then
+Returns true if the SV has get magic or
+overloading. If either is true then
the scalar is active data, and has the potential to return a new value every
-time it is accessed. Hence you must be careful to only read it once per user
-logical operation and work with that returned value. If neither is true then
+time it is accessed. Hence you must be careful to
+only read it once per user logical operation and work
+with that returned value. If neither is true then
the scalar's value cannot change unless written to.
=cut
@@ -880,7 +973,10 @@
#define SvGAMAGIC(sv) (SvGMAGICAL(sv) || SvAMAGIC(sv))
-#define Gv_AMG(stash) (PL_amagic_generation && Gv_AMupdate(stash, FALSE))
+#define Gv_AMG(stash) \
+ (HvNAME(stash) && Gv_AMupdate(stash,FALSE) \
+ ? 1 \
+ : (HvAMAGIC_off(stash), 0))
#define SvWEAKREF(sv) ((SvFLAGS(sv) & (SVf_ROK|SVprv_WEAKREF)) \
== (SVf_ROK|SVprv_WEAKREF))
@@ -892,19 +988,46 @@
#define SvPCS_IMPORTED_on(sv) (SvFLAGS(sv) |= (SVf_ROK|SVprv_PCS_IMPORTED))
#define SvPCS_IMPORTED_off(sv) (SvFLAGS(sv) &= ~(SVf_ROK|SVprv_PCS_IMPORTED))
-#define SvTHINKFIRST(sv) (SvFLAGS(sv) & SVf_THINKFIRST)
+/*
+=for apidoc m|U32|SvTHINKFIRST|SV *sv
-#define SvPADSTALE(sv) (SvFLAGS(sv) & SVs_PADSTALE)
-#define SvPADSTALE_on(sv) (SvFLAGS(sv) |= SVs_PADSTALE)
-#define SvPADSTALE_off(sv) (SvFLAGS(sv) &= ~SVs_PADSTALE)
+A quick flag check to see whether an sv should be passed to sv_force_normal
+to be "downgraded" before SvIVX or SvPVX can be modified directly.
-#define SvPADTMP(sv) (SvFLAGS(sv) & SVs_PADTMP)
-#define SvPADTMP_on(sv) (SvFLAGS(sv) |= SVs_PADTMP)
-#define SvPADTMP_off(sv) (SvFLAGS(sv) &= ~SVs_PADTMP)
+For example, if your scalar is a reference and you want to modify the SvIVX
+slot, you can't just do SvROK_off, as that will leak the referent.
+This is used internally by various sv-modifying functions, such as
+sv_setsv, sv_setiv and sv_pvn_force.
+
+One case that this does not handle is a gv without SvFAKE set. After
+
+ if (SvTHINKFIRST(gv)) sv_force_normal(gv);
+
+it will still be a gv.
+
+SvTHINKFIRST sometimes produces false positives. In those cases
+sv_force_normal does nothing.
+
+=cut
+*/
+
+#define SvTHINKFIRST(sv) (SvFLAGS(sv) & SVf_THINKFIRST)
+
#define SvPADMY(sv) (SvFLAGS(sv) & SVs_PADMY)
#define SvPADMY_on(sv) (SvFLAGS(sv) |= SVs_PADMY)
+/* SVs_PADTMP and SVs_PADSTALE share the same bit, mediated by SVs_PADMY */
+
+#define SvPADTMP(sv) ((SvFLAGS(sv) & (SVs_PADMY|SVs_PADTMP)) == SVs_PADTMP)
+#define SvPADSTALE(sv) ((SvFLAGS(sv) & (SVs_PADMY|SVs_PADSTALE)) \
+ == (SVs_PADMY|SVs_PADSTALE))
+
+#define SvPADTMP_on(sv) S_SvPADTMP_on(MUTABLE_SV(sv))
+#define SvPADTMP_off(sv) S_SvPADTMP_off(MUTABLE_SV(sv))
+#define SvPADSTALE_on(sv) S_SvPADSTALE_on(MUTABLE_SV(sv))
+#define SvPADSTALE_off(sv) S_SvPADSTALE_off(MUTABLE_SV(sv))
+
#define SvTEMP(sv) (SvFLAGS(sv) & SVs_TEMP)
#define SvTEMP_on(sv) (SvFLAGS(sv) |= SVs_TEMP)
#define SvTEMP_off(sv) (SvFLAGS(sv) &= ~SVs_TEMP)
@@ -1003,9 +1126,6 @@
((XPVMG*) SvANY(sv))->xmg_u.xmg_ourstash = st; \
} STMT_END
-#ifdef PERL_DEBUG_COW
-#else
-#endif
#define SvRVx(sv) SvRV(sv)
#ifdef PERL_DEBUG_COW
@@ -1018,7 +1138,7 @@
# define SvRV_const(sv) (0 + (sv)->sv_u.svu_rv)
/* Don't test the core XS code yet. */
# if defined (PERL_CORE) && PERL_DEBUG_COW > 1
-# define SvPVX(sv) (0 + (assert(!SvREADONLY(sv)), (sv)->sv_u.svu_pv))
+# define SvPVX(sv) (0 + (assert_(!SvREADONLY(sv)) (sv)->sv_u.svu_pv))
# else
# define SvPVX(sv) SvPVX_mutable(sv)
# endif
@@ -1026,13 +1146,8 @@
# define SvLEN(sv) (0 + ((XPV*) SvANY(sv))->xpv_len)
# define SvEND(sv) ((sv)->sv_u.svu_pv + ((XPV*)SvANY(sv))->xpv_cur)
-# ifdef DEBUGGING
-# define SvMAGIC(sv) (0 + *(assert(SvTYPE(sv) >= SVt_PVMG), &((XPVMG*) SvANY(sv))->xmg_u.xmg_magic))
-# define SvSTASH(sv) (0 + *(assert(SvTYPE(sv) >= SVt_PVMG), &((XPVMG*) SvANY(sv))->xmg_stash))
-# else
-# define SvMAGIC(sv) (0 + ((XPVMG*) SvANY(sv))->xmg_u.xmg_magic)
-# define SvSTASH(sv) (0 + ((XPVMG*) SvANY(sv))->xmg_stash)
-# endif
+# define SvMAGIC(sv) (0 + *(assert_(SvTYPE(sv) >= SVt_PVMG) &((XPVMG*) SvANY(sv))->xmg_u.xmg_magic))
+# define SvSTASH(sv) (0 + *(assert_(SvTYPE(sv) >= SVt_PVMG) &((XPVMG*) SvANY(sv))->xmg_stash))
#else
# define SvLEN(sv) ((XPV*) SvANY(sv))->xpv_len
# define SvEND(sv) ((sv)->sv_u.svu_pv + ((XPV*)SvANY(sv))->xpv_cur)
@@ -1041,9 +1156,7 @@
/* These get expanded inside other macros that already use a variable _sv */
# define SvPVX(sv) \
(*({ SV *const _svpvx = MUTABLE_SV(sv); \
- assert(SvTYPE(_svpvx) >= SVt_PV); \
- assert(SvTYPE(_svpvx) != SVt_PVAV); \
- assert(SvTYPE(_svpvx) != SVt_PVHV); \
+ assert(PL_valid_types_PVX[SvTYPE(_svpvx) & SVt_MASK]); \
assert(!isGV_with_GP(_svpvx)); \
assert(!(SvTYPE(_svpvx) == SVt_PVIO \
&& !(IoFLAGS(_svpvx) & IOf_FAKE_DIRP))); \
@@ -1051,9 +1164,8 @@
}))
# define SvCUR(sv) \
(*({ const SV *const _svcur = (const SV *)(sv); \
- assert(SvTYPE(_svcur) >= SVt_PV); \
- assert(SvTYPE(_svcur) != SVt_PVAV); \
- assert(SvTYPE(_svcur) != SVt_PVHV); \
+ assert(PL_valid_types_PVX[SvTYPE(_svcur) & SVt_MASK] \
+ || SvTYPE(_svcur) == SVt_REGEXP); \
assert(!isGV_with_GP(_svcur)); \
assert(!(SvTYPE(_svcur) == SVt_PVIO \
&& !(IoFLAGS(_svcur) & IOf_FAKE_DIRP))); \
@@ -1061,47 +1173,25 @@
}))
# define SvIVX(sv) \
(*({ const SV *const _svivx = (const SV *)(sv); \
- assert(SvTYPE(_svivx) == SVt_IV || SvTYPE(_svivx) >= SVt_PVIV); \
- assert(SvTYPE(_svivx) != SVt_PVAV); \
- assert(SvTYPE(_svivx) != SVt_PVHV); \
- assert(SvTYPE(_svivx) != SVt_PVCV); \
- assert(SvTYPE(_svivx) != SVt_PVFM); \
- assert(SvTYPE(_svivx) != SVt_PVIO); \
- assert(SvTYPE(_svivx) != SVt_REGEXP); \
+ assert(PL_valid_types_IVX[SvTYPE(_svivx) & SVt_MASK]); \
assert(!isGV_with_GP(_svivx)); \
&(((XPVIV*) MUTABLE_PTR(SvANY(_svivx)))->xiv_iv); \
}))
# define SvUVX(sv) \
(*({ const SV *const _svuvx = (const SV *)(sv); \
- assert(SvTYPE(_svuvx) == SVt_IV || SvTYPE(_svuvx) >= SVt_PVIV); \
- assert(SvTYPE(_svuvx) != SVt_PVAV); \
- assert(SvTYPE(_svuvx) != SVt_PVHV); \
- assert(SvTYPE(_svuvx) != SVt_PVCV); \
- assert(SvTYPE(_svuvx) != SVt_PVFM); \
- assert(SvTYPE(_svuvx) != SVt_PVIO); \
- assert(SvTYPE(_svuvx) != SVt_REGEXP); \
+ assert(PL_valid_types_IVX[SvTYPE(_svuvx) & SVt_MASK]); \
assert(!isGV_with_GP(_svuvx)); \
&(((XPVUV*) MUTABLE_PTR(SvANY(_svuvx)))->xuv_uv); \
}))
# define SvNVX(sv) \
(*({ const SV *const _svnvx = (const SV *)(sv); \
- assert(SvTYPE(_svnvx) == SVt_NV || SvTYPE(_svnvx) >= SVt_PVNV); \
- assert(SvTYPE(_svnvx) != SVt_PVAV); \
- assert(SvTYPE(_svnvx) != SVt_PVHV); \
- assert(SvTYPE(_svnvx) != SVt_PVCV); \
- assert(SvTYPE(_svnvx) != SVt_PVFM); \
- assert(SvTYPE(_svnvx) != SVt_PVIO); \
- assert(SvTYPE(_svnvx) != SVt_REGEXP); \
+ assert(PL_valid_types_NVX[SvTYPE(_svnvx) & SVt_MASK]); \
assert(!isGV_with_GP(_svnvx)); \
&(((XPVNV*) MUTABLE_PTR(SvANY(_svnvx)))->xnv_u.xnv_nv); \
}))
# define SvRV(sv) \
(*({ SV *const _svrv = MUTABLE_SV(sv); \
- assert(SvTYPE(_svrv) >= SVt_PV || SvTYPE(_svrv) == SVt_IV); \
- assert(SvTYPE(_svrv) != SVt_PVAV); \
- assert(SvTYPE(_svrv) != SVt_PVHV); \
- assert(SvTYPE(_svrv) != SVt_PVCV); \
- assert(SvTYPE(_svrv) != SVt_PVFM); \
+ assert(PL_valid_types_RV[SvTYPE(_svrv) & SVt_MASK]); \
assert(!isGV_with_GP(_svrv)); \
assert(!(SvTYPE(_svrv) == SVt_PVIO \
&& !(IoFLAGS(_svrv) & IOf_FAKE_DIRP))); \
@@ -1109,11 +1199,7 @@
}))
# define SvRV_const(sv) \
({ const SV *const _svrv = (const SV *)(sv); \
- assert(SvTYPE(_svrv) >= SVt_PV || SvTYPE(_svrv) == SVt_IV); \
- assert(SvTYPE(_svrv) != SVt_PVAV); \
- assert(SvTYPE(_svrv) != SVt_PVHV); \
- assert(SvTYPE(_svrv) != SVt_PVCV); \
- assert(SvTYPE(_svrv) != SVt_PVFM); \
+ assert(PL_valid_types_RV[SvTYPE(_svrv) & SVt_MASK]); \
assert(!isGV_with_GP(_svrv)); \
assert(!(SvTYPE(_svrv) == SVt_PVIO \
&& !(IoFLAGS(_svrv) & IOf_FAKE_DIRP))); \
@@ -1171,43 +1257,34 @@
STMT_START {if (!SvIOKp(sv) && (SvNOK(sv) || SvPOK(sv))) \
(void) SvIV(sv); } STMT_END
#define SvIV_please_nomg(sv) \
- STMT_START {if (!SvIOKp(sv) && (SvNOK(sv) || SvPOK(sv))) \
- (void) SvIV_nomg(sv); } STMT_END
+ (!SvIOKp(sv) && (SvNOK(sv) || SvPOK(sv)) \
+ ? (SvIV_nomg(sv), SvIOK(sv)) \
+ : SvIOK(sv))
#define SvIV_set(sv, val) \
- STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \
- assert(SvTYPE(sv) != SVt_PVAV); \
- assert(SvTYPE(sv) != SVt_PVHV); \
- assert(SvTYPE(sv) != SVt_PVCV); \
+ STMT_START { \
+ assert(PL_valid_types_IV_set[SvTYPE(sv) & SVt_MASK]); \
assert(!isGV_with_GP(sv)); \
(((XPVIV*) SvANY(sv))->xiv_iv = (val)); } STMT_END
#define SvNV_set(sv, val) \
- STMT_START { assert(SvTYPE(sv) == SVt_NV || SvTYPE(sv) >= SVt_PVNV); \
- assert(SvTYPE(sv) != SVt_PVAV); assert(SvTYPE(sv) != SVt_PVHV); \
- assert(SvTYPE(sv) != SVt_PVCV); assert(SvTYPE(sv) != SVt_PVFM); \
- assert(SvTYPE(sv) != SVt_PVIO); \
+ STMT_START { \
+ assert(PL_valid_types_NV_set[SvTYPE(sv) & SVt_MASK]); \
assert(!isGV_with_GP(sv)); \
(((XPVNV*)SvANY(sv))->xnv_u.xnv_nv = (val)); } STMT_END
#define SvPV_set(sv, val) \
- STMT_START { assert(SvTYPE(sv) >= SVt_PV); \
- assert(SvTYPE(sv) != SVt_PVAV); \
- assert(SvTYPE(sv) != SVt_PVHV); \
+ STMT_START { \
+ assert(PL_valid_types_PVX[SvTYPE(sv) & SVt_MASK]); \
assert(!isGV_with_GP(sv)); \
assert(!(SvTYPE(sv) == SVt_PVIO \
&& !(IoFLAGS(sv) & IOf_FAKE_DIRP))); \
((sv)->sv_u.svu_pv = (val)); } STMT_END
#define SvUV_set(sv, val) \
- STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \
- assert(SvTYPE(sv) != SVt_PVAV); \
- assert(SvTYPE(sv) != SVt_PVHV); \
- assert(SvTYPE(sv) != SVt_PVCV); \
+ STMT_START { \
+ assert(PL_valid_types_IV_set[SvTYPE(sv) & SVt_MASK]); \
assert(!isGV_with_GP(sv)); \
(((XPVUV*)SvANY(sv))->xuv_uv = (val)); } STMT_END
#define SvRV_set(sv, val) \
- STMT_START { assert(SvTYPE(sv) >= SVt_PV || SvTYPE(sv) == SVt_IV); \
- assert(SvTYPE(sv) != SVt_PVAV); \
- assert(SvTYPE(sv) != SVt_PVHV); \
- assert(SvTYPE(sv) != SVt_PVCV); \
- assert(SvTYPE(sv) != SVt_PVFM); \
+ STMT_START { \
+ assert(PL_valid_types_RV[SvTYPE(sv) & SVt_MASK]); \
assert(!isGV_with_GP(sv)); \
assert(!(SvTYPE(sv) == SVt_PVIO \
&& !(IoFLAGS(sv) & IOf_FAKE_DIRP))); \
@@ -1219,17 +1296,16 @@
STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \
(((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END
#define SvCUR_set(sv, val) \
- STMT_START { assert(SvTYPE(sv) >= SVt_PV); \
- assert(SvTYPE(sv) != SVt_PVAV); \
- assert(SvTYPE(sv) != SVt_PVHV); \
+ STMT_START { \
+ assert(PL_valid_types_PVX[SvTYPE(sv) & SVt_MASK] \
+ || SvTYPE(sv) == SVt_REGEXP); \
assert(!isGV_with_GP(sv)); \
assert(!(SvTYPE(sv) == SVt_PVIO \
&& !(IoFLAGS(sv) & IOf_FAKE_DIRP))); \
(((XPV*) SvANY(sv))->xpv_cur = (val)); } STMT_END
#define SvLEN_set(sv, val) \
- STMT_START { assert(SvTYPE(sv) >= SVt_PV); \
- assert(SvTYPE(sv) != SVt_PVAV); \
- assert(SvTYPE(sv) != SVt_PVHV); \
+ STMT_START { \
+ assert(PL_valid_types_PVX[SvTYPE(sv) & SVt_MASK]); \
assert(!isGV_with_GP(sv)); \
assert(!(SvTYPE(sv) == SVt_PVIO \
&& !(IoFLAGS(sv) & IOf_FAKE_DIRP))); \
@@ -1280,51 +1356,44 @@
} STMT_END
#endif
-#define PERL_FBM_TABLE_OFFSET 1 /* Number of bytes between EOS and table */
+#ifndef PERL_CORE
+# define BmFLAGS(sv) (SvTAIL(sv) ? FBMcf_TAIL : 0)
+#endif
-/* SvPOKp not SvPOK in the assertion because the string can be tainted! eg
- perl -T -e '/$^X/'
-*/
#if defined (DEBUGGING) && defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
-# define BmFLAGS(sv) \
- (*({ SV *const _bmflags = MUTABLE_SV(sv); \
- assert(SvTYPE(_bmflags) == SVt_PVGV); \
- assert(SvVALID(_bmflags)); \
- &(((XPVGV*) SvANY(_bmflags))->xnv_u.xbm_s.xbm_flags); \
- }))
# define BmRARE(sv) \
(*({ SV *const _bmrare = MUTABLE_SV(sv); \
- assert(SvTYPE(_bmrare) == SVt_PVGV); \
+ assert(SvTYPE(_bmrare) == SVt_PVMG); \
assert(SvVALID(_bmrare)); \
- &(((XPVGV*) SvANY(_bmrare))->xnv_u.xbm_s.xbm_rare); \
+ &(((XPVMG*) SvANY(_bmrare))->xnv_u.xbm_s.xbm_rare); \
}))
# define BmUSEFUL(sv) \
(*({ SV *const _bmuseful = MUTABLE_SV(sv); \
- assert(SvTYPE(_bmuseful) == SVt_PVGV); \
+ assert(SvTYPE(_bmuseful) == SVt_PVMG); \
assert(SvVALID(_bmuseful)); \
assert(!SvIOK(_bmuseful)); \
- &(((XPVGV*) SvANY(_bmuseful))->xiv_u.xivu_i32); \
+ &(((XPVMG*) SvANY(_bmuseful))->xnv_u.xbm_s.xbm_useful); \
}))
# define BmPREVIOUS(sv) \
(*({ SV *const _bmprevious = MUTABLE_SV(sv); \
- assert(SvTYPE(_bmprevious) == SVt_PVGV); \
+ assert(SvTYPE(_bmprevious) == SVt_PVMG); \
assert(SvVALID(_bmprevious)); \
- &(((XPVGV*) SvANY(_bmprevious))->xnv_u.xbm_s.xbm_previous); \
+ &(((XPVMG*) SvANY(_bmprevious))->xiv_u.xivu_uv); \
}))
#else
-# define BmFLAGS(sv) ((XPVGV*) SvANY(sv))->xnv_u.xbm_s.xbm_flags
-# define BmRARE(sv) ((XPVGV*) SvANY(sv))->xnv_u.xbm_s.xbm_rare
-# define BmUSEFUL(sv) ((XPVGV*) SvANY(sv))->xiv_u.xivu_i32
-# define BmPREVIOUS(sv) ((XPVGV*) SvANY(sv))->xnv_u.xbm_s.xbm_previous
+# define BmRARE(sv) ((XPVMG*) SvANY(sv))->xnv_u.xbm_s.xbm_rare
+# define BmUSEFUL(sv) ((XPVMG*) SvANY(sv))->xnv_u.xbm_s.xbm_useful
+# define BmPREVIOUS(sv) ((XPVMG*) SvANY(sv))->xiv_u.xivu_uv
#endif
-#define FmLINES(sv) ((XPVFM*) SvANY(sv))->xfm_lines
+#define FmLINES(sv) ((XPVIV*) SvANY(sv))->xiv_iv
#define LvTYPE(sv) ((XPVLV*) SvANY(sv))->xlv_type
#define LvTARG(sv) ((XPVLV*) SvANY(sv))->xlv_targ
#define LvTARGOFF(sv) ((XPVLV*) SvANY(sv))->xlv_targoff
#define LvTARGLEN(sv) ((XPVLV*) SvANY(sv))->xlv_targlen
+#define LvFLAGS(sv) ((XPVLV*) SvANY(sv))->xlv_flags
#define IoIFP(sv) (sv)->sv_u.svu_fp
#define IoOFP(sv) ((XPVIO*) SvANY(sv))->xio_ofp
@@ -1357,7 +1426,7 @@
/*
=for apidoc Am|bool|SvTAINTED|SV* sv
-Checks to see if an SV is tainted. Returns TRUE if it is, FALSE if
+Checks to see if an SV is tainted. Returns TRUE if it is, FALSE if
not.
=for apidoc Am|void|SvTAINTED_on|SV* sv
@@ -1364,8 +1433,8 @@
Marks an SV as tainted if tainting is enabled.
=for apidoc Am|void|SvTAINTED_off|SV* sv
-Untaints an SV. Be I<very> careful with this routine, as it short-circuits
-some of Perl's fundamental security features. XS module authors should not
+Untaints an SV. Be I<very> careful with this routine, as it short-circuits
+some of Perl's fundamental security features. XS module authors should not
use this function unless they fully understand all the implications of
unconditionally untainting the value. Untainting should be done in the
standard perl fashion, via a carefully crafted regexp, rather than directly
@@ -1372,7 +1441,11 @@
untainting variables.
=for apidoc Am|void|SvTAINT|SV* sv
-Taints an SV if tainting is enabled.
+Taints an SV if tainting is enabled, and if some input to the current
+expression is tainted--usually a variable, but possibly also implicit
+inputs such as locale settings. C<SvTAINT> propagates that taintedness to
+the outputs of an expression in a pessimistic fashion; i.e., without paying
+attention to precisely which outputs are influenced by which inputs.
=cut
*/
@@ -1379,14 +1452,18 @@
#define sv_taint(sv) sv_magic((sv), NULL, PERL_MAGIC_taint, NULL, 0)
-#define SvTAINTED(sv) (SvMAGICAL(sv) && sv_tainted(sv))
-#define SvTAINTED_on(sv) STMT_START{ if(PL_tainting){sv_taint(sv);} }STMT_END
-#define SvTAINTED_off(sv) STMT_START{ if(PL_tainting){sv_untaint(sv);} }STMT_END
+#if NO_TAINT_SUPPORT
+# define SvTAINTED(sv) 0
+#else
+# define SvTAINTED(sv) (SvMAGICAL(sv) && sv_tainted(sv))
+#endif
+#define SvTAINTED_on(sv) STMT_START{ if(TAINTING_get){sv_taint(sv);} }STMT_END
+#define SvTAINTED_off(sv) STMT_START{ if(TAINTING_get){sv_untaint(sv);} }STMT_END
#define SvTAINT(sv) \
STMT_START { \
- if (PL_tainting) { \
- if (PL_tainted) \
+ if (TAINTING_get) { \
+ if (TAINT_get) \
SvTAINTED_on(sv); \
} \
} STMT_END
@@ -1393,39 +1470,50 @@
/*
=for apidoc Am|char*|SvPV_force|SV* sv|STRLEN len
-Like C<SvPV> but will force the SV into containing just a string
-(C<SvPOK_only>). You want force if you are going to update the C<SvPVX>
-directly.
+Like C<SvPV> but will force the SV into containing a string (C<SvPOK>), and
+only a string (C<SvPOK_only>), by hook or by crook. You need force if you are
+going to update the C<SvPVX> directly. Processes get magic.
+Note that coercing an arbitrary scalar into a plain PV will potentially
+strip useful data from it. For example if the SV was C<SvROK>, then the
+referent will have its reference count decremented, and the SV itself may
+be converted to an C<SvPOK> scalar with a string buffer containing a value
+such as C<"ARRAY(0x1234)">.
+
=for apidoc Am|char*|SvPV_force_nomg|SV* sv|STRLEN len
-Like C<SvPV> but will force the SV into containing just a string
-(C<SvPOK_only>). You want force if you are going to update the C<SvPVX>
-directly. Doesn't process magic.
+Like C<SvPV_force>, but doesn't process get magic.
=for apidoc Am|char*|SvPV|SV* sv|STRLEN len
Returns a pointer to the string in the SV, or a stringified form of
the SV if the SV does not contain a string. The SV may cache the
-stringified version becoming C<SvPOK>. Handles 'get' magic. See also
+stringified version becoming C<SvPOK>. Handles 'get' magic. See also
C<SvPVx> for a version which guarantees to evaluate sv only once.
+Note that there is no guarantee that the return value of C<SvPV()> is
+equal to C<SvPVX(sv)>, or that C<SvPVX(sv)> contains valid data, or that
+successive calls to C<SvPV(sv)) will return the same pointer value each
+time. This is due to the way that things like overloading and
+Copy-On-Write are handled. In these cases, the return value may point to
+a temporary buffer or similar. If you absolutely need the SvPVX field to
+be valid (for example, if you intend to write to it), then see
+L</SvPV_force>.
+
=for apidoc Am|char*|SvPVx|SV* sv|STRLEN len
A version of C<SvPV> which guarantees to evaluate C<sv> only once.
Only use this if C<sv> is an expression with side effects, otherwise use the
-more efficient C<SvPVX>.
+more efficient C<SvPV>.
=for apidoc Am|char*|SvPV_nomg|SV* sv|STRLEN len
Like C<SvPV> but doesn't process magic.
=for apidoc Am|char*|SvPV_nolen|SV* sv
-Returns a pointer to the string in the SV, or a stringified form of
-the SV if the SV does not contain a string. The SV may cache the
-stringified form becoming C<SvPOK>. Handles 'get' magic.
+Like C<SvPV> but doesn't set a length variable.
=for apidoc Am|char*|SvPV_nomg_nolen|SV* sv
Like C<SvPV_nolen> but doesn't process magic.
=for apidoc Am|IV|SvIV|SV* sv
-Coerces the given SV to an integer and returns it. See C<SvIVx> for a
+Coerces the given SV to an integer and returns it. See C<SvIVx> for a
version which guarantees to evaluate sv only once.
=for apidoc Am|IV|SvIV_nomg|SV* sv
@@ -1432,12 +1520,13 @@
Like C<SvIV> but doesn't process magic.
=for apidoc Am|IV|SvIVx|SV* sv
-Coerces the given SV to an integer and returns it. Guarantees to evaluate
-C<sv> only once. Only use this if C<sv> is an expression with side effects,
+Coerces the given SV to an integer and returns it.
+Guarantees to evaluate C<sv> only once. Only use
+this if C<sv> is an expression with side effects,
otherwise use the more efficient C<SvIV>.
=for apidoc Am|NV|SvNV|SV* sv
-Coerce the given SV to a double and return it. See C<SvNVx> for a version
+Coerce the given SV to a double and return it. See C<SvNVx> for a version
which guarantees to evaluate sv only once.
=for apidoc Am|NV|SvNV_nomg|SV* sv
@@ -1444,8 +1533,9 @@
Like C<SvNV> but doesn't process magic.
=for apidoc Am|NV|SvNVx|SV* sv
-Coerces the given SV to a double and returns it. Guarantees to evaluate
-C<sv> only once. Only use this if C<sv> is an expression with side effects,
+Coerces the given SV to a double and returns it.
+Guarantees to evaluate C<sv> only once. Only use
+this if C<sv> is an expression with side effects,
otherwise use the more efficient C<SvNV>.
=for apidoc Am|UV|SvUV|SV* sv
@@ -1456,8 +1546,9 @@
Like C<SvUV> but doesn't process magic.
=for apidoc Am|UV|SvUVx|SV* sv
-Coerces the given SV to an unsigned integer and returns it. Guarantees to
-C<sv> only once. Only use this if C<sv> is an expression with side effects,
+Coerces the given SV to an unsigned integer and
+returns it. Guarantees to evaluate C<sv> only once. Only
+use this if C<sv> is an expression with side effects,
otherwise use the more efficient C<SvUV>.
=for apidoc Am|bool|SvTRUE|SV* sv
@@ -1509,9 +1600,9 @@
otherwise.
=for apidoc Am|bool|SvIsCOW|SV* sv
-Returns a boolean indicating whether the SV is Copy-On-Write. (either shared
+Returns a boolean indicating whether the SV is Copy-On-Write (either shared
hash key scalars, or full Copy On Write scalars if 5.9.0 is configured for
-COW)
+COW).
=for apidoc Am|bool|SvIsCOW_shared_hash|SV* sv
Returns a boolean indicating whether the SV is Copy-On-Write shared hash key
@@ -1531,15 +1622,15 @@
=for apidoc Amdb|STRLEN|sv_utf8_upgrade_nomg|NN SV *sv
-Like sv_utf8_upgrade, but doesn't do magic on C<sv>
+Like sv_utf8_upgrade, but doesn't do magic on C<sv>.
=cut
*/
/* Let us hope that bitmaps for UV and IV are the same */
-#define SvIV(sv) (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv))
-#define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv))
-#define SvNV(sv) (SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv))
+#define SvIV(sv) (SvIOK_nog(sv) ? SvIVX(sv) : sv_2iv(sv))
+#define SvUV(sv) (SvUOK_nog(sv) ? SvUVX(sv) : sv_2uv(sv))
+#define SvNV(sv) (SvNOK_nog(sv) ? SvNVX(sv) : sv_2nv(sv))
#define SvIV_nomg(sv) (SvIOK(sv) ? SvIVX(sv) : sv_2iv_flags(sv, 0))
#define SvUV_nomg(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv_flags(sv, 0))
@@ -1547,23 +1638,23 @@
/* ----*/
-#define SvPV(sv, lp) SvPV_flags(sv, lp, SV_GMAGIC)
-#define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC)
+#define SvPV(sv, lp) SvPV_flags(sv, lp, SV_GMAGIC)
+#define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC)
#define SvPV_mutable(sv, lp) SvPV_flags_mutable(sv, lp, SV_GMAGIC)
#define SvPV_flags(sv, lp, flags) \
- ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
+ (SvPOK_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags))
#define SvPV_flags_const(sv, lp, flags) \
- ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
+ (SvPOK_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \
(const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN))
#define SvPV_flags_const_nolen(sv, flags) \
- ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
+ (SvPOK_nog(sv) \
? SvPVX_const(sv) : \
(const char*) sv_2pv_flags(sv, 0, flags|SV_CONST_RETURN))
#define SvPV_flags_mutable(sv, lp, flags) \
- ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
+ (SvPOK_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \
sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN))
@@ -1575,26 +1666,28 @@
#define SvPV_force_nomg_nolen(sv) SvPV_force_flags_nolen(sv, 0)
#define SvPV_force_flags(sv, lp, flags) \
- ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \
- ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags))
+ (SvPOK_pure_nogthink(sv) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags))
+
#define SvPV_force_flags_nolen(sv, flags) \
- ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \
- ? SvPVX(sv) : sv_pvn_force_flags(sv, 0, flags))
+ (SvPOK_pure_nogthink(sv) \
+ ? SvPVX(sv) : sv_pvn_force_flags(sv, 0, flags))
+
#define SvPV_force_flags_mutable(sv, lp, flags) \
- ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \
- ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \
+ (SvPOK_pure_nogthink(sv) \
+ ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \
: sv_pvn_force_flags(sv, &lp, flags|SV_MUTABLE_RETURN))
#define SvPV_nolen(sv) \
- ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
+ (SvPOK_nog(sv) \
? SvPVX(sv) : sv_2pv_flags(sv, 0, SV_GMAGIC))
#define SvPV_nomg_nolen(sv) \
- ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
+ (SvPOK_nog(sv) \
? SvPVX(sv) : sv_2pv_flags(sv, 0, 0))
#define SvPV_nolen_const(sv) \
- ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
+ (SvPOK_nog(sv) \
? SvPVX_const(sv) : sv_2pv_flags(sv, 0, SV_GMAGIC|SV_CONST_RETURN))
#define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0)
@@ -1604,33 +1697,31 @@
/* ----*/
#define SvPVutf8(sv, lp) \
- ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK|SVf_UTF8) \
+ (SvPOK_utf8_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvutf8(sv, &lp))
#define SvPVutf8_force(sv, lp) \
- ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8|SVf_THINKFIRST)) == (SVf_POK|SVf_UTF8) \
+ (SvPOK_utf8_pure_nogthink(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvutf8n_force(sv, &lp))
-
#define SvPVutf8_nolen(sv) \
- ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK|SVf_UTF8)\
+ (SvPOK_utf8_nog(sv) \
? SvPVX(sv) : sv_2pvutf8(sv, 0))
/* ----*/
#define SvPVbyte(sv, lp) \
- ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \
+ (SvPOK_byte_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp))
#define SvPVbyte_force(sv, lp) \
- ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8|SVf_THINKFIRST)) == (SVf_POK) \
+ (SvPOK_byte_pure_nogthink(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvbyten_force(sv, &lp))
#define SvPVbyte_nolen(sv) \
- ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK)\
+ (SvPOK_byte_nog(sv) \
? SvPVX(sv) : sv_2pvbyte(sv, 0))
-
/* define FOOx(): idempotent versions of FOO(). If possible, use a local
* var to evaluate the arg once; failing that, use a global if possible;
@@ -1641,6 +1732,20 @@
#define SvPVutf8x_force(sv, lp) sv_pvutf8n_force(sv, &lp)
#define SvPVbytex_force(sv, lp) sv_pvbyten_force(sv, &lp)
+#define SvTRUE(sv) ((sv) && (SvGMAGICAL(sv) ? sv_2bool(sv) : SvTRUE_common(sv, sv_2bool_nomg(sv))))
+#define SvTRUE_nomg(sv) ((sv) && ( SvTRUE_common(sv, sv_2bool_nomg(sv))))
+#define SvTRUE_NN(sv) (SvGMAGICAL(sv) ? sv_2bool(sv) : SvTRUE_common(sv, sv_2bool_nomg(sv)))
+#define SvTRUE_nomg_NN(sv) ( SvTRUE_common(sv, sv_2bool_nomg(sv)))
+#define SvTRUE_common(sv,fallback) ( \
+ !SvOK(sv) \
+ ? 0 \
+ : SvPOK(sv) \
+ ? SvPVXtrue(sv) \
+ : (SvFLAGS(sv) & (SVf_IOK|SVf_NOK)) \
+ ? ( (SvIOK(sv) && SvIVX(sv) != 0) \
+ || (SvNOK(sv) && SvNVX(sv) != 0.0)) \
+ : (fallback))
+
#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
# define SvIVx(sv) ({SV *_sv = MUTABLE_SV(sv); SvIV(_sv); })
@@ -1653,39 +1758,8 @@
# define SvPVutf8x(sv, lp) ({SV *_sv = (sv); SvPVutf8(_sv, lp); })
# define SvPVbytex(sv, lp) ({SV *_sv = (sv); SvPVbyte(_sv, lp); })
# define SvPVbytex_nolen(sv) ({SV *_sv = (sv); SvPVbyte_nolen(_sv); })
-# define SvTRUE(sv) ( \
- !sv \
- ? 0 \
- : SvPOK(sv) \
- ? (({XPV *nxpv = (XPV*)SvANY(sv); \
- nxpv && \
- (nxpv->xpv_cur > 1 || \
- (nxpv->xpv_cur && *(sv)->sv_u.svu_pv != '0')); }) \
- ? 1 \
- : 0) \
- : \
- SvIOK(sv) \
- ? SvIVX(sv) != 0 \
- : SvNOK(sv) \
- ? SvNVX(sv) != 0.0 \
- : sv_2bool(sv) )
-# define SvTRUE_nomg(sv) ( \
- !sv \
- ? 0 \
- : SvPOK(sv) \
- ? (({XPV *nxpv = (XPV*)SvANY(sv); \
- nxpv && \
- (nxpv->xpv_cur > 1 || \
- (nxpv->xpv_cur && *(sv)->sv_u.svu_pv != '0')); }) \
- ? 1 \
- : 0) \
- : \
- SvIOK(sv) \
- ? SvIVX(sv) != 0 \
- : SvNOK(sv) \
- ? SvNVX(sv) != 0.0 \
- : sv_2bool_flags(sv,0) )
-# define SvTRUEx(sv) ({SV *_sv = (sv); SvTRUE(_sv); })
+# define SvTRUEx(sv) ({SV *_sv = (sv); SvTRUE(_sv); })
+# define SvTRUEx_nomg(sv) ({SV *_sv = (sv); SvTRUE_nomg(_sv); })
#else /* __GNUC__ */
@@ -1702,41 +1776,24 @@
# define SvPVutf8x(sv, lp) ((PL_Sv = (sv)), SvPVutf8(PL_Sv, lp))
# define SvPVbytex(sv, lp) ((PL_Sv = (sv)), SvPVbyte(PL_Sv, lp))
# define SvPVbytex_nolen(sv) ((PL_Sv = (sv)), SvPVbyte_nolen(PL_Sv))
-# define SvTRUE(sv) ( \
- !sv \
- ? 0 \
- : SvPOK(sv) \
- ? ((PL_Xpv = (XPV*)SvANY(PL_Sv = (sv))) && \
- (PL_Xpv->xpv_cur > 1 || \
- (PL_Xpv->xpv_cur && *PL_Sv->sv_u.svu_pv != '0')) \
- ? 1 \
- : 0) \
- : \
- SvIOK(sv) \
- ? SvIVX(sv) != 0 \
- : SvNOK(sv) \
- ? SvNVX(sv) != 0.0 \
- : sv_2bool(sv) )
-# define SvTRUE_nomg(sv) ( \
- !sv \
- ? 0 \
- : SvPOK(sv) \
- ? ((PL_Xpv = (XPV*)SvANY(PL_Sv = (sv))) && \
- (PL_Xpv->xpv_cur > 1 || \
- (PL_Xpv->xpv_cur && *PL_Sv->sv_u.svu_pv != '0')) \
- ? 1 \
- : 0) \
- : \
- SvIOK(sv) \
- ? SvIVX(sv) != 0 \
- : SvNOK(sv) \
- ? SvNVX(sv) != 0.0 \
- : sv_2bool_flags(sv,0) )
-# define SvTRUEx(sv) ((PL_Sv = (sv)), SvTRUE(PL_Sv))
+# define SvTRUEx(sv) ((PL_Sv = (sv)), SvTRUE(PL_Sv))
+# define SvTRUEx_nomg(sv) ((PL_Sv = (sv)), SvTRUE_nomg(PL_Sv))
#endif /* __GNU__ */
-#define SvIsCOW(sv) ((SvFLAGS(sv) & (SVf_FAKE | SVf_READONLY)) == \
- (SVf_FAKE | SVf_READONLY))
+#define SvPVXtrue(sv) ( \
+ ((XPV*)SvANY((sv))) \
+ && ( \
+ ((XPV*)SvANY((sv)))->xpv_cur > 1 \
+ || ( \
+ ((XPV*)SvANY((sv)))->xpv_cur \
+ && *(sv)->sv_u.svu_pv != '0' \
+ ) \
+ ) \
+)
+
+#define SvIsCOW(sv) (SvFLAGS(sv) & SVf_IsCOW)
+#define SvIsCOW_on(sv) (SvFLAGS(sv) |= SVf_IsCOW)
+#define SvIsCOW_off(sv) (SvFLAGS(sv) &= ~SVf_IsCOW)
#define SvIsCOW_shared_hash(sv) (SvIsCOW(sv) && SvLEN(sv) == 0)
#define SvSHARED_HEK_FROM_PV(pvx) \
@@ -1765,6 +1822,12 @@
/* if (after resolving magic etc), the SV is found to be overloaded,
* don't call the overload magic, just return as-is */
#define SV_SKIP_OVERLOAD 8192
+/* It is not yet clear whether we want this as an API, or what the
+ * constants should be named. */
+#ifdef PERL_CORE
+# define SV_CATBYTES 16384
+# define SV_CATUTF8 32768
+#endif
/* The core is safe for this COW optimisation. XS code on CPAN may not be.
So only default to doing the COW setup if we're in the core.
@@ -1799,18 +1862,40 @@
((SvIsCOW(sv) ? sv_force_normal_flags(sv, 0) : (void) 0), 0)
# define SvIsCOW_normal(sv) (SvIsCOW(sv) && SvLEN(sv))
# define SvRELEASE_IVX_(sv) SvRELEASE_IVX(sv),
+# define SvCANCOW(sv) \
+ (SvIsCOW(sv) || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)
+/* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
+ on-write. */
+# define CAN_COW_MASK (SVs_OBJECT|SVs_GMG|SVs_SMG|SVs_RMG|SVf_IOK|SVf_NOK| \
+ SVf_POK|SVf_ROK|SVp_IOK|SVp_NOK|SVp_POK|SVf_FAKE| \
+ SVf_OOK|SVf_BREAK|SVf_READONLY)
#else
# define SvRELEASE_IVX(sv) 0
/* This little game brought to you by the need to shut this warning up:
-mg.c: In function `Perl_magic_get':
+mg.c: In function 'Perl_magic_get':
mg.c:1024: warning: left-hand operand of comma expression has no effect
*/
# define SvRELEASE_IVX_(sv) /**/
+# ifdef PERL_NEW_COPY_ON_WRITE
+# define SvCANCOW(sv) \
+ (SvIsCOW(sv) \
+ ? SvLEN(sv) ? CowREFCNT(sv) != SV_COW_REFCNT_MAX : 1 \
+ : (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS \
+ && SvCUR(sv)+1 < SvLEN(sv))
+ /* Note: To allow 256 COW "copies", a refcnt of 0 means 1. */
+# define CowREFCNT(sv) (*(U8 *)(SvPVX(sv)+SvLEN(sv)-1))
+# define SV_COW_REFCNT_MAX ((1 << sizeof(U8)*8) - 1)
+# ifndef SV_COW_THRESHOLD
+# define SV_COW_THRESHOLD 0 /* min string length for cow */
+# endif
+# ifndef SV_COWBUF_THRESHOLD
+# define SV_COWBUF_THRESHOLD 1250 /* min string length for cow */
+# endif /* over existing buffer */
+# define CAN_COW_MASK (SVf_POK|SVf_ROK|SVp_POK|SVf_FAKE| \
+ SVf_OOK|SVf_BREAK|SVf_READONLY)
+# endif
#endif /* PERL_OLD_COPY_ON_WRITE */
-#define CAN_COW_MASK (SVs_OBJECT|SVs_GMG|SVs_SMG|SVs_RMG|SVf_IOK|SVf_NOK| \
- SVf_POK|SVf_ROK|SVp_IOK|SVp_NOK|SVp_POK|SVf_FAKE| \
- SVf_OOK|SVf_BREAK|SVf_READONLY)
#define CAN_COW_FLAGS (SVp_POK|SVf_POK)
#define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) \
@@ -1835,8 +1920,9 @@
#define sv_catsv_nomg(dsv, ssv) sv_catsv_flags(dsv, ssv, 0)
#define sv_catsv_mg(dsv, ssv) sv_catsv_flags(dsv, ssv, SV_GMAGIC|SV_SMAGIC)
#define sv_catpvn(dsv, sstr, slen) sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC)
-#define sv_catpvn_mg(sv, sstr, slen) \
- sv_catpvn_flags(sv, sstr, slen, SV_GMAGIC|SV_SMAGIC);
+#define sv_catpvn_mg(sv, sstr, slen) sv_catpvn_flags(sv, sstr, slen, SV_GMAGIC|SV_SMAGIC);
+#define sv_copypv(dsv, ssv) sv_copypv_flags(dsv, ssv, SV_GMAGIC)
+#define sv_copypv_nomg(dsv, ssv) sv_copypv_flags(dsv, ssv, 0)
#define sv_2pv(sv, lp) sv_2pv_flags(sv, lp, SV_GMAGIC)
#define sv_2pv_nolen(sv) sv_2pv(sv, 0)
#define sv_2pvbyte_nolen(sv) sv_2pvbyte(sv, 0)
@@ -1852,12 +1938,15 @@
#define sv_cmp_locale(sv1, sv2) sv_cmp_locale_flags(sv1, sv2, SV_GMAGIC)
#define sv_collxfrm(sv, nxp) sv_cmp_flags(sv, nxp, SV_GMAGIC)
#define sv_2bool(sv) sv_2bool_flags(sv, SV_GMAGIC)
+#define sv_2bool_nomg(sv) sv_2bool_flags(sv, 0)
#define sv_insert(bigstr, offset, len, little, littlelen) \
Perl_sv_insert_flags(aTHX_ (bigstr),(offset), (len), (little), \
(littlelen), SV_GMAGIC)
+#define sv_mortalcopy(sv) \
+ Perl_sv_mortalcopy_flags(aTHX_ sv, SV_GMAGIC|SV_DO_COW_SVSETSV)
/* Should be named SvCatPVN_utf8_upgrade? */
-#define sv_catpvn_utf8_upgrade(dsv, sstr, slen, nsv) \
+#define sv_catpvn_nomg_utf8_upgrade(dsv, sstr, slen, nsv) \
STMT_START { \
if (!(nsv)) \
nsv = newSVpvn_flags(sstr, slen, SVs_TEMP); \
@@ -1865,9 +1954,19 @@
sv_setpvn(nsv, sstr, slen); \
SvUTF8_off(nsv); \
sv_utf8_upgrade(nsv); \
- sv_catsv(dsv, nsv); \
+ sv_catsv_nomg(dsv, nsv); \
} STMT_END
+#define sv_catpvn_nomg_maybeutf8(dsv, sstr, slen, is_utf8) \
+ sv_catpvn_flags(dsv, sstr, slen, (is_utf8)?SV_CATUTF8:SV_CATBYTES)
+#ifdef PERL_CORE
+# define sv_or_pv_len_utf8(sv, pv, bytelen) \
+ (SvGAMAGIC(sv) \
+ ? utf8_length((U8 *)(pv), (U8 *)(pv)+(bytelen)) \
+ : sv_len_utf8(sv))
+# define sv_or_pv_pos_u2b(sv,s,p,lp) S_sv_or_pv_pos_u2b(aTHX_ sv,s,p,lp)
+#endif
+
/*
=for apidoc Am|SV*|newRV_inc|SV* sv
@@ -1885,11 +1984,14 @@
=head1 Magical Functions
=for apidoc Am|void|SvGETMAGIC|SV* sv
-Invokes C<mg_get> on an SV if it has 'get' magic. This macro evaluates its
+Invokes C<mg_get> on an SV if it has 'get' magic. For example, this
+will call C<FETCH> on a tied variable. This macro evaluates its
argument more than once.
=for apidoc Am|void|SvSETMAGIC|SV* sv
-Invokes C<mg_set> on an SV if it has 'set' magic. This macro evaluates its
+Invokes C<mg_set> on an SV if it has 'set' magic. This is necessary
+after modifying a scalar, in case it is a magical variable like C<$|>
+or a tied variable (it calls C<STORE>). This macro evaluates its
argument more than once.
=for apidoc Am|void|SvSetSV|SV* dsb|SV* ssv
@@ -1898,7 +2000,7 @@
=for apidoc Am|void|SvSetSV_nosteal|SV* dsv|SV* ssv
Calls a non-destructive version of C<sv_setsv> if dsv is not the same as
-ssv. May evaluate arguments more than once.
+ssv. May evaluate arguments more than once.
=for apidoc Am|void|SvSetMagicSV|SV* dsb|SV* ssv
Like C<SvSetSV>, but does any set magic required afterwards.
@@ -1924,7 +2026,8 @@
Expands the character buffer in the SV so that it has room for the
indicated number of bytes (remember to reserve space for an extra trailing
NUL character). Calls C<sv_grow> to perform the expansion if necessary.
-Returns a pointer to the character buffer.
+Returns a pointer to the character buffer. SV must be of type >= SVt_PV. One
+alternative is to call C<sv_grow> if you are not sure of the type of SV.
=cut
*/
@@ -1934,7 +2037,7 @@
#define SvUNLOCK(sv) PL_unlockhook(aTHX_ sv)
#define SvDESTROYABLE(sv) PL_destroyhook(aTHX_ sv)
-#define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
+#define SvGETMAGIC(x) ((void)(SvGMAGICAL(x) && mg_get(x)))
#define SvSETMAGIC(x) STMT_START { if (SvSMAGICAL(x)) mg_set(x); } STMT_END
#define SvSetSV_and(dst,src,finally) \
@@ -1969,8 +2072,25 @@
#define SvPEEK(sv) ""
#endif
-#define SvIMMORTAL(sv) ((sv)==&PL_sv_undef || (sv)==&PL_sv_yes || (sv)==&PL_sv_no || (sv)==&PL_sv_placeholder)
+#define SvIMMORTAL(sv) (SvREADONLY(sv) && ((sv)==&PL_sv_undef || (sv)==&PL_sv_yes || (sv)==&PL_sv_no || (sv)==&PL_sv_placeholder))
+#ifdef DEBUGGING
+ /* exercise the immortal resurrection code in sv_free2() */
+# define SvREFCNT_IMMORTAL 1000
+#else
+# define SvREFCNT_IMMORTAL ((~(U32)0)/2)
+#endif
+
+/*
+=for apidoc Am|SV *|boolSV|bool b
+
+Returns a true SV if C<b> is a true value, or a false SV if C<b> is 0.
+
+See also C<PL_sv_yes> and C<PL_sv_no>.
+
+=cut
+*/
+
#define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
#define isGV(sv) (SvTYPE(sv) == SVt_PVGV)
@@ -1991,9 +2111,18 @@
assert (!SvIOKp(sv)); \
(SvFLAGS(sv) &= ~SVpgv_GP); \
} STMT_END
+#define isREGEXP(sv) \
+ (SvTYPE(sv) == SVt_REGEXP \
+ || (SvFLAGS(sv) & (SVTYPEMASK|SVp_POK|SVpgv_GP|SVf_FAKE)) \
+ == (SVt_PVLV|SVf_FAKE))
-#define SvGROW(sv,len) (SvLEN(sv) < (len) ? sv_grow(sv,len) : SvPVX(sv))
+#ifdef PERL_NEW_COPY_ON_WRITE
+# define SvGROW(sv,len) \
+ (SvIsCOW(sv) || SvLEN(sv) < (len) ? sv_grow(sv,len) : SvPVX(sv))
+#else
+# define SvGROW(sv,len) (SvLEN(sv) < (len) ? sv_grow(sv,len) : SvPVX(sv))
+#endif
#define SvGROW_mutable(sv,len) \
(SvLEN(sv) < (len) ? sv_grow(sv,len) : SvPVX_mutable(sv))
#define Sv_Grow sv_grow
@@ -2023,13 +2152,25 @@
#define newSVpvn_utf8(s, len, u) newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
/*
+=for apidoc Amx|SV*|newSVpadname|PADNAME *pn
+
+Creates a new SV containing the pad name. This is currently identical
+to C<newSVsv>, but pad names may cease being SVs at some point, so
+C<newSVpadname> is preferable.
+
+=cut
+*/
+
+#define newSVpadname(pn) newSVsv(pn)
+
+/*
=for apidoc Am|void|SvOOK_offset|NN SV*sv|STRLEN len
Reads into I<len> the offset from SvPVX back to the true start of the
allocated buffer, which will be non-zero if C<sv_chop> has been used to
-efficiently remove characters from start of the buffer. Implemented as a
+efficiently remove characters from start of the buffer. Implemented as a
macro, which takes the address of I<len>, which must be of type C<STRLEN>.
-Evaluates I<sv> more than once. Sets I<len> to 0 if C<SvOOK(sv)> is false.
+Evaluates I<sv> more than once. Sets I<len> to 0 if C<SvOOK(sv)> is false.
=cut
*/
@@ -2042,23 +2183,23 @@
# define SvOOK_offset(sv, offset) STMT_START { \
assert(sizeof(offset) == sizeof(STRLEN)); \
if (SvOOK(sv)) { \
- const U8 *crash = (U8*)SvPVX_const(sv); \
- offset = *--crash; \
- if (!offset) { \
- crash -= sizeof(STRLEN); \
- Copy(crash, (U8 *)&offset, sizeof(STRLEN), U8); \
+ const U8 *_crash = (U8*)SvPVX_const(sv); \
+ (offset) = *--_crash; \
+ if (!(offset)) { \
+ _crash -= sizeof(STRLEN); \
+ Copy(_crash, (U8 *)&(offset), sizeof(STRLEN), U8); \
} \
{ \
/* Validate the preceding buffer's sentinels to \
verify that no-one is using it. */ \
- const U8 *const bonk = (U8 *) SvPVX_const(sv) - offset; \
- while (crash > bonk) { \
- --crash; \
- assert (*crash == (U8)PTR2UV(crash)); \
+ const U8 *const _bonk = (U8*)SvPVX_const(sv) - (offset);\
+ while (_crash > _bonk) { \
+ --_crash; \
+ assert (*_crash == (U8)PTR2UV(_crash)); \
} \
} \
} else { \
- offset = 0; \
+ (offset) = 0; \
} \
} STMT_END
#else
@@ -2066,13 +2207,13 @@
# define SvOOK_offset(sv, offset) STMT_START { \
assert(sizeof(offset) == sizeof(STRLEN)); \
if (SvOOK(sv)) { \
- offset = ((U8*)SvPVX_const(sv))[-1]; \
- if (!offset) { \
+ (offset) = ((U8*)SvPVX_const(sv))[-1]; \
+ if (!(offset)) { \
Copy(SvPVX_const(sv) - 1 - sizeof(STRLEN), \
- (U8 *)&offset, sizeof(STRLEN), U8); \
+ (U8*)&(offset), sizeof(STRLEN), U8); \
} \
} else { \
- offset = 0; \
+ (offset) = 0; \
} \
} STMT_END
#endif
@@ -2083,8 +2224,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/sv.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.4
\ No newline at end of property
Modified: trunk/contrib/perl/taint.c
===================================================================
--- trunk/contrib/perl/taint.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/taint.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -11,7 +11,7 @@
/*
* '...we will have peace, when you and all your works have perished--and
* the works of your dark master to whom you would deliver us. You are a
- * liar, Saruman, and a corrupter of men's hearts.' --Th\xE9oden
+ * liar, Saruman, and a corrupter of men's hearts.' --Théoden
*
* [p.580 of _The Lord of the Rings_, III/x: "The Voice of Saruman"]
*/
@@ -33,39 +33,39 @@
# if Uid_t_size == 1
{
- const UV uid = PL_uid;
- const UV euid = PL_euid;
+ const UV uid = PerlProc_getuid();
+ const UV euid = PerlProc_geteuid();
DEBUG_u(PerlIO_printf(Perl_debug_log,
"%s %d %"UVuf" %"UVuf"\n",
- s, PL_tainted, uid, euid));
+ s, TAINT_get, uid, euid));
}
# else
{
- const IV uid = PL_uid;
- const IV euid = PL_euid;
+ const IV uid = PerlProc_getuid();
+ const IV euid = PerlProc_geteuid();
DEBUG_u(PerlIO_printf(Perl_debug_log,
"%s %d %"IVdf" %"IVdf"\n",
- s, PL_tainted, uid, euid));
+ s, TAINT_get, uid, euid));
}
# endif
#endif
- if (PL_tainted) {
+ if (TAINT_get) {
const char *ug;
if (!f)
f = PL_no_security;
- if (PL_euid != PL_uid)
+ if (PerlProc_getuid() != PerlProc_geteuid())
ug = " while running setuid";
- else if (PL_egid != PL_gid)
+ else if (PerlProc_getgid() != PerlProc_getegid())
ug = " while running setgid";
- else if (PL_taint_warn)
+ else if (TAINT_WARN_get)
ug = " while running with -t switch";
else
ug = " while running with -T switch";
- if (PL_unsafe || PL_taint_warn) {
+ if (PL_unsafe || TAINT_WARN_get) {
Perl_ck_warner_d(aTHX_ packWARN(WARN_TAINT), f, s, ug);
}
else {
@@ -95,13 +95,13 @@
/* Don't bother if there's no *ENV glob */
if (!PL_envgv)
return;
- /* If there's no %ENV hash of if it's not magical, croak, because
+ /* If there's no %ENV hash or if it's not magical, croak, because
* it probably doesn't reflect the actual environment */
if (!GvHV(PL_envgv) || !(SvRMAGICAL(GvHV(PL_envgv))
&& mg_find((const SV *)GvHV(PL_envgv), PERL_MAGIC_env))) {
- const bool was_tainted = PL_tainted;
+ const bool was_tainted = TAINT_get;
const char * const name = GvENAME(PL_envgv);
- PL_tainted = TRUE;
+ TAINT;
if (strEQ(name,"ENV"))
/* hash alias */
taint_proper("%%ENV is aliased to %s%s", "another variable");
@@ -109,7 +109,10 @@
/* glob alias: report it in the error message */
taint_proper("%%ENV is aliased to %%%s%s", name);
/* this statement is reached under -t or -U */
- PL_tainted = was_tainted;
+ TAINT_set(was_tainted);
+#ifdef NO_TAINT_SUPPORT
+ PERL_UNUSED_VAR(was_tainted);
+#endif
}
#ifdef VMS
@@ -154,13 +157,17 @@
svp = hv_fetchs(GvHVn(PL_envgv),"TERM",FALSE);
if (svp && *svp && SvTAINTED(*svp)) {
STRLEN len;
- const bool was_tainted = PL_tainted;
+ const bool was_tainted = TAINT_get;
const char *t = SvPV_const(*svp, len);
const char * const e = t + len;
- PL_tainted = was_tainted;
- if (t < e && isALNUM(*t))
+
+ TAINT_set(was_tainted);
+#ifdef NO_TAINT_SUPPORT
+ PERL_UNUSED_VAR(was_tainted);
+#endif
+ if (t < e && isWORDCHAR(*t))
t++;
- while (t < e && (isALNUM(*t) || strchr("-_.+", *t)))
+ while (t < e && (isWORDCHAR(*t) || strchr("-_.+", *t)))
t++;
if (t < e) {
TAINT;
@@ -182,8 +189,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/taint.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/thread.h
===================================================================
--- trunk/contrib/perl/thread.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/thread.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -40,9 +40,6 @@
# define NEED_PTHREAD_INIT
# define PTHREAD_CREATE_JOINABLE (1)
# endif
-# ifdef __OPEN_VM
-# define pthread_addr_t void *
-# endif
# ifdef OEMVS
# define pthread_addr_t void *
# define pthread_create(t,a,s,d) pthread_create(t,&(a),s,d)
@@ -65,7 +62,7 @@
# define pthread_mutexattr_init(a) pthread_mutexattr_create(a)
# define pthread_mutexattr_settype(a,t) pthread_mutexattr_setkind_np(a,t)
# endif
-# if defined(DJGPP) || defined(__OPEN_VM) || defined(OEMVS)
+# if defined(DJGPP) || defined(OEMVS)
# define PTHREAD_ATTR_SETDETACHSTATE(a,s) pthread_attr_setdetachstate(a,&(s))
# define YIELD pthread_yield(NULL)
# endif
@@ -441,8 +438,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/thread.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/time64.c
===================================================================
--- trunk/contrib/perl/time64.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/time64.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -269,34 +269,31 @@
static void S_copy_little_tm_to_big_TM(const struct tm *src, struct TM *dest) {
- if( src == NULL ) {
- memset(dest, 0, sizeof(*dest));
- }
- else {
-# ifdef USE_TM64
- dest->tm_sec = src->tm_sec;
- dest->tm_min = src->tm_min;
- dest->tm_hour = src->tm_hour;
- dest->tm_mday = src->tm_mday;
- dest->tm_mon = src->tm_mon;
- dest->tm_year = (Year)src->tm_year;
- dest->tm_wday = src->tm_wday;
- dest->tm_yday = src->tm_yday;
- dest->tm_isdst = src->tm_isdst;
+ assert(src);
+ assert(dest);
+#ifdef USE_TM64
+ dest->tm_sec = src->tm_sec;
+ dest->tm_min = src->tm_min;
+ dest->tm_hour = src->tm_hour;
+ dest->tm_mday = src->tm_mday;
+ dest->tm_mon = src->tm_mon;
+ dest->tm_year = (Year)src->tm_year;
+ dest->tm_wday = src->tm_wday;
+ dest->tm_yday = src->tm_yday;
+ dest->tm_isdst = src->tm_isdst;
-# ifdef HAS_TM_TM_GMTOFF
- dest->tm_gmtoff = src->tm_gmtoff;
-# endif
+# ifdef HAS_TM_TM_GMTOFF
+ dest->tm_gmtoff = src->tm_gmtoff;
+# endif
-# ifdef HAS_TM_TM_ZONE
- dest->tm_zone = src->tm_zone;
-# endif
+# ifdef HAS_TM_TM_ZONE
+ dest->tm_zone = src->tm_zone;
+# endif
-# else
- /* They're the same type */
- memcpy(dest, src, sizeof(*dest));
-# endif
- }
+#else
+ /* They're the same type */
+ memcpy(dest, src, sizeof(*dest));
+#endif
}
@@ -303,7 +300,9 @@
#ifndef HAS_LOCALTIME_R
/* Simulate localtime_r() to the best of our ability */
static struct tm * S_localtime_r(const time_t *clock, struct tm *result) {
+#ifdef VMS
dTHX; /* in case the following is defined as Perl_my_localtime(aTHX_ ...) */
+#endif
const struct tm *static_result = localtime(clock);
assert(result != NULL);
Property changes on: trunk/contrib/perl/time64.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/time64.h
===================================================================
--- trunk/contrib/perl/time64.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/time64.h 2013-12-02 21:18:17 UTC (rev 6438)
Property changes on: trunk/contrib/perl/time64.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Index: trunk/contrib/perl/time64_config.h
===================================================================
--- trunk/contrib/perl/time64_config.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/time64_config.h 2013-12-02 21:18:17 UTC (rev 6438)
Property changes on: trunk/contrib/perl/time64_config.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
Modified: trunk/contrib/perl/toke.c
===================================================================
--- trunk/contrib/perl/toke.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/toke.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -66,7 +66,6 @@
#define PL_multi_start (PL_parser->multi_start)
#define PL_multi_open (PL_parser->multi_open)
#define PL_multi_close (PL_parser->multi_close)
-#define PL_pending_ident (PL_parser->pending_ident)
#define PL_preambled (PL_parser->preambled)
#define PL_sublex_info (PL_parser->sublex_info)
#define PL_linestr (PL_parser->linestr)
@@ -111,13 +110,8 @@
# define PL_nextval (PL_parser->nextval)
#endif
-/* This can't be done with embed.fnc, because struct yy_parser contains a
- member named pending_ident, which clashes with the generated #define */
-static int
-S_pending_ident(pTHX);
+static const char* const ident_too_long = "Identifier too long";
-static const char ident_too_long[] = "Identifier too long";
-
#ifdef PERL_MAD
# define CURMAD(slot,sv) if (PL_madskills) { curmad(slot,sv); sv = 0; }
# define NEXTVAL_NEXTTOKE PL_nexttoke[PL_curforce].next_val
@@ -133,7 +127,7 @@
#ifdef USE_UTF8_SCRIPTS
# define UTF (!IN_BYTES)
#else
-# define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
+# define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || ( !(PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS) && (PL_hints & HINT_UTF8)))
#endif
/* The maximum number of characters preceding the unrecognized one to display */
@@ -148,6 +142,9 @@
/* LEX_* are values for PL_lex_state, the state of the lexer.
* They are arranged oddly so that the guard on the switch statement
* can get by with a single comparison (if the compiler is smart enough).
+ *
+ * These values refer to the various states within a sublex parse,
+ * i.e. within a double quotish string
*/
/* #define LEX_NOTPARSING 11 is done in perl.h. */
@@ -224,6 +221,7 @@
* LOOPX : loop exiting command (goto, last, dump, etc)
* FTST : file test operator
* FUN0 : zero-argument function
+ * FUN0OP : zero-argument function, with its op created in this file
* FUN1 : not used, except for not, which isn't a UNIOP
* BOop : bitwise or or xor
* BAop : bitwise and
@@ -254,6 +252,7 @@
#define LOOPX(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
#define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
#define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
+#define FUN0OP(f) return (pl_yylval.opval=f, CLINE, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0OP))
#define 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)))
@@ -270,9 +269,9 @@
* The UNIDOR macro is for unary functions that can be followed by the //
* operator (such as C<shift // 0>).
*/
-#define UNI2(f,x) { \
+#define UNI3(f,x,have_x) { \
pl_yylval.ival = f; \
- PL_expect = x; \
+ if (have_x) PL_expect = x; \
PL_bufptr = s; \
PL_last_uni = PL_oldbufptr; \
PL_last_lop_op = f; \
@@ -281,19 +280,15 @@
s = PEEKSPACE(s); \
return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
}
-#define UNI(f) UNI2(f,XTERM)
-#define UNIDOR(f) UNI2(f,XTERMORDORDOR)
-
-#define UNIBRACK(f) { \
- pl_yylval.ival = f; \
- PL_bufptr = s; \
- PL_last_uni = PL_oldbufptr; \
- if (*s == '(') \
- return REPORT( (int)FUNC1 ); \
- s = PEEKSPACE(s); \
- return REPORT( (*s == '(') ? (int)FUNC1 : (int)UNIOP ); \
+#define UNI(f) UNI3(f,XTERM,1)
+#define UNIDOR(f) UNI3(f,XTERMORDORDOR,1)
+#define UNIPROTO(f,optional) { \
+ if (optional) PL_last_uni = PL_oldbufptr; \
+ OPERATOR(f); \
}
+#define UNIBRACK(f) UNI3(f,0,0)
+
/* grandfather return to old style */
#define OLDLOP(f) \
do { \
@@ -305,6 +300,15 @@
return (int)LSTOP; \
} while(0)
+#define COPLINE_INC_WITH_HERELINES \
+ STMT_START { \
+ CopLINE_inc(PL_curcop); \
+ if (PL_parser->lex_shared->herelines) \
+ CopLINE(PL_curcop) += PL_parser->lex_shared->herelines, \
+ PL_parser->lex_shared->herelines = 0; \
+ } STMT_END
+
+
#ifdef DEBUGGING
/* how to interpret the pl_yylval associated with the token */
@@ -313,8 +317,7 @@
TOKENTYPE_IVAL,
TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
TOKENTYPE_PVAL,
- TOKENTYPE_OPVAL,
- TOKENTYPE_GVVAL
+ TOKENTYPE_OPVAL
};
static struct debug_tokens {
@@ -344,8 +347,11 @@
{ EQOP, TOKENTYPE_OPNUM, "EQOP" },
{ FOR, TOKENTYPE_IVAL, "FOR" },
{ FORMAT, TOKENTYPE_NONE, "FORMAT" },
+ { FORMLBRACK, TOKENTYPE_NONE, "FORMLBRACK" },
+ { FORMRBRACK, TOKENTYPE_NONE, "FORMRBRACK" },
{ FUNC, TOKENTYPE_OPNUM, "FUNC" },
{ FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
+ { FUNC0OP, TOKENTYPE_OPVAL, "FUNC0OP" },
{ FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
{ FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
{ FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
@@ -361,12 +367,12 @@
{ METHOD, TOKENTYPE_OPVAL, "METHOD" },
{ MULOP, TOKENTYPE_OPNUM, "MULOP" },
{ MY, TOKENTYPE_IVAL, "MY" },
- { MYSUB, TOKENTYPE_NONE, "MYSUB" },
{ NOAMP, TOKENTYPE_NONE, "NOAMP" },
{ NOTOP, TOKENTYPE_NONE, "NOTOP" },
{ OROP, TOKENTYPE_IVAL, "OROP" },
{ OROR, TOKENTYPE_NONE, "OROR" },
{ PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
+ { PEG, TOKENTYPE_NONE, "PEG" },
{ PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
{ PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
{ PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
@@ -376,8 +382,10 @@
{ PREDEC, TOKENTYPE_NONE, "PREDEC" },
{ PREINC, TOKENTYPE_NONE, "PREINC" },
{ PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
+ { QWLIST, TOKENTYPE_OPVAL, "QWLIST" },
{ REFGEN, TOKENTYPE_NONE, "REFGEN" },
{ RELOP, TOKENTYPE_OPNUM, "RELOP" },
+ { REQUIRE, TOKENTYPE_NONE, "REQUIRE" },
{ SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
{ SUB, TOKENTYPE_NONE, "SUB" },
{ THING, TOKENTYPE_OPVAL, "THING" },
@@ -418,7 +426,7 @@
}
if (name)
Perl_sv_catpv(aTHX_ report, name);
- else if ((char)rv > ' ' && (char)rv < '~')
+ else if ((char)rv > ' ' && (char)rv <= '~')
Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
else if (!rv)
sv_catpvs(report, "EOF");
@@ -426,7 +434,6 @@
Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
switch (type) {
case TOKENTYPE_NONE:
- case TOKENTYPE_GVVAL: /* doesn't appear to be used */
break;
case TOKENTYPE_IVAL:
Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival);
@@ -530,7 +537,7 @@
s = oldbp;
else
PL_bufptr = s;
- yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
+ yywarn(Perl_form(aTHX_ "%s found where operator expected", what), UTF ? SVf_UTF8 : 0);
if (ckWARN_d(WARN_SYNTAX)) {
if (is_first)
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
@@ -537,17 +544,21 @@
"\t(Missing semicolon on previous line?)\n");
else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
const char *t;
- for (t = PL_oldoldbufptr; (isALNUM_lazy_if(t,UTF) || *t == ':'); t++)
+ for (t = PL_oldoldbufptr; (isWORDCHAR_lazy_if(t,UTF) || *t == ':');
+ t += UTF ? UTF8SKIP(t) : 1)
NOOP;
if (t < PL_bufptr && isSPACE(*t))
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "\t(Do you need to predeclare %.*s?)\n",
- (int)(t - PL_oldoldbufptr), PL_oldoldbufptr);
+ "\t(Do you need to predeclare %"SVf"?)\n",
+ SVfARG(newSVpvn_flags(PL_oldoldbufptr, (STRLEN)(t - PL_oldoldbufptr),
+ SVs_TEMP | (UTF ? SVf_UTF8 : 0))));
}
else {
assert(s >= oldbp);
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "\t(Missing operator before %.*s?)\n", (int)(s - oldbp), oldbp);
+ "\t(Missing operator before %"SVf"?)\n",
+ SVfARG(newSVpvn_flags(oldbp, (STRLEN)(s - oldbp),
+ SVs_TEMP | (UTF ? SVf_UTF8 : 0))));
}
}
PL_bufptr = oldbp;
@@ -588,6 +599,8 @@
Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
}
+#include "feature.h"
+
/*
* Check whether the named feature is enabled.
*/
@@ -595,16 +608,18 @@
Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
{
dVAR;
- HV * const hinthv = GvHV(PL_hintgv);
char he_name[8 + MAX_FEATURE_LEN] = "feature_";
PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
+ assert(CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM);
+
if (namelen > MAX_FEATURE_LEN)
return FALSE;
memcpy(&he_name[8], name, namelen);
- return (hinthv && hv_exists(hinthv, he_name, 8 + namelen));
+ return cBOOL(cop_hints_fetch_pvn(PL_curcop, he_name, 8 + namelen, 0,
+ REFCOUNTED_HE_EXISTS));
}
/*
@@ -616,8 +631,8 @@
static void
strip_return(SV *sv)
{
- register const char *s = SvPVX_const(sv);
- register const char * const e = s + SvCUR(sv);
+ const char *s = SvPVX_const(sv);
+ const char * const e = s + SvCUR(sv);
PERL_ARGS_ASSERT_STRIP_RETURN;
@@ -625,7 +640,7 @@
while (s < e) {
if (*s++ == '\r' && *s == '\n') {
/* hit a CR-LF, need to copy the rest */
- register char *d = s - 1;
+ char *d = s - 1;
*d++ = *s++;
while (s < e) {
if (*s == '\r' && s[1] == '\n')
@@ -666,15 +681,20 @@
code in I<line> comes first and must consist of complete lines of input,
and I<rsfp> supplies the remainder of the source.
-The I<flags> parameter is reserved for future use, and must always
-be zero, except for one flag that is currently reserved for perl's internal
-use.
+The I<flags> parameter is reserved for future use. Currently it is only
+used by perl internally, so extensions should always pass zero.
=cut
*/
/* LEX_START_SAME_FILTER indicates that this is not a new file, so it
- can share filters with the current parser. */
+ can share filters with the current parser.
+ LEX_START_DONT_CLOSE indicates that the file handle wasn't opened by the
+ caller, hence isn't owned by the parser, so shouldn't be closed on parser
+ destruction. This is used to handle the case of defaulting to reading the
+ script from the standard input because no filename was given on the command
+ line (without getting confused by situation where STDIN has been closed, so
+ the script handle is opened on fd 0) */
void
Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
@@ -681,9 +701,8 @@
{
dVAR;
const char *s = NULL;
- STRLEN len;
yy_parser *parser, *oparser;
- if (flags && flags != LEX_START_SAME_FILTER)
+ if (flags && flags & ~LEX_START_FLAGS)
Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
/* create and initialise a parser */
@@ -714,25 +733,27 @@
parser->rsfp = rsfp;
parser->rsfp_filters =
!(flags & LEX_START_SAME_FILTER) || !oparser
- ? newAV()
- : MUTABLE_AV(SvREFCNT_inc(oparser->rsfp_filters));
+ ? NULL
+ : MUTABLE_AV(SvREFCNT_inc(
+ oparser->rsfp_filters
+ ? oparser->rsfp_filters
+ : (oparser->rsfp_filters = newAV())
+ ));
Newx(parser->lex_brackstack, 120, char);
Newx(parser->lex_casestack, 12, char);
*parser->lex_casestack = '\0';
+ Newxz(parser->lex_shared, 1, LEXSHARED);
if (line) {
+ STRLEN len;
s = SvPV_const(line, len);
+ parser->linestr = flags & LEX_START_COPIED
+ ? SvREFCNT_inc_simple_NN(line)
+ : newSVpvn_flags(s, len, SvUTF8(line));
+ sv_catpvs(parser->linestr, "\n;");
} else {
- len = 0;
- }
-
- if (!len) {
parser->linestr = newSVpvs("\n;");
- } else {
- parser->linestr = newSVpvn_flags(s, len, SvUTF8(line));
- if (s[len-1] != ';')
- sv_catpvs(parser->linestr, "\n;");
}
parser->oldoldbufptr =
parser->oldbufptr =
@@ -740,8 +761,10 @@
parser->linestart = SvPVX(parser->linestr);
parser->bufend = parser->bufptr + SvCUR(parser->linestr);
parser->last_lop = parser->last_uni = NULL;
+ parser->lex_flags = flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
+ |LEX_DONT_CLOSE_RSFP);
- parser->in_pod = 0;
+ parser->in_pod = parser->filtered = 0;
}
@@ -755,20 +778,54 @@
PL_curcop = parser->saved_curcop;
SvREFCNT_dec(parser->linestr);
- if (parser->rsfp == PerlIO_stdin())
+ if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
PerlIO_clearerr(parser->rsfp);
else if (parser->rsfp && (!parser->old_parser ||
(parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
PerlIO_close(parser->rsfp);
SvREFCNT_dec(parser->rsfp_filters);
+ SvREFCNT_dec(parser->lex_stuff);
+ SvREFCNT_dec(parser->sublex_info.repl);
Safefree(parser->lex_brackstack);
Safefree(parser->lex_casestack);
+ Safefree(parser->lex_shared);
PL_parser = parser->old_parser;
Safefree(parser);
}
+void
+Perl_parser_free_nexttoke_ops(pTHX_ yy_parser *parser, OPSLAB *slab)
+{
+#ifdef PERL_MAD
+ I32 nexttoke = parser->lasttoke;
+#else
+ I32 nexttoke = parser->nexttoke;
+#endif
+ PERL_ARGS_ASSERT_PARSER_FREE_NEXTTOKE_OPS;
+ while (nexttoke--) {
+#ifdef PERL_MAD
+ if (S_is_opval_token(parser->nexttoke[nexttoke].next_type
+ & 0xffff)
+ && parser->nexttoke[nexttoke].next_val.opval
+ && parser->nexttoke[nexttoke].next_val.opval->op_slabbed
+ && OpSLAB(parser->nexttoke[nexttoke].next_val.opval) == slab) {
+ op_free(parser->nexttoke[nexttoke].next_val.opval);
+ parser->nexttoke[nexttoke].next_val.opval = NULL;
+ }
+#else
+ if (S_is_opval_token(parser->nexttype[nexttoke] & 0xffff)
+ && parser->nextval[nexttoke].opval
+ && parser->nextval[nexttoke].opval->op_slabbed
+ && OpSLAB(parser->nextval[nexttoke].opval) == slab) {
+ op_free(parser->nextval[nexttoke].opval);
+ parser->nextval[nexttoke].opval = NULL;
+ }
+#endif
+ }
+}
+
/*
=for apidoc AmxU|SV *|PL_parser-E<gt>linestr
@@ -887,7 +944,7 @@
SV *linestr;
char *buf;
STRLEN bufend_pos, bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
- STRLEN linestart_pos, last_uni_pos, last_lop_pos;
+ STRLEN linestart_pos, last_uni_pos, last_lop_pos, re_eval_start_pos;
linestr = PL_parser->linestr;
buf = SvPVX(linestr);
if (len <= SvLEN(linestr))
@@ -899,7 +956,11 @@
linestart_pos = PL_parser->linestart - buf;
last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
+ re_eval_start_pos = PL_parser->lex_shared->re_eval_start ?
+ PL_parser->lex_shared->re_eval_start - buf : 0;
+
buf = sv_grow(linestr, len);
+
PL_parser->bufend = buf + bufend_pos;
PL_parser->bufptr = buf + bufptr_pos;
PL_parser->oldbufptr = buf + oldbufptr_pos;
@@ -909,6 +970,8 @@
PL_parser->last_uni = buf + last_uni_pos;
if (PL_parser->last_lop)
PL_parser->last_lop = buf + last_lop_pos;
+ if (PL_parser->lex_shared->re_eval_start)
+ PL_parser->lex_shared->re_eval_start = buf + re_eval_start_pos;
return buf;
}
@@ -946,10 +1009,13 @@
if (flags & LEX_STUFF_UTF8) {
goto plain_copy;
} else {
- STRLEN highhalf = 0;
+ STRLEN highhalf = 0; /* Count of variants */
const char *p, *e = pv+len;
- for (p = pv; p != e; p++)
- highhalf += !!(((U8)*p) & 0x80);
+ for (p = pv; p != e; p++) {
+ if (! UTF8_IS_INVARIANT(*p)) {
+ highhalf++;
+ }
+ }
if (!highhalf)
goto plain_copy;
lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf);
@@ -960,9 +1026,9 @@
PL_parser->bufend += len+highhalf;
for (p = pv; p != e; p++) {
U8 c = (U8)*p;
- if (c & 0x80) {
- *bufptr++ = (char)(0xc0 | (c >> 6));
- *bufptr++ = (char)(0x80 | (c & 0x3f));
+ if (! UTF8_IS_INVARIANT(c)) {
+ *bufptr++ = UTF8_TWO_BYTE_HI(c);
+ *bufptr++ = UTF8_TWO_BYTE_LO(c);
} else {
*bufptr++ = (char)c;
}
@@ -974,14 +1040,13 @@
const char *p, *e = pv+len;
for (p = pv; p != e; p++) {
U8 c = (U8)*p;
- if (c >= 0xc4) {
+ if (UTF8_IS_ABOVE_LATIN1(c)) {
Perl_croak(aTHX_ "Lexing code attempted to stuff "
"non-Latin-1 character into Latin-1 input");
- } else if (c >= 0xc2 && p+1 != e &&
- (((U8)p[1]) & 0xc0) == 0x80) {
+ } else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, e)) {
p++;
highhalf++;
- } else if (c >= 0x80) {
+ } else if (! UTF8_IS_INVARIANT(c)) {
/* malformed UTF-8 */
ENTER;
SAVESPTR(PL_warnhook);
@@ -998,17 +1063,20 @@
SvCUR_set(PL_parser->linestr,
SvCUR(PL_parser->linestr) + len-highhalf);
PL_parser->bufend += len-highhalf;
- for (p = pv; p != e; p++) {
- U8 c = (U8)*p;
- if (c & 0x80) {
- *bufptr++ = (char)(((c & 0x3) << 6) | (p[1] & 0x3f));
- p++;
- } else {
- *bufptr++ = (char)c;
+ p = pv;
+ while (p < e) {
+ if (UTF8_IS_INVARIANT(*p)) {
+ *bufptr++ = *p;
+ p++;
}
+ else {
+ assert(p < e -1 );
+ *bufptr++ = TWO_BYTE_UTF8_TO_UNI(*p, *(p+1));
+ p += 2;
+ }
}
} else {
- plain_copy:
+ plain_copy:
lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len);
bufptr = PL_parser->bufptr;
Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char);
@@ -1139,7 +1207,7 @@
Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to");
for (; s != ptr; s++)
if (*s == '\n') {
- CopLINE_inc(PL_curcop);
+ COPLINE_INC_WITH_HERELINES;
PL_parser->linestart = s+1;
}
PL_parser->bufptr = ptr;
@@ -1222,6 +1290,7 @@
*/
#define LEX_FAKE_EOF 0x80000000
+#define LEX_NO_TERM 0x40000000
bool
Perl_lex_next_chunk(pTHX_ U32 flags)
@@ -1233,7 +1302,7 @@
STRLEN linestart_pos, last_uni_pos, last_lop_pos;
bool got_some_for_debugger = 0;
bool got_some;
- if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF))
+ if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF|LEX_NO_TERM))
Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
linestr = PL_parser->linestr;
buf = SvPVX(linestr);
@@ -1259,11 +1328,13 @@
}
if (flags & LEX_FAKE_EOF) {
goto eof;
- } else if (!PL_parser->rsfp) {
+ } else if (!PL_parser->rsfp && !PL_parser->filtered) {
got_some = 0;
} else if (filter_gets(linestr, old_bufend_pos)) {
got_some = 1;
got_some_for_debugger = 1;
+ } else if (flags & LEX_NO_TERM) {
+ got_some = 0;
} else {
if (!SvPOK(linestr)) /* can get undefined by filter_gets */
sv_setpvs(linestr, "");
@@ -1271,12 +1342,12 @@
/* End of real input. Close filehandle (unless it was STDIN),
* then add implicit termination.
*/
- if ((PerlIO*)PL_parser->rsfp == PerlIO_stdin())
+ if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
PerlIO_clearerr(PL_parser->rsfp);
else if (PL_parser->rsfp)
(void)PerlIO_close(PL_parser->rsfp);
PL_parser->rsfp = NULL;
- PL_parser->in_pod = 0;
+ PL_parser->in_pod = PL_parser->filtered = 0;
#ifdef PERL_MAD
if (PL_madskills && !PL_in_eval && (PL_minus_p || PL_minus_n))
PL_faketokens = 1;
@@ -1353,10 +1424,10 @@
bufend = PL_parser->bufend;
}
head = (U8)*s;
- if (!(head & 0x80))
+ if (UTF8_IS_INVARIANT(head))
return head;
- if (head & 0x40) {
- len = PL_utf8skip[head];
+ if (UTF8_IS_START(head)) {
+ len = UTF8SKIP(&head);
while ((STRLEN)(bufend-s) < len) {
if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS))
break;
@@ -1413,8 +1484,11 @@
c = lex_peek_unichar(flags);
if (c != -1) {
if (c == '\n')
- CopLINE_inc(PL_curcop);
- PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
+ COPLINE_INC_WITH_HERELINES;
+ if (UTF)
+ PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
+ else
+ ++(PL_parser->bufptr);
}
return c;
}
@@ -1479,7 +1553,7 @@
if (flags & LEX_NO_NEXT_CHUNK)
break;
PL_parser->bufptr = s;
- CopLINE_inc(PL_curcop);
+ COPLINE_INC_WITH_HERELINES;
got_more = lex_next_chunk(flags);
CopLINE_dec(PL_curcop);
s = PL_parser->bufptr;
@@ -1522,7 +1596,13 @@
PERL_ARGS_ASSERT_INCLINE;
- CopLINE_inc(PL_curcop);
+ COPLINE_INC_WITH_HERELINES;
+ if (!PL_rsfp && !PL_parser->filtered && PL_lex_state == LEX_NORMAL
+ && s+1 == PL_bufend && *s == ';') {
+ /* fake newline in string eval */
+ CopLINE_dec(PL_curcop);
+ return;
+ }
if (*s++ != '#')
return;
while (SPACE_OR_TAB(*s))
@@ -1578,7 +1658,7 @@
tmplen = 0;
}
- if (tmplen > 7 && strnEQ(cf, "(eval ", 6)) {
+ if (!PL_rsfp && !PL_parser->filtered) {
/* must copy *{"::_<(eval N)[oldfilename:L]"}
* to *{"::_<newfilename"} */
/* However, the long form of evals is only turned on by the
@@ -1655,7 +1735,7 @@
/* skip space before PL_thistoken */
STATIC char *
-S_skipspace0(pTHX_ register char *s)
+S_skipspace0(pTHX_ char *s)
{
PERL_ARGS_ASSERT_SKIPSPACE0;
@@ -1676,7 +1756,7 @@
/* skip space after PL_thistoken */
STATIC char *
-S_skipspace1(pTHX_ register char *s)
+S_skipspace1(pTHX_ char *s)
{
const char *start = s;
I32 startoff = start - SvPVX(PL_linestr);
@@ -1703,7 +1783,7 @@
}
STATIC char *
-S_skipspace2(pTHX_ register char *s, SV **svp)
+S_skipspace2(pTHX_ char *s, SV **svp)
{
char *start;
const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
@@ -1756,7 +1836,7 @@
*/
STATIC char *
-S_skipspace(pTHX_ register char *s)
+S_skipspace(pTHX_ char *s)
{
#ifdef PERL_MAD
char *start = s;
@@ -1811,7 +1891,7 @@
while (isSPACE(*PL_last_uni))
PL_last_uni++;
s = PL_last_uni;
- while (isALNUM_lazy_if(s,UTF) || *s == '-')
+ while (isWORDCHAR_lazy_if(s,UTF) || *s == '-')
s++;
if ((t = strchr(s, '(')) && t < PL_bufptr)
return;
@@ -2030,10 +2110,10 @@
*/
STATIC char *
-S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
+S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
{
dVAR;
- register char *s;
+ char *s;
STRLEN len;
PERL_ARGS_ASSERT_FORCE_WORD;
@@ -2079,15 +2159,16 @@
*/
STATIC void
-S_force_ident(pTHX_ register const char *s, int kind)
+S_force_ident(pTHX_ const char *s, int kind)
{
dVAR;
PERL_ARGS_ASSERT_FORCE_IDENT;
- if (*s) {
- const STRLEN len = strlen(s);
- OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn(s, len));
+ if (s[0]) {
+ const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
+ OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
+ UTF ? SVf_UTF8 : 0));
start_force(PL_curforce);
NEXTVAL_NEXTTOKE.opval = o;
force_next(WORD);
@@ -2097,8 +2178,8 @@
warnings if the symbol must be introduced in an eval.
GSAR 96-10-12 */
gv_fetchpvn_flags(s, len,
- PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
- : GV_ADD,
+ (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
+ : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
kind == '$' ? SVt_PV :
kind == '@' ? SVt_PVAV :
kind == '%' ? SVt_PVHV :
@@ -2108,6 +2189,14 @@
}
}
+static void
+S_force_ident_maybe_lex(pTHX_ char pit)
+{
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.ival = pit;
+ force_next('p');
+}
+
NV
Perl_str_to_version(pTHX_ SV *sv)
{
@@ -2173,11 +2262,13 @@
if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
SV *ver;
#ifdef USE_LOCALE_NUMERIC
- char *loc = setlocale(LC_NUMERIC, "C");
+ char *loc = savepv(setlocale(LC_NUMERIC, NULL));
+ setlocale(LC_NUMERIC, "C");
#endif
s = scan_num(s, &pl_yylval);
#ifdef USE_LOCALE_NUMERIC
setlocale(LC_NUMERIC, loc);
+ Safefree(loc);
#endif
version = pl_yylval.opval;
ver = cSVOPx(version)->op_sv;
@@ -2275,9 +2366,9 @@
S_tokeq(pTHX_ SV *sv)
{
dVAR;
- register char *s;
- register char *send;
- register char *d;
+ char *s;
+ char *send;
+ char *d;
STRLEN len = 0;
SV *pv = sv;
@@ -2320,14 +2411,10 @@
* converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
* interact with PL_lex_state, and create fake ( ... ) argument lists
* to handle functions and concatenation.
- * They assume that whoever calls them will be setting up a fake
- * join call, because each subthing puts a ',' after it. This lets
- * "lower \luPpEr"
- * become
- * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
- *
- * (I'm not sure whether the spurious commas at the end of lcfirst's
- * arguments and join's arguments are created or not).
+ * For example,
+ * "foo\lbar"
+ * is tokenised as
+ * stringify ( const[foo] concat lcfirst ( const[bar] ) )
*/
/*
@@ -2350,7 +2437,7 @@
S_sublex_start(pTHX)
{
dVAR;
- register const I32 op_type = pl_yylval.ival;
+ const I32 op_type = pl_yylval.ival;
if (op_type == OP_NULL) {
pl_yylval.opval = PL_lex_op;
@@ -2411,6 +2498,7 @@
S_sublex_push(pTHX)
{
dVAR;
+ LEXSHARED *shared;
ENTER;
PL_lex_state = PL_sublex_info.super_state;
@@ -2417,10 +2505,12 @@
SAVEBOOL(PL_lex_dojoin);
SAVEI32(PL_lex_brackets);
SAVEI32(PL_lex_allbrackets);
+ SAVEI32(PL_lex_formbrack);
SAVEI8(PL_lex_fakeeof);
SAVEI32(PL_lex_casemods);
SAVEI32(PL_lex_starts);
SAVEI8(PL_lex_state);
+ SAVESPTR(PL_lex_repl);
SAVEVPTR(PL_lex_inpat);
SAVEI16(PL_lex_inwhat);
SAVECOPLINE(PL_curcop);
@@ -2434,9 +2524,20 @@
SAVESPTR(PL_linestr);
SAVEGENERICPV(PL_lex_brackstack);
SAVEGENERICPV(PL_lex_casestack);
+ SAVEGENERICPV(PL_parser->lex_shared);
+ SAVEBOOL(PL_parser->lex_re_reparsing);
+ /* The here-doc parser needs to be able to peek into outer lexing
+ scopes to find the body of the here-doc. So we put PL_linestr and
+ PL_bufptr into lex_shared, to ‘share’ those values.
+ */
+ PL_parser->lex_shared->ls_linestr = PL_linestr;
+ PL_parser->lex_shared->ls_bufptr = PL_bufptr;
+
PL_linestr = PL_lex_stuff;
+ PL_lex_repl = PL_sublex_info.repl;
PL_lex_stuff = NULL;
+ PL_sublex_info.repl = NULL;
PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
= SvPVX(PL_linestr);
@@ -2443,9 +2544,10 @@
PL_bufend += SvCUR(PL_linestr);
PL_last_lop = PL_last_uni = NULL;
SAVEFREESV(PL_linestr);
+ if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
PL_lex_dojoin = FALSE;
- PL_lex_brackets = 0;
+ PL_lex_brackets = PL_lex_formbrack = 0;
PL_lex_allbrackets = 0;
PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
Newx(PL_lex_brackstack, 120, char);
@@ -2455,6 +2557,10 @@
PL_lex_starts = 0;
PL_lex_state = LEX_INTERPCONCAT;
CopLINE_set(PL_curcop, (line_t)PL_multi_start);
+
+ Newxz(shared, 1, LEXSHARED);
+ shared->ls_prev = PL_parser->lex_shared;
+ PL_parser->lex_shared = shared;
PL_lex_inwhat = PL_sublex_info.sub_inwhat;
if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
@@ -2463,6 +2569,9 @@
else
PL_lex_inpat = NULL;
+ PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
+ PL_in_eval &= ~EVAL_RE_REPARSING;
+
return '(';
}
@@ -2497,7 +2606,6 @@
PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
PL_bufend += SvCUR(PL_linestr);
PL_last_lop = PL_last_uni = NULL;
- SAVEFREESV(PL_linestr);
PL_lex_dojoin = FALSE;
PL_lex_brackets = 0;
PL_lex_allbrackets = 0;
@@ -2543,12 +2651,210 @@
}
}
+PERL_STATIC_INLINE SV*
+S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
+{
+ /* <s> points to first character of interior of \N{}, <e> to one beyond the
+ * interior, hence to the "}". Finds what the name resolves to, returning
+ * an SV* containing it; NULL if no valid one found */
+
+ SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
+
+ HV * table;
+ SV **cvp;
+ SV *cv;
+ SV *rv;
+ HV *stash;
+ const U8* first_bad_char_loc;
+ const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
+
+ PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
+
+ if (UTF && ! is_utf8_string_loc((U8 *) backslash_ptr,
+ e - backslash_ptr,
+ &first_bad_char_loc))
+ {
+ /* If warnings are on, this will print a more detailed analysis of what
+ * is wrong than the error message below */
+ utf8n_to_uvuni(first_bad_char_loc,
+ e - ((char *) first_bad_char_loc),
+ NULL, 0);
+
+ /* We deliberately don't try to print the malformed character, which
+ * might not print very well; it also may be just the first of many
+ * malformations, so don't print what comes after it */
+ yyerror(Perl_form(aTHX_
+ "Malformed UTF-8 character immediately after '%.*s'",
+ (int) (first_bad_char_loc - (U8 *) backslash_ptr), backslash_ptr));
+ return NULL;
+ }
+
+ res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
+ /* include the <}> */
+ e - backslash_ptr + 1);
+ if (! SvPOK(res)) {
+ SvREFCNT_dec_NN(res);
+ return NULL;
+ }
+
+ /* See if the charnames handler is the Perl core's, and if so, we can skip
+ * the validation needed for a user-supplied one, as Perl's does its own
+ * validation. */
+ table = GvHV(PL_hintgv); /* ^H */
+ cvp = hv_fetchs(table, "charnames", FALSE);
+ if (cvp && (cv = *cvp) && SvROK(cv) && ((rv = SvRV(cv)) != NULL)
+ && SvTYPE(rv) == SVt_PVCV && ((stash = CvSTASH(rv)) != NULL))
+ {
+ const char * const name = HvNAME(stash);
+ if strEQ(name, "_charnames") {
+ return res;
+ }
+ }
+
+ /* Here, it isn't Perl's charname handler. We can't rely on a
+ * user-supplied handler to validate the input name. For non-ut8 input,
+ * look to see that the first character is legal. Then loop through the
+ * rest checking that each is a continuation */
+
+ /* This code needs to be sync'ed with a regex in _charnames.pm which does
+ * the same thing */
+
+ if (! UTF) {
+ if (! isALPHAU(*s)) {
+ goto bad_charname;
+ }
+ s++;
+ while (s < e) {
+ if (! isCHARNAME_CONT(*s)) {
+ goto bad_charname;
+ }
+ if (*s == ' ' && *(s-1) == ' ' && ckWARN(WARN_DEPRECATED)) {
+ Perl_warn(aTHX_ "A sequence of multiple spaces in a charnames alias definition is deprecated");
+ }
+ s++;
+ }
+ if (*(s-1) == ' ' && ckWARN(WARN_DEPRECATED)) {
+ Perl_warn(aTHX_ "Trailing white-space in a charnames alias definition is deprecated");
+ }
+ }
+ else {
+ /* Similarly for utf8. For invariants can check directly; for other
+ * Latin1, can calculate their code point and check; otherwise use a
+ * swash */
+ if (UTF8_IS_INVARIANT(*s)) {
+ if (! isALPHAU(*s)) {
+ goto bad_charname;
+ }
+ s++;
+ } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
+ if (! isALPHAU(UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(*s, *(s+1))))) {
+ goto bad_charname;
+ }
+ s += 2;
+ }
+ else {
+ if (! PL_utf8_charname_begin) {
+ U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
+ PL_utf8_charname_begin = _core_swash_init("utf8",
+ "_Perl_Charname_Begin",
+ &PL_sv_undef,
+ 1, 0, NULL, &flags);
+ }
+ if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
+ goto bad_charname;
+ }
+ s += UTF8SKIP(s);
+ }
+
+ while (s < e) {
+ if (UTF8_IS_INVARIANT(*s)) {
+ if (! isCHARNAME_CONT(*s)) {
+ goto bad_charname;
+ }
+ if (*s == ' ' && *(s-1) == ' ' && ckWARN(WARN_DEPRECATED)) {
+ Perl_warn(aTHX_ "A sequence of multiple spaces in a charnames alias definition is deprecated");
+ }
+ s++;
+ }
+ else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
+ if (! isCHARNAME_CONT(UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(*s,
+ *(s+1)))))
+ {
+ goto bad_charname;
+ }
+ s += 2;
+ }
+ else {
+ if (! PL_utf8_charname_continue) {
+ U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
+ PL_utf8_charname_continue = _core_swash_init("utf8",
+ "_Perl_Charname_Continue",
+ &PL_sv_undef,
+ 1, 0, NULL, &flags);
+ }
+ if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
+ goto bad_charname;
+ }
+ s += UTF8SKIP(s);
+ }
+ }
+ if (*(s-1) == ' ' && ckWARN(WARN_DEPRECATED)) {
+ Perl_warn(aTHX_ "Trailing white-space in a charnames alias definition is deprecated");
+ }
+ }
+
+ if (SvUTF8(res)) { /* Don't accept malformed input */
+ const U8* first_bad_char_loc;
+ STRLEN len;
+ const char* const str = SvPV_const(res, len);
+ if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) {
+ /* If warnings are on, this will print a more detailed analysis of
+ * what is wrong than the error message below */
+ utf8n_to_uvuni(first_bad_char_loc,
+ (char *) first_bad_char_loc - str,
+ NULL, 0);
+
+ /* We deliberately don't try to print the malformed character,
+ * which might not print very well; it also may be just the first
+ * of many malformations, so don't print what comes after it */
+ yyerror_pv(
+ Perl_form(aTHX_
+ "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
+ (int) (e - backslash_ptr + 1), backslash_ptr,
+ (int) ((char *) first_bad_char_loc - str), str
+ ),
+ SVf_UTF8);
+ return NULL;
+ }
+ }
+
+ return res;
+
+ bad_charname: {
+ int bad_char_size = ((UTF) ? UTF8SKIP(s) : 1);
+
+ /* The final %.*s makes sure that should the trailing NUL be missing
+ * that this print won't run off the end of the string */
+ yyerror_pv(
+ Perl_form(aTHX_
+ "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
+ (int)(s - backslash_ptr + bad_char_size), backslash_ptr,
+ (int)(e - s + bad_char_size), s + bad_char_size
+ ),
+ UTF ? SVf_UTF8 : 0);
+ return NULL;
+ }
+}
+
/*
scan_const
- Extracts a pattern, double-quoted string, or transliteration. This
- is terrifying code.
+ Extracts the next constant part of a pattern, double-quoted string,
+ or transliteration. This is terrifying code.
+ For example, in parsing the double-quoted string "ab\x63$d", it would
+ stop at the '$' and return an OP_CONST containing 'abc'.
+
It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
processing a pattern (PL_lex_inpat is true), a transliteration
(PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
@@ -2555,16 +2861,24 @@
Returns a pointer to the character scanned up to. If this is
advanced from the start pointer supplied (i.e. if anything was
- successfully parsed), will leave an OP for the substring scanned
+ successfully parsed), will leave an OP_CONST for the substring scanned
in pl_yylval. Caller must intuit reason for not parsing further
by looking at the next characters herself.
In patterns:
- backslashes:
- constants: \N{NAME} only
- case and quoting: \U \Q \E
- stops on @ and $, but not for $ as tail anchor
+ expand:
+ \N{FOO} => \N{U+hex_for_character_FOO}
+ (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
+ pass through:
+ all other \-char, including \N and \N{ apart from \N{ABC}
+
+ stops on:
+ @ and $ where it appears to be a var, but not for $ as tail anchor
+ \l \L \u \U \Q \E
+ (?{ or (??{
+
+
In transliterations:
characters are VERY literal, except for - not at the start or end
of the string, which indicates a range. If the range is in bytes,
@@ -2593,7 +2907,7 @@
it's a tail anchor if $ is the last thing in the string, or if it's
followed by one of "()| \r\n\t"
- \1 (backreferences) are turned into $1
+ \1 (backreferences) are turned into $1 in substitutions
The structure of the code is
while (there's a character to process) {
@@ -2625,13 +2939,14 @@
S_scan_const(pTHX_ char *start)
{
dVAR;
- register char *send = PL_bufend; /* end of the constant */
+ char *send = PL_bufend; /* end of the constant */
SV *sv = newSV(send - start); /* sv for the constant. See
note below on sizing. */
- register char *s = start; /* start of the constant */
- register char *d = SvPVX(sv); /* destination for copies */
+ char *s = start; /* start of the constant */
+ char *d = SvPVX(sv); /* destination for copies */
bool dorange = FALSE; /* are we in a translit range? */
bool didrange = FALSE; /* did we just finish a range? */
+ bool in_charclass = FALSE; /* within /[...]/ */
bool has_utf8 = FALSE; /* Output constant is UTF8 */
bool this_utf8 = cBOOL(UTF); /* Is the source string assumed
to be UTF8? But, this can
@@ -2639,6 +2954,7 @@
isn't utf8, as for example
when it is entirely composed
of hex constants */
+ SV *res; /* result from charnames */
/* Note on sizing: The scanned constant is placed into sv, which is
* initialized by newSV() assuming one byte of output for every byte of
@@ -2652,7 +2968,8 @@
* far, plus the length the current construct will occupy, plus room for
* the trailing NUL, plus one byte for every input byte still unscanned */
- UV uv;
+ UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
+ before set */
#ifdef EBCDIC
UV literal_endpoint = 0;
bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
@@ -2667,6 +2984,9 @@
this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
}
+ /* Protect sv from errors and fatal warnings. */
+ ENTER_with_name("scan_const");
+ SAVEFREESV(sv);
while (s < send || dorange) {
@@ -2686,7 +3006,7 @@
#ifdef EBCDIC
&& !native_range
#endif
- ) {
+ ) {
char * const c = (char*)utf8_hop((U8*)d, -1);
char *e = d++;
while (e-- > c)
@@ -2821,33 +3141,38 @@
/* if we get here, we're not doing a transliteration */
- /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
- except for the last char, which will be done separately. */
- else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
+ else if (*s == '[' && PL_lex_inpat && !in_charclass) {
+ char *s1 = s-1;
+ int esc = 0;
+ while (s1 >= start && *s1-- == '\\')
+ esc = !esc;
+ if (!esc)
+ in_charclass = TRUE;
+ }
+
+ else if (*s == ']' && PL_lex_inpat && in_charclass) {
+ char *s1 = s-1;
+ int esc = 0;
+ while (s1 >= start && *s1-- == '\\')
+ esc = !esc;
+ if (!esc)
+ in_charclass = FALSE;
+ }
+
+ /* skip for regexp comments /(?#comment)/, except for the last
+ * char, which will be done separately.
+ * Stop on (?{..}) and friends */
+
+ else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) {
if (s[2] == '#') {
while (s+1 < send && *s != ')')
*d++ = NATIVE_TO_NEED(has_utf8,*s++);
}
- else if (s[2] == '{' /* This should match regcomp.c */
- || (s[2] == '?' && s[3] == '{'))
+ else if (!PL_lex_casemods &&
+ ( s[2] == '{' /* This should match regcomp.c */
+ || (s[2] == '?' && s[3] == '{')))
{
- I32 count = 1;
- char *regparse = s + (s[2] == '{' ? 3 : 4);
- char c;
-
- while (count && (c = *regparse)) {
- if (c == '\\' && regparse[1])
- regparse++;
- else if (c == '{')
- count++;
- else if (c == '}')
- count--;
- regparse++;
- }
- if (*regparse != ')')
- regparse--; /* Leave one char for continuation. */
- while (s < regparse)
- *d++ = NATIVE_TO_NEED(has_utf8,*s++);
+ break;
}
}
@@ -2854,15 +3179,32 @@
/* likewise skip #-initiated comments in //x patterns */
else if (*s == '#' && PL_lex_inpat &&
((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED) {
- while (s+1 < send && *s != '\n')
+ while (s+1 < send && *s != '\n') {
+ /* for maint-5.18, half-fix #-in-charclass bug:
+ * *do* recognise codeblocks: /[#](?{})/
+ * *don't* recognise interpolated vars: /[#$x]/
+ */
+ if (in_charclass && !PL_lex_casemods && s+3 < send &&
+ s[0] == '(' &&
+ s[1] == '?' &&
+ ( s[2] == '{'
+ || (s[2] == '?' && s[3] == '{')))
+ break;
*d++ = NATIVE_TO_NEED(has_utf8,*s++);
+ }
+ if (s+ 1 < send && *s != '\n')
+ break; /* we stopped on (?{}), not EOL */
}
+ /* no further processing of single-quoted regex */
+ else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
+ goto default_action;
+
/* check for embedded arrays
(@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
*/
else if (*s == '@' && s[1]) {
- if (isALNUM_lazy_if(s+1,UTF))
+ if (isWORDCHAR_lazy_if(s+1,UTF))
break;
if (strchr(":'{$", s[1]))
break;
@@ -2904,7 +3246,7 @@
}
/* string-change backslash escapes */
- if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
+ if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
--s;
break;
}
@@ -2924,7 +3266,7 @@
else if (PL_lex_inpat
&& (*s != 'N'
|| s[1] != '{'
- || regcurly(s + 1)))
+ || regcurly(s + 1, FALSE)))
{
*d++ = NATIVE_TO_NEED(has_utf8,'\\');
goto default_action;
@@ -2941,7 +3283,7 @@
/* FALL THROUGH */
default:
{
- if ((isALPHA(*s) || isDIGIT(*s)))
+ if ((isALPHANUMERIC(*s)))
Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
"Unrecognized escape \\%c passed through",
*s);
@@ -2953,10 +3295,16 @@
case '0': case '1': case '2': case '3':
case '4': case '5': case '6': case '7':
{
- I32 flags = 0;
+ I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
STRLEN len = 3;
uv = NATIVE_TO_UNI(grok_oct(s, &len, &flags, NULL));
s += len;
+ if (len < 3 && s < send && isDIGIT(*s)
+ && ckWARN(WARN_MISC))
+ {
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
+ "%s", form_short_octal_warning(s, len));
+ }
}
goto NUM_ESCAPE_INSERT;
@@ -2963,11 +3311,14 @@
/* eg. \o{24} indicates the octal constant \024 */
case 'o':
{
- STRLEN len;
const char* error;
- bool valid = grok_bslash_o(s, &uv, &len, &error, 1);
- s += len;
+ bool valid = grok_bslash_o(&s, &uv, &error,
+ TRUE, /* Output warning */
+ FALSE, /* Not strict */
+ TRUE, /* Output warnings for
+ non-portables */
+ UTF);
if (! valid) {
yyerror(error);
continue;
@@ -2977,30 +3328,20 @@
/* eg. \x24 indicates the hex constant 0x24 */
case 'x':
- ++s;
- if (*s == '{') {
- char* const e = strchr(s, '}');
- I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
- PERL_SCAN_DISALLOW_PREFIX;
- STRLEN len;
+ {
+ const char* error;
- ++s;
- if (!e) {
- yyerror("Missing right brace on \\x{}");
+ bool valid = grok_bslash_x(&s, &uv, &error,
+ TRUE, /* Output warning */
+ FALSE, /* Not strict */
+ TRUE, /* Output warnings for
+ non-portables */
+ UTF);
+ if (! valid) {
+ yyerror(error);
continue;
}
- len = e - s;
- uv = NATIVE_TO_UNI(grok_hex(s, &len, &flags, NULL));
- s = e + 1;
}
- else {
- {
- STRLEN len = 2;
- I32 flags = PERL_SCAN_DISALLOW_PREFIX;
- uv = NATIVE_TO_UNI(grok_hex(s, &len, &flags, NULL));
- s += len;
- }
- }
NUM_ESCAPE_INSERT:
/* Insert oct or hex escaped character. There will always be
@@ -3104,31 +3445,6 @@
/* Here it looks like a named character */
- if (PL_lex_inpat) {
-
- /* XXX This block is temporary code. \N{} implies that the
- * pattern is to have Unicode semantics, and therefore
- * currently has to be encoded in utf8. By putting it in
- * utf8 now, we save a whole pass in the regular expression
- * compiler. Once that code is changed so Unicode
- * semantics doesn't necessarily have to be in utf8, this
- * block should be removed. However, the code that parses
- * the output of this would have to be changed to not
- * necessarily expect utf8 */
- if (!has_utf8) {
- SvCUR_set(sv, d - SvPVX_const(sv));
- SvPOK_on(sv);
- *d = '\0';
- /* See Note on sizing above. */
- sv_utf8_upgrade_flags_grow(sv,
- SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
- /* 5 = '\N{' + cur char + NUL */
- (STRLEN)(send - s) + 5);
- d = SvPVX(sv) + SvCUR(sv);
- has_utf8 = TRUE;
- }
- }
-
if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
| PERL_SCAN_DISALLOW_PREFIX;
@@ -3190,33 +3506,13 @@
else d = (char*)uvuni_to_utf8((U8*)d, uv);
}
}
- else { /* Here is \N{NAME} but not \N{U+...}. */
+ else /* Here is \N{NAME} but not \N{U+...}. */
+ if ((res = get_and_check_backslash_N_name(s, e)))
+ {
+ STRLEN len;
+ const char *str = SvPV_const(res, len);
+ if (PL_lex_inpat) {
- SV *res; /* result from charnames */
- const char *str; /* the string in 'res' */
- STRLEN len; /* its length */
-
- /* Get the value for NAME */
- res = newSVpvn(s, e - s);
- res = new_constant( NULL, 0, "charnames",
- /* includes all of: \N{...} */
- res, NULL, s - 3, e - s + 4 );
-
- /* Most likely res will be in utf8 already since the
- * standard charnames uses pack U, but a custom translator
- * can leave it otherwise, so make sure. XXX This can be
- * revisited to not have charnames use utf8 for characters
- * that don't need it when regexes don't have to be in utf8
- * for Unicode semantics. If doing so, remember EBCDIC */
- sv_utf8_upgrade(res);
- str = SvPV_const(res, len);
-
- /* Don't accept malformed input */
- if (! is_utf8_string((U8 *) str, len)) {
- yyerror("Malformed UTF-8 returned by \\N");
- }
- else if (PL_lex_inpat) {
-
if (! len) { /* The name resolved to an empty string */
Copy("\\N{}", d, 4, char);
d += 4;
@@ -3229,73 +3525,88 @@
* returned by charnames */
const char *str_end = str + len;
- STRLEN char_length; /* cur char's byte length */
- STRLEN output_length; /* and the number of bytes
- after this is translated
- into hex digits */
const STRLEN off = d - SvPVX_const(sv);
- /* 2 hex per byte; 2 chars for '\N'; 2 chars for
- * max('U+', '.'); and 1 for NUL */
- char hex_string[2 * UTF8_MAXBYTES + 5];
+ if (! SvUTF8(res)) {
+ /* For the non-UTF-8 case, we can determine the
+ * exact length needed without having to parse
+ * through the string. Each character takes up
+ * 2 hex digits plus either a trailing dot or
+ * the "}" */
+ d = off + SvGROW(sv, off
+ + 3 * len
+ + 6 /* For the "\N{U+", and
+ trailing NUL */
+ + (STRLEN)(send - e));
+ Copy("\\N{U+", d, 5, char);
+ d += 5;
+ while (str < str_end) {
+ char hex_string[4];
+ my_snprintf(hex_string, sizeof(hex_string),
+ "%02X.", (U8) *str);
+ Copy(hex_string, d, 3, char);
+ d += 3;
+ str++;
+ }
+ d--; /* We will overwrite below the final
+ dot with a right brace */
+ }
+ else {
+ STRLEN char_length; /* cur char's byte length */
- /* Get the first character of the result. */
- U32 uv = utf8n_to_uvuni((U8 *) str,
- len,
- &char_length,
- UTF8_ALLOW_ANYUV);
+ /* and the number of bytes after this is
+ * translated into hex digits */
+ STRLEN output_length;
- /* The call to is_utf8_string() above hopefully
- * guarantees that there won't be an error. But
- * it's easy here to make sure. The function just
- * above warns and returns 0 if invalid utf8, but
- * it can also return 0 if the input is validly a
- * NUL. Disambiguate */
- if (uv == 0 && NATIVE_TO_ASCII(*str) != '\0') {
- uv = UNICODE_REPLACEMENT;
- }
+ /* 2 hex per byte; 2 chars for '\N'; 2 chars
+ * for max('U+', '.'); and 1 for NUL */
+ char hex_string[2 * UTF8_MAXBYTES + 5];
- /* Convert first code point to hex, including the
- * boiler plate before it. For all these, we
- * convert to native format so that downstream code
- * can continue to assume the input is native */
- output_length =
- my_snprintf(hex_string, sizeof(hex_string),
- "\\N{U+%X",
- (unsigned int) UNI_TO_NATIVE(uv));
+ /* Get the first character of the result. */
+ U32 uv = utf8n_to_uvuni((U8 *) str,
+ len,
+ &char_length,
+ UTF8_ALLOW_ANYUV);
+ /* Convert first code point to hex, including
+ * the boiler plate before it. For all these,
+ * we convert to native format so that
+ * downstream code can continue to assume the
+ * input is native */
+ output_length =
+ my_snprintf(hex_string, sizeof(hex_string),
+ "\\N{U+%X",
+ (unsigned int) UNI_TO_NATIVE(uv));
- /* Make sure there is enough space to hold it */
- d = off + SvGROW(sv, off
- + output_length
- + (STRLEN)(send - e)
- + 2); /* '}' + NUL */
- /* And output it */
- Copy(hex_string, d, output_length, char);
- d += output_length;
+ /* Make sure there is enough space to hold it */
+ d = off + SvGROW(sv, off
+ + output_length
+ + (STRLEN)(send - e)
+ + 2); /* '}' + NUL */
+ /* And output it */
+ Copy(hex_string, d, output_length, char);
+ d += output_length;
- /* For each subsequent character, append dot and
- * its ordinal in hex */
- while ((str += char_length) < str_end) {
- const STRLEN off = d - SvPVX_const(sv);
- U32 uv = utf8n_to_uvuni((U8 *) str,
- str_end - str,
- &char_length,
- UTF8_ALLOW_ANYUV);
- if (uv == 0 && NATIVE_TO_ASCII(*str) != '\0') {
- uv = UNICODE_REPLACEMENT;
- }
+ /* For each subsequent character, append dot and
+ * its ordinal in hex */
+ while ((str += char_length) < str_end) {
+ const STRLEN off = d - SvPVX_const(sv);
+ U32 uv = utf8n_to_uvuni((U8 *) str,
+ str_end - str,
+ &char_length,
+ UTF8_ALLOW_ANYUV);
+ output_length =
+ my_snprintf(hex_string,
+ sizeof(hex_string),
+ ".%X",
+ (unsigned int) UNI_TO_NATIVE(uv));
- output_length =
- my_snprintf(hex_string, sizeof(hex_string),
- ".%X",
- (unsigned int) UNI_TO_NATIVE(uv));
-
- d = off + SvGROW(sv, off
- + output_length
- + (STRLEN)(send - e)
- + 2); /* '}' + NUL */
- Copy(hex_string, d, output_length, char);
- d += output_length;
+ d = off + SvGROW(sv, off
+ + output_length
+ + (STRLEN)(send - e)
+ + 2); /* '}' + NUL */
+ Copy(hex_string, d, output_length, char);
+ d += output_length;
+ }
}
*d++ = '}'; /* Done. Add the trailing brace */
@@ -3328,68 +3639,9 @@
Copy(str, d, len, char);
d += len;
}
+
SvREFCNT_dec(res);
- /* Deprecate non-approved name syntax */
- if (ckWARN_d(WARN_DEPRECATED)) {
- bool problematic = FALSE;
- char* i = s;
-
- /* For non-ut8 input, look to see that the first
- * character is an alpha, then loop through the rest
- * checking that each is a continuation */
- if (! this_utf8) {
- if (! isALPHAU(*i)) problematic = TRUE;
- else for (i = s + 1; i < e; i++) {
- if (isCHARNAME_CONT(*i)) continue;
- problematic = TRUE;
- break;
- }
- }
- else {
- /* Similarly for utf8. For invariants can check
- * directly. We accept anything above the latin1
- * range because it is immaterial to Perl if it is
- * correct or not, and is expensive to check. But
- * it is fairly easy in the latin1 range to convert
- * the variants into a single character and check
- * those */
- if (UTF8_IS_INVARIANT(*i)) {
- if (! isALPHAU(*i)) problematic = TRUE;
- } else if (UTF8_IS_DOWNGRADEABLE_START(*i)) {
- if (! isALPHAU(UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(*i,
- *(i+1)))))
- {
- problematic = TRUE;
- }
- }
- if (! problematic) for (i = s + UTF8SKIP(s);
- i < e;
- i+= UTF8SKIP(i))
- {
- if (UTF8_IS_INVARIANT(*i)) {
- if (isCHARNAME_CONT(*i)) continue;
- } else if (! UTF8_IS_DOWNGRADEABLE_START(*i)) {
- continue;
- } else if (isCHARNAME_CONT(
- UNI_TO_NATIVE(
- TWO_BYTE_UTF8_TO_UNI(*i, *(i+1)))))
- {
- continue;
- }
- problematic = TRUE;
- break;
- }
- }
- if (problematic) {
- /* The e-i passed to the final %.*s makes sure that
- * should the trailing NUL be missing that this
- * print won't run off the end of the string */
- Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
- "Deprecated character in \\N{...}; marked by <-- HERE in \\N{%.*s<-- HERE %.*s",
- (int)(i - s + 1), s, (int)(e - i), i + 1);
- }
- }
} /* End \N{NAME} */
#ifdef EBCDIC
if (!dorange)
@@ -3491,7 +3743,8 @@
*d = '\0';
SvCUR_set(sv, d - SvPVX_const(sv));
if (SvCUR(sv) >= SvLEN(sv))
- Perl_croak(aTHX_ "panic: constant overflowed allocated space");
+ Perl_croak(aTHX_ "panic: constant overflowed allocated space, %"UVuf
+ " >= %"UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
SvPOK_on(sv);
if (PL_encoding && !has_utf8) {
@@ -3514,7 +3767,10 @@
/* return the substring (via pl_yylval) only if we parsed anything */
if (s > PL_bufptr) {
- if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) ) {
+ SvREFCNT_inc_simple_void_NN(sv);
+ if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
+ && ! PL_parser->lex_re_reparsing)
+ {
const char *const key = PL_lex_inpat ? "qr" : "q";
const STRLEN keylen = PL_lex_inpat ? 2 : 1;
const char *type;
@@ -3526,6 +3782,9 @@
} else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
type = "s";
typelen = 1;
+ } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
+ type = "q";
+ typelen = 1;
} else {
type = "qq";
typelen = 2;
@@ -3535,8 +3794,8 @@
type, typelen);
}
pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
- } else
- SvREFCNT_dec(sv);
+ }
+ LEAVE_with_name("scan_const");
return s;
}
@@ -3562,7 +3821,7 @@
/* This is the one truly awful dwimmer necessary to conflate C and sed. */
STATIC int
-S_intuit_more(pTHX_ register char *s)
+S_intuit_more(pTHX_ char *s)
{
dVAR;
@@ -3579,7 +3838,7 @@
/* In a pattern, so maybe we have {n,m}. */
if (*s == '{') {
- if (regcurly(s)) {
+ if (regcurly(s, FALSE)) {
return FALSE;
}
return TRUE;
@@ -3592,16 +3851,16 @@
return FALSE;
else {
/* this is terrifying, and it works */
- int weight = 2; /* let's weigh the evidence */
+ int weight;
char seen[256];
- unsigned char un_char = 255, last_un_char;
const char * const send = strchr(s,']');
+ unsigned char un_char, last_un_char;
char tmpbuf[sizeof PL_tokenbuf * 4];
if (!send) /* has to be an expression */
return TRUE;
+ weight = 2; /* let's weigh the evidence */
- Zero(seen,256,char);
if (*s == '$')
weight -= 3;
else if (isDIGIT(*s)) {
@@ -3612,6 +3871,8 @@
else
weight -= 100;
}
+ Zero(seen,256,char);
+ un_char = 255;
for (; s < send; s++) {
last_un_char = un_char;
un_char = (unsigned char)*s;
@@ -3620,11 +3881,12 @@
case '&':
case '$':
weight -= seen[un_char] * 10;
- if (isALNUM_lazy_if(s+1,UTF)) {
+ if (isWORDCHAR_lazy_if(s+1,UTF)) {
int len;
scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
len = (int)strlen(tmpbuf);
- if (len > 1 && gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PV))
+ if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
+ UTF ? SVf_UTF8 : 0, SVt_PV))
weight -= 100;
else
weight -= 10;
@@ -3666,7 +3928,7 @@
weight -= 5; /* cope with negative subscript */
break;
default:
- if (!isALNUM(last_un_char)
+ if (!isWORDCHAR(last_un_char)
&& !(last_un_char == '$' || last_un_char == '@'
|| last_un_char == '&')
&& isALPHA(*s) && s[1] && isALPHA(s[1])) {
@@ -3701,7 +3963,7 @@
*
* First argument is the stuff after the first token, e.g. "bar".
*
- * Not a method if bar is a filehandle.
+ * Not a method if foo is a filehandle.
* Not a method if foo is a subroutine prototyped to take a filehandle.
* Not a method if it's really "Foo $bar"
* Method if it's "foo $bar"
@@ -3726,12 +3988,10 @@
PERL_ARGS_ASSERT_INTUIT_METHOD;
- if (gv) {
- if (SvTYPE(gv) == SVt_PVGV && GvIO(gv))
+ if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
return 0;
- if (cv) {
- if (SvPOK(cv)) {
- const char *proto = SvPVX_const(cv);
+ if (cv && SvPOK(cv)) {
+ const char *proto = CvPROTO(cv);
if (proto) {
if (*proto == ';')
proto++;
@@ -3738,9 +3998,6 @@
if (*proto == '*')
return 0;
}
- }
- } else
- gv = NULL;
}
s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
/* start is the beginning of the possible filehandle/object,
@@ -3749,7 +4006,7 @@
*/
if (*start == '$') {
- if (gv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
+ if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
isUPPER(*PL_tokenbuf))
return 0;
#ifdef PERL_MAD
@@ -3772,11 +4029,11 @@
#endif
goto bare_package;
}
- indirgv = gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PVCV);
+ indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
if (indirgv && GvCVu(indirgv))
return 0;
/* filehandle or package name makes it a method */
- if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, 0)) {
+ if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
#ifdef PERL_MAD
soff = s - SvPVX(PL_linestr);
#endif
@@ -3789,7 +4046,8 @@
S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
if (PL_madskills)
- curmad('X', newSVpvn(start,SvPVX(PL_linestr) + soff - start));
+ curmad('X', newSVpvn_flags(start,SvPVX(PL_linestr) + soff - start,
+ ( UTF ? SVf_UTF8 : 0 )));
PL_expect = XTERM;
force_next(WORD);
PL_bufptr = s;
@@ -3829,6 +4087,9 @@
if (!PL_parser)
return NULL;
+ if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
+ Perl_croak(aTHX_ "Source filters apply only to byte streams");
+
if (!PL_rsfp_filters)
PL_rsfp_filters = newAV();
if (!datasv)
@@ -3841,6 +4102,45 @@
SvPV_nolen(datasv)));
av_unshift(PL_rsfp_filters, 1);
av_store(PL_rsfp_filters, 0, datasv) ;
+ if (
+ !PL_parser->filtered
+ && PL_parser->lex_flags & LEX_EVALBYTES
+ && PL_bufptr < PL_bufend
+ ) {
+ const char *s = PL_bufptr;
+ while (s < PL_bufend) {
+ if (*s == '\n') {
+ SV *linestr = PL_parser->linestr;
+ char *buf = SvPVX(linestr);
+ STRLEN const bufptr_pos = PL_parser->bufptr - buf;
+ STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
+ STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
+ STRLEN const linestart_pos = PL_parser->linestart - buf;
+ STRLEN const last_uni_pos =
+ PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
+ STRLEN const last_lop_pos =
+ PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
+ av_push(PL_rsfp_filters, linestr);
+ PL_parser->linestr =
+ newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
+ buf = SvPVX(PL_parser->linestr);
+ PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
+ PL_parser->bufptr = buf + bufptr_pos;
+ PL_parser->oldbufptr = buf + oldbufptr_pos;
+ PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
+ PL_parser->linestart = buf + linestart_pos;
+ if (PL_parser->last_uni)
+ PL_parser->last_uni = buf + last_uni_pos;
+ if (PL_parser->last_lop)
+ PL_parser->last_lop = buf + last_lop_pos;
+ SvLEN(linestr) = SvCUR(linestr);
+ SvCUR(linestr) = s-SvPVX(linestr);
+ PL_parser->filtered = 1;
+ break;
+ }
+ s++;
+ }
+ }
return(datasv);
}
@@ -3883,7 +4183,7 @@
/* This API is bad. It should have been using unsigned int for maxlen.
Not sure if we want to change the API, but if not we should sanity
check the value here. */
- const unsigned int correct_length
+ unsigned int correct_length
= maxlen < 0 ?
#ifdef PERL_MICRO
0x7FFFFFFF
@@ -3935,6 +4235,31 @@
idx));
return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
}
+ if (SvTYPE(datasv) != SVt_PVIO) {
+ if (correct_length) {
+ /* Want a block */
+ const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
+ if (!remainder) return 0; /* eof */
+ if (correct_length > remainder) correct_length = remainder;
+ sv_catpvn(buf_sv, SvEND(datasv), correct_length);
+ SvCUR_set(datasv, SvCUR(datasv) + correct_length);
+ } else {
+ /* Want a line */
+ const char *s = SvEND(datasv);
+ const char *send = SvPVX(datasv) + SvLEN(datasv);
+ while (s < send) {
+ if (*s == '\n') {
+ s++;
+ break;
+ }
+ s++;
+ }
+ if (s == send) return 0; /* eof */
+ sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
+ SvCUR_set(datasv, s-SvPVX(datasv));
+ }
+ return SvCUR(buf_sv);
+ }
/* Get function pointer hidden within datasv */
funcp = DPTR2FPTR(filter_t, IoANY(datasv));
DEBUG_P(PerlIO_printf(Perl_debug_log,
@@ -3947,7 +4272,7 @@
}
STATIC char *
-S_filter_gets(pTHX_ register SV *sv, STRLEN append)
+S_filter_gets(pTHX_ SV *sv, STRLEN append)
{
dVAR;
@@ -3983,13 +4308,13 @@
if (len > 2 &&
(pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
- (gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVHV)))
+ (gv = gv_fetchpvn_flags(pkgname, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
{
return GvHV(gv); /* Foo:: */
}
/* use constant CLASS => 'MyClass' */
- gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV);
+ gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
if (gv && GvCV(gv)) {
SV * const sv = cv_const_sv(GvCV(gv));
if (sv)
@@ -3996,7 +4321,7 @@
pkgname = SvPV_const(sv, len);
}
- return gv_stashpvn(pkgname, len, 0);
+ return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
}
/*
@@ -4042,10 +4367,6 @@
PL_thiswhite = 0;
PL_thismad = 0;
- /* just do what yylex would do on pending identifier; leave PL_thiswhite alone */
- if (PL_lex_state != LEX_KNOWNEXT && PL_pending_ident)
- return S_pending_ident(aTHX);
-
/* previous token ate up our whitespace? */
if (!PL_lasttoke && PL_nextwhite) {
PL_thiswhite = PL_nextwhite;
@@ -4087,7 +4408,7 @@
}
/* put off final whitespace till peg */
- if (optype == ';' && !PL_rsfp) {
+ if (optype == ';' && !PL_rsfp && !PL_parser->filtered) {
PL_nextwhite = PL_thiswhite;
PL_thiswhite = 0;
}
@@ -4146,6 +4467,10 @@
}
break;
+ /* pval */
+ case LABEL:
+ break;
+
case ']':
case '}':
if (PL_faketokens)
@@ -4192,10 +4517,6 @@
}
break;
- /* pval */
- case LABEL:
- break;
-
/* ival */
default:
break;
@@ -4218,6 +4539,7 @@
if (PL_expect != XSTATE)
yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
is_use ? "use" : "no"));
+ PL_expect = XTERM;
s = SKIPSPACE1(s);
if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
s = force_version(s, TRUE);
@@ -4264,21 +4586,40 @@
stitching them into a tree.
Returns:
- PRIVATEREF
+ The type of the next token
Structure:
- if read an identifier
- if we're in a my declaration
- croak if they tried to say my($foo::bar)
- build the ops for a my() declaration
- if it's an access to a my() variable
- are we in a sort block?
- croak if my($a); $a <=> $b
- build ops for access to a my() variable
- if in a dq string, and they've said @foo and we can't find @foo
- croak
- build ops for a bareword
- if we already built the token before, use it.
+ Switch based on the current state:
+ - if we already built the token before, use it
+ - if we have a case modifier in a string, deal with that
+ - handle other cases of interpolation inside a string
+ - scan the next line if we are inside a format
+ In the normal state switch on the next character:
+ - default:
+ if alphabetic, go to key lookup
+ unrecoginized character - croak
+ - 0/4/26: handle end-of-line or EOF
+ - cases for whitespace
+ - \n and #: handle comments and line numbers
+ - various operators, brackets and sigils
+ - numbers
+ - quotes
+ - 'v': vstrings (or go to key lookup)
+ - 'x' repetition operator (or go to key lookup)
+ - other ASCII alphanumerics (key lookup begins here):
+ word before => ?
+ keyword plugin
+ scan built-in keyword (but do nothing with it yet)
+ check for statement label
+ check for lexical subs
+ goto just_a_word if there is one
+ see whether built-in keyword is overridden
+ switch on keyword number:
+ - default: just_a_word:
+ not a built-in keyword; handle bareword lookup
+ disambiguate between method and sub call
+ fall back to bareword
+ - cases for built-in keywords
*/
@@ -4289,10 +4630,11 @@
Perl_yylex(pTHX)
{
dVAR;
- register char *s = PL_bufptr;
- register char *d;
+ char *s = PL_bufptr;
+ char *d;
STRLEN len;
bool bof = FALSE;
+ U8 formbrack = 0;
U32 fake_eof = 0;
/* orig_keyword, gvp, and gv are initialized here because
@@ -4311,12 +4653,7 @@
pv_display(tmp, s, strlen(s), 0, 60));
SvREFCNT_dec(tmp);
} );
- /* check if there's an identifier for us to look at */
- if (PL_lex_state != LEX_KNOWNEXT && PL_pending_ident)
- return REPORT(S_pending_ident(aTHX));
- /* no identifier pending identification */
-
switch (PL_lex_state) {
#ifdef COMMENTARY
case LEX_NORMAL: /* Some compilers will produce faster */
@@ -4375,12 +4712,7 @@
PL_lex_allbrackets--;
next_type &= 0xffff;
}
-#ifdef PERL_MAD
- /* FIXME - can these be merged? */
- return next_type;
-#else
- return REPORT(next_type);
-#endif
+ return REPORT(next_type == 'p' ? pending_ident() : next_type);
}
/* interpolated case modifiers like \L \U, including \Q and \E.
@@ -4389,7 +4721,9 @@
case LEX_INTERPCASEMOD:
#ifdef DEBUGGING
if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
- Perl_croak(aTHX_ "panic: INTERPCASEMOD");
+ Perl_croak(aTHX_
+ "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
+ PL_bufptr, PL_bufend, *PL_bufptr);
#endif
/* handle \E or end of string */
if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
@@ -4399,7 +4733,8 @@
PL_lex_casestack[PL_lex_casemods] = '\0';
if (PL_bufptr != PL_bufend
- && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
+ && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
+ || oldmod == 'F')) {
PL_bufptr += 2;
PL_lex_state = LEX_INTERPCONCAT;
#ifdef PERL_MAD
@@ -4410,12 +4745,19 @@
PL_lex_allbrackets--;
return REPORT(')');
}
+ else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
+ /* Got an unpaired \E */
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
+ "Useless use of \\E");
+ }
#ifdef PERL_MAD
while (PL_bufptr != PL_bufend &&
PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
- if (!PL_thiswhite)
+ if (PL_madskills) {
+ if (!PL_thiswhite)
PL_thiswhite = newSVpvs("");
- sv_catpvn(PL_thiswhite, PL_bufptr, 2);
+ sv_catpvn(PL_thiswhite, PL_bufptr, 2);
+ }
PL_bufptr += 2;
}
#else
@@ -4431,9 +4773,11 @@
s = PL_bufptr + 1;
if (s[1] == '\\' && s[2] == 'E') {
#ifdef PERL_MAD
- if (!PL_thiswhite)
+ if (PL_madskills) {
+ if (!PL_thiswhite)
PL_thiswhite = newSVpvs("");
- sv_catpvn(PL_thiswhite, PL_bufptr, 4);
+ sv_catpvn(PL_thiswhite, PL_bufptr, 4);
+ }
#endif
PL_bufptr = s + 3;
PL_lex_state = LEX_INTERPCONCAT;
@@ -4444,8 +4788,10 @@
if (!PL_madskills) /* when just compiling don't need correct */
if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
- if ((*s == 'L' || *s == 'U') &&
- (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
+ if ((*s == 'L' || *s == 'U' || *s == 'F') &&
+ (strchr(PL_lex_casestack, 'L')
+ || strchr(PL_lex_casestack, 'U')
+ || strchr(PL_lex_casestack, 'F'))) {
PL_lex_casestack[--PL_lex_casemods] = '\0';
PL_lex_allbrackets--;
return REPORT(')');
@@ -4469,8 +4815,10 @@
NEXTVAL_NEXTTOKE.ival = OP_UC;
else if (*s == 'Q')
NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
+ else if (*s == 'F')
+ NEXTVAL_NEXTTOKE.ival = OP_FC;
else
- Perl_croak(aTHX_ "panic: yylex");
+ Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
if (PL_madskills) {
SV* const tmpsv = newSVpvs("\\ ");
/* replace the space with the character we want to escape
@@ -4507,10 +4855,13 @@
case LEX_INTERPSTART:
if (PL_bufptr == PL_bufend)
return REPORT(sublex_done());
- DEBUG_T({ PerlIO_printf(Perl_debug_log,
+ DEBUG_T({ if(*PL_bufptr != '(') PerlIO_printf(Perl_debug_log,
"### Interpolated variable\n"); });
PL_expect = XTERM;
- PL_lex_dojoin = (*PL_bufptr == '@');
+ /* for /@a/, we leave the joining for the regex engine to do
+ * (unless we're within \Q etc) */
+ PL_lex_dojoin = (*PL_bufptr == '@'
+ && (!PL_lex_inpat || PL_lex_casemods));
PL_lex_state = LEX_INTERPNORMAL;
if (PL_lex_dojoin) {
start_force(PL_curforce);
@@ -4528,6 +4879,18 @@
NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
force_next(FUNC);
}
+ /* Convert (?{...}) and friends to 'do {...}' */
+ if (PL_lex_inpat && *PL_bufptr == '(') {
+ PL_parser->lex_shared->re_eval_start = PL_bufptr;
+ PL_bufptr += 2;
+ if (*PL_bufptr != '{')
+ PL_bufptr++;
+ start_force(PL_curforce);
+ /* XXX probably need a CURMAD(something) here */
+ PL_expect = XTERMBLOCK;
+ force_next(DO);
+ }
+
if (PL_lex_starts++) {
s = PL_bufptr;
#ifdef PERL_MAD
@@ -4573,21 +4936,52 @@
Perl_croak(aTHX_ "Bad evalled substitution pattern");
PL_lex_repl = NULL;
}
+ /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets
+ re_eval_str. If the here-doc body’s length equals the previous
+ value of re_eval_start, re_eval_start will now be null. So
+ check re_eval_str as well. */
+ if (PL_parser->lex_shared->re_eval_start
+ || PL_parser->lex_shared->re_eval_str) {
+ SV *sv;
+ if (*PL_bufptr != ')')
+ Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
+ PL_bufptr++;
+ /* having compiled a (?{..}) expression, return the original
+ * text too, as a const */
+ if (PL_parser->lex_shared->re_eval_str) {
+ sv = PL_parser->lex_shared->re_eval_str;
+ PL_parser->lex_shared->re_eval_str = NULL;
+ SvCUR_set(sv,
+ PL_bufptr - PL_parser->lex_shared->re_eval_start);
+ SvPV_shrink_to_cur(sv);
+ }
+ else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
+ PL_bufptr - PL_parser->lex_shared->re_eval_start);
+ start_force(PL_curforce);
+ /* XXX probably need a CURMAD(something) here */
+ NEXTVAL_NEXTTOKE.opval =
+ (OP*)newSVOP(OP_CONST, 0,
+ sv);
+ force_next(THING);
+ PL_parser->lex_shared->re_eval_start = NULL;
+ PL_expect = XTERM;
+ return REPORT(',');
+ }
+
/* FALLTHROUGH */
case LEX_INTERPCONCAT:
#ifdef DEBUGGING
if (PL_lex_brackets)
- Perl_croak(aTHX_ "panic: INTERPCONCAT");
+ Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
+ (long) PL_lex_brackets);
#endif
if (PL_bufptr == PL_bufend)
return REPORT(sublex_done());
- if (SvIVX(PL_linestr) == '\'') {
+ /* m'foo' still needs to be parsed for possible (?{...}) */
+ if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
SV *sv = newSVsv(PL_linestr);
- if (!PL_lex_inpat)
- sv = tokeq(sv);
- else if ( PL_hints & HINT_NEW_RE )
- sv = new_constant(NULL, 0, "qr", sv, sv, "q", 1);
+ sv = tokeq(sv);
pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
s = PL_bufend;
}
@@ -4629,11 +5023,14 @@
return yylex();
case LEX_FORMLINE:
- PL_lex_state = LEX_NORMAL;
s = scan_formline(PL_bufptr);
if (!PL_lex_formbrack)
+ {
+ formbrack = 1;
goto rightbracket;
- OPERATOR(';');
+ }
+ PL_bufptr = s;
+ return yylex();
}
s = PL_bufptr;
@@ -4650,10 +5047,15 @@
#endif
switch (*s) {
default:
- if (isIDFIRST_lazy_if(s,UTF))
+ if (UTF ? isIDFIRST_utf8((U8*)s) : isALNUMC(*s))
goto keylookup;
{
- unsigned char c = *s;
+ SV *dsv = newSVpvs_flags("", SVs_TEMP);
+ const char *c = UTF ? savepv(sv_uni_display(dsv, newSVpvn_flags(s,
+ UTF8SKIP(s),
+ SVs_TEMP | SVf_UTF8),
+ 10, UNI_DISPLAY_ISPRINT))
+ : Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
if (len > UNRECOGNIZED_PRECEDE_COUNT) {
d = UTF ? (char *) Perl_utf8_hop(aTHX_ (U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT;
@@ -4661,7 +5063,10 @@
d = PL_linestart;
}
*s = '\0';
- Perl_croak(aTHX_ "Unrecognized character \\x%02X; marked by <-- HERE after %s<-- HERE near column %d", c, d, (int) len + 1);
+ sv_setpv(dsv, d);
+ if (UTF)
+ SvUTF8_on(dsv);
+ Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %"SVf"<-- HERE near column %d", c, SVfARG(dsv), (int) len + 1);
}
case 4:
case 26:
@@ -4671,7 +5076,7 @@
if (PL_madskills)
PL_faketokens = 0;
#endif
- if (!PL_rsfp) {
+ if (!PL_rsfp && (!PL_parser->filtered || s+1 < PL_bufend)) {
PL_last_uni = 0;
PL_last_lop = 0;
if (PL_lex_brackets &&
@@ -4773,7 +5178,7 @@
fake_eof = LEX_FAKE_EOF;
}
PL_bufptr = PL_bufend;
- CopLINE_inc(PL_curcop);
+ COPLINE_INC_WITH_HERELINES;
if (!lex_next_chunk(fake_eof)) {
CopLINE_dec(PL_curcop);
s = PL_bufptr;
@@ -4792,12 +5197,12 @@
*(U8*)s == 0xEF ||
*(U8*)s >= 0xFE ||
s[1] == 0)) {
- IV offset = (IV)PerlIO_tell(PL_rsfp);
- bof = (offset == SvCUR(PL_linestr));
+ Off_t offset = (IV)PerlIO_tell(PL_rsfp);
+ bof = (offset == (Off_t)SvCUR(PL_linestr));
#if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
/* offset may include swallowed CR */
if (!bof)
- bof = (offset == SvCUR(PL_linestr)+1);
+ bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
#endif
if (bof) {
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
@@ -4818,7 +5223,7 @@
PL_parser->in_pod = 0;
}
}
- if (PL_rsfp)
+ if (PL_rsfp || PL_parser->filtered)
incline(s);
} while (PL_parser->in_pod);
PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
@@ -5017,9 +5422,11 @@
}
}
if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
- PL_bufptr = s;
PL_lex_state = LEX_FORMLINE;
- return yylex();
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.ival = 0;
+ force_next(FORMRBRACK);
+ TOKEN(';');
}
goto retry;
case '\r':
@@ -5031,9 +5438,11 @@
case ' ': case '\t': case '\f': case 013:
#ifdef PERL_MAD
PL_realtokenstart = -1;
- if (!PL_thiswhite)
+ if (PL_madskills) {
+ if (!PL_thiswhite)
PL_thiswhite = newSVpvs("");
- sv_catpvn(PL_thiswhite, s, 1);
+ sv_catpvn(PL_thiswhite, s, 1);
+ }
#endif
s++;
goto retry;
@@ -5044,8 +5453,10 @@
if (PL_madskills)
PL_faketokens = 0;
#endif
- if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
- if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
+ if (PL_lex_state != LEX_NORMAL ||
+ (PL_in_eval && !PL_rsfp && !PL_parser->filtered)) {
+ if (*s == '#' && s == PL_linestart && PL_in_eval
+ && !PL_rsfp && !PL_parser->filtered) {
/* handle eval qq[#line 1 "foo"\n ...] */
CopLINE_dec(PL_curcop);
incline(s);
@@ -5052,10 +5463,11 @@
}
if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
s = SKIPSPACE0(s);
- if (!PL_in_eval || PL_rsfp)
+ if (!PL_in_eval || PL_rsfp || PL_parser->filtered)
incline(s);
}
else {
+ const bool in_comment = *s == '#';
d = s;
while (d < PL_bufend && *d != '\n')
d++;
@@ -5062,18 +5474,25 @@
if (d < PL_bufend)
d++;
else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
- Perl_croak(aTHX_ "panic: input overflow");
+ Perl_croak(aTHX_ "panic: input overflow, %p > %p",
+ d, PL_bufend);
#ifdef PERL_MAD
if (PL_madskills)
PL_thiswhite = newSVpvn(s, d - s);
#endif
s = d;
- incline(s);
+ if (in_comment && d == PL_bufend
+ && PL_lex_state == LEX_INTERPNORMAL
+ && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
+ && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
+ else incline(s);
}
if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
- PL_bufptr = s;
PL_lex_state = LEX_FORMLINE;
- return yylex();
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.ival = 0;
+ force_next(FORMRBRACK);
+ TOKEN(';');
}
}
else {
@@ -5116,7 +5535,7 @@
}
goto retry;
case '-':
- if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
+ if (s[1] && isALPHA(s[1]) && !isWORDCHAR(s[2])) {
I32 ftst = 0;
char tmp;
@@ -5288,7 +5707,8 @@
if (!PL_tokenbuf[1]) {
PREREF('%');
}
- PL_pending_ident = '%';
+ PL_expect = XOPERATOR;
+ force_ident_maybe_lex('%');
TERM('%');
case '^':
@@ -5313,6 +5733,9 @@
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
TOKEN(0);
s += 2;
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
+ "Smartmatch is experimental");
Eop(OP_SMARTMATCH);
}
s++;
@@ -5373,9 +5796,9 @@
break;
}
}
- sv = newSVpvn(s, len);
+ sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
if (*d == '(') {
- d = scan_str(d,TRUE,TRUE);
+ d = scan_str(d,TRUE,TRUE,FALSE, FALSE);
if (!d) {
/* MUST advance bufptr here to avoid bogus
"at end of line" context messages from yyerror().
@@ -5531,21 +5954,14 @@
}
TERM(']');
case '{':
+ s++;
leftbracket:
- s++;
if (PL_lex_brackets > 100) {
Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
}
switch (PL_expect) {
case XTERM:
- if (PL_lex_formbrack) {
- s--;
- PRETERMBLOCK(DO);
- }
- if (PL_oldoldbufptr == PL_last_lop)
- PL_lex_brackstack[PL_lex_brackets++] = XTERM;
- else
- PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
+ PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
PL_lex_allbrackets++;
OPERATOR(HASHBRACK);
case XOPERATOR:
@@ -5627,9 +6043,9 @@
}
else if (*s == 'q') {
if (++t < PL_bufend
- && (!isALNUM(*t)
+ && (!isWORDCHAR(*t)
|| ((*t == 'q' || *t == 'x') && ++t < PL_bufend
- && !isALNUM(*t))))
+ && !isWORDCHAR(*t))))
{
/* skip q//-like construct */
const char *tmps;
@@ -5668,12 +6084,12 @@
}
else
/* skip plain q word */
- while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
+ while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
t += UTF8SKIP(t);
}
- else if (isALNUM_lazy_if(t,UTF)) {
+ else if (isWORDCHAR_lazy_if(t,UTF)) {
t += UTF8SKIP(t);
- while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
+ while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
t += UTF8SKIP(t);
}
while (t < PL_bufend && isSPACE(*t))
@@ -5695,7 +6111,7 @@
pl_yylval.ival = CopLINE(PL_curcop);
if (isSPACE(*s) || *s == '#')
PL_copline = NOLINE; /* invalidate current command line number */
- TOKEN('{');
+ TOKEN(formbrack ? '=' : '{');
case '}':
if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
TOKEN(0);
@@ -5706,8 +6122,6 @@
else
PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
PL_lex_allbrackets--;
- if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
- PL_lex_formbrack = 0;
if (PL_lex_state == LEX_INTERPNORMAL) {
if (PL_lex_brackets == 0) {
if (PL_expect & XFAKEBRACK) {
@@ -5723,7 +6137,10 @@
#endif
return yylex(); /* ignore fake brackets */
}
- if (*s == '-' && s[1] == '>')
+ if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
+ && SvEVALED(PL_lex_repl))
+ PL_lex_state = LEX_INTERPEND;
+ else if (*s == '-' && s[1] == '>')
PL_lex_state = LEX_INTERPENDMAYBE;
else if (*s != '[' && *s != '{')
PL_lex_state = LEX_INTERPEND;
@@ -5739,11 +6156,17 @@
curmad('X', newSVpvn(s-1,1));
CURMAD('_', PL_thiswhite);
}
- force_next('}');
+ force_next(formbrack ? '.' : '}');
+ if (formbrack) LEAVE;
#ifdef PERL_MAD
- if (!PL_thistoken)
+ if (PL_madskills && !PL_thistoken)
PL_thistoken = newSVpvs("");
#endif
+ if (formbrack == 2) { /* means . where arguments were expected */
+ start_force(PL_curforce);
+ force_next(';');
+ TOKEN(FORMRBRACK);
+ }
TOKEN(';');
case '&':
s++;
@@ -5772,10 +6195,12 @@
BAop(OP_BIT_AND);
}
- s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
- if (*PL_tokenbuf) {
+ PL_tokenbuf[0] = '&';
+ s = scan_ident(s - 1, PL_bufend, PL_tokenbuf + 1,
+ sizeof PL_tokenbuf - 1, TRUE);
+ if (PL_tokenbuf[1]) {
PL_expect = XOPERATOR;
- force_ident(PL_tokenbuf, '&');
+ force_ident_maybe_lex('&');
}
else
PREREF('&');
@@ -5829,7 +6254,8 @@
if (PL_expect == XSTATE && isALPHA(tmp) &&
(s == PL_linestart+1 || s[-2] == '\n') )
{
- if (PL_in_eval && !PL_rsfp) {
+ if ((PL_in_eval && !PL_rsfp && !PL_parser->filtered)
+ || PL_lex_state != LEX_NORMAL) {
d = PL_bufend;
while (s < d) {
if (*s++ == '\n') {
@@ -5860,7 +6286,7 @@
goto retry;
}
}
- if (PL_lex_brackets < PL_lex_formbrack) {
+ if (PL_expect == XBLOCK) {
const char *t = s;
#ifdef PERL_STRICT_CR
while (SPACE_OR_TAB(*t))
@@ -5869,8 +6295,12 @@
#endif
t++;
if (*t == '\n' || *t == '#') {
- s--;
- PL_expect = XBLOCK;
+ formbrack = 1;
+ ENTER;
+ SAVEI8(PL_parser->form_lex_state);
+ SAVEI32(PL_lex_formbrack);
+ PL_parser->form_lex_state = PL_lex_state;
+ PL_lex_formbrack = PL_lex_brackets + 1;
goto leftbracket;
}
}
@@ -5896,8 +6326,8 @@
if (*t == '/' || *t == '?' ||
((*t == 'm' || *t == 's' || *t == 'y')
- && !isALNUM(t[1])) ||
- (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
+ && !isWORDCHAR(t[1])) ||
+ (*t == 't' && t[1] == 'r' && !isWORDCHAR(t[2])))
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"!=~ should be !~");
}
@@ -5921,7 +6351,8 @@
s = scan_heredoc(s);
else
s = scan_inputsymbol(s);
- TERM(sublex_start());
+ PL_expect = XOPERATOR;
+ TOKEN(sublex_start());
}
s++;
{
@@ -6005,7 +6436,7 @@
if (!PL_tokenbuf[1])
PREREF(DOLSHARP);
PL_expect = XOPERATOR;
- PL_pending_ident = '#';
+ force_ident_maybe_lex('#');
TOKEN(DOLSHARP);
}
@@ -6020,14 +6451,6 @@
PREREF('$');
}
- /* This kludge not intended to be bulletproof. */
- if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
- pl_yylval.opval = newSVOP(OP_CONST, 0,
- newSViv(CopARYBASE_get(&PL_compiling)));
- pl_yylval.opval->op_private = OPpCONST_ARYBASE;
- TERM(THING);
- }
-
d = s;
{
const char tmp = *s;
@@ -6041,7 +6464,7 @@
if (ckWARN(WARN_SYNTAX)) {
char *t = s+1;
- while (isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$')
+ while (isSPACE(*t) || isWORDCHAR_lazy_if(t,UTF) || *t == '$')
t++;
if (*t++ == ',') {
PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
@@ -6069,10 +6492,12 @@
&len);
while (isSPACE(*t))
t++;
- if (*t == ';' && get_cvn_flags(tmpbuf, len, 0))
+ if (*t == ';'
+ && get_cvn_flags(tmpbuf, len, UTF ? SVf_UTF8 : 0))
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "You need to quote \"%s\"",
- tmpbuf);
+ "You need to quote \"%"SVf"\"",
+ SVfARG(newSVpvn_flags(tmpbuf, len,
+ SVs_TEMP | (UTF ? SVf_UTF8 : 0))));
}
}
}
@@ -6129,7 +6554,7 @@
PL_expect = XTERM; /* print $fh <<"EOF" */
}
}
- PL_pending_ident = '$';
+ force_ident_maybe_lex('$');
TOKEN('$');
case '@':
@@ -6150,20 +6575,24 @@
if (*s == '[' || *s == '{') {
if (ckWARN(WARN_SYNTAX)) {
const char *t = s + 1;
- while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
- t++;
+ while (*t && (isWORDCHAR_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
+ t += UTF ? UTF8SKIP(t) : 1;
if (*t == '}' || *t == ']') {
t++;
PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
+ /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "Scalar value %.*s better written as $%.*s",
- (int)(t-PL_bufptr), PL_bufptr,
- (int)(t-PL_bufptr-1), PL_bufptr+1);
+ "Scalar value %"SVf" better written as $%"SVf,
+ SVfARG(newSVpvn_flags(PL_bufptr, (STRLEN)(t-PL_bufptr),
+ SVs_TEMP | (UTF ? SVf_UTF8 : 0 ))),
+ SVfARG(newSVpvn_flags(PL_bufptr+1, (STRLEN)(t-PL_bufptr-1),
+ SVs_TEMP | (UTF ? SVf_UTF8 : 0 ))));
}
}
}
}
- PL_pending_ident = '@';
+ PL_expect = XOPERATOR;
+ force_ident_maybe_lex('@');
TERM('@');
case '/': /* may be division, defined-or, or pattern */
@@ -6214,7 +6643,7 @@
if (PL_oldoldbufptr == PL_last_uni
&& (*PL_last_uni != 's' || s - PL_last_uni < 5
|| memNE(PL_last_uni, "study", 5)
- || isALNUM_lazy_if(PL_last_uni+5,UTF)
+ || isWORDCHAR_lazy_if(PL_last_uni+5,UTF)
))
check_uni();
if (*s == '?')
@@ -6232,8 +6661,8 @@
#endif
&& (s == PL_linestart || s[-1] == '\n') )
{
- PL_lex_formbrack = 0;
PL_expect = XSTATE;
+ formbrack = 2; /* dot seen where arguments expected */
goto rightbracket;
}
if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
@@ -6274,7 +6703,7 @@
TERM(THING);
case '\'':
- s = scan_str(s,!!PL_madskills,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
if (PL_expect == XOPERATOR) {
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
@@ -6289,7 +6718,7 @@
TERM(sublex_start());
case '"':
- s = scan_str(s,!!PL_madskills,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
if (PL_expect == XOPERATOR) {
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
@@ -6312,7 +6741,7 @@
TERM(sublex_start());
case '`':
- s = scan_str(s,!!PL_madskills,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
if (PL_expect == XOPERATOR)
no_op("Backticks",s);
@@ -6339,11 +6768,20 @@
s = scan_num(s, &pl_yylval);
TERM(THING);
}
+ else if ((*start == ':' && start[1] == ':')
+ || (PL_expect == XSTATE && *start == ':'))
+ goto keylookup;
+ else if (PL_expect == XSTATE) {
+ d = start;
+ while (d < PL_bufend && isSPACE(*d)) d++;
+ if (*d == ':') goto keylookup;
+ }
/* avoid v123abc() or $h{v1}, allow C<print v10;> */
- else if (!isALPHA(*start) && (PL_expect == XTERM
+ if (!isALPHA(*start) && (PL_expect == XTERM
|| PL_expect == XREF || PL_expect == XSTATE
|| PL_expect == XTERMORDORDOR)) {
- GV *const gv = gv_fetchpvn_flags(s, start - s, 0, SVt_PVCV);
+ GV *const gv = gv_fetchpvn_flags(s, start - s,
+ UTF ? SVf_UTF8 : 0, SVt_PVCV);
if (!gv) {
s = scan_num(s, &pl_yylval);
TERM(THING);
@@ -6388,11 +6826,21 @@
keylookup: {
bool anydelim;
+ bool lex;
I32 tmp;
+ SV *sv;
+ CV *cv;
+ PADOFFSET off;
+ OP *rv2cv_op;
+ lex = FALSE;
orig_keyword = 0;
+ off = 0;
+ sv = NULL;
+ cv = NULL;
gv = NULL;
gvp = NULL;
+ rv2cv_op = NULL;
PL_bufptr = s;
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
@@ -6452,17 +6900,55 @@
if (!anydelim && PL_expect == XSTATE
&& d < PL_bufend && *d == ':' && *(d + 1) != ':') {
s = d + 1;
- pl_yylval.pval = CopLABEL_alloc(PL_tokenbuf);
+ pl_yylval.pval = savepvn(PL_tokenbuf, len+1);
+ pl_yylval.pval[len] = '\0';
+ pl_yylval.pval[len+1] = UTF ? 1 : 0;
CLINE;
TOKEN(LABEL);
}
+ /* Check for lexical sub */
+ if (PL_expect != XOPERATOR) {
+ char tmpbuf[sizeof PL_tokenbuf + 1];
+ *tmpbuf = '&';
+ Copy(PL_tokenbuf, tmpbuf+1, len, char);
+ off = pad_findmy_pvn(tmpbuf, len+1, UTF ? SVf_UTF8 : 0);
+ if (off != NOT_IN_PAD) {
+ assert(off); /* we assume this is boolean-true below */
+ if (PAD_COMPNAME_FLAGS_isOUR(off)) {
+ HV * const stash = PAD_COMPNAME_OURSTASH(off);
+ HEK * const stashname = HvNAME_HEK(stash);
+ sv = newSVhek(stashname);
+ sv_catpvs(sv, "::");
+ sv_catpvn_flags(sv, PL_tokenbuf, len,
+ (UTF ? SV_CATUTF8 : SV_CATBYTES));
+ gv = gv_fetchsv(sv, GV_NOADD_NOINIT | SvUTF8(sv),
+ SVt_PVCV);
+ off = 0;
+ if (!gv) {
+ sv_free(sv);
+ sv = NULL;
+ goto just_a_word;
+ }
+ }
+ else {
+ rv2cv_op = newOP(OP_PADANY, 0);
+ rv2cv_op->op_targ = off;
+ cv = find_lexical_cv(off);
+ }
+ lex = TRUE;
+ goto just_a_word;
+ }
+ off = 0;
+ }
+
if (tmp < 0) { /* second-class keyword? */
GV *ogv = NULL; /* override (winner) */
GV *hgv = NULL; /* hidden (loser) */
if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
CV *cv;
- if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVCV)) &&
+ if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
+ UTF ? SVf_UTF8 : 0, SVt_PVCV)) &&
(cv = GvCVu(gv)))
{
if (GvIMPORTED_CV(gv))
@@ -6471,7 +6957,8 @@
hgv = gv;
}
if (!ogv &&
- (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
+ (gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf,
+ UTF ? -(I32)len : (I32)len, FALSE)) &&
(gv = *gvp) && isGV_with_GP(gv) &&
GvCVu(gv) && GvIMPORTED_CV(gv))
{
@@ -6514,16 +7001,22 @@
earlier ':' case doesn't bypass the initialisation. */
if (0) {
just_a_word_zero_gv:
+ sv = NULL;
+ cv = NULL;
gv = NULL;
gvp = NULL;
+ rv2cv_op = NULL;
orig_keyword = 0;
+ lex = 0;
+ off = 0;
}
just_a_word: {
- SV *sv;
int pkgname = 0;
const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
- OP *rv2cv_op;
- CV *cv;
+ const char penultchar =
+ lastchar && PL_bufptr - 2 >= PL_linestart
+ ? PL_bufptr[-2]
+ : 0;
#ifdef PERL_MAD
SV *nextPL_nextwhite = 0;
#endif
@@ -6536,7 +7029,9 @@
s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
TRUE, &morelen);
if (!morelen)
- Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
+ Perl_croak(aTHX_ "Bad name after %"SVf"%s",
+ SVfARG(newSVpvn_flags(PL_tokenbuf, len,
+ (UTF ? SVf_UTF8 : 0) | SVs_TEMP )),
*s == '\'' ? "'" : "::");
len += morelen;
pkgname = 1;
@@ -6553,7 +7048,8 @@
}
/* Look for a subroutine with this name in current package,
- unless name is "Foo::", in which case Foo is a bareword
+ unless this is a lexical sub, or name is "Foo::",
+ in which case Foo is a bareword
(and a package name). */
if (len > 2 && !PL_madskills &&
@@ -6560,10 +7056,11 @@
PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
{
if (ckWARN(WARN_BAREWORD)
- && ! gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVHV))
+ && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
- "Bareword \"%s\" refers to nonexistent package",
- PL_tokenbuf);
+ "Bareword \"%"SVf"\" refers to nonexistent package",
+ SVfARG(newSVpvn_flags(PL_tokenbuf, len,
+ (UTF ? SVf_UTF8 : 0) | SVs_TEMP)));
len -= 2;
PL_tokenbuf[len] = '\0';
gv = NULL;
@@ -6570,13 +7067,14 @@
gvp = 0;
}
else {
- if (!gv) {
+ if (!lex && !gv) {
/* Mustn't actually add anything to a symbol table.
But also don't want to "initialise" any placeholder
constants that might already be there into full
blown PVGVs with attached PVCV. */
gv = gv_fetchpvn_flags(PL_tokenbuf, len,
- GV_NOADD_NOINIT, SVt_PVCV);
+ GV_NOADD_NOINIT | ( UTF ? SVf_UTF8 : 0 ),
+ SVt_PVCV);
}
len = 0;
}
@@ -6583,7 +7081,8 @@
/* if we saw a global override before, get the right name */
- sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
+ if (!sv)
+ sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
len ? len : strlen(PL_tokenbuf));
if (gvp) {
SV * const tmp_sv = sv;
@@ -6609,12 +7108,13 @@
if (len)
goto safe_bareword;
+ if (!off)
{
OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
const_op->op_private = OPpCONST_BARE;
rv2cv_op = newCVREF(0, const_op);
+ cv = lex ? GvCV(gv) : rv2cv_op_cv(rv2cv_op, 0);
}
- cv = rv2cv_op_cv(rv2cv_op, 0);
/* See if it's the indirect object for a list operator. */
@@ -6701,7 +7201,8 @@
}
start_force(PL_curforce);
#endif
- NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
+ NEXTVAL_NEXTTOKE.opval =
+ off ? rv2cv_op : pl_yylval.opval;
PL_expect = XOPERATOR;
#ifdef PERL_MAD
if (PL_madskills) {
@@ -6710,8 +7211,9 @@
PL_thistoken = newSVpvs("");
}
#endif
- op_free(rv2cv_op);
- force_next(WORD);
+ if (off)
+ op_free(pl_yylval.opval), force_next(PRIVATEREF);
+ else op_free(rv2cv_op), force_next(WORD);
pl_yylval.ival = 0;
TOKEN('&');
}
@@ -6743,10 +7245,12 @@
/* Not a method, so call it a subroutine (if defined) */
if (cv) {
- if (lastchar == '-')
- Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
- "Ambiguous use of -%s resolved as -&%s()",
- PL_tokenbuf, PL_tokenbuf);
+ if (lastchar == '-' && penultchar != '-') {
+ const SV *tmpsv = newSVpvn_flags( PL_tokenbuf, len ? len : strlen(PL_tokenbuf), (UTF ? SVf_UTF8 : 0) | SVs_TEMP );
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
+ "Ambiguous use of -%"SVf" resolved as -&%"SVf"()",
+ SVfARG(tmpsv), SVfARG(tmpsv));
+ }
/* Check for a constant sub */
if ((sv = cv_const_sv(cv))) {
its_constant:
@@ -6753,13 +7257,14 @@
op_free(rv2cv_op);
SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
- pl_yylval.opval->op_private = 0;
+ pl_yylval.opval->op_private = OPpCONST_FOLDED;
pl_yylval.opval->op_flags |= OPf_SPECIAL;
TOKEN(WORD);
}
op_free(pl_yylval.opval);
- pl_yylval.opval = rv2cv_op;
+ pl_yylval.opval =
+ off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op;
pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
PL_last_lop = PL_oldbufptr;
PL_last_lop_op = OP_ENTERSUB;
@@ -6770,12 +7275,15 @@
#endif
SvPOK(cv))
{
- STRLEN protolen;
- const char *proto = SvPV_const(MUTABLE_SV(cv), protolen);
+ STRLEN protolen = CvPROTOLEN(cv);
+ const char *proto = CvPROTO(cv);
+ bool optional;
if (!protolen)
TERM(FUNC0SUB);
- while (*proto == ';')
+ if ((optional = *proto == ';'))
+ do
proto++;
+ while (*proto == ';');
if (
(
(
@@ -6788,12 +7296,13 @@
*proto == '\\' && proto[1] && proto[2] == '\0'
)
)
- OPERATOR(UNIOPSUB);
+ UNIPROTO(UNIOPSUB,optional);
if (*proto == '\\' && proto[1] == '[') {
const char *p = proto + 2;
while(*p && *p != ']')
++p;
- if(*p == ']' && !p[1]) OPERATOR(UNIOPSUB);
+ if(*p == ']' && !p[1])
+ UNIPROTO(UNIOPSUB,optional);
}
if (*proto == '&' && *s == '{') {
if (PL_curstash)
@@ -6820,7 +7329,7 @@
curmad('X', PL_thistoken);
PL_thistoken = newSVpvs("");
}
- force_next(WORD);
+ force_next(off ? PRIVATEREF : WORD);
if (!PL_lex_allbrackets &&
PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
@@ -6848,9 +7357,11 @@
}
}
if (probable_sub) {
- gv = gv_fetchpv(PL_tokenbuf, GV_ADD, SVt_PVCV);
+ gv = gv_fetchpv(PL_tokenbuf, GV_ADD | ( UTF ? SVf_UTF8 : 0 ),
+ SVt_PVCV);
op_free(pl_yylval.opval);
- pl_yylval.opval = rv2cv_op;
+ pl_yylval.opval =
+ off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op;
pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
PL_last_lop = PL_oldbufptr;
PL_last_lop_op = OP_ENTERSUB;
@@ -6862,7 +7373,7 @@
PL_nextwhite = nextPL_nextwhite;
curmad('X', PL_thistoken);
PL_thistoken = newSVpvs("");
- force_next(WORD);
+ force_next(off ? PRIVATEREF : WORD);
if (!PL_lex_allbrackets &&
PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
@@ -6871,7 +7382,7 @@
#else
NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
PL_expect = XTERM;
- force_next(WORD);
+ force_next(off ? PRIVATEREF : WORD);
if (!PL_lex_allbrackets &&
PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
@@ -6902,7 +7413,7 @@
d = PL_tokenbuf;
while (isLOWER(*d))
d++;
- if (!*d && !gv_stashpv(PL_tokenbuf, 0))
+ if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
PL_tokenbuf);
}
@@ -6913,8 +7424,10 @@
safe_bareword:
if ((lastchar == '*' || lastchar == '%' || lastchar == '&')) {
Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
- "Operator or semicolon missing before %c%s",
- lastchar, PL_tokenbuf);
+ "Operator or semicolon missing before %c%"SVf,
+ lastchar, SVfARG(newSVpvn_flags(PL_tokenbuf,
+ strlen(PL_tokenbuf),
+ SVs_TEMP | (UTF ? SVf_UTF8 : 0))));
Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
"Ambiguous use of %c resolved as operator %c",
lastchar, lastchar);
@@ -6923,21 +7436,23 @@
}
case KEY___FILE__:
- pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
- newSVpv(CopFILE(PL_curcop),0));
- TERM(THING);
+ FUN0OP(
+ (OP*)newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
+ );
case KEY___LINE__:
- pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
- Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
- TERM(THING);
+ FUN0OP(
+ (OP*)newSVOP(OP_CONST, 0,
+ Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)))
+ );
case KEY___PACKAGE__:
- pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
+ FUN0OP(
+ (OP*)newSVOP(OP_CONST, 0,
(PL_curstash
? newSVhek(HvNAME_HEK(PL_curstash))
- : &PL_sv_undef));
- TERM(THING);
+ : &PL_sv_undef))
+ );
case KEY___DATA__:
case KEY___END__: {
@@ -6944,10 +7459,20 @@
GV *gv;
if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
const char *pname = "main";
+ STRLEN plen = 4;
+ U32 putf8 = 0;
if (PL_tokenbuf[2] == 'D')
- pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash);
- gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), GV_ADD,
- SVt_PVIO);
+ {
+ HV * const stash =
+ PL_curstash ? PL_curstash : PL_defstash;
+ pname = HvNAME_get(stash);
+ plen = HvNAMELEN (stash);
+ if(HvNAMEUTF8(stash)) putf8 = SVf_UTF8;
+ }
+ gv = gv_fetchpvn_flags(
+ Perl_form(aTHX_ "%*s::DATA", (int)plen, pname),
+ plen+6, GV_ADD|putf8, SVt_PVIO
+ );
GvMULTI_on(gv);
if (!GvIO(gv))
GvIOp(gv) = newIO();
@@ -6981,12 +7506,6 @@
#else
if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
#endif /* NETWARE */
-#ifdef PERLIO_IS_STDIO /* really? */
-# if defined(__BORLANDC__)
- /* XXX see note in do_binmode() */
- ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
-# endif
-#endif
if (loc > 0)
PerlIO_seek(PL_rsfp, loc, 0);
}
@@ -7037,6 +7556,9 @@
goto fake_eof;
}
+ case KEY___SUB__:
+ FUN0OP(newPVOP(OP_RUNCV,0,NULL));
+
case KEY_AUTOLOAD:
case KEY_DESTROY:
case KEY_BEGIN:
@@ -7052,14 +7574,26 @@
case KEY_CORE:
if (*s == ':' && s[1] == ':') {
+ STRLEN olen = len;
+ d = s;
s += 2;
- d = s;
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
- if (!(tmp = keyword(PL_tokenbuf, len, 0)))
- Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
+ if ((*s == ':' && s[1] == ':')
+ || (!(tmp = keyword(PL_tokenbuf, len, 1)) && *s == '\''))
+ {
+ s = d;
+ len = olen;
+ Copy(PL_bufptr, PL_tokenbuf, olen, char);
+ goto just_a_word;
+ }
+ if (!tmp)
+ Perl_croak(aTHX_ "CORE::%"SVf" is not a keyword",
+ SVfARG(newSVpvn_flags(PL_tokenbuf, len,
+ (UTF ? SVf_UTF8 : 0) | SVs_TEMP)));
if (tmp < 0)
tmp = -tmp;
- else if (tmp == KEY_require || tmp == KEY_do)
+ else if (tmp == KEY_require || tmp == KEY_do
+ || tmp == KEY_glob)
/* that's a way to remember we saw "CORE::" */
orig_keyword = tmp;
goto reserved_word;
@@ -7099,12 +7633,6 @@
UNI(OP_CHOP);
case KEY_continue:
- /* When 'use switch' is in effect, continue has a dual
- life as a control operator. */
- {
- if (!FEATURE_IS_ENABLED("switch"))
- PREBLOCK(CONTINUE);
- else {
/* We have to disambiguate the two senses of
"continue". If the next token is a '{' then
treat it as the start of a continue block;
@@ -7115,8 +7643,6 @@
PREBLOCK(CONTINUE);
else
FUN0(OP_CONTINUE);
- }
- }
case KEY_chdir:
/* may use HOME */
@@ -7171,8 +7697,18 @@
s = SKIPSPACE1(s);
if (*s == '{')
PRETERMBLOCK(DO);
- if (*s != '\'')
- s = force_word(s,WORD,TRUE,TRUE,FALSE);
+ if (*s != '\'') {
+ *PL_tokenbuf = '&';
+ d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
+ 1, &len);
+ if (len && !keyword(PL_tokenbuf + 1, len, 0)) {
+ d = SKIPSPACE1(d);
+ if (*d == '(') {
+ force_ident_maybe_lex('&');
+ s = d;
+ }
+ }
+ }
if (orig_keyword == KEY_do) {
orig_keyword = 0;
pl_yylval.ival = 1;
@@ -7205,6 +7741,7 @@
UNI(OP_DBMCLOSE);
case KEY_dump:
+ PL_expect = XOPERATOR;
s = force_word(s,WORD,TRUE,FALSE,FALSE);
LOOPX(OP_DUMP);
@@ -7239,6 +7776,10 @@
UNIBRACK(OP_ENTEREVAL);
}
+ case KEY_evalbytes:
+ PL_expect = XTERM;
+ UNIBRACK(-OP_ENTEREVAL);
+
case KEY_eof:
UNI(OP_EOF);
@@ -7307,6 +7848,9 @@
case KEY_fork:
FUN0(OP_FORK);
+ case KEY_fc:
+ UNI(OP_FC);
+
case KEY_fcntl:
LOP(OP_FCNTL,XTERM);
@@ -7330,6 +7874,7 @@
LOP(OP_GREPSTART, XREF);
case KEY_goto:
+ PL_expect = XOPERATOR;
s = force_word(s,WORD,TRUE,FALSE,FALSE);
LOOPX(OP_GOTO);
@@ -7416,10 +7961,16 @@
case KEY_given:
pl_yylval.ival = CopLINE(PL_curcop);
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
+ "given is experimental");
OPERATOR(GIVEN);
case KEY_glob:
- LOP(OP_GLOB,XTERM);
+ LOP(
+ orig_keyword==KEY_glob ? (orig_keyword=0, -OP_GLOB) : OP_GLOB,
+ XTERM
+ );
case KEY_hex:
UNI(OP_HEX);
@@ -7449,6 +8000,7 @@
LOP(OP_KILL,XTERM);
case KEY_last:
+ PL_expect = XOPERATOR;
s = force_word(s,WORD,TRUE,FALSE,FALSE);
LOOPX(OP_LAST);
@@ -7526,13 +8078,23 @@
#endif
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
+ {
+ if (!FEATURE_LEXSUBS_IS_ENABLED)
+ Perl_croak(aTHX_
+ "Experimental \"%s\" subs not enabled",
+ tmp == KEY_my ? "my" :
+ tmp == KEY_state ? "state" : "our");
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__LEXICAL_SUBS),
+ "The lexical_subs feature is experimental");
goto really_sub;
+ }
PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
if (!PL_in_my_stash) {
char tmpbuf[1024];
PL_bufptr = s;
my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
- yyerror(tmpbuf);
+ yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
}
#ifdef PERL_MAD
if (PL_madskills) { /* just add type to declarator token */
@@ -7546,6 +8108,7 @@
OPERATOR(MY);
case KEY_next:
+ PL_expect = XOPERATOR;
s = force_word(s,WORD,TRUE,FALSE,FALSE);
LOOPX(OP_NEXT);
@@ -7556,7 +8119,7 @@
case KEY_no:
s = tokenize_use(0, s);
- OPERATOR(USE);
+ TERM(USE);
case KEY_not:
if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
@@ -7571,19 +8134,22 @@
case KEY_open:
s = SKIPSPACE1(s);
if (isIDFIRST_lazy_if(s,UTF)) {
- const char *t;
- for (d = s; isALNUM_lazy_if(d,UTF);)
- d++;
+ const char *t;
+ d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE,
+ &len);
for (t=d; isSPACE(*t);)
t++;
if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
/* [perl #16184] */
&& !(t[0] == '=' && t[1] == '>')
+ && !(t[0] == ':' && t[1] == ':')
+ && !keyword(s, d-s, 0)
) {
- int parms_len = (int)(d-s);
+ SV *tmpsv = newSVpvn_flags(s, (STRLEN)(d-s),
+ SVs_TEMP | (UTF ? SVf_UTF8 : 0));
Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
- "Precedence problem: open %.*s should be open(%.*s)",
- parms_len, s, parms_len, s);
+ "Precedence problem: open %"SVf" should be open(%"SVf")",
+ SVfARG(tmpsv), SVfARG(tmpsv));
}
}
LOP(OP_OPEN,XTERM);
@@ -7637,7 +8203,7 @@
LOP(OP_PIPE_OP,XTERM);
case KEY_q:
- s = scan_str(s,!!PL_madskills,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
if (!s)
missingterm(NULL);
pl_yylval.ival = OP_CONST;
@@ -7648,12 +8214,13 @@
case KEY_qw: {
OP *words = NULL;
- s = scan_str(s,!!PL_madskills,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
if (!s)
missingterm(NULL);
PL_expect = XOPERATOR;
if (SvCUR(PL_lex_stuff)) {
- int warned = 0;
+ int warned_comma = !ckWARN(WARN_QW);
+ int warned_comment = warned_comma;
d = SvPV_force(PL_lex_stuff, len);
while (len) {
for (; isSPACE(*d) && len; --len, ++d)
@@ -7661,17 +8228,17 @@
if (len) {
SV *sv;
const char *b = d;
- if (!warned && ckWARN(WARN_QW)) {
+ if (!warned_comma || !warned_comment) {
for (; !isSPACE(*d) && len; --len, ++d) {
- if (*d == ',') {
+ if (!warned_comma && *d == ',') {
Perl_warner(aTHX_ packWARN(WARN_QW),
"Possible attempt to separate words with commas");
- ++warned;
+ ++warned_comma;
}
- else if (*d == '#') {
+ else if (!warned_comment && *d == '#') {
Perl_warner(aTHX_ packWARN(WARN_QW),
"Possible attempt to put comments in qw() list");
- ++warned;
+ ++warned_comment;
}
}
}
@@ -7697,7 +8264,7 @@
}
case KEY_qq:
- s = scan_str(s,!!PL_madskills,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
if (!s)
missingterm(NULL);
pl_yylval.ival = OP_STRINGIFY;
@@ -7710,7 +8277,7 @@
TERM(sublex_start());
case KEY_qx:
- s = scan_str(s,!!PL_madskills,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
if (!s)
missingterm(NULL);
readpipe_override();
@@ -7721,6 +8288,7 @@
case KEY_require:
s = SKIPSPACE1(s);
+ PL_expect = XOPERATOR;
if (isDIGIT(*s)) {
s = force_version(s, FALSE);
}
@@ -7730,7 +8298,8 @@
*PL_tokenbuf = '\0';
s = force_word(s,WORD,TRUE,TRUE,FALSE);
if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
- gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), GV_ADD);
+ gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
+ GV_ADD | (UTF ? SVf_UTF8 : 0));
else if (*s == '<')
yyerror("<> should be quotes");
}
@@ -7751,6 +8320,7 @@
UNI(OP_RESET);
case KEY_redo:
+ PL_expect = XOPERATOR;
s = force_word(s,WORD,TRUE,FALSE,FALSE);
LOOPX(OP_REDO);
@@ -7891,8 +8461,6 @@
case KEY_sort:
checkcomma(s,PL_tokenbuf,"subroutine name");
s = SKIPSPACE1(s);
- if (*s == ';' || *s == ')') /* probably a close */
- Perl_croak(aTHX_ "sort is now a reserved word");
PL_expect = XTERM;
s = force_word(s,WORD,TRUE,TRUE,FALSE);
LOP(OP_SORT,XREF);
@@ -7925,7 +8493,7 @@
case KEY_sub:
really_sub:
{
- char tmpbuf[sizeof PL_tokenbuf];
+ char * const tmpbuf = PL_tokenbuf + 1;
SSize_t tboffset = 0;
expectation attrful;
bool have_name, have_proto;
@@ -7935,12 +8503,15 @@
SV *tmpwhite = 0;
char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
- SV *subtoken = newSVpvn(tstart, s - tstart);
+ SV *subtoken = PL_madskills
+ ? newSVpvn_flags(tstart, s - tstart, SvUTF8(PL_linestr))
+ : NULL;
PL_thistoken = 0;
d = s;
s = SKIPSPACE2(s,tmpwhite);
#else
+ d = s;
s = skipspace(s);
#endif
@@ -7955,12 +8526,17 @@
attrful = XATTRBLOCK;
/* remember buffer pos'n for later force_word */
tboffset = s - PL_oldbufptr;
- d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
+ d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE,
+ &len);
#ifdef PERL_MAD
if (PL_madskills)
- nametoke = newSVpvn(s, d - s);
+ nametoke = newSVpvn_flags(s, d - s, SvUTF8(PL_linestr));
#endif
- if (memchr(tmpbuf, ':', len))
+ *PL_tokenbuf = '&';
+ if (memchr(tmpbuf, ':', len) || key != KEY_sub
+ || pad_findmy_pvn(
+ PL_tokenbuf, len + 1, UTF ? SVf_UTF8 : 0
+ ) != NOT_IN_PAD)
sv_setpvn(PL_subname, tmpbuf, len);
else {
sv_setsv(PL_subname,PL_curstname);
@@ -7967,15 +8543,16 @@
sv_catpvs(PL_subname,"::");
sv_catpvn(PL_subname,tmpbuf,len);
}
+ if (SvUTF8(PL_linestr))
+ SvUTF8_on(PL_subname);
have_name = TRUE;
+
#ifdef PERL_MAD
-
start_force(0);
CURMAD('X', nametoke);
CURMAD('_', tmpwhite);
- (void) force_word(PL_oldbufptr + tboffset, WORD,
- FALSE, TRUE, TRUE);
+ force_ident_maybe_lex('&');
s = SKIPSPACE2(d,tmpwhite);
#else
@@ -7983,8 +8560,13 @@
#endif
}
else {
- if (key == KEY_my)
- Perl_croak(aTHX_ "Missing name in \"my sub\"");
+ if (key == KEY_my || key == KEY_our || key==KEY_state)
+ {
+ *d = '\0';
+ /* diag_listed_as: Missing name in "%s sub" */
+ Perl_croak(aTHX_
+ "Missing name in \"%s\"", PL_bufptr);
+ }
PL_expect = XTERMBLOCK;
attrful = XATTRTERM;
sv_setpvs(PL_subname,"?");
@@ -7992,17 +8574,16 @@
}
if (key == KEY_format) {
- if (*s == '=')
- PL_lex_formbrack = PL_lex_brackets + 1;
#ifdef PERL_MAD
PL_thistoken = subtoken;
s = d;
+ PERL_UNUSED_VAR(tboffset);
#else
if (have_name)
(void) force_word(PL_oldbufptr + tboffset, WORD,
FALSE, TRUE, TRUE);
#endif
- OPERATOR(FORMAT);
+ PREBLOCK(FORMAT);
}
/* Look for a prototype */
@@ -8016,26 +8597,27 @@
bool underscore = FALSE;
bool seen_underscore = FALSE;
const bool warnillegalproto = ckWARN(WARN_ILLEGALPROTO);
+ STRLEN tmplen;
- s = scan_str(s,!!PL_madskills,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
if (!s)
Perl_croak(aTHX_ "Prototype not terminated");
/* strip spaces and check for bad characters */
- d = SvPVX(PL_lex_stuff);
+ d = SvPV(PL_lex_stuff, tmplen);
tmp = 0;
- for (p = d; *p; ++p) {
+ for (p = d; tmplen; tmplen--, ++p) {
if (!isSPACE(*p)) {
- d[tmp++] = *p;
+ d[tmp++] = *p;
if (warnillegalproto) {
if (must_be_last)
proto_after_greedy_proto = TRUE;
- if (!strchr("$@%*;[]&\\_+", *p)) {
+ if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
bad_proto = TRUE;
}
else {
if ( underscore ) {
- if ( *p != ';' )
+ if ( !strchr(";@%", *p) )
bad_proto = TRUE;
underscore = FALSE;
}
@@ -8058,17 +8640,26 @@
}
}
}
- d[tmp] = '\0';
+ d[tmp] = '\0';
if (proto_after_greedy_proto)
Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
"Prototype after '%c' for %"SVf" : %s",
greedy_proto, SVfARG(PL_subname), d);
- if (bad_proto)
+ if (bad_proto) {
+ SV *dsv = newSVpvs_flags("", SVs_TEMP);
Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
"Illegal character %sin prototype for %"SVf" : %s",
seen_underscore ? "after '_' " : "",
- SVfARG(PL_subname), d);
- SvCUR_set(PL_lex_stuff, tmp);
+ SVfARG(PL_subname),
+ SvUTF8(PL_lex_stuff)
+ ? sv_uni_display(dsv,
+ newSVpvn_flags(d, tmp, SVs_TEMP | SVf_UTF8),
+ tmp,
+ UNI_DISPLAY_ISPRINT)
+ : pv_pretty(dsv, d, tmp, 60, NULL, NULL,
+ PERL_PV_ESCAPE_NONASCII));
+ }
+ SvCUR_set(PL_lex_stuff, tmp);
have_proto = TRUE;
#ifdef PERL_MAD
@@ -8109,6 +8700,7 @@
force_next(0);
PL_thistoken = subtoken;
+ PERL_UNUSED_VAR(have_proto);
#else
if (have_proto) {
NEXTVAL_NEXTTOKE.opval =
@@ -8125,11 +8717,8 @@
TOKEN(ANONSUB);
}
#ifndef PERL_MAD
- (void) force_word(PL_oldbufptr + tboffset, WORD,
- FALSE, TRUE, TRUE);
+ force_ident_maybe_lex('&');
#endif
- if (key == KEY_my)
- TOKEN(MYSUB);
TOKEN(SUB);
}
@@ -8155,6 +8744,7 @@
LOP(OP_SYSWRITE,XTERM);
case KEY_tr:
+ case KEY_y:
s = scan_trans(s);
TERM(sublex_start());
@@ -8232,6 +8822,9 @@
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
return REPORT(0);
pl_yylval.ival = CopLINE(PL_curcop);
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
+ "when is experimental");
OPERATOR(WHEN);
case KEY_while:
@@ -8282,10 +8875,6 @@
return REPORT(0);
pl_yylval.ival = OP_XOR;
OPERATOR(OROP);
-
- case KEY_y:
- s = scan_trans(s);
- TERM(sublex_start());
}
}}
}
@@ -8293,20 +8882,36 @@
#pragma segment Main
#endif
+/*
+ S_pending_ident
+
+ Looks up an identifier in the pad or in a package
+
+ Returns:
+ PRIVATEREF if this is a lexical name.
+ WORD if this belongs to a package.
+
+ Structure:
+ if we're in a my declaration
+ croak if they tried to say my($foo::bar)
+ build the ops for a my() declaration
+ if it's an access to a my() variable
+ build ops for access to a my() variable
+ if in a dq string, and they've said @foo and we can't find @foo
+ warn
+ build ops for a bareword
+*/
+
static int
S_pending_ident(pTHX)
{
dVAR;
- register char *d;
PADOFFSET tmp = 0;
- /* pit holds the identifier we read and pending_ident is reset */
- char pit = PL_pending_ident;
+ const char pit = (char)pl_yylval.ival;
const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
/* All routes through this function want to know if there is a colon. */
const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
- PL_pending_ident = 0;
- /* PL_realtokenstart = realtokenend = PL_bufptr - SvPVX(PL_linestr); */
DEBUG_T({ PerlIO_printf(Perl_debug_log,
"### Pending identifier '%s'\n", PL_tokenbuf); });
@@ -8319,37 +8924,32 @@
if (PL_in_my) {
if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
if (has_colon)
- yyerror(Perl_form(aTHX_ "No package name allowed for "
+ yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
"variable %s in \"our\"",
- PL_tokenbuf));
- tmp = allocmy(PL_tokenbuf, tokenbuf_len, 0);
+ PL_tokenbuf), UTF ? SVf_UTF8 : 0);
+ tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
}
else {
if (has_colon)
- yyerror(Perl_form(aTHX_ PL_no_myglob,
- PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf));
+ yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
+ PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf),
+ UTF ? SVf_UTF8 : 0);
pl_yylval.opval = newOP(OP_PADANY, 0);
- pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len, 0);
- return PRIVATEREF;
+ pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
+ UTF ? SVf_UTF8 : 0);
+ return PRIVATEREF;
}
}
/*
build the ops for accesses to a my() variable.
-
- Deny my($a) or my($b) in a sort block, *if* $a or $b is
- then used in a comparison. This catches most, but not
- all cases. For instance, it catches
- sort { my($a); $a <=> $b }
- but not
- sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
- (although why you'd do that is anyone's guess).
*/
if (!has_colon) {
if (!PL_in_my)
- tmp = pad_findmy(PL_tokenbuf, tokenbuf_len, 0);
+ tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
+ UTF ? SVf_UTF8 : 0);
if (tmp != NOT_IN_PAD) {
/* might be an "our" variable" */
if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
@@ -8358,10 +8958,11 @@
HEK * const stashname = HvNAME_HEK(stash);
SV * const sym = newSVhek(stashname);
sv_catpvs(sym, "::");
- sv_catpvn(sym, PL_tokenbuf+1, tokenbuf_len - 1);
+ sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
pl_yylval.opval->op_private = OPpCONST_ENTERED;
- gv_fetchsv(sym,
+ if (pit != '&')
+ gv_fetchsv(sym,
(PL_in_eval
? (GV_ADDMULTI | GV_ADDINEVAL)
: GV_ADDMULTI
@@ -8372,23 +8973,6 @@
return WORD;
}
- /* if it's a sort block and they're naming $a or $b */
- if (PL_last_lop_op == OP_SORT &&
- PL_tokenbuf[0] == '$' &&
- (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
- && !PL_tokenbuf[2])
- {
- for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
- d < PL_bufend && *d != '\n';
- d++)
- {
- if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
- Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
- PL_tokenbuf);
- }
- }
- }
-
pl_yylval.opval = newOP(OP_PADANY, 0);
pl_yylval.opval->op_targ = tmp;
return PRIVATEREF;
@@ -8402,8 +8986,8 @@
*/
if (ckWARN(WARN_AMBIGUOUS) &&
pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
- GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1, 0,
- SVt_PVAV);
+ GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
+ ( UTF ? SVf_UTF8 : 0 ), SVt_PVAV);
if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
/* DO NOT warn for @- and @+ */
&& !( PL_tokenbuf[2] == '\0' &&
@@ -8412,17 +8996,22 @@
{
/* Downgraded from fatal to warning 20000522 mjd */
Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
- "Possible unintended interpolation of %s in string",
- PL_tokenbuf);
+ "Possible unintended interpolation of %"SVf" in string",
+ SVfARG(newSVpvn_flags(PL_tokenbuf, tokenbuf_len,
+ SVs_TEMP | ( UTF ? SVf_UTF8 : 0 ))));
}
}
/* build ops for a bareword */
- pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn(PL_tokenbuf + 1,
- tokenbuf_len - 1));
+ pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
+ newSVpvn_flags(PL_tokenbuf + 1,
+ tokenbuf_len - 1,
+ UTF ? SVf_UTF8 : 0 ));
pl_yylval.opval->op_private = OPpCONST_ENTERED;
- gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
- PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD,
+ if (pit != '&')
+ gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
+ (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD)
+ | ( UTF ? SVf_UTF8 : 0 ),
((PL_tokenbuf[0] == '$') ? SVt_PV
: (PL_tokenbuf[0] == '@') ? SVt_PVAV
: SVt_PVHV));
@@ -8464,9 +9053,10 @@
while (s < PL_bufend && isSPACE(*s))
s++;
if (isIDFIRST_lazy_if(s,UTF)) {
- const char * const w = s++;
- while (isALNUM_lazy_if(s,UTF))
- s++;
+ const char * const w = s;
+ s += UTF ? UTF8SKIP(s) : 1;
+ while (isWORDCHAR_lazy_if(s,UTF))
+ s += UTF ? UTF8SKIP(s) : 1;
while (s < PL_bufend && isSPACE(*s))
s++;
if (*s == ',') {
@@ -8474,7 +9064,7 @@
if (keyword(w, s - w, 0))
return;
- gv = gv_fetchpvn_flags(w, s - w, 0, SVt_PVCV);
+ gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
if (gv && GvCVu(gv))
return;
Perl_croak(aTHX_ "No comma allowed after %s", what);
@@ -8482,10 +9072,13 @@
}
}
-/* Either returns sv, or mortalizes sv and returns a new SV*.
+/* S_new_constant(): do any overload::constant lookup.
+
+ Either returns sv, or mortalizes/frees sv and returns a new SV*.
Best used as sv=new_constant(..., sv, ...).
If s, pv are NULL, calls subroutine with one argument,
- and type is used with error messages only. */
+ and <type> is used with error messages only.
+ <type> is assumed to be well formed UTF-8 */
STATIC SV *
S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
@@ -8492,52 +9085,83 @@
SV *sv, SV *pv, const char *type, STRLEN typelen)
{
dVAR; dSP;
- HV * const table = GvHV(PL_hintgv); /* ^H */
+ HV * table = GvHV(PL_hintgv); /* ^H */
SV *res;
+ SV *errsv = NULL;
SV **cvp;
SV *cv, *typesv;
const char *why1 = "", *why2 = "", *why3 = "";
PERL_ARGS_ASSERT_NEW_CONSTANT;
+ /* We assume that this is true: */
+ if (*key == 'c') { assert (strEQ(key, "charnames")); }
+ assert(type || s);
- if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
- SV *msg;
-
- why2 = (const char *)
- (strEQ(key,"charnames")
- ? "(possibly a missing \"use charnames ...\")"
- : "");
- msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
- (type ? type: "undef"), why2);
-
- /* This is convoluted and evil ("goto considered harmful")
- * but I do not understand the intricacies of all the different
- * failure modes of %^H in here. The goal here is to make
- * the most probable error message user-friendly. --jhi */
-
- goto msgdone;
-
- report:
- msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
- (type ? type: "undef"), why1, why2, why3);
- msgdone:
- yyerror(SvPVX_const(msg));
- SvREFCNT_dec(msg);
- return sv;
- }
-
/* charnames doesn't work well if there have been errors found */
- if (PL_error_count > 0 && strEQ(key,"charnames"))
+ if (PL_error_count > 0 && *key == 'c')
+ {
+ SvREFCNT_dec_NN(sv);
return &PL_sv_undef;
+ }
- cvp = hv_fetch(table, key, keylen, FALSE);
- if (!cvp || !SvOK(*cvp)) {
- why1 = "$^H{";
- why2 = key;
- why3 = "} is not defined";
- goto report;
+ sv_2mortal(sv); /* Parent created it permanently */
+ if (!table
+ || ! (PL_hints & HINT_LOCALIZE_HH)
+ || ! (cvp = hv_fetch(table, key, keylen, FALSE))
+ || ! SvOK(*cvp))
+ {
+ char *msg;
+
+ /* Here haven't found what we're looking for. If it is charnames,
+ * perhaps it needs to be loaded. Try doing that before giving up */
+ if (*key == 'c') {
+ Perl_load_module(aTHX_
+ 0,
+ newSVpvs("_charnames"),
+ /* version parameter; no need to specify it, as if
+ * we get too early a version, will fail anyway,
+ * not being able to find '_charnames' */
+ NULL,
+ newSVpvs(":full"),
+ newSVpvs(":short"),
+ NULL);
+ SPAGAIN;
+ table = GvHV(PL_hintgv);
+ if (table
+ && (PL_hints & HINT_LOCALIZE_HH)
+ && (cvp = hv_fetch(table, key, keylen, FALSE))
+ && SvOK(*cvp))
+ {
+ goto now_ok;
+ }
+ }
+ if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
+ msg = Perl_form(aTHX_
+ "Constant(%.*s) unknown",
+ (int)(type ? typelen : len),
+ (type ? type: s));
+ }
+ else {
+ why1 = "$^H{";
+ why2 = key;
+ why3 = "} is not defined";
+ report:
+ if (*key == 'c') {
+ msg = Perl_form(aTHX_
+ /* The +3 is for '\N{'; -4 for that, plus '}' */
+ "Unknown charname '%.*s'", (int)typelen - 4, type + 3
+ );
+ }
+ else {
+ msg = Perl_form(aTHX_ "Constant(%.*s): %s%s%s",
+ (int)(type ? typelen : len),
+ (type ? type: s), why1, why2, why3);
+ }
+ }
+ yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
+ return SvREFCNT_inc_simple_NN(sv);
}
- sv_2mortal(sv); /* Parent created it permanently */
+now_ok:
cv = *cvp;
if (!pv && s)
pv = newSVpvn_flags(s, len, SVs_TEMP);
@@ -8563,15 +9187,18 @@
SPAGAIN ;
/* Check the eval first */
- if (!PL_in_eval && SvTRUE(ERRSV)) {
- sv_catpvs(ERRSV, "Propagated");
- yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
+ if (!PL_in_eval && ((errsv = ERRSV), SvTRUE_NN(errsv))) {
+ STRLEN errlen;
+ const char * errstr;
+ sv_catpvs(errsv, "Propagated");
+ errstr = SvPV_const(errsv, errlen);
+ yyerror_pvn(errstr, errlen, 0); /* Duplicates the message inside eval */
(void)POPs;
- res = SvREFCNT_inc_simple(sv);
+ res = SvREFCNT_inc_simple_NN(sv);
}
else {
res = POPs;
- SvREFCNT_inc_simple_void(res);
+ SvREFCNT_inc_simple_void_NN(res);
}
PUTBACK ;
@@ -8584,6 +9211,7 @@
why2 = key;
why3 = "}} did not return a defined value";
sv = res;
+ (void)sv_2mortal(sv);
goto report;
}
@@ -8590,60 +9218,82 @@
return res;
}
+PERL_STATIC_INLINE void
+S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, bool is_utf8) {
+ dVAR;
+ PERL_ARGS_ASSERT_PARSE_IDENT;
+
+ for (;;) {
+ if (*d >= e)
+ Perl_croak(aTHX_ "%s", ident_too_long);
+ if (is_utf8 && isIDFIRST_utf8((U8*)*s)) {
+ /* The UTF-8 case must come first, otherwise things
+ * like c\N{COMBINING TILDE} would start failing, as the
+ * isWORDCHAR_A case below would gobble the 'c' up.
+ */
+
+ char *t = *s + UTF8SKIP(*s);
+ while (isIDCONT_utf8((U8*)t))
+ t += UTF8SKIP(t);
+ if (*d + (t - *s) > e)
+ Perl_croak(aTHX_ "%s", ident_too_long);
+ Copy(*s, *d, t - *s, char);
+ *d += t - *s;
+ *s = t;
+ }
+ else if ( isWORDCHAR_A(**s) ) {
+ do {
+ *(*d)++ = *(*s)++;
+ } while isWORDCHAR_A(**s);
+ }
+ else if (allow_package && **s == '\'' && isIDFIRST_lazy_if(*s+1,is_utf8)) {
+ *(*d)++ = ':';
+ *(*d)++ = ':';
+ (*s)++;
+ }
+ else if (allow_package && **s == ':' && (*s)[1] == ':'
+ /* Disallow things like Foo::$bar. For the curious, this is
+ * the code path that triggers the "Bad name after" warning
+ * when looking for barewords.
+ */
+ && (*s)[2] != '$') {
+ *(*d)++ = *(*s)++;
+ *(*d)++ = *(*s)++;
+ }
+ else
+ break;
+ }
+ return;
+}
+
/* Returns a NUL terminated string, with the length of the string written to
*slp
*/
STATIC char *
-S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
+S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
{
dVAR;
- register char *d = dest;
- register char * const e = d + destlen - 3; /* two-character token, ending NUL */
+ char *d = dest;
+ char * const e = d + destlen - 3; /* two-character token, ending NUL */
+ bool is_utf8 = cBOOL(UTF);
PERL_ARGS_ASSERT_SCAN_WORD;
- for (;;) {
- if (d >= e)
- Perl_croak(aTHX_ ident_too_long);
- if (isALNUM(*s)) /* UTF handled below */
- *d++ = *s++;
- else if (allow_package && (*s == '\'') && isIDFIRST_lazy_if(s+1,UTF)) {
- *d++ = ':';
- *d++ = ':';
- s++;
- }
- else if (allow_package && (s[0] == ':') && (s[1] == ':') && (s[2] != '$')) {
- *d++ = *s++;
- *d++ = *s++;
- }
- else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
- char *t = s + UTF8SKIP(s);
- size_t len;
- while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
- t += UTF8SKIP(t);
- len = t - s;
- if (d + len > e)
- Perl_croak(aTHX_ ident_too_long);
- Copy(s, d, len, char);
- d += len;
- s = t;
- }
- else {
- *d = '\0';
- *slp = d - dest;
- return s;
- }
- }
+ parse_ident(&s, &d, e, allow_package, is_utf8);
+ *d = '\0';
+ *slp = d - dest;
+ return s;
}
STATIC char *
-S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
+S_scan_ident(pTHX_ char *s, const char *send, char *dest, STRLEN destlen, I32 ck_uni)
{
dVAR;
char *bracket = NULL;
char funny = *s++;
- register char *d = dest;
- register char * const e = d + destlen - 3; /* two-character token, ending NUL */
+ char *d = dest;
+ char * const e = d + destlen - 3; /* two-character token, ending NUL */
+ bool is_utf8 = cBOOL(UTF);
PERL_ARGS_ASSERT_SCAN_IDENT;
@@ -8652,38 +9302,12 @@
if (isDIGIT(*s)) {
while (isDIGIT(*s)) {
if (d >= e)
- Perl_croak(aTHX_ ident_too_long);
+ Perl_croak(aTHX_ "%s", ident_too_long);
*d++ = *s++;
}
}
else {
- for (;;) {
- if (d >= e)
- Perl_croak(aTHX_ ident_too_long);
- if (isALNUM(*s)) /* UTF handled below */
- *d++ = *s++;
- else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
- *d++ = ':';
- *d++ = ':';
- s++;
- }
- else if (*s == ':' && s[1] == ':') {
- *d++ = *s++;
- *d++ = *s++;
- }
- else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
- char *t = s + UTF8SKIP(s);
- while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
- t += UTF8SKIP(t);
- if (d + (t - s) > e)
- Perl_croak(aTHX_ ident_too_long);
- Copy(s, d, t - s, char);
- d += t - s;
- s = t;
- }
- else
- break;
- }
+ parse_ident(&s, &d, e, 1, is_utf8);
}
*d = '\0';
d = dest;
@@ -8693,7 +9317,11 @@
return s;
}
if (*s == '$' && s[1] &&
- (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
+ (isIDFIRST_lazy_if(s+1,is_utf8)
+ || isDIGIT_A((U8)s[1])
+ || s[1] == '$'
+ || s[1] == '{'
+ || strnEQ(s+1,"::",2)) )
{
return s;
}
@@ -8700,45 +9328,39 @@
if (*s == '{') {
bracket = s;
s++;
+ while (s < send && SPACE_OR_TAB(*s))
+ s++;
}
- else if (ck_uni)
- check_uni();
- if (s < send)
- *d = *s++;
- d[1] = '\0';
+
+#define VALID_LEN_ONE_IDENT(d, u) (isPUNCT_A((U8)*(d)) \
+ || isCNTRL_A((U8)*(d)) \
+ || isDIGIT_A((U8)*(d)) \
+ || (!(u) && !UTF8_IS_INVARIANT((U8)*(d))))
+ if (s < send
+ && (isIDFIRST_lazy_if(s, is_utf8) || VALID_LEN_ONE_IDENT(s, is_utf8)))
+ {
+ if (is_utf8) {
+ const STRLEN skip = UTF8SKIP(s);
+ STRLEN i;
+ d[skip] = '\0';
+ for ( i = 0; i < skip; i++ )
+ d[i] = *s++;
+ }
+ else {
+ *d = *s++;
+ d[1] = '\0';
+ }
+ }
if (*d == '^' && *s && isCONTROLVAR(*s)) {
*d = toCTRL(*s);
s++;
}
+ else if (ck_uni && !bracket)
+ check_uni();
if (bracket) {
- if (isSPACE(s[-1])) {
- while (s < send) {
- const char ch = *s++;
- if (!SPACE_OR_TAB(ch)) {
- *d = ch;
- break;
- }
- }
- }
- if (isIDFIRST_lazy_if(d,UTF)) {
- d++;
- if (UTF) {
- char *end = s;
- while ((end < send && isALNUM_lazy_if(end,UTF)) || *end == ':') {
- end += UTF8SKIP(end);
- while (end < send && UTF8_IS_CONTINUED(*end) && is_utf8_mark((U8*)end))
- end += UTF8SKIP(end);
- }
- Copy(s, d, end - s, char);
- d += end - s;
- s = end;
- }
- else {
- while ((isALNUM(*s) || *s == ':') && d < e)
- *d++ = *s++;
- if (d >= e)
- Perl_croak(aTHX_ ident_too_long);
- }
+ if (isIDFIRST_lazy_if(d,is_utf8)) {
+ d += is_utf8 ? UTF8SKIP(d) : 1;
+ parse_ident(&s, &d, e, 1, is_utf8);
*d = '\0';
while (s < send && SPACE_OR_TAB(*s))
s++;
@@ -8760,17 +9382,21 @@
}
/* Handle extended ${^Foo} variables
* 1999-02-27 mjd-perl-patch at plover.com */
- else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
- && isALNUM(*s))
+ else if (!isWORDCHAR(*d) && !isPRINT(*d) /* isCTRL(d) */
+ && isWORDCHAR(*s))
{
d++;
- while (isALNUM(*s) && d < e) {
+ while (isWORDCHAR(*s) && d < e) {
*d++ = *s++;
}
if (d >= e)
- Perl_croak(aTHX_ ident_too_long);
+ Perl_croak(aTHX_ "%s", ident_too_long);
*d = '\0';
}
+
+ while (s < send && SPACE_OR_TAB(*s))
+ s++;
+
if (*s == '}') {
s++;
if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
@@ -8780,13 +9406,15 @@
if (PL_lex_state == LEX_NORMAL) {
if (ckWARN(WARN_AMBIGUOUS) &&
(keyword(dest, d - dest, 0)
- || get_cvn_flags(dest, d - dest, 0)))
+ || get_cvn_flags(dest, d - dest, is_utf8 ? SVf_UTF8 : 0)))
{
+ SV *tmp = newSVpvn_flags( dest, d - dest,
+ SVs_TEMP | (is_utf8 ? SVf_UTF8 : 0) );
if (funny == '#')
funny = '@';
Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
- "Ambiguous use of %c{%s} resolved to %c%s",
- funny, dest, funny, dest);
+ "Ambiguous use of %c{%"SVf"} resolved to %c%"SVf,
+ funny, tmp, funny, tmp);
}
}
}
@@ -8806,18 +9434,24 @@
/* Adds, subtracts to/from 'pmfl' based on regex modifier flags found in
* the parse starting at 's', based on the subset that are valid in this
* context input to this routine in 'valid_flags'. Advances s. Returns
- * TRUE if the input was a valid flag, so the next char may be as well;
- * otherwise FALSE. 'charset' should point to a NUL upon first call on the
- * current regex. This routine will set it to any charset modifier found.
- * The caller shouldn't change it. This way, another charset modifier
- * encountered in the parse can be detected as an error, as we have decided
- * allow only one */
+ * TRUE if the input should be treated as a valid flag, so the next char
+ * may be as well; otherwise FALSE. 'charset' should point to a NUL upon
+ * first call on the current regex. This routine will set it to any
+ * charset modifier found. The caller shouldn't change it. This way,
+ * another charset modifier encountered in the parse can be detected as an
+ * error, as we have decided to allow only one */
const char c = **s;
+ STRLEN charlen = UTF ? UTF8SKIP(*s) : 1;
- if (! strchr(valid_flags, c)) {
- if (isALNUM(c)) {
- goto deprecate;
+ if ( charlen != 1 || ! strchr(valid_flags, c) ) {
+ if (isWORDCHAR_lazy_if(*s, UTF)) {
+ yyerror_pv(Perl_form(aTHX_ "Unknown regexp modifier \"/%.*s\"", (int)charlen, *s),
+ UTF ? SVf_UTF8 : 0);
+ (*s) += charlen;
+ /* Pretend that it worked, so will continue processing before
+ * dieing */
+ return TRUE;
}
return FALSE;
}
@@ -8831,34 +9465,6 @@
case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
case LOCALE_PAT_MOD:
-
- /* In 5.14, qr//lt is legal but deprecated; the 't' means they
- * can't be regex modifiers.
- * In 5.14, s///le is legal and ambiguous. Try to disambiguate as
- * much as easily done. s///lei, for example, has to mean regex
- * modifiers if it's not an error (as does any word character
- * following the 'e'). Otherwise, we resolve to the backwards-
- * compatible, but less likely 's/// le ...', i.e. as meaning
- * less-than-or-equal. The reason it's not likely is that s//
- * returns a number for code in the field (/r returns a string, but
- * that wasn't added until the 5.13 series), and so '<=' should be
- * used for comparing, not 'le'. */
- if (*((*s) + 1) == 't') {
- goto deprecate;
- }
- else if (*((*s) + 1) == 'e' && ! isALNUM(*((*s) + 2))) {
-
- /* 'e' is valid only for substitutes, s///e. If it is not
- * valid in the current context, then 'm//le' must mean the
- * comparison operator, so use the regular deprecation message.
- */
- if (! strchr(valid_flags, 'e')) {
- goto deprecate;
- }
- Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
- "Ambiguous use of 's//le...' resolved as 's// le...'; Rewrite as 's//el' if you meant 'use locale rules and evaluate rhs as an expression'. In Perl 5.16, it will be resolved the other way");
- return FALSE;
- }
if (*charset) {
goto multiple_charsets;
}
@@ -8866,11 +9472,6 @@
*charset = c;
break;
case UNICODE_PAT_MOD:
- /* In 5.14, qr//unless and qr//until are legal but deprecated; the
- * 'n' means they can't be regex modifiers */
- if (*((*s) + 1) == 'n') {
- goto deprecate;
- }
if (*charset) {
goto multiple_charsets;
}
@@ -8878,12 +9479,6 @@
*charset = c;
break;
case ASCII_RESTRICT_PAT_MOD:
- /* In 5.14, qr//and is legal but deprecated; the 'n' means they
- * can't be regex modifiers */
- if (*((*s) + 1) == 'n') {
- goto deprecate;
- }
-
if (! *charset) {
set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
}
@@ -8913,11 +9508,6 @@
(*s)++;
return TRUE;
- deprecate:
- Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX),
- "Having no space between pattern and following word is deprecated");
- return FALSE;
-
multiple_charsets:
if (*charset != c) {
yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
@@ -8939,7 +9529,7 @@
{
dVAR;
PMOP *pm;
- char *s = scan_str(start,!!PL_madskills,FALSE);
+ char *s;
const char * const valid_flags =
(const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
char charset = '\0'; /* character set modifier */
@@ -8949,6 +9539,9 @@
PERL_ARGS_ASSERT_SCAN_PAT;
+ s = scan_str(start,!!PL_madskills,FALSE, (PL_in_eval & EVAL_RE_REPARSING),
+ TRUE /* look for escaped bracketed metas */ );
+
if (!s) {
const char * const delimiter = skipspace(start);
Perl_croak(aTHX_
@@ -8984,6 +9577,25 @@
#ifdef PERL_MAD
modstart = s;
#endif
+
+ /* if qr/...(?{..}).../, then need to parse the pattern within a new
+ * anon CV. False positives like qr/[(?{]/ are harmless */
+
+ if (type == OP_QR) {
+ STRLEN len;
+ char *e, *p = SvPV(PL_lex_stuff, len);
+ e = p + len;
+ for (; p < e; p++) {
+ if (p[0] == '(' && p[1] == '?'
+ && (p[2] == '{' || (p[2] == '?' && p[3] == '{')))
+ {
+ pm->op_pmflags |= PMf_HAS_CV;
+ break;
+ }
+ }
+ pm->op_pmflags |= PMf_IS_QR;
+ }
+
while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags), &s, &charset)) {};
#ifdef PERL_MAD
if (PL_madskills && modstart != s) {
@@ -9008,7 +9620,7 @@
{
dVAR;
char *s;
- register PMOP *pm;
+ PMOP *pm;
I32 first_start;
I32 es = 0;
char charset = '\0'; /* character set modifier */
@@ -9020,7 +9632,8 @@
pl_yylval.ival = OP_NULL;
- s = scan_str(start,!!PL_madskills,FALSE);
+ s = scan_str(start,!!PL_madskills,FALSE,FALSE,
+ TRUE /* look for escaped bracketed metas */ );
if (!s)
Perl_croak(aTHX_ "Substitution pattern not terminated");
@@ -9038,7 +9651,7 @@
#endif
first_start = PL_multi_start;
- s = scan_str(s,!!PL_madskills,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
if (!s) {
if (PL_lex_stuff) {
SvREFCNT_dec(PL_lex_stuff);
@@ -9085,8 +9698,6 @@
if (es) {
SV * const repl = newSVpvs("");
- PL_sublex_info.super_bufptr = s;
- PL_sublex_info.super_bufend = PL_bufend;
PL_multi_end = 0;
pm->op_pmflags |= PMf_EVAL;
while (es-- > 0) {
@@ -9096,13 +9707,11 @@
sv_catpvs(repl, "do ");
}
sv_catpvs(repl, "{");
- sv_catsv(repl, PL_lex_repl);
- if (strchr(SvPVX(PL_lex_repl), '#'))
- sv_catpvs(repl, "\n");
+ sv_catsv(repl, PL_sublex_info.repl);
sv_catpvs(repl, "}");
SvEVALED_on(repl);
- SvREFCNT_dec(PL_lex_repl);
- PL_lex_repl = repl;
+ SvREFCNT_dec(PL_sublex_info.repl);
+ PL_sublex_info.repl = repl;
}
PL_lex_op = (OP*)pm;
@@ -9114,9 +9723,8 @@
S_scan_trans(pTHX_ char *start)
{
dVAR;
- register char* s;
+ char* s;
OP *o;
- short *tbl;
U8 squash;
U8 del;
U8 complement;
@@ -9129,7 +9737,7 @@
pl_yylval.ival = OP_NULL;
- s = scan_str(start,!!PL_madskills,FALSE);
+ s = scan_str(start,!!PL_madskills,FALSE,FALSE, FALSE);
if (!s)
Perl_croak(aTHX_ "Transliteration pattern not terminated");
@@ -9145,7 +9753,7 @@
}
#endif
- s = scan_str(s,!!PL_madskills,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
if (!s) {
if (PL_lex_stuff) {
SvREFCNT_dec(PL_lex_stuff);
@@ -9184,12 +9792,11 @@
}
no_more:
- tbl = (short *)PerlMemShared_calloc(complement&&!del?258:256, sizeof(short));
- o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)tbl);
+ o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL);
o->op_private &= ~OPpTRANS_ALL;
o->op_private |= del|squash|complement|
(DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
- (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
+ (DO_UTF8(PL_sublex_info.repl) ? OPpTRANS_TO_UTF : 0);
PL_lex_op = o;
pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
@@ -9206,20 +9813,43 @@
return s;
}
+/* scan_heredoc
+ Takes a pointer to the first < in <<FOO.
+ Returns a pointer to the byte following <<FOO.
+
+ This function scans a heredoc, which involves different methods
+ depending on whether we are in a string eval, quoted construct, etc.
+ This is because PL_linestr could containing a single line of input, or
+ a whole string being evalled, or the contents of the current quote-
+ like operator.
+
+ The two basic methods are:
+ - Steal lines from the input stream
+ - Scan the heredoc in PL_linestr and remove it therefrom
+
+ In a file scope or filtered eval, the first method is used; in a
+ string eval, the second.
+
+ In a quote-like operator, we have to choose between the two,
+ depending on where we can find a newline. We peek into outer lex-
+ ing scopes until we find one with a newline in it. If we reach the
+ outermost lexing scope and it is a file, we use the stream method.
+ Otherwise it is treated as an eval.
+*/
+
STATIC char *
-S_scan_heredoc(pTHX_ register char *s)
+S_scan_heredoc(pTHX_ char *s)
{
dVAR;
- SV *herewas;
I32 op_type = OP_SCALAR;
I32 len;
SV *tmpstr;
char term;
- const char *found_newline;
- register char *d;
- register char *e;
+ char *d;
+ char *e;
char *peek;
- const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
+ const bool infile = PL_rsfp || PL_parser->filtered;
+ LEXSHARED *shared = PL_parser->lex_shared;
#ifdef PERL_MAD
I32 stuffstart = s - SvPVX(PL_linestr);
char *tstart;
@@ -9230,10 +9860,9 @@
PERL_ARGS_ASSERT_SCAN_HEREDOC;
s += 2;
- d = PL_tokenbuf;
+ d = PL_tokenbuf + 1;
e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
- if (!outer)
- *d++ = '\n';
+ *PL_tokenbuf = '\n';
peek = s;
while (SPACE_OR_TAB(*peek))
peek++;
@@ -9241,18 +9870,20 @@
s = peek;
term = *s++;
s = delimcpy(d, e, s, PL_bufend, term, &len);
+ if (s == PL_bufend)
+ Perl_croak(aTHX_ "Unterminated delimiter for here document");
d += len;
- if (s < PL_bufend)
- s++;
+ s++;
}
else {
if (*s == '\\')
+ /* <<\FOO is equivalent to <<'FOO' */
s++, term = '\'';
else
term = '"';
- if (!isALNUM_lazy_if(s,UTF))
+ if (!isWORDCHAR_lazy_if(s,UTF))
deprecate("bare << to mean <<\"\"");
- for (; isALNUM_lazy_if(s,UTF); s++) {
+ for (; isWORDCHAR_lazy_if(s,UTF); s++) {
if (d < e)
*d++ = *s;
}
@@ -9265,8 +9896,8 @@
#ifdef PERL_MAD
if (PL_madskills) {
- tstart = PL_tokenbuf + !outer;
- PL_thisclose = newSVpvn(tstart, len - !outer);
+ tstart = PL_tokenbuf + 1;
+ PL_thisclose = newSVpvn(tstart, len - 1);
tstart = SvPVX(PL_linestr) + stuffstart;
PL_thisopen = newSVpvn(tstart, s - tstart);
stuffstart = s - SvPVX(PL_linestr);
@@ -9297,20 +9928,6 @@
}
#endif
#ifdef PERL_MAD
- found_newline = 0;
-#endif
- if ( outer || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s)) ) {
- herewas = newSVpvn(s,PL_bufend-s);
- }
- else {
-#ifdef PERL_MAD
- herewas = newSVpvn(s-1,found_newline-s+1);
-#else
- s--;
- herewas = newSVpvn(s,found_newline-s);
-#endif
- }
-#ifdef PERL_MAD
if (PL_madskills) {
tstart = SvPVX(PL_linestr) + stuffstart;
if (PL_thisstuff)
@@ -9318,14 +9935,8 @@
else
PL_thisstuff = newSVpvn(tstart, s - tstart);
}
-#endif
- s += SvCUR(herewas);
-#ifdef PERL_MAD
stuffstart = s - SvPVX(PL_linestr);
-
- if (found_newline)
- s--;
#endif
tmpstr = newSV_type(SVt_PVIV);
@@ -9339,46 +9950,57 @@
SvIV_set(tmpstr, '\\');
}
- CLINE;
- PL_multi_start = CopLINE(PL_curcop);
+ PL_multi_start = CopLINE(PL_curcop) + 1;
PL_multi_open = PL_multi_close = '<';
- term = *PL_tokenbuf;
- if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
- char * const bufptr = PL_sublex_info.super_bufptr;
- char * const bufend = PL_sublex_info.super_bufend;
- char * const olds = s - SvCUR(herewas);
- s = strchr(bufptr, '\n');
- if (!s)
- s = bufend;
- d = s;
- while (s < bufend &&
- (*s != term || memNE(s,PL_tokenbuf,len)) ) {
- if (*s++ == '\n')
- CopLINE_inc(PL_curcop);
+ /* inside a string eval or quote-like operator */
+ if (!infile || PL_lex_inwhat) {
+ SV *linestr;
+ char *bufend;
+ char * const olds = s;
+ PERL_CONTEXT * const cx = &cxstack[cxstack_ix];
+ /* These two fields are not set until an inner lexing scope is
+ entered. But we need them set here. */
+ shared->ls_bufptr = s;
+ shared->ls_linestr = PL_linestr;
+ if (PL_lex_inwhat)
+ /* Look for a newline. If the current buffer does not have one,
+ peek into the line buffer of the parent lexing scope, going
+ up as many levels as necessary to find one with a newline
+ after bufptr.
+ */
+ while (!(s = (char *)memchr(
+ (void *)shared->ls_bufptr, '\n',
+ SvEND(shared->ls_linestr)-shared->ls_bufptr
+ ))) {
+ shared = shared->ls_prev;
+ /* shared is only null if we have gone beyond the outermost
+ lexing scope. In a file, we will have broken out of the
+ loop in the previous iteration. In an eval, the string buf-
+ fer ends with "\n;", so the while condition below will have
+ evaluated to false. So shared can never be null. */
+ assert(shared);
+ /* A LEXSHARED struct with a null ls_prev pointer is the outer-
+ most lexing scope. In a file, shared->ls_linestr at that
+ level is just one line, so there is no body to steal. */
+ if (infile && !shared->ls_prev) {
+ s = olds;
+ goto streaming;
+ }
+ }
+ else { /* eval */
+ s = (char*)memchr((void*)s, '\n', PL_bufend - s);
+ assert(s);
}
- if (s >= bufend) {
- CopLINE_set(PL_curcop, (line_t)PL_multi_start);
- missingterm(PL_tokenbuf);
- }
- sv_setpvn(herewas,bufptr,d-bufptr+1);
- sv_setpvn(tmpstr,d+1,s-d);
- s += len - 1;
- sv_catpvn(herewas,s,bufend-s);
- Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
-
- s = olds;
- goto retval;
- }
- else if (!outer) {
+ linestr = shared->ls_linestr;
+ bufend = SvEND(linestr);
d = s;
- while (s < PL_bufend &&
- (*s != term || memNE(s,PL_tokenbuf,len)) ) {
+ while (s < bufend - len + 1 &&
+ memNE(s,PL_tokenbuf,len) ) {
if (*s++ == '\n')
- CopLINE_inc(PL_curcop);
+ ++shared->herelines;
}
- if (s >= PL_bufend) {
- CopLINE_set(PL_curcop, (line_t)PL_multi_start);
- missingterm(PL_tokenbuf);
+ if (s >= bufend - len + 1) {
+ goto interminable;
}
sv_setpvn(tmpstr,d+1,s-d);
#ifdef PERL_MAD
@@ -9391,17 +10013,54 @@
}
#endif
s += len - 1;
- CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
+ /* the preceding stmt passes a newline */
+ shared->herelines++;
- sv_catpvn(herewas,s,PL_bufend-s);
- sv_setsv(PL_linestr,herewas);
- PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
- PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
- PL_last_lop = PL_last_uni = NULL;
+ /* s now points to the newline after the heredoc terminator.
+ d points to the newline before the body of the heredoc.
+ */
+
+ /* We are going to modify linestr in place here, so set
+ aside copies of the string if necessary for re-evals or
+ (caller $n)[6]. */
+ /* See the Paranoia note in case LEX_INTERPEND in yylex, for why we
+ check shared->re_eval_str. */
+ if (shared->re_eval_start || shared->re_eval_str) {
+ /* Set aside the rest of the regexp */
+ if (!shared->re_eval_str)
+ shared->re_eval_str =
+ newSVpvn(shared->re_eval_start,
+ bufend - shared->re_eval_start);
+ shared->re_eval_start -= s-d;
+ }
+ if (cxstack_ix >= 0 && CxTYPE(cx) == CXt_EVAL &&
+ CxOLD_OP_TYPE(cx) == OP_ENTEREVAL &&
+ cx->blk_eval.cur_text == linestr)
+ {
+ cx->blk_eval.cur_text = newSVsv(linestr);
+ SvSCREAM_on(cx->blk_eval.cur_text);
+ }
+ /* Copy everything from s onwards back to d. */
+ Move(s,d,bufend-s + 1,char);
+ SvCUR_set(linestr, SvCUR(linestr) - (s-d));
+ /* Setting PL_bufend only applies when we have not dug deeper
+ into other scopes, because sublex_done sets PL_bufend to
+ SvEND(PL_linestr). */
+ if (shared == PL_parser->lex_shared) PL_bufend = SvEND(linestr);
+ s = olds;
}
else
- sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
- while (s >= PL_bufend) { /* multiple line string? */
+ {
+ SV *linestr_save;
+ streaming:
+ sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
+ term = PL_tokenbuf[1];
+ len--;
+ linestr_save = PL_linestr; /* must restore this afterwards */
+ d = s; /* and this */
+ PL_linestr = newSVpvs("");
+ PL_bufend = SvPVX(PL_linestr);
+ while (1) {
#ifdef PERL_MAD
if (PL_madskills) {
tstart = SvPVX(PL_linestr) + stuffstart;
@@ -9411,19 +10070,24 @@
PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
}
#endif
- PL_bufptr = s;
- CopLINE_inc(PL_curcop);
- if (!outer || !lex_next_chunk(0)) {
- CopLINE_set(PL_curcop, (line_t)PL_multi_start);
- missingterm(PL_tokenbuf);
+ PL_bufptr = PL_bufend;
+ CopLINE_set(PL_curcop,
+ PL_multi_start + shared->herelines);
+ if (!lex_next_chunk(LEX_NO_TERM)
+ && (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n')) {
+ SvREFCNT_dec(linestr_save);
+ goto interminable;
}
- CopLINE_dec(PL_curcop);
+ CopLINE_set(PL_curcop, (line_t)PL_multi_start - 1);
+ if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
+ lex_grow_linestr(SvCUR(PL_linestr) + 2);
+ sv_catpvs(PL_linestr, "\n\0");
+ }
s = PL_bufptr;
#ifdef PERL_MAD
stuffstart = s - SvPVX(PL_linestr);
#endif
- CopLINE_inc(PL_curcop);
- PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ shared->herelines++;
PL_last_lop = PL_last_uni = NULL;
#ifndef PERL_STRICT_CR
if (PL_bufend - PL_linestart >= 2) {
@@ -9440,26 +10104,23 @@
else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
PL_bufend[-1] = '\n';
#endif
- if (*s == term && memEQ(s,PL_tokenbuf,len)) {
- STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
- *(SvPVX(PL_linestr) + off ) = ' ';
- lex_grow_linestr(SvCUR(PL_linestr) + SvCUR(herewas) + 1);
- sv_catsv(PL_linestr,herewas);
+ if (*s == term && memEQ(s,PL_tokenbuf + 1,len)) {
+ SvREFCNT_dec(PL_linestr);
+ PL_linestr = linestr_save;
+ PL_linestart = SvPVX(linestr_save);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
- s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
+ s = d;
+ break;
}
else {
- s = PL_bufend;
sv_catsv(tmpstr,PL_linestr);
}
+ }
}
- s++;
-retval:
PL_multi_end = CopLINE(PL_curcop);
if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
SvPV_shrink_to_cur(tmpstr);
}
- SvREFCNT_dec(herewas);
if (!IN_BYTES) {
if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
SvUTF8_on(tmpstr);
@@ -9469,6 +10130,11 @@
PL_lex_stuff = tmpstr;
pl_yylval.ival = op_type;
return s;
+
+ interminable:
+ SvREFCNT_dec(tmpstr);
+ CopLINE_set(PL_curcop, (line_t)PL_multi_start - 1);
+ missingterm(PL_tokenbuf + 1);
}
/* scan_inputsymbol
@@ -9491,7 +10157,7 @@
S_scan_inputsymbol(pTHX_ char *start)
{
dVAR;
- register char *s = start; /* current position in buffer */
+ char *s = start; /* current position in buffer */
char *end;
I32 len;
char *d = PL_tokenbuf; /* start of temp holding space */
@@ -9525,8 +10191,8 @@
if (*d == '$' && d[1]) d++;
/* allow <Pkg'VALUE> or <Pkg::VALUE> */
- while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
- d++;
+ while (*d && (isWORDCHAR_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
+ d += UTF ? UTF8SKIP(d) : 1;
/* If we've tried to read what we allow filehandles to look like, and
there's still text left, then it must be a glob() and not a getline.
@@ -9536,7 +10202,7 @@
if (d - PL_tokenbuf != len) {
pl_yylval.ival = OP_GLOB;
- s = scan_str(start,!!PL_madskills,FALSE);
+ s = scan_str(start,!!PL_madskills,FALSE,FALSE, FALSE);
if (!s)
Perl_croak(aTHX_ "Glob not terminated");
return s;
@@ -9569,7 +10235,7 @@
/* try to find it in the pad for this block, otherwise find
add symbol table ops
*/
- const PADOFFSET tmp = pad_findmy(d, len, 0);
+ const PADOFFSET tmp = pad_findmy_pvn(d, len, UTF ? SVf_UTF8 : 0);
if (tmp != NOT_IN_PAD) {
if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
@@ -9597,7 +10263,7 @@
gv = gv_fetchpv(d,
(PL_in_eval
? (GV_ADDMULTI | GV_ADDINEVAL)
- : GV_ADDMULTI),
+ : GV_ADDMULTI) | ( UTF ? SVf_UTF8 : 0 ),
SVt_PV);
PL_lex_op = readline_overriden
? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
@@ -9617,7 +10283,7 @@
/* If it's none of the above, it must be a literal filehandle
(<Foo::BAR> or <FOO>) so build a simple readline OP */
else {
- GV * const gv = gv_fetchpv(d, GV_ADD, SVt_PVIO);
+ GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO);
PL_lex_op = readline_overriden
? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST,
@@ -9636,6 +10302,8 @@
takes: start position in buffer
keep_quoted preserve \ on the embedded delimiter(s)
keep_delims preserve the delimiters around the string
+ re_reparse compiling a run-time /(?{})/:
+ collapse // to /, and skip encoding src
returns: position to continue reading from buffer
side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
updates the read buffer.
@@ -9676,20 +10344,25 @@
*/
STATIC char *
-S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
+S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse,
+ bool deprecate_escaped_meta /* Should we issue a deprecation warning
+ for certain paired metacharacters that
+ appear escaped within it */
+ )
{
dVAR;
- SV *sv; /* scalar value: string */
- const char *tmps; /* temp string, used for delimiter matching */
- register char *s = start; /* current position in the buffer */
- register char term; /* terminating character */
- register char *to; /* current position in the sv's data */
- I32 brackets = 1; /* bracket nesting level */
- bool has_utf8 = FALSE; /* is there any utf8 content? */
- I32 termcode; /* terminating char. code */
- U8 termstr[UTF8_MAXBYTES]; /* terminating string */
- STRLEN termlen; /* length of terminating string */
- int last_off = 0; /* last position for nesting bracket */
+ SV *sv; /* scalar value: string */
+ const char *tmps; /* temp string, used for delimiter matching */
+ char *s = start; /* current position in the buffer */
+ char term; /* terminating character */
+ char *to; /* current position in the sv's data */
+ I32 brackets = 1; /* bracket nesting level */
+ bool has_utf8 = FALSE; /* is there any utf8 content? */
+ I32 termcode; /* terminating char. code */
+ U8 termstr[UTF8_MAXBYTES]; /* terminating string */
+ STRLEN termlen; /* length of terminating string */
+ int last_off = 0; /* last position for nesting bracket */
+ char *escaped_open = NULL;
#ifdef PERL_MAD
int stuffstart;
char *tstart;
@@ -9720,7 +10393,7 @@
termlen = 1;
}
else {
- termcode = utf8_to_uvchr((U8*)s, &termlen);
+ termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen);
Copy(s, termstr, termlen, U8);
if (!UTF8_IS_INVARIANT(term))
has_utf8 = TRUE;
@@ -9736,6 +10409,18 @@
PL_multi_close = term;
+ /* A warning is raised if the input parameter requires it for escaped (by a
+ * backslash) paired metacharacters {} [] and () when the delimiters are
+ * those same characters, and the backslash is ineffective. This doesn't
+ * happen for <>, as they aren't metas. */
+ if (deprecate_escaped_meta
+ && (PL_multi_open == PL_multi_close
+ || ! ckWARN_d(WARN_DEPRECATED)
+ || PL_multi_open == '<'))
+ {
+ deprecate_escaped_meta = FALSE;
+ }
+
/* create a new SV to hold the contents. 79 is the SV's initial length.
What a random number. */
sv = newSV_type(SVt_PVIV);
@@ -9749,13 +10434,13 @@
s += termlen;
#ifdef PERL_MAD
tstart = SvPVX(PL_linestr) + stuffstart;
- if (!PL_thisopen && !keep_delims) {
+ if (PL_madskills && !PL_thisopen && !keep_delims) {
PL_thisopen = newSVpvn(tstart, s - tstart);
stuffstart = s - SvPVX(PL_linestr);
}
#endif
for (;;) {
- if (PL_encoding && !UTF) {
+ if (PL_encoding && !UTF && !re_reparse) {
bool cont = TRUE;
while (cont) {
@@ -9766,8 +10451,8 @@
char * const svlast = SvEND(sv) - 1;
for (; s < ns; s++) {
- if (*s == '\n' && !PL_rsfp)
- CopLINE_inc(PL_curcop);
+ if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
+ COPLINE_INC_WITH_HERELINES;
}
if (!found)
goto read_more_line;
@@ -9833,13 +10518,16 @@
if (PL_multi_open == PL_multi_close) {
for (; s < PL_bufend; s++,to++) {
/* embedded newlines increment the current line number */
- if (*s == '\n' && !PL_rsfp)
- CopLINE_inc(PL_curcop);
+ if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
+ COPLINE_INC_WITH_HERELINES;
/* handle quoted delimiters */
if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
- if (!keep_quoted && s[1] == term)
+ if (!keep_quoted
+ && (s[1] == term
+ || (re_reparse && s[1] == '\\'))
+ )
s++;
- /* any other quotes are simply copied straight through */
+ /* any other quotes are simply copied straight through */
else
*to++ = *s++;
}
@@ -9865,13 +10553,50 @@
/* read until we run out of string, or we find the terminator */
for (; s < PL_bufend; s++,to++) {
/* embedded newlines increment the line count */
- if (*s == '\n' && !PL_rsfp)
- CopLINE_inc(PL_curcop);
+ if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
+ COPLINE_INC_WITH_HERELINES;
/* backslashes can escape the open or closing characters */
if (*s == '\\' && s+1 < PL_bufend) {
if (!keep_quoted &&
((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
+ {
s++;
+
+ /* Here, 'deprecate_escaped_meta' is true iff the
+ * delimiters are paired metacharacters, and 's' points
+ * to an occurrence of one of them within the string,
+ * which was preceded by a backslash. If this is a
+ * context where the delimiter is also a metacharacter,
+ * the backslash is useless, and deprecated. () and []
+ * are meta in any context. {} are meta only when
+ * appearing in a quantifier or in things like '\p{'.
+ * They also aren't meta unless there is a matching
+ * closed, escaped char later on within the string.
+ * If 's' points to an open, set a flag; if to a close,
+ * test that flag, and raise a warning if it was set */
+
+ if (deprecate_escaped_meta) {
+ if (*s == PL_multi_open) {
+ if (*s != '{') {
+ escaped_open = s;
+ }
+ else if (regcurly(s,
+ TRUE /* Look for a closing
+ '\}' */)
+ || (s - start > 2 /* Look for e.g.
+ '\x{' */
+ && _generic_isCC(*(s-2), _CC_BACKSLASH_FOO_LBRACE_IS_META)))
+ {
+ escaped_open = s;
+ }
+ }
+ else if (escaped_open) {
+ Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
+ "Useless use of '\\'; doesn't escape metacharacter '%c'", PL_multi_open);
+ escaped_open = NULL;
+ }
+ }
+ }
else
*to++ = *s++;
}
@@ -9925,7 +10650,7 @@
PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
}
#endif
- CopLINE_inc(PL_curcop);
+ COPLINE_INC_WITH_HERELINES;
PL_bufptr = PL_bufend;
if (!lex_next_chunk(0)) {
sv_free(sv);
@@ -9940,7 +10665,7 @@
/* at this point, we have successfully read the delimited string */
- if (!PL_encoding || UTF) {
+ if (!PL_encoding || UTF || re_reparse) {
#ifdef PERL_MAD
if (PL_madskills) {
char * const tstart = SvPVX(PL_linestr) + stuffstart;
@@ -9972,7 +10697,7 @@
}
}
#endif
- if (has_utf8 || PL_encoding)
+ if (has_utf8 || (PL_encoding && !re_reparse))
SvUTF8_on(sv);
PL_multi_end = CopLINE(PL_curcop);
@@ -9988,7 +10713,7 @@
*/
if (PL_lex_stuff)
- PL_lex_repl = sv;
+ PL_sublex_info.repl = sv;
else
PL_lex_stuff = sv;
return s;
@@ -10020,14 +10745,14 @@
Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
{
dVAR;
- register const char *s = start; /* current position in buffer */
- register char *d; /* destination in temp buffer */
- register char *e; /* end of temp buffer */
+ const char *s = start; /* current position in buffer */
+ char *d; /* destination in temp buffer */
+ char *e; /* end of temp buffer */
NV nv; /* number read, as a double */
SV *sv = NULL; /* place to put the converted number */
bool floatit; /* boolean: int or float? */
const char *lastub = NULL; /* position of last underbar */
- static char const number_too_long[] = "Number too long";
+ static const char* const number_too_long = "Number too long";
PERL_ARGS_ASSERT_SCAN_NUM;
@@ -10035,7 +10760,7 @@
switch (*s) {
default:
- Perl_croak(aTHX_ "panic: scan_num");
+ Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s);
/* if it starts with a 0, it could be an octal number, a decimal in
0.13 disguise, or a hexadecimal number, or a binary number. */
@@ -10237,7 +10962,7 @@
else {
/* check for end of fixed-length buffer */
if (d >= e)
- Perl_croak(aTHX_ number_too_long);
+ Perl_croak(aTHX_ "%s", number_too_long);
/* if we're ok, copy the character */
*d++ = *s++;
}
@@ -10267,7 +10992,7 @@
for (; isDIGIT(*s) || *s == '_'; s++) {
/* fixed length buffer check */
if (d >= e)
- Perl_croak(aTHX_ number_too_long);
+ Perl_croak(aTHX_ "%s", number_too_long);
if (*s == '_') {
if (lastub && s == lastub + 1)
Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
@@ -10319,7 +11044,7 @@
while (isDIGIT(*s) || *s == '_') {
if (isDIGIT(*s)) {
if (d >= e)
- Perl_croak(aTHX_ number_too_long);
+ Perl_croak(aTHX_ "%s", number_too_long);
*d++ = *s++;
}
else {
@@ -10375,7 +11100,11 @@
case 'v':
vstring:
sv = newSV(5); /* preallocate storage space */
+ ENTER_with_name("scan_vstring");
+ SAVEFREESV(sv);
s = scan_vstring(s, PL_bufend, sv);
+ SvREFCNT_inc_simple_void_NN(sv);
+ LEAVE_with_name("scan_vstring");
break;
}
@@ -10390,11 +11119,11 @@
}
STATIC char *
-S_scan_formline(pTHX_ register char *s)
+S_scan_formline(pTHX_ char *s)
{
dVAR;
- register char *eol;
- register char *t;
+ char *eol;
+ char *t;
SV * const stuff = newSVpvs("");
bool needargs = FALSE;
bool eofmt = FALSE;
@@ -10425,13 +11154,9 @@
break;
}
}
- if (PL_in_eval && !PL_rsfp) {
- eol = (char *) memchr(s,'\n',PL_bufend-s);
- if (!eol++)
+ eol = (char *) memchr(s,'\n',PL_bufend-s);
+ if (!eol++)
eol = PL_bufend;
- }
- else
- eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
if (*s != '#') {
for (t = s; t < eol; t++) {
if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
@@ -10456,7 +11181,8 @@
break;
}
s = (char*)eol;
- if (PL_rsfp) {
+ if ((PL_rsfp || PL_parser->filtered)
+ && PL_parser->form_lex_state == LEX_NORMAL) {
bool got_some;
#ifdef PERL_MAD
if (PL_madskills) {
@@ -10467,7 +11193,7 @@
}
#endif
PL_bufptr = PL_bufend;
- CopLINE_inc(PL_curcop);
+ COPLINE_INC_WITH_HERELINES;
got_some = lex_next_chunk(0);
CopLINE_dec(PL_curcop);
s = PL_bufptr;
@@ -10480,16 +11206,15 @@
incline(s);
}
enough:
+ if (!SvCUR(stuff) || needargs)
+ PL_lex_state = PL_parser->form_lex_state;
if (SvCUR(stuff)) {
- PL_expect = XTERM;
+ PL_expect = XSTATE;
if (needargs) {
- PL_lex_state = LEX_NORMAL;
start_force(PL_curforce);
NEXTVAL_NEXTTOKE.ival = 0;
- force_next(',');
+ force_next(FORMLBRACK);
}
- else
- PL_lex_state = LEX_FORMLINE;
if (!IN_BYTES) {
if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
SvUTF8_on(stuff);
@@ -10499,15 +11224,11 @@
start_force(PL_curforce);
NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
force_next(THING);
- start_force(PL_curforce);
- NEXTVAL_NEXTTOKE.ival = OP_FORMLINE;
- force_next(LSTOP);
}
else {
SvREFCNT_dec(stuff);
if (eofmt)
PL_lex_formbrack = 0;
- PL_bufptr = s;
}
#ifdef PERL_MAD
if (PL_madskills) {
@@ -10528,9 +11249,6 @@
const I32 oldsavestack_ix = PL_savestack_ix;
CV* const outsidecv = PL_compcv;
- if (PL_compcv) {
- assert(SvTYPE(PL_compcv) == SVt_PVCV);
- }
SAVEI32(PL_subline);
save_item(PL_subname);
SAVESPTR(PL_compcv);
@@ -10542,6 +11260,9 @@
CvPADLIST(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))
+ CvPADLIST(PL_compcv)->xpadl_outid =
+ PadlistNAMES(CvPADLIST(outsidecv));
return oldsavestack_ix;
}
@@ -10550,7 +11271,7 @@
#pragma segment Perl_yylex
#endif
static int
-S_yywarn(pTHX_ const char *const s)
+S_yywarn(pTHX_ const char *const s, U32 flags)
{
dVAR;
@@ -10557,7 +11278,7 @@
PERL_ARGS_ASSERT_YYWARN;
PL_in_eval |= EVAL_WARNONLY;
- yyerror(s);
+ yyerror_pv(s, flags);
PL_in_eval &= ~EVAL_WARNONLY;
return 0;
}
@@ -10565,17 +11286,31 @@
int
Perl_yyerror(pTHX_ const char *const s)
{
+ PERL_ARGS_ASSERT_YYERROR;
+ return yyerror_pvn(s, strlen(s), 0);
+}
+
+int
+Perl_yyerror_pv(pTHX_ const char *const s, U32 flags)
+{
+ PERL_ARGS_ASSERT_YYERROR_PV;
+ return yyerror_pvn(s, strlen(s), flags);
+}
+
+int
+Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
+{
dVAR;
- const char *where = NULL;
const char *context = NULL;
int contlen = -1;
SV *msg;
+ SV * const where_sv = newSVpvs_flags("", SVs_TEMP);
int yychar = PL_parser->yychar;
- PERL_ARGS_ASSERT_YYERROR;
+ PERL_ARGS_ASSERT_YYERROR_PVN;
if (!yychar || (yychar == ';' && !PL_rsfp))
- where = "at EOF";
+ sv_catpvs(where_sv, "at EOF");
else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
PL_oldbufptr != PL_bufptr) {
@@ -10610,18 +11345,18 @@
contlen = PL_bufptr - PL_oldbufptr;
}
else if (yychar > 255)
- where = "next token ???";
+ sv_catpvs(where_sv, "next token ???");
else if (yychar == -2) { /* YYEMPTY */
if (PL_lex_state == LEX_NORMAL ||
(PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
- where = "at end of line";
+ sv_catpvs(where_sv, "at end of line");
else if (PL_lex_inpat)
- where = "within pattern";
+ sv_catpvs(where_sv, "within pattern");
else
- where = "within string";
+ sv_catpvs(where_sv, "within string");
}
else {
- SV * const where_sv = newSVpvs_flags("next char ", SVs_TEMP);
+ sv_catpvs(where_sv, "next char ");
if (yychar < 32)
Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
else if (isPRINT_LC(yychar)) {
@@ -10630,15 +11365,16 @@
}
else
Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
- where = SvPVX_const(where_sv);
}
- msg = sv_2mortal(newSVpv(s, 0));
+ msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP);
Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
if (context)
- Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
+ Perl_sv_catpvf(aTHX_ msg, "near \"%"SVf"\"\n",
+ SVfARG(newSVpvn_flags(context, contlen,
+ SVs_TEMP | (UTF ? SVf_UTF8 : 0))));
else
- Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
+ Perl_sv_catpvf(aTHX_ msg, "%"SVf"\n", SVfARG(where_sv));
if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
Perl_sv_catpvf(aTHX_ msg,
" (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
@@ -10651,9 +11387,10 @@
else
qerror(msg);
if (PL_error_count >= 10) {
- if (PL_in_eval && SvCUR(ERRSV))
+ SV * errsv;
+ if (PL_in_eval && ((errsv = ERRSV), SvCUR(errsv)))
Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
- SVfARG(ERRSV), OutCopFILE(PL_curcop));
+ SVfARG(errsv), OutCopFILE(PL_curcop));
else
Perl_croak(aTHX_ "%s has too many errors.\n",
OutCopFILE(PL_curcop));
@@ -10679,6 +11416,7 @@
if (s[1] == 0xFE) {
/* UTF-16 little-endian? (or UTF-32LE?) */
if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
+ /* diag_listed_as: Unsupported script encoding %s */
Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
#ifndef PERL_NO_UTF16_FILTER
if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
@@ -10687,6 +11425,7 @@
s = add_utf16_textfilter(s, TRUE);
}
#else
+ /* diag_listed_as: Unsupported script encoding %s */
Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
#endif
}
@@ -10700,6 +11439,7 @@
s = add_utf16_textfilter(s, FALSE);
}
#else
+ /* diag_listed_as: Unsupported script encoding %s */
Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
#endif
}
@@ -10715,6 +11455,7 @@
if (s[1] == 0) {
if (s[2] == 0xFE && s[3] == 0xFF) {
/* UTF-32 big-endian */
+ /* diag_listed_as: Unsupported script encoding %s */
Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
}
}
@@ -10726,6 +11467,7 @@
if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
s = add_utf16_textfilter(s, FALSE);
#else
+ /* diag_listed_as: Unsupported script encoding %s */
Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
#endif
}
@@ -10748,6 +11490,7 @@
if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
s = add_utf16_textfilter(s, TRUE);
#else
+ /* diag_listed_as: Unsupported script encoding %s */
Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
#endif
}
@@ -10911,7 +11654,7 @@
Function must be called like
- sv = newSV(5);
+ sv = sv_2mortal(newSV(5));
s = scan_vstring(s,e,sv);
where s and e are the start and end of the string.
@@ -10918,6 +11661,11 @@
The sv should already be large enough to store the vstring
passed in, for performance reasons.
+This function may croak if fatal warnings are enabled in the
+calling scope, hence the sv_2mortal in the example (to prevent
+a leak). Make sure to do SvREFCNT_inc afterwards if you use
+sv_2mortal.
+
*/
char *
@@ -10964,6 +11712,7 @@
rev += (*end - '0') * mult;
mult *= 10;
if (orev > rev)
+ /* diag_listed_as: Integer overflow in %s number */
Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
"Integer overflow in decimal number");
}
@@ -11282,16 +12031,10 @@
if (PL_lex_state == LEX_KNOWNEXT) {
PL_parser->yychar = yylex();
if (PL_parser->yychar == LABEL) {
- char *lpv = pl_yylval.pval;
+ char * const lpv = pl_yylval.pval;
STRLEN llen = strlen(lpv);
- SV *lsv;
PL_parser->yychar = YYEMPTY;
- lsv = newSV_type(SVt_PV);
- SvPV_set(lsv, lpv);
- SvCUR_set(lsv, llen);
- SvLEN_set(lsv, llen+1);
- SvPOK_on(lsv);
- return lsv;
+ return newSVpvn_flags(lpv, llen, lpv[llen+1] ? SVf_UTF8 : 0);
} else {
yyunlex();
goto no_label;
@@ -11298,17 +12041,12 @@
}
} else {
char *s, *t;
- U8 c;
STRLEN wlen, bufptr_pos;
lex_read_space(0);
t = s = PL_bufptr;
- c = (U8)*s;
- if (!isIDFIRST_A(c))
+ if (!isIDFIRST_lazy_if(s, UTF))
goto no_label;
- do {
- c = (U8)*++t;
- } while(isWORDCHAR_A(c));
- wlen = t - s;
+ t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen);
if (word_takes_any_delimeter(s, wlen))
goto no_label;
bufptr_pos = s - SvPVX(PL_linestr);
@@ -11320,7 +12058,7 @@
PL_oldoldbufptr = PL_oldbufptr;
PL_oldbufptr = s;
PL_bufptr = t+1;
- return newSVpvn(s, wlen);
+ return newSVpvn_flags(s, wlen, UTF ? SVf_UTF8 : 0);
} else {
PL_bufptr = s;
no_label:
@@ -11413,29 +12151,12 @@
return stmtseqop;
}
-void
-Perl_munge_qwlist_to_paren_list(pTHX_ OP *qwlist)
-{
- PERL_ARGS_ASSERT_MUNGE_QWLIST_TO_PAREN_LIST;
- deprecate("qw(...) as parentheses");
- force_next((4<<24)|')');
- if (qwlist->op_type == OP_STUB) {
- op_free(qwlist);
- }
- else {
- start_force(PL_curforce);
- NEXTVAL_NEXTTOKE.opval = qwlist;
- force_next(THING);
- }
- force_next((2<<24)|'(');
-}
-
/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/toke.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.4
\ No newline at end of property
Modified: trunk/contrib/perl/uconfig.h
===================================================================
--- trunk/contrib/perl/uconfig.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/uconfig.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -88,7 +88,7 @@
* of significant digits in a double precision number. If this
* symbol is not defined, a guess of 15 is usually pretty good.
*/
-/*#define HAS_DBL_DIG / * */
+/*#define HAS_DBL_DIG / **/
/* HAS_DIFFTIME:
* This symbol, if defined, indicates that the difftime routine is
@@ -527,7 +527,7 @@
* This symbol, if defined, indicates that the strtol routine is available
* to provide better numeric string conversion than atoi() and friends.
*/
-/*#define HAS_STRTOL / **/
+#define HAS_STRTOL /**/
/* HAS_STRXFRM:
* This symbol, if defined, indicates that the strxfrm() routine is
@@ -879,47 +879,19 @@
#define _V(args) ()
#endif
-/* INTSIZE:
- * This symbol contains the value of sizeof(int) so that the C
- * preprocessor can make decisions based on it.
+/* OSNAME:
+ * This symbol contains the name of the operating system, as determined
+ * by Configure. You shouldn't rely on it too much; the specific
+ * feature tests from Configure are generally more reliable.
*/
-/* LONGSIZE:
- * This symbol contains the value of sizeof(long) so that the C
- * preprocessor can make decisions based on it.
+/* OSVERS:
+ * This symbol contains the version of the operating system, as determined
+ * by Configure. You shouldn't rely on it too much; the specific
+ * feature tests from Configure are generally more reliable.
*/
-/* SHORTSIZE:
- * This symbol contains the value of sizeof(short) so that the C
- * preprocessor can make decisions based on it.
- */
-#define INTSIZE 4 /**/
-#define LONGSIZE 4 /**/
-#define SHORTSIZE 2 /**/
+#define OSNAME "unknown" /**/
+#define OSVERS "unknown" /**/
-/* MULTIARCH:
- * This symbol, if defined, signifies that the build
- * process will produce some binary files that are going to be
- * used in a cross-platform environment. This is the case for
- * example with the NeXT "fat" binaries that contain executables
- * for several CPUs.
- */
-/*#define MULTIARCH / **/
-
-/* HAS_QUAD:
- * This symbol, if defined, tells that there's a 64-bit integer type,
- * Quad_t, and its unsigned counterpart, Uquad_t. QUADKIND will be one
- * of QUAD_IS_INT, QUAD_IS_LONG, QUAD_IS_LONG_LONG, or QUAD_IS_INT64_T.
- */
-/*#define HAS_QUAD / **/
-#ifdef HAS_QUAD
-# define Quad_t int64_t /**/
-# define Uquad_t uint64_t /**/
-# define QUADKIND 4 /**/
-# define QUAD_IS_INT 1
-# define QUAD_IS_LONG 2
-# define QUAD_IS_LONG_LONG 3
-# define QUAD_IS_INT64_T 4
-#endif
-
/* USE_CROSS_COMPILE:
* This symbol, if defined, indicates that Perl is being cross-compiled.
*/
@@ -932,16 +904,22 @@
#define PERL_TARGETARCH "" /**/
#endif
+/* MULTIARCH:
+ * This symbol, if defined, signifies that the build
+ * process will produce some binary files that are going to be
+ * used in a cross-platform environment. This is the case for
+ * example with the NeXT "fat" binaries that contain executables
+ * for several CPUs.
+ */
+/*#define MULTIARCH / **/
+
/* MEM_ALIGNBYTES:
* This symbol contains the number of bytes required to align a
* double, or a long double when applicable. Usual values are 2,
- * 4 and 8. The default is eight, for safety.
+ * 4 and 8. The default is eight, for safety. For cross-compiling
+ * or multiarch support, Configure will set a minimum of 8.
*/
-#if defined(USE_CROSS_COMPILE) || defined(MULTIARCH)
-# define MEM_ALIGNBYTES 8
-#else
#define MEM_ALIGNBYTES 4
-#endif
/* ARCHLIB:
* This variable, if defined, holds the name of the directory in
@@ -956,8 +934,8 @@
* This symbol contains the ~name expanded version of ARCHLIB, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
-/*#define ARCHLIB "/usr/local/lib/perl5/5.14/unknown" / **/
-/*#define ARCHLIB_EXP "/usr/local/lib/perl5/5.14/unknown" / **/
+/*#define ARCHLIB "/usr/local/lib/perl5/5.18/unknown" / **/
+/*#define ARCHLIB_EXP "/usr/local/lib/perl5/5.18/unknown" / **/
/* ARCHNAME:
* This symbol holds a string representing the architecture name.
@@ -983,11 +961,27 @@
#define BIN_EXP "/usr/local/bin" /**/
#define PERL_RELOCATABLE_INC "undef" /**/
+/* INTSIZE:
+ * This symbol contains the value of sizeof(int) so that the C
+ * preprocessor can make decisions based on it.
+ */
+/* LONGSIZE:
+ * This symbol contains the value of sizeof(long) so that the C
+ * preprocessor can make decisions based on it.
+ */
+/* SHORTSIZE:
+ * This symbol contains the value of sizeof(short) so that the C
+ * preprocessor can make decisions based on it.
+ */
+#define INTSIZE 4 /**/
+#define LONGSIZE 4 /**/
+#define SHORTSIZE 2 /**/
+
/* BYTEORDER:
* This symbol holds the hexadecimal constant defined in byteorder,
* in a UV, i.e. 0x1234 or 0x4321 or 0x12345678, etc...
* If the compiler supports cross-compiling or multiple-architecture
- * binaries (eg. on NeXT systems), use compiler-defined macros to
+ * binaries (e.g. on NeXT systems), use compiler-defined macros to
* determine the byte order.
* On NeXT 3.2 (and greater), you can build "Fat" Multiple Architecture
* Binaries (MAB) on either big endian or little endian machines.
@@ -1032,6 +1026,64 @@
*/
#define CHARBITS 8 /**/
+/* CAT2:
+ * This macro concatenates 2 tokens together.
+ */
+/* STRINGIFY:
+ * This macro surrounds its token with double quotes.
+ */
+#if 42 == 1
+#define CAT2(a,b) a/**/b
+#define STRINGIFY(a) "a"
+#endif
+#if 42 == 42
+#define PeRl_CaTiFy(a, b) a ## b
+#define PeRl_StGiFy(a) #a
+#define CAT2(a,b) PeRl_CaTiFy(a,b)
+#define StGiFy(a) PeRl_StGiFy(a)
+#define STRINGIFY(a) PeRl_StGiFy(a)
+#endif
+#if 42 != 1 && 42 != 42
+#include "Bletch: How does this C preprocessor concatenate tokens?"
+#endif
+
+/* CPPSTDIN:
+ * This symbol contains the first part of the string which will invoke
+ * the C preprocessor on the standard input and produce to standard
+ * output. Typical value of "cc -E" or "/lib/cpp", but it can also
+ * call a wrapper. See CPPRUN.
+ */
+/* CPPMINUS:
+ * This symbol contains the second part of the string which will invoke
+ * the C preprocessor on the standard input and produce to standard
+ * output. This symbol will have the value "-" if CPPSTDIN needs a minus
+ * to specify standard input, otherwise the value is "".
+ */
+/* CPPRUN:
+ * This symbol contains the string which will invoke a C preprocessor on
+ * the standard input and produce to standard output. It needs to end
+ * with CPPLAST, after all other preprocessor flags have been specified.
+ * The main difference with CPPSTDIN is that this program will never be a
+ * pointer to a shell wrapper, i.e. it will be empty if no preprocessor is
+ * available directly to the user. Note that it may well be different from
+ * the preprocessor used to compile the C program.
+ */
+/* CPPLAST:
+ * This symbol is intended to be used along with CPPRUN in the same manner
+ * symbol CPPMINUS is used with CPPSTDIN. It contains either "-" or "".
+ */
+#define CPPSTDIN "cc -E"
+#define CPPMINUS "-"
+#define CPPRUN "cc -E"
+#define CPPLAST "-"
+
+/* HAS_ACCESS:
+ * This manifest constant lets the C program know that the access()
+ * system call is available to check for accessibility using real UID/GID.
+ * (always present on UNIX.)
+ */
+/*#define HAS_ACCESS / **/
+
/* HAS_ACCESSX:
* This symbol, if defined, indicates that the accessx routine is
* available to do extended access checks.
@@ -1051,6 +1103,43 @@
/*#define HAS_ASCTIME_R / **/
#define ASCTIME_R_PROTO 0 /**/
+/* HASATTRIBUTE_FORMAT:
+ * Can we handle GCC attribute for checking printf-style formats
+ */
+/* PRINTF_FORMAT_NULL_OK:
+ * Allows __printf__ format to be null when checking printf-style
+ */
+/* HASATTRIBUTE_MALLOC:
+ * Can we handle GCC attribute for malloc-style functions.
+ */
+/* HASATTRIBUTE_NONNULL:
+ * Can we handle GCC attribute for nonnull function parms.
+ */
+/* HASATTRIBUTE_NORETURN:
+ * Can we handle GCC attribute for functions that do not return
+ */
+/* HASATTRIBUTE_PURE:
+ * Can we handle GCC attribute for pure functions
+ */
+/* HASATTRIBUTE_UNUSED:
+ * Can we handle GCC attribute for unused variables and arguments
+ */
+/* HASATTRIBUTE_DEPRECATED:
+ * Can we handle GCC attribute for marking deprecated APIs
+ */
+/* HASATTRIBUTE_WARN_UNUSED_RESULT:
+ * Can we handle GCC attribute for warning on unused results
+ */
+/*#define HASATTRIBUTE_DEPRECATED / **/
+/*#define HASATTRIBUTE_FORMAT / **/
+/*#define PRINTF_FORMAT_NULL_OK / **/
+/*#define HASATTRIBUTE_NORETURN / **/
+/*#define HASATTRIBUTE_MALLOC / **/
+/*#define HASATTRIBUTE_NONNULL / **/
+/*#define HASATTRIBUTE_PURE / **/
+/*#define HASATTRIBUTE_UNUSED / **/
+/*#define HASATTRIBUTE_WARN_UNUSED_RESULT / **/
+
/* CASTI32:
* This symbol is defined if the C compiler can cast negative
* or large floating point numbers to 32-bit ints.
@@ -1078,6 +1167,17 @@
*/
/*#define VOID_CLOSEDIR / **/
+/* HASCONST:
+ * This symbol, if defined, indicates that this C compiler knows about
+ * the const type. There is no need to actually test for that symbol
+ * within your programs. The mere use of the "const" keyword will
+ * trigger the necessary tests.
+ */
+/*#define HASCONST / **/
+#ifndef HASCONST
+#define const
+#endif
+
/* HAS_CRYPT_R:
* This symbol, if defined, indicates that the crypt_r routine
* is available to crypt re-entrantly.
@@ -1091,6 +1191,17 @@
/*#define HAS_CRYPT_R / **/
#define CRYPT_R_PROTO 0 /**/
+/* HAS_CSH:
+ * This symbol, if defined, indicates that the C-shell exists.
+ */
+/* CSH:
+ * This symbol, if defined, contains the full pathname of csh.
+ */
+/*#define HAS_CSH / **/
+#ifdef HAS_CSH
+#define CSH "" /**/
+#endif
+
/* HAS_CTERMID_R:
* This symbol, if defined, indicates that the ctermid_r routine
* is available to ctermid re-entrantly.
@@ -1117,6 +1228,26 @@
/*#define HAS_CTIME_R / **/
#define CTIME_R_PROTO 0 /**/
+/* SETUID_SCRIPTS_ARE_SECURE_NOW:
+ * This symbol, if defined, indicates that the bug that prevents
+ * setuid scripts from being secure is not present in this kernel.
+ */
+/* DOSUID:
+ * This symbol, if defined, indicates that the C program should
+ * check the script that it is executing for setuid/setgid bits, and
+ * attempt to emulate setuid/setgid on systems that have disabled
+ * setuid #! scripts because the kernel can't do it securely.
+ * It is up to the package designer to make sure that this emulation
+ * is done securely. Among other things, it should do an fstat on
+ * the script it just opened to make sure it really is a setuid/setgid
+ * script, it should make sure the arguments passed correspond exactly
+ * to the argument on the #! line, and it should not trust any
+ * subprocesses to which it must pass the filename rather than the
+ * file descriptor of the script to be executed.
+ */
+/*#define SETUID_SCRIPTS_ARE_SECURE_NOW / **/
+/*#define DOSUID / **/
+
/* HAS_DRAND48_R:
* This symbol, if defined, indicates that the drand48_r routine
* is available to drand48 re-entrantly.
@@ -1130,6 +1261,14 @@
/*#define HAS_DRAND48_R / **/
#define DRAND48_R_PROTO 0 /**/
+/* HAS_DRAND48_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the drand48() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern double drand48(void);
+ */
+/*#define HAS_DRAND48_PROTO / **/
+
/* HAS_EACCESS:
* This symbol, if defined, indicates that the eaccess routine is
* available to do extended access checks.
@@ -1136,6 +1275,12 @@
*/
/*#define HAS_EACCESS / **/
+/* HAS_ENDGRENT:
+ * This symbol, if defined, indicates that the getgrent routine is
+ * available for finalizing sequential access of the group database.
+ */
+/*#define HAS_ENDGRENT / **/
+
/* HAS_ENDGRENT_R:
* This symbol, if defined, indicates that the endgrent_r routine
* is available to endgrent re-entrantly.
@@ -1149,6 +1294,12 @@
/*#define HAS_ENDGRENT_R / **/
#define ENDGRENT_R_PROTO 0 /**/
+/* HAS_ENDHOSTENT:
+ * This symbol, if defined, indicates that the endhostent() routine is
+ * available to close whatever was being used for host queries.
+ */
+/*#define HAS_ENDHOSTENT / **/
+
/* HAS_ENDHOSTENT_R:
* This symbol, if defined, indicates that the endhostent_r routine
* is available to endhostent re-entrantly.
@@ -1162,6 +1313,12 @@
/*#define HAS_ENDHOSTENT_R / **/
#define ENDHOSTENT_R_PROTO 0 /**/
+/* HAS_ENDNETENT:
+ * This symbol, if defined, indicates that the endnetent() routine is
+ * available to close whatever was being used for network queries.
+ */
+/*#define HAS_ENDNETENT / **/
+
/* HAS_ENDNETENT_R:
* This symbol, if defined, indicates that the endnetent_r routine
* is available to endnetent re-entrantly.
@@ -1175,6 +1332,12 @@
/*#define HAS_ENDNETENT_R / **/
#define ENDNETENT_R_PROTO 0 /**/
+/* HAS_ENDPROTOENT:
+ * This symbol, if defined, indicates that the endprotoent() routine is
+ * available to close whatever was being used for protocol queries.
+ */
+/*#define HAS_ENDPROTOENT / **/
+
/* HAS_ENDPROTOENT_R:
* This symbol, if defined, indicates that the endprotoent_r routine
* is available to endprotoent re-entrantly.
@@ -1188,6 +1351,12 @@
/*#define HAS_ENDPROTOENT_R / **/
#define ENDPROTOENT_R_PROTO 0 /**/
+/* HAS_ENDPWENT:
+ * This symbol, if defined, indicates that the getgrent routine is
+ * available for finalizing sequential access of the passwd database.
+ */
+/*#define HAS_ENDPWENT / **/
+
/* HAS_ENDPWENT_R:
* This symbol, if defined, indicates that the endpwent_r routine
* is available to endpwent re-entrantly.
@@ -1201,6 +1370,12 @@
/*#define HAS_ENDPWENT_R / **/
#define ENDPWENT_R_PROTO 0 /**/
+/* HAS_ENDSERVENT:
+ * This symbol, if defined, indicates that the endservent() routine is
+ * available to close whatever was being used for service queries.
+ */
+/*#define HAS_ENDSERVENT / **/
+
/* HAS_ENDSERVENT_R:
* This symbol, if defined, indicates that the endservent_r routine
* is available to endservent re-entrantly.
@@ -1220,6 +1395,12 @@
*/
/*#define HAS_FD_SET / **/
+/* FLEXFILENAMES:
+ * This symbol, if defined, indicates that the system supports filenames
+ * longer than 14 characters.
+ */
+/*#define FLEXFILENAMES / **/
+
/* Gconvert:
* This preprocessor macro is defined to convert a floating point
* number to a string without a trailing decimal point. This
@@ -1237,6 +1418,12 @@
*/
#define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x))
+/* HAS_GETGRENT:
+ * This symbol, if defined, indicates that the getgrent routine is
+ * available for sequential access of the group database.
+ */
+/*#define HAS_GETGRENT / **/
+
/* HAS_GETGRENT_R:
* This symbol, if defined, indicates that the getgrent_r routine
* is available to getgrent re-entrantly.
@@ -1276,6 +1463,53 @@
/*#define HAS_GETGRNAM_R / **/
#define GETGRNAM_R_PROTO 0 /**/
+/* HAS_GETHOSTBYADDR:
+ * This symbol, if defined, indicates that the gethostbyaddr() routine is
+ * available to look up hosts by their IP addresses.
+ */
+/*#define HAS_GETHOSTBYADDR / **/
+
+/* HAS_GETHOSTBYNAME:
+ * This symbol, if defined, indicates that the gethostbyname() routine is
+ * available to look up host names in some data base or other.
+ */
+/*#define HAS_GETHOSTBYNAME / **/
+
+/* HAS_GETHOSTENT:
+ * This symbol, if defined, indicates that the gethostent() routine is
+ * available to look up host names in some data base or another.
+ */
+/*#define HAS_GETHOSTENT / **/
+
+/* HAS_GETHOSTNAME:
+ * This symbol, if defined, indicates that the C program may use the
+ * gethostname() routine to derive the host name. See also HAS_UNAME
+ * and PHOSTNAME.
+ */
+/* HAS_UNAME:
+ * This symbol, if defined, indicates that the C program may use the
+ * uname() routine to derive the host name. See also HAS_GETHOSTNAME
+ * and PHOSTNAME.
+ */
+/* PHOSTNAME:
+ * This symbol, if defined, indicates the command to feed to the
+ * popen() routine to derive the host name. See also HAS_GETHOSTNAME
+ * and HAS_UNAME. Note that the command uses a fully qualified path,
+ * so that it is safe even if used by a process with super-user
+ * privileges.
+ */
+/* HAS_PHOSTNAME:
+ * This symbol, if defined, indicates that the C program may use the
+ * contents of PHOSTNAME as a command to feed to the popen() routine
+ * to derive the host name.
+ */
+/*#define HAS_GETHOSTNAME / **/
+/*#define HAS_UNAME / **/
+/*#define HAS_PHOSTNAME / **/
+#ifdef HAS_PHOSTNAME
+#define PHOSTNAME "/bin/hostname" /* How to get the host name */
+#endif
+
/* HAS_GETHOSTBYADDR_R:
* This symbol, if defined, indicates that the gethostbyaddr_r routine
* is available to gethostbyaddr re-entrantly.
@@ -1315,6 +1549,14 @@
/*#define HAS_GETHOSTENT_R / **/
#define GETHOSTENT_R_PROTO 0 /**/
+/* HAS_GETHOST_PROTOS:
+ * This symbol, if defined, indicates that <netdb.h> includes
+ * prototypes for gethostent(), gethostbyname(), and
+ * gethostbyaddr(). Otherwise, it is up to the program to guess
+ * them. See netdbtype.U for probing for various Netdb_xxx_t types.
+ */
+/*#define HAS_GETHOST_PROTOS / **/
+
/* HAS_GETLOGIN_R:
* This symbol, if defined, indicates that the getlogin_r routine
* is available to getlogin re-entrantly.
@@ -1328,6 +1570,24 @@
/*#define HAS_GETLOGIN_R / **/
#define GETLOGIN_R_PROTO 0 /**/
+/* HAS_GETNETBYADDR:
+ * This symbol, if defined, indicates that the getnetbyaddr() routine is
+ * available to look up networks by their IP addresses.
+ */
+/*#define HAS_GETNETBYADDR / **/
+
+/* HAS_GETNETBYNAME:
+ * This symbol, if defined, indicates that the getnetbyname() routine is
+ * available to look up networks by their names.
+ */
+/*#define HAS_GETNETBYNAME / **/
+
+/* HAS_GETNETENT:
+ * This symbol, if defined, indicates that the getnetent() routine is
+ * available to look up network names in some data base or another.
+ */
+/*#define HAS_GETNETENT / **/
+
/* HAS_GETNETBYADDR_R:
* This symbol, if defined, indicates that the getnetbyaddr_r routine
* is available to getnetbyaddr re-entrantly.
@@ -1367,6 +1627,14 @@
/*#define HAS_GETNETENT_R / **/
#define GETNETENT_R_PROTO 0 /**/
+/* HAS_GETNET_PROTOS:
+ * This symbol, if defined, indicates that <netdb.h> includes
+ * prototypes for getnetent(), getnetbyname(), and
+ * getnetbyaddr(). Otherwise, it is up to the program to guess
+ * them. See netdbtype.U for probing for various Netdb_xxx_t types.
+ */
+/*#define HAS_GETNET_PROTOS / **/
+
/* HAS_GETPAGESIZE:
* This symbol, if defined, indicates that the getpagesize system call
* is available to get system page size, which is the granularity of
@@ -1374,6 +1642,34 @@
*/
/*#define HAS_GETPAGESIZE / **/
+/* HAS_GETPROTOENT:
+ * This symbol, if defined, indicates that the getprotoent() routine is
+ * available to look up protocols in some data base or another.
+ */
+/*#define HAS_GETPROTOENT / **/
+
+/* HAS_GETPGRP:
+ * This symbol, if defined, indicates that the getpgrp routine is
+ * available to get the current process group.
+ */
+/* USE_BSD_GETPGRP:
+ * This symbol, if defined, indicates that getpgrp needs one
+ * arguments whereas USG one needs none.
+ */
+/*#define HAS_GETPGRP / **/
+/*#define USE_BSD_GETPGRP / **/
+
+/* HAS_GETPROTOBYNAME:
+ * This symbol, if defined, indicates that the getprotobyname()
+ * routine is available to look up protocols by their name.
+ */
+/* HAS_GETPROTOBYNUMBER:
+ * This symbol, if defined, indicates that the getprotobynumber()
+ * routine is available to look up protocols by their number.
+ */
+/*#define HAS_GETPROTOBYNAME / **/
+/*#define HAS_GETPROTOBYNUMBER / **/
+
/* HAS_GETPROTOBYNAME_R:
* This symbol, if defined, indicates that the getprotobyname_r routine
* is available to getprotobyname re-entrantly.
@@ -1413,6 +1709,21 @@
/*#define HAS_GETPROTOENT_R / **/
#define GETPROTOENT_R_PROTO 0 /**/
+/* HAS_GETPROTO_PROTOS:
+ * This symbol, if defined, indicates that <netdb.h> includes
+ * prototypes for getprotoent(), getprotobyname(), and
+ * getprotobyaddr(). Otherwise, it is up to the program to guess
+ * them. See netdbtype.U for probing for various Netdb_xxx_t types.
+ */
+/*#define HAS_GETPROTO_PROTOS / **/
+
+/* HAS_GETPWENT:
+ * This symbol, if defined, indicates that the getpwent routine is
+ * available for sequential access of the passwd database.
+ * If this is not available, the older getpw() function may be available.
+ */
+/*#define HAS_GETPWENT / **/
+
/* HAS_GETPWENT_R:
* This symbol, if defined, indicates that the getpwent_r routine
* is available to getpwent re-entrantly.
@@ -1452,6 +1763,12 @@
/*#define HAS_GETPWUID_R / **/
#define GETPWUID_R_PROTO 0 /**/
+/* HAS_GETSERVENT:
+ * This symbol, if defined, indicates that the getservent() routine is
+ * available to look up network services in some data base or another.
+ */
+/*#define HAS_GETSERVENT / **/
+
/* HAS_GETSERVBYNAME_R:
* This symbol, if defined, indicates that the getservbyname_r routine
* is available to getservbyname re-entrantly.
@@ -1491,6 +1808,14 @@
/*#define HAS_GETSERVENT_R / **/
#define GETSERVENT_R_PROTO 0 /**/
+/* HAS_GETSERV_PROTOS:
+ * This symbol, if defined, indicates that <netdb.h> includes
+ * prototypes for getservent(), getservbyname(), and
+ * getservbyaddr(). Otherwise, it is up to the program to guess
+ * them. See netdbtype.U for probing for various Netdb_xxx_t types.
+ */
+/*#define HAS_GETSERV_PROTOS / **/
+
/* HAS_GETSPNAM_R:
* This symbol, if defined, indicates that the getspnam_r routine
* is available to getspnam re-entrantly.
@@ -1504,6 +1829,17 @@
/*#define HAS_GETSPNAM_R / **/
#define GETSPNAM_R_PROTO 0 /**/
+/* HAS_GETSERVBYNAME:
+ * This symbol, if defined, indicates that the getservbyname()
+ * routine is available to look up services by their name.
+ */
+/* HAS_GETSERVBYPORT:
+ * This symbol, if defined, indicates that the getservbyport()
+ * routine is available to look up services by their port.
+ */
+/*#define HAS_GETSERVBYNAME / **/
+/*#define HAS_GETSERVBYPORT / **/
+
/* HAS_GMTIME_R:
* This symbol, if defined, indicates that the gmtime_r routine
* is available to gmtime re-entrantly.
@@ -1527,6 +1863,31 @@
# define _GNU_SOURCE
#endif
+/* HAS_HTONL:
+ * This symbol, if defined, indicates that the htonl() routine (and
+ * friends htons() ntohl() ntohs()) are available to do network
+ * order byte swapping.
+ */
+/* HAS_HTONS:
+ * This symbol, if defined, indicates that the htons() routine (and
+ * friends htonl() ntohl() ntohs()) are available to do network
+ * order byte swapping.
+ */
+/* HAS_NTOHL:
+ * This symbol, if defined, indicates that the ntohl() routine (and
+ * friends htonl() htons() ntohs()) are available to do network
+ * order byte swapping.
+ */
+/* HAS_NTOHS:
+ * This symbol, if defined, indicates that the ntohs() routine (and
+ * friends htonl() htons() ntohl()) are available to do network
+ * order byte swapping.
+ */
+/*#define HAS_HTONL / **/
+/*#define HAS_HTONS / **/
+/*#define HAS_NTOHL / **/
+/*#define HAS_NTOHS / **/
+
/* HAS_ISASCII:
* This manifest constant lets the C program know that isascii
* is available.
@@ -1566,6 +1927,72 @@
/*#define HAS_LOCALTIME_R / **/
#define LOCALTIME_R_PROTO 0 /**/
+/* HAS_LONG_DOUBLE:
+ * This symbol will be defined if the C compiler supports long
+ * doubles.
+ */
+/* LONG_DOUBLESIZE:
+ * This symbol contains the size of a long double, so that the
+ * C preprocessor can make decisions based on it. It is only
+ * defined if the system supports long doubles.
+ */
+/*#define HAS_LONG_DOUBLE / **/
+#ifdef HAS_LONG_DOUBLE
+#define LONG_DOUBLESIZE 8 /**/
+#endif
+
+/* HAS_LONG_LONG:
+ * This symbol will be defined if the C compiler supports long long.
+ */
+/* LONGLONGSIZE:
+ * This symbol contains the size of a long long, so that the
+ * C preprocessor can make decisions based on it. It is only
+ * defined if the system supports long long.
+ */
+/*#define HAS_LONG_LONG / **/
+#ifdef HAS_LONG_LONG
+#define LONGLONGSIZE 8 /**/
+#endif
+
+/* HAS_LSEEK_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the lseek() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern off_t lseek(int, off_t, int);
+ */
+/*#define HAS_LSEEK_PROTO / **/
+
+/* HAS_MEMCHR:
+ * This symbol, if defined, indicates that the memchr routine is available
+ * to locate characters within a C string.
+ */
+#define HAS_MEMCHR /**/
+
+/* HAS_MKSTEMP:
+ * This symbol, if defined, indicates that the mkstemp routine is
+ * available to exclusively create and open a uniquely named
+ * temporary file.
+ */
+/*#define HAS_MKSTEMP / **/
+
+/* HAS_MMAP:
+ * This symbol, if defined, indicates that the mmap system call is
+ * available to map a file into memory.
+ */
+/* Mmap_t:
+ * This symbol holds the return type of the mmap() system call
+ * (and simultaneously the type of the first argument).
+ * Usually set to 'void *' or 'caddr_t'.
+ */
+/*#define HAS_MMAP / **/
+#define Mmap_t void * /**/
+
+/* HAS_MSG:
+ * This symbol, if defined, indicates that the entire msg*(2) library is
+ * supported (IPC mechanism based on message queues).
+ */
+/*#define HAS_MSG / **/
+
/* HAS_OPEN3:
* This manifest constant lets the C program know that the three
* argument form of open(2) is available.
@@ -1669,6 +2096,18 @@
*/
/*#define HAS_SANE_MEMCMP / **/
+/* HAS_SEM:
+ * This symbol, if defined, indicates that the entire sem*(2) library is
+ * supported.
+ */
+/*#define HAS_SEM / **/
+
+/* HAS_SETGRENT:
+ * This symbol, if defined, indicates that the setgrent routine is
+ * available for initializing sequential access of the group database.
+ */
+/*#define HAS_SETGRENT / **/
+
/* HAS_SETGRENT_R:
* This symbol, if defined, indicates that the setgrent_r routine
* is available to setgrent re-entrantly.
@@ -1682,6 +2121,12 @@
/*#define HAS_SETGRENT_R / **/
#define SETGRENT_R_PROTO 0 /**/
+/* HAS_SETHOSTENT:
+ * This symbol, if defined, indicates that the sethostent() routine is
+ * available.
+ */
+/*#define HAS_SETHOSTENT / **/
+
/* HAS_SETHOSTENT_R:
* This symbol, if defined, indicates that the sethostent_r routine
* is available to sethostent re-entrantly.
@@ -1708,6 +2153,12 @@
/*#define HAS_SETLOCALE_R / **/
#define SETLOCALE_R_PROTO 0 /**/
+/* HAS_SETNETENT:
+ * This symbol, if defined, indicates that the setnetent() routine is
+ * available.
+ */
+/*#define HAS_SETNETENT / **/
+
/* HAS_SETNETENT_R:
* This symbol, if defined, indicates that the setnetent_r routine
* is available to setnetent re-entrantly.
@@ -1721,6 +2172,24 @@
/*#define HAS_SETNETENT_R / **/
#define SETNETENT_R_PROTO 0 /**/
+/* HAS_SETPROTOENT:
+ * This symbol, if defined, indicates that the setprotoent() routine is
+ * available.
+ */
+/*#define HAS_SETPROTOENT / **/
+
+/* HAS_SETPGRP:
+ * This symbol, if defined, indicates that the setpgrp routine is
+ * available to set the current process group.
+ */
+/* USE_BSD_SETPGRP:
+ * This symbol, if defined, indicates that setpgrp needs two
+ * arguments whereas USG one needs none. See also HAS_SETPGID
+ * for a POSIX interface.
+ */
+/*#define HAS_SETPGRP / **/
+/*#define USE_BSD_SETPGRP / **/
+
/* HAS_SETPROTOENT_R:
* This symbol, if defined, indicates that the setprotoent_r routine
* is available to setprotoent re-entrantly.
@@ -1734,6 +2203,12 @@
/*#define HAS_SETPROTOENT_R / **/
#define SETPROTOENT_R_PROTO 0 /**/
+/* HAS_SETPWENT:
+ * This symbol, if defined, indicates that the setpwent routine is
+ * available for initializing sequential access of the passwd database.
+ */
+/*#define HAS_SETPWENT / **/
+
/* HAS_SETPWENT_R:
* This symbol, if defined, indicates that the setpwent_r routine
* is available to setpwent re-entrantly.
@@ -1747,6 +2222,12 @@
/*#define HAS_SETPWENT_R / **/
#define SETPWENT_R_PROTO 0 /**/
+/* HAS_SETSERVENT:
+ * This symbol, if defined, indicates that the setservent() routine is
+ * available.
+ */
+/*#define HAS_SETSERVENT / **/
+
/* HAS_SETSERVENT_R:
* This symbol, if defined, indicates that the setservent_r routine
* is available to setservent re-entrantly.
@@ -1760,6 +2241,33 @@
/*#define HAS_SETSERVENT_R / **/
#define SETSERVENT_R_PROTO 0 /**/
+/* HAS_SETVBUF:
+ * This symbol, if defined, indicates that the setvbuf routine is
+ * available to change buffering on an open stdio stream.
+ * to a line-buffered mode.
+ */
+/*#define HAS_SETVBUF / **/
+
+/* HAS_SHM:
+ * This symbol, if defined, indicates that the entire shm*(2) library is
+ * supported.
+ */
+/*#define HAS_SHM / **/
+
+/* Shmat_t:
+ * This symbol holds the return type of the shmat() system call.
+ * Usually set to 'void *' or 'char *'.
+ */
+/* HAS_SHMAT_PROTOTYPE:
+ * This symbol, if defined, indicates that the sys/shm.h includes
+ * a prototype for shmat(). Otherwise, it is up to the program to
+ * guess one. Shmat_t shmat(int, Shmat_t, int) is a good guess,
+ * but not always right so it should be emitted by the program only
+ * when HAS_SHMAT_PROTOTYPE is not defined to avoid conflicting defs.
+ */
+#define Shmat_t void * /**/
+/*#define HAS_SHMAT_PROTOTYPE / **/
+
/* HAS_SIGACTION:
* This symbol, if defined, indicates that Vr4's sigaction() routine
* is available.
@@ -1797,6 +2305,89 @@
#define Siglongjmp(buf,retval) longjmp((buf),(retval))
#endif
+/* HAS_SOCKET:
+ * This symbol, if defined, indicates that the BSD socket interface is
+ * supported.
+ */
+/* HAS_SOCKETPAIR:
+ * This symbol, if defined, indicates that the BSD socketpair() call is
+ * supported.
+ */
+/* HAS_MSG_CTRUNC:
+ * This symbol, if defined, indicates that the MSG_CTRUNC is supported.
+ * Checking just with #ifdef might not be enough because this symbol
+ * has been known to be an enum.
+ */
+/* HAS_MSG_DONTROUTE:
+ * This symbol, if defined, indicates that the MSG_DONTROUTE is supported.
+ * Checking just with #ifdef might not be enough because this symbol
+ * has been known to be an enum.
+ */
+/* HAS_MSG_OOB:
+ * This symbol, if defined, indicates that the MSG_OOB is supported.
+ * Checking just with #ifdef might not be enough because this symbol
+ * has been known to be an enum.
+ */
+/* HAS_MSG_PEEK:
+ * This symbol, if defined, indicates that the MSG_PEEK is supported.
+ * Checking just with #ifdef might not be enough because this symbol
+ * has been known to be an enum.
+ */
+/* HAS_MSG_PROXY:
+ * This symbol, if defined, indicates that the MSG_PROXY is supported.
+ * Checking just with #ifdef might not be enough because this symbol
+ * has been known to be an enum.
+ */
+/* HAS_SCM_RIGHTS:
+ * This symbol, if defined, indicates that the SCM_RIGHTS is supported.
+ * Checking just with #ifdef might not be enough because this symbol
+ * has been known to be an enum.
+ */
+/* HAS_SOCKADDR_SA_LEN:
+ * This symbol, if defined, indicates that the struct sockaddr
+ * structure has a member called sa_len, indicating the length of
+ * the structure.
+ */
+/* HAS_SOCKADDR_IN6:
+ * This symbol, if defined, indicates the availability of
+ * struct sockaddr_in6;
+ */
+/* HAS_SIN6_SCOPE_ID:
+ * This symbol, if defined, indicates that the struct sockaddr_in6
+ * structure has a member called sin6_scope_id.
+ */
+/* HAS_IP_MREQ:
+ * This symbol, if defined, indicates the availability of
+ * struct ip_mreq;
+ */
+/* HAS_IP_MREQ_SOURCE:
+ * This symbol, if defined, indicates the availability of
+ * struct ip_mreq_source;
+ */
+/* HAS_IPV6_MREQ:
+ * This symbol, if defined, indicates the availability of
+ * struct ipv6_mreq;
+ */
+/* HAS_IPV6_MREQ_SOURCE:
+ * This symbol, if defined, indicates the availability of
+ * struct ipv6_mreq_source;
+ */
+/*#define HAS_SOCKET / **/
+/*#define HAS_SOCKETPAIR / **/
+/*#define HAS_SOCKADDR_SA_LEN / **/
+/*#define HAS_MSG_CTRUNC / **/
+/*#define HAS_MSG_DONTROUTE / **/
+/*#define HAS_MSG_OOB / **/
+/*#define HAS_MSG_PEEK / **/
+/*#define HAS_MSG_PROXY / **/
+/*#define HAS_SCM_RIGHTS / **/
+/*#define HAS_SOCKADDR_IN6 / **/
+/*#define HAS_SIN6_SCOPE_ID / **/
+/*#define HAS_IP_MREQ / **/
+/*#define HAS_IP_MREQ_SOURCE / **/
+/*#define HAS_IPV6_MREQ / **/
+/*#define HAS_IPV6_MREQ_SOURCE / **/
+
/* HAS_SRAND48_R:
* This symbol, if defined, indicates that the srand48_r routine
* is available to srand48 re-entrantly.
@@ -1823,6 +2414,35 @@
/*#define HAS_SRANDOM_R / **/
#define SRANDOM_R_PROTO 0 /**/
+/* USE_STAT_BLOCKS:
+ * This symbol is defined if this system has a stat structure declaring
+ * st_blksize and st_blocks.
+ */
+#ifndef USE_STAT_BLOCKS
+/*#define USE_STAT_BLOCKS / **/
+#endif
+
+/* HAS_STATIC_INLINE:
+ * This symbol, if defined, indicates that the C compiler supports
+ * C99-style static inline. That is, the function can't be called
+ * from another translation unit.
+ */
+/* PERL_STATIC_INLINE:
+ * This symbol gives the best-guess incantation to use for static
+ * inline functions. If HAS_STATIC_INLINE is defined, this will
+ * give C99-style inline. If HAS_STATIC_INLINE is not defined,
+ * this will give a plain 'static'. It will always be defined
+ * to something that gives static linkage.
+ * Possibilities include
+ * static inline (c99)
+ * static __inline__ (gcc -ansi)
+ * static __inline (MSVC)
+ * static _inline (older MSVC)
+ * static (c89 compilers)
+ */
+/*#define HAS_STATIC_INLINE / **/
+#define PERL_STATIC_INLINE static /**/
+
/* USE_STDIO_PTR:
* This symbol is defined if the _ptr and _cnt fields (or similar)
* of the stdio FILE structure can be used to access the stdio buffer
@@ -1893,6 +2513,32 @@
#define FILE_bufsiz(fp) ((fp)->_IO_read_end - (fp)->_IO_read_base)
#endif
+/* USE_STRUCT_COPY:
+ * This symbol, if defined, indicates that this C compiler knows how
+ * to copy structures. If undefined, you'll need to use a block copy
+ * routine of some sort instead.
+ */
+/*#define USE_STRUCT_COPY / **/
+
+/* HAS_STRERROR:
+ * This symbol, if defined, indicates that the strerror routine is
+ * available to translate error numbers to strings. See the writeup
+ * of Strerror() in this file before you try to define your own.
+ */
+/* HAS_SYS_ERRLIST:
+ * This symbol, if defined, indicates that the sys_errlist array is
+ * available to translate error numbers to strings. The extern int
+ * sys_nerr gives the size of that table.
+ */
+/* Strerror:
+ * This preprocessor symbol is defined as a macro if strerror() is
+ * not available to translate error numbers to strings but sys_errlist[]
+ * array is there.
+ */
+/*#define HAS_STRERROR / **/
+/*#define HAS_SYS_ERRLIST / **/
+#define Strerror(e) strerror(e)
+
/* HAS_STRERROR_R:
* This symbol, if defined, indicates that the strerror_r routine
* is available to strerror re-entrantly.
@@ -1906,6 +2552,30 @@
/*#define HAS_STRERROR_R / **/
#define STRERROR_R_PROTO 0 /**/
+/* HAS_STRTOUL:
+ * This symbol, if defined, indicates that the strtoul routine is
+ * available to provide conversion of strings to unsigned long.
+ */
+#define HAS_STRTOUL /**/
+
+/* HAS_TIME:
+ * This symbol, if defined, indicates that the time() routine exists.
+ */
+/* Time_t:
+ * This symbol holds the type returned by time(). It can be long,
+ * or time_t on BSD sites (in which case <sys/types.h> should be
+ * included).
+ */
+#define HAS_TIME /**/
+#define Time_t time_t /* Time type */
+
+/* HAS_TIMES:
+ * This symbol, if defined, indicates that the times() routine exists.
+ * Note that this became obsolete on some systems (SUNOS), which now
+ * use getrusage(). It may be necessary to include <sys/times.h>.
+ */
+/*#define HAS_TIMES / **/
+
/* HAS_TMPNAM_R:
* This symbol, if defined, indicates that the tmpnam_r routine
* is available to tmpnam re-entrantly.
@@ -1932,886 +2602,6 @@
/*#define HAS_TTYNAME_R / **/
#define TTYNAME_R_PROTO 0 /**/
-/* HAS_VPRINTF:
- * This symbol, if defined, indicates that the vprintf routine is available
- * to printf with a pointer to an argument list. If unavailable, you
- * may need to write your own, probably in terms of _doprnt().
- */
-/* USE_CHAR_VSPRINTF:
- * This symbol is defined if this system has vsprintf() returning type
- * (char*). The trend seems to be to declare it as "int vsprintf()". It
- * is up to the package author to declare vsprintf correctly based on the
- * symbol.
- */
-#define HAS_VPRINTF /**/
-/*#define USE_CHAR_VSPRINTF / **/
-
-/* DOUBLESIZE:
- * This symbol contains the size of a double, so that the C preprocessor
- * can make decisions based on it.
- */
-#define DOUBLESIZE 8 /**/
-
-/* I_MACH_CTHREADS:
- * This symbol, if defined, indicates to the C program that it should
- * include <mach/cthreads.h>.
- */
-/*#define I_MACH_CTHREADS / **/
-
-/* I_PTHREAD:
- * This symbol, if defined, indicates to the C program that it should
- * include <pthread.h>.
- */
-/*#define I_PTHREAD / **/
-
-/* I_SYS_ACCESS:
- * This symbol, if defined, indicates to the C program that it should
- * include <sys/access.h>.
- */
-/*#define I_SYS_ACCESS / **/
-
-/* I_SYS_SECURITY:
- * This symbol, if defined, indicates to the C program that it should
- * include <sys/security.h>.
- */
-/*#define I_SYS_SECURITY / **/
-
-/* I_TIME:
- * This symbol, if defined, indicates to the C program that it should
- * include <time.h>.
- */
-/* I_SYS_TIME:
- * This symbol, if defined, indicates to the C program that it should
- * include <sys/time.h>.
- */
-/* I_SYS_TIME_KERNEL:
- * This symbol, if defined, indicates to the C program that it should
- * include <sys/time.h> with KERNEL defined.
- */
-/* HAS_TM_TM_ZONE:
- * This symbol, if defined, indicates to the C program that
- * the struct tm has a tm_zone field.
- */
-/* HAS_TM_TM_GMTOFF:
- * This symbol, if defined, indicates to the C program that
- * the struct tm has a tm_gmtoff field.
- */
-#define I_TIME /**/
-/*#define I_SYS_TIME / **/
-/*#define I_SYS_TIME_KERNEL / **/
-/*#define HAS_TM_TM_ZONE / **/
-/*#define HAS_TM_TM_GMTOFF / **/
-
-/* PERL_INC_VERSION_LIST:
- * This variable specifies the list of subdirectories in over
- * which perl.c:incpush() and lib/lib.pm will automatically
- * search when adding directories to @INC, in a format suitable
- * for a C initialization string. See the inc_version_list entry
- * in Porting/Glossary for more details.
- */
-/*#define PERL_INC_VERSION_LIST NULL / **/
-
-/* INSTALL_USR_BIN_PERL:
- * This symbol, if defined, indicates that Perl is to be installed
- * also as /usr/bin/perl.
- */
-/*#define INSTALL_USR_BIN_PERL / **/
-
-/* VAL_O_NONBLOCK:
- * This symbol is to be used during open() or fcntl(F_SETFL) to turn on
- * non-blocking I/O for the file descriptor. Note that there is no way
- * back, i.e. you cannot turn it blocking again this way. If you wish to
- * alternatively switch between blocking and non-blocking, use the
- * ioctl(FIOSNBIO) call instead, but that is not supported by all devices.
- */
-/* VAL_EAGAIN:
- * This symbol holds the errno error code set by read() when no data was
- * present on the non-blocking file descriptor.
- */
-/* RD_NODATA:
- * This symbol holds the return code from read() when no data is present
- * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is
- * not defined, then you can't distinguish between no data and EOF by
- * issuing a read(). You'll have to find another way to tell for sure!
- */
-/* EOF_NONBLOCK:
- * This symbol, if defined, indicates to the C program that a read() on
- * a non-blocking file descriptor will return 0 on EOF, and not the value
- * held in RD_NODATA (-1 usually, in that case!).
- */
-#define VAL_O_NONBLOCK O_NONBLOCK
-#define VAL_EAGAIN EAGAIN
-#define RD_NODATA -1
-#undef EOF_NONBLOCK
-
-/* PERL_OTHERLIBDIRS:
- * This variable contains a colon-separated set of paths for the perl
- * binary to search for additional library files or modules.
- * These directories will be tacked to the end of @INC.
- * Perl will automatically search below each path for version-
- * and architecture-specific directories. See PERL_INC_VERSION_LIST
- * for more details.
- */
-/*#define PERL_OTHERLIBDIRS " " / **/
-
-/* PRIVLIB:
- * This symbol contains the name of the private library for this package.
- * The library is private in the sense that it needn't be in anyone's
- * execution path, but it should be accessible by the world. The program
- * should be prepared to do ~ expansion.
- */
-/* PRIVLIB_EXP:
- * 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 "/usr/local/lib/perl5/5.14" /**/
-#define PRIVLIB_EXP "/usr/local/lib/perl5/5.14" /**/
-
-/* PTRSIZE:
- * This symbol contains the size of a pointer, so that the C preprocessor
- * can make decisions based on it. It will be sizeof(void *) if
- * the compiler supports (void *); otherwise it will be
- * sizeof(char *).
- */
-#define PTRSIZE 4 /**/
-
-/* Drand01:
- * This macro is to be used to generate uniformly distributed
- * random numbers over the range [0., 1.[. You may have to supply
- * an 'extern double drand48();' in your program since SunOS 4.1.3
- * doesn't provide you with anything relevant in its headers.
- * See HAS_DRAND48_PROTO.
- */
-/* Rand_seed_t:
- * This symbol defines the type of the argument of the
- * random seed function.
- */
-/* seedDrand01:
- * This symbol defines the macro to be used in seeding the
- * random number generator (see Drand01).
- */
-/* RANDBITS:
- * This symbol indicates how many bits are produced by the
- * function used to generate normalized random numbers.
- * Values include 15, 16, 31, and 48.
- */
-#define Drand01() ((rand() & 0x7FFF) / (double) ((unsigned long)1 << 15)) /**/
-#define Rand_seed_t int /**/
-#define seedDrand01(x) srand((Rand_seed_t)x) /**/
-#define RANDBITS 48 /**/
-
-/* SITEARCH:
- * This symbol contains the name of the private library for this package.
- * The library is private in the sense that it needn't be in anyone's
- * execution path, but it should be accessible by the world. The program
- * should be prepared to do ~ expansion.
- * The standard distribution will put nothing in this directory.
- * After perl has been installed, users may install their own local
- * architecture-dependent modules in this directory with
- * MakeMaker Makefile.PL
- * or equivalent. See INSTALL for details.
- */
-/* SITEARCH_EXP:
- * 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 "/usr/local/lib/perl5/5.14/unknown" / **/
-/*#define SITEARCH_EXP "/usr/local/lib/perl5/5.14/unknown" / **/
-
-/* SITELIB:
- * This symbol contains the name of the private library for this package.
- * The library is private in the sense that it needn't be in anyone's
- * execution path, but it should be accessible by the world. The program
- * should be prepared to do ~ expansion.
- * The standard distribution will put nothing in this directory.
- * After perl has been installed, users may install their own local
- * architecture-independent modules in this directory with
- * MakeMaker Makefile.PL
- * or equivalent. See INSTALL for details.
- */
-/* SITELIB_EXP:
- * This symbol contains the ~name expanded version of SITELIB, to be used
- * in programs that are not prepared to deal with ~ expansion at run-time.
- */
-/* SITELIB_STEM:
- * This define is SITELIB_EXP with any trailing version-specific component
- * 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 "/usr/local/lib/perl5/5.14" /**/
-#define SITELIB_EXP "/usr/local/lib/perl5/5.14" /**/
-#define SITELIB_STEM "/usr/local/lib/perl5" /**/
-
-/* SSize_t:
- * This symbol holds the type used by functions that return
- * a count of bytes or an error condition. It must be a signed type.
- * It is usually ssize_t, but may be long or int, etc.
- * It may be necessary to include <sys/types.h> or <unistd.h>
- * to get any typedef'ed information.
- * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t).
- */
-#define SSize_t int /* signed count of bytes */
-
-/* USE_ITHREADS:
- * This symbol, if defined, indicates that Perl should be built to
- * use the interpreter-based threading implementation.
- */
-/* USE_5005THREADS:
- * This symbol, if defined, indicates that Perl should be built to
- * use the 5.005-based threading implementation.
- * Only valid up to 5.8.x.
- */
-/* OLD_PTHREADS_API:
- * This symbol, if defined, indicates that Perl should
- * be built to use the old draft POSIX threads API.
- */
-/* USE_REENTRANT_API:
- * This symbol, if defined, indicates that Perl should
- * try to use the various _r versions of library functions.
- * This is extremely experimental.
- */
-/*#define USE_5005THREADS / **/
-/*#define USE_ITHREADS / **/
-#if defined(USE_5005THREADS) && !defined(USE_ITHREADS)
-#define USE_THREADS /* until src is revised*/
-#endif
-/*#define OLD_PTHREADS_API / **/
-/*#define USE_REENTRANT_API / **/
-
-/* PERL_VENDORARCH:
- * If defined, this symbol contains the name of a private library.
- * The library is private in the sense that it needn't be in anyone's
- * execution path, but it should be accessible by the world.
- * It may have a ~ on the front.
- * The standard distribution will put nothing in this directory.
- * Vendors who distribute perl may wish to place their own
- * architecture-dependent modules and extensions in this directory with
- * MakeMaker Makefile.PL INSTALLDIRS=vendor
- * or equivalent. See INSTALL for details.
- */
-/* PERL_VENDORARCH_EXP:
- * This symbol contains the ~name expanded version of PERL_VENDORARCH, to be used
- * in programs that are not prepared to deal with ~ expansion at run-time.
- */
-/*#define PERL_VENDORARCH "" / **/
-/*#define PERL_VENDORARCH_EXP "" / **/
-
-/* PERL_VENDORLIB_EXP:
- * This symbol contains the ~name expanded version of VENDORLIB, to be used
- * in programs that are not prepared to deal with ~ expansion at run-time.
- */
-/* PERL_VENDORLIB_STEM:
- * This define is PERL_VENDORLIB_EXP with any trailing version-specific component
- * 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 PERL_VENDORLIB_EXP "" / **/
-/*#define PERL_VENDORLIB_STEM "" / **/
-
-/* HAS_STATIC_INLINE:
- * This symbol, if defined, indicates that the C compiler supports
- * C99-style static inline. That is, the function can't be called
- * from another translation unit.
- */
-/* PERL_STATIC_INLINE:
- * This symbol gives the best-guess incantation to use for static
- * inline functions. If HAS_STATIC_INLINE is defined, this will
- * give C99-style inline. If HAS_STATIC_INLINE is not defined,
- * this will give a plain 'static'. It will always be defined
- * to something that gives static linkage.
- * Possibilities include
- * static inline (c99)
- * static __inline__ (gcc -ansi)
- * static __inline (MSVC)
- * static _inline (older MSVC)
- * static (c89 compilers)
- */
-/*#define HAS_STATIC_INLINE / **/
-#define PERL_STATIC_INLINE static /**/
-
-/* EBCDIC:
- * This symbol, if defined, indicates that this system uses
- * EBCDIC encoding.
- */
-/*#define EBCDIC / **/
-
-/* OSNAME:
- * This symbol contains the name of the operating system, as determined
- * by Configure. You shouldn't rely on it too much; the specific
- * feature tests from Configure are generally more reliable.
- */
-/* OSVERS:
- * This symbol contains the version of the operating system, as determined
- * by Configure. You shouldn't rely on it too much; the specific
- * feature tests from Configure are generally more reliable.
- */
-#define OSNAME "unknown" /**/
-#define OSVERS "unknown" /**/
-
-/* CAT2:
- * This macro concatenates 2 tokens together.
- */
-/* STRINGIFY:
- * This macro surrounds its token with double quotes.
- */
-#if 42 == 1
-#define CAT2(a,b) a/**/b
-#define STRINGIFY(a) "a"
-#endif
-#if 42 == 42
-#define PeRl_CaTiFy(a, b) a ## b
-#define PeRl_StGiFy(a) #a
-#define CAT2(a,b) PeRl_CaTiFy(a,b)
-#define StGiFy(a) PeRl_StGiFy(a)
-#define STRINGIFY(a) PeRl_StGiFy(a)
-#endif
-#if 42 != 1 && 42 != 42
-#include "Bletch: How does this C preprocessor concatenate tokens?"
-#endif
-
-/* CPPSTDIN:
- * This symbol contains the first part of the string which will invoke
- * the C preprocessor on the standard input and produce to standard
- * output. Typical value of "cc -E" or "/lib/cpp", but it can also
- * call a wrapper. See CPPRUN.
- */
-/* CPPMINUS:
- * This symbol contains the second part of the string which will invoke
- * the C preprocessor on the standard input and produce to standard
- * output. This symbol will have the value "-" if CPPSTDIN needs a minus
- * to specify standard input, otherwise the value is "".
- */
-/* CPPRUN:
- * This symbol contains the string which will invoke a C preprocessor on
- * the standard input and produce to standard output. It needs to end
- * with CPPLAST, after all other preprocessor flags have been specified.
- * The main difference with CPPSTDIN is that this program will never be a
- * pointer to a shell wrapper, i.e. it will be empty if no preprocessor is
- * available directly to the user. Note that it may well be different from
- * the preprocessor used to compile the C program.
- */
-/* CPPLAST:
- * This symbol is intended to be used along with CPPRUN in the same manner
- * symbol CPPMINUS is used with CPPSTDIN. It contains either "-" or "".
- */
-#define CPPSTDIN "cc -E"
-#define CPPMINUS "-"
-#define CPPRUN "cc -E"
-#define CPPLAST "-"
-
-/* HAS_ACCESS:
- * This manifest constant lets the C program know that the access()
- * system call is available to check for accessibility using real UID/GID.
- * (always present on UNIX.)
- */
-/*#define HAS_ACCESS / **/
-
-/* HASATTRIBUTE_FORMAT:
- * Can we handle GCC attribute for checking printf-style formats
- */
-/* PRINTF_FORMAT_NULL_OK:
- * Allows __printf__ format to be null when checking printf-style
- */
-/* HASATTRIBUTE_MALLOC:
- * Can we handle GCC attribute for malloc-style functions.
- */
-/* HASATTRIBUTE_NONNULL:
- * Can we handle GCC attribute for nonnull function parms.
- */
-/* HASATTRIBUTE_NORETURN:
- * Can we handle GCC attribute for functions that do not return
- */
-/* HASATTRIBUTE_PURE:
- * Can we handle GCC attribute for pure functions
- */
-/* HASATTRIBUTE_UNUSED:
- * Can we handle GCC attribute for unused variables and arguments
- */
-/* HASATTRIBUTE_DEPRECATED:
- * Can we handle GCC attribute for marking deprecated APIs
- */
-/* HASATTRIBUTE_WARN_UNUSED_RESULT:
- * Can we handle GCC attribute for warning on unused results
- */
-/*#define HASATTRIBUTE_DEPRECATED / **/
-/*#define HASATTRIBUTE_FORMAT / **/
-/*#define PRINTF_FORMAT_NULL_OK / **/
-/*#define HASATTRIBUTE_NORETURN / **/
-/*#define HASATTRIBUTE_MALLOC / **/
-/*#define HASATTRIBUTE_NONNULL / **/
-/*#define HASATTRIBUTE_PURE / **/
-/*#define HASATTRIBUTE_UNUSED / **/
-/*#define HASATTRIBUTE_WARN_UNUSED_RESULT / **/
-
-/* HASCONST:
- * This symbol, if defined, indicates that this C compiler knows about
- * the const type. There is no need to actually test for that symbol
- * within your programs. The mere use of the "const" keyword will
- * trigger the necessary tests.
- */
-/*#define HASCONST / **/
-#ifndef HASCONST
-#define const
-#endif
-
-/* HAS_CSH:
- * This symbol, if defined, indicates that the C-shell exists.
- */
-/* CSH:
- * This symbol, if defined, contains the full pathname of csh.
- */
-/*#define HAS_CSH / **/
-#ifdef HAS_CSH
-#define CSH "" /**/
-#endif
-
-/* SETUID_SCRIPTS_ARE_SECURE_NOW:
- * This symbol, if defined, indicates that the bug that prevents
- * setuid scripts from being secure is not present in this kernel.
- */
-/* DOSUID:
- * This symbol, if defined, indicates that the C program should
- * check the script that it is executing for setuid/setgid bits, and
- * attempt to emulate setuid/setgid on systems that have disabled
- * setuid #! scripts because the kernel can't do it securely.
- * It is up to the package designer to make sure that this emulation
- * is done securely. Among other things, it should do an fstat on
- * the script it just opened to make sure it really is a setuid/setgid
- * script, it should make sure the arguments passed correspond exactly
- * to the argument on the #! line, and it should not trust any
- * subprocesses to which it must pass the filename rather than the
- * file descriptor of the script to be executed.
- */
-/*#define SETUID_SCRIPTS_ARE_SECURE_NOW / **/
-/*#define DOSUID / **/
-
-/* HAS_ENDGRENT:
- * This symbol, if defined, indicates that the getgrent routine is
- * available for finalizing sequential access of the group database.
- */
-/*#define HAS_ENDGRENT / **/
-
-/* HAS_ENDHOSTENT:
- * This symbol, if defined, indicates that the endhostent() routine is
- * available to close whatever was being used for host queries.
- */
-/*#define HAS_ENDHOSTENT / **/
-
-/* HAS_ENDNETENT:
- * This symbol, if defined, indicates that the endnetent() routine is
- * available to close whatever was being used for network queries.
- */
-/*#define HAS_ENDNETENT / **/
-
-/* HAS_ENDPROTOENT:
- * This symbol, if defined, indicates that the endprotoent() routine is
- * available to close whatever was being used for protocol queries.
- */
-/*#define HAS_ENDPROTOENT / **/
-
-/* HAS_ENDPWENT:
- * This symbol, if defined, indicates that the getgrent routine is
- * available for finalizing sequential access of the passwd database.
- */
-/*#define HAS_ENDPWENT / **/
-
-/* HAS_ENDSERVENT:
- * This symbol, if defined, indicates that the endservent() routine is
- * available to close whatever was being used for service queries.
- */
-/*#define HAS_ENDSERVENT / **/
-
-/* FLEXFILENAMES:
- * This symbol, if defined, indicates that the system supports filenames
- * longer than 14 characters.
- */
-/*#define FLEXFILENAMES / **/
-
-/* HAS_GETGRENT:
- * This symbol, if defined, indicates that the getgrent routine is
- * available for sequential access of the group database.
- */
-/*#define HAS_GETGRENT / **/
-
-/* HAS_GETHOSTBYADDR:
- * This symbol, if defined, indicates that the gethostbyaddr() routine is
- * available to look up hosts by their IP addresses.
- */
-/*#define HAS_GETHOSTBYADDR / **/
-
-/* HAS_GETHOSTBYNAME:
- * This symbol, if defined, indicates that the gethostbyname() routine is
- * available to look up host names in some data base or other.
- */
-/*#define HAS_GETHOSTBYNAME / **/
-
-/* HAS_GETHOSTENT:
- * This symbol, if defined, indicates that the gethostent() routine is
- * available to look up host names in some data base or another.
- */
-/*#define HAS_GETHOSTENT / **/
-
-/* HAS_GETHOSTNAME:
- * This symbol, if defined, indicates that the C program may use the
- * gethostname() routine to derive the host name. See also HAS_UNAME
- * and PHOSTNAME.
- */
-/* HAS_UNAME:
- * This symbol, if defined, indicates that the C program may use the
- * uname() routine to derive the host name. See also HAS_GETHOSTNAME
- * and PHOSTNAME.
- */
-/* PHOSTNAME:
- * This symbol, if defined, indicates the command to feed to the
- * popen() routine to derive the host name. See also HAS_GETHOSTNAME
- * and HAS_UNAME. Note that the command uses a fully qualified path,
- * so that it is safe even if used by a process with super-user
- * privileges.
- */
-/* HAS_PHOSTNAME:
- * This symbol, if defined, indicates that the C program may use the
- * contents of PHOSTNAME as a command to feed to the popen() routine
- * to derive the host name.
- */
-/*#define HAS_GETHOSTNAME / **/
-/*#define HAS_UNAME / **/
-/*#define HAS_PHOSTNAME / **/
-#ifdef HAS_PHOSTNAME
-#define PHOSTNAME "/bin/hostname" /* How to get the host name */
-#endif
-
-/* HAS_GETNETBYADDR:
- * This symbol, if defined, indicates that the getnetbyaddr() routine is
- * available to look up networks by their IP addresses.
- */
-/*#define HAS_GETNETBYADDR / **/
-
-/* HAS_GETNETBYNAME:
- * This symbol, if defined, indicates that the getnetbyname() routine is
- * available to look up networks by their names.
- */
-/*#define HAS_GETNETBYNAME / **/
-
-/* HAS_GETNETENT:
- * This symbol, if defined, indicates that the getnetent() routine is
- * available to look up network names in some data base or another.
- */
-/*#define HAS_GETNETENT / **/
-
-/* HAS_GETPROTOENT:
- * This symbol, if defined, indicates that the getprotoent() routine is
- * available to look up protocols in some data base or another.
- */
-/*#define HAS_GETPROTOENT / **/
-
-/* HAS_GETPGRP:
- * This symbol, if defined, indicates that the getpgrp routine is
- * available to get the current process group.
- */
-/* USE_BSD_GETPGRP:
- * This symbol, if defined, indicates that getpgrp needs one
- * arguments whereas USG one needs none.
- */
-/*#define HAS_GETPGRP / **/
-/*#define USE_BSD_GETPGRP / **/
-
-/* HAS_GETPROTOBYNAME:
- * This symbol, if defined, indicates that the getprotobyname()
- * routine is available to look up protocols by their name.
- */
-/* HAS_GETPROTOBYNUMBER:
- * This symbol, if defined, indicates that the getprotobynumber()
- * routine is available to look up protocols by their number.
- */
-/*#define HAS_GETPROTOBYNAME / **/
-/*#define HAS_GETPROTOBYNUMBER / **/
-
-/* HAS_GETPWENT:
- * This symbol, if defined, indicates that the getpwent routine is
- * available for sequential access of the passwd database.
- * If this is not available, the older getpw() function may be available.
- */
-/*#define HAS_GETPWENT / **/
-
-/* HAS_GETSERVENT:
- * This symbol, if defined, indicates that the getservent() routine is
- * available to look up network services in some data base or another.
- */
-/*#define HAS_GETSERVENT / **/
-
-/* HAS_GETSERVBYNAME:
- * This symbol, if defined, indicates that the getservbyname()
- * routine is available to look up services by their name.
- */
-/* HAS_GETSERVBYPORT:
- * This symbol, if defined, indicates that the getservbyport()
- * routine is available to look up services by their port.
- */
-/*#define HAS_GETSERVBYNAME / **/
-/*#define HAS_GETSERVBYPORT / **/
-
-/* HAS_HTONL:
- * This symbol, if defined, indicates that the htonl() routine (and
- * friends htons() ntohl() ntohs()) are available to do network
- * order byte swapping.
- */
-/* HAS_HTONS:
- * This symbol, if defined, indicates that the htons() routine (and
- * friends htonl() ntohl() ntohs()) are available to do network
- * order byte swapping.
- */
-/* HAS_NTOHL:
- * This symbol, if defined, indicates that the ntohl() routine (and
- * friends htonl() htons() ntohs()) are available to do network
- * order byte swapping.
- */
-/* HAS_NTOHS:
- * This symbol, if defined, indicates that the ntohs() routine (and
- * friends htonl() htons() ntohl()) are available to do network
- * order byte swapping.
- */
-/*#define HAS_HTONL / **/
-/*#define HAS_HTONS / **/
-/*#define HAS_NTOHL / **/
-/*#define HAS_NTOHS / **/
-
-/* HAS_LONG_DOUBLE:
- * This symbol will be defined if the C compiler supports long
- * doubles.
- */
-/* LONG_DOUBLESIZE:
- * This symbol contains the size of a long double, so that the
- * C preprocessor can make decisions based on it. It is only
- * defined if the system supports long doubles.
- */
-/*#define HAS_LONG_DOUBLE / **/
-#ifdef HAS_LONG_DOUBLE
-#define LONG_DOUBLESIZE 8 /**/
-#endif
-
-/* HAS_LONG_LONG:
- * This symbol will be defined if the C compiler supports long long.
- */
-/* LONGLONGSIZE:
- * This symbol contains the size of a long long, so that the
- * C preprocessor can make decisions based on it. It is only
- * defined if the system supports long long.
- */
-/*#define HAS_LONG_LONG / **/
-#ifdef HAS_LONG_LONG
-#define LONGLONGSIZE 8 /**/
-#endif
-
-/* HAS_MEMCHR:
- * This symbol, if defined, indicates that the memchr routine is available
- * to locate characters within a C string.
- */
-#define HAS_MEMCHR /**/
-
-/* HAS_MKSTEMP:
- * This symbol, if defined, indicates that the mkstemp routine is
- * available to exclusively create and open a uniquely named
- * temporary file.
- */
-/*#define HAS_MKSTEMP / **/
-
-/* HAS_MMAP:
- * This symbol, if defined, indicates that the mmap system call is
- * available to map a file into memory.
- */
-/* Mmap_t:
- * This symbol holds the return type of the mmap() system call
- * (and simultaneously the type of the first argument).
- * Usually set to 'void *' or 'caddr_t'.
- */
-/*#define HAS_MMAP / **/
-#define Mmap_t void * /**/
-
-/* HAS_MSG:
- * This symbol, if defined, indicates that the entire msg*(2) library is
- * supported (IPC mechanism based on message queues).
- */
-/*#define HAS_MSG / **/
-
-/* HAS_SEM:
- * This symbol, if defined, indicates that the entire sem*(2) library is
- * supported.
- */
-/*#define HAS_SEM / **/
-
-/* HAS_SETGRENT:
- * This symbol, if defined, indicates that the setgrent routine is
- * available for initializing sequential access of the group database.
- */
-/*#define HAS_SETGRENT / **/
-
-/* HAS_SETHOSTENT:
- * This symbol, if defined, indicates that the sethostent() routine is
- * available.
- */
-/*#define HAS_SETHOSTENT / **/
-
-/* HAS_SETNETENT:
- * This symbol, if defined, indicates that the setnetent() routine is
- * available.
- */
-/*#define HAS_SETNETENT / **/
-
-/* HAS_SETPROTOENT:
- * This symbol, if defined, indicates that the setprotoent() routine is
- * available.
- */
-/*#define HAS_SETPROTOENT / **/
-
-/* HAS_SETPGRP:
- * This symbol, if defined, indicates that the setpgrp routine is
- * available to set the current process group.
- */
-/* USE_BSD_SETPGRP:
- * This symbol, if defined, indicates that setpgrp needs two
- * arguments whereas USG one needs none. See also HAS_SETPGID
- * for a POSIX interface.
- */
-/*#define HAS_SETPGRP / **/
-/*#define USE_BSD_SETPGRP / **/
-
-/* HAS_SETPWENT:
- * This symbol, if defined, indicates that the setpwent routine is
- * available for initializing sequential access of the passwd database.
- */
-/*#define HAS_SETPWENT / **/
-
-/* HAS_SETSERVENT:
- * This symbol, if defined, indicates that the setservent() routine is
- * available.
- */
-/*#define HAS_SETSERVENT / **/
-
-/* HAS_SETVBUF:
- * This symbol, if defined, indicates that the setvbuf routine is
- * available to change buffering on an open stdio stream.
- * to a line-buffered mode.
- */
-/*#define HAS_SETVBUF / **/
-
-/* HAS_SHM:
- * This symbol, if defined, indicates that the entire shm*(2) library is
- * supported.
- */
-/*#define HAS_SHM / **/
-
-/* Shmat_t:
- * This symbol holds the return type of the shmat() system call.
- * Usually set to 'void *' or 'char *'.
- */
-/* HAS_SHMAT_PROTOTYPE:
- * This symbol, if defined, indicates that the sys/shm.h includes
- * a prototype for shmat(). Otherwise, it is up to the program to
- * guess one. Shmat_t shmat(int, Shmat_t, int) is a good guess,
- * but not always right so it should be emitted by the program only
- * when HAS_SHMAT_PROTOTYPE is not defined to avoid conflicting defs.
- */
-#define Shmat_t void * /**/
-/*#define HAS_SHMAT_PROTOTYPE / **/
-
-/* HAS_SOCKET:
- * This symbol, if defined, indicates that the BSD socket interface is
- * supported.
- */
-/* HAS_SOCKETPAIR:
- * This symbol, if defined, indicates that the BSD socketpair() call is
- * supported.
- */
-/* HAS_MSG_CTRUNC:
- * This symbol, if defined, indicates that the MSG_CTRUNC is supported.
- * Checking just with #ifdef might not be enough because this symbol
- * has been known to be an enum.
- */
-/* HAS_MSG_DONTROUTE:
- * This symbol, if defined, indicates that the MSG_DONTROUTE is supported.
- * Checking just with #ifdef might not be enough because this symbol
- * has been known to be an enum.
- */
-/* HAS_MSG_OOB:
- * This symbol, if defined, indicates that the MSG_OOB is supported.
- * Checking just with #ifdef might not be enough because this symbol
- * has been known to be an enum.
- */
-/* HAS_MSG_PEEK:
- * This symbol, if defined, indicates that the MSG_PEEK is supported.
- * Checking just with #ifdef might not be enough because this symbol
- * has been known to be an enum.
- */
-/* HAS_MSG_PROXY:
- * This symbol, if defined, indicates that the MSG_PROXY is supported.
- * Checking just with #ifdef might not be enough because this symbol
- * has been known to be an enum.
- */
-/* HAS_SCM_RIGHTS:
- * This symbol, if defined, indicates that the SCM_RIGHTS is supported.
- * Checking just with #ifdef might not be enough because this symbol
- * has been known to be an enum.
- */
-/* HAS_SOCKADDR_SA_LEN:
- * This symbol, if defined, indicates that the struct sockaddr
- * structure has a member called sa_len, indicating the length of
- * the structure.
- */
-/* HAS_SIN6_SCOPE_ID:
- * This symbol, if defined, indicates that the struct sockaddr_in6
- * structure has a member called sin6_scope_id.
- */
-/*#define HAS_SOCKET / **/
-/*#define HAS_SOCKETPAIR / **/
-/*#define HAS_SOCKADDR_SA_LEN / **/
-/*#define HAS_MSG_CTRUNC / **/
-/*#define HAS_MSG_DONTROUTE / **/
-/*#define HAS_MSG_OOB / **/
-/*#define HAS_MSG_PEEK / **/
-/*#define HAS_MSG_PROXY / **/
-/*#define HAS_SCM_RIGHTS / **/
-/*#define HAS_SIN6_SCOPE_ID / **/
-
-/* USE_STAT_BLOCKS:
- * This symbol is defined if this system has a stat structure declaring
- * st_blksize and st_blocks.
- */
-#ifndef USE_STAT_BLOCKS
-/*#define USE_STAT_BLOCKS / **/
-#endif
-
-/* USE_STRUCT_COPY:
- * This symbol, if defined, indicates that this C compiler knows how
- * to copy structures. If undefined, you'll need to use a block copy
- * routine of some sort instead.
- */
-/*#define USE_STRUCT_COPY / **/
-
-/* HAS_STRERROR:
- * This symbol, if defined, indicates that the strerror routine is
- * available to translate error numbers to strings. See the writeup
- * of Strerror() in this file before you try to define your own.
- */
-/* HAS_SYS_ERRLIST:
- * This symbol, if defined, indicates that the sys_errlist array is
- * available to translate error numbers to strings. The extern int
- * sys_nerr gives the size of that table.
- */
-/* Strerror:
- * This preprocessor symbol is defined as a macro if strerror() is
- * not available to translate error numbers to strings but sys_errlist[]
- * array is there.
- */
-/*#define HAS_STRERROR / **/
-/*#define HAS_SYS_ERRLIST / **/
-#define Strerror(e) strerror(e)
-
-/* HAS_STRTOUL:
- * This symbol, if defined, indicates that the strtoul routine is
- * available to provide conversion of strings to unsigned long.
- */
-#define HAS_STRTOUL /**/
-
/* HAS_UNION_SEMUN:
* This symbol, if defined, indicates that the union semun is
* defined by including <sys/sem.h>. If not, the user code
@@ -2862,6 +2652,71 @@
#define volatile
#endif
+/* HAS_VPRINTF:
+ * This symbol, if defined, indicates that the vprintf routine is available
+ * to printf with a pointer to an argument list. If unavailable, you
+ * may need to write your own, probably in terms of _doprnt().
+ */
+/* USE_CHAR_VSPRINTF:
+ * This symbol is defined if this system has vsprintf() returning type
+ * (char*). The trend seems to be to declare it as "int vsprintf()". It
+ * is up to the package author to declare vsprintf correctly based on the
+ * symbol.
+ */
+#define HAS_VPRINTF /**/
+/*#define USE_CHAR_VSPRINTF / **/
+
+/* DOUBLESIZE:
+ * This symbol contains the size of a double, so that the C preprocessor
+ * can make decisions based on it.
+ */
+#define DOUBLESIZE 8 /**/
+
+/* EBCDIC:
+ * This symbol, if defined, indicates that this system uses
+ * EBCDIC encoding.
+ */
+/* BOOTSTRAP_CHARSET:
+ * This symbol, if defined, indicates that this system needs
+ * converting various files to the native character set before
+ * bringing up perl on a system that has a non-ASCII character
+ * set and no working perl.
+ */
+/*#define EBCDIC / **/
+/*#define BOOTSTRAP_CHARSET / **/
+
+/* Fpos_t:
+ * This symbol holds the type used to declare file positions in libc.
+ * It can be fpos_t, long, uint, etc... It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+#define Fpos_t int /* File position type */
+
+/* Gid_t_f:
+ * This symbol defines the format string used for printing a Gid_t.
+ */
+#define Gid_t_f "lu" /**/
+
+/* Gid_t_sign:
+ * This symbol holds the signedness of a Gid_t.
+ * 1 for unsigned, -1 for signed.
+ */
+#define Gid_t_sign 1 /* GID sign */
+
+/* Gid_t_size:
+ * This symbol holds the size of a Gid_t in bytes.
+ */
+#define Gid_t_size 4 /* GID size */
+
+/* Gid_t:
+ * This symbol holds the return type of getgid() and the type of
+ * argument to setrgid() and related functions. Typically,
+ * it is the type of group ids in the kernel. It can be int, ushort,
+ * gid_t, etc... It may be necessary to include <sys/types.h> to get
+ * any typedef'ed information.
+ */
+#define Gid_t int /* Type for getgid(), etc... */
+
/* I_DIRENT:
* This symbol, if defined, indicates to the C program that it should
* include <dirent.h>. Using this symbol also triggers the definition
@@ -2893,6 +2748,12 @@
/*#define I_GRP / **/
/*#define GRPASSWD / **/
+/* I_MACH_CTHREADS:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <mach/cthreads.h>.
+ */
+/*#define I_MACH_CTHREADS / **/
+
/* I_NDBM:
* This symbol, if defined, indicates that <ndbm.h> exists and should
* be included.
@@ -2944,6 +2805,12 @@
*/
/*#define I_NET_ERRNO / **/
+/* I_PTHREAD:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <pthread.h>.
+ */
+/*#define I_PTHREAD / **/
+
/* I_PWD:
* This symbol, if defined, indicates to the C program that it should
* include <pwd.h>.
@@ -2990,6 +2857,18 @@
/*#define PWGECOS / **/
/*#define PWPASSWD / **/
+/* I_SYS_ACCESS:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/access.h>.
+ */
+/*#define I_SYS_ACCESS / **/
+
+/* I_SYS_SECURITY:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/security.h>.
+ */
+/*#define I_SYS_SECURITY / **/
+
/* I_SYSUIO:
* This symbol, if defined, indicates that <sys/uio.h> exists and
* should be included.
@@ -2996,6 +2875,32 @@
*/
/*#define I_SYSUIO / **/
+/* I_TIME:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <time.h>.
+ */
+/* I_SYS_TIME:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/time.h>.
+ */
+/* I_SYS_TIME_KERNEL:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/time.h> with KERNEL defined.
+ */
+/* HAS_TM_TM_ZONE:
+ * This symbol, if defined, indicates to the C program that
+ * the struct tm has a tm_zone field.
+ */
+/* HAS_TM_TM_GMTOFF:
+ * This symbol, if defined, indicates to the C program that
+ * the struct tm has a tm_gmtoff field.
+ */
+#define I_TIME /**/
+/*#define I_SYS_TIME / **/
+/*#define I_SYS_TIME_KERNEL / **/
+/*#define HAS_TM_TM_ZONE / **/
+/*#define HAS_TM_TM_GMTOFF / **/
+
/* I_STDARG:
* This symbol, if defined, indicates that <stdarg.h> exists and should
* be included.
@@ -3007,6 +2912,36 @@
#define I_STDARG /**/
/*#define I_VARARGS / **/
+/* PERL_INC_VERSION_LIST:
+ * This variable specifies the list of subdirectories in over
+ * which perl.c:incpush() and lib/lib.pm will automatically
+ * search when adding directories to @INC, in a format suitable
+ * for a C initialization string. See the inc_version_list entry
+ * in Porting/Glossary for more details.
+ */
+/*#define PERL_INC_VERSION_LIST NULL / **/
+
+/* INSTALL_USR_BIN_PERL:
+ * This symbol, if defined, indicates that Perl is to be installed
+ * also as /usr/bin/perl.
+ */
+/*#define INSTALL_USR_BIN_PERL / **/
+
+/* Off_t:
+ * This symbol holds the type used to declare offsets in the kernel.
+ * It can be int, long, off_t, etc... It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+/* LSEEKSIZE:
+ * This symbol holds the number of bytes used by the Off_t.
+ */
+/* Off_t_size:
+ * This symbol holds the number of bytes used by the Off_t.
+ */
+#define Off_t int /* <offset> type */
+#define LSEEKSIZE 4 /* <offset> size */
+#define Off_t_size 4 /* <offset> size */
+
/* Free_t:
* This variable contains the return type of free(). It is usually
* void, but occasionally int.
@@ -3027,6 +2962,92 @@
*/
/*#define MYMALLOC / **/
+/* Mode_t:
+ * This symbol holds the type used to declare file modes
+ * for systems calls. It is usually mode_t, but may be
+ * int or unsigned short. It may be necessary to include <sys/types.h>
+ * to get any typedef'ed information.
+ */
+#define Mode_t int /* file mode parameter for system calls */
+
+/* VAL_O_NONBLOCK:
+ * This symbol is to be used during open() or fcntl(F_SETFL) to turn on
+ * non-blocking I/O for the file descriptor. Note that there is no way
+ * back, i.e. you cannot turn it blocking again this way. If you wish to
+ * alternatively switch between blocking and non-blocking, use the
+ * ioctl(FIOSNBIO) call instead, but that is not supported by all devices.
+ */
+/* VAL_EAGAIN:
+ * This symbol holds the errno error code set by read() when no data was
+ * present on the non-blocking file descriptor.
+ */
+/* RD_NODATA:
+ * This symbol holds the return code from read() when no data is present
+ * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is
+ * not defined, then you can't distinguish between no data and EOF by
+ * issuing a read(). You'll have to find another way to tell for sure!
+ */
+/* EOF_NONBLOCK:
+ * This symbol, if defined, indicates to the C program that a read() on
+ * a non-blocking file descriptor will return 0 on EOF, and not the value
+ * held in RD_NODATA (-1 usually, in that case!).
+ */
+#define VAL_O_NONBLOCK O_NONBLOCK
+#define VAL_EAGAIN EAGAIN
+#define RD_NODATA -1
+#undef EOF_NONBLOCK
+
+/* Netdb_host_t:
+ * This symbol holds the type used for the 1st argument
+ * to gethostbyaddr().
+ */
+/* Netdb_hlen_t:
+ * This symbol holds the type used for the 2nd argument
+ * to gethostbyaddr().
+ */
+/* Netdb_name_t:
+ * This symbol holds the type used for the argument to
+ * gethostbyname().
+ */
+/* Netdb_net_t:
+ * This symbol holds the type used for the 1st argument to
+ * getnetbyaddr().
+ */
+#define Netdb_host_t const char * /**/
+#define Netdb_hlen_t int /**/
+#define Netdb_name_t const char * /**/
+#define Netdb_net_t unsigned long /**/
+
+/* PERL_OTHERLIBDIRS:
+ * This variable contains a colon-separated set of paths for the perl
+ * binary to search for additional library files or modules.
+ * These directories will be tacked to the end of @INC.
+ * Perl will automatically search below each path for version-
+ * and architecture-specific directories. See PERL_INC_VERSION_LIST
+ * for more details.
+ */
+/*#define PERL_OTHERLIBDIRS " " / **/
+
+/* Pid_t:
+ * This symbol holds the type used to declare process ids in the kernel.
+ * It can be int, uint, pid_t, etc... It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+#define Pid_t int /* PID type */
+
+/* PRIVLIB:
+ * This symbol contains the name of the private library for this package.
+ * The library is private in the sense that it needn't be in anyone's
+ * execution path, but it should be accessible by the world. The program
+ * should be prepared to do ~ expansion.
+ */
+/* PRIVLIB_EXP:
+ * 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 "/usr/local/lib/perl5/5.18" /**/
+#define PRIVLIB_EXP "/usr/local/lib/perl5/5.18" /**/
+
/* CAN_PROTOTYPE:
* If defined, this macro indicates that the C compiler can handle
* function prototypes.
@@ -3045,6 +3066,65 @@
#define _(args) ()
#endif
+/* PTRSIZE:
+ * This symbol contains the size of a pointer, so that the C preprocessor
+ * can make decisions based on it. It will be sizeof(void *) if
+ * the compiler supports (void *); otherwise it will be
+ * sizeof(char *).
+ */
+#define PTRSIZE 4 /**/
+
+/* HAS_QUAD:
+ * This symbol, if defined, tells that there's a 64-bit integer type,
+ * Quad_t, and its unsigned counterpart, Uquad_t. QUADKIND will be one
+ * of QUAD_IS_INT, QUAD_IS_LONG, QUAD_IS_LONG_LONG, QUAD_IS_INT64_T,
+ * or QUAD_IS___INT64.
+ */
+/*#define HAS_QUAD / **/
+#ifdef HAS_QUAD
+# define Quad_t int64_t /**/
+# define Uquad_t uint64_t /**/
+# define QUADKIND 4 /**/
+# define QUAD_IS_INT 1
+# define QUAD_IS_LONG 2
+# define QUAD_IS_LONG_LONG 3
+# define QUAD_IS_INT64_T 4
+# define QUAD_IS___INT64 5
+#endif
+
+/* Drand01:
+ * This macro is to be used to generate uniformly distributed
+ * random numbers over the range [0., 1.[. You may have to supply
+ * an 'extern double drand48();' in your program since SunOS 4.1.3
+ * doesn't provide you with anything relevant in its headers.
+ * See HAS_DRAND48_PROTO.
+ */
+/* Rand_seed_t:
+ * This symbol defines the type of the argument of the
+ * random seed function.
+ */
+/* seedDrand01:
+ * This symbol defines the macro to be used in seeding the
+ * random number generator (see Drand01).
+ */
+/* RANDBITS:
+ * This symbol indicates how many bits are produced by the
+ * function used to generate normalized random numbers.
+ * Values include 15, 16, 31, and 48.
+ */
+#define Drand01() ((rand() & 0x7FFF) / (double) ((unsigned long)1 << 15)) /**/
+#define Rand_seed_t int /**/
+#define seedDrand01(x) srand((Rand_seed_t)x) /**/
+#define RANDBITS 48 /**/
+
+/* Select_fd_set_t:
+ * This symbol holds the type used for the 2nd, 3rd, and 4th
+ * arguments to select. Usually, this is 'fd_set *', if HAS_FD_SET
+ * is defined, and 'int *' otherwise. This is only useful if you
+ * have select(), of course.
+ */
+#define Select_fd_set_t int /**/
+
/* SH_PATH:
* This symbol contains the full pathname to the shell used on this
* on this system to execute Bourne shell scripts. Usually, this will be
@@ -3094,6 +3174,77 @@
#define SIG_NUM 0 /**/
#define SIG_SIZE 1 /**/
+/* SITEARCH:
+ * This symbol contains the name of the private library for this package.
+ * The library is private in the sense that it needn't be in anyone's
+ * execution path, but it should be accessible by the world. The program
+ * should be prepared to do ~ expansion.
+ * The standard distribution will put nothing in this directory.
+ * After perl has been installed, users may install their own local
+ * architecture-dependent modules in this directory with
+ * MakeMaker Makefile.PL
+ * or equivalent. See INSTALL for details.
+ */
+/* SITEARCH_EXP:
+ * 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 "/usr/local/lib/perl5/5.18/unknown" / **/
+/*#define SITEARCH_EXP "/usr/local/lib/perl5/5.18/unknown" / **/
+
+/* SITELIB:
+ * This symbol contains the name of the private library for this package.
+ * The library is private in the sense that it needn't be in anyone's
+ * execution path, but it should be accessible by the world. The program
+ * should be prepared to do ~ expansion.
+ * The standard distribution will put nothing in this directory.
+ * After perl has been installed, users may install their own local
+ * architecture-independent modules in this directory with
+ * MakeMaker Makefile.PL
+ * or equivalent. See INSTALL for details.
+ */
+/* SITELIB_EXP:
+ * This symbol contains the ~name expanded version of SITELIB, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+/* SITELIB_STEM:
+ * This define is SITELIB_EXP with any trailing version-specific component
+ * 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 "/usr/local/lib/perl5/5.18" /**/
+#define SITELIB_EXP "/usr/local/lib/perl5/5.18" /**/
+#define SITELIB_STEM "/usr/local/lib/perl5" /**/
+
+/* Size_t_size:
+ * This symbol holds the size of a Size_t in bytes.
+ */
+#define Size_t_size 4 /**/
+
+/* Size_t:
+ * This symbol holds the type used to declare length parameters
+ * for string functions. It is usually size_t, but may be
+ * unsigned long, int, etc. It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+#define Size_t size_t /* length parameter for string functions */
+
+/* Sock_size_t:
+ * This symbol holds the type used for the size argument of
+ * various socket calls (just the base type, not the pointer-to).
+ */
+#define Sock_size_t int /**/
+
+/* SSize_t:
+ * This symbol holds the type used by functions that return
+ * a count of bytes or an error condition. It must be a signed type.
+ * It is usually ssize_t, but may be long or int, etc.
+ * It may be necessary to include <sys/types.h> or <unistd.h>
+ * to get any typedef'ed information.
+ * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t).
+ */
+#define SSize_t int /* signed count of bytes */
+
/* STDCHAR:
* This symbol is defined to be the type of char used in stdio.h.
* It has the values "unsigned char" or "char".
@@ -3100,6 +3251,85 @@
*/
#define STDCHAR char /**/
+/* Uid_t_f:
+ * This symbol defines the format string used for printing a Uid_t.
+ */
+#define Uid_t_f "lu" /**/
+
+/* Uid_t_sign:
+ * This symbol holds the signedness of a Uid_t.
+ * 1 for unsigned, -1 for signed.
+ */
+#define Uid_t_sign 1 /* UID sign */
+
+/* Uid_t_size:
+ * This symbol holds the size of a Uid_t in bytes.
+ */
+#define Uid_t_size 4 /* UID size */
+
+/* Uid_t:
+ * This symbol holds the type used to declare user ids in the kernel.
+ * It can be int, ushort, uid_t, etc... It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+#define Uid_t int /* UID type */
+
+/* USE_ITHREADS:
+ * This symbol, if defined, indicates that Perl should be built to
+ * use the interpreter-based threading implementation.
+ */
+/* USE_5005THREADS:
+ * This symbol, if defined, indicates that Perl should be built to
+ * use the 5.005-based threading implementation.
+ * Only valid up to 5.8.x.
+ */
+/* OLD_PTHREADS_API:
+ * This symbol, if defined, indicates that Perl should
+ * be built to use the old draft POSIX threads API.
+ */
+/* USE_REENTRANT_API:
+ * This symbol, if defined, indicates that Perl should
+ * try to use the various _r versions of library functions.
+ * This is extremely experimental.
+ */
+/*#define USE_5005THREADS / **/
+/*#define USE_ITHREADS / **/
+#if defined(USE_5005THREADS) && !defined(USE_ITHREADS)
+#define USE_THREADS /* until src is revised*/
+#endif
+/*#define OLD_PTHREADS_API / **/
+/*#define USE_REENTRANT_API / **/
+
+/* PERL_VENDORARCH:
+ * If defined, this symbol contains the name of a private library.
+ * The library is private in the sense that it needn't be in anyone's
+ * execution path, but it should be accessible by the world.
+ * It may have a ~ on the front.
+ * The standard distribution will put nothing in this directory.
+ * Vendors who distribute perl may wish to place their own
+ * architecture-dependent modules and extensions in this directory with
+ * MakeMaker Makefile.PL INSTALLDIRS=vendor
+ * or equivalent. See INSTALL for details.
+ */
+/* PERL_VENDORARCH_EXP:
+ * This symbol contains the ~name expanded version of PERL_VENDORARCH, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+/*#define PERL_VENDORARCH "" / **/
+/*#define PERL_VENDORARCH_EXP "" / **/
+
+/* PERL_VENDORLIB_EXP:
+ * This symbol contains the ~name expanded version of VENDORLIB, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+/* PERL_VENDORLIB_STEM:
+ * This define is PERL_VENDORLIB_EXP with any trailing version-specific component
+ * 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 PERL_VENDORLIB_EXP "" / **/
+/*#define PERL_VENDORLIB_STEM "" / **/
+
/* VOIDFLAGS:
* This symbol indicates how much support of the void type is given by this
* compiler. What various bits mean:
@@ -3489,6 +3719,12 @@
*/
/*#define HAS_INT64_T / **/
+/* HAS_ISBLANK:
+ * This manifest constant lets the C program know that isblank
+ * is available.
+ */
+/*#define HAS_ISBLANK / **/
+
/* HAS_ISFINITE:
* This symbol, if defined, indicates that the isfinite routine is
* available to check whether a double is finite (non-infinity non-NaN).
@@ -4085,6 +4321,12 @@
*/
/*#define I_SOCKS / **/
+/* I_STDBOOL:
+ * This symbol, if defined, indicates that <stdbool.h> exists and
+ * can be included.
+ */
+/*#define I_STDBOOL / **/
+
/* I_SUNMATH:
* This symbol, if defined, indicates that <sunmath.h> exists and
* should be included.
@@ -4354,6 +4596,16 @@
*/
#define SELECT_MIN_BITS 32 /**/
+/* ST_INO_SIZE:
+ * This variable contains the size of struct stat's st_ino in bytes.
+ */
+/* ST_INO_SIGN:
+ * This symbol holds the signedness of struct stat's st_ino.
+ * 1 for unsigned, -1 for signed.
+ */
+#define ST_INO_SIGN 1 /* st_ino sign */
+#define ST_INO_SIZE 4 /* st_ino size */
+
/* STARTPERL:
* This variable contains the string to put in front of a perl
* script to make sure (one hopes) that it runs with perl and not
@@ -4435,6 +4687,13 @@
/*#define USE_FAST_STDIO / **/
#endif
+/* USE_KERN_PROC_PATHNAME:
+ * This symbol, if defined, indicates that we can use sysctl with
+ * KERN_PROC_PATHNAME to get a full path for the executable, and hence
+ * convert $^X to an absolute path.
+ */
+/*#define USE_KERN_PROC_PATHNAME / **/
+
/* USE_LARGE_FILES:
* This symbol, if defined, indicates that large file support
* should be used when available.
@@ -4467,6 +4726,13 @@
/*#define MULTIPLICITY / **/
#endif
+/* USE_NSGETEXECUTABLEPATH:
+ * This symbol, if defined, indicates that we can use _NSGetExecutablePath
+ * and realpath to get a full path for the executable, and hence convert
+ * $^X to an absolute path.
+ */
+/*#define USE_NSGETEXECUTABLEPATH / **/
+
/* USE_PERLIO:
* This symbol, if defined, indicates that the PerlIO abstraction should
* be used throughout. If not defined, stdio should be
@@ -4484,208 +4750,9 @@
/*#define USE_SOCKS / **/
#endif
-/* HAS_DRAND48_PROTO:
- * This symbol, if defined, indicates that the system provides
- * a prototype for the drand48() function. Otherwise, it is up
- * to the program to supply one. A good guess is
- * extern double drand48(void);
- */
-/*#define HAS_DRAND48_PROTO / **/
-
-/* HAS_GETHOST_PROTOS:
- * This symbol, if defined, indicates that <netdb.h> includes
- * prototypes for gethostent(), gethostbyname(), and
- * gethostbyaddr(). Otherwise, it is up to the program to guess
- * them. See netdbtype.U for probing for various Netdb_xxx_t types.
- */
-/*#define HAS_GETHOST_PROTOS / **/
-
-/* HAS_GETNET_PROTOS:
- * This symbol, if defined, indicates that <netdb.h> includes
- * prototypes for getnetent(), getnetbyname(), and
- * getnetbyaddr(). Otherwise, it is up to the program to guess
- * them. See netdbtype.U for probing for various Netdb_xxx_t types.
- */
-/*#define HAS_GETNET_PROTOS / **/
-
-/* HAS_GETPROTO_PROTOS:
- * This symbol, if defined, indicates that <netdb.h> includes
- * prototypes for getprotoent(), getprotobyname(), and
- * getprotobyaddr(). Otherwise, it is up to the program to guess
- * them. See netdbtype.U for probing for various Netdb_xxx_t types.
- */
-/*#define HAS_GETPROTO_PROTOS / **/
-
-/* HAS_GETSERV_PROTOS:
- * This symbol, if defined, indicates that <netdb.h> includes
- * prototypes for getservent(), getservbyname(), and
- * getservbyaddr(). Otherwise, it is up to the program to guess
- * them. See netdbtype.U for probing for various Netdb_xxx_t types.
- */
-/*#define HAS_GETSERV_PROTOS / **/
-
-/* HAS_LSEEK_PROTO:
- * This symbol, if defined, indicates that the system provides
- * a prototype for the lseek() function. Otherwise, it is up
- * to the program to supply one. A good guess is
- * extern off_t lseek(int, off_t, int);
- */
-/*#define HAS_LSEEK_PROTO / **/
-
-/* Netdb_host_t:
- * This symbol holds the type used for the 1st argument
- * to gethostbyaddr().
- */
-/* Netdb_hlen_t:
- * This symbol holds the type used for the 2nd argument
- * to gethostbyaddr().
- */
-/* Netdb_name_t:
- * This symbol holds the type used for the argument to
- * gethostbyname().
- */
-/* Netdb_net_t:
- * This symbol holds the type used for the 1st argument to
- * getnetbyaddr().
- */
-#define Netdb_host_t const char * /**/
-#define Netdb_hlen_t int /**/
-#define Netdb_name_t const char * /**/
-#define Netdb_net_t unsigned long /**/
-
-/* Select_fd_set_t:
- * This symbol holds the type used for the 2nd, 3rd, and 4th
- * arguments to select. Usually, this is 'fd_set *', if HAS_FD_SET
- * is defined, and 'int *' otherwise. This is only useful if you
- * have select(), of course.
- */
-#define Select_fd_set_t int /**/
-
-/* Sock_size_t:
- * This symbol holds the type used for the size argument of
- * various socket calls (just the base type, not the pointer-to).
- */
-#define Sock_size_t int /**/
-
-/* HAS_TIME:
- * This symbol, if defined, indicates that the time() routine exists.
- */
-/* Time_t:
- * This symbol holds the type returned by time(). It can be long,
- * or time_t on BSD sites (in which case <sys/types.h> should be
- * included).
- */
-#define HAS_TIME /**/
-#define Time_t time_t /* Time type */
-
-/* HAS_TIMES:
- * This symbol, if defined, indicates that the times() routine exists.
- * Note that this became obsolete on some systems (SUNOS), which now
- * use getrusage(). It may be necessary to include <sys/times.h>.
- */
-/*#define HAS_TIMES / **/
-
-/* Fpos_t:
- * This symbol holds the type used to declare file positions in libc.
- * It can be fpos_t, long, uint, etc... It may be necessary to include
- * <sys/types.h> to get any typedef'ed information.
- */
-#define Fpos_t int /* File position type */
-
-/* Gid_t_f:
- * This symbol defines the format string used for printing a Gid_t.
- */
-#define Gid_t_f "lu" /**/
-
-/* Gid_t_sign:
- * This symbol holds the signedess of a Gid_t.
- * 1 for unsigned, -1 for signed.
- */
-#define Gid_t_sign 1 /* GID sign */
-
-/* Gid_t_size:
- * This symbol holds the size of a Gid_t in bytes.
- */
-#define Gid_t_size 4 /* GID size */
-
-/* Gid_t:
- * This symbol holds the return type of getgid() and the type of
- * argument to setrgid() and related functions. Typically,
- * it is the type of group ids in the kernel. It can be int, ushort,
- * gid_t, etc... It may be necessary to include <sys/types.h> to get
- * any typedef'ed information.
- */
-#define Gid_t int /* Type for getgid(), etc... */
-
-/* Off_t:
- * This symbol holds the type used to declare offsets in the kernel.
- * It can be int, long, off_t, etc... It may be necessary to include
- * <sys/types.h> to get any typedef'ed information.
- */
-/* LSEEKSIZE:
- * This symbol holds the number of bytes used by the Off_t.
- */
-/* Off_t_size:
- * This symbol holds the number of bytes used by the Off_t.
- */
-#define Off_t int /* <offset> type */
-#define LSEEKSIZE 4 /* <offset> size */
-#define Off_t_size 4 /* <offset> size */
-
-/* Mode_t:
- * This symbol holds the type used to declare file modes
- * for systems calls. It is usually mode_t, but may be
- * int or unsigned short. It may be necessary to include <sys/types.h>
- * to get any typedef'ed information.
- */
-#define Mode_t int /* file mode parameter for system calls */
-
-/* Pid_t:
- * This symbol holds the type used to declare process ids in the kernel.
- * It can be int, uint, pid_t, etc... It may be necessary to include
- * <sys/types.h> to get any typedef'ed information.
- */
-#define Pid_t int /* PID type */
-
-/* Size_t_size:
- * This symbol holds the size of a Size_t in bytes.
- */
-#define Size_t_size 4 /* */
-
-/* Size_t:
- * This symbol holds the type used to declare length parameters
- * for string functions. It is usually size_t, but may be
- * unsigned long, int, etc. It may be necessary to include
- * <sys/types.h> to get any typedef'ed information.
- */
-#define Size_t size_t /* length parameter for string functions */
-
-/* Uid_t_f:
- * This symbol defines the format string used for printing a Uid_t.
- */
-#define Uid_t_f "lu" /**/
-
-/* Uid_t_sign:
- * This symbol holds the signedess of a Uid_t.
- * 1 for unsigned, -1 for signed.
- */
-#define Uid_t_sign 1 /* UID sign */
-
-/* Uid_t_size:
- * This symbol holds the size of a Uid_t in bytes.
- */
-#define Uid_t_size 4 /* UID size */
-
-/* Uid_t:
- * This symbol holds the type used to declare user ids in the kernel.
- * It can be int, ushort, uid_t, etc... It may be necessary to include
- * <sys/types.h> to get any typedef'ed information.
- */
-#define Uid_t int /* UID type */
-
#endif
/* Generated from:
- * 323778627146f2762cd41f4dd1db6659f59006ec9bcaaf6bcc645d0380dda938 config_h.SH
- * 2cf3a76ed7acc1c0fee31fb6f5117eef18b28c542aa7225a22c84ed74b710c83 uconfig.sh
+ * 2c9dc3f21d37b1665f6a59dfc6d79e6cb08bdf36a9c3e427d11d6b9ddffe2439 config_h.SH
+ * 26ab9b4aa382d32761cb91084ba59e7e4b190799502a43366ccb3d2f584783ca uconfig.sh
* ex: set ro: */
Property changes on: trunk/contrib/perl/uconfig.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Copied: trunk/contrib/perl/unicode_constants.h (from rev 6437, vendor/perl/5.18.1/unicode_constants.h)
===================================================================
--- trunk/contrib/perl/unicode_constants.h (rev 0)
+++ trunk/contrib/perl/unicode_constants.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -0,0 +1,44 @@
+/* -*- buffer-read-only: t -*-
+ * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ * This file is built by regen/unicode_constants.pl from Unicode data.
+ * Any changes made here will be lost!
+ */
+
+
+#ifndef H_UNICODE_CONSTANTS /* Guard against nested #includes */
+#define H_UNICODE_CONSTANTS 1
+
+/* This file contains #defines for various Unicode code points. The values
+ * the macros expand to are the native Unicode code point, or all or portions
+ * of the UTF-8 encoding for the code point. In the former case, the macro
+ * name has the suffix "_NATIVE"; otherwise, the suffix "_UTF8".
+ *
+ * The macros that have the suffix "_UTF8" may have further suffixes, as
+ * follows:
+ * "_FIRST_BYTE" if the value is just the first byte of the UTF-8
+ * representation; the value will be a numeric constant.
+ * "_TAIL" if instead it represents all but the first byte. This, and
+ * with no additional suffix are both string constants */
+
+
+#define COMBINING_GRAVE_ACCENT_UTF8 "\xCC\x80" /* U+0300 */
+#define COMBINING_ACUTE_ACCENT_UTF8 "\xCC\x81" /* U+0301 */
+#define COMBINING_DIAERESIS_UTF8 "\xCC\x88" /* U+0308 */
+
+#define GREEK_SMALL_LETTER_IOTA_UTF8 "\xCE\xB9" /* U+03B9 */
+
+#define GREEK_SMALL_LETTER_UPSILON_UTF8 "\xCF\x85" /* U+03C5 */
+
+#define HYPHEN_UTF8 "\xE2\x80\x90" /* U+2010 */
+#define FIRST_SURROGATE_UTF8_FIRST_BYTE 0xED /* U+D800 */
+
+#define DEL_NATIVE 0x7F /* U+007F */
+#define LATIN_SMALL_LETTER_SHARP_S_NATIVE 0xDF /* U+00DF */
+#define LATIN_SMALL_LETTER_A_WITH_RING_ABOVE_NATIVE 0xE5 /* U+00E5 */
+#define LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE_NATIVE 0xC5 /* U+00C5 */
+#define LATIN_SMALL_LETTER_Y_WITH_DIAERESIS_NATIVE 0xFF /* U+00FF */
+#define MICRO_SIGN_NATIVE 0xB5 /* U+00B5 */
+
+#endif /* H_UNICODE_CONSTANTS */
+
+/* ex: set ro: */
Modified: trunk/contrib/perl/universal.c
===================================================================
--- trunk/contrib/perl/universal.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/universal.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -39,12 +39,11 @@
*/
STATIC bool
-S_isa_lookup(pTHX_ HV *stash, const char * const name)
+S_isa_lookup(pTHX_ HV *stash, const char * const name, STRLEN len, U32 flags)
{
dVAR;
const struct mro_meta *const meta = HvMROMETA(stash);
HV *isa = meta->isa;
- STRLEN len = strlen(name);
const HV *our_stash;
PERL_ARGS_ASSERT_ISA_LOOKUP;
@@ -54,8 +53,7 @@
isa = meta->isa;
}
- if (hv_common(isa, NULL, name, len, 0 /* No "UTF-8" flag possible with only
- a char * argument*/,
+ if (hv_common(isa, NULL, name, len, ( flags & SVf_UTF8 ? HVhek_UTF8 : 0),
HV_FETCH_ISEXISTS, NULL, 0)) {
/* Direct name lookup worked. */
return TRUE;
@@ -64,7 +62,7 @@
/* A stash/class can go by many names (ie. User == main::User), so
we use the HvENAME in the stash itself, which is canonical, falling
back to HvNAME if necessary. */
- our_stash = gv_stashpvn(name, len, 0);
+ our_stash = gv_stashpvn(name, len, flags);
if (our_stash) {
HEK *canon_name = HvENAME_HEK(our_stash);
@@ -83,22 +81,76 @@
/*
=head1 SV Manipulation Functions
-=for apidoc sv_derived_from
+=for apidoc sv_derived_from_pvn
Returns a boolean indicating whether the SV is derived from the specified class
I<at the C level>. To check derivation at the Perl level, call C<isa()> as a
normal Perl method.
+Currently, the only significant value for C<flags> is SVf_UTF8.
+
=cut
+
+=for apidoc sv_derived_from_sv
+
+Exactly like L</sv_derived_from_pvn>, but takes the name string in the form
+of an SV instead of a string/length pair.
+
+=cut
+
*/
bool
+Perl_sv_derived_from_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
+{
+ char *namepv;
+ STRLEN namelen;
+ PERL_ARGS_ASSERT_SV_DERIVED_FROM_SV;
+ namepv = SvPV(namesv, namelen);
+ if (SvUTF8(namesv))
+ flags |= SVf_UTF8;
+ return sv_derived_from_pvn(sv, namepv, namelen, flags);
+}
+
+/*
+=for apidoc sv_derived_from
+
+Exactly like L</sv_derived_from_pv>, but doesn't take a C<flags> parameter.
+
+=cut
+*/
+
+bool
Perl_sv_derived_from(pTHX_ SV *sv, const char *const name)
{
+ PERL_ARGS_ASSERT_SV_DERIVED_FROM;
+ return sv_derived_from_pvn(sv, name, strlen(name), 0);
+}
+
+/*
+=for apidoc sv_derived_from_pv
+
+Exactly like L</sv_derived_from_pvn>, but takes a nul-terminated string
+instead of a string/length pair.
+
+=cut
+*/
+
+
+bool
+Perl_sv_derived_from_pv(pTHX_ SV *sv, const char *const name, U32 flags)
+{
+ PERL_ARGS_ASSERT_SV_DERIVED_FROM_PV;
+ return sv_derived_from_pvn(sv, name, strlen(name), flags);
+}
+
+bool
+Perl_sv_derived_from_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
+{
dVAR;
HV *stash;
- PERL_ARGS_ASSERT_SV_DERIVED_FROM;
+ PERL_ARGS_ASSERT_SV_DERIVED_FROM_PVN;
SvGETMAGIC(sv);
@@ -112,13 +164,15 @@
}
else {
stash = gv_stashsv(sv, 0);
+ if (!stash)
+ stash = gv_stashpvs("UNIVERSAL", 0);
}
- return stash ? isa_lookup(stash, name) : FALSE;
+ return stash ? isa_lookup(stash, name, len, flags) : FALSE;
}
/*
-=for apidoc sv_does
+=for apidoc sv_does_sv
Returns a boolean indicating whether the SV performs a specific, named role.
The SV can be a Perl object or the name of a Perl class.
@@ -129,14 +183,15 @@
#include "XSUB.h"
bool
-Perl_sv_does(pTHX_ SV *sv, const char *const name)
+Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
{
- const char *classname;
+ SV *classname;
bool does_it;
SV *methodname;
dSP;
- PERL_ARGS_ASSERT_SV_DOES;
+ PERL_ARGS_ASSERT_SV_DOES_SV;
+ PERL_UNUSED_ARG(flags);
ENTER;
SAVETMPS;
@@ -143,26 +198,26 @@
SvGETMAGIC(sv);
- if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
- || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) {
+ if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) {
LEAVE;
return FALSE;
}
if (sv_isobject(sv)) {
- classname = sv_reftype(SvRV(sv),TRUE);
+ classname = sv_ref(NULL,SvRV(sv),TRUE);
} else {
- classname = SvPV_nolen(sv);
+ classname = sv;
}
- if (strEQ(name,classname)) {
+ if (sv_eq(classname, namesv)) {
LEAVE;
return TRUE;
}
PUSHMARK(SP);
- XPUSHs(sv);
- mXPUSHs(newSVpv(name, 0));
+ EXTEND(SP, 2);
+ PUSHs(sv);
+ PUSHs(namesv);
PUTBACK;
methodname = newSVpvs_flags("isa", SVs_TEMP);
@@ -181,6 +236,53 @@
}
/*
+=for apidoc sv_does
+
+Like L</sv_does_pv>, but doesn't take a C<flags> parameter.
+
+=cut
+*/
+
+bool
+Perl_sv_does(pTHX_ SV *sv, const char *const name)
+{
+ PERL_ARGS_ASSERT_SV_DOES;
+ return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP), 0);
+}
+
+/*
+=for apidoc sv_does_pv
+
+Like L</sv_does_sv>, but takes a nul-terminated string instead of an SV.
+
+=cut
+*/
+
+
+bool
+Perl_sv_does_pv(pTHX_ SV *sv, const char *const name, U32 flags)
+{
+ PERL_ARGS_ASSERT_SV_DOES_PV;
+ return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP | flags), flags);
+}
+
+/*
+=for apidoc sv_does_pvn
+
+Like L</sv_does_sv>, but takes a string/length pair instead of an SV.
+
+=cut
+*/
+
+bool
+Perl_sv_does_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
+{
+ PERL_ARGS_ASSERT_SV_DOES_PVN;
+
+ return sv_does_sv(sv, newSVpvn_flags(name, len, flags | SVs_TEMP), flags);
+}
+
+/*
=for apidoc croak_xs_usage
A specialised variant of C<croak()> for emitting the usage message for xsubs
@@ -190,13 +292,13 @@
works out the package name and subroutine name from C<cv>, and then calls
C<croak()>. Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as:
- Perl_croak(aTHX_ "Usage: %s::%s(%s)", "ouch" "awk", "eee_yow");
+ Perl_croak(aTHX_ "Usage: %"SVf"::%"SVf"(%s)", "ouch" "awk", "eee_yow");
=cut
*/
void
-Perl_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
+Perl_croak_xs_usage(const CV *const cv, const char *const params)
{
const GV *const gv = CvGV(cv);
@@ -203,17 +305,19 @@
PERL_ARGS_ASSERT_CROAK_XS_USAGE;
if (gv) {
- const char *const gvname = GvNAME(gv);
const HV *const stash = GvSTASH(gv);
- const char *const hvname = stash ? HvNAME_get(stash) : NULL;
- if (hvname)
- Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
+ if (HvNAME_get(stash))
+ Perl_croak_nocontext("Usage: %"HEKf"::%"HEKf"(%s)",
+ HEKfARG(HvNAME_HEK(stash)),
+ HEKfARG(GvNAME_HEK(gv)),
+ params);
else
- Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
+ Perl_croak_nocontext("Usage: %"HEKf"(%s)",
+ HEKfARG(GvNAME_HEK(gv)), 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);
}
}
@@ -226,17 +330,13 @@
croak_xs_usage(cv, "reference, kind");
else {
SV * const sv = ST(0);
- const char *name;
SvGETMAGIC(sv);
- if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
- || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
+ if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
XSRETURN_UNDEF;
- name = SvPV_nolen_const(ST(1));
-
- ST(0) = boolSV(sv_derived_from(sv, name));
+ ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0));
XSRETURN(1);
}
}
@@ -246,7 +346,6 @@
dVAR;
dXSARGS;
SV *sv;
- const char *name;
SV *rv;
HV *pkg = NULL;
@@ -257,11 +356,10 @@
SvGETMAGIC(sv);
- if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
- || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
+ if (!SvOK(sv) || !(SvROK(sv) || SvNIOK(sv) || (SvPOK(sv) && SvCUR(sv))
+ ))
XSRETURN_UNDEF;
- name = SvPV_nolen_const(ST(1));
rv = &PL_sv_undef;
if (SvROK(sv)) {
@@ -271,10 +369,12 @@
}
else {
pkg = gv_stashsv(sv, 0);
+ if (!pkg)
+ pkg = gv_stashpv("UNIVERSAL", 0);
}
if (pkg) {
- GV * const gv = gv_fetchmethod_autoload(pkg, name, FALSE);
+ GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0);
if (gv && isGV(gv))
rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
}
@@ -290,13 +390,10 @@
PERL_UNUSED_ARG(cv);
if (items != 2)
- Perl_croak(aTHX_ "Usage: invocand->DOES(kind)");
+ Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
else {
SV * const sv = ST(0);
- const char *name;
-
- name = SvPV_nolen_const(ST(1));
- if (sv_does( sv, name ))
+ if (sv_does_sv( sv, ST(1), 0 ))
XSRETURN_YES;
XSRETURN_NO;
@@ -330,8 +427,9 @@
SV * const nsv = sv_newmortal();
sv_setsv(nsv, sv);
sv = nsv;
- if ( !sv_derived_from(sv, "version"))
+ if ( !sv_isobject(sv) || !sv_derived_from(sv, "version"))
upg_version(sv, FALSE);
+
undef = NULL;
}
else {
@@ -344,18 +442,19 @@
if (undef) {
if (pkg) {
- const char * const name = HvNAME_get(pkg);
+ const HEK * const name = HvNAME_HEK(pkg);
Perl_croak(aTHX_
- "%s does not define $%s::VERSION--version check failed",
- name, name);
+ "%"HEKf" does not define $%"HEKf
+ "::VERSION--version check failed",
+ HEKfARG(name), HEKfARG(name));
} else {
Perl_croak(aTHX_
- "%s defines neither package nor VERSION--version check failed",
- SvPVx_nolen_const(ST(0)) );
+ "%"SVf" defines neither package nor VERSION--version check failed",
+ SVfARG(ST(0)) );
}
}
- if ( !sv_derived_from(req, "version")) {
+ if ( !sv_isobject(req) || !sv_derived_from(req, "version")) {
/* req may very well be R/O, so create a new object */
req = sv_2mortal( new_version(req) );
}
@@ -362,13 +461,15 @@
if ( vcmp( req, sv ) > 0 ) {
if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
- Perl_croak(aTHX_ "%s version %"SVf" required--"
- "this is only version %"SVf"", HvNAME_get(pkg),
+ Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
+ "this is only version %"SVf"",
+ HEKfARG(HvNAME_HEK(pkg)),
SVfARG(sv_2mortal(vnormal(req))),
SVfARG(sv_2mortal(vnormal(sv))));
} else {
- Perl_croak(aTHX_ "%s version %"SVf" required--"
- "this is only version %"SVf"", HvNAME_get(pkg),
+ Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
+ "this is only version %"SVf,
+ HEKfARG(HvNAME_HEK(pkg)),
SVfARG(sv_2mortal(vstringify(req))),
SVfARG(sv_2mortal(vstringify(sv))));
}
@@ -389,16 +490,25 @@
{
dVAR;
dXSARGS;
- if (items > 3)
+ if (items > 3 || items < 1)
croak_xs_usage(cv, "class, version");
SP -= items;
{
SV *vs = ST(1);
SV *rv;
- const char * const classname =
- sv_isobject(ST(0)) /* get the class if called as an object method */
- ? HvNAME(SvSTASH(SvRV(ST(0))))
- : (char *)SvPV_nolen(ST(0));
+ STRLEN len;
+ const char *classname;
+ U32 flags;
+ if ( sv_isobject(ST(0)) ) { /* get the class if called as an object method */
+ const HV * stash = SvSTASH(SvRV(ST(0)));
+ classname = HvNAME(stash);
+ len = HvNAMELEN(stash);
+ flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
+ }
+ else {
+ classname = SvPV(ST(0), len);
+ flags = SvUTF8(ST(0));
+ }
if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
/* create empty object */
@@ -411,8 +521,8 @@
}
rv = new_version(vs);
- if ( strcmp(classname,"version") != 0 ) /* inherited new() */
- sv_bless(rv, gv_stashpv(classname, GV_ADD));
+ if ( strnNE(classname,"version", len) ) /* inherited new() */
+ sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
mPUSHs(rv);
PUTBACK;
@@ -430,7 +540,7 @@
{
SV * lobj = ST(0);
- if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
+ if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
lobj = SvRV(lobj);
}
else
@@ -453,7 +563,7 @@
{
SV * lobj = ST(0);
- if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
+ if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
lobj = SvRV(lobj);
}
else
@@ -476,7 +586,7 @@
{
SV * lobj = ST(0);
- if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
+ if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
lobj = SvRV(lobj);
}
else
@@ -499,7 +609,7 @@
{
SV * lobj = ST(0);
- if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
+ if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
lobj = SvRV(lobj);
}
else
@@ -511,7 +621,7 @@
SV * robj = ST(1);
const IV swap = (IV)SvIV(ST(2));
- if ( ! sv_derived_from(robj, "version") )
+ if ( !sv_isobject(robj) || !sv_derived_from(robj, "version") )
{
robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
sv_2mortal(robj);
@@ -542,9 +652,15 @@
if (items < 1)
croak_xs_usage(cv, "lobj, ...");
SP -= items;
- if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
+ if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
SV * const lobj = SvRV(ST(0));
- SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
+ SV * const rs =
+ newSViv( vcmp(lobj,
+ sv_2mortal(new_version(
+ sv_2mortal(newSVpvs("0"))
+ ))
+ )
+ );
mPUSHs(rs);
PUTBACK;
return;
@@ -559,7 +675,7 @@
dXSARGS;
if (items < 1)
croak_xs_usage(cv, "lobj, ...");
- if (sv_derived_from(ST(0), "version") && SvROK(ST(0)))
+ if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version"))
Perl_croak(aTHX_ "operation not supported with version object");
else
Perl_croak(aTHX_ "lobj is not of type version");
@@ -575,7 +691,7 @@
if (items != 1)
croak_xs_usage(cv, "lobj");
SP -= items;
- if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
+ if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
SV * const lobj = ST(0);
if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
XSRETURN_YES;
@@ -597,15 +713,22 @@
{
SV * ver = ST(0);
SV * rv;
- const char * classname = "";
- if ( items == 2 && SvOK(ST(1)) ) {
- /* getting called as object or class method */
- ver = ST(1);
- classname =
- sv_isobject(ST(0)) /* class called as an object method */
- ? HvNAME_get(SvSTASH(SvRV(ST(0))))
- : (char *)SvPV_nolen(ST(0));
- }
+ STRLEN len = 0;
+ const char * classname = "";
+ U32 flags = 0;
+ if ( items == 2 && SvOK(ST(1)) ) {
+ ver = ST(1);
+ if ( sv_isobject(ST(0)) ) { /* class called as an object method */
+ const HV * stash = SvSTASH(SvRV(ST(0)));
+ classname = HvNAME(stash);
+ len = HvNAMELEN(stash);
+ flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
+ }
+ else {
+ classname = SvPV(ST(0), len);
+ flags = SvUTF8(ST(0));
+ }
+ }
if ( !SvVOK(ver) ) { /* not already a v-string */
rv = sv_newmortal();
sv_setsv(rv,ver); /* make a duplicate */
@@ -613,9 +736,10 @@
} else {
rv = sv_2mortal(new_version(ver));
}
- if ( items == 2 && strcmp(classname,"version") ) { /* inherited new() */
- sv_bless(rv, gv_stashpv(classname, GV_ADD));
- }
+ if ( items == 2
+ && strnNE(classname,"version", len) ) { /* inherited new() */
+ sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
+ }
PUSHs(rv);
}
PUTBACK;
@@ -629,7 +753,7 @@
if (items != 1)
croak_xs_usage(cv, "lobj");
SP -= items;
- if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
+ if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
SV * const lobj = ST(0);
if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
XSRETURN_YES;
@@ -684,6 +808,7 @@
if (items != 1)
croak_xs_usage(cv, "sv");
sv_utf8_encode(ST(0));
+ SvSETMAGIC(ST(0));
XSRETURN_EMPTY;
}
@@ -696,10 +821,10 @@
else {
SV * const sv = ST(0);
bool RETVAL;
- if (SvIsCOW(sv)) sv_force_normal(sv);
+ SvPV_force_nolen(sv);
RETVAL = sv_utf8_decode(sv);
+ SvSETMAGIC(sv);
ST(0) = boolSV(RETVAL);
- sv_2mortal(ST(0));
}
XSRETURN(1);
}
@@ -733,7 +858,6 @@
const bool RETVAL = sv_utf8_downgrade(sv, failok);
ST(0) = boolSV(RETVAL);
- sv_2mortal(ST(0));
}
XSRETURN(1);
}
@@ -779,7 +903,7 @@
sv = SvRV(svz);
if (items == 1) {
- if (SvREADONLY(sv))
+ if (SvREADONLY(sv) && !SvIsCOW(sv))
XSRETURN_YES;
else
XSRETURN_NO;
@@ -786,18 +910,18 @@
}
else if (items == 2) {
if (SvTRUE(ST(1))) {
+ if (SvIsCOW(sv)) sv_force_normal(sv);
SvREADONLY_on(sv);
XSRETURN_YES;
}
else {
/* I hope you really know what you are doing. */
- SvREADONLY_off(sv);
+ if (!SvIsCOW(sv)) SvREADONLY_off(sv);
XSRETURN_NO;
}
}
XSRETURN_UNDEF; /* Can't happen. */
}
-
XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
{
dVAR;
@@ -804,22 +928,23 @@
dXSARGS;
SV * const svz = ST(0);
SV * sv;
+ U32 refcnt;
PERL_UNUSED_ARG(cv);
/* [perl #77776] - called as &foo() not foo() */
- if (!SvROK(svz))
+ if ((items != 1 && items != 2) || !SvROK(svz))
croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
sv = SvRV(svz);
- if (items == 1)
- XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
- else if (items == 2) {
/* I hope you really know what you are doing. */
- SvREFCNT(sv) = SvIV(ST(1));
- XSRETURN_IV(SvREFCNT(sv));
- }
- XSRETURN_UNDEF; /* Can't happen. */
+ /* idea is for SvREFCNT(sv) to be accessed only once */
+ refcnt = items == 2 ?
+ /* we free one ref on exit */
+ (SvREFCNT(sv) = SvUV(ST(1)) + 1)
+ : SvREFCNT(sv);
+ XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */
+
}
XS(XS_Internals_hv_clear_placehold)
@@ -889,14 +1014,10 @@
}
sv = POPs;
- gv = MUTABLE_GV(sv);
+ gv = MAYBE_DEREF_GV(sv);
- if (!isGV(sv)) {
- if (SvROK(sv) && isGV(SvRV(sv)))
- gv = MUTABLE_GV(SvRV(sv));
- else if (SvPOKp(sv))
- gv = gv_fetchsv(sv, 0, SVt_PVIO);
- }
+ if (!gv && !SvROK(sv))
+ gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
if (gv && (io = GvIO(gv))) {
AV* const av = PerlIO_get_layers(aTHX_ input ?
@@ -914,21 +1035,22 @@
const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
+ EXTEND(SP, 3); /* Three is the max in all branches: better check just once */
if (details) {
/* Indents of 5? Yuck. */
/* We know that PerlIO_get_layers creates a new SV for
the name and flags, so we can just take a reference
and "steal" it when we free the AV below. */
- XPUSHs(namok
+ PUSHs(namok
? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
: &PL_sv_undef);
- XPUSHs(argok
+ PUSHs(argok
? newSVpvn_flags(SvPVX_const(*argsvp),
SvCUR(*argsvp),
(SvUTF8(*argsvp) ? SVf_UTF8 : 0)
| SVs_TEMP)
: &PL_sv_undef);
- XPUSHs(flgok
+ PUSHs(flgok
? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
: &PL_sv_undef);
nitem += 3;
@@ -935,19 +1057,19 @@
}
else {
if (namok && argok)
- XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
+ PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
SVfARG(*namsvp),
SVfARG(*argsvp))));
else if (namok)
- XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
+ PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
else
- XPUSHs(&PL_sv_undef);
+ PUSHs(&PL_sv_undef);
nitem++;
if (flgok) {
const IV flags = SvIVX(*flgsvp);
if (flags & PERLIO_F_UTF8) {
- XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
+ PUSHs(newSVpvs_flags("utf8", SVs_TEMP));
nitem++;
}
}
@@ -964,45 +1086,7 @@
XSRETURN(0);
}
-XS(XS_Internals_hash_seed)
-{
- dVAR;
- /* Using dXSARGS would also have dITEM and dSP,
- * which define 2 unused local variables. */
- dAXMARK;
- PERL_UNUSED_ARG(cv);
- PERL_UNUSED_VAR(mark);
- XSRETURN_UV(PERL_HASH_SEED);
-}
-XS(XS_Internals_rehash_seed)
-{
- dVAR;
- /* Using dXSARGS would also have dITEM and dSP,
- * which define 2 unused local variables. */
- dAXMARK;
- PERL_UNUSED_ARG(cv);
- PERL_UNUSED_VAR(mark);
- XSRETURN_UV(PL_rehash_seed);
-}
-
-XS(XS_Internals_HvREHASH) /* Subject to change */
-{
- dVAR;
- dXSARGS;
- PERL_UNUSED_ARG(cv);
- if (SvROK(ST(0))) {
- const HV * const hv = (const HV *) SvRV(ST(0));
- if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
- if (HvREHASH(hv))
- XSRETURN_YES;
- else
- XSRETURN_NO;
- }
- }
- Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
-}
-
XS(XS_re_is_regexp)
{
dVAR;
@@ -1113,6 +1197,7 @@
av = MUTABLE_AV(SvRV(ret));
length = av_len(av);
+ EXTEND(SP, length+1); /* better extend stack just once */
for (i = 0; i <= length; i++) {
entry = av_fetch(av, i, FALSE);
@@ -1119,7 +1204,7 @@
if (!entry)
Perl_croak(aTHX_ "NULL array element in re::regnames()");
- mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
+ mPUSHs(SvREFCNT_inc_simple_NN(*entry));
}
SvREFCNT_dec(ret);
@@ -1134,11 +1219,11 @@
dXSARGS;
REGEXP *re;
+ EXTEND(SP, 2);
+ SP -= items;
if (items != 1)
croak_xs_usage(cv, "sv");
- SP -= items;
-
/*
Checks if a reference is a regex or not. If the parameter is
not a ref, or is not the result of a qr// then returns false
@@ -1190,8 +1275,8 @@
(RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
/* return the pattern and the modifiers */
- XPUSHs(pattern);
- XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
+ PUSHs(pattern);
+ PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
XSRETURN(2);
} else {
/* Scalar, so use the string that Perl would return */
@@ -1202,7 +1287,7 @@
pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
(RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
#endif
- XPUSHs(pattern);
+ PUSHs(pattern);
XSRETURN(1);
}
} else {
@@ -1234,7 +1319,7 @@
const char *proto;
};
-struct xsub_details details[] = {
+const struct xsub_details details[] = {
{"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
{"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
{"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
@@ -1252,6 +1337,15 @@
{"version::vcmp", XS_version_vcmp, NULL},
{"version::(bool", XS_version_boolean, NULL},
{"version::boolean", XS_version_boolean, NULL},
+ {"version::(+", XS_version_noop, NULL},
+ {"version::(-", XS_version_noop, NULL},
+ {"version::(*", XS_version_noop, NULL},
+ {"version::(/", XS_version_noop, NULL},
+ {"version::(+=", XS_version_noop, NULL},
+ {"version::(-=", XS_version_noop, NULL},
+ {"version::(*=", XS_version_noop, NULL},
+ {"version::(/=", XS_version_noop, NULL},
+ {"version::(abs", XS_version_noop, NULL},
{"version::(nomethod", XS_version_noop, NULL},
{"version::noop", XS_version_noop, NULL},
{"version::is_alpha", XS_version_is_alpha, NULL},
@@ -1270,9 +1364,6 @@
{"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
{"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
{"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
- {"Internals::hash_seed", XS_Internals_hash_seed, ""},
- {"Internals::rehash_seed", XS_Internals_rehash_seed, ""},
- {"Internals::HvREHASH", XS_Internals_HvREHASH, "\\%"},
{"re::is_regexp", XS_re_is_regexp, "$"},
{"re::regname", XS_re_regname, ";$$"},
{"re::regnames", XS_re_regnames, ";$"},
@@ -1285,7 +1376,7 @@
{
dVAR;
static const char file[] = __FILE__;
- struct xsub_details *xsub = details;
+ const struct xsub_details *xsub = details;
const struct xsub_details *end
= details + sizeof(details) / sizeof(details[0]);
@@ -1293,12 +1384,14 @@
newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
} while (++xsub < end);
- /* register the overloading (type 'A') magic */
- PL_amagic_generation++;
-
/* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
- CvFILE(newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL))
- = (char *)file;
+ {
+ CV * const cv =
+ newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
+ Safefree(CvFILE(cv));
+ CvFILE(cv) = (char *)file;
+ CvDYNFILE_off(cv);
+ }
}
/*
@@ -1305,8 +1398,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/universal.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.4
\ No newline at end of property
Modified: trunk/contrib/perl/unixish.h
===================================================================
--- trunk/contrib/perl/unixish.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/unixish.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -133,7 +133,8 @@
#ifndef PERL_SYS_TERM_BODY
# define PERL_SYS_TERM_BODY() \
- HINTS_REFCNT_TERM; OP_REFCNT_TERM; PERLIO_TERM; MALLOC_TERM;
+ HINTS_REFCNT_TERM; OP_CHECK_MUTEX_TERM; \
+ OP_REFCNT_TERM; PERLIO_TERM; MALLOC_TERM;
#endif
@@ -149,8 +150,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/unixish.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/utf8.c
===================================================================
--- trunk/contrib/perl/utf8.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/utf8.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -13,12 +13,12 @@
* heard of that we don't want to see any closer; and that's the one place
* we're trying to get to! And that's just where we can't get, nohow.'
*
- * [p.603 of _The Lord of the Rings_, IV/I: "The Taming of Sm\xE9agol"]
+ * [p.603 of _The Lord of the Rings_, IV/I: "The Taming of Sméagol"]
*
* 'Well do I understand your speech,' he answered in the same language;
* 'yet few strangers do so. Why then do you not speak in the Common Tongue,
* as is the custom in the West, if you wish to be answered?'
- * --Gandalf, addressing Th\xE9oden's door wardens
+ * --Gandalf, addressing Théoden's door wardens
*
* [p.508 of _The Lord of the Rings_, III/vi: "The King of the Golden Hall"]
*
@@ -31,11 +31,13 @@
#include "EXTERN.h"
#define PERL_IN_UTF8_C
#include "perl.h"
+#include "inline_invlist.c"
#ifndef EBCDIC
/* Separate prototypes needed because in ASCII systems these are
* usually macros but they still are compiled as code, too. */
PERL_CALLCONV UV Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags);
+PERL_CALLCONV UV Perl_valid_utf8_to_uvchr(pTHX_ const U8 *s, STRLEN *retlen);
PERL_CALLCONV U8* Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv);
#endif
@@ -57,7 +59,7 @@
/*
=for apidoc is_ascii_string
-Returns true if the first C<len> bytes of the given string are the same whether
+Returns true if the first C<len> bytes of the string C<s> are the same whether
or not the string is encoded in UTF-8 (or UTF-EBCDIC on EBCDIC machines). That
is, if they are invariant. On ASCII-ish machines, only ASCII characters
fit this definition, hence the function's name.
@@ -64,7 +66,7 @@
If C<len> is 0, it will be calculated using C<strlen(s)>.
-See also is_utf8_string(), is_utf8_string_loclen(), and is_utf8_string_loc().
+See also L</is_utf8_string>(), L</is_utf8_string_loclen>(), and L</is_utf8_string_loc>().
=cut
*/
@@ -88,7 +90,7 @@
/*
=for apidoc uvuni_to_utf8_flags
-Adds the UTF-8 representation of the code point C<uv> to the end
+Adds the UTF-8 representation of the Unicode code point C<uv> to the end
of the string C<d>; C<d> should have at least C<UTF8_MAXBYTES+1> free
bytes available. The return value is the pointer to the byte after the
end of the new character. In other words,
@@ -107,9 +109,14 @@
*(d++) = uv;
+where uv is a code point expressed in Latin-1 or above, not the platform's
+native character set. B<Almost all code should instead use L</uvchr_to_utf8>
+or L</uvchr_to_utf8_flags>>.
+
This function will convert to UTF-8 (and not warn) even code points that aren't
legal Unicode or are problematic, unless C<flags> contains one or more of the
-following flags.
+following flags:
+
If C<uv> is a Unicode surrogate code point and UNICODE_WARN_SURROGATE is set,
the function will raise a warning, provided UTF8 warnings are enabled. If instead
UNICODE_DISALLOW_SURROGATE is set, the function will fail and return NULL.
@@ -116,8 +123,9 @@
If both flags are set, the function will both warn and return NULL.
The UNICODE_WARN_NONCHAR and UNICODE_DISALLOW_NONCHAR flags correspondingly
-affect how the function handles a Unicode non-character. And, likewise for the
-UNICODE_WARN_SUPER and UNICODE_DISALLOW_SUPER flags, and code points that are
+affect how the function handles a Unicode non-character. And likewise, the
+UNICODE_WARN_SUPER and UNICODE_DISALLOW_SUPER flags, affect the handling of
+code points that are
above the Unicode maximum of 0x10FFFF. Code points above 0x7FFF_FFFF (which are
even less portable) can be warned and/or disallowed even if other above-Unicode
code points are accepted by the UNICODE_WARN_FE_FF and UNICODE_DISALLOW_FE_FF
@@ -136,7 +144,10 @@
{
PERL_ARGS_ASSERT_UVUNI_TO_UTF8_FLAGS;
- if (ckWARN_d(WARN_UTF8)) {
+ /* The first problematic code point is the first surrogate */
+ if (uv >= UNICODE_SURROGATE_FIRST
+ && ckWARN4_d(WARN_UTF8, WARN_SURROGATE, WARN_NON_UNICODE, WARN_NONCHAR))
+ {
if (UNICODE_IS_SURROGATE(uv)) {
if (flags & UNICODE_WARN_SURROGATE) {
Perl_ck_warner_d(aTHX_ packWARN(WARN_SURROGATE),
@@ -252,14 +263,14 @@
return d;
}
#endif
-#endif /* Loop style */
+#endif /* Non loop style */
}
/*
-Tests if some arbitrary number of bytes begins in a valid UTF-8
+Tests if the first C<len> bytes of string C<s> form a valid UTF-8
character. Note that an INVARIANT (i.e. ASCII) character is a valid
-UTF-8 character. The actual number of bytes in the UTF-8 character
+UTF-8 character. The number of bytes in the UTF-8 character
will be returned if it is valid, otherwise 0.
This is the "slow" version as opposed to the "fast" version which is
@@ -269,72 +280,84 @@
you should use the _slow(). In practice this means that the _slow()
will be used very rarely, since the maximum Unicode code point (as of
Unicode 4.1) is U+10FFFF, which encodes in UTF-8 to four bytes. Only
-the "Perl extended UTF-8" (the infamous 'v-strings') will encode into
+the "Perl extended UTF-8" (e.g, the infamous 'v-strings') will encode into
five bytes or more.
=cut */
-STATIC STRLEN
+PERL_STATIC_INLINE STRLEN
S_is_utf8_char_slow(const U8 *s, const STRLEN len)
{
- U8 u = *s;
- STRLEN slen;
- UV uv, ouv;
+ dTHX; /* The function called below requires thread context */
+ STRLEN actual_len;
+
PERL_ARGS_ASSERT_IS_UTF8_CHAR_SLOW;
- if (UTF8_IS_INVARIANT(u))
- return 1;
+ utf8n_to_uvuni(s, len, &actual_len, UTF8_CHECK_ONLY);
- if (!UTF8_IS_START(u))
- return 0;
+ return (actual_len == (STRLEN) -1) ? 0 : actual_len;
+}
- if (len < 2 || !UTF8_IS_CONTINUATION(s[1]))
+/*
+=for apidoc is_utf8_char_buf
+
+Returns the number of bytes that comprise the first UTF-8 encoded character in
+buffer C<buf>. C<buf_end> should point to one position beyond the end of the
+buffer. 0 is returned if C<buf> does not point to a complete, valid UTF-8
+encoded character.
+
+Note that an INVARIANT character (i.e. ASCII on non-EBCDIC
+machines) is a valid UTF-8 character.
+
+=cut */
+
+STRLEN
+Perl_is_utf8_char_buf(const U8 *buf, const U8* buf_end)
+{
+
+ STRLEN len;
+
+ PERL_ARGS_ASSERT_IS_UTF8_CHAR_BUF;
+
+ if (buf_end <= buf) {
return 0;
+ }
- slen = len - 1;
- s++;
-#ifdef EBCDIC
- u = NATIVE_TO_UTF(u);
-#endif
- u &= UTF_START_MASK(len);
- uv = u;
- ouv = uv;
- while (slen--) {
- if (!UTF8_IS_CONTINUATION(*s))
- return 0;
- uv = UTF8_ACCUMULATE(uv, *s);
- if (uv < ouv)
- return 0;
- ouv = uv;
- s++;
+ len = buf_end - buf;
+ if (len > UTF8SKIP(buf)) {
+ len = UTF8SKIP(buf);
}
- if ((STRLEN)UNISKIP(uv) < len)
- return 0;
-
- return len;
+#ifdef IS_UTF8_CHAR
+ if (IS_UTF8_CHAR_FAST(len))
+ return IS_UTF8_CHAR(buf, len) ? len : 0;
+#endif /* #ifdef IS_UTF8_CHAR */
+ return is_utf8_char_slow(buf, len);
}
/*
=for apidoc is_utf8_char
+DEPRECATED!
+
Tests if some arbitrary number of bytes begins in a valid UTF-8
character. Note that an INVARIANT (i.e. ASCII on non-EBCDIC machines)
character is a valid UTF-8 character. The actual number of bytes in the UTF-8
character will be returned if it is valid, otherwise 0.
+This function is deprecated due to the possibility that malformed input could
+cause reading beyond the end of the input buffer. Use L</is_utf8_char_buf>
+instead.
+
=cut */
+
STRLEN
Perl_is_utf8_char(const U8 *s)
{
- const STRLEN len = UTF8SKIP(s);
+ PERL_ARGS_ASSERT_IS_UTF8_CHAR;
- PERL_ARGS_ASSERT_IS_UTF8_CHAR;
-#ifdef IS_UTF8_CHAR
- if (IS_UTF8_CHAR_FAST(len))
- return IS_UTF8_CHAR(s, len) ? len : 0;
-#endif /* #ifdef IS_UTF8_CHAR */
- return is_utf8_char_slow(s, len);
+ /* Assumes we have enough space, which is why this is deprecated */
+ return is_utf8_char_buf(s, s + UTF8SKIP(s));
}
@@ -341,13 +364,13 @@
/*
=for apidoc is_utf8_string
-Returns true if first C<len> bytes of the given string form a valid
+Returns true if the first C<len> bytes of string C<s> form a valid
UTF-8 string, false otherwise. If C<len> is 0, it will be calculated
-using C<strlen(s)>. Note that 'a valid UTF-8 string' does not mean 'a
-string that contains code points above 0x7F encoded in UTF-8' because a
-valid ASCII string is a valid UTF-8 string.
+using C<strlen(s)> (which means if you use this option, that C<s> has to have a
+terminating NUL byte). Note that all characters being ASCII constitute 'a
+valid UTF-8 string'.
-See also is_ascii_string(), is_utf8_string_loclen(), and is_utf8_string_loc().
+See also L</is_ascii_string>(), L</is_utf8_string_loclen>(), and L</is_utf8_string_loc>().
=cut
*/
@@ -361,35 +384,30 @@
PERL_ARGS_ASSERT_IS_UTF8_STRING;
while (x < send) {
- STRLEN c;
/* Inline the easy bits of is_utf8_char() here for speed... */
- if (UTF8_IS_INVARIANT(*x))
- c = 1;
- else if (!UTF8_IS_START(*x))
- goto out;
+ if (UTF8_IS_INVARIANT(*x)) {
+ x++;
+ }
else {
/* ... and call is_utf8_char() only if really needed. */
-#ifdef IS_UTF8_CHAR
- c = UTF8SKIP(x);
+ const STRLEN c = UTF8SKIP(x);
+ const U8* const next_char_ptr = x + c;
+
+ if (next_char_ptr > send) {
+ return FALSE;
+ }
+
if (IS_UTF8_CHAR_FAST(c)) {
if (!IS_UTF8_CHAR(x, c))
- c = 0;
+ return FALSE;
}
- else
- c = is_utf8_char_slow(x, c);
-#else
- c = is_utf8_char(x);
-#endif /* #ifdef IS_UTF8_CHAR */
- if (!c)
- goto out;
+ else if (! is_utf8_char_slow(x, c)) {
+ return FALSE;
+ }
+ x = next_char_ptr;
}
- x += c;
}
- out:
- if (x != send)
- return FALSE;
-
return TRUE;
}
@@ -398,20 +416,20 @@
=for apidoc is_utf8_string_loc
-Like is_utf8_string() but stores the location of the failure (in the
-case of "utf8ness failure") or the location s+len (in the case of
+Like L</is_utf8_string> but stores the location of the failure (in the
+case of "utf8ness failure") or the location C<s>+C<len> (in the case of
"utf8ness success") in the C<ep>.
-See also is_utf8_string_loclen() and is_utf8_string().
+See also L</is_utf8_string_loclen>() and L</is_utf8_string>().
=for apidoc is_utf8_string_loclen
-Like is_utf8_string() but stores the location of the failure (in the
-case of "utf8ness failure") or the location s+len (in the case of
+Like L</is_utf8_string>() but stores the location of the failure (in the
+case of "utf8ness failure") or the location C<s>+C<len> (in the case of
"utf8ness success") in the C<ep>, and the number of UTF-8
encoded characters in the C<el>.
-See also is_utf8_string_loc() and is_utf8_string().
+See also L</is_utf8_string_loc>() and L</is_utf8_string>().
=cut
*/
@@ -427,27 +445,27 @@
PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
while (x < send) {
+ const U8* next_char_ptr;
+
/* Inline the easy bits of is_utf8_char() here for speed... */
if (UTF8_IS_INVARIANT(*x))
- c = 1;
- else if (!UTF8_IS_START(*x))
- goto out;
+ next_char_ptr = x + 1;
else {
/* ... and call is_utf8_char() only if really needed. */
-#ifdef IS_UTF8_CHAR
c = UTF8SKIP(x);
+ next_char_ptr = c + x;
+ if (next_char_ptr > send) {
+ goto out;
+ }
if (IS_UTF8_CHAR_FAST(c)) {
if (!IS_UTF8_CHAR(x, c))
c = 0;
} else
c = is_utf8_char_slow(x, c);
-#else
- c = is_utf8_char(x);
-#endif /* #ifdef IS_UTF8_CHAR */
if (!c)
goto out;
}
- x += c;
+ x = next_char_ptr;
outlen++;
}
@@ -465,16 +483,16 @@
=for apidoc utf8n_to_uvuni
Bottom level UTF-8 decode routine.
-Returns the code point value of the first character in the string C<s>
-which is assumed to be in UTF-8 (or UTF-EBCDIC) encoding and no longer than
-C<curlen> bytes; C<retlen> will be set to the length, in bytes, of that
-character.
+Returns the code point value of the first character in the string C<s>,
+which is assumed to be in UTF-8 (or UTF-EBCDIC) encoding, and no longer than
+C<curlen> bytes; C<*retlen> (if C<retlen> isn't NULL) will be set to
+the length, in bytes, of that character.
The value of C<flags> determines the behavior when C<s> does not point to a
well-formed UTF-8 character. If C<flags> is 0, when a malformation is found,
-C<retlen> is set to the expected length of the UTF-8 character in bytes, zero
-is returned, and if UTF-8 warnings haven't been lexically disabled, a warning
-is raised.
+zero is returned and C<*retlen> is set so that (S<C<s> + C<*retlen>>) is the
+next possible position in C<s> that could begin a non-malformed character.
+Also, if UTF-8 warnings haven't been lexically disabled, a warning is raised.
Various ALLOW flags can be set in C<flags> to allow (and not warn on)
individual types of malformations, such as the sequence being overlong (that
@@ -482,18 +500,26 @@
overlong sequences are expressly forbidden in the UTF-8 standard due to
potential security issues). Another malformation example is the first byte of
a character not being a legal first byte. See F<utf8.h> for the list of such
-flags. Of course, the value returned by this function under such conditions is
-not reliable.
+flags. For allowed 0 length strings, this function returns 0; for allowed
+overlong sequences, the computed code point is returned; for all other allowed
+malformations, the Unicode REPLACEMENT CHARACTER is returned, as these have no
+determinable reasonable value.
The UTF8_CHECK_ONLY flag overrides the behavior when a non-allowed (by other
flags) malformation is found. If this flag is set, the routine assumes that
the caller will raise a warning, and this function will silently just set
-C<retlen> to C<-1> and return zero.
+C<retlen> to C<-1> (cast to C<STRLEN>) and return zero.
+Note that this API requires disambiguation between successful decoding a NUL
+character, and an error return (unless the UTF8_CHECK_ONLY flag is set), as
+in both cases, 0 is returned. To disambiguate, upon a zero return, see if the
+first byte of C<s> is 0 as well. If so, the input was a NUL; if not, the input
+had an error.
+
Certain code points are considered problematic. These are Unicode surrogates,
-Unicode non-characters, and code points above the Unicode maximum of 0x10FFF.
+Unicode non-characters, and code points above the Unicode maximum of 0x10FFFF.
By default these are considered regular code points, but certain situations
-warrant special handling for them. if C<flags> contains
+warrant special handling for them. If C<flags> contains
UTF8_DISALLOW_ILLEGAL_INTERCHANGE, all three classes are treated as
malformations and handled as such. The flags UTF8_DISALLOW_SURROGATE,
UTF8_DISALLOW_NONCHAR, and UTF8_DISALLOW_SUPER (meaning above the legal Unicode
@@ -509,20 +535,24 @@
Very large code points (above 0x7FFF_FFFF) are considered more problematic than
the others that are above the Unicode legal maximum. There are several
-reasons, one of which is that the original UTF-8 specification never went above
-this number (the current 0x10FFF limit was imposed later). The UTF-8 encoding
-on ASCII platforms for these large code point begins with a byte containing
-0xFE or 0xFF. The UTF8_DISALLOW_FE_FF flag will cause them to be treated as
-malformations, while allowing smaller above-Unicode code points. (Of course
-UTF8_DISALLOW_SUPER will treat all above-Unicode code points, including these,
-as malformations.) Similarly, UTF8_WARN_FE_FF acts just like the other WARN
-flags, but applies just to these code points.
+reasons: they requre at least 32 bits to represent them on ASCII platforms, are
+not representable at all on EBCDIC platforms, and the original UTF-8
+specification never went above this number (the current 0x10FFFF limit was
+imposed later). (The smaller ones, those that fit into 32 bits, are
+representable by a UV on ASCII platforms, but not by an IV, which means that
+the number of operations that can be performed on them is quite restricted.)
+The UTF-8 encoding on ASCII platforms for these large code points begins with a
+byte containing 0xFE or 0xFF. The UTF8_DISALLOW_FE_FF flag will cause them to
+be treated as malformations, while allowing smaller above-Unicode code points.
+(Of course UTF8_DISALLOW_SUPER will treat all above-Unicode code points,
+including these, as malformations.) Similarly, UTF8_WARN_FE_FF acts just like
+the other WARN flags, but applies just to these code points.
All other code points corresponding to Unicode characters, including private
use and those yet to be assigned, are never considered malformed and never
warn.
-Most code should use utf8_to_uvchr() rather than call this directly.
+Most code should use L</utf8_to_uvchr_buf>() rather than call this directly.
=cut
*/
@@ -532,148 +562,276 @@
{
dVAR;
const U8 * const s0 = s;
- UV uv = *s, ouv = 0;
- STRLEN len = 1;
- bool dowarn = ckWARN_d(WARN_UTF8);
- const UV startbyte = *s;
- STRLEN expectlen = 0;
- U32 warning = 0;
+ U8 overflow_byte = '\0'; /* Save byte in case of overflow */
+ U8 * send;
+ UV uv = *s;
+ STRLEN expectlen;
SV* sv = NULL;
+ UV outlier_ret = 0; /* return value when input is in error or problematic
+ */
+ UV pack_warn = 0; /* Save result of packWARN() for later */
+ bool unexpected_non_continuation = FALSE;
+ bool overflowed = FALSE;
+ bool do_overlong_test = TRUE; /* May have to skip this test */
+ const char* const malformed_text = "Malformed UTF-8 character";
+
PERL_ARGS_ASSERT_UTF8N_TO_UVUNI;
-/* This list is a superset of the UTF8_ALLOW_XXX. */
+ /* The order of malformation tests here is important. We should consume as
+ * few bytes as possible in order to not skip any valid character. This is
+ * required by the Unicode Standard (section 3.9 of Unicode 6.0); see also
+ * http://unicode.org/reports/tr36 for more discussion as to why. For
+ * example, once we've done a UTF8SKIP, we can tell the expected number of
+ * bytes, and could fail right off the bat if the input parameters indicate
+ * that there are too few available. But it could be that just that first
+ * byte is garbled, and the intended character occupies fewer bytes. If we
+ * blindly assumed that the first byte is correct, and skipped based on
+ * that number, we could skip over a valid input character. So instead, we
+ * always examine the sequence byte-by-byte.
+ *
+ * We also should not consume too few bytes, otherwise someone could inject
+ * things. For example, an input could be deliberately designed to
+ * overflow, and if this code bailed out immediately upon discovering that,
+ * returning to the caller *retlen pointing to the very next byte (one
+ * which is actually part of of the overflowing sequence), that could look
+ * legitimate to the caller, which could discard the initial partial
+ * sequence and process the rest, inappropriately */
-#define UTF8_WARN_EMPTY 1
-#define UTF8_WARN_CONTINUATION 2
-#define UTF8_WARN_NON_CONTINUATION 3
-#define UTF8_WARN_SHORT 4
-#define UTF8_WARN_OVERFLOW 5
-#define UTF8_WARN_LONG 6
+ /* Zero length strings, if allowed, of necessity are zero */
+ if (UNLIKELY(curlen == 0)) {
+ if (retlen) {
+ *retlen = 0;
+ }
- if (curlen == 0 &&
- !(flags & UTF8_ALLOW_EMPTY)) {
- warning = UTF8_WARN_EMPTY;
+ if (flags & UTF8_ALLOW_EMPTY) {
+ return 0;
+ }
+ if (! (flags & UTF8_CHECK_ONLY)) {
+ sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (empty string)", malformed_text));
+ }
goto malformed;
}
+ expectlen = UTF8SKIP(s);
+
+ /* A well-formed UTF-8 character, as the vast majority of calls to this
+ * function will be for, has this expected length. For efficiency, set
+ * things up here to return it. It will be overriden only in those rare
+ * cases where a malformation is found */
+ if (retlen) {
+ *retlen = expectlen;
+ }
+
+ /* An invariant is trivially well-formed */
if (UTF8_IS_INVARIANT(uv)) {
- if (retlen)
- *retlen = 1;
return (UV) (NATIVE_TO_UTF(*s));
}
- if (UTF8_IS_CONTINUATION(uv) &&
- !(flags & UTF8_ALLOW_CONTINUATION)) {
- warning = UTF8_WARN_CONTINUATION;
- goto malformed;
- }
+ /* A continuation character can't start a valid sequence */
+ if (UNLIKELY(UTF8_IS_CONTINUATION(uv))) {
+ if (flags & UTF8_ALLOW_CONTINUATION) {
+ if (retlen) {
+ *retlen = 1;
+ }
+ return UNICODE_REPLACEMENT;
+ }
- if (UTF8_IS_START(uv) && curlen > 1 && !UTF8_IS_CONTINUATION(s[1]) &&
- !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
- warning = UTF8_WARN_NON_CONTINUATION;
+ if (! (flags & UTF8_CHECK_ONLY)) {
+ sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (unexpected continuation byte 0x%02x, with no preceding start byte)", malformed_text, *s0));
+ }
+ curlen = 1;
goto malformed;
}
#ifdef EBCDIC
uv = NATIVE_TO_UTF(uv);
-#else
- if (uv == 0xfe || uv == 0xff) {
- if (flags & (UTF8_WARN_SUPER|UTF8_WARN_FE_FF)) {
- sv = sv_2mortal(Perl_newSVpvf(aTHX_ "Code point beginning with byte 0x%02"UVXf" is not Unicode, and not portable", uv));
- flags &= ~UTF8_WARN_SUPER; /* Only warn once on this problem */
- }
- if (flags & (UTF8_DISALLOW_SUPER|UTF8_DISALLOW_FE_FF)) {
- goto malformed;
- }
- }
#endif
- if (!(uv & 0x20)) { len = 2; uv &= 0x1f; }
- else if (!(uv & 0x10)) { len = 3; uv &= 0x0f; }
- else if (!(uv & 0x08)) { len = 4; uv &= 0x07; }
- else if (!(uv & 0x04)) { len = 5; uv &= 0x03; }
-#ifdef EBCDIC
- else if (!(uv & 0x02)) { len = 6; uv &= 0x01; }
- else { len = 7; uv &= 0x01; }
-#else
- else if (!(uv & 0x02)) { len = 6; uv &= 0x01; }
- else if (!(uv & 0x01)) { len = 7; uv = 0; }
- else { len = 13; uv = 0; } /* whoa! */
-#endif
+ /* Here is not a continuation byte, nor an invariant. The only thing left
+ * is a start byte (possibly for an overlong) */
- if (retlen)
- *retlen = len;
+ /* Remove the leading bits that indicate the number of bytes in the
+ * character's whole UTF-8 sequence, leaving just the bits that are part of
+ * the value */
+ uv &= UTF_START_MASK(expectlen);
- expectlen = len;
+ /* Now, loop through the remaining bytes in the character's sequence,
+ * accumulating each into the working value as we go. Be sure to not look
+ * past the end of the input string */
+ send = (U8*) s0 + ((expectlen <= curlen) ? expectlen : curlen);
- if ((curlen < expectlen) &&
- !(flags & UTF8_ALLOW_SHORT)) {
- warning = UTF8_WARN_SHORT;
- goto malformed;
- }
+ for (s = s0 + 1; s < send; s++) {
+ if (LIKELY(UTF8_IS_CONTINUATION(*s))) {
+#ifndef EBCDIC /* Can't overflow in EBCDIC */
+ if (uv & UTF_ACCUMULATION_OVERFLOW_MASK) {
- len--;
- s++;
- ouv = uv; /* ouv is the value from the previous iteration */
+ /* The original implementors viewed this malformation as more
+ * serious than the others (though I, khw, don't understand
+ * why, since other malformations also give very very wrong
+ * results), so there is no way to turn off checking for it.
+ * Set a flag, but keep going in the loop, so that we absorb
+ * the rest of the bytes that comprise the character. */
+ overflowed = TRUE;
+ overflow_byte = *s; /* Save for warning message's use */
+ }
+#endif
+ uv = UTF8_ACCUMULATE(uv, *s);
+ }
+ else {
+ /* Here, found a non-continuation before processing all expected
+ * bytes. This byte begins a new character, so quit, even if
+ * allowing this malformation. */
+ unexpected_non_continuation = TRUE;
+ break;
+ }
+ } /* End of loop through the character's bytes */
- while (len--) {
- if (!UTF8_IS_CONTINUATION(*s) &&
- !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
- s--;
- warning = UTF8_WARN_NON_CONTINUATION;
+ /* Save how many bytes were actually in the character */
+ curlen = s - s0;
+
+ /* The loop above finds two types of malformations: non-continuation and/or
+ * overflow. The non-continuation malformation is really a too-short
+ * malformation, as it means that the current character ended before it was
+ * expected to (being terminated prematurely by the beginning of the next
+ * character, whereas in the too-short malformation there just are too few
+ * bytes available to hold the character. In both cases, the check below
+ * that we have found the expected number of bytes would fail if executed.)
+ * Thus the non-continuation malformation is really unnecessary, being a
+ * subset of the too-short malformation. But there may be existing
+ * applications that are expecting the non-continuation type, so we retain
+ * it, and return it in preference to the too-short malformation. (If this
+ * code were being written from scratch, the two types might be collapsed
+ * into one.) I, khw, am also giving priority to returning the
+ * non-continuation and too-short malformations over overflow when multiple
+ * ones are present. I don't know of any real reason to prefer one over
+ * the other, except that it seems to me that multiple-byte errors trumps
+ * errors from a single byte */
+ if (UNLIKELY(unexpected_non_continuation)) {
+ if (!(flags & UTF8_ALLOW_NON_CONTINUATION)) {
+ if (! (flags & UTF8_CHECK_ONLY)) {
+ if (curlen == 1) {
+ sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (unexpected non-continuation byte 0x%02x, immediately after start byte 0x%02x)", malformed_text, *s, *s0));
+ }
+ else {
+ sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (unexpected non-continuation byte 0x%02x, %d bytes after start byte 0x%02x, expected %d bytes)", malformed_text, *s, (int) curlen, *s0, (int)expectlen));
+ }
+ }
goto malformed;
}
- else
- uv = UTF8_ACCUMULATE(uv, *s);
- if (!(uv > ouv)) { /* If the value didn't grow from the previous
- iteration, something is horribly wrong */
- /* These cannot be allowed. */
- if (uv == ouv) {
- if (expectlen != 13 && !(flags & UTF8_ALLOW_LONG)) {
- warning = UTF8_WARN_LONG;
- goto malformed;
- }
+ uv = UNICODE_REPLACEMENT;
+
+ /* Skip testing for overlongs, as the REPLACEMENT may not be the same
+ * as what the original expectations were. */
+ do_overlong_test = FALSE;
+ if (retlen) {
+ *retlen = curlen;
+ }
+ }
+ else if (UNLIKELY(curlen < expectlen)) {
+ if (! (flags & UTF8_ALLOW_SHORT)) {
+ if (! (flags & UTF8_CHECK_ONLY)) {
+ sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (%d byte%s, need %d, after start byte 0x%02x)", malformed_text, (int)curlen, curlen == 1 ? "" : "s", (int)expectlen, *s0));
}
- else { /* uv < ouv */
- /* This cannot be allowed. */
- warning = UTF8_WARN_OVERFLOW;
- goto malformed;
- }
+ goto malformed;
}
- s++;
- ouv = uv;
+ uv = UNICODE_REPLACEMENT;
+ do_overlong_test = FALSE;
+ if (retlen) {
+ *retlen = curlen;
+ }
}
- if ((expectlen > (STRLEN)UNISKIP(uv)) && !(flags & UTF8_ALLOW_LONG)) {
- warning = UTF8_WARN_LONG;
+#ifndef EBCDIC /* EBCDIC allows FE, FF, can't overflow */
+ if ((*s0 & 0xFE) == 0xFE /* matches both FE, FF */
+ && (flags & (UTF8_WARN_FE_FF|UTF8_DISALLOW_FE_FF)))
+ {
+ /* By adding UTF8_CHECK_ONLY to the test, we avoid unnecessary
+ * generation of the sv, since no warnings are raised under CHECK */
+ if ((flags & (UTF8_WARN_FE_FF|UTF8_CHECK_ONLY)) == UTF8_WARN_FE_FF
+ && ckWARN_d(WARN_UTF8))
+ {
+ /* This message is deliberately not of the same syntax as the other
+ * messages for malformations, for backwards compatibility in the
+ * unlikely event that code is relying on its precise earlier text
+ */
+ sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s Code point beginning with byte 0x%02X is not Unicode, and not portable", malformed_text, *s0));
+ pack_warn = packWARN(WARN_UTF8);
+ }
+ if (flags & UTF8_DISALLOW_FE_FF) {
+ goto malformed;
+ }
+ }
+ if (UNLIKELY(overflowed)) {
+
+ /* If the first byte is FF, it will overflow a 32-bit word. If the
+ * first byte is FE, it will overflow a signed 32-bit word. The
+ * above preserves backward compatibility, since its message was used
+ * in earlier versions of this code in preference to overflow */
+ sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (overflow at byte 0x%02x, after start byte 0x%02x)", malformed_text, overflow_byte, *s0));
goto malformed;
- } else if (flags & (UTF8_DISALLOW_ILLEGAL_INTERCHANGE|UTF8_WARN_ILLEGAL_INTERCHANGE)) {
+ }
+#endif
+
+ if (do_overlong_test
+ && expectlen > (STRLEN)UNISKIP(uv)
+ && ! (flags & UTF8_ALLOW_LONG))
+ {
+ /* The overlong malformation has lower precedence than the others.
+ * Note that if this malformation is allowed, we return the actual
+ * value, instead of the replacement character. This is because this
+ * value is actually well-defined. */
+ if (! (flags & UTF8_CHECK_ONLY)) {
+ sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (%d byte%s, need %d, after start byte 0x%02x)", malformed_text, (int)expectlen, expectlen == 1 ? "": "s", UNISKIP(uv), *s0));
+ }
+ goto malformed;
+ }
+
+ /* Here, the input is considered to be well-formed , but could be a
+ * problematic code point that is not allowed by the input parameters. */
+ if (uv >= UNICODE_SURROGATE_FIRST /* isn't problematic if < this */
+ && (flags & (UTF8_DISALLOW_ILLEGAL_INTERCHANGE
+ |UTF8_WARN_ILLEGAL_INTERCHANGE)))
+ {
if (UNICODE_IS_SURROGATE(uv)) {
- if ((flags & (UTF8_WARN_SURROGATE|UTF8_CHECK_ONLY)) == UTF8_WARN_SURROGATE) {
+ if ((flags & (UTF8_WARN_SURROGATE|UTF8_CHECK_ONLY)) == UTF8_WARN_SURROGATE
+ && ckWARN2_d(WARN_UTF8, WARN_SURROGATE))
+ {
sv = sv_2mortal(Perl_newSVpvf(aTHX_ "UTF-16 surrogate U+%04"UVXf"", uv));
+ pack_warn = packWARN2(WARN_UTF8, WARN_SURROGATE);
}
if (flags & UTF8_DISALLOW_SURROGATE) {
goto disallowed;
}
}
- else if (UNICODE_IS_NONCHAR(uv)) {
- if ((flags & (UTF8_WARN_NONCHAR|UTF8_CHECK_ONLY)) == UTF8_WARN_NONCHAR ) {
- sv = sv_2mortal(Perl_newSVpvf(aTHX_ "Unicode non-character U+%04"UVXf" is illegal for open interchange", uv));
+ else if ((uv > PERL_UNICODE_MAX)) {
+ if ((flags & (UTF8_WARN_SUPER|UTF8_CHECK_ONLY)) == UTF8_WARN_SUPER
+ && ckWARN2_d(WARN_UTF8, WARN_NON_UNICODE))
+ {
+ sv = sv_2mortal(Perl_newSVpvf(aTHX_ "Code point 0x%04"UVXf" is not Unicode, may not be portable", uv));
+ pack_warn = packWARN2(WARN_UTF8, WARN_NON_UNICODE);
}
- if (flags & UTF8_DISALLOW_NONCHAR) {
+ if (flags & UTF8_DISALLOW_SUPER) {
goto disallowed;
}
}
- else if ((uv > PERL_UNICODE_MAX)) {
- if ((flags & (UTF8_WARN_SUPER|UTF8_CHECK_ONLY)) == UTF8_WARN_SUPER) {
- sv = sv_2mortal(Perl_newSVpvf(aTHX_ "Code point 0x%04"UVXf" is not Unicode, may not be portable", uv));
+ else if (UNICODE_IS_NONCHAR(uv)) {
+ if ((flags & (UTF8_WARN_NONCHAR|UTF8_CHECK_ONLY)) == UTF8_WARN_NONCHAR
+ && ckWARN2_d(WARN_UTF8, WARN_NONCHAR))
+ {
+ sv = sv_2mortal(Perl_newSVpvf(aTHX_ "Unicode non-character U+%04"UVXf" is illegal for open interchange", uv));
+ pack_warn = packWARN2(WARN_UTF8, WARN_NONCHAR);
}
- if (flags & UTF8_DISALLOW_SUPER) {
+ if (flags & UTF8_DISALLOW_NONCHAR) {
goto disallowed;
}
}
+ if (sv) {
+ outlier_ret = uv;
+ goto do_warn;
+ }
+
/* Here, this is not considered a malformed character, so drop through
* to return it */
}
@@ -680,14 +838,40 @@
return uv;
-disallowed: /* Is disallowed, but otherwise not malformed. 'sv' will have been
- set if there is to be a warning. */
- if (!sv) {
- dowarn = 0;
- }
+ /* There are three cases which get to beyond this point. In all 3 cases:
+ * <sv> if not null points to a string to print as a warning.
+ * <curlen> is what <*retlen> should be set to if UTF8_CHECK_ONLY isn't
+ * set.
+ * <outlier_ret> is what return value to use if UTF8_CHECK_ONLY isn't set.
+ * This is done by initializing it to 0, and changing it only
+ * for case 1).
+ * The 3 cases are:
+ * 1) The input is valid but problematic, and to be warned about. The
+ * return value is the resultant code point; <*retlen> is set to
+ * <curlen>, the number of bytes that comprise the code point.
+ * <pack_warn> contains the result of packWARN() for the warning
+ * types. The entry point for this case is the label <do_warn>;
+ * 2) The input is a valid code point but disallowed by the parameters to
+ * this function. The return value is 0. If UTF8_CHECK_ONLY is set,
+ * <*relen> is -1; otherwise it is <curlen>, the number of bytes that
+ * comprise the code point. <pack_warn> contains the result of
+ * packWARN() for the warning types. The entry point for this case is
+ * the label <disallowed>.
+ * 3) The input is malformed. The return value is 0. If UTF8_CHECK_ONLY
+ * is set, <*relen> is -1; otherwise it is <curlen>, the number of
+ * bytes that comprise the malformation. All such malformations are
+ * assumed to be warning type <utf8>. The entry point for this case
+ * is the label <malformed>.
+ */
malformed:
+ if (sv && ckWARN_d(WARN_UTF8)) {
+ pack_warn = packWARN(WARN_UTF8);
+ }
+
+disallowed:
+
if (flags & UTF8_CHECK_ONLY) {
if (retlen)
*retlen = ((STRLEN) -1);
@@ -694,91 +878,177 @@
return 0;
}
- if (dowarn) {
- if (! sv) {
- sv = newSVpvs_flags("Malformed UTF-8 character ", SVs_TEMP);
- }
+do_warn:
- switch (warning) {
- case 0: /* Intentionally empty. */ break;
- case UTF8_WARN_EMPTY:
- sv_catpvs(sv, "(empty string)");
- break;
- case UTF8_WARN_CONTINUATION:
- Perl_sv_catpvf(aTHX_ sv, "(unexpected continuation byte 0x%02"UVxf", with no preceding start byte)", uv);
- break;
- case UTF8_WARN_NON_CONTINUATION:
- if (s == s0)
- Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", immediately after start byte 0x%02"UVxf")",
- (UV)s[1], startbyte);
- else {
- const int len = (int)(s-s0);
- Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", %d byte%s after start byte 0x%02"UVxf", expected %d bytes)",
- (UV)s[1], len, len > 1 ? "s" : "", startbyte, (int)expectlen);
- }
+ if (pack_warn) { /* <pack_warn> was initialized to 0, and changed only
+ if warnings are to be raised. */
+ const char * const string = SvPVX_const(sv);
- break;
- case UTF8_WARN_SHORT:
- Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
- (int)curlen, curlen == 1 ? "" : "s", (int)expectlen, startbyte);
- expectlen = curlen; /* distance for caller to skip */
- break;
- case UTF8_WARN_OVERFLOW:
- Perl_sv_catpvf(aTHX_ sv, "(overflow at 0x%"UVxf", byte 0x%02x, after start byte 0x%02"UVxf")",
- ouv, *s, startbyte);
- break;
- case UTF8_WARN_LONG:
- Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
- (int)expectlen, expectlen == 1 ? "": "s", UNISKIP(uv), startbyte);
- break;
- default:
- sv_catpvs(sv, "(unknown reason)");
- break;
- }
-
- if (sv) {
- const char * const s = SvPVX_const(sv);
+ if (PL_op)
+ Perl_warner(aTHX_ pack_warn, "%s in %s", string, OP_DESC(PL_op));
+ else
+ Perl_warner(aTHX_ pack_warn, "%s", string);
+ }
- if (PL_op)
- Perl_warner(aTHX_ packWARN(WARN_UTF8),
- "%s in %s", s, OP_DESC(PL_op));
- else
- Perl_warner(aTHX_ packWARN(WARN_UTF8), "%s", s);
- }
+ if (retlen) {
+ *retlen = curlen;
}
- if (retlen)
- *retlen = expectlen ? expectlen : len;
+ return outlier_ret;
+}
- return 0;
+/*
+=for apidoc utf8_to_uvchr_buf
+
+Returns the native code point of the first character in the string C<s> which
+is assumed to be in UTF-8 encoding; C<send> points to 1 beyond the end of C<s>.
+C<*retlen> will be set to the length, in bytes, of that character.
+
+If C<s> does not point to a well-formed UTF-8 character and UTF8 warnings are
+enabled, zero is returned and C<*retlen> is set (if C<retlen> isn't
+NULL) to -1. If those warnings are off, the computed value, if well-defined
+(or the Unicode REPLACEMENT CHARACTER if not), is silently returned, and
+C<*retlen> is set (if C<retlen> isn't NULL) so that (S<C<s> + C<*retlen>>) is
+the next possible position in C<s> that could begin a non-malformed character.
+See L</utf8n_to_uvuni> for details on when the REPLACEMENT CHARACTER is
+returned.
+
+=cut
+*/
+
+
+UV
+Perl_utf8_to_uvchr_buf(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
+{
+ PERL_ARGS_ASSERT_UTF8_TO_UVCHR_BUF;
+
+ assert(s < send);
+
+ return utf8n_to_uvchr(s, send - s, retlen,
+ ckWARN_d(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
}
+/* Like L</utf8_to_uvchr_buf>(), but should only be called when it is known that
+ * there are no malformations in the input UTF-8 string C<s>. surrogates,
+ * non-character code points, and non-Unicode code points are allowed. A macro
+ * in utf8.h is used to normally avoid this function wrapper */
+
+UV
+Perl_valid_utf8_to_uvchr(pTHX_ const U8 *s, STRLEN *retlen)
+{
+ const UV uv = valid_utf8_to_uvuni(s, retlen);
+
+ PERL_ARGS_ASSERT_VALID_UTF8_TO_UVCHR;
+
+ return UNI_TO_NATIVE(uv);
+}
+
/*
=for apidoc utf8_to_uvchr
+DEPRECATED!
+
Returns the native code point of the first character in the string C<s>
which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
length, in bytes, of that character.
-If C<s> does not point to a well-formed UTF-8 character, zero is
-returned and retlen is set, if possible, to -1.
+Some, but not all, UTF-8 malformations are detected, and in fact, some
+malformed input could cause reading beyond the end of the input buffer, which
+is why this function is deprecated. Use L</utf8_to_uvchr_buf> instead.
+If C<s> points to one of the detected malformations, and UTF8 warnings are
+enabled, zero is returned and C<*retlen> is set (if C<retlen> isn't
+NULL) to -1. If those warnings are off, the computed value if well-defined (or
+the Unicode REPLACEMENT CHARACTER, if not) is silently returned, and C<*retlen>
+is set (if C<retlen> isn't NULL) so that (S<C<s> + C<*retlen>>) is the
+next possible position in C<s> that could begin a non-malformed character.
+See L</utf8n_to_uvuni> for details on when the REPLACEMENT CHARACTER is returned.
+
=cut
*/
-
UV
Perl_utf8_to_uvchr(pTHX_ const U8 *s, STRLEN *retlen)
{
PERL_ARGS_ASSERT_UTF8_TO_UVCHR;
- return utf8n_to_uvchr(s, UTF8_MAXBYTES, retlen,
- ckWARN_d(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
+ return utf8_to_uvchr_buf(s, s + UTF8_MAXBYTES, retlen);
}
/*
+=for apidoc utf8_to_uvuni_buf
+
+Returns the Unicode code point of the first character in the string C<s> which
+is assumed to be in UTF-8 encoding; C<send> points to 1 beyond the end of C<s>.
+C<retlen> will be set to the length, in bytes, of that character.
+
+This function should only be used when the returned UV is considered
+an index into the Unicode semantic tables (e.g. swashes).
+
+If C<s> does not point to a well-formed UTF-8 character and UTF8 warnings are
+enabled, zero is returned and C<*retlen> is set (if C<retlen> isn't
+NULL) to -1. If those warnings are off, the computed value if well-defined (or
+the Unicode REPLACEMENT CHARACTER, if not) is silently returned, and C<*retlen>
+is set (if C<retlen> isn't NULL) so that (S<C<s> + C<*retlen>>) is the
+next possible position in C<s> that could begin a non-malformed character.
+See L</utf8n_to_uvuni> for details on when the REPLACEMENT CHARACTER is returned.
+
+=cut
+*/
+
+UV
+Perl_utf8_to_uvuni_buf(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
+{
+ PERL_ARGS_ASSERT_UTF8_TO_UVUNI_BUF;
+
+ assert(send > s);
+
+ /* Call the low level routine asking for checks */
+ return Perl_utf8n_to_uvuni(aTHX_ s, send -s, retlen,
+ ckWARN_d(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
+}
+
+/* Like L</utf8_to_uvuni_buf>(), but should only be called when it is known that
+ * there are no malformations in the input UTF-8 string C<s>. Surrogates,
+ * non-character code points, and non-Unicode code points are allowed */
+
+UV
+Perl_valid_utf8_to_uvuni(pTHX_ const U8 *s, STRLEN *retlen)
+{
+ UV expectlen = UTF8SKIP(s);
+ const U8* send = s + expectlen;
+ UV uv = NATIVE_TO_UTF(*s);
+
+ PERL_ARGS_ASSERT_VALID_UTF8_TO_UVUNI;
+
+ if (retlen) {
+ *retlen = expectlen;
+ }
+
+ /* An invariant is trivially returned */
+ if (expectlen == 1) {
+ return uv;
+ }
+
+ /* Remove the leading bits that indicate the number of bytes, leaving just
+ * the bits that are part of the value */
+ uv &= UTF_START_MASK(expectlen);
+
+ /* Now, loop through the remaining bytes, accumulating each into the
+ * working total as we go. (I khw tried unrolling the loop for up to 4
+ * bytes, but there was no performance improvement) */
+ for (++s; s < send; s++) {
+ uv = UTF8_ACCUMULATE(uv, *s);
+ }
+
+ return uv;
+}
+
+/*
=for apidoc utf8_to_uvuni
+DEPRECATED!
+
Returns the Unicode code point of the first character in the string C<s>
which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
length, in bytes, of that character.
@@ -786,9 +1056,18 @@
This function should only be used when the returned UV is considered
an index into the Unicode semantic tables (e.g. swashes).
-If C<s> does not point to a well-formed UTF-8 character, zero is
-returned and retlen is set, if possible, to -1.
+Some, but not all, UTF-8 malformations are detected, and in fact, some
+malformed input could cause reading beyond the end of the input buffer, which
+is why this function is deprecated. Use L</utf8_to_uvuni_buf> instead.
+If C<s> points to one of the detected malformations, and UTF8 warnings are
+enabled, zero is returned and C<*retlen> is set (if C<retlen> doesn't point to
+NULL) to -1. If those warnings are off, the computed value if well-defined (or
+the Unicode REPLACEMENT CHARACTER, if not) is silently returned, and C<*retlen>
+is set (if C<retlen> isn't NULL) so that (S<C<s> + C<*retlen>>) is the
+next possible position in C<s> that could begin a non-malformed character.
+See L</utf8n_to_uvuni> for details on when the REPLACEMENT CHARACTER is returned.
+
=cut
*/
@@ -797,9 +1076,7 @@
{
PERL_ARGS_ASSERT_UTF8_TO_UVUNI;
- /* Call the low level routine asking for checks */
- return Perl_utf8n_to_uvuni(aTHX_ s, UTF8_MAXBYTES, retlen,
- ckWARN_d(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
+ return valid_utf8_to_uvuni(s, retlen);
}
/*
@@ -827,10 +1104,7 @@
if (e < s)
goto warn_and_return;
while (s < e) {
- if (!UTF8_IS_INVARIANT(*s))
- s += UTF8SKIP(s);
- else
- s++;
+ s += UTF8SKIP(s);
len++;
}
@@ -907,8 +1181,8 @@
/*
=for apidoc bytes_cmp_utf8
-Compares the sequence of characters (stored as octets) in b, blen with the
-sequence of characters (stored as UTF-8) in u, ulen. Returns 0 if they are
+Compares the sequence of characters (stored as octets) in C<b>, C<blen> with the
+sequence of characters (stored as UTF-8) in C<u>, C<ulen>. Returns 0 if they are
equal, -1 or -2 if the first string is less than the second string, +1 or +2
if the first string is greater than the second string.
@@ -976,11 +1250,11 @@
=for apidoc utf8_to_bytes
Converts a string C<s> of length C<len> from UTF-8 into native byte encoding.
-Unlike C<bytes_to_utf8>, this over-writes the original string, and
-updates len to contain the new length.
+Unlike L</bytes_to_utf8>, this over-writes the original string, and
+updates C<len> to contain the new length.
Returns zero on failure, setting C<len> to -1.
-If you need a copy of the string, see C<bytes_from_utf8>.
+If you need a copy of the string, see L</bytes_from_utf8>.
=cut
*/
@@ -1009,7 +1283,7 @@
d = s = save;
while (s < send) {
STRLEN ulen;
- *d++ = (U8)utf8_to_uvchr(s, &ulen);
+ *d++ = (U8)utf8_to_uvchr_buf(s, send, &ulen);
s += ulen;
}
*d = '\0';
@@ -1021,7 +1295,7 @@
=for apidoc bytes_from_utf8
Converts a string C<s> of length C<len> from UTF-8 into native byte encoding.
-Unlike C<utf8_to_bytes> but like C<bytes_to_utf8>, returns a pointer to
+Unlike L</utf8_to_bytes> but like L</bytes_to_utf8>, returns a pointer to
the newly-created string, and updates C<len> to contain the new
length. Returns the original string if no conversion occurs, C<len>
is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to
@@ -1086,11 +1360,14 @@
If you want to convert to UTF-8 from encodings other than
the native (Latin1 or EBCDIC),
-see sv_recode_to_utf8().
+see L</sv_recode_to_utf8>().
=cut
*/
+/* This logic is duplicated in sv_catpvn_flags, so any bug fixes will
+ likewise need duplication. */
+
U8*
Perl_bytes_to_utf8(pTHX_ const U8 *s, STRLEN *len)
{
@@ -1207,54 +1484,104 @@
return utf16_to_utf8(p, d, bytelen, newlen);
}
-/* for now these are all defined (inefficiently) in terms of the utf8 versions */
+bool
+Perl__is_uni_FOO(pTHX_ const U8 classnum, const UV c)
+{
+ U8 tmpbuf[UTF8_MAXBYTES+1];
+ uvchr_to_utf8(tmpbuf, c);
+ return _is_utf8_FOO(classnum, tmpbuf);
+}
+/* for now these are all defined (inefficiently) in terms of the utf8 versions.
+ * Note that the macros in handy.h that call these short-circuit calling them
+ * for Latin-1 range inputs */
+
bool
Perl_is_uni_alnum(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXBYTES+1];
uvchr_to_utf8(tmpbuf, c);
- return is_utf8_alnum(tmpbuf);
+ return _is_utf8_FOO(_CC_WORDCHAR, tmpbuf);
}
bool
+Perl_is_uni_alnumc(pTHX_ UV c)
+{
+ U8 tmpbuf[UTF8_MAXBYTES+1];
+ uvchr_to_utf8(tmpbuf, c);
+ return _is_utf8_FOO(_CC_ALPHANUMERIC, tmpbuf);
+}
+
+/* Internal function so we can deprecate the external one, and call
+ this one from other deprecated functions in this file */
+
+PERL_STATIC_INLINE bool
+S_is_utf8_idfirst(pTHX_ const U8 *p)
+{
+ dVAR;
+
+ if (*p == '_')
+ return TRUE;
+ /* is_utf8_idstart would be more logical. */
+ return is_utf8_common(p, &PL_utf8_idstart, "IdStart");
+}
+
+bool
Perl_is_uni_idfirst(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXBYTES+1];
uvchr_to_utf8(tmpbuf, c);
- return is_utf8_idfirst(tmpbuf);
+ return S_is_utf8_idfirst(aTHX_ tmpbuf);
}
bool
-Perl_is_uni_alpha(pTHX_ UV c)
+Perl__is_uni_perl_idcont(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXBYTES+1];
uvchr_to_utf8(tmpbuf, c);
- return is_utf8_alpha(tmpbuf);
+ return _is_utf8_perl_idcont(tmpbuf);
}
bool
-Perl_is_uni_ascii(pTHX_ UV c)
+Perl__is_uni_perl_idstart(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXBYTES+1];
uvchr_to_utf8(tmpbuf, c);
- return is_utf8_ascii(tmpbuf);
+ return _is_utf8_perl_idstart(tmpbuf);
}
bool
-Perl_is_uni_space(pTHX_ UV c)
+Perl_is_uni_alpha(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXBYTES+1];
uvchr_to_utf8(tmpbuf, c);
- return is_utf8_space(tmpbuf);
+ return _is_utf8_FOO(_CC_ALPHA, tmpbuf);
}
bool
+Perl_is_uni_ascii(pTHX_ UV c)
+{
+ return isASCII(c);
+}
+
+bool
+Perl_is_uni_blank(pTHX_ UV c)
+{
+ return isBLANK_uni(c);
+}
+
+bool
+Perl_is_uni_space(pTHX_ UV c)
+{
+ return isSPACE_uni(c);
+}
+
+bool
Perl_is_uni_digit(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXBYTES+1];
uvchr_to_utf8(tmpbuf, c);
- return is_utf8_digit(tmpbuf);
+ return _is_utf8_FOO(_CC_DIGIT, tmpbuf);
}
bool
@@ -1262,7 +1589,7 @@
{
U8 tmpbuf[UTF8_MAXBYTES+1];
uvchr_to_utf8(tmpbuf, c);
- return is_utf8_upper(tmpbuf);
+ return _is_utf8_FOO(_CC_UPPER, tmpbuf);
}
bool
@@ -1270,15 +1597,13 @@
{
U8 tmpbuf[UTF8_MAXBYTES+1];
uvchr_to_utf8(tmpbuf, c);
- return is_utf8_lower(tmpbuf);
+ return _is_utf8_FOO(_CC_LOWER, tmpbuf);
}
bool
Perl_is_uni_cntrl(pTHX_ UV c)
{
- U8 tmpbuf[UTF8_MAXBYTES+1];
- uvchr_to_utf8(tmpbuf, c);
- return is_utf8_cntrl(tmpbuf);
+ return isCNTRL_L1(c);
}
bool
@@ -1286,7 +1611,7 @@
{
U8 tmpbuf[UTF8_MAXBYTES+1];
uvchr_to_utf8(tmpbuf, c);
- return is_utf8_graph(tmpbuf);
+ return _is_utf8_FOO(_CC_GRAPH, tmpbuf);
}
bool
@@ -1294,7 +1619,7 @@
{
U8 tmpbuf[UTF8_MAXBYTES+1];
uvchr_to_utf8(tmpbuf, c);
- return is_utf8_print(tmpbuf);
+ return _is_utf8_FOO(_CC_PRINT, tmpbuf);
}
bool
@@ -1302,131 +1627,370 @@
{
U8 tmpbuf[UTF8_MAXBYTES+1];
uvchr_to_utf8(tmpbuf, c);
- return is_utf8_punct(tmpbuf);
+ return _is_utf8_FOO(_CC_PUNCT, tmpbuf);
}
bool
Perl_is_uni_xdigit(pTHX_ UV c)
{
- U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
- uvchr_to_utf8(tmpbuf, c);
- return is_utf8_xdigit(tmpbuf);
+ return isXDIGIT_uni(c);
}
UV
+Perl__to_upper_title_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp, const char S_or_s)
+{
+ /* We have the latin1-range values compiled into the core, so just use
+ * those, converting the result to utf8. The only difference between upper
+ * and title case in this range is that LATIN_SMALL_LETTER_SHARP_S is
+ * either "SS" or "Ss". Which one to use is passed into the routine in
+ * 'S_or_s' to avoid a test */
+
+ UV converted = toUPPER_LATIN1_MOD(c);
+
+ PERL_ARGS_ASSERT__TO_UPPER_TITLE_LATIN1;
+
+ assert(S_or_s == 'S' || S_or_s == 's');
+
+ if (UNI_IS_INVARIANT(converted)) { /* No difference between the two for
+ characters in this range */
+ *p = (U8) converted;
+ *lenp = 1;
+ return converted;
+ }
+
+ /* toUPPER_LATIN1_MOD gives the correct results except for three outliers,
+ * which it maps to one of them, so as to only have to have one check for
+ * it in the main case */
+ if (UNLIKELY(converted == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
+ switch (c) {
+ case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
+ converted = LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS;
+ break;
+ case MICRO_SIGN:
+ converted = GREEK_CAPITAL_LETTER_MU;
+ break;
+ case LATIN_SMALL_LETTER_SHARP_S:
+ *(p)++ = 'S';
+ *p = S_or_s;
+ *lenp = 2;
+ return 'S';
+ default:
+ Perl_croak(aTHX_ "panic: to_upper_title_latin1 did not expect '%c' to map to '%c'", c, LATIN_SMALL_LETTER_Y_WITH_DIAERESIS);
+ assert(0); /* NOTREACHED */
+ }
+ }
+
+ *(p)++ = UTF8_TWO_BYTE_HI(converted);
+ *p = UTF8_TWO_BYTE_LO(converted);
+ *lenp = 2;
+
+ return converted;
+}
+
+/* Call the function to convert a UTF-8 encoded character to the specified case.
+ * Note that there may be more than one character in the result.
+ * INP is a pointer to the first byte of the input character
+ * OUTP will be set to the first byte of the string of changed characters. It
+ * needs to have space for UTF8_MAXBYTES_CASE+1 bytes
+ * LENP will be set to the length in bytes of the string of changed characters
+ *
+ * The functions return the ordinal of the first character in the string of OUTP */
+#define CALL_UPPER_CASE(INP, OUTP, LENP) Perl_to_utf8_case(aTHX_ INP, OUTP, LENP, &PL_utf8_toupper, "ToUc", "utf8::ToSpecUc")
+#define CALL_TITLE_CASE(INP, OUTP, LENP) Perl_to_utf8_case(aTHX_ INP, OUTP, LENP, &PL_utf8_totitle, "ToTc", "utf8::ToSpecTc")
+#define CALL_LOWER_CASE(INP, OUTP, LENP) Perl_to_utf8_case(aTHX_ INP, OUTP, LENP, &PL_utf8_tolower, "ToLc", "utf8::ToSpecLc")
+
+/* This additionally has the input parameter SPECIALS, which if non-zero will
+ * cause this to use the SPECIALS hash for folding (meaning get full case
+ * folding); otherwise, when zero, this implies a simple case fold */
+#define CALL_FOLD_CASE(INP, OUTP, LENP, SPECIALS) Perl_to_utf8_case(aTHX_ INP, OUTP, LENP, &PL_utf8_tofold, "ToCf", (SPECIALS) ? "utf8::ToSpecCf" : NULL)
+
+UV
Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp)
{
+ dVAR;
+
+ /* Convert the Unicode character whose ordinal is <c> to its uppercase
+ * version and store that in UTF-8 in <p> and its length in bytes in <lenp>.
+ * Note that the <p> needs to be at least UTF8_MAXBYTES_CASE+1 bytes since
+ * the changed version may be longer than the original character.
+ *
+ * The ordinal of the first character of the changed version is returned
+ * (but note, as explained above, that there may be more.) */
+
PERL_ARGS_ASSERT_TO_UNI_UPPER;
+ if (c < 256) {
+ return _to_upper_title_latin1((U8) c, p, lenp, 'S');
+ }
+
uvchr_to_utf8(p, c);
- return to_utf8_upper(p, p, lenp);
+ return CALL_UPPER_CASE(p, p, lenp);
}
UV
Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp)
{
+ dVAR;
+
PERL_ARGS_ASSERT_TO_UNI_TITLE;
+ if (c < 256) {
+ return _to_upper_title_latin1((U8) c, p, lenp, 's');
+ }
+
uvchr_to_utf8(p, c);
- return to_utf8_title(p, p, lenp);
+ return CALL_TITLE_CASE(p, p, lenp);
}
+STATIC U8
+S_to_lower_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp)
+{
+ /* We have the latin1-range values compiled into the core, so just use
+ * those, converting the result to utf8. Since the result is always just
+ * one character, we allow <p> to be NULL */
+
+ U8 converted = toLOWER_LATIN1(c);
+
+ if (p != NULL) {
+ if (UNI_IS_INVARIANT(converted)) {
+ *p = converted;
+ *lenp = 1;
+ }
+ else {
+ *p = UTF8_TWO_BYTE_HI(converted);
+ *(p+1) = UTF8_TWO_BYTE_LO(converted);
+ *lenp = 2;
+ }
+ }
+ return converted;
+}
+
UV
Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp)
{
+ dVAR;
+
PERL_ARGS_ASSERT_TO_UNI_LOWER;
+ if (c < 256) {
+ return to_lower_latin1((U8) c, p, lenp);
+ }
+
uvchr_to_utf8(p, c);
- return to_utf8_lower(p, p, lenp);
+ return CALL_LOWER_CASE(p, p, lenp);
}
UV
-Perl__to_uni_fold_flags(pTHX_ UV c, U8* p, STRLEN *lenp, U8 flags)
+Perl__to_fold_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp, const bool flags)
{
+ /* Corresponds to to_lower_latin1(), <flags> is TRUE if to use full case
+ * folding */
+
+ UV converted;
+
+ PERL_ARGS_ASSERT__TO_FOLD_LATIN1;
+
+ if (c == MICRO_SIGN) {
+ converted = GREEK_SMALL_LETTER_MU;
+ }
+ else if (flags && c == LATIN_SMALL_LETTER_SHARP_S) {
+ *(p)++ = 's';
+ *p = 's';
+ *lenp = 2;
+ return 's';
+ }
+ else { /* In this range the fold of all other characters is their lower
+ case */
+ converted = toLOWER_LATIN1(c);
+ }
+
+ if (UNI_IS_INVARIANT(converted)) {
+ *p = (U8) converted;
+ *lenp = 1;
+ }
+ else {
+ *(p)++ = UTF8_TWO_BYTE_HI(converted);
+ *p = UTF8_TWO_BYTE_LO(converted);
+ *lenp = 2;
+ }
+
+ return converted;
+}
+
+UV
+Perl__to_uni_fold_flags(pTHX_ UV c, U8* p, STRLEN *lenp, const U8 flags)
+{
+
+ /* Not currently externally documented, and subject to change
+ * <flags> bits meanings:
+ * FOLD_FLAGS_FULL iff full folding is to be used;
+ * FOLD_FLAGS_LOCALE iff in locale
+ * FOLD_FLAGS_NOMIX_ASCII iff non-ASCII to ASCII folds are prohibited
+ */
+
PERL_ARGS_ASSERT__TO_UNI_FOLD_FLAGS;
- uvchr_to_utf8(p, c);
- return _to_utf8_fold_flags(p, p, lenp, flags);
+ if (c < 256) {
+ UV result = _to_fold_latin1((U8) c, p, lenp,
+ cBOOL(((flags & FOLD_FLAGS_FULL)
+ /* If ASCII-safe, don't allow full folding,
+ * as that could include SHARP S => ss;
+ * otherwise there is no crossing of
+ * ascii/non-ascii in the latin1 range */
+ && ! (flags & FOLD_FLAGS_NOMIX_ASCII))));
+ /* It is illegal for the fold to cross the 255/256 boundary under
+ * locale; in this case return the original */
+ return (result > 256 && flags & FOLD_FLAGS_LOCALE)
+ ? c
+ : result;
+ }
+
+ /* If no special needs, just use the macro */
+ if ( ! (flags & (FOLD_FLAGS_LOCALE|FOLD_FLAGS_NOMIX_ASCII))) {
+ uvchr_to_utf8(p, c);
+ return CALL_FOLD_CASE(p, p, lenp, flags & FOLD_FLAGS_FULL);
+ }
+ else { /* Otherwise, _to_utf8_fold_flags has the intelligence to deal with
+ the special flags. */
+ U8 utf8_c[UTF8_MAXBYTES + 1];
+ uvchr_to_utf8(utf8_c, c);
+ return _to_utf8_fold_flags(utf8_c, p, lenp, flags, NULL);
+ }
}
-/* for now these all assume no locale info available for Unicode > 255 */
-
bool
Perl_is_uni_alnum_lc(pTHX_ UV c)
{
- return is_uni_alnum(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isALNUM_LC(UNI_TO_NATIVE(c));
+ }
+ return _is_uni_FOO(_CC_WORDCHAR, c);
}
bool
+Perl_is_uni_alnumc_lc(pTHX_ UV c)
+{
+ if (c < 256) {
+ return isALPHANUMERIC_LC(UNI_TO_NATIVE(c));
+ }
+ return _is_uni_FOO(_CC_ALPHANUMERIC, c);
+}
+
+bool
Perl_is_uni_idfirst_lc(pTHX_ UV c)
{
- return is_uni_idfirst(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isIDFIRST_LC(UNI_TO_NATIVE(c));
+ }
+ return _is_uni_perl_idstart(c);
}
bool
Perl_is_uni_alpha_lc(pTHX_ UV c)
{
- return is_uni_alpha(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isALPHA_LC(UNI_TO_NATIVE(c));
+ }
+ return _is_uni_FOO(_CC_ALPHA, c);
}
bool
Perl_is_uni_ascii_lc(pTHX_ UV c)
{
- return is_uni_ascii(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isASCII_LC(UNI_TO_NATIVE(c));
+ }
+ return 0;
}
bool
+Perl_is_uni_blank_lc(pTHX_ UV c)
+{
+ if (c < 256) {
+ return isBLANK_LC(UNI_TO_NATIVE(c));
+ }
+ return isBLANK_uni(c);
+}
+
+bool
Perl_is_uni_space_lc(pTHX_ UV c)
{
- return is_uni_space(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isSPACE_LC(UNI_TO_NATIVE(c));
+ }
+ return isSPACE_uni(c);
}
bool
Perl_is_uni_digit_lc(pTHX_ UV c)
{
- return is_uni_digit(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isDIGIT_LC(UNI_TO_NATIVE(c));
+ }
+ return _is_uni_FOO(_CC_DIGIT, c);
}
bool
Perl_is_uni_upper_lc(pTHX_ UV c)
{
- return is_uni_upper(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isUPPER_LC(UNI_TO_NATIVE(c));
+ }
+ return _is_uni_FOO(_CC_UPPER, c);
}
bool
Perl_is_uni_lower_lc(pTHX_ UV c)
{
- return is_uni_lower(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isLOWER_LC(UNI_TO_NATIVE(c));
+ }
+ return _is_uni_FOO(_CC_LOWER, c);
}
bool
Perl_is_uni_cntrl_lc(pTHX_ UV c)
{
- return is_uni_cntrl(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isCNTRL_LC(UNI_TO_NATIVE(c));
+ }
+ return 0;
}
bool
Perl_is_uni_graph_lc(pTHX_ UV c)
{
- return is_uni_graph(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isGRAPH_LC(UNI_TO_NATIVE(c));
+ }
+ return _is_uni_FOO(_CC_GRAPH, c);
}
bool
Perl_is_uni_print_lc(pTHX_ UV c)
{
- return is_uni_print(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isPRINT_LC(UNI_TO_NATIVE(c));
+ }
+ return _is_uni_FOO(_CC_PRINT, c);
}
bool
Perl_is_uni_punct_lc(pTHX_ UV c)
{
- return is_uni_punct(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isPUNCT_LC(UNI_TO_NATIVE(c));
+ }
+ return _is_uni_FOO(_CC_PUNCT, c);
}
bool
Perl_is_uni_xdigit_lc(pTHX_ UV c)
{
- return is_uni_xdigit(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isXDIGIT_LC(UNI_TO_NATIVE(c));
+ }
+ return isXDIGIT_uni(c);
}
U32
@@ -1459,22 +2023,62 @@
return (U32)to_uni_lower(c, tmpbuf, &len);
}
-static bool
+PERL_STATIC_INLINE bool
S_is_utf8_common(pTHX_ const U8 *const p, SV **swash,
const char *const swashname)
{
+ /* returns a boolean giving whether or not the UTF8-encoded character that
+ * starts at <p> is in the swash indicated by <swashname>. <swash>
+ * contains a pointer to where the swash indicated by <swashname>
+ * is to be stored; which this routine will do, so that future calls will
+ * look at <*swash> and only generate a swash if it is not null
+ *
+ * Note that it is assumed that the buffer length of <p> is enough to
+ * contain all the bytes that comprise the character. Thus, <*p> should
+ * have been checked before this call for mal-formedness enough to assure
+ * that. */
+
dVAR;
PERL_ARGS_ASSERT_IS_UTF8_COMMON;
- if (!is_utf8_char(p))
- return FALSE;
- if (!*swash)
- *swash = swash_init("utf8", swashname, &PL_sv_undef, 1, 0);
+ /* The API should have included a length for the UTF-8 character in <p>,
+ * but it doesn't. We therefore assume that p has been validated at least
+ * as far as there being enough bytes available in it to accommodate the
+ * character without reading beyond the end, and pass that number on to the
+ * validating routine */
+ if (! is_utf8_char_buf(p, p + UTF8SKIP(p))) {
+ if (ckWARN_d(WARN_UTF8)) {
+ Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED,WARN_UTF8),
+ "Passing malformed UTF-8 to \"%s\" is deprecated", swashname);
+ if (ckWARN(WARN_UTF8)) { /* This will output details as to the
+ what the malformation is */
+ utf8_to_uvchr_buf(p, p + UTF8SKIP(p), NULL);
+ }
+ }
+ return FALSE;
+ }
+ if (!*swash) {
+ U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
+ *swash = _core_swash_init("utf8", swashname, &PL_sv_undef, 1, 0, NULL, &flags);
+ }
+
return swash_fetch(*swash, p, TRUE) != 0;
}
bool
+Perl__is_utf8_FOO(pTHX_ const U8 classnum, const U8 *p)
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT__IS_UTF8_FOO;
+
+ assert(classnum < _FIRST_NON_SWASH_CC);
+
+ return is_utf8_common(p, &PL_utf8_swash_ptrs[classnum], swash_property_names[classnum]);
+}
+
+bool
Perl_is_utf8_alnum(pTHX_ const U8 *p)
{
dVAR;
@@ -1484,10 +2088,20 @@
/* NOTE: "IsWord", not "IsAlnum", since Alnum is a true
* descendant of isalnum(3), in other words, it doesn't
* contain the '_'. --jhi */
- return is_utf8_common(p, &PL_utf8_alnum, "IsWord");
+ return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_WORDCHAR], "IsWord");
}
bool
+Perl_is_utf8_alnumc(pTHX_ const U8 *p)
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_ALNUMC;
+
+ return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_ALPHANUMERIC], "IsAlnum");
+}
+
+bool
Perl_is_utf8_idfirst(pTHX_ const U8 *p) /* The naming is historical. */
{
dVAR;
@@ -1494,10 +2108,7 @@
PERL_ARGS_ASSERT_IS_UTF8_IDFIRST;
- if (*p == '_')
- return TRUE;
- /* is_utf8_idstart would be more logical. */
- return is_utf8_common(p, &PL_utf8_idstart, "IdStart");
+ return S_is_utf8_idfirst(aTHX_ p);
}
bool
@@ -1514,6 +2125,27 @@
}
bool
+Perl__is_utf8_perl_idstart(pTHX_ const U8 *p)
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT__IS_UTF8_PERL_IDSTART;
+
+ return is_utf8_common(p, &PL_utf8_perl_idstart, "_Perl_IDStart");
+}
+
+bool
+Perl__is_utf8_perl_idcont(pTHX_ const U8 *p)
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT__IS_UTF8_PERL_IDCONT;
+
+ return is_utf8_common(p, &PL_utf8_perl_idcont, "_Perl_IDCont");
+}
+
+
+bool
Perl_is_utf8_idcont(pTHX_ const U8 *p)
{
dVAR;
@@ -1520,8 +2152,6 @@
PERL_ARGS_ASSERT_IS_UTF8_IDCONT;
- if (*p == '_')
- return TRUE;
return is_utf8_common(p, &PL_utf8_idcont, "IdContinue");
}
@@ -1532,8 +2162,6 @@
PERL_ARGS_ASSERT_IS_UTF8_XIDCONT;
- if (*p == '_')
- return TRUE;
return is_utf8_common(p, &PL_utf8_idcont, "XIdContinue");
}
@@ -1544,7 +2172,7 @@
PERL_ARGS_ASSERT_IS_UTF8_ALPHA;
- return is_utf8_common(p, &PL_utf8_alpha, "IsAlpha");
+ return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_ALPHA], "IsAlpha");
}
bool
@@ -1554,10 +2182,22 @@
PERL_ARGS_ASSERT_IS_UTF8_ASCII;
- return is_utf8_common(p, &PL_utf8_ascii, "IsAscii");
+ /* ASCII characters are the same whether in utf8 or not. So the macro
+ * works on both utf8 and non-utf8 representations. */
+ return isASCII(*p);
}
bool
+Perl_is_utf8_blank(pTHX_ const U8 *p)
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_BLANK;
+
+ return isBLANK_utf8(p);
+}
+
+bool
Perl_is_utf8_space(pTHX_ const U8 *p)
{
dVAR;
@@ -1564,7 +2204,7 @@
PERL_ARGS_ASSERT_IS_UTF8_SPACE;
- return is_utf8_common(p, &PL_utf8_space, "IsSpacePerl");
+ return isSPACE_utf8(p);
}
bool
@@ -1574,7 +2214,9 @@
PERL_ARGS_ASSERT_IS_UTF8_PERL_SPACE;
- return is_utf8_common(p, &PL_utf8_perl_space, "IsPerlSpace");
+ /* Only true if is an ASCII space-like character, and ASCII is invariant
+ * under utf8, so can just use the macro */
+ return isSPACE_A(*p);
}
bool
@@ -1584,7 +2226,9 @@
PERL_ARGS_ASSERT_IS_UTF8_PERL_WORD;
- return is_utf8_common(p, &PL_utf8_perl_word, "IsPerlWord");
+ /* Only true if is an ASCII word character, and ASCII is invariant
+ * under utf8, so can just use the macro */
+ return isWORDCHAR_A(*p);
}
bool
@@ -1594,7 +2238,7 @@
PERL_ARGS_ASSERT_IS_UTF8_DIGIT;
- return is_utf8_common(p, &PL_utf8_digit, "IsDigit");
+ return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_DIGIT], "IsDigit");
}
bool
@@ -1604,7 +2248,9 @@
PERL_ARGS_ASSERT_IS_UTF8_POSIX_DIGIT;
- return is_utf8_common(p, &PL_utf8_posix_digit, "IsPosixDigit");
+ /* Only true if is an ASCII digit character, and ASCII is invariant
+ * under utf8, so can just use the macro */
+ return isDIGIT_A(*p);
}
bool
@@ -1614,7 +2260,7 @@
PERL_ARGS_ASSERT_IS_UTF8_UPPER;
- return is_utf8_common(p, &PL_utf8_upper, "IsUppercase");
+ return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_UPPER], "IsUppercase");
}
bool
@@ -1624,7 +2270,7 @@
PERL_ARGS_ASSERT_IS_UTF8_LOWER;
- return is_utf8_common(p, &PL_utf8_lower, "IsLowercase");
+ return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_LOWER], "IsLowercase");
}
bool
@@ -1634,7 +2280,7 @@
PERL_ARGS_ASSERT_IS_UTF8_CNTRL;
- return is_utf8_common(p, &PL_utf8_cntrl, "IsCntrl");
+ return isCNTRL_utf8(p);
}
bool
@@ -1644,7 +2290,7 @@
PERL_ARGS_ASSERT_IS_UTF8_GRAPH;
- return is_utf8_common(p, &PL_utf8_graph, "IsGraph");
+ return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_GRAPH], "IsGraph");
}
bool
@@ -1654,7 +2300,7 @@
PERL_ARGS_ASSERT_IS_UTF8_PRINT;
- return is_utf8_common(p, &PL_utf8_print, "IsPrint");
+ return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_PRINT], "IsPrint");
}
bool
@@ -1664,7 +2310,7 @@
PERL_ARGS_ASSERT_IS_UTF8_PUNCT;
- return is_utf8_common(p, &PL_utf8_punct, "IsPunct");
+ return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_PUNCT], "IsPunct");
}
bool
@@ -1674,140 +2320,52 @@
PERL_ARGS_ASSERT_IS_UTF8_XDIGIT;
- return is_utf8_common(p, &PL_utf8_xdigit, "IsXDigit");
+ return is_XDIGIT_utf8(p);
}
bool
-Perl_is_utf8_mark(pTHX_ const U8 *p)
+Perl__is_utf8_mark(pTHX_ const U8 *p)
{
dVAR;
- PERL_ARGS_ASSERT_IS_UTF8_MARK;
+ PERL_ARGS_ASSERT__IS_UTF8_MARK;
return is_utf8_common(p, &PL_utf8_mark, "IsM");
}
-bool
-Perl_is_utf8_X_begin(pTHX_ const U8 *p)
-{
- dVAR;
- PERL_ARGS_ASSERT_IS_UTF8_X_BEGIN;
-
- return is_utf8_common(p, &PL_utf8_X_begin, "_X_Begin");
-}
-
bool
-Perl_is_utf8_X_extend(pTHX_ const U8 *p)
+Perl_is_utf8_mark(pTHX_ const U8 *p)
{
dVAR;
- PERL_ARGS_ASSERT_IS_UTF8_X_EXTEND;
+ PERL_ARGS_ASSERT_IS_UTF8_MARK;
- return is_utf8_common(p, &PL_utf8_X_extend, "_X_Extend");
+ return _is_utf8_mark(p);
}
-bool
-Perl_is_utf8_X_prepend(pTHX_ const U8 *p)
-{
- dVAR;
-
- PERL_ARGS_ASSERT_IS_UTF8_X_PREPEND;
-
- return is_utf8_common(p, &PL_utf8_X_prepend, "GCB=Prepend");
-}
-
-bool
-Perl_is_utf8_X_non_hangul(pTHX_ const U8 *p)
-{
- dVAR;
-
- PERL_ARGS_ASSERT_IS_UTF8_X_NON_HANGUL;
-
- return is_utf8_common(p, &PL_utf8_X_non_hangul, "HST=Not_Applicable");
-}
-
-bool
-Perl_is_utf8_X_L(pTHX_ const U8 *p)
-{
- dVAR;
-
- PERL_ARGS_ASSERT_IS_UTF8_X_L;
-
- return is_utf8_common(p, &PL_utf8_X_L, "GCB=L");
-}
-
-bool
-Perl_is_utf8_X_LV(pTHX_ const U8 *p)
-{
- dVAR;
-
- PERL_ARGS_ASSERT_IS_UTF8_X_LV;
-
- return is_utf8_common(p, &PL_utf8_X_LV, "GCB=LV");
-}
-
-bool
-Perl_is_utf8_X_LVT(pTHX_ const U8 *p)
-{
- dVAR;
-
- PERL_ARGS_ASSERT_IS_UTF8_X_LVT;
-
- return is_utf8_common(p, &PL_utf8_X_LVT, "GCB=LVT");
-}
-
-bool
-Perl_is_utf8_X_T(pTHX_ const U8 *p)
-{
- dVAR;
-
- PERL_ARGS_ASSERT_IS_UTF8_X_T;
-
- return is_utf8_common(p, &PL_utf8_X_T, "GCB=T");
-}
-
-bool
-Perl_is_utf8_X_V(pTHX_ const U8 *p)
-{
- dVAR;
-
- PERL_ARGS_ASSERT_IS_UTF8_X_V;
-
- return is_utf8_common(p, &PL_utf8_X_V, "GCB=V");
-}
-
-bool
-Perl_is_utf8_X_LV_LVT_V(pTHX_ const U8 *p)
-{
- dVAR;
-
- PERL_ARGS_ASSERT_IS_UTF8_X_LV_LVT_V;
-
- return is_utf8_common(p, &PL_utf8_X_LV_LVT_V, "_X_LV_LVT_V");
-}
-
/*
=for apidoc to_utf8_case
-The "p" contains the pointer to the UTF-8 string encoding
-the character that is being converted.
+The C<p> contains the pointer to the UTF-8 string encoding
+the character that is being converted. This routine assumes that the character
+at C<p> is well-formed.
-The "ustrp" is a pointer to the character buffer to put the
-conversion result to. The "lenp" is a pointer to the length
+The C<ustrp> is a pointer to the character buffer to put the
+conversion result to. The C<lenp> is a pointer to the length
of the result.
-The "swashp" is a pointer to the swash to use.
+The C<swashp> is a pointer to the swash to use.
-Both the special and normal mappings are stored in lib/unicore/To/Foo.pl,
-and loaded by SWASHNEW, using lib/utf8_heavy.pl. The special (usually,
+Both the special and normal mappings are stored in F<lib/unicore/To/Foo.pl>,
+and loaded by SWASHNEW, using F<lib/utf8_heavy.pl>. The C<special> (usually,
but not always, a multicharacter mapping), is tried first.
-The "special" is a string like "utf8::ToSpecLower", which means the
+The C<special> is a string like "utf8::ToSpecLower", which means the
hash %utf8::ToSpecLower. The access to the hash is through
Perl_to_utf8_case().
-The "normal" is a string like "ToLower" which means the swash
+The C<normal> is a string like "ToLower" which means the swash
%utf8::ToLower.
=cut */
@@ -1819,7 +2377,7 @@
dVAR;
U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
STRLEN len = 0;
- const UV uv0 = utf8_to_uvchr(p, NULL);
+ const UV uv0 = valid_utf8_to_uvchr(p, NULL);
/* The NATIVE_TO_UNI() and UNI_TO_NATIVE() mappings
* are necessary in EBCDIC, they are redundant no-ops
* in ASCII-ish platforms, and hopefully optimized away. */
@@ -1852,24 +2410,8 @@
uvuni_to_utf8(tmpbuf, uv1);
if (!*swashp) /* load on-demand */
- *swashp = swash_init("utf8", normal, &PL_sv_undef, 4, 0);
- /* This is the beginnings of a skeleton of code to read the info section
- * that is in all the swashes in case we ever want to do that, so one can
- * read things whose maps aren't code points, and whose default if missing
- * is not to the code point itself. This was just to see if it actually
- * worked. Details on what the possibilities are are in perluniprops.pod
- HV * const hv = get_hv("utf8::SwashInfo", 0);
- if (hv) {
- SV **svp;
- svp = hv_fetch(hv, (const char*)normal, strlen(normal), FALSE);
- const char *s;
+ *swashp = _core_swash_init("utf8", normal, &PL_sv_undef, 4, 0, NULL, NULL);
- HV * const this_hash = SvRV(*svp);
- svp = hv_fetch(this_hash, "type", strlen("type"), FALSE);
- s = SvPV_const(*svp, len);
- }
- }*/
-
if (special) {
/* It might be "special" (sometimes, but not always,
* a multicharacter mapping) */
@@ -1896,7 +2438,7 @@
STRLEN tlen = 0;
while (t < tend) {
- const UV c = utf8_to_uvchr(t, &tlen);
+ const UV c = utf8_to_uvchr_buf(t, tend, &tlen);
if (tlen > 0) {
d = uvchr_to_utf8(d, UNI_TO_NATIVE(c));
t += tlen;
@@ -1921,7 +2463,7 @@
}
if (!len && *swashp) {
- const UV uv2 = swash_fetch(*swashp, tmpbuf, TRUE);
+ const UV uv2 = swash_fetch(*swashp, tmpbuf, TRUE /* => is utf8 */);
if (uv2) {
/* It was "normal" (a single character mapping). */
@@ -1930,21 +2472,80 @@
}
}
- if (!len) /* Neither: just copy. In other words, there was no mapping
- defined, which means that the code point maps to itself */
- len = uvchr_to_utf8(ustrp, uv0) - ustrp;
+ if (len) {
+ if (lenp) {
+ *lenp = len;
+ }
+ return valid_utf8_to_uvchr(ustrp, 0);
+ }
+ /* Here, there was no mapping defined, which means that the code point maps
+ * to itself. Return the inputs */
+ len = UTF8SKIP(p);
+ if (p != ustrp) { /* Don't copy onto itself */
+ Copy(p, ustrp, len, U8);
+ }
+
if (lenp)
*lenp = len;
- return len ? utf8_to_uvchr(ustrp, 0) : 0;
+ return uv0;
+
}
+STATIC UV
+S_check_locale_boundary_crossing(pTHX_ 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 locale. If the result
+ * contains a character that crosses the 255/256 boundary, disallow the
+ * change, and return the original code point. See L<perlfunc/lc> for why;
+ *
+ * p points to the original string whose case was changed; assumed
+ * by this routine to be well-formed
+ * result the code point of the first character in the changed-case string
+ * ustrp points to the changed-case string (<result> represents its first char)
+ * lenp points to the length of <ustrp> */
+
+ UV original; /* To store the first code point of <p> */
+
+ PERL_ARGS_ASSERT_CHECK_LOCALE_BOUNDARY_CROSSING;
+
+ assert(! UTF8_IS_INVARIANT(*p) && ! UTF8_IS_DOWNGRADEABLE_START(*p));
+
+ /* We know immediately if the first character in the string crosses the
+ * boundary, so can skip */
+ if (result > 255) {
+
+ /* Look at every character in the result; if any cross the
+ * boundary, the whole thing is disallowed */
+ U8* s = ustrp + UTF8SKIP(ustrp);
+ U8* e = ustrp + *lenp;
+ while (s < e) {
+ if (UTF8_IS_INVARIANT(*s) || UTF8_IS_DOWNGRADEABLE_START(*s))
+ {
+ goto bad_crossing;
+ }
+ s += UTF8SKIP(s);
+ }
+
+ /* Here, no characters crossed, result is ok as-is */
+ return result;
+ }
+
+bad_crossing:
+
+ /* Failed, have to return the original */
+ original = valid_utf8_to_uvchr(p, lenp);
+ Copy(p, ustrp, *lenp, char);
+ return original;
+}
+
/*
=for apidoc to_utf8_upper
-Convert the UTF-8 encoded character at p to its uppercase version and
-store that in UTF-8 in ustrp and its length in bytes in lenp. Note
+Convert the UTF-8 encoded character at C<p> to its uppercase version and
+store that in UTF-8 in C<ustrp> and its length in bytes in C<lenp>. Note
that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since
the uppercase version may be longer than the original character.
@@ -1951,73 +2552,220 @@
The first character of the uppercased version is returned
(but note, as explained above, that there may be more.)
+The character at C<p> is assumed by this routine to be well-formed.
+
=cut */
+/* Not currently externally documented, and subject to change:
+ * <flags> is set iff locale semantics are to be used for code points < 256
+ * <tainted_ptr> if non-null, *tainted_ptr will be set TRUE iff locale rules
+ * were used in the calculation; otherwise unchanged. */
+
UV
-Perl_to_utf8_upper(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
+Perl__to_utf8_upper_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, const bool flags, bool* tainted_ptr)
{
dVAR;
- PERL_ARGS_ASSERT_TO_UTF8_UPPER;
+ UV result;
- return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
- &PL_utf8_toupper, "ToUpper", "utf8::ToSpecUpper");
+ PERL_ARGS_ASSERT__TO_UTF8_UPPER_FLAGS;
+
+ if (UTF8_IS_INVARIANT(*p)) {
+ if (flags) {
+ result = toUPPER_LC(*p);
+ }
+ else {
+ return _to_upper_title_latin1(*p, ustrp, lenp, 'S');
+ }
+ }
+ else if UTF8_IS_DOWNGRADEABLE_START(*p) {
+ if (flags) {
+ result = toUPPER_LC(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)));
+ }
+ else {
+ return _to_upper_title_latin1(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)),
+ ustrp, lenp, 'S');
+ }
+ }
+ else { /* utf8, ord above 255 */
+ result = CALL_UPPER_CASE(p, ustrp, lenp);
+
+ if (flags) {
+ result = check_locale_boundary_crossing(p, result, ustrp, lenp);
+ }
+ return result;
+ }
+
+ /* Here, used locale rules. Convert back to utf8 */
+ if (UTF8_IS_INVARIANT(result)) {
+ *ustrp = (U8) result;
+ *lenp = 1;
+ }
+ else {
+ *ustrp = UTF8_EIGHT_BIT_HI(result);
+ *(ustrp + 1) = UTF8_EIGHT_BIT_LO(result);
+ *lenp = 2;
+ }
+
+ if (tainted_ptr) {
+ *tainted_ptr = TRUE;
+ }
+ return result;
}
/*
=for apidoc to_utf8_title
-Convert the UTF-8 encoded character at p to its titlecase version and
-store that in UTF-8 in ustrp and its length in bytes in lenp. Note
-that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
+Convert the UTF-8 encoded character at C<p> to its titlecase version and
+store that in UTF-8 in C<ustrp> and its length in bytes in C<lenp>. Note
+that the C<ustrp> needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
titlecase version may be longer than the original character.
The first character of the titlecased version is returned
(but note, as explained above, that there may be more.)
+The character at C<p> is assumed by this routine to be well-formed.
+
=cut */
+/* Not currently externally documented, and subject to change:
+ * <flags> is set iff locale semantics are to be used for code points < 256
+ * Since titlecase is not defined in POSIX, uppercase is used instead
+ * for these/
+ * <tainted_ptr> if non-null, *tainted_ptr will be set TRUE iff locale rules
+ * were used in the calculation; otherwise unchanged. */
+
UV
-Perl_to_utf8_title(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
+Perl__to_utf8_title_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, const bool flags, bool* tainted_ptr)
{
dVAR;
- PERL_ARGS_ASSERT_TO_UTF8_TITLE;
+ UV result;
- return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
- &PL_utf8_totitle, "ToTitle", "utf8::ToSpecTitle");
+ PERL_ARGS_ASSERT__TO_UTF8_TITLE_FLAGS;
+
+ if (UTF8_IS_INVARIANT(*p)) {
+ if (flags) {
+ result = toUPPER_LC(*p);
+ }
+ else {
+ return _to_upper_title_latin1(*p, ustrp, lenp, 's');
+ }
+ }
+ else if UTF8_IS_DOWNGRADEABLE_START(*p) {
+ if (flags) {
+ result = toUPPER_LC(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)));
+ }
+ else {
+ return _to_upper_title_latin1(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)),
+ ustrp, lenp, 's');
+ }
+ }
+ else { /* utf8, ord above 255 */
+ result = CALL_TITLE_CASE(p, ustrp, lenp);
+
+ if (flags) {
+ result = check_locale_boundary_crossing(p, result, ustrp, lenp);
+ }
+ return result;
+ }
+
+ /* Here, used locale rules. Convert back to utf8 */
+ if (UTF8_IS_INVARIANT(result)) {
+ *ustrp = (U8) result;
+ *lenp = 1;
+ }
+ else {
+ *ustrp = UTF8_EIGHT_BIT_HI(result);
+ *(ustrp + 1) = UTF8_EIGHT_BIT_LO(result);
+ *lenp = 2;
+ }
+
+ if (tainted_ptr) {
+ *tainted_ptr = TRUE;
+ }
+ return result;
}
/*
=for apidoc to_utf8_lower
-Convert the UTF-8 encoded character at p to its lowercase version and
-store that in UTF-8 in ustrp and its length in bytes in lenp. Note
-that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
+Convert the UTF-8 encoded character at C<p> to its lowercase version and
+store that in UTF-8 in ustrp and its length in bytes in C<lenp>. Note
+that the C<ustrp> needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
lowercase version may be longer than the original character.
The first character of the lowercased version is returned
(but note, as explained above, that there may be more.)
+The character at C<p> is assumed by this routine to be well-formed.
+
=cut */
+/* Not currently externally documented, and subject to change:
+ * <flags> is set iff locale semantics are to be used for code points < 256
+ * <tainted_ptr> if non-null, *tainted_ptr will be set TRUE iff locale rules
+ * were used in the calculation; otherwise unchanged. */
+
UV
-Perl_to_utf8_lower(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
+Perl__to_utf8_lower_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, const bool flags, bool* tainted_ptr)
{
+ UV result;
+
dVAR;
- PERL_ARGS_ASSERT_TO_UTF8_LOWER;
+ PERL_ARGS_ASSERT__TO_UTF8_LOWER_FLAGS;
- return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
- &PL_utf8_tolower, "ToLower", "utf8::ToSpecLower");
+ if (UTF8_IS_INVARIANT(*p)) {
+ if (flags) {
+ result = toLOWER_LC(*p);
+ }
+ else {
+ return to_lower_latin1(*p, ustrp, lenp);
+ }
+ }
+ else if UTF8_IS_DOWNGRADEABLE_START(*p) {
+ if (flags) {
+ result = toLOWER_LC(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)));
+ }
+ else {
+ return to_lower_latin1(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)),
+ ustrp, lenp);
+ }
+ }
+ else { /* utf8, ord above 255 */
+ result = CALL_LOWER_CASE(p, ustrp, lenp);
+
+ if (flags) {
+ result = check_locale_boundary_crossing(p, result, ustrp, lenp);
+ }
+
+ return result;
+ }
+
+ /* Here, used locale rules. Convert back to utf8 */
+ if (UTF8_IS_INVARIANT(result)) {
+ *ustrp = (U8) result;
+ *lenp = 1;
+ }
+ else {
+ *ustrp = UTF8_EIGHT_BIT_HI(result);
+ *(ustrp + 1) = UTF8_EIGHT_BIT_LO(result);
+ *lenp = 2;
+ }
+
+ if (tainted_ptr) {
+ *tainted_ptr = TRUE;
+ }
+ return result;
}
/*
=for apidoc to_utf8_fold
-Convert the UTF-8 encoded character at p to its foldcase version and
-store that in UTF-8 in ustrp and its length in bytes in lenp. Note
-that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
+Convert the UTF-8 encoded character at C<p> to its foldcase version and
+store that in UTF-8 in C<ustrp> and its length in bytes in C<lenp>. Note
+that the C<ustrp> needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
foldcase version may be longer than the original character (up to
three characters).
@@ -2024,97 +2772,376 @@
The first character of the foldcased version is returned
(but note, as explained above, that there may be more.)
+The character at C<p> is assumed by this routine to be well-formed.
+
=cut */
-/* Not currently externally documented is 'flags', which currently is non-zero
- * if full case folds are to be used; otherwise simple folds */
+/* Not currently externally documented, and subject to change,
+ * in <flags>
+ * bit FOLD_FLAGS_LOCALE is set iff locale semantics are to be used for code
+ * points < 256. Since foldcase is not defined in
+ * POSIX, lowercase is used instead
+ * bit FOLD_FLAGS_FULL is set iff full case folds are to be used;
+ * otherwise simple folds
+ * bit FOLD_FLAGS_NOMIX_ASCII is set iff folds of non-ASCII to ASCII are
+ * prohibited
+ * <tainted_ptr> if non-null, *tainted_ptr will be set TRUE iff locale rules
+ * were used in the calculation; otherwise unchanged. */
UV
-Perl__to_utf8_fold_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, U8 flags)
+Perl__to_utf8_fold_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, U8 flags, bool* tainted_ptr)
{
- const char *specials = (flags) ? "utf8::ToSpecFold" : NULL;
-
dVAR;
+ UV result;
+
PERL_ARGS_ASSERT__TO_UTF8_FOLD_FLAGS;
- return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
- &PL_utf8_tofold, "ToFold", specials);
+ /* These are mutually exclusive */
+ assert (! ((flags & FOLD_FLAGS_LOCALE) && (flags & FOLD_FLAGS_NOMIX_ASCII)));
+
+ assert(p != ustrp); /* Otherwise overwrites */
+
+ if (UTF8_IS_INVARIANT(*p)) {
+ if (flags & FOLD_FLAGS_LOCALE) {
+ result = toLOWER_LC(*p);
+ }
+ else {
+ return _to_fold_latin1(*p, ustrp, lenp,
+ cBOOL(flags & FOLD_FLAGS_FULL));
+ }
+ }
+ else if UTF8_IS_DOWNGRADEABLE_START(*p) {
+ if (flags & FOLD_FLAGS_LOCALE) {
+ result = toLOWER_LC(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)));
+ }
+ else {
+ return _to_fold_latin1(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)),
+ ustrp, lenp,
+ cBOOL((flags & FOLD_FLAGS_FULL
+ /* If ASCII safe, don't allow full
+ * folding, as that could include SHARP
+ * S => ss; otherwise there is no
+ * crossing of ascii/non-ascii in the
+ * latin1 range */
+ && ! (flags & FOLD_FLAGS_NOMIX_ASCII))));
+ }
+ }
+ else { /* utf8, ord above 255 */
+ result = CALL_FOLD_CASE(p, ustrp, lenp, flags & FOLD_FLAGS_FULL);
+
+ if ((flags & FOLD_FLAGS_LOCALE)) {
+ return check_locale_boundary_crossing(p, result, ustrp, lenp);
+ }
+ else if (! (flags & FOLD_FLAGS_NOMIX_ASCII)) {
+ return result;
+ }
+ else {
+ /* This is called when changing the case of a utf8-encoded
+ * character above the Latin1 range, and the result should not
+ * contain an ASCII character. */
+
+ UV original; /* To store the first code point of <p> */
+
+ /* Look at every character in the result; if any cross the
+ * boundary, the whole thing is disallowed */
+ U8* s = ustrp;
+ U8* e = ustrp + *lenp;
+ while (s < e) {
+ if (isASCII(*s)) {
+ /* Crossed, have to return the original */
+ original = valid_utf8_to_uvchr(p, lenp);
+ Copy(p, ustrp, *lenp, char);
+ return original;
+ }
+ s += UTF8SKIP(s);
+ }
+
+ /* Here, no characters crossed, result is ok as-is */
+ return result;
+ }
+ }
+
+ /* Here, used locale rules. Convert back to utf8 */
+ if (UTF8_IS_INVARIANT(result)) {
+ *ustrp = (U8) result;
+ *lenp = 1;
+ }
+ else {
+ *ustrp = UTF8_EIGHT_BIT_HI(result);
+ *(ustrp + 1) = UTF8_EIGHT_BIT_LO(result);
+ *lenp = 2;
+ }
+
+ if (tainted_ptr) {
+ *tainted_ptr = TRUE;
+ }
+ return result;
}
/* Note:
- * A "swash" is a swatch hash.
- * A "swatch" is a bit vector generated by utf8.c:S_swash_get().
+ * Returns a "swash" which is a hash described in utf8.c:Perl_swash_fetch().
* C<pkg> is a pointer to a package name for SWASHNEW, should be "utf8".
* For other parameters, see utf8::SWASHNEW in lib/utf8_heavy.pl.
*/
+
SV*
Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none)
{
+ PERL_ARGS_ASSERT_SWASH_INIT;
+
+ /* Returns a copy of a swash initiated by the called function. This is the
+ * public interface, and returning a copy prevents others from doing
+ * mischief on the original */
+
+ return newSVsv(_core_swash_init(pkg, name, listsv, minbits, none, NULL, NULL));
+}
+
+SV*
+Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none, SV* invlist, U8* const flags_p)
+{
+ /* Initialize and return a swash, creating it if necessary. It does this
+ * by calling utf8_heavy.pl in the general case. The returned value may be
+ * the swash's inversion list instead if the input parameters allow it.
+ * Which is returned should be immaterial to callers, as the only
+ * operations permitted on a swash, swash_fetch(), _get_swash_invlist(),
+ * and swash_to_invlist() handle both these transparently.
+ *
+ * This interface should only be used by functions that won't destroy or
+ * adversely change the swash, as doing so affects all other uses of the
+ * swash in the program; the general public should use 'Perl_swash_init'
+ * instead.
+ *
+ * pkg is the name of the package that <name> should be in.
+ * name is the name of the swash to find. Typically it is a Unicode
+ * property name, including user-defined ones
+ * listsv is a string to initialize the swash with. It must be of the form
+ * documented as the subroutine return value in
+ * L<perlunicode/User-Defined Character Properties>
+ * minbits is the number of bits required to represent each data element.
+ * It is '1' for binary properties.
+ * none I (khw) do not understand this one, but it is used only in tr///.
+ * invlist is an inversion list to initialize the swash with (or NULL)
+ * flags_p if non-NULL is the address of various input and output flag bits
+ * to the routine, as follows: ('I' means is input to the routine;
+ * 'O' means output from the routine. Only flags marked O are
+ * meaningful on return.)
+ * _CORE_SWASH_INIT_USER_DEFINED_PROPERTY indicates if the swash
+ * came from a user-defined property. (I O)
+ * _CORE_SWASH_INIT_RETURN_IF_UNDEF indicates that instead of croaking
+ * when the swash cannot be located, to simply return NULL. (I)
+ * _CORE_SWASH_INIT_ACCEPT_INVLIST indicates that the caller will accept a
+ * return of an inversion list instead of a swash hash if this routine
+ * thinks that would result in faster execution of swash_fetch() later
+ * on. (I)
+ *
+ * Thus there are three possible inputs to find the swash: <name>,
+ * <listsv>, and <invlist>. At least one must be specified. The result
+ * will be the union of the specified ones, although <listsv>'s various
+ * actions can intersect, etc. what <name> gives.
+ *
+ * <invlist> is only valid for binary properties */
+
dVAR;
- SV* retval;
- dSP;
- const size_t pkg_len = strlen(pkg);
- const size_t name_len = strlen(name);
- HV * const stash = gv_stashpvn(pkg, pkg_len, 0);
- SV* errsv_save;
- GV *method;
+ SV* retval = &PL_sv_undef;
+ HV* swash_hv = NULL;
+ const int invlist_swash_boundary =
+ (flags_p && *flags_p & _CORE_SWASH_INIT_ACCEPT_INVLIST)
+ ? 512 /* Based on some benchmarking, but not extensive, see commit
+ message */
+ : -1; /* Never return just an inversion list */
- PERL_ARGS_ASSERT_SWASH_INIT;
+ assert(listsv != &PL_sv_undef || strNE(name, "") || invlist);
+ assert(! invlist || minbits == 1);
- PUSHSTACKi(PERLSI_MAGIC);
- ENTER;
- SAVEHINTS();
- save_re_context();
- method = gv_fetchmeth(stash, "SWASHNEW", 8, -1);
- if (!method) { /* demand load utf8 */
+ /* If data was passed in to go out to utf8_heavy to find the swash of, do
+ * so */
+ if (listsv != &PL_sv_undef || strNE(name, "")) {
+ dSP;
+ const size_t pkg_len = strlen(pkg);
+ const size_t name_len = strlen(name);
+ HV * const stash = gv_stashpvn(pkg, pkg_len, 0);
+ SV* errsv_save;
+ GV *method;
+
+ PERL_ARGS_ASSERT__CORE_SWASH_INIT;
+
+ PUSHSTACKi(PERLSI_MAGIC);
ENTER;
- errsv_save = newSVsv(ERRSV);
- /* It is assumed that callers of this routine are not passing in any
- user derived data. */
- /* Need to do this after save_re_context() as it will set PL_tainted to
- 1 while saving $1 etc (see the code after getrx: in Perl_magic_get).
- Even line to create errsv_save can turn on PL_tainted. */
- SAVEBOOL(PL_tainted);
- PL_tainted = 0;
- Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(pkg,pkg_len),
- NULL);
- if (!SvTRUE(ERRSV))
- sv_setsv(ERRSV, errsv_save);
- SvREFCNT_dec(errsv_save);
+ SAVEHINTS();
+ save_re_context();
+ /* We might get here via a subroutine signature which uses a utf8
+ * parameter name, at which point PL_subname will have been set
+ * but not yet used. */
+ save_item(PL_subname);
+ if (PL_parser && PL_parser->error_count)
+ SAVEI8(PL_parser->error_count), PL_parser->error_count = 0;
+ method = gv_fetchmeth(stash, "SWASHNEW", 8, -1);
+ if (!method) { /* demand load utf8 */
+ ENTER;
+ if ((errsv_save = GvSV(PL_errgv))) SAVEFREESV(errsv_save);
+ GvSV(PL_errgv) = NULL;
+ /* It is assumed that callers of this routine are not passing in
+ * any user derived data. */
+ /* Need to do this after save_re_context() as it will set
+ * PL_tainted to 1 while saving $1 etc (see the code after getrx:
+ * in Perl_magic_get). Even line to create errsv_save can turn on
+ * PL_tainted. */
+#ifndef NO_TAINT_SUPPORT
+ SAVEBOOL(TAINT_get);
+ TAINT_NOT;
+#endif
+ Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(pkg,pkg_len),
+ NULL);
+ {
+ /* Not ERRSV, as there is no need to vivify a scalar we are
+ about to discard. */
+ SV * const errsv = GvSV(PL_errgv);
+ if (!SvTRUE(errsv)) {
+ GvSV(PL_errgv) = SvREFCNT_inc_simple(errsv_save);
+ SvREFCNT_dec(errsv);
+ }
+ }
+ LEAVE;
+ }
+ SPAGAIN;
+ PUSHMARK(SP);
+ EXTEND(SP,5);
+ mPUSHp(pkg, pkg_len);
+ mPUSHp(name, name_len);
+ PUSHs(listsv);
+ mPUSHi(minbits);
+ mPUSHi(none);
+ PUTBACK;
+ if ((errsv_save = GvSV(PL_errgv))) SAVEFREESV(errsv_save);
+ GvSV(PL_errgv) = NULL;
+ /* If we already have a pointer to the method, no need to use
+ * call_method() to repeat the lookup. */
+ if (method
+ ? call_sv(MUTABLE_SV(method), G_SCALAR)
+ : call_sv(newSVpvs_flags("SWASHNEW", SVs_TEMP), G_SCALAR | G_METHOD))
+ {
+ retval = *PL_stack_sp--;
+ SvREFCNT_inc(retval);
+ }
+ {
+ /* Not ERRSV. See above. */
+ SV * const errsv = GvSV(PL_errgv);
+ if (!SvTRUE(errsv)) {
+ GvSV(PL_errgv) = SvREFCNT_inc_simple(errsv_save);
+ SvREFCNT_dec(errsv);
+ }
+ }
LEAVE;
+ POPSTACK;
+ if (IN_PERL_COMPILETIME) {
+ CopHINTS_set(PL_curcop, PL_hints);
+ }
+ if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV) {
+ if (SvPOK(retval))
+
+ /* If caller wants to handle missing properties, let them */
+ if (flags_p && *flags_p & _CORE_SWASH_INIT_RETURN_IF_UNDEF) {
+ return NULL;
+ }
+ Perl_croak(aTHX_
+ "Can't find Unicode property definition \"%"SVf"\"",
+ SVfARG(retval));
+ Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
+ }
+ } /* End of calling the module to find the swash */
+
+ /* If this operation fetched a swash, and we will need it later, get it */
+ if (retval != &PL_sv_undef
+ && (minbits == 1 || (flags_p
+ && ! (*flags_p
+ & _CORE_SWASH_INIT_USER_DEFINED_PROPERTY))))
+ {
+ swash_hv = MUTABLE_HV(SvRV(retval));
+
+ /* If we don't already know that there is a user-defined component to
+ * this swash, and the user has indicated they wish to know if there is
+ * one (by passing <flags_p>), find out */
+ if (flags_p && ! (*flags_p & _CORE_SWASH_INIT_USER_DEFINED_PROPERTY)) {
+ SV** user_defined = hv_fetchs(swash_hv, "USER_DEFINED", FALSE);
+ if (user_defined && SvUV(*user_defined)) {
+ *flags_p |= _CORE_SWASH_INIT_USER_DEFINED_PROPERTY;
+ }
+ }
}
- SPAGAIN;
- PUSHMARK(SP);
- EXTEND(SP,5);
- mPUSHp(pkg, pkg_len);
- mPUSHp(name, name_len);
- PUSHs(listsv);
- mPUSHi(minbits);
- mPUSHi(none);
- PUTBACK;
- errsv_save = newSVsv(ERRSV);
- /* If we already have a pointer to the method, no need to use call_method()
- to repeat the lookup. */
- if (method ? call_sv(MUTABLE_SV(method), G_SCALAR)
- : call_sv(newSVpvs_flags("SWASHNEW", SVs_TEMP), G_SCALAR | G_METHOD))
- retval = newSVsv(*PL_stack_sp--);
- else
- retval = &PL_sv_undef;
- if (!SvTRUE(ERRSV))
- sv_setsv(ERRSV, errsv_save);
- SvREFCNT_dec(errsv_save);
- LEAVE;
- POPSTACK;
- if (IN_PERL_COMPILETIME) {
- CopHINTS_set(PL_curcop, PL_hints);
+
+ /* Make sure there is an inversion list for binary properties */
+ if (minbits == 1) {
+ SV** swash_invlistsvp = NULL;
+ SV* swash_invlist = NULL;
+ bool invlist_in_swash_is_valid = FALSE;
+ bool swash_invlist_unclaimed = FALSE; /* whether swash_invlist has
+ an unclaimed reference count */
+
+ /* If this operation fetched a swash, get its already existing
+ * inversion list, or create one for it */
+
+ if (swash_hv) {
+ swash_invlistsvp = hv_fetchs(swash_hv, "V", FALSE);
+ if (swash_invlistsvp) {
+ swash_invlist = *swash_invlistsvp;
+ invlist_in_swash_is_valid = TRUE;
+ }
+ else {
+ swash_invlist = _swash_to_invlist(retval);
+ swash_invlist_unclaimed = TRUE;
+ }
+ }
+
+ /* If an inversion list was passed in, have to include it */
+ if (invlist) {
+
+ /* Any fetched swash will by now have an inversion list in it;
+ * otherwise <swash_invlist> will be NULL, indicating that we
+ * didn't fetch a swash */
+ if (swash_invlist) {
+
+ /* Add the passed-in inversion list, which invalidates the one
+ * already stored in the swash */
+ invlist_in_swash_is_valid = FALSE;
+ _invlist_union(invlist, swash_invlist, &swash_invlist);
+ }
+ else {
+
+ /* Here, there is no swash already. Set up a minimal one, if
+ * we are going to return a swash */
+ if ((int) _invlist_len(invlist) > invlist_swash_boundary) {
+ swash_hv = newHV();
+ retval = newRV_noinc(MUTABLE_SV(swash_hv));
+ }
+ swash_invlist = invlist;
+ }
+ }
+
+ /* Here, we have computed the union of all the passed-in data. It may
+ * be that there was an inversion list in the swash which didn't get
+ * touched; otherwise save the one computed one */
+ if (! invlist_in_swash_is_valid
+ && (int) _invlist_len(swash_invlist) > invlist_swash_boundary)
+ {
+ if (! hv_stores(MUTABLE_HV(SvRV(retval)), "V", swash_invlist))
+ {
+ Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
+ }
+ /* We just stole a reference count. */
+ if (swash_invlist_unclaimed) swash_invlist_unclaimed = FALSE;
+ else SvREFCNT_inc_simple_void_NN(swash_invlist);
+ }
+
+ /* Use the inversion list stand-alone if small enough */
+ if ((int) _invlist_len(swash_invlist) <= invlist_swash_boundary) {
+ SvREFCNT_dec(retval);
+ if (!swash_invlist_unclaimed)
+ SvREFCNT_inc_simple_void_NN(swash_invlist);
+ retval = newRV_noinc(swash_invlist);
+ }
}
- if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV) {
- if (SvPOK(retval))
- Perl_croak(aTHX_ "Can't find Unicode property definition \"%"SVf"\"",
- SVfARG(retval));
- Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
- }
+
return retval;
}
@@ -2125,7 +3152,7 @@
* the lower-level routine, and it is similarly broken for returning
* multiple values. --jhi
* For those, you should use to_utf8_case() instead */
-/* Now SWASHGET is recasted into S_swash_get in this file. */
+/* Now SWASHGET is recasted into S_swatch_get in this file. */
/* Note:
* Returns the value of property/mapping C<swash> for the first character
@@ -2132,6 +3159,34 @@
* of the string C<ptr>. If C<do_utf8> is true, the string C<ptr> is
* assumed to be in utf8. If C<do_utf8> is false, the string C<ptr> is
* assumed to be in native 8-bit encoding. Caches the swatch in C<swash>.
+ *
+ * A "swash" is a hash which contains initially the keys/values set up by
+ * SWASHNEW. The purpose is to be able to completely represent a Unicode
+ * property for all possible code points. Things are stored in a compact form
+ * (see utf8_heavy.pl) so that calculation is required to find the actual
+ * property value for a given code point. As code points are looked up, new
+ * key/value pairs are added to the hash, so that the calculation doesn't have
+ * to ever be re-done. Further, each calculation is done, not just for the
+ * desired one, but for a whole block of code points adjacent to that one.
+ * For binary properties on ASCII machines, the block is usually for 64 code
+ * points, starting with a code point evenly divisible by 64. Thus if the
+ * property value for code point 257 is requested, the code goes out and
+ * calculates the property values for all 64 code points between 256 and 319,
+ * and stores these as a single 64-bit long bit vector, called a "swatch",
+ * under the key for code point 256. The key is the UTF-8 encoding for code
+ * point 256, minus the final byte. Thus, if the length of the UTF-8 encoding
+ * for a code point is 13 bytes, the key will be 12 bytes long. If the value
+ * for code point 258 is then requested, this code realizes that it would be
+ * stored under the key for 256, and would find that value and extract the
+ * relevant bit, offset from 256.
+ *
+ * Non-binary properties are stored in as many bits as necessary to represent
+ * their values (32 currently, though the code is more general than that), not
+ * as single bits, but the principal is the same: the value for each key is a
+ * vector that encompasses the property values for all code points whose UTF-8
+ * representations are represented by the key. That is, for all code points
+ * whose UTF-8 representations are length N bytes, and the key is the first N-1
+ * bytes of that.
*/
UV
Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8)
@@ -2150,6 +3205,16 @@
PERL_ARGS_ASSERT_SWASH_FETCH;
+ /* If it really isn't a hash, it isn't really swash; must be an inversion
+ * list */
+ if (SvTYPE(hv) != SVt_PVHV) {
+ return _invlist_contains_cp((SV*)hv,
+ (do_utf8)
+ ? valid_utf8_to_uvchr(ptr, NULL)
+ : c);
+ }
+
+ /* Convert to utf8 if not already */
if (!do_utf8 && !UNI_IS_INVARIANT(c)) {
tmputf8[0] = (U8)UTF8_EIGHT_BIT_HI(c);
tmputf8[1] = (U8)UTF8_EIGHT_BIT_LO(c);
@@ -2174,18 +3239,6 @@
/* If char is encoded then swatch is for the prefix */
needents = (1 << UTF_ACCUMULATION_SHIFT);
off = NATIVE_TO_UTF(ptr[klen]) & UTF_CONTINUATION_MASK;
- if (UTF8_IS_SUPER(ptr) && ckWARN_d(WARN_NON_UNICODE)) {
- const UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXBYTES, 0, 0);
-
- /* This outputs warnings for binary properties only, assuming that
- * to_utf8_case() will output any. Also, surrogates aren't checked
- * for, as that would warn on things like /\p{Gc=Cs}/ */
- SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
- if (SvUV(*bitssvp) == 1) {
- Perl_warner(aTHX_ packWARN(WARN_NON_UNICODE),
- "Code point 0x%04"UVXf" is not Unicode, no properties match it; all inverse properties do", code_point);
- }
- }
}
/*
@@ -2208,7 +3261,7 @@
/* Try our second-level swatch cache, kept in a hash. */
SV** svp = hv_fetch(hv, (const char*)ptr, klen, FALSE);
- /* If not cached, generate it via swash_get */
+ /* If not cached, generate it via swatch_get */
if (!svp || !SvPOK(*svp)
|| !(tmps = (const U8*)SvPV_const(*svp, slen))) {
/* We use utf8n_to_uvuni() as we want an index into
@@ -2217,9 +3270,9 @@
const UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXBYTES, 0,
ckWARN(WARN_UTF8) ?
0 : UTF8_ALLOW_ANY);
- swatch = swash_get(swash,
+ swatch = swatch_get(swash,
/* On EBCDIC & ~(0xA0-1) isn't a useful thing to do */
- (klen) ? (code_point & ~(needents - 1)) : 0,
+ (klen) ? (code_point & ~((UV)needents - 1)) : 0,
needents);
if (IN_PERL_COMPILETIME)
@@ -2229,7 +3282,9 @@
if (!svp || !(tmps = (U8*)SvPV(*svp, slen))
|| (slen << 3) < needents)
- Perl_croak(aTHX_ "panic: swash_fetch got improper swatch");
+ Perl_croak(aTHX_ "panic: swash_fetch got improper swatch, "
+ "svp=%p, tmps=%p, slen=%"UVuf", needents=%"UVuf,
+ svp, tmps, (UV)slen, (UV)needents);
}
PL_last_swash_hv = hv;
@@ -2256,7 +3311,8 @@
off <<= 2;
return (tmps[off] << 24) + (tmps[off+1] << 16) + (tmps[off+2] << 8) + tmps[off + 3] ;
}
- Perl_croak(aTHX_ "panic: swash_fetch got swatch of unexpected bit width");
+ Perl_croak(aTHX_ "panic: swash_fetch got swatch of unexpected bit width, "
+ "slen=%"UVuf", needents=%"UVuf, (UV)slen, (UV)needents);
NORETURN_FUNCTION_END;
}
@@ -2284,7 +3340,9 @@
{
const int typeto = typestr[0] == 'T' && typestr[1] == 'o';
STRLEN numlen; /* Length of the number */
- I32 flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
+ I32 flags = PERL_SCAN_SILENT_ILLDIGIT
+ | PERL_SCAN_DISALLOW_PREFIX
+ | PERL_SCAN_SILENT_NON_PORTABLE;
/* nl points to the next \n in the scan */
U8* const nl = (U8*)memchr(l, '\n', lend - l);
@@ -2304,7 +3362,9 @@
/* The max range value follows, separated by a BLANK */
if (isBLANK(*l)) {
++l;
- flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
+ flags = PERL_SCAN_SILENT_ILLDIGIT
+ | PERL_SCAN_DISALLOW_PREFIX
+ | PERL_SCAN_SILENT_NON_PORTABLE;
numlen = lend - l;
*max = grok_hex((char *)l, &numlen, &flags, NULL);
if (numlen)
@@ -2317,18 +3377,31 @@
if (wants_value) {
if (isBLANK(*l)) {
++l;
- flags = PERL_SCAN_SILENT_ILLDIGIT |
- PERL_SCAN_DISALLOW_PREFIX;
- numlen = lend - l;
- *val = grok_hex((char *)l, &numlen, &flags, NULL);
- if (numlen)
- l += numlen;
- else
- *val = 0;
+
+ /* The ToLc, etc table mappings are not in hex, and must be
+ * corrected by adding the code point to them */
+ if (typeto) {
+ char *after_strtol = (char *) lend;
+ *val = Strtol((char *)l, &after_strtol, 10);
+ l = (U8 *) after_strtol;
+ }
+ else { /* Other tables are in hex, and are the correct result
+ without tweaking */
+ flags = PERL_SCAN_SILENT_ILLDIGIT
+ | PERL_SCAN_DISALLOW_PREFIX
+ | PERL_SCAN_SILENT_NON_PORTABLE;
+ numlen = lend - l;
+ *val = grok_hex((char *)l, &numlen, &flags, NULL);
+ if (numlen)
+ l += numlen;
+ else
+ *val = 0;
+ }
}
else {
*val = 0;
if (typeto) {
+ /* diag_listed_as: To%s: illegal mapping '%s' */
Perl_croak(aTHX_ "%s: illegal mapping '%s'",
typestr, l);
}
@@ -2343,6 +3416,7 @@
if (wants_value) {
*val = 0;
if (typeto) {
+ /* diag_listed_as: To%s: illegal mapping '%s' */
Perl_croak(aTHX_ "%s: illegal mapping '%s'", typestr, l);
}
}
@@ -2366,33 +3440,54 @@
* Should be used via swash_fetch, which will cache the swatch in C<swash>.
*/
STATIC SV*
-S_swash_get(pTHX_ SV* swash, UV start, UV span)
+S_swatch_get(pTHX_ SV* swash, UV start, UV span)
{
SV *swatch;
- U8 *l, *lend, *x, *xend, *s;
+ U8 *l, *lend, *x, *xend, *s, *send;
STRLEN lcur, xcur, scur;
HV *const hv = MUTABLE_HV(SvRV(swash));
+ SV** const invlistsvp = hv_fetchs(hv, "V", FALSE);
- /* The string containing the main body of the table */
- SV** const listsvp = hv_fetchs(hv, "LIST", FALSE);
+ SV** listsvp = NULL; /* The string containing the main body of the table */
+ SV** extssvp = NULL;
+ SV** invert_it_svp = NULL;
+ U8* typestr = NULL;
+ STRLEN bits;
+ STRLEN octets; /* if bits == 1, then octets == 0 */
+ UV none;
+ UV end = start + span;
- SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
- SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
- SV** const nonesvp = hv_fetchs(hv, "NONE", FALSE);
- SV** const extssvp = hv_fetchs(hv, "EXTRAS", FALSE);
- const U8* const typestr = (U8*)SvPV_nolen(*typesvp);
- const STRLEN bits = SvUV(*bitssvp);
- const STRLEN octets = bits >> 3; /* if bits == 1, then octets == 0 */
- const UV none = SvUV(*nonesvp);
- const UV end = start + span;
+ if (invlistsvp == NULL) {
+ SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
+ SV** const nonesvp = hv_fetchs(hv, "NONE", FALSE);
+ SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
+ extssvp = hv_fetchs(hv, "EXTRAS", FALSE);
+ listsvp = hv_fetchs(hv, "LIST", FALSE);
+ invert_it_svp = hv_fetchs(hv, "INVERT_IT", FALSE);
- PERL_ARGS_ASSERT_SWASH_GET;
+ bits = SvUV(*bitssvp);
+ none = SvUV(*nonesvp);
+ typestr = (U8*)SvPV_nolen(*typesvp);
+ }
+ else {
+ bits = 1;
+ none = 0;
+ }
+ octets = bits >> 3; /* if bits == 1, then octets == 0 */
+ PERL_ARGS_ASSERT_SWATCH_GET;
+
if (bits != 1 && bits != 8 && bits != 16 && bits != 32) {
- Perl_croak(aTHX_ "panic: swash_get doesn't expect bits %"UVuf,
+ Perl_croak(aTHX_ "panic: swatch_get doesn't expect bits %"UVuf,
(UV)bits);
}
+ /* If overflowed, use the max possible */
+ if (end < start) {
+ end = UV_MAX;
+ span = end - start;
+ }
+
/* create and initialize $swatch */
scur = octets ? (span * octets) : (span + 7) / 8;
swatch = newSV(scur);
@@ -2422,11 +3517,16 @@
SvCUR_set(swatch, scur);
s = (U8*)SvPVX(swatch);
+ if (invlistsvp) { /* If has an inversion list set up use that */
+ _invlist_populate_swatch(*invlistsvp, start, end, s);
+ return swatch;
+ }
+
/* read $swash->{LIST} */
l = (U8*)SvPV(*listsvp, lcur);
lend = l + lcur;
while (l < lend) {
- UV min, max, val;
+ UV min, max, val, upper;
l = S_swash_scan_list_line(aTHX_ l, lend, &min, &max, &val,
cBOOL(octets), typestr);
if (l > lend) {
@@ -2437,6 +3537,15 @@
if (max < start)
continue;
+ /* <end> is generally 1 beyond where we want to set things, but at the
+ * platform's infinity, where we can't go any higher, we want to
+ * include the code point at <end> */
+ upper = (max < end)
+ ? max
+ : (max != UV_MAX || end != UV_MAX)
+ ? end - 1
+ : end;
+
if (octets) {
UV key;
if (min < start) {
@@ -2445,10 +3554,8 @@
}
min = start;
}
- for (key = min; key <= max; key++) {
+ for (key = min; key <= upper; key++) {
STRLEN offset;
- if (key >= end)
- goto go_out_list;
/* offset must be non-negative (start <= min <= key < end) */
offset = octets * (key - start);
if (bits == 8)
@@ -2472,17 +3579,39 @@
UV key;
if (min < start)
min = start;
- for (key = min; key <= max; key++) {
+
+ for (key = min; key <= upper; key++) {
const STRLEN offset = (STRLEN)(key - start);
- if (key >= end)
- goto go_out_list;
s[offset >> 3] |= 1 << (offset & 7);
}
}
} /* while */
- go_out_list:
- /* read $swash->{EXTRAS} */
+ /* Invert if the data says it should be. Assumes that bits == 1 */
+ if (invert_it_svp && SvUV(*invert_it_svp)) {
+
+ /* Unicode properties should come with all bits above PERL_UNICODE_MAX
+ * be 0, and their inversion should also be 0, as we don't succeed any
+ * Unicode property matches for non-Unicode code points */
+ if (start <= PERL_UNICODE_MAX) {
+
+ /* The code below assumes that we never cross the
+ * Unicode/above-Unicode boundary in a range, as otherwise we would
+ * have to figure out where to stop flipping the bits. Since this
+ * boundary is divisible by a large power of 2, and swatches comes
+ * in small powers of 2, this should be a valid assumption */
+ assert(start + span - 1 <= PERL_UNICODE_MAX);
+
+ send = s + scur;
+ while (s < send) {
+ *s = ~(*s);
+ s++;
+ }
+ }
+ }
+
+ /* read $swash->{EXTRAS}
+ * This code also copied to swash_to_invlist() below */
x = (U8*)SvPV(*extssvp, xcur);
xend = x + xcur;
while (x < xend) {
@@ -2527,19 +3656,22 @@
otherbitssvp = hv_fetchs(otherhv, "BITS", FALSE);
otherbits = (STRLEN)SvUV(*otherbitssvp);
if (bits < otherbits)
- Perl_croak(aTHX_ "panic: swash_get found swatch size mismatch");
+ Perl_croak(aTHX_ "panic: swatch_get found swatch size mismatch, "
+ "bits=%"UVuf", otherbits=%"UVuf, (UV)bits, (UV)otherbits);
/* The "other" swatch must be destroyed after. */
- other = swash_get(*othersvp, start, span);
+ other = swatch_get(*othersvp, start, span);
o = (U8*)SvPV(other, olen);
if (!olen)
- Perl_croak(aTHX_ "panic: swash_get got improper swatch");
+ Perl_croak(aTHX_ "panic: swatch_get got improper swatch");
s = (U8*)SvPV(swatch, slen);
if (bits == 1 && otherbits == 1) {
if (slen != olen)
- Perl_croak(aTHX_ "panic: swash_get found swatch length mismatch");
+ Perl_croak(aTHX_ "panic: swatch_get found swatch length "
+ "mismatch, slen=%"UVuf", olen=%"UVuf,
+ (UV)slen, (UV)olen);
switch (opc) {
case '+':
@@ -2619,7 +3751,11 @@
Perl__swash_inversion_hash(pTHX_ SV* const swash)
{
- /* Subject to change or removal. For use only in one place in regexec.c
+ /* Subject to change or removal. For use only in regcomp.c and regexec.c
+ * Can't be used on a property that is subject to user override, as it
+ * relies on the value of SPECIALS in the swash which would be set by
+ * utf8_heavy.pl to the hash in the non-overriden file, and hence is not set
+ * for overridden properties
*
* Returns a hash which is the inversion and closure of a swash mapping.
* For example, consider the input lines:
@@ -2635,14 +3771,29 @@
* Essentially, for any code point, it gives all the code points that map to
* it, or the list of 'froms' for that point.
*
- * Currently it only looks at the main body of the swash, and ignores any
- * additions or deletions from other swashes */
+ * Currently it ignores any additions or deletions from other swashes,
+ * looking at just the main body of the swash, and if there are SPECIALS
+ * in the swash, at that hash
+ *
+ * The specials hash can be extra code points, and most likely consists of
+ * maps from single code points to multiple ones (each expressed as a string
+ * of utf8 characters). This function currently returns only 1-1 mappings.
+ * However consider this possible input in the specials hash:
+ * "\xEF\xAC\x85" => "\x{0073}\x{0074}", # U+FB05 => 0073 0074
+ * "\xEF\xAC\x86" => "\x{0073}\x{0074}", # U+FB06 => 0073 0074
+ *
+ * Both FB05 and FB06 map to the same multi-char sequence, which we don't
+ * currently handle. But it also means that FB05 and FB06 are equivalent in
+ * a 1-1 mapping which we should handle, and this relationship may not be in
+ * the main table. Therefore this function examines all the multi-char
+ * sequences and adds the 1-1 mappings that come out of that. */
U8 *l, *lend;
STRLEN lcur;
HV *const hv = MUTABLE_HV(SvRV(swash));
- /* The string containing the main body of the table */
+ /* The string containing the main body of the table. This will have its
+ * assertion fail if the swash has been converted to its inversion list */
SV** const listsvp = hv_fetchs(hv, "LIST", FALSE);
SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
@@ -2653,6 +3804,7 @@
const STRLEN bits = SvUV(*bitssvp);
const STRLEN octets = bits >> 3; /* if bits == 1, then octets == 0 */
const UV none = SvUV(*nonesvp);
+ SV **specials_p = hv_fetchs(hv, "SPECIALS", 0);
HV* ret = newHV();
@@ -2664,6 +3816,118 @@
(UV)bits);
}
+ if (specials_p) { /* It might be "special" (sometimes, but not always, a
+ mapping to more than one character */
+
+ /* Construct an inverse mapping hash for the specials */
+ HV * const specials_hv = MUTABLE_HV(SvRV(*specials_p));
+ HV * specials_inverse = newHV();
+ char *char_from; /* the lhs of the map */
+ I32 from_len; /* its byte length */
+ char *char_to; /* the rhs of the map */
+ I32 to_len; /* its byte length */
+ SV *sv_to; /* and in a sv */
+ AV* from_list; /* list of things that map to each 'to' */
+
+ hv_iterinit(specials_hv);
+
+ /* The keys are the characters (in utf8) that map to the corresponding
+ * utf8 string value. Iterate through the list creating the inverse
+ * list. */
+ while ((sv_to = hv_iternextsv(specials_hv, &char_from, &from_len))) {
+ SV** listp;
+ if (! SvPOK(sv_to)) {
+ Perl_croak(aTHX_ "panic: value returned from hv_iternextsv() "
+ "unexpectedly is not a string, flags=%lu",
+ (unsigned long)SvFLAGS(sv_to));
+ }
+ /*DEBUG_U(PerlIO_printf(Perl_debug_log, "Found mapping from %"UVXf", First char of to is %"UVXf"\n", valid_utf8_to_uvchr((U8*) char_from, 0), valid_utf8_to_uvchr((U8*) SvPVX(sv_to), 0)));*/
+
+ /* Each key in the inverse list is a mapped-to value, and the key's
+ * hash value is a list of the strings (each in utf8) that map to
+ * it. Those strings are all one character long */
+ if ((listp = hv_fetch(specials_inverse,
+ SvPVX(sv_to),
+ SvCUR(sv_to), 0)))
+ {
+ from_list = (AV*) *listp;
+ }
+ else { /* No entry yet for it: create one */
+ from_list = newAV();
+ if (! hv_store(specials_inverse,
+ SvPVX(sv_to),
+ SvCUR(sv_to),
+ (SV*) from_list, 0))
+ {
+ Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
+ }
+ }
+
+ /* Here have the list associated with this 'to' (perhaps newly
+ * created and empty). Just add to it. Note that we ASSUME that
+ * the input is guaranteed to not have duplications, so we don't
+ * check for that. Duplications just slow down execution time. */
+ av_push(from_list, newSVpvn_utf8(char_from, from_len, TRUE));
+ }
+
+ /* Here, 'specials_inverse' contains the inverse mapping. Go through
+ * it looking for cases like the FB05/FB06 examples above. There would
+ * be an entry in the hash like
+ * 'st' => [ FB05, FB06 ]
+ * In this example we will create two lists that get stored in the
+ * returned hash, 'ret':
+ * FB05 => [ FB05, FB06 ]
+ * FB06 => [ FB05, FB06 ]
+ *
+ * Note that there is nothing to do if the array only has one element.
+ * (In the normal 1-1 case handled below, we don't have to worry about
+ * two lists, as everything gets tied to the single list that is
+ * generated for the single character 'to'. But here, we are omitting
+ * that list, ('st' in the example), so must have multiple lists.) */
+ while ((from_list = (AV *) hv_iternextsv(specials_inverse,
+ &char_to, &to_len)))
+ {
+ if (av_len(from_list) > 0) {
+ int i;
+
+ /* We iterate over all combinations of i,j to place each code
+ * point on each list */
+ for (i = 0; i <= av_len(from_list); i++) {
+ int j;
+ AV* i_list = newAV();
+ SV** entryp = av_fetch(from_list, i, FALSE);
+ if (entryp == NULL) {
+ Perl_croak(aTHX_ "panic: av_fetch() unexpectedly failed");
+ }
+ if (hv_fetch(ret, SvPVX(*entryp), SvCUR(*entryp), FALSE)) {
+ Perl_croak(aTHX_ "panic: unexpected entry for %s", SvPVX(*entryp));
+ }
+ if (! hv_store(ret, SvPVX(*entryp), SvCUR(*entryp),
+ (SV*) i_list, FALSE))
+ {
+ Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
+ }
+
+ /* For debugging: UV u = valid_utf8_to_uvchr((U8*) SvPVX(*entryp), 0);*/
+ for (j = 0; j <= av_len(from_list); j++) {
+ entryp = av_fetch(from_list, j, FALSE);
+ if (entryp == NULL) {
+ Perl_croak(aTHX_ "panic: av_fetch() unexpectedly failed");
+ }
+
+ /* When i==j this adds itself to the list */
+ av_push(i_list, newSVuv(utf8_to_uvchr_buf(
+ (U8*) SvPVX(*entryp),
+ (U8*) SvPVX(*entryp) + SvCUR(*entryp),
+ 0)));
+ /*DEBUG_U(PerlIO_printf(Perl_debug_log, "%s: %d: Adding %"UVXf" to list for %"UVXf"\n", __FILE__, __LINE__, valid_utf8_to_uvchr((U8*) SvPVX(*entryp), 0), u));*/
+ }
+ }
+ }
+ }
+ SvREFCNT_dec(specials_inverse); /* done with it */
+ } /* End of specials */
+
/* read $swash->{LIST} */
l = (U8*)SvPV(*listsvp, lcur);
lend = l + lcur;
@@ -2681,10 +3945,10 @@
/* Each element in the range is to be inverted */
for (inverse = min; inverse <= max; inverse++) {
AV* list;
- SV* element;
SV** listp;
IV i;
bool found_key = FALSE;
+ bool found_inverse = FALSE;
/* The key is the inverse mapping */
char key[UTF8_MAXBYTES+1];
@@ -2702,7 +3966,9 @@
}
}
- for (i = 0; i < av_len(list); i++) {
+ /* Look through list to see if this inverse mapping already is
+ * listed, or if there is a mapping to itself already */
+ for (i = 0; i <= av_len(list); i++) {
SV** entryp = av_fetch(list, i, FALSE);
SV* entry;
if (entryp == NULL) {
@@ -2709,8 +3975,17 @@
Perl_croak(aTHX_ "panic: av_fetch() unexpectedly failed");
}
entry = *entryp;
+ /*DEBUG_U(PerlIO_printf(Perl_debug_log, "list for %"UVXf" contains %"UVXf"\n", val, SvUV(entry)));*/
if (SvUV(entry) == val) {
found_key = TRUE;
+ }
+ if (SvUV(entry) == inverse) {
+ found_inverse = TRUE;
+ }
+
+ /* No need to continue searching if found everything we are
+ * looking for */
+ if (found_key && found_inverse) {
break;
}
}
@@ -2717,22 +3992,25 @@
/* Make sure there is a mapping to itself on the list */
if (! found_key) {
- element = newSVuv(val);
- av_push(list, element);
+ av_push(list, newSVuv(val));
+ /*DEBUG_U(PerlIO_printf(Perl_debug_log, "%s: %d: Adding %"UVXf" to list for %"UVXf"\n", __FILE__, __LINE__, val, val));*/
}
/* Simply add the value to the list */
- element = newSVuv(inverse);
- av_push(list, element);
+ if (! found_inverse) {
+ av_push(list, newSVuv(inverse));
+ /*DEBUG_U(PerlIO_printf(Perl_debug_log, "%s: %d: Adding %"UVXf" to list for %"UVXf"\n", __FILE__, __LINE__, inverse, val));*/
+ }
- /* swash_get() increments the value of val for each element in the
+ /* swatch_get() increments the value of val for each element in the
* range. That makes more compact tables possible. You can
* express the capitalization, for example, of all consecutive
* letters with a single line: 0061\t007A\t0041 This maps 0061 to
* 0041, 0062 to 0042, etc. I (khw) have never understood 'none',
- * and it's not documented, and perhaps not even currently used,
- * but I copied the semantics from swash_get(), just in case */
+ * and it's not documented; it appears to be used only in
+ * implementing tr//; I copied the semantics from swatch_get(), just
+ * in case */
if (!none || val < none) {
++val;
}
@@ -2742,11 +4020,12 @@
return ret;
}
-HV*
+SV*
Perl__swash_to_invlist(pTHX_ SV* const swash)
{
- /* Subject to change or removal. For use only in one place in regcomp.c */
+ /* Subject to change or removal. For use only in one place in regcomp.c.
+ * Ownership is given to one reference count in the returned SV* */
U8 *l, *lend;
char *loc;
@@ -2754,20 +4033,38 @@
HV *const hv = MUTABLE_HV(SvRV(swash));
UV elements = 0; /* Number of elements in the inversion list */
U8 empty[] = "";
+ SV** listsvp;
+ SV** typesvp;
+ SV** bitssvp;
+ SV** extssvp;
+ SV** invert_it_svp;
- /* The string containing the main body of the table */
- SV** const listsvp = hv_fetchs(hv, "LIST", FALSE);
- SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
- SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
+ U8* typestr;
+ STRLEN bits;
+ STRLEN octets; /* if bits == 1, then octets == 0 */
+ U8 *x, *xend;
+ STRLEN xcur;
- const U8* const typestr = (U8*)SvPV_nolen(*typesvp);
- const STRLEN bits = SvUV(*bitssvp);
- const STRLEN octets = bits >> 3; /* if bits == 1, then octets == 0 */
+ SV* invlist;
- HV* invlist;
-
PERL_ARGS_ASSERT__SWASH_TO_INVLIST;
+ /* If not a hash, it must be the swash's inversion list instead */
+ if (SvTYPE(hv) != SVt_PVHV) {
+ return SvREFCNT_inc_simple_NN((SV*) hv);
+ }
+
+ /* The string containing the main body of the table */
+ listsvp = hv_fetchs(hv, "LIST", FALSE);
+ typesvp = hv_fetchs(hv, "TYPE", FALSE);
+ bitssvp = hv_fetchs(hv, "BITS", FALSE);
+ extssvp = hv_fetchs(hv, "EXTRAS", FALSE);
+ invert_it_svp = hv_fetchs(hv, "INVERT_IT", FALSE);
+
+ typestr = (U8*)SvPV_nolen(*typesvp);
+ bits = SvUV(*bitssvp);
+ octets = bits >> 3; /* if bits == 1, then octets == 0 */
+
/* read $swash->{LIST} */
if (SvPOK(*listsvp)) {
l = (U8*)SvPV(*listsvp, lcur);
@@ -2793,7 +4090,9 @@
/* If the ending is somehow corrupt and isn't a new line, add another
* element for the final range that isn't in the inversion list */
- if (! (*lend == '\n' || (*lend == '\0' && *(lend - 1) == '\n'))) {
+ if (! (*lend == '\n'
+ || (*lend == '\0' && (lcur == 0 || *(lend - 1) == '\n'))))
+ {
elements++;
}
@@ -2811,17 +4110,121 @@
break;
}
- _append_range_to_invlist(invlist, start, end);
+ invlist = _add_range_to_invlist(invlist, start, end);
}
+ /* Invert if the data says it should be */
+ if (invert_it_svp && SvUV(*invert_it_svp)) {
+ _invlist_invert_prop(invlist);
+ }
+
+ /* This code is copied from swatch_get()
+ * read $swash->{EXTRAS} */
+ x = (U8*)SvPV(*extssvp, xcur);
+ xend = x + xcur;
+ while (x < xend) {
+ STRLEN namelen;
+ U8 *namestr;
+ SV** othersvp;
+ HV* otherhv;
+ STRLEN otherbits;
+ SV **otherbitssvp, *other;
+ U8 *nl;
+
+ const U8 opc = *x++;
+ if (opc == '\n')
+ continue;
+
+ nl = (U8*)memchr(x, '\n', xend - x);
+
+ if (opc != '-' && opc != '+' && opc != '!' && opc != '&') {
+ if (nl) {
+ x = nl + 1; /* 1 is length of "\n" */
+ continue;
+ }
+ else {
+ x = xend; /* to EXTRAS' end at which \n is not found */
+ break;
+ }
+ }
+
+ namestr = x;
+ if (nl) {
+ namelen = nl - namestr;
+ x = nl + 1;
+ }
+ else {
+ namelen = xend - namestr;
+ x = xend;
+ }
+
+ othersvp = hv_fetch(hv, (char *)namestr, namelen, FALSE);
+ otherhv = MUTABLE_HV(SvRV(*othersvp));
+ otherbitssvp = hv_fetchs(otherhv, "BITS", FALSE);
+ otherbits = (STRLEN)SvUV(*otherbitssvp);
+
+ if (bits != otherbits || bits != 1) {
+ Perl_croak(aTHX_ "panic: _swash_to_invlist only operates on boolean "
+ "properties, bits=%"UVuf", otherbits=%"UVuf,
+ (UV)bits, (UV)otherbits);
+ }
+
+ /* The "other" swatch must be destroyed after. */
+ other = _swash_to_invlist((SV *)*othersvp);
+
+ /* End of code copied from swatch_get() */
+ switch (opc) {
+ case '+':
+ _invlist_union(invlist, other, &invlist);
+ break;
+ case '!':
+ _invlist_union_maybe_complement_2nd(invlist, other, TRUE, &invlist);
+ break;
+ case '-':
+ _invlist_subtract(invlist, other, &invlist);
+ break;
+ case '&':
+ _invlist_intersection(invlist, other, &invlist);
+ break;
+ default:
+ break;
+ }
+ sv_free(other); /* through with it! */
+ }
+
return invlist;
}
+SV*
+Perl__get_swash_invlist(pTHX_ SV* const swash)
+{
+ SV** ptr;
+
+ PERL_ARGS_ASSERT__GET_SWASH_INVLIST;
+
+ if (! SvROK(swash)) {
+ return NULL;
+ }
+
+ /* If it really isn't a hash, it isn't really swash; must be an inversion
+ * list */
+ if (SvTYPE(SvRV(swash)) != SVt_PVHV) {
+ return SvRV(swash);
+ }
+
+ ptr = hv_fetchs(MUTABLE_HV(SvRV(swash)), "V", FALSE);
+ if (! ptr) {
+ return NULL;
+ }
+
+ return *ptr;
+}
+
/*
=for apidoc uvchr_to_utf8
Adds the UTF-8 representation of the Native code point C<uv> to the end
-of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
+of the string C<d>; C<d> should have at least C<UTF8_MAXBYTES+1> free
bytes available. The return value is the pointer to the byte after the
end of the new character. In other words,
@@ -2861,7 +4264,7 @@
which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
length, in bytes, of that character.
-length and flags are the same as utf8n_to_uvuni().
+C<length> and C<flags> are the same as L</utf8n_to_uvuni>().
=cut
*/
@@ -2880,12 +4283,12 @@
}
bool
-Perl_check_utf8_print(pTHX_ register const U8* s, const STRLEN len)
+Perl_check_utf8_print(pTHX_ const U8* s, const STRLEN len)
{
/* May change: warns if surrogates, non-character code points, or
- * non-Unicode code points are in s which has length len. Returns TRUE if
- * none found; FALSE otherwise. The only other validity check is to make
- * sure that this won't exceed the string's length */
+ * non-Unicode code points are in s which has length len bytes. Returns
+ * TRUE if none found; FALSE otherwise. The only other validity check is
+ * to make sure that this won't exceed the string's length */
const U8* const e = s + len;
bool ok = TRUE;
@@ -2898,11 +4301,11 @@
"%s in %s", unees, PL_op ? OP_DESC(PL_op) : "print");
return FALSE;
}
- if (*s >= UTF8_FIRST_PROBLEMATIC_CODE_POINT_FIRST_BYTE) {
+ if (UNLIKELY(*s >= UTF8_FIRST_PROBLEMATIC_CODE_POINT_FIRST_BYTE)) {
STRLEN char_len;
if (UTF8_IS_SUPER(s)) {
if (ckWARN_d(WARN_NON_UNICODE)) {
- UV uv = utf8_to_uvchr(s, &char_len);
+ UV uv = utf8_to_uvchr_buf(s, e, &char_len);
Perl_warner(aTHX_ packWARN(WARN_NON_UNICODE),
"Code point 0x%04"UVXf" is not Unicode, may not be portable", uv);
ok = FALSE;
@@ -2910,7 +4313,7 @@
}
else if (UTF8_IS_SURROGATE(s)) {
if (ckWARN_d(WARN_SURROGATE)) {
- UV uv = utf8_to_uvchr(s, &char_len);
+ UV uv = utf8_to_uvchr_buf(s, e, &char_len);
Perl_warner(aTHX_ packWARN(WARN_SURROGATE),
"Unicode surrogate U+%04"UVXf" is illegal in UTF-8", uv);
ok = FALSE;
@@ -2920,7 +4323,7 @@
((UTF8_IS_NONCHAR_GIVEN_THAT_NON_SUPER_AND_GE_PROBLEMATIC(s))
&& (ckWARN_d(WARN_NONCHAR)))
{
- UV uv = utf8_to_uvchr(s, &char_len);
+ UV uv = utf8_to_uvchr_buf(s, e, &char_len);
Perl_warner(aTHX_ packWARN(WARN_NONCHAR),
"Unicode non-character U+%04"UVXf" is illegal for open interchange", uv);
ok = FALSE;
@@ -2935,11 +4338,11 @@
/*
=for apidoc pv_uni_display
-Build to the scalar dsv a displayable version of the string spv,
-length len, the displayable version being at most pvlim bytes long
+Build to the scalar C<dsv> a displayable version of the string C<spv>,
+length C<len>, the displayable version being at most C<pvlim> bytes long
(if longer, the rest is truncated and "..." will be appended).
-The flags argument can have UNI_DISPLAY_ISPRINT set to display
+The C<flags> argument can have UNI_DISPLAY_ISPRINT set to display
isPRINT()able characters as themselves, UNI_DISPLAY_BACKSLASH
to display the \\[nrfta\\] as the backslashed versions (like '\n')
(UNI_DISPLAY_BACKSLASH is preferred over UNI_DISPLAY_ISPRINT for \\).
@@ -2946,7 +4349,7 @@
UNI_DISPLAY_QQ (and its alias UNI_DISPLAY_REGEX) have both
UNI_DISPLAY_BACKSLASH and UNI_DISPLAY_ISPRINT turned on.
-The pointer to the PV of the dsv is returned.
+The pointer to the PV of the C<dsv> is returned.
=cut */
char *
@@ -2970,7 +4373,7 @@
truncated++;
break;
}
- u = utf8_to_uvchr((U8*)s, 0);
+ u = utf8_to_uvchr_buf((U8*)s, (U8*)e, 0);
if (u < 256) {
const unsigned char c = (unsigned char)u & 0xFF;
if (flags & UNI_DISPLAY_BACKSLASH) {
@@ -3014,13 +4417,13 @@
/*
=for apidoc sv_uni_display
-Build to the scalar dsv a displayable version of the scalar sv,
-the displayable version being at most pvlim bytes long
+Build to the scalar C<dsv> a displayable version of the scalar C<sv>,
+the displayable version being at most C<pvlim> bytes long
(if longer, the rest is truncated and "..." will be appended).
-The flags argument is as in pv_uni_display().
+The C<flags> argument is as in L</pv_uni_display>().
-The pointer to the PV of the dsv is returned.
+The pointer to the PV of the C<dsv> is returned.
=cut
*/
@@ -3027,9 +4430,12 @@
char *
Perl_sv_uni_display(pTHX_ SV *dsv, SV *ssv, STRLEN pvlim, UV flags)
{
+ const char * const ptr =
+ isREGEXP(ssv) ? RX_WRAPPED((REGEXP*)ssv) : SvPVX_const(ssv);
+
PERL_ARGS_ASSERT_SV_UNI_DISPLAY;
- return Perl_pv_uni_display(aTHX_ dsv, (const U8*)SvPVX_const(ssv),
+ return Perl_pv_uni_display(aTHX_ dsv, (const U8*)ptr,
SvCUR(ssv), pvlim, flags);
}
@@ -3036,40 +4442,44 @@
/*
=for apidoc foldEQ_utf8
-Returns true if the leading portions of the strings s1 and s2 (either or both
+Returns true if the leading portions of the strings C<s1> and C<s2> (either or both
of which may be in UTF-8) are the same case-insensitively; false otherwise.
How far into the strings to compare is determined by other input parameters.
-If u1 is true, the string s1 is assumed to be in UTF-8-encoded Unicode;
-otherwise it is assumed to be in native 8-bit encoding. Correspondingly for u2
-with respect to s2.
+If C<u1> is true, the string C<s1> is assumed to be in UTF-8-encoded Unicode;
+otherwise it is assumed to be in native 8-bit encoding. Correspondingly for C<u2>
+with respect to C<s2>.
-If the byte length l1 is non-zero, it says how far into s1 to check for fold
-equality. In other words, s1+l1 will be used as a goal to reach. The
+If the byte length C<l1> is non-zero, it says how far into C<s1> to check for fold
+equality. In other words, C<s1>+C<l1> will be used as a goal to reach. The
scan will not be considered to be a match unless the goal is reached, and
-scanning won't continue past that goal. Correspondingly for l2 with respect to
-s2.
+scanning won't continue past that goal. Correspondingly for C<l2> with respect to
+C<s2>.
-If pe1 is non-NULL and the pointer it points to is not NULL, that pointer is
-considered an end pointer beyond which scanning of s1 will not continue under
-any circumstances. This means that if both l1 and pe1 are specified, and pe1
-is less than s1+l1, the match will never be successful because it can never
+If C<pe1> is non-NULL and the pointer it points to is not NULL, that pointer is
+considered an end pointer to the position 1 byte past the maximum point
+in C<s1> beyond which scanning will not continue under any circumstances.
+(This routine assumes that UTF-8 encoded input strings are not malformed;
+malformed input can cause it to read past C<pe1>).
+This means that if both C<l1> and C<pe1> are specified, and C<pe1>
+is less than C<s1>+C<l1>, the match will never be successful because it can
+never
get as far as its goal (and in fact is asserted against). Correspondingly for
-pe2 with respect to s2.
+C<pe2> with respect to C<s2>.
-At least one of s1 and s2 must have a goal (at least one of l1 and l2 must be
-non-zero), and if both do, both have to be
+At least one of C<s1> and C<s2> must have a goal (at least one of C<l1> and
+C<l2> must be non-zero), and if both do, both have to be
reached for a successful match. Also, if the fold of a character is multiple
characters, all of them must be matched (see tr21 reference below for
'folding').
-Upon a successful match, if pe1 is non-NULL,
-it will be set to point to the beginning of the I<next> character of s1 beyond
-what was matched. Correspondingly for pe2 and s2.
+Upon a successful match, if C<pe1> is non-NULL,
+it will be set to point to the beginning of the I<next> character of C<s1>
+beyond what was matched. Correspondingly for C<pe2> and C<s2>.
For case-insensitiveness, the "casefolding" of Unicode is used
instead of upper/lowercasing both the characters, see
-http://www.unicode.org/unicode/reports/tr21/ (Case Mappings).
+L<http://www.unicode.org/unicode/reports/tr21/> (Case Mappings).
=cut */
@@ -3082,27 +4492,33 @@
* points below 256; unicode rules for above 255; and
* folds that cross those boundaries are disallowed,
* like the NOMIX_ASCII option
+ * FOLDEQ_S1_ALREADY_FOLDED s1 has already been folded before calling this
+ * routine. This allows that step to be skipped.
+ * FOLDEQ_S2_ALREADY_FOLDED Similarly.
*/
I32
-Perl_foldEQ_utf8_flags(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const char *s2, char **pe2, register UV l2, bool u2, U32 flags)
+Perl_foldEQ_utf8_flags(pTHX_ const char *s1, char **pe1, UV l1, bool u1, const char *s2, char **pe2, UV l2, bool u2, U32 flags)
{
dVAR;
- register const U8 *p1 = (const U8*)s1; /* Point to current char */
- register const U8 *p2 = (const U8*)s2;
- register const U8 *g1 = NULL; /* goal for s1 */
- register const U8 *g2 = NULL;
- register const U8 *e1 = NULL; /* Don't scan s1 past this */
- register U8 *f1 = NULL; /* Point to current folded */
- register const U8 *e2 = NULL;
- register U8 *f2 = NULL;
+ const U8 *p1 = (const U8*)s1; /* Point to current char */
+ const U8 *p2 = (const U8*)s2;
+ const U8 *g1 = NULL; /* goal for s1 */
+ const U8 *g2 = NULL;
+ const U8 *e1 = NULL; /* Don't scan s1 past this */
+ U8 *f1 = NULL; /* Point to current folded */
+ const U8 *e2 = NULL;
+ U8 *f2 = NULL;
STRLEN n1 = 0, n2 = 0; /* Number of bytes in current char */
U8 foldbuf1[UTF8_MAXBYTES_CASE+1];
U8 foldbuf2[UTF8_MAXBYTES_CASE+1];
- U8 natbuf[2]; /* Holds native 8-bit char converted to utf8;
- these always fit in 2 bytes */
PERL_ARGS_ASSERT_FOLDEQ_UTF8_FLAGS;
+ /* The algorithm requires that input with the flags on the first line of
+ * the assert not be pre-folded. */
+ assert( ! ((flags & (FOLDEQ_UTF8_NOMIX_ASCII | FOLDEQ_UTF8_LOCALE))
+ && (flags & (FOLDEQ_S1_ALREADY_FOLDED | FOLDEQ_S2_ALREADY_FOLDED))));
+
if (pe1) {
e1 = *(U8**)pe1;
}
@@ -3144,6 +4560,10 @@
assert(e2);
}
+ /* If both operands are already folded, we could just do a memEQ on the
+ * whole strings at once, but it would be better if the caller realized
+ * this and didn't even call us */
+
/* Look through both strings, a character at a time */
while (p1 < e1 && p2 < e2) {
@@ -3151,96 +4571,107 @@
* and the length of the fold. (exception: locale rules just get the
* character to a single byte) */
if (n1 == 0) {
+ if (flags & FOLDEQ_S1_ALREADY_FOLDED) {
+ f1 = (U8 *) p1;
+ n1 = UTF8SKIP(f1);
+ }
+ else {
+ /* If in locale matching, we use two sets of rules, depending
+ * on if the code point is above or below 255. Here, we test
+ * for and handle locale rules */
+ if ((flags & FOLDEQ_UTF8_LOCALE)
+ && (! u1 || UTF8_IS_INVARIANT(*p1)
+ || UTF8_IS_DOWNGRADEABLE_START(*p1)))
+ {
+ /* There is no mixing of code points above and below 255. */
+ if (u2 && (! UTF8_IS_INVARIANT(*p2)
+ && ! UTF8_IS_DOWNGRADEABLE_START(*p2)))
+ {
+ return 0;
+ }
- /* If in locale matching, we use two sets of rules, depending on if
- * the code point is above or below 255. Here, we test for and
- * handle locale rules */
- if ((flags & FOLDEQ_UTF8_LOCALE)
- && (! u1 || UTF8_IS_INVARIANT(*p1) || UTF8_IS_DOWNGRADEABLE_START(*p1)))
- {
- /* There is no mixing of code points above and below 255. */
- if (u2 && (! UTF8_IS_INVARIANT(*p2)
- && ! UTF8_IS_DOWNGRADEABLE_START(*p2)))
- {
- return 0;
+ /* We handle locale rules by converting, if necessary, the
+ * code point to a single byte. */
+ if (! u1 || UTF8_IS_INVARIANT(*p1)) {
+ *foldbuf1 = *p1;
+ }
+ else {
+ *foldbuf1 = TWO_BYTE_UTF8_TO_UNI(*p1, *(p1 + 1));
+ }
+ n1 = 1;
}
+ else if (isASCII(*p1)) { /* Note, that here won't be both
+ ASCII and using locale rules */
- /* We handle locale rules by converting, if necessary, the code
- * point to a single byte. */
- if (! u1 || UTF8_IS_INVARIANT(*p1)) {
- *foldbuf1 = *p1;
+ /* If trying to mix non- with ASCII, and not supposed to,
+ * fail */
+ if ((flags & FOLDEQ_UTF8_NOMIX_ASCII) && ! isASCII(*p2)) {
+ return 0;
+ }
+ n1 = 1;
+ *foldbuf1 = toLOWER(*p1); /* Folds in the ASCII range are
+ just lowercased */
}
- else {
- *foldbuf1 = TWO_BYTE_UTF8_TO_UNI(*p1, *(p1 + 1));
+ else if (u1) {
+ to_utf8_fold(p1, foldbuf1, &n1);
}
- n1 = 1;
- }
- else if (isASCII(*p1)) { /* Note, that here won't be both ASCII
- and using locale rules */
-
- /* If trying to mix non- with ASCII, and not supposed to, fail */
- if ((flags & FOLDEQ_UTF8_NOMIX_ASCII) && ! isASCII(*p2)) {
- return 0;
+ else { /* Not utf8, get utf8 fold */
+ to_uni_fold(NATIVE_TO_UNI(*p1), foldbuf1, &n1);
}
- n1 = 1;
- *foldbuf1 = toLOWER(*p1); /* Folds in the ASCII range are
- just lowercased */
+ f1 = foldbuf1;
}
- else if (u1) {
- to_utf8_fold(p1, foldbuf1, &n1);
- }
- else { /* Not utf8, convert to it first and then get fold */
- uvuni_to_utf8(natbuf, (UV) NATIVE_TO_UNI(((UV)*p1)));
- to_utf8_fold(natbuf, foldbuf1, &n1);
- }
- f1 = foldbuf1;
}
if (n2 == 0) { /* Same for s2 */
- if ((flags & FOLDEQ_UTF8_LOCALE)
- && (! u2 || UTF8_IS_INVARIANT(*p2) || UTF8_IS_DOWNGRADEABLE_START(*p2)))
- {
- /* Here, the next char in s2 is < 256. We've already worked on
- * s1, and if it isn't also < 256, can't match */
- if (u1 && (! UTF8_IS_INVARIANT(*p1)
- && ! UTF8_IS_DOWNGRADEABLE_START(*p1)))
+ if (flags & FOLDEQ_S2_ALREADY_FOLDED) {
+ f2 = (U8 *) p2;
+ n2 = UTF8SKIP(f2);
+ }
+ else {
+ if ((flags & FOLDEQ_UTF8_LOCALE)
+ && (! u2 || UTF8_IS_INVARIANT(*p2) || UTF8_IS_DOWNGRADEABLE_START(*p2)))
{
- return 0;
+ /* Here, the next char in s2 is < 256. We've already
+ * worked on s1, and if it isn't also < 256, can't match */
+ if (u1 && (! UTF8_IS_INVARIANT(*p1)
+ && ! UTF8_IS_DOWNGRADEABLE_START(*p1)))
+ {
+ return 0;
+ }
+ if (! u2 || UTF8_IS_INVARIANT(*p2)) {
+ *foldbuf2 = *p2;
+ }
+ else {
+ *foldbuf2 = TWO_BYTE_UTF8_TO_UNI(*p2, *(p2 + 1));
+ }
+
+ /* Use another function to handle locale rules. We've made
+ * sure that both characters to compare are single bytes */
+ if (! foldEQ_locale((char *) f1, (char *) foldbuf2, 1)) {
+ return 0;
+ }
+ n1 = n2 = 0;
}
- if (! u2 || UTF8_IS_INVARIANT(*p2)) {
- *foldbuf2 = *p2;
+ else if (isASCII(*p2)) {
+ if ((flags & FOLDEQ_UTF8_NOMIX_ASCII) && ! isASCII(*p1)) {
+ return 0;
+ }
+ n2 = 1;
+ *foldbuf2 = toLOWER(*p2);
}
+ else if (u2) {
+ to_utf8_fold(p2, foldbuf2, &n2);
+ }
else {
- *foldbuf2 = TWO_BYTE_UTF8_TO_UNI(*p2, *(p2 + 1));
+ to_uni_fold(NATIVE_TO_UNI(*p2), foldbuf2, &n2);
}
-
- /* Use another function to handle locale rules. We've made
- * sure that both characters to compare are single bytes */
- if (! foldEQ_locale((char *) f1, (char *) foldbuf2, 1)) {
- return 0;
- }
- n1 = n2 = 0;
+ f2 = foldbuf2;
}
- else if (isASCII(*p2)) {
- if (flags && ! isASCII(*p1)) {
- return 0;
- }
- n2 = 1;
- *foldbuf2 = toLOWER(*p2);
- }
- else if (u2) {
- to_utf8_fold(p2, foldbuf2, &n2);
- }
- else {
- uvuni_to_utf8(natbuf, (UV) NATIVE_TO_UNI(((UV)*p2)));
- to_utf8_fold(natbuf, foldbuf2, &n2);
- }
- f2 = foldbuf2;
}
/* Here f1 and f2 point to the beginning of the strings to compare.
- * These strings are the folds of the input characters, stored in utf8.
- */
+ * These strings are the folds of the next character from each input
+ * string, stored in utf8. */
/* While there is more to look for in both folds, see if they
* continue to match */
@@ -3249,7 +4680,7 @@
if (fold_length != UTF8SKIP(f2)
|| (fold_length == 1 && *f1 != *f2) /* Short circuit memNE
function call for single
- character */
+ byte */
|| memNE((char*)f1, (char*)f2, fold_length))
{
return 0; /* mismatch */
@@ -3293,8 +4724,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/utf8.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/utf8.h
===================================================================
--- trunk/contrib/perl/utf8.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/utf8.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -1,12 +1,22 @@
/* utf8.h
*
- * Copyright (C) 2000, 2001, 2002, 2005, 2006, 2007, 2009 by Larry Wall and others
+ * This file contains definitions for use with the UTF-8 encoding. It
+ * actually also works with the variant UTF-8 encoding called UTF-EBCDIC, and
+ * hides almost all of the differences between these from the caller. In other
+ * words, someone should #include this file, and if the code is being compiled
+ * on an EBCDIC platform, things should mostly just work.
*
+ * Copyright (C) 2000, 2001, 2002, 2005, 2006, 2007, 2009,
+ * 2010, 2011 by Larry Wall and others
+ *
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*
*/
+#ifndef H_UTF8 /* Guard against recursive inclusion */
+#define H_UTF8 1
+
/* Use UTF-8 as the default script encoding?
* Turning this on will break scripts having non-UTF-8 binary
* data (such as Latin-1) in string literals. */
@@ -16,9 +26,23 @@
# define USE_UTF8_IN_NAMES (PL_hints & HINT_UTF8)
#endif
-#define to_uni_fold(c, p, lenp) _to_uni_fold_flags(c, p, lenp, 1)
-#define to_utf8_fold(c, p, lenp) _to_utf8_fold_flags(c, p, lenp, 1)
+/* For to_utf8_fold_flags, q.v. */
+#define FOLD_FLAGS_LOCALE 0x1
+#define FOLD_FLAGS_FULL 0x2
+#define FOLD_FLAGS_NOMIX_ASCII 0x4
+/* For _core_swash_init(), internal core use only */
+#define _CORE_SWASH_INIT_USER_DEFINED_PROPERTY 0x1
+#define _CORE_SWASH_INIT_RETURN_IF_UNDEF 0x2
+#define _CORE_SWASH_INIT_ACCEPT_INVLIST 0x4
+
+#define to_uni_fold(c, p, lenp) _to_uni_fold_flags(c, p, lenp, FOLD_FLAGS_FULL)
+#define to_utf8_fold(c, p, lenp) _to_utf8_fold_flags(c, p, lenp, \
+ FOLD_FLAGS_FULL, NULL)
+#define to_utf8_lower(a,b,c) _to_utf8_lower_flags(a,b,c,0, NULL)
+#define to_utf8_upper(a,b,c) _to_utf8_upper_flags(a,b,c,0, NULL)
+#define to_utf8_title(a,b,c) _to_utf8_title_flags(a,b,c,0, NULL)
+
/* Source backward compatibility. */
#define uvuni_to_utf8(d, uv) uvuni_to_utf8_flags(d, uv, 0)
#define is_utf8_string_loc(s, len, ep) is_utf8_string_loclen(s, len, ep, 0)
@@ -27,6 +51,8 @@
foldEQ_utf8_flags(s1, pe1, l1, u1, s2, pe2, l2, u2, 0)
#define FOLDEQ_UTF8_NOMIX_ASCII (1 << 0)
#define FOLDEQ_UTF8_LOCALE (1 << 1)
+#define FOLDEQ_S1_ALREADY_FOLDED (1 << 2)
+#define FOLDEQ_S2_ALREADY_FOLDED (1 << 3)
/*
=for apidoc ibcmp_utf8
@@ -50,15 +76,25 @@
#ifdef DOINIT
EXTCONST unsigned char PL_utf8skip[] = {
-1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* ascii */
-1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* ascii */
-1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* ascii */
-1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* ascii */
-1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* bogus */
-1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* bogus */
-2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, /* scripts */
-3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,4,4,4,4,4,4,4,4,5,5,5,5,6,6, /* cjk etc. */
-7,13, /* Perl extended (not UTF-8). Up to 72bit allowed (64-bit + reserved). */
+/* 0x00 */ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* ascii */
+/* 0x10 */ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* ascii */
+/* 0x20 */ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* ascii */
+/* 0x30 */ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* ascii */
+/* 0x40 */ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* ascii */
+/* 0x50 */ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* ascii */
+/* 0x60 */ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* ascii */
+/* 0x70 */ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* ascii */
+/* 0x80 */ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* bogus: continuation byte */
+/* 0x90 */ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* bogus: continuation byte */
+/* 0xA0 */ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* bogus: continuation byte */
+/* 0xB0 */ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* bogus: continuation byte */
+/* 0xC0 */ 2,2, /* overlong */
+/* 0xC2 */ 2,2,2,2,2,2,2,2,2,2,2,2,2,2, /* U+0080 to U+03FF */
+/* 0xD0 */ 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, /* U+0400 to U+07FF */
+/* 0xE0 */ 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3, /* U+0800 to U+FFFF */
+/* 0xF0 */ 4,4,4,4,4,4,4,4,5,5,5,5,6,6, /* above BMP to 2**31 - 1 */
+/* 0xFE */ 7,13, /* Perl extended (never was official UTF-8). Up to 72bit
+ allowed (64-bit + reserved). */
};
#else
EXTCONST unsigned char PL_utf8skip[];
@@ -66,12 +102,17 @@
END_EXTERN_C
+#include "regcharclass.h"
+#include "unicode_constants.h"
+
/* Native character to iso-8859-1 */
#define NATIVE_TO_ASCII(ch) (ch)
#define ASCII_TO_NATIVE(ch) (ch)
/* Transform after encoding */
#define NATIVE_TO_UTF(ch) (ch)
+#define NATIVE_TO_I8(ch) NATIVE_TO_UTF(ch) /* a clearer synonym */
#define UTF_TO_NATIVE(ch) (ch)
+#define I8_TO_NATIVE(ch) UTF_TO_NATIVE(ch)
/* Transforms in wide UV chars */
#define UNI_TO_NATIVE(ch) (ch)
#define NATIVE_TO_UNI(ch) (ch)
@@ -81,6 +122,7 @@
/* As there are no translations, avoid the function wrapper */
#define utf8n_to_uvchr utf8n_to_uvuni
+#define valid_utf8_to_uvchr valid_utf8_to_uvuni
#define uvchr_to_utf8 uvuni_to_utf8
/*
@@ -94,17 +136,21 @@
U+0800..U+0FFF E0 * A0..BF 80..BF
U+1000..U+CFFF E1..EC 80..BF 80..BF
U+D000..U+D7FF ED 80..9F 80..BF
- U+D800..U+DFFF +++++++ utf16 surrogates, not legal utf8 +++++++
+ U+D800..U+DFFF ED A0..BF 80..BF (surrogates)
U+E000..U+FFFF EE..EF 80..BF 80..BF
U+10000..U+3FFFF F0 * 90..BF 80..BF 80..BF
U+40000..U+FFFFF F1..F3 80..BF 80..BF 80..BF
U+100000..U+10FFFF F4 80..8F 80..BF 80..BF
+ Below are non-Unicode code points
+ U+110000..U+13FFFF F4 90..BF 80..BF 80..BF
+ U+110000..U+1FFFFF F5..F7 80..BF 80..BF 80..BF
+ U+200000..: F8.. * 88..BF 80..BF 80..BF 80..BF
Note the gaps before several of the byte entries above marked by '*'. These are
caused by legal UTF-8 avoiding non-shortest encodings: it is technically
possible to UTF-8-encode a single code point in different ways, but that is
explicitly forbidden, and the shortest possible encoding should always be used
-(and that is what Perl does).
+(and that is what Perl does). The non-shortest ones are called 'overlongs'.
*/
@@ -111,12 +157,12 @@
/*
Another way to look at it, as bits:
- Code Points 1st Byte 2nd Byte 3rd Byte 4th Byte
+ Code Points 1st Byte 2nd Byte 3rd Byte 4th Byte
- 0aaaaaaa 0aaaaaaa
- 00000bbbbbaaaaaa 110bbbbb 10aaaaaa
- ccccbbbbbbaaaaaa 1110cccc 10bbbbbb 10aaaaaa
- 00000dddccccccbbbbbbaaaaaa 11110ddd 10cccccc 10bbbbbb 10aaaaaa
+ 0aaa aaaa 0aaa aaaa
+ 0000 0bbb bbaa aaaa 110b bbbb 10aa aaaa
+ cccc bbbb bbaa aaaa 1110 cccc 10bb bbbb 10aa aaaa
+ 00 000d ddcc cccc bbbb bbaa aaaa 1111 0ddd 10cc cccc 10bb bbbb 10aa aaaa
As you can see, the continuation bytes all begin with C<10>, and the
leading bits of the start byte tell how many bytes there are in the
@@ -126,21 +172,63 @@
*/
+/* Is the representation of the Unicode code point 'c' the same regardless of
+ * being encoded in UTF-8 or not? */
#define UNI_IS_INVARIANT(c) (((UV)c) < 0x80)
-/* Note that C0 and C1 are invalid in legal UTF8, so the lower bound of the
- * below might ought to be C2 */
-#define UTF8_IS_START(c) (((U8)c) >= 0xc0)
-#define UTF8_IS_CONTINUATION(c) (((U8)c) >= 0x80 && (((U8)c) <= 0xbf))
+
+/* Is the UTF8-encoded byte 'c' part of a variant sequence in UTF-8? This is
+ * the inverse of UTF8_IS_INVARIANT */
#define UTF8_IS_CONTINUED(c) (((U8)c) & 0x80)
-#define UTF8_IS_DOWNGRADEABLE_START(c) (((U8)c & 0xfc) == 0xc0)
+/* Is the byte 'c' the first byte of a multi-byte UTF8-8 encoded sequence?
+ * This doesn't catch invariants (they are single-byte). It also excludes the
+ * illegal overlong sequences that begin with C0 and C1. */
+#define UTF8_IS_START(c) (((U8)c) >= 0xc2)
+
+/* Is the byte 'c' part of a multi-byte UTF8-8 encoded sequence, and not the
+ * first byte thereof? */
+#define UTF8_IS_CONTINUATION(c) ((((U8)c) & 0xC0) == 0x80)
+
+/* Is the UTF8-encoded byte 'c' the first byte of a two byte sequence? Use
+ * UTF8_IS_NEXT_CHAR_DOWNGRADEABLE() instead if the input isn't known to
+ * be well-formed. Masking with 0xfe allows the low bit to be 0 or 1; thus
+ * this matches 0xc[23]. */
+#define UTF8_IS_DOWNGRADEABLE_START(c) (((U8)(c) & 0xfe) == 0xc2)
+
+/* Is the UTF8-encoded byte 'c' the first byte of a sequence of bytes that
+ * represent a code point > 255? */
+#define UTF8_IS_ABOVE_LATIN1(c) ((U8)(c) >= 0xc4)
+
+/* This defines the 1-bits that are to be in the first byte of a multi-byte
+ * UTF-8 encoded character that give the number of bytes that comprise the
+ * character.
+ * */
#define UTF_START_MARK(len) (((len) > 7) ? 0xFF : (0xFE << (7-(len))))
+
+/* Masks out the initial one bits in a start byte, leaving the real data ones.
+ * Doesn't work on an invariant byte */
#define UTF_START_MASK(len) (((len) >= 7) ? 0x00 : (0x1F >> ((len)-2)))
+/* This defines the bits that are to be in the continuation bytes of a multi-byte
+ * UTF-8 encoded character that indicate it is a continuation byte. */
#define UTF_CONTINUATION_MARK 0x80
+
+/* This is the number of low-order bits a continuation byte in a UTF-8 encoded
+ * sequence contributes to the specification of the code point. In the bit
+ * maps above, you see that the first 2 bits are a constant '10', leaving 6 of
+ * real information */
#define UTF_ACCUMULATION_SHIFT 6
+
+/* 2**UTF_ACCUMULATION_SHIFT - 1 */
#define UTF_CONTINUATION_MASK ((U8)0x3f)
+/* If a value is anded with this, and the result is non-zero, then using the
+ * original value in UTF8_ACCUMULATE will overflow, shifting bits off the left
+ * */
+#define UTF_ACCUMULATION_OVERFLOW_MASK \
+ (((UV) UTF_CONTINUATION_MASK) << ((sizeof(UV) * CHARBITS) \
+ - UTF_ACCUMULATION_SHIFT))
+
#ifdef HAS_QUAD
#define UNISKIP(uv) ( (uv) < 0x80 ? 1 : \
(uv) < 0x800 ? 2 : \
@@ -159,6 +247,25 @@
(uv) < 0x80000000 ? 6 : 7 )
#endif
+/* How wide can a single UTF-8 encoded character become in bytes. */
+/* NOTE: Strictly speaking Perl's UTF-8 should not be called UTF-8 since UTF-8
+ * is an encoding of Unicode, and Unicode's upper limit, 0x10FFFF, can be
+ * expressed with 4 bytes. However, Perl thinks of UTF-8 as a way to encode
+ * non-negative integers in a binary format, even those above Unicode */
+#define UTF8_MAXBYTES 13
+
+/* The maximum number of UTF-8 bytes a single Unicode character can
+ * uppercase/lowercase/fold into. Unicode guarantees that the maximum
+ * expansion is 3 characters. On ASCIIish platforms, the highest Unicode
+ * character occupies 4 bytes, therefore this number would be 12, but this is
+ * smaller than the maximum width a single above-Unicode character can occupy,
+ * so use that instead */
+#if UTF8_MAXBYTES < 12
+#error UTF8_MAXBYTES must be at least 12
+#endif
+
+#define UTF8_MAXBYTES_CASE UTF8_MAXBYTES
+
#endif /* EBCDIC vs ASCII */
/* Rest of these are attributes of Unicode and perl's internals rather than the
@@ -168,8 +275,17 @@
#define NATIVE8_TO_UNI(ch) NATIVE_TO_ASCII(ch) /* a clearer synonym */
-#define UTF8_ACCUMULATE(old, new) (((old) << UTF_ACCUMULATION_SHIFT) | (((U8)new) & UTF_CONTINUATION_MASK))
+/* Adds a UTF8 continuation byte 'new' of information to a running total code
+ * point 'old' of all the continuation bytes so far. This is designed to be
+ * used in a loop to convert from UTF-8 to the code point represented */
+#define UTF8_ACCUMULATE(old, new) (((old) << UTF_ACCUMULATION_SHIFT) \
+ | (((U8)new) & UTF_CONTINUATION_MASK))
+/* This works in the face of malformed UTF-8. */
+#define UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, e) (UTF8_IS_DOWNGRADEABLE_START(*s) \
+ && ( (e) - (s) > 1) \
+ && UTF8_IS_CONTINUATION(*((s)+1)))
+
/* Convert a two (not one) byte utf8 character to a unicode code point value.
* Needs just one iteration of accumulate. Should not be used unless it is
* known that the two bytes are legal: 1) two-byte start, and 2) continuation.
@@ -179,9 +295,16 @@
UTF8_ACCUMULATE((NATIVE_TO_UTF(HI) & UTF_START_MASK(2)), \
NATIVE_TO_UTF(LO))
+/* How many bytes in the UTF-8 encoded character whose first (perhaps only)
+ * byte is pointed to by 's' */
#define UTF8SKIP(s) PL_utf8skip[*(const U8*)(s)]
+/* Is the byte 'c' the same character when encoded in UTF-8 as when not. This
+ * works on both UTF-8 encoded strings and non-encoded, as it returns TRUE in
+ * each for the exact same set of bit patterns. (And it works on any byte in a
+ * UTF-8 encoded string) */
#define UTF8_IS_INVARIANT(c) UNI_IS_INVARIANT(NATIVE_TO_UTF(c))
+
#define NATIVE_IS_INVARIANT(c) UNI_IS_INVARIANT(NATIVE8_TO_UNI(c))
#define MAX_PORTABLE_UTF8_TWO_BYTE 0x3FF /* constrained by EBCDIC */
@@ -190,8 +313,10 @@
* bytes from an ordinal that is known to fit into two bytes; it must be less
* than 0x3FF to work across both encodings. */
/* Nocast allows these to be used in the case label of a switch statement */
-#define UTF8_TWO_BYTE_HI_nocast(c) UTF_TO_NATIVE(((c) >> UTF_ACCUMULATION_SHIFT) | (0xFF & UTF_START_MARK(2)))
-#define UTF8_TWO_BYTE_LO_nocast(c) UTF_TO_NATIVE(((c) & UTF_CONTINUATION_MASK) | UTF_CONTINUATION_MARK)
+#define UTF8_TWO_BYTE_HI_nocast(c) NATIVE_TO_I8(((c) \
+ >> UTF_ACCUMULATION_SHIFT) | (0xFF & UTF_START_MARK(2)))
+#define UTF8_TWO_BYTE_LO_nocast(c) NATIVE_TO_I8(((c) & UTF_CONTINUATION_MASK) \
+ | UTF_CONTINUATION_MARK)
#define UTF8_TWO_BYTE_HI(c) ((U8) (UTF8_TWO_BYTE_HI_nocast(c)))
#define UTF8_TWO_BYTE_LO(c) ((U8) (UTF8_TWO_BYTE_LO_nocast(c)))
@@ -201,46 +326,32 @@
#define UTF8_EIGHT_BIT_LO(c) UTF8_TWO_BYTE_LO((U8)(c))
/*
- * Note: we try to be careful never to call the isXXX_utf8() functions
- * unless we're pretty sure we've seen the beginning of a UTF-8 or UTFEBCDIC
- * character. Otherwise we risk loading in the heavy-duty swash_init and
- * swash_fetch routines unnecessarily.
+ * 'UTF' is whether or not p is encoded in UTF8. The names 'foo_lazy_if' stem
+ * from an earlier version of these macros in which they didn't call the
+ * foo_utf8() macros (i.e. were 'lazy') unless they decided that *p is the
+ * beginning of a utf8 character. Now that foo_utf8() determines that itself,
+ * no need to do it again here
*/
-#define isIDFIRST_lazy_if(p,c) ((IN_BYTES || (!c || ! UTF8_IS_START(*((const U8*)p)))) \
- ? isIDFIRST(*(p)) \
- : isIDFIRST_utf8((const U8*)p))
-#define isALNUM_lazy_if(p,c) ((IN_BYTES || (!c || ! UTF8_IS_START(*((const U8*)p)))) \
- ? isALNUM(*(p)) \
- : isALNUM_utf8((const U8*)p))
+#define isIDFIRST_lazy_if(p,UTF) ((IN_BYTES || !UTF ) \
+ ? isIDFIRST(*(p)) \
+ : isIDFIRST_utf8((const U8*)p))
+#define isWORDCHAR_lazy_if(p,UTF) ((IN_BYTES || (!UTF )) \
+ ? isWORDCHAR(*(p)) \
+ : isWORDCHAR_utf8((const U8*)p))
+#define isALNUM_lazy_if(p,UTF) isWORDCHAR_lazy_if(p,UTF)
-#define isIDFIRST_lazy(p) isIDFIRST_lazy_if(p,1)
-#define isALNUM_lazy(p) isALNUM_lazy_if(p,1)
-
-#define UTF8_MAXBYTES 13
-/* How wide can a single UTF-8 encoded character become in bytes.
- * NOTE: Strictly speaking Perl's UTF-8 should not be called UTF-8
- * since UTF-8 is an encoding of Unicode and given Unicode's current
- * upper limit only four bytes is possible. Perl thinks of UTF-8
- * as a way to encode non-negative integers in a binary format. */
#define UTF8_MAXLEN UTF8_MAXBYTES
-/* The maximum number of UTF-8 bytes a single Unicode character can
- * uppercase/lowercase/fold into; this number depends on the Unicode
- * version. An example of maximal expansion is the U+03B0 which
- * uppercases to U+03C5 U+0308 U+0301. The Unicode databases that
- * tell these things are UnicodeData.txt, CaseFolding.txt, and
- * SpecialCasing.txt. The value is 6 for strict Unicode characters, but it has
- * to be as big as Perl allows for a single character */
-#define UTF8_MAXBYTES_CASE UTF8_MAXBYTES
-
/* A Unicode character can fold to up to 3 characters */
#define UTF8_MAX_FOLD_CHAR_EXPAND 3
#define IN_BYTES (CopHINTS_get(PL_curcop) & HINT_BYTES)
#define DO_UTF8(sv) (SvUTF8(sv) && !IN_BYTES)
-#define IN_UNI_8_BIT ( (CopHINTS_get(PL_curcop) & HINT_UNI_8_BIT) \
- && ! IN_LOCALE_RUNTIME && ! IN_BYTES)
+#define IN_UNI_8_BIT \
+ (CopHINTS_get(PL_curcop) & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS) \
+ && ! IN_LOCALE_RUNTIME && ! IN_BYTES)
+
#define UTF8_ALLOW_EMPTY 0x0001 /* Allow a zero length string */
/* Allow first byte to be a continuation byte */
@@ -292,24 +403,11 @@
* problematic in some contexts. This allows code that needs to check for
* those to to quickly exclude the vast majority of code points it will
* encounter */
-#ifdef EBCDIC
-# define UTF8_FIRST_PROBLEMATIC_CODE_POINT_FIRST_BYTE UTF_TO_NATIVE(0xF1)
-#else
-# define UTF8_FIRST_PROBLEMATIC_CODE_POINT_FIRST_BYTE 0xED
-#endif
+#define UTF8_FIRST_PROBLEMATIC_CODE_POINT_FIRST_BYTE \
+ FIRST_SURROGATE_UTF8_FIRST_BYTE
-/* ASCII EBCDIC I8
- * U+D7FF: \xED\x9F\xBF \xF1\xB5\xBF\xBF last before surrogates
- * U+D800: \xED\xA0\x80 \xF1\xB6\xA0\xA0 1st surrogate
- * U+DFFF: \xED\xBF\xBF \xF1\xB7\xBF\xBF final surrogate
- * U+E000: \xEE\x80\x80 \xF1\xB8\xA0\xA0 next after surrogates
- */
-#ifdef EBCDIC /* Both versions assume well-formed UTF8 */
-# define UTF8_IS_SURROGATE(s) (*(s) == UTF_TO_NATIVE(0xF1) \
- && (*((s) +1) == UTF_TO_NATIVE(0xB6)) || *((s) + 1) == UTF_TO_NATIVE(0xB7))
-#else
-# define UTF8_IS_SURROGATE(s) (*(s) == 0xED && *((s) + 1) >= 0xA0)
-#endif
+#define UTF8_IS_SURROGATE(s) cBOOL(is_SURROGATE_utf8(s))
+#define UTF8_IS_REPLACEMENT(s, send) cBOOL(is_REPLACEMENT_utf8_safe(s,send))
/* ASCII EBCDIC I8
* U+10FFFF: \xF4\x8F\xBF\xBF \xF9\xA1\xBF\xBF\xBF max legal Unicode
@@ -317,68 +415,21 @@
* U+110001: \xF4\x90\x80\x81 \xF9\xA2\xA0\xA0\xA1
*/
#ifdef EBCDIC /* Both versions assume well-formed UTF8 */
-# define UTF8_IS_SUPER(s) (*(s) >= UTF_TO_NATIVE(0xF9) \
- && (*(s) > UTF_TO_NATIVE(0xF9) || (*((s) + 1) >= UTF_TO_NATIVE(0xA2))))
+# define UTF8_IS_SUPER(s) (NATIVE_TO_I8(* (U8*) (s)) >= 0xF9 \
+ && (NATIVE_TO_I8(* (U8*) (s)) > 0xF9 \
+ || (NATIVE_TO_I8(* (U8*) ((s)) + 1 >= 0xA2))))
#else
-# define UTF8_IS_SUPER(s) (*(s) >= 0xF4 \
- && (*(s) > 0xF4 || (*((s) + 1) >= 0x90)))
+# define UTF8_IS_SUPER(s) (*(U8*) (s) >= 0xF4 \
+ && (*(U8*) (s) > 0xF4 || (*((U8*) (s) + 1) >= 0x90)))
#endif
-/* ASCII EBCDIC I8
- * U+FDCF: \xEF\xB7\x8F \xF1\xBF\xAE\xAF last before non-char block
- * U+FDD0: \xEF\xB7\x90 \xF1\xBF\xAE\xB0 first non-char in block
- * U+FDEF: \xEF\xB7\xAF \xF1\xBF\xAF\xAF last non-char in block
- * U+FDF0: \xEF\xB7\xB0 \xF1\xBF\xAF\xB0 first after non-char block
- * U+FFFF: \xEF\xBF\xBF \xF1\xBF\xBF\xBF
- * U+1FFFF: \xF0\x9F\xBF\xBF \xF3\xBF\xBF\xBF
- * U+2FFFF: \xF0\xAF\xBF\xBF \xF5\xBF\xBF\xBF
- * U+3FFFF: \xF0\xBF\xBF\xBF \xF7\xBF\xBF\xBF
- * U+4FFFF: \xF1\x8F\xBF\xBF \xF8\xA9\xBF\xBF\xBF
- * U+5FFFF: \xF1\x9F\xBF\xBF \xF8\xAB\xBF\xBF\xBF
- * U+6FFFF: \xF1\xAF\xBF\xBF \xF8\xAD\xBF\xBF\xBF
- * U+7FFFF: \xF1\xBF\xBF\xBF \xF8\xAF\xBF\xBF\xBF
- * U+8FFFF: \xF2\x8F\xBF\xBF \xF8\xB1\xBF\xBF\xBF
- * U+9FFFF: \xF2\x9F\xBF\xBF \xF8\xB3\xBF\xBF\xBF
- * U+AFFFF: \xF2\xAF\xBF\xBF \xF8\xB5\xBF\xBF\xBF
- * U+BFFFF: \xF2\xBF\xBF\xBF \xF8\xB7\xBF\xBF\xBF
- * U+CFFFF: \xF3\x8F\xBF\xBF \xF8\xB9\xBF\xBF\xBF
- * U+DFFFF: \xF3\x9F\xBF\xBF \xF8\xBB\xBF\xBF\xBF
- * U+EFFFF: \xF3\xAF\xBF\xBF \xF8\xBD\xBF\xBF\xBF
- * U+FFFFF: \xF3\xBF\xBF\xBF \xF8\xBF\xBF\xBF\xBF
- * U+10FFFF: \xF4\x8F\xBF\xBF \xF9\xA1\xBF\xBF\xBF
- */
-#define UTF8_IS_NONCHAR_(s) ( \
- *(s) >= UTF8_FIRST_PROBLEMATIC_CODE_POINT_FIRST_BYTE \
- && ! UTF8_IS_SUPER(s) \
- && UTF8_IS_NONCHAR_GIVEN_THAT_NON_SUPER_AND_GE_FIRST_PROBLEMATIC(s) \
+/* These are now machine generated, and the 'given' clause is no longer
+ * applicable */
+#define UTF8_IS_NONCHAR_GIVEN_THAT_NON_SUPER_AND_GE_PROBLEMATIC(s) \
+ cBOOL(is_NONCHAR_utf8(s))
+#define UTF8_IS_NONCHAR_(s) \
+ UTF8_IS_NONCHAR_GIVEN_THAT_NON_SUPER_AND_GE_PROBLEMATIC(s)
-#ifdef EBCDIC /* Both versions assume well-formed UTF8 */
-# define UTF8_IS_NONCHAR_GIVEN_THAT_NON_SUPER_AND_GE_PROBLEMATIC(s) \
- ((*(s) == UTF_TO_NATIVE(0xF1) \
- && (*((s) + 1) == UTF_TO_NATIVE(0xBF) \
- && ((*((s) + 2) == UTF_TO_NATIVE(0xAE) \
- && *((s) + 3) >= UTF_TO_NATIVE(0xB0)) \
- || (*((s) + 2) == UTF_TO_NATIVE(0xAF) \
- && *((s) + 3) <= UTF_TO_NATIVE(0xAF))))) \
- || (UTF8SKIP(*(s)) > 3 \
- /* (These were all derived by inspection and experimentation with an */ \
- /* editor) The next line checks the next to final byte in the char */ \
- && *((s) + UTF8SKIP(*(s)) - 2) == UTF_TO_NATIVE(0xBF) \
- && *((s) + UTF8SKIP(*(s)) - 3) == UTF_TO_NATIVE(0xBF) \
- && (NATIVE_TO_UTF(*((s) + UTF8SKIP(*(s)) - 4)) & 0x81) == 0x81 \
- && (NATIVE_TO_UTF(*((s) + UTF8SKIP(*(s)) - 1)) & 0xBE) == 0XBE))
-#else
-# define UTF8_IS_NONCHAR_GIVEN_THAT_NON_SUPER_AND_GE_PROBLEMATIC(s) \
- ((*(s) == 0xEF \
- && ((*((s) + 1) == 0xB7 && (*((s) + 2) >= 0x90 && (*((s) + 2) <= 0xAF)))\
- /* Gets U+FFF[EF] */ \
- || (*((s) + 1) == 0xBF && ((*((s) + 2) & 0xBE) == 0xBE)))) \
- || ((*((s) + 2) == 0xBF \
- && (*((s) + 3) & 0xBE) == 0xBE \
- /* Excludes things like U+10FFE = \xF0\x90\xBF\xBE */ \
- && (*((s) + 1) & 0x8F) == 0x8F)))
-#endif
-
#define UNICODE_SURROGATE_FIRST 0xD800
#define UNICODE_SURROGATE_LAST 0xDFFF
#define UNICODE_REPLACEMENT 0xFFFD
@@ -396,10 +447,10 @@
#define UNICODE_DISALLOW_NONCHAR 0x0020
#define UNICODE_DISALLOW_SUPER 0x0040
#define UNICODE_DISALLOW_FE_FF 0x0080
-#define UNICODE_WARN_ILLEGAL_INTERCHANGE \
- (UNICODE_WARN_SURROGATE|UNICODE_WARN_NONCHAR|UNICODE_WARN_SUPER)
-#define UNICODE_DISALLOW_ILLEGAL_INTERCHANGE \
- (UNICODE_DISALLOW_SURROGATE|UNICODE_DISALLOW_NONCHAR|UNICODE_DISALLOW_SUPER)
+#define UNICODE_WARN_ILLEGAL_INTERCHANGE \
+ (UNICODE_WARN_SURROGATE|UNICODE_WARN_NONCHAR|UNICODE_WARN_SUPER)
+#define UNICODE_DISALLOW_ILLEGAL_INTERCHANGE \
+ (UNICODE_DISALLOW_SURROGATE|UNICODE_DISALLOW_NONCHAR|UNICODE_DISALLOW_SUPER)
/* For backward source compatibility, as are now the default */
#define UNICODE_ALLOW_SURROGATE 0
@@ -424,6 +475,14 @@
# define UTF8_QUAD_MAX UINT64_C(0x1000000000)
#endif
+#define LATIN_SMALL_LETTER_SHARP_S LATIN_SMALL_LETTER_SHARP_S_NATIVE
+#define LATIN_SMALL_LETTER_Y_WITH_DIAERESIS \
+ LATIN_SMALL_LETTER_Y_WITH_DIAERESIS_NATIVE
+#define MICRO_SIGN MICRO_SIGN_NATIVE
+#define LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE \
+ LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE_NATIVE
+#define LATIN_SMALL_LETTER_A_WITH_RING_ABOVE \
+ LATIN_SMALL_LETTER_A_WITH_RING_ABOVE_NATIVE
#define UNICODE_GREEK_CAPITAL_LETTER_SIGMA 0x03A3
#define UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA 0x03C2
#define UNICODE_GREEK_SMALL_LETTER_SIGMA 0x03C3
@@ -431,6 +490,9 @@
#define GREEK_CAPITAL_LETTER_MU 0x039C /* Upper and title case of MICRON */
#define LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS 0x0178 /* Also is title case */
#define LATIN_CAPITAL_LETTER_SHARP_S 0x1E9E
+#define LATIN_SMALL_LETTER_LONG_S 0x017F
+#define KELVIN_SIGN 0x212A
+#define ANGSTROM_SIGN 0x212B
#define UNI_DISPLAY_ISPRINT 0x0001
#define UNI_DISPLAY_BACKSLASH 0x0002
@@ -437,14 +499,6 @@
#define UNI_DISPLAY_QQ (UNI_DISPLAY_ISPRINT|UNI_DISPLAY_BACKSLASH)
#define UNI_DISPLAY_REGEX (UNI_DISPLAY_ISPRINT|UNI_DISPLAY_BACKSLASH)
-#ifndef EBCDIC
-# define LATIN_SMALL_LETTER_SHARP_S 0x00DF
-# define LATIN_SMALL_LETTER_Y_WITH_DIAERESIS 0x00FF
-# define MICRO_SIGN 0x00B5
-# define LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE 0x00C5
-# define LATIN_SMALL_LETTER_A_WITH_RING_ABOVE 0x00E5
-#endif
-
#define ANYOF_FOLD_SHARP_S(node, input, end) \
(ANYOF_BITMAP_TEST(node, LATIN_SMALL_LETTER_SHARP_S) && \
(ANYOF_NONBITMAP(node)) && \
@@ -454,88 +508,71 @@
toLOWER((input)[1]) == 's')
#define SHARP_S_SKIP 2
-#ifdef EBCDIC
-/* IS_UTF8_CHAR() is not ported to EBCDIC */
-#else
-#define IS_UTF8_CHAR_1(p) \
- ((p)[0] <= 0x7F)
-#define IS_UTF8_CHAR_2(p) \
- ((p)[0] >= 0xC2 && (p)[0] <= 0xDF && \
- (p)[1] >= 0x80 && (p)[1] <= 0xBF)
-#define IS_UTF8_CHAR_3a(p) \
- ((p)[0] == 0xE0 && \
- (p)[1] >= 0xA0 && (p)[1] <= 0xBF && \
- (p)[2] >= 0x80 && (p)[2] <= 0xBF)
-#define IS_UTF8_CHAR_3b(p) \
- ((p)[0] >= 0xE1 && (p)[0] <= 0xEC && \
- (p)[1] >= 0x80 && (p)[1] <= 0xBF && \
- (p)[2] >= 0x80 && (p)[2] <= 0xBF)
-#define IS_UTF8_CHAR_3c(p) \
- ((p)[0] == 0xED && \
- (p)[1] >= 0x80 && (p)[1] <= 0xBF && \
- (p)[2] >= 0x80 && (p)[2] <= 0xBF)
-/* In IS_UTF8_CHAR_3c(p) one could use
- * (p)[1] >= 0x80 && (p)[1] <= 0x9F
- * if one wanted to exclude surrogates. */
-#define IS_UTF8_CHAR_3d(p) \
- ((p)[0] >= 0xEE && (p)[0] <= 0xEF && \
- (p)[1] >= 0x80 && (p)[1] <= 0xBF && \
- (p)[2] >= 0x80 && (p)[2] <= 0xBF)
-#define IS_UTF8_CHAR_4a(p) \
- ((p)[0] == 0xF0 && \
- (p)[1] >= 0x90 && (p)[1] <= 0xBF && \
- (p)[2] >= 0x80 && (p)[2] <= 0xBF && \
- (p)[3] >= 0x80 && (p)[3] <= 0xBF)
-#define IS_UTF8_CHAR_4b(p) \
- ((p)[0] >= 0xF1 && (p)[0] <= 0xF3 && \
- (p)[1] >= 0x80 && (p)[1] <= 0xBF && \
- (p)[2] >= 0x80 && (p)[2] <= 0xBF && \
- (p)[3] >= 0x80 && (p)[3] <= 0xBF)
-/* In IS_UTF8_CHAR_4c(p) one could use
- * (p)[0] == 0xF4
- * if one wanted to stop at the Unicode limit U+10FFFF.
- * The 0xF7 allows us to go to 0x1fffff (0x200000 would
- * require five bytes). Not doing any further code points
- * since that is not needed (and that would not be strict
- * UTF-8, anyway). The "slow path" in Perl_is_utf8_char()
- * will take care of the "extended UTF-8". */
-#define IS_UTF8_CHAR_4c(p) \
- ((p)[0] >= 0xF4 && (p)[0] <= 0xF7 && \
- (p)[1] >= 0x80 && (p)[1] <= 0xBF && \
- (p)[2] >= 0x80 && (p)[2] <= 0xBF && \
- (p)[3] >= 0x80 && (p)[3] <= 0xBF)
+/* If you want to exclude surrogates, and beyond legal Unicode, see the blame
+ * log for earlier versions which gave details for these */
-#define IS_UTF8_CHAR_3(p) \
- (IS_UTF8_CHAR_3a(p) || \
- IS_UTF8_CHAR_3b(p) || \
- IS_UTF8_CHAR_3c(p) || \
- IS_UTF8_CHAR_3d(p))
-#define IS_UTF8_CHAR_4(p) \
- (IS_UTF8_CHAR_4a(p) || \
- IS_UTF8_CHAR_4b(p) || \
- IS_UTF8_CHAR_4c(p))
+#ifndef EBCDIC
+/* This was generated by regen/regcharclass.pl, and then moved here. The lines
+ * that generated it were then commented out. This was done solely because it
+ * takes on the order of 10 minutes to generate, and is never going to change.
+ * The EBCDIC equivalent hasn't been commented out in regcharclass.pl, so it
+ * should generate and run the correct stuff */
+/*
+ UTF8_CHAR: Matches utf8 from 1 to 4 bytes
+ 0x0 - 0x1FFFFF
+*/
+/*** GENERATED CODE ***/
+#define is_UTF8_CHAR_utf8_safe(s,e) \
+( ((e)-(s) > 3) ? \
+ ( ( ( ((U8*)s)[0] & 0x80 ) == 0x00 ) ? 1 \
+ : ( 0xC2 <= ((U8*)s)[0] && ((U8*)s)[0] <= 0xDF ) ? \
+ ( ( ( ((U8*)s)[1] & 0xC0 ) == 0x80 ) ? 2 : 0 ) \
+ : ( 0xE0 == ((U8*)s)[0] ) ? \
+ ( ( ( ( ((U8*)s)[1] & 0xE0 ) == 0xA0 ) && ( ( ((U8*)s)[2] & 0xC0 ) == 0x80 ) ) ? 3 : 0 )\
+ : ( 0xE1 <= ((U8*)s)[0] && ((U8*)s)[0] <= 0xEF ) ? \
+ ( ( ( ( ((U8*)s)[1] & 0xC0 ) == 0x80 ) && ( ( ((U8*)s)[2] & 0xC0 ) == 0x80 ) ) ? 3 : 0 )\
+ : ( 0xF0 == ((U8*)s)[0] ) ? \
+ ( ( ( ( 0x90 <= ((U8*)s)[1] && ((U8*)s)[1] <= 0xBF ) && ( ( ((U8*)s)[2] & 0xC0 ) == 0x80 ) ) && ( ( ((U8*)s)[3] & 0xC0 ) == 0x80 ) ) ? 4 : 0 )\
+ : ( ( ( ( 0xF1 <= ((U8*)s)[0] && ((U8*)s)[0] <= 0xF7 ) && ( ( ((U8*)s)[1] & 0xC0 ) == 0x80 ) ) && ( ( ((U8*)s)[2] & 0xC0 ) == 0x80 ) ) && ( ( ((U8*)s)[3] & 0xC0 ) == 0x80 ) ) ? 4 : 0 )\
+: ((e)-(s) > 2) ? \
+ ( ( ( ((U8*)s)[0] & 0x80 ) == 0x00 ) ? 1 \
+ : ( 0xC2 <= ((U8*)s)[0] && ((U8*)s)[0] <= 0xDF ) ? \
+ ( ( ( ((U8*)s)[1] & 0xC0 ) == 0x80 ) ? 2 : 0 ) \
+ : ( 0xE0 == ((U8*)s)[0] ) ? \
+ ( ( ( ( ((U8*)s)[1] & 0xE0 ) == 0xA0 ) && ( ( ((U8*)s)[2] & 0xC0 ) == 0x80 ) ) ? 3 : 0 )\
+ : ( ( ( 0xE1 <= ((U8*)s)[0] && ((U8*)s)[0] <= 0xEF ) && ( ( ((U8*)s)[1] & 0xC0 ) == 0x80 ) ) && ( ( ((U8*)s)[2] & 0xC0 ) == 0x80 ) ) ? 3 : 0 )\
+: ((e)-(s) > 1) ? \
+ ( ( ( ((U8*)s)[0] & 0x80 ) == 0x00 ) ? 1 \
+ : ( ( 0xC2 <= ((U8*)s)[0] && ((U8*)s)[0] <= 0xDF ) && ( ( ((U8*)s)[1] & 0xC0 ) == 0x80 ) ) ? 2 : 0 )\
+: ((e)-(s) > 0) ? \
+ ( ( ((U8*)s)[0] & 0x80 ) == 0x00 ) \
+: 0 )
+#endif
+
/* IS_UTF8_CHAR(p) is strictly speaking wrong (not UTF-8) because it
* (1) allows UTF-8 encoded UTF-16 surrogates
* (2) it allows code points past U+10FFFF.
* The Perl_is_utf8_char() full "slow" code will handle the Perl
* "extended UTF-8". */
-#define IS_UTF8_CHAR(p, n) \
- ((n) == 1 ? IS_UTF8_CHAR_1(p) : \
- (n) == 2 ? IS_UTF8_CHAR_2(p) : \
- (n) == 3 ? IS_UTF8_CHAR_3(p) : \
- (n) == 4 ? IS_UTF8_CHAR_4(p) : 0)
+#define IS_UTF8_CHAR(p, n) (is_UTF8_CHAR_utf8_safe(p, (p) + (n)) == n)
-#define IS_UTF8_CHAR_FAST(n) ((n) <= 4)
+/* regen/regcharclass.pl generates is_UTF8_CHAR_utf8_safe() macros for up to
+ * these number of bytes. So this has to be coordinated with it */
+#ifdef EBCDIC
+# define IS_UTF8_CHAR_FAST(n) ((n) <= 5)
+#else
+# define IS_UTF8_CHAR_FAST(n) ((n) <= 4)
+#endif
-#endif /* IS_UTF8_CHAR() for UTF-8 */
+#endif /* H_UTF8 */
/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/utf8.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/utfebcdic.h
===================================================================
--- trunk/contrib/perl/utfebcdic.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/utfebcdic.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -1,7 +1,7 @@
/* utfebcdic.h
*
- * Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 2009 by Larry Wall,
- * Nick Ing-Simmons, and others
+ * Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 2009,
+ * 2010, 2011 by Larry Wall, Nick Ing-Simmons, and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
@@ -152,7 +152,7 @@
* remains 'A' */
#if '^' == 95 /* if defined(__MVS__) || defined(??) (VM/ESA?) 1047 */
-EXTCONST unsigned char PL_utf2e[] = { /* I8 to EBCDIC (IBM-1047) */
+EXTCONST unsigned char PL_utf2e[] = { /* I8 to UTFEBCDIC (IBM-1047) */
0x00, 0x01, 0x02, 0x03, 0x37, 0x2D, 0x2E, 0x2F, 0x16, 0x05, 0x15, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,
0x10, 0x11, 0x12, 0x13, 0x3C, 0x3D, 0x32, 0x26, 0x18, 0x19, 0x3F, 0x27, 0x1C, 0x1D, 0x1E, 0x1F,
0x40, 0x5A, 0x7F, 0x7B, 0x5B, 0x6C, 0x50, 0x7D, 0x4D, 0x5D, 0x5C, 0x4E, 0x6B, 0x60, 0x4B, 0x61,
@@ -171,7 +171,7 @@
0xDC, 0xDD, 0xDE, 0xDF, 0xE1, 0xEA, 0xEB, 0xEC, 0xED, 0xEE, 0xEF, 0xFA, 0xFB, 0xFC, 0xFD, 0xFE
};
-EXTCONST unsigned char PL_e2utf[] = { /* EBCDIC (IBM-1047) to I8 */
+EXTCONST unsigned char PL_e2utf[] = { /* UTFEBCDIC (IBM-1047) to I8 */
0x00, 0x01, 0x02, 0x03, 0x9C, 0x09, 0x86, 0x7F, 0x97, 0x8D, 0x8E, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,
0x10, 0x11, 0x12, 0x13, 0x9D, 0x0A, 0x08, 0x87, 0x18, 0x19, 0x92, 0x8F, 0x1C, 0x1D, 0x1E, 0x1F,
0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x17, 0x1B, 0x88, 0x89, 0x8A, 0x8B, 0x8C, 0x05, 0x06, 0x07,
@@ -192,7 +192,7 @@
#endif /* 1047 */
#if '^' == 106 /* if defined(_OSD_POSIX) POSIX-BC */
-unsigned char PL_utf2e[] = { /* I8 to EBCDIC (POSIX-BC) */
+unsigned char PL_utf2e[] = { /* I8 to UTFEBCDIC (POSIX-BC) */
0x00, 0x01, 0x02, 0x03, 0x37, 0x2D, 0x2E, 0x2F, 0x16, 0x05, 0x15, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,
0x10, 0x11, 0x12, 0x13, 0x3C, 0x3D, 0x32, 0x26, 0x18, 0x19, 0x3F, 0x27, 0x1C, 0x1D, 0x1E, 0x1F,
0x40, 0x5A, 0x7F, 0x7B, 0x5B, 0x6C, 0x50, 0x7D, 0x4D, 0x5D, 0x5C, 0x4E, 0x6B, 0x60, 0x4B, 0x61,
@@ -211,7 +211,7 @@
0xDC, 0xC0, 0xDE, 0xDF, 0xE1, 0xEA, 0xEB, 0xEC, 0xED, 0xEE, 0xEF, 0xFA, 0xDD, 0xFC, 0xE0, 0xFE
};
-unsigned char PL_e2utf[] = { /* EBCDIC (POSIX-BC) to I8 */
+unsigned char PL_e2utf[] = { /* UTFEBCDIC (POSIX-BC) to I8 */
0x00, 0x01, 0x02, 0x03, 0x9C, 0x09, 0x86, 0x7F, 0x97, 0x8D, 0x8E, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,
0x10, 0x11, 0x12, 0x13, 0x9D, 0x0A, 0x08, 0x87, 0x18, 0x19, 0x92, 0x8F, 0x1C, 0x1D, 0x1E, 0x1F,
0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x17, 0x1B, 0x88, 0x89, 0x8A, 0x8B, 0x8C, 0x05, 0x06, 0x07,
@@ -232,7 +232,7 @@
#endif /* POSIX-BC */
#if '^' == 176 /* if defined(??) (OS/400?) 037 */
-unsigned char PL_utf2e[] = { /* I8 to EBCDIC (IBM-037) */
+unsigned char PL_utf2e[] = { /* I8 to UTFEBCDIC (IBM-037) */
0x00, 0x01, 0x02, 0x03, 0x37, 0x2D, 0x2E, 0x2F, 0x16, 0x05, 0x25, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,
0x10, 0x11, 0x12, 0x13, 0x3C, 0x3D, 0x32, 0x26, 0x18, 0x19, 0x3F, 0x27, 0x1C, 0x1D, 0x1E, 0x1F,
0x40, 0x5A, 0x7F, 0x7B, 0x5B, 0x6C, 0x50, 0x7D, 0x4D, 0x5D, 0x5C, 0x4E, 0x6B, 0x60, 0x4B, 0x61,
@@ -251,7 +251,7 @@
0xDC, 0xDD, 0xDE, 0xDF, 0xE1, 0xEA, 0xEB, 0xEC, 0xED, 0xEE, 0xEF, 0xFA, 0xFB, 0xFC, 0xFD, 0xFE
};
-unsigned char PL_e2utf[] = { /* EBCDIC (IBM-037) to I8 */
+unsigned char PL_e2utf[] = { /* UTFEBCDIC (IBM-037) to I8 */
0x00, 0x01, 0x02, 0x03, 0x9C, 0x09, 0x86, 0x7F, 0x97, 0x8D, 0x8E, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,
0x10, 0x11, 0x12, 0x13, 0x9D, 0x85, 0x08, 0x87, 0x18, 0x19, 0x92, 0x8F, 0x1C, 0x1D, 0x1E, 0x1F,
0x80, 0x81, 0x82, 0x83, 0x84, 0x0A, 0x17, 0x1B, 0x88, 0x89, 0x8A, 0x8B, 0x8C, 0x05, 0x06, 0x07,
@@ -295,12 +295,6 @@
0x8C, 0x49, 0xCD, 0xCE, 0xCB, 0xCF, 0xCC, 0xE1, 0x70, 0xDD, 0xDE, 0xDB, 0xDC, 0x8D, 0x8E, 0xDF
};
-#define LATIN_SMALL_LETTER_Y_WITH_DIAERESIS 0xDF
-#define LATIN_SMALL_LETTER_SHARP_S 0x59
-#define MICRO_SIGN 0xA0
-#define LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE 0x0067
-#define LATIN_SMALL_LETTER_A_WITH_RING_ABOVE 0x0047
-
EXTCONST unsigned char PL_e2a[] = { /* EBCDIC (IBM-1047) to ASCII (iso-8859-1) */
0x00, 0x01, 0x02, 0x03, 0x9C, 0x09, 0x86, 0x7F, 0x97, 0x8D, 0x8E, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,
0x10, 0x11, 0x12, 0x13, 0x9D, 0x0A, 0x08, 0x87, 0x18, 0x19, 0x92, 0x8F, 0x1C, 0x1D, 0x1E, 0x1F,
@@ -377,12 +371,6 @@
0x8C, 0x49, 0xCD, 0xCE, 0xCB, 0xCF, 0xCC, 0xE1, 0x70, 0xC0, 0xDE, 0xDB, 0xDC, 0x8D, 0x8E, 0xDF
};
-#define LATIN_SMALL_LETTER_Y_WITH_DIAERESIS 0xDF
-#define LATIN_SMALL_LETTER_SHARP_S 0x59
-#define MICRO_SIGN 0xA0
-#define LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE 0x0067
-#define LATIN_SMALL_LETTER_A_WITH_RING_ABOVE 0x0047
-
EXTCONST unsigned char PL_e2a[] = { /* EBCDIC (POSIX-BC) to ASCII (ISO8859-1) */
0x00, 0x01, 0x02, 0x03, 0x9C, 0x09, 0x86, 0x7F, 0x97, 0x8D, 0x8E, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,
0x10, 0x11, 0x12, 0x13, 0x9D, 0x0A, 0x08, 0x87, 0x18, 0x19, 0x92, 0x8F, 0x1C, 0x1D, 0x1E, 0x1F,
@@ -459,13 +447,6 @@
0x8C, 0x49, 0xCD, 0xCE, 0xCB, 0xCF, 0xCC, 0xE1, 0x70, 0xDD, 0xDE, 0xDB, 0xDC, 0x8D, 0x8E, 0xDF
};
-
-#define LATIN_SMALL_LETTER_Y_WITH_DIAERESIS 0xDF
-#define LATIN_SMALL_LETTER_SHARP_S 0x59
-#define MICRO_SIGN 0xA0
-#define LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE 0x0067
-#define LATIN_SMALL_LETTER_A_WITH_RING_ABOVE 0x0047
-
EXTCONST unsigned char PL_e2a[] = { /* EBCDIC (IBM-037) to ASCII (ISO8859-1) */
0x00, 0x01, 0x02, 0x03, 0x9C, 0x09, 0x86, 0x7F, 0x97, 0x8D, 0x8E, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,
0x10, 0x11, 0x12, 0x13, 0x9D, 0x85, 0x08, 0x87, 0x18, 0x19, 0x92, 0x8F, 0x1C, 0x1D, 0x1E, 0x1F,
@@ -522,6 +503,10 @@
};
#endif /* 037 */
+/* Since the EBCDIC code pages are isomorphic to Latin1, that table is merely a
+ * duplicate */
+EXTCONST unsigned char * PL_fold_latin1 = PL_fold;
+
#else
EXTCONST unsigned char PL_utf8skip[];
EXTCONST unsigned char PL_e2utf[];
@@ -529,12 +514,9 @@
EXTCONST unsigned char PL_e2a[];
EXTCONST unsigned char PL_a2e[];
EXTCONST unsigned char PL_fold[];
+EXTCONST unsigned char * PL_fold_latin1;
#endif
-/* Since the EBCDIC code pages are isomorphic to Latin1, that table is merely a
- * duplicate */
-EXTCONST unsigned char * PL_fold_latin1 = PL_fold;
-
END_EXTERN_C
/* EBCDIC-happy ways of converting native code to UTF-8 */
@@ -544,7 +526,9 @@
#define ASCII_TO_NATIVE(ch) PL_a2e[(U8)(ch)]
/* Transform after encoding, essentially converts to/from I8 */
#define NATIVE_TO_UTF(ch) PL_e2utf[(U8)(ch)] /* to I8 */
+#define NATIVE_TO_I8(ch) NATIVE_TO_UTF(ch) /* synonym */
#define UTF_TO_NATIVE(ch) PL_utf2e[(U8)(ch)] /* from I8 */
+#define I8_TO_NATIVE(ch) UTF_TO_NATIVE(ch) /* synonym */
/* Transform in wide UV char space */
#define NATIVE_TO_UNI(ch) (((ch) > 255) ? (ch) : NATIVE_TO_ASCII(ch))
#define UNI_TO_NATIVE(ch) (((ch) > 255) ? (ch) : ASCII_TO_NATIVE(ch))
@@ -558,8 +542,6 @@
Unicode Bit pattern 1st Byte 2nd Byte 3rd Byte 4th Byte 5th Byte 6th Byte 7th byte
U+0000..U+007F 000000000xxxxxxx 0xxxxxxx
U+0080..U+009F 00000000100xxxxx 100xxxxx
- U+00A0..U+00FF 00000000yyyxxxxx 11000yyy 101xxxxx
-
U+00A0..U+03FF 000000yyyyyxxxxx 110yyyyy 101xxxxx
U+0400..U+3FFF 00zzzzyyyyyxxxxx 1110zzzz 101yyyyy 101xxxxx
U+4000..U+3FFFF 0wwwzzzzzyyyyyxxxxx 11110www 101zzzzz 101yyyyy 101xxxxx
@@ -579,13 +561,17 @@
(uv) < 0x400000 ? 5 : \
(uv) < 0x4000000 ? 6 : 7 )
+#define UNI_IS_INVARIANT(c) ((c) < 0xA0)
-#define UNI_IS_INVARIANT(c) ((c) < 0xA0)
-/* UTF-EBCDIC semantic macros - transform back into I8 and then compare */
-#define UTF8_IS_START(c) (NATIVE_TO_UTF(c) >= 0xA0 && (NATIVE_TO_UTF(c) & 0xE0) != 0xA0)
+/* UTF-EBCDIC semantic macros - transform back into I8 and then compare
+ * Comments as to the meaning of each are given at their corresponding utf8.h
+ * definitions */
+
+#define UTF8_IS_START(c) (NATIVE_TO_UTF(c) >= 0xC5 && NATIVE_TO_UTF(c) != 0xE0)
#define UTF8_IS_CONTINUATION(c) ((NATIVE_TO_UTF(c) & 0xE0) == 0xA0)
#define UTF8_IS_CONTINUED(c) (NATIVE_TO_UTF(c) >= 0xA0)
-#define UTF8_IS_DOWNGRADEABLE_START(c) (NATIVE_TO_UTF(c) >= 0xA0 && (NATIVE_TO_UTF(c) & 0xF8) == 0xC0)
+#define UTF8_IS_DOWNGRADEABLE_START(c) (NATIVE_TO_UTF(c) >= 0xC5 && NATIVE_TO_UTF(c) <= 0xC7)
+#define UTF8_IS_ABOVE_LATIN1(c) (NATIVE_TO_I8(c) >= 0xC8)
#define UTF_START_MARK(len) (((len) > 7) ? 0xFF : ((U8)(0xFE << (7-(len)))))
#define UTF_START_MASK(len) (((len) >= 6) ? 0x01 : (0x1F >> ((len)-2)))
@@ -593,12 +579,25 @@
#define UTF_CONTINUATION_MASK ((U8)0x1f)
#define UTF_ACCUMULATION_SHIFT 5
+/* How wide can a single UTF-8 encoded character become in bytes. */
+/* NOTE: Strictly speaking Perl's UTF-8 should not be called UTF-8 since UTF-8
+ * is an encoding of Unicode, and Unicode's upper limit, 0x10FFFF, can be
+ * expressed with 5 bytes. However, Perl thinks of UTF-8 as a way to encode
+ * non-negative integers in a binary format, even those above Unicode */
+#define UTF8_MAXBYTES 7
+
+/* The maximum number of UTF-8 bytes a single Unicode character can
+ * uppercase/lowercase/fold into. Unicode guarantees that the maximum
+ * expansion is 3 characters. On EBCDIC platforms, the highest Unicode
+ * character occupies 5 bytes, therefore this number is 15 */
+#define UTF8_MAXBYTES_CASE 15
+
/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/utfebcdic.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/util.c
===================================================================
--- trunk/contrib/perl/util.c 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/util.c 2013-12-02 21:18:17 UTC (rev 6438)
@@ -12,7 +12,7 @@
* 'Very useful, no doubt, that was to Saruman; yet it seems that he was
* not content.' --Gandalf to Pippin
*
- * [p.598 of _The Lord of the Rings_, III/xi: "The Palant\xEDr"]
+ * [p.598 of _The Lord of the Rings_, III/xi: "The PalantÃr"]
*/
/* This file contains assorted utility routines.
@@ -24,6 +24,7 @@
#include "EXTERN.h"
#define PERL_IN_UTIL_C
#include "perl.h"
+#include "reentr.h"
#ifdef USE_PERLIO
#include "perliol.h" /* For PerlIOUnix_refcnt */
@@ -41,10 +42,6 @@
int putenv(char *);
#endif
-#ifdef I_SYS_WAIT
-# include <sys/wait.h>
-#endif
-
#ifdef HAS_SELECT
# ifdef I_SYS_SELECT
# include <sys/select.h>
@@ -63,17 +60,6 @@
* XXX This advice seems to be widely ignored :-( --AD August 1996.
*/
-static char *
-S_write_no_mem(pTHX)
-{
- dVAR;
- /* Can't use PerlIO to write as it allocates memory */
- PerlLIO_write(PerlIO_fileno(Perl_error_log),
- PL_no_mem, strlen(PL_no_mem));
- my_exit(1);
- NORETURN_FUNCTION_END;
-}
-
#if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
# define ALWAYS_NEED_THX
#endif
@@ -98,8 +84,8 @@
size += sTHX;
#endif
#ifdef DEBUGGING
- if ((long)size < 0)
- Perl_croak_nocontext("panic: malloc");
+ if ((SSize_t)size < 0)
+ Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size);
#endif
ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
PERL_ALLOC_CHECK(ptr);
@@ -135,7 +121,7 @@
if (PL_nomemok)
return NULL;
else {
- return write_no_mem();
+ croak_no_mem();
}
}
/*NOTREACHED*/
@@ -176,7 +162,8 @@
= (struct perl_memory_debug_header *)where;
if (header->interpreter != aTHX) {
- Perl_croak_nocontext("panic: realloc from wrong pool");
+ Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p",
+ header->interpreter, aTHX);
}
assert(header->next->prev == header);
assert(header->prev->next == header);
@@ -191,8 +178,8 @@
}
#endif
#ifdef DEBUGGING
- if ((long)size < 0)
- Perl_croak_nocontext("panic: realloc");
+ if ((SSize_t)size < 0)
+ Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size);
#endif
ptr = (Malloc_t)PerlMem_realloc(where,size);
PERL_ALLOC_CHECK(ptr);
@@ -237,7 +224,7 @@
if (PL_nomemok)
return NULL;
else {
- return write_no_mem();
+ croak_no_mem();
}
}
/*NOTREACHED*/
@@ -262,14 +249,19 @@
= (struct perl_memory_debug_header *)where;
if (header->interpreter != aTHX) {
- Perl_croak_nocontext("panic: free from wrong pool");
+ Perl_croak_nocontext("panic: free from wrong pool, %p!=%p",
+ header->interpreter, aTHX);
}
if (!header->prev) {
Perl_croak_nocontext("panic: duplicate free");
}
- if (!(header->next) || header->next->prev != header
- || header->prev->next != header) {
- Perl_croak_nocontext("panic: bad free");
+ if (!(header->next))
+ Perl_croak_nocontext("panic: bad free, header->next==NULL");
+ if (header->next->prev != header || header->prev->next != header) {
+ Perl_croak_nocontext("panic: bad free, ->next->prev=%p, "
+ "header=%p, ->prev->next=%p",
+ header->next->prev, header,
+ header->prev->next);
}
/* Unlink us from the chain. */
header->next->prev = header->prev;
@@ -294,18 +286,23 @@
dTHX;
#endif
Malloc_t ptr;
+#if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)
MEM_SIZE total_size = 0;
+#endif
/* Even though calloc() for zero bytes is strange, be robust. */
- if (size && (count <= MEM_SIZE_MAX / size))
+ if (size && (count <= MEM_SIZE_MAX / size)) {
+#if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)
total_size = size * count;
+#endif
+ }
else
- Perl_croak_nocontext("%s", PL_memory_wrap);
+ Perl_croak_memory_wrap();
#ifdef PERL_TRACK_MEMPOOL
if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
total_size += sTHX;
else
- Perl_croak_nocontext("%s", PL_memory_wrap);
+ Perl_croak_memory_wrap();
#endif
#ifdef HAS_64K_LIMIT
if (total_size > 0xffff) {
@@ -315,8 +312,9 @@
}
#endif /* HAS_64K_LIMIT */
#ifdef DEBUGGING
- if ((long)size < 0 || (long)count < 0)
- Perl_croak_nocontext("panic: calloc");
+ if ((SSize_t)size < 0 || (SSize_t)count < 0)
+ Perl_croak_nocontext("panic: calloc, size=%"UVuf", count=%"UVuf,
+ (UV)size, (UV)count);
#endif
#ifdef PERL_TRACK_MEMPOOL
/* Have to use malloc() because we've added some space for our tracking
@@ -360,7 +358,7 @@
#endif
if (PL_nomemok)
return NULL;
- return write_no_mem();
+ croak_no_mem();
}
}
@@ -398,9 +396,9 @@
/* copy a string up to some (non-backslashed) delimiter, if any */
char *
-Perl_delimcpy(register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
+Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend, int delim, I32 *retlen)
{
- register I32 tolen;
+ I32 tolen;
PERL_ARGS_ASSERT_DELIMCPY;
@@ -428,38 +426,19 @@
/* This routine was donated by Corey Satten. */
char *
-Perl_instr(register const char *big, register const char *little)
+Perl_instr(const char *big, const char *little)
{
- register I32 first;
PERL_ARGS_ASSERT_INSTR;
+ /* libc prior to 4.6.27 did not work properly on a NULL 'little' */
if (!little)
return (char*)big;
- first = *little++;
- if (!first)
- return (char*)big;
- while (*big) {
- register const char *s, *x;
- if (*big++ != first)
- continue;
- for (x=big,s=little; *s; /**/ ) {
- if (!*x)
- return NULL;
- if (*s != *x)
- break;
- else {
- s++;
- x++;
- }
- }
- if (!*s)
- return (char*)(big-1);
- }
- return NULL;
+ return strstr((char*)big, (char*)little);
}
-/* same as instr but allow embedded nulls */
+/* same as instr but allow embedded nulls. The end pointers point to 1 beyond
+ * the final character desired to be checked */
char *
Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
@@ -488,11 +467,11 @@
/* reverse of the above--find last substring */
char *
-Perl_rninstr(register const char *big, const char *bigend, const char *little, const char *lend)
+Perl_rninstr(const char *big, const char *bigend, const char *little, const char *lend)
{
- register const char *bigbeg;
- register const I32 first = *little;
- register const char * const littleend = lend;
+ const char *bigbeg;
+ const I32 first = *little;
+ const char * const littleend = lend;
PERL_ARGS_ASSERT_RNINSTR;
@@ -501,7 +480,7 @@
bigbeg = big;
big = bigend - (littleend - little++);
while (big >= bigbeg) {
- register const char *s, *x;
+ const char *s, *x;
if (*big-- != first)
continue;
for (x=big+2,s=little; s < littleend; /**/ ) {
@@ -539,14 +518,21 @@
Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
{
dVAR;
- register const U8 *s;
- register U32 i;
+ const U8 *s;
+ STRLEN i;
STRLEN len;
- U32 rarest = 0;
+ STRLEN rarest = 0;
U32 frequency = 256;
+ MAGIC *mg;
PERL_ARGS_ASSERT_FBM_COMPILE;
+ if (isGV_with_GP(sv))
+ return;
+
+ if (SvVALID(sv))
+ return;
+
if (flags & FBMcf_TAIL) {
MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
@@ -556,31 +542,49 @@
s = (U8*)SvPV_force_mutable(sv, len);
if (len == 0) /* TAIL might be on a zero-length string. */
return;
- SvUPGRADE(sv, SVt_PVGV);
+ SvUPGRADE(sv, SVt_PVMG);
SvIOK_off(sv);
SvNOK_off(sv);
SvVALID_on(sv);
+
+ /* "deep magic", the comment used to add. The use of MAGIC itself isn't
+ really. MAGIC was originally added in 79072805bf63abe5 (perl 5.0 alpha 2)
+ to call SvVALID_off() if the scalar was assigned to.
+
+ The comment itself (and "deeper magic" below) date back to
+ 378cc40b38293ffc (perl 2.0). "deep magic" was an annotation on
+ str->str_pok |= 2;
+ where the magic (presumably) was that the scalar had a BM table hidden
+ inside itself.
+
+ As MAGIC is always present on BMs [in Perl 5 :-)], we can use it to store
+ the table instead of the previous (somewhat hacky) approach of co-opting
+ the string buffer and storing it after the string. */
+
+ assert(!mg_find(sv, PERL_MAGIC_bm));
+ mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0);
+ assert(mg);
+
if (len > 2) {
- const unsigned char *sb;
+ /* Shorter strings are special-cased in Perl_fbm_instr(), and don't use
+ the BM table. */
const U8 mlen = (len>255) ? 255 : (U8)len;
- register U8 *table;
+ const unsigned char *const sb = s + len - mlen; /* first char (maybe) */
+ U8 *table;
- Sv_Grow(sv, len + 256 + PERL_FBM_TABLE_OFFSET);
- table
- = (unsigned char*)(SvPVX_mutable(sv) + len + PERL_FBM_TABLE_OFFSET);
- s = table - 1 - PERL_FBM_TABLE_OFFSET; /* last char */
+ Newx(table, 256, U8);
memset((void*)table, mlen, 256);
+ mg->mg_ptr = (char *)table;
+ mg->mg_len = 256;
+
+ s += len - 1; /* last char */
i = 0;
- sb = s - mlen + 1; /* first char (maybe) */
while (s >= sb) {
if (table[*s] == mlen)
table[*s] = (U8)i;
s--, i++;
}
- } else {
- Sv_Grow(sv, len + PERL_FBM_TABLE_OFFSET);
}
- sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0); /* deep magic */
s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
for (i = 0; i < len; i++) {
@@ -589,14 +593,13 @@
frequency = PL_freq[s[i]];
}
}
- BmFLAGS(sv) = (U8)flags;
BmRARE(sv) = s[rarest];
BmPREVIOUS(sv) = rarest;
BmUSEFUL(sv) = 100; /* Initial value */
if (flags & FBMcf_TAIL)
SvTAIL_on(sv);
- DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %lu\n",
- BmRARE(sv),(unsigned long)BmPREVIOUS(sv)));
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %"UVuf"\n",
+ BmRARE(sv), BmPREVIOUS(sv)));
}
/* If SvTAIL(littlestr), it has a fake '\n' at end. */
@@ -606,8 +609,8 @@
/*
=for apidoc fbm_instr
-Returns the location of the SV in the string delimited by C<str> and
-C<strend>. It returns C<NULL> if the string can't be found. The C<sv>
+Returns the location of the SV in the string delimited by C<big> and
+C<bigend>. It returns C<NULL> if the string can't be found. The C<sv>
does not have to be fbm_compiled, but the search will not be as fast
then.
@@ -615,14 +618,13 @@
*/
char *
-Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
+Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U32 flags)
{
- register unsigned char *s;
+ unsigned char *s;
STRLEN l;
- register const unsigned char *little
- = (const unsigned char *)SvPV_const(littlestr,l);
- register STRLEN littlelen = l;
- register const I32 multiline = flags & FBMrf_MULTILINE;
+ const unsigned char *little = (const unsigned char *)SvPV_const(littlestr,l);
+ STRLEN littlelen = l;
+ const I32 multiline = flags & FBMrf_MULTILINE;
PERL_ARGS_ASSERT_FBM_INSTR;
@@ -636,9 +638,10 @@
return NULL;
}
- if (littlelen <= 2) { /* Special-cased */
-
- if (littlelen == 1) {
+ switch (littlelen) { /* Special cases for 0, 1 and 2 */
+ case 0:
+ return (char*)big; /* Cannot be SvTAIL! */
+ case 1:
if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
/* Know that bigend != big. */
if (bigend[-1] == '\n')
@@ -654,11 +657,7 @@
if (SvTAIL(littlestr))
return (char *) bigend;
return NULL;
- }
- if (!littlelen)
- return (char*)big; /* Cannot be SvTAIL! */
-
- /* littlelen is 2 */
+ case 2:
if (SvTAIL(littlestr) && !multiline) {
if (bigend[-1] == '\n' && bigend[-2] == *little)
return (char*)bigend - 2;
@@ -718,7 +717,10 @@
if (SvTAIL(littlestr) && (*bigend == *little))
return (char *)bigend; /* bigend is already decremented. */
return NULL;
+ default:
+ break; /* Only lengths 0 1 and 2 have special-case code. */
}
+
if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
s = bigend - littlelen;
if (s >= big && bigend[-1] == '\n' && *s == *little
@@ -756,9 +758,9 @@
return NULL;
{
- register const unsigned char * const table
- = little + littlelen + PERL_FBM_TABLE_OFFSET;
- register const unsigned char *oldlittle;
+ const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm);
+ const unsigned char * const table = (const unsigned char *) mg->mg_ptr;
+ const unsigned char *oldlittle;
--littlelen; /* Last char found by table lookup */
@@ -766,7 +768,7 @@
little += littlelen; /* last char */
oldlittle = little;
if (s < bigend) {
- register I32 tmp;
+ I32 tmp;
top2:
if ((tmp = table[*s])) {
@@ -775,7 +777,7 @@
goto check_end;
}
else { /* less expensive than calling strncmp() */
- register unsigned char * const olds = s;
+ unsigned char * const olds = s;
tmp = littlelen;
@@ -793,7 +795,7 @@
}
check_end:
if ( s == bigend
- && (BmFLAGS(littlestr) & FBMcf_TAIL)
+ && SvTAIL(littlestr)
&& memEQ((char *)(bigend - littlelen),
(char *)(oldlittle - littlelen), littlelen) )
return (char*)bigend - littlelen;
@@ -801,109 +803,21 @@
}
}
-/* start_shift, end_shift are positive quantities which give offsets
- of ends of some substring of bigstr.
- If "last" we want the last occurrence.
- old_posp is the way of communication between consequent calls if
- the next call needs to find the .
- The initial *old_posp should be -1.
-
- Note that we take into account SvTAIL, so one can get extra
- optimizations if _ALL flag is set.
- */
-
-/* If SvTAIL is actually due to \Z or \z, this gives false positives
- if PL_multiline. In fact if !PL_multiline the authoritative answer
- is not supported yet. */
-
char *
Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
{
dVAR;
- register const unsigned char *big;
- register I32 pos;
- register I32 previous;
- register I32 first;
- register const unsigned char *little;
- register I32 stop_pos;
- register const unsigned char *littleend;
- I32 found = 0;
-
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);
- assert(SvTYPE(littlestr) == SVt_PVGV);
- assert(SvVALID(littlestr));
-
- if (*old_posp == -1
- ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
- : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
- cant_find:
- if ( BmRARE(littlestr) == '\n'
- && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
- little = (const unsigned char *)(SvPVX_const(littlestr));
- littleend = little + SvCUR(littlestr);
- first = *little++;
- goto check_tail;
- }
- return NULL;
- }
-
- little = (const unsigned char *)(SvPVX_const(littlestr));
- littleend = little + SvCUR(littlestr);
- first = *little++;
- /* The value of pos we can start at: */
- previous = BmPREVIOUS(littlestr);
- big = (const unsigned char *)(SvPVX_const(bigstr));
- /* The value of pos we can stop at: */
- stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
- if (previous + start_shift > stop_pos) {
-/*
- stop_pos does not include SvTAIL in the count, so this check is incorrect
- (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
-*/
-#if 0
- if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
- goto check_tail;
-#endif
- return NULL;
- }
- while (pos < previous + start_shift) {
- if (!(pos += PL_screamnext[pos]))
- goto cant_find;
- }
- big -= previous;
- do {
- register const unsigned char *s, *x;
- if (pos >= stop_pos) break;
- if (big[pos] != first)
- continue;
- for (x=big+pos+1,s=little; s < littleend; /**/ ) {
- if (*s++ != *x++) {
- s--;
- break;
- }
- }
- if (s == littleend) {
- *old_posp = pos;
- if (!last) return (char *)(big+pos);
- found = 1;
- }
- } while ( pos += PL_screamnext[pos] );
- if (last && found)
- return (char *)(big+(*old_posp));
- check_tail:
- if (!SvTAIL(littlestr) || (end_shift > 0))
- return NULL;
- /* Ignore the trailing "\n". This code is not microoptimized */
- big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr));
- stop_pos = littleend - little; /* Actual littlestr len */
- if (stop_pos == 0)
- return (char*)big;
- big -= stop_pos;
- if (*big == first
- && ((stop_pos == 1) ||
- memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
- return (char*)big;
+ /* 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");
return NULL;
}
@@ -920,13 +834,15 @@
I32
-Perl_foldEQ(const char *s1, const char *s2, register I32 len)
+Perl_foldEQ(const char *s1, const char *s2, I32 len)
{
- register const U8 *a = (const U8 *)s1;
- register const U8 *b = (const U8 *)s2;
+ const U8 *a = (const U8 *)s1;
+ const U8 *b = (const U8 *)s2;
PERL_ARGS_ASSERT_FOLDEQ;
+ assert(len >= 0);
+
while (len--) {
if (*a != *b && *a != PL_fold[*b])
return 0;
@@ -935,7 +851,7 @@
return 1;
}
I32
-Perl_foldEQ_latin1(const char *s1, const char *s2, register I32 len)
+Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
{
/* Compare non-utf8 using Unicode (Latin1) semantics. Does not work on
* MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
@@ -942,11 +858,13 @@
* LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these. Nor
* does it check that the strings each have at least 'len' characters */
- register const U8 *a = (const U8 *)s1;
- register const U8 *b = (const U8 *)s2;
+ const U8 *a = (const U8 *)s1;
+ const U8 *b = (const U8 *)s2;
PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
+ assert(len >= 0);
+
while (len--) {
if (*a != *b && *a != PL_fold_latin1[*b]) {
return 0;
@@ -966,14 +884,16 @@
*/
I32
-Perl_foldEQ_locale(const char *s1, const char *s2, register I32 len)
+Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
{
dVAR;
- register const U8 *a = (const U8 *)s1;
- register const U8 *b = (const U8 *)s2;
+ const U8 *a = (const U8 *)s1;
+ const U8 *b = (const U8 *)s2;
PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
+ assert(len >= 0);
+
while (len--) {
if (*a != *b && *a != PL_fold_locale[*b])
return 0;
@@ -1025,11 +945,13 @@
*/
char *
-Perl_savepvn(pTHX_ const char *pv, register I32 len)
+Perl_savepvn(pTHX_ const char *pv, I32 len)
{
- register char *newaddr;
+ char *newaddr;
PERL_UNUSED_CONTEXT;
+ assert(len >= 0);
+
Newx(newaddr,len+1,char);
/* Give a meaning to NULL pointer mainly for the use in sv_magic() */
if (pv) {
@@ -1053,7 +975,7 @@
char *
Perl_savesharedpv(pTHX_ const char *pv)
{
- register char *newaddr;
+ char *newaddr;
STRLEN pvlen;
if (!pv)
return NULL;
@@ -1061,7 +983,7 @@
pvlen = strlen(pv)+1;
newaddr = (char*)PerlMemShared_malloc(pvlen);
if (!newaddr) {
- return write_no_mem();
+ croak_no_mem();
}
return (char*)memcpy(newaddr, pv, pvlen);
}
@@ -1080,10 +1002,10 @@
{
char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
- PERL_ARGS_ASSERT_SAVESHAREDPVN;
+ /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */
if (!newaddr) {
- return write_no_mem();
+ croak_no_mem();
}
newaddr[len] = '\0';
return (char*)memcpy(newaddr, pv, len);
@@ -1103,7 +1025,7 @@
{
STRLEN len;
const char * const pv = SvPV_const(sv, len);
- register char *newaddr;
+ char *newaddr;
PERL_ARGS_ASSERT_SAVESVPV;
@@ -1361,10 +1283,13 @@
if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
&& IoLINES(GvIOp(PL_last_in_gv)))
{
+ STRLEN l;
const bool line_mode = (RsSIMPLE(PL_rs) &&
- SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
- Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
- PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
+ *SvPV_const(PL_rs,l) == '\n' && l == 1);
+ Perl_sv_catpvf(aTHX_ sv, ", <%"SVf"> %s %"IVdf,
+ SVfARG(PL_last_in_gv == PL_argvgv
+ ? &PL_sv_no
+ : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))),
line_mode ? "line" : "chunk",
(IV)IoLINES(GvIOp(PL_last_in_gv)));
}
@@ -1510,7 +1435,7 @@
{
PERL_ARGS_ASSERT_DIE_SV;
croak_sv(baseex);
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
return NULL;
}
@@ -1532,7 +1457,7 @@
va_list args;
va_start(args, pat);
vcroak(pat, &args);
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
va_end(args);
return NULL;
}
@@ -1544,7 +1469,7 @@
va_list args;
va_start(args, pat);
vcroak(pat, &args);
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
va_end(args);
return NULL;
}
@@ -1644,7 +1569,7 @@
va_list args;
va_start(args, pat);
vcroak(pat, &args);
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
va_end(args);
}
#endif /* PERL_IMPLICIT_CONTEXT */
@@ -1655,7 +1580,7 @@
va_list args;
va_start(args, pat);
vcroak(pat, &args);
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
va_end(args);
}
@@ -1670,11 +1595,42 @@
*/
void
-Perl_croak_no_modify(pTHX)
+Perl_croak_no_modify()
{
- Perl_croak(aTHX_ "%s", PL_no_modify);
+ Perl_croak_nocontext( "%s", PL_no_modify);
}
+/* does not return, used in util.c perlio.c and win32.c
+ This is typically called when malloc returns NULL.
+*/
+void
+Perl_croak_no_mem()
+{
+ dTHX;
+
+ /* Can't use PerlIO to write as it allocates memory */
+ PerlLIO_write(PerlIO_fileno(Perl_error_log),
+ PL_no_mem, sizeof(PL_no_mem)-1);
+ my_exit(1);
+}
+
+/* saves machine code for a common noreturn idiom typically used in Newx*() */
+void
+Perl_croak_memory_wrap(void)
+{
+ Perl_croak_nocontext("%s",PL_memory_wrap);
+}
+
+
+/* does not return, used only in POPSTACK */
+void
+Perl_croak_popstack(void)
+{
+ dTHX;
+ PerlIO_printf(Perl_error_log, "panic: POPSTACK\n");
+ my_exit(1);
+}
+
/*
=for apidoc Am|void|warn_sv|SV *baseex
@@ -1898,7 +1854,8 @@
STRLEN *
Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
STRLEN size) {
- const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
+ const MEM_SIZE len_wanted =
+ sizeof(STRLEN) + (size > WARNsize ? size : WARNsize);
PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
@@ -1908,6 +1865,8 @@
PerlMemShared_realloc(buffer, len_wanted));
buffer[0] = size;
Copy(bits, (buffer + 1), size, char);
+ if (size < WARNsize)
+ Zero((char *)(buffer + 1) + size, WARNsize - size, char);
return buffer;
}
@@ -1936,8 +1895,8 @@
#ifndef PERL_USE_SAFE_PUTENV
if (!PL_use_safe_putenv) {
/* most putenv()s leak, so we manipulate environ directly */
- register I32 i;
- register const I32 len = strlen(nam);
+ I32 i;
+ const I32 len = strlen(nam);
int nlen, vlen;
/* where does it go? */
@@ -1985,7 +1944,7 @@
my_setenv_format(environ[i], nam, nlen, val, vlen);
} else {
# endif
-# if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
+# if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__)
# if defined(HAS_UNSETENV)
if (val == NULL) {
(void)unsetenv(nam);
@@ -1998,7 +1957,8 @@
# else
# if defined(HAS_UNSETENV)
if (val == NULL) {
- (void)unsetenv(nam);
+ if (environ) /* old glibc can crash with null environ */
+ (void)unsetenv(nam);
} else {
const int nlen = strlen(nam);
const int vlen = strlen(val);
@@ -2033,7 +1993,7 @@
Perl_my_setenv(pTHX_ const char *nam, const char *val)
{
dVAR;
- register char *envstr;
+ char *envstr;
const int nlen = strlen(nam);
int vlen;
@@ -2049,7 +2009,7 @@
#endif /* WIN32 || NETWARE */
-#endif /* !VMS && !EPOC*/
+#endif /* !VMS */
#ifdef UNLINK_ALL_VERSIONS
I32
@@ -2068,12 +2028,14 @@
/* this is a drop-in replacement for bcopy() */
#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
char *
-Perl_my_bcopy(register const char *from,register char *to,register I32 len)
+Perl_my_bcopy(const char *from, char *to, I32 len)
{
char * const retval = to;
PERL_ARGS_ASSERT_MY_BCOPY;
+ assert(len >= 0);
+
if (from - to >= 0) {
while (len--)
*to++ = *from++;
@@ -2091,12 +2053,14 @@
/* this is a drop-in replacement for memset() */
#ifndef HAS_MEMSET
void *
-Perl_my_memset(register char *loc, register I32 ch, register I32 len)
+Perl_my_memset(char *loc, I32 ch, I32 len)
{
char * const retval = loc;
PERL_ARGS_ASSERT_MY_MEMSET;
+ assert(len >= 0);
+
while (len--)
*loc++ = ch;
return retval;
@@ -2106,12 +2070,14 @@
/* this is a drop-in replacement for bzero() */
#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
char *
-Perl_my_bzero(register char *loc, register I32 len)
+Perl_my_bzero(char *loc, I32 len)
{
char * const retval = loc;
PERL_ARGS_ASSERT_MY_BZERO;
+ assert(len >= 0);
+
while (len--)
*loc++ = 0;
return retval;
@@ -2121,14 +2087,16 @@
/* this is a drop-in replacement for memcmp() */
#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
I32
-Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
+Perl_my_memcmp(const char *s1, const char *s2, I32 len)
{
- register const U8 *a = (const U8 *)s1;
- register const U8 *b = (const U8 *)s2;
- register I32 tmp;
+ const U8 *a = (const U8 *)s1;
+ const U8 *b = (const U8 *)s2;
+ I32 tmp;
PERL_ARGS_ASSERT_MY_MEMCMP;
+ assert(len >= 0);
+
while (len--) {
if ((tmp = *a++ - *b++))
return tmp;
@@ -2228,8 +2196,8 @@
#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
Perl_croak(aTHX_ "Unknown BYTEORDER\n");
#else
- register I32 o;
- register I32 s;
+ I32 o;
+ I32 s;
for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
u.c[o & 0xf] = (l >> s) & 255;
@@ -2257,8 +2225,8 @@
#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
Perl_croak(aTHX_ "Unknown BYTEORDER\n");
#else
- register I32 o;
- register I32 s;
+ I32 o;
+ I32 s;
u.l = l;
l = 0;
@@ -2283,14 +2251,14 @@
#define HTOLE(name,type) \
type \
- name (register type n) \
+ name (type n) \
{ \
union { \
type value; \
char c[sizeof(type)]; \
} u; \
- register U32 i; \
- register U32 s = 0; \
+ U32 i; \
+ U32 s = 0; \
for (i = 0; i < sizeof(u.c); i++, s += 8) { \
u.c[i] = (n >> s) & 0xFF; \
} \
@@ -2299,14 +2267,14 @@
#define LETOH(name,type) \
type \
- name (register type n) \
+ name (type n) \
{ \
union { \
type value; \
char c[sizeof(type)]; \
} u; \
- register U32 i; \
- register U32 s = 0; \
+ U32 i; \
+ U32 s = 0; \
u.value = n; \
n = 0; \
for (i = 0; i < sizeof(u.c); i++, s += 8) { \
@@ -2321,14 +2289,14 @@
#define HTOBE(name,type) \
type \
- name (register type n) \
+ name (type n) \
{ \
union { \
type value; \
char c[sizeof(type)]; \
} u; \
- register U32 i; \
- register U32 s = 8*(sizeof(u.c)-1); \
+ U32 i; \
+ U32 s = 8*(sizeof(u.c)-1); \
for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
u.c[i] = (n >> s) & 0xFF; \
} \
@@ -2337,14 +2305,14 @@
#define BETOH(name,type) \
type \
- name (register type n) \
+ name (type n) \
{ \
union { \
type value; \
char c[sizeof(type)]; \
} u; \
- register U32 i; \
- register U32 s = 8*(sizeof(u.c)-1); \
+ U32 i; \
+ U32 s = 8*(sizeof(u.c)-1); \
u.value = n; \
n = 0; \
for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
@@ -2359,7 +2327,7 @@
#define NOT_AVAIL(name,type) \
type \
- name (register type n) \
+ name (type n) \
{ \
Perl_croak_nocontext(#name "() not available"); \
return n; /* not reached */ \
@@ -2508,9 +2476,9 @@
void
Perl_my_swabn(void *ptr, int n)
{
- register char *s = (char *)ptr;
- register char *e = s + (n-1);
- register char tc;
+ char *s = (char *)ptr;
+ char *e = s + (n-1);
+ char tc;
PERL_ARGS_ASSERT_MY_SWABN;
@@ -2524,11 +2492,11 @@
PerlIO *
Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
{
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
dVAR;
int p[2];
- register I32 This, that;
- register Pid_t pid;
+ I32 This, that;
+ Pid_t pid;
SV *sv;
I32 did_pipes = 0;
int pp[2];
@@ -2538,7 +2506,7 @@
PERL_FLUSHALL_FOR_CHILD;
This = (*mode == 'w');
that = !This;
- if (PL_tainting) {
+ if (TAINTING_get) {
taint_env();
taint_proper("Insecure %s%s", "EXEC");
}
@@ -2639,7 +2607,7 @@
int pid2, status;
PerlLIO_close(p[This]);
if (n != sizeof(int))
- Perl_croak(aTHX_ "panic: kid popen errno read");
+ Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
do {
pid2 = wait4pid(pid, &status, 0);
} while (pid2 == -1 && errno == EINTR);
@@ -2661,14 +2629,14 @@
}
/* VMS' my_popen() is in VMS.c, same with OS/2. */
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
PerlIO *
Perl_my_popen(pTHX_ const char *cmd, const char *mode)
{
dVAR;
int p[2];
- register I32 This, that;
- register Pid_t pid;
+ I32 This, that;
+ Pid_t pid;
SV *sv;
const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
I32 did_pipes = 0;
@@ -2684,7 +2652,7 @@
#endif
This = (*mode == 'w');
that = !This;
- if (doexec && PL_tainting) {
+ if (doexec && TAINTING_get) {
taint_env();
taint_proper("Insecure %s%s", "EXEC");
}
@@ -2708,7 +2676,6 @@
sleep(5);
}
if (pid == 0) {
- GV* tmpgv;
#undef THIS
#undef THAT
@@ -2754,15 +2721,6 @@
default, binary, low-level mode; see PerlIOBuf_open(). */
PerlLIO_setmode((*mode == 'r'), O_BINARY);
#endif
-
- if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
- SvREADONLY_off(GvSV(tmpgv));
- sv_setiv(GvSV(tmpgv), PerlProc_getpid());
- SvREADONLY_on(GvSV(tmpgv));
- }
-#ifdef THREADS_HAVE_PIDS
- PL_ppid = (IV)getppid();
-#endif
PL_forkprocess = 0;
#ifdef PERL_USES_PL_PIDSTATUS
hv_clear(PL_pidstatus); /* we have no children */
@@ -2805,7 +2763,7 @@
int pid2, status;
PerlLIO_close(p[This]);
if (n != sizeof(int))
- Perl_croak(aTHX_ "panic: kid popen errno read");
+ Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
do {
pid2 = wait4pid(pid, &status, 0);
} while (pid2 == -1 && errno == EINTR);
@@ -2818,20 +2776,6 @@
return PerlIO_fdopen(p[This], mode);
}
#else
-#if defined(atarist) || defined(EPOC)
-FILE *popen();
-PerlIO *
-Perl_my_popen(pTHX_ const char *cmd, const char *mode)
-{
- PERL_ARGS_ASSERT_MY_POPEN;
- PERL_FLUSHALL_FOR_CHILD;
- /* Call system's popen() to get a FILE *, then import it.
- used 0 for 2nd parameter to PerlIO_importFILE;
- apparently not used
- */
- return PerlIO_importFILE(popen(cmd, mode), 0);
-}
-#else
#if defined(DJGPP)
FILE *djgpp_popen();
PerlIO *
@@ -2853,7 +2797,6 @@
}
#endif
#endif
-#endif
#endif /* !DOSISH */
@@ -2864,6 +2807,9 @@
dVAR;
#if defined(USE_ITHREADS)
/* locks must be held in locking order (if any) */
+# ifdef USE_PERLIO
+ MUTEX_LOCK(&PL_perlio_mutex);
+# endif
# ifdef MYMALLOC
MUTEX_LOCK(&PL_malloc_mutex);
# endif
@@ -2878,6 +2824,9 @@
dVAR;
#if defined(USE_ITHREADS)
/* locks must be released in same order as in atfork_lock() */
+# ifdef USE_PERLIO
+ MUTEX_UNLOCK(&PL_perlio_mutex);
+# endif
# ifdef MYMALLOC
MUTEX_UNLOCK(&PL_malloc_mutex);
# endif
@@ -3113,7 +3062,7 @@
#endif /* !PERL_MICRO */
/* VMS' my_pclose() is in VMS.c; same with OS/2 */
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
I32
Perl_my_pclose(pTHX_ PerlIO *ptr)
{
@@ -3146,9 +3095,6 @@
#endif
close_failed = (PerlIO_close(ptr) == EOF);
SAVE_ERRNO;
-#ifdef UTS
- if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
-#endif
#ifndef PERL_MICRO
rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
@@ -3271,7 +3217,7 @@
void
S_pidgone(pTHX_ Pid_t pid, int status)
{
- register SV *sv;
+ SV *sv;
sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
SvUPGRADE(sv,SVt_IV);
@@ -3280,7 +3226,7 @@
}
#endif
-#if defined(atarist) || defined(OS2) || defined(EPOC)
+#if defined(OS2)
int pclose();
#ifdef HAS_FORK
int /* Cannot prototype with I32
@@ -3315,20 +3261,25 @@
#define PERL_REPEATCPY_LINEAR 4
void
-Perl_repeatcpy(register char *to, register const char *from, I32 len, register I32 count)
+Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
{
PERL_ARGS_ASSERT_REPEATCPY;
+ assert(len >= 0);
+
+ if (count < 0)
+ Perl_croak_memory_wrap();
+
if (len == 1)
memset(to, *from, count);
else if (count) {
- register char *p = to;
- I32 items, linear, half;
+ char *p = to;
+ IV items, linear, half;
linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
for (items = 0; items < linear; ++items) {
- register const char *q = from;
- I32 todo;
+ const char *q = from;
+ IV todo;
for (todo = len; todo > 0; todo--)
*p++ = *q++;
}
@@ -3335,7 +3286,7 @@
half = count / 2;
while (items <= half) {
- I32 size = items * len;
+ IV size = items * len;
memcpy(p, to, size);
p += size;
items *= 2;
@@ -3393,11 +3344,11 @@
const char *xfound = NULL;
char *xfailed = NULL;
char tmpbuf[MAXPATHLEN];
- register char *s;
+ char *s;
I32 len = 0;
int retval;
char *bufend;
-#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
+#if defined(DOSISH) && !defined(OS2)
# define SEARCH_EXTS ".bat", ".cmd", NULL
# define MAX_EXT_LEN 4
#endif
@@ -3520,11 +3471,8 @@
bufend = s + strlen(s);
while (s < bufend) {
-#if defined(atarist) || defined(DOSISH)
+# ifdef DOSISH
for (len = 0; *s
-# ifdef atarist
- && *s != ','
-# endif
&& *s != ';'; len++, s++) {
if (len < sizeof tmpbuf)
tmpbuf[len] = *s;
@@ -3531,17 +3479,17 @@
}
if (len < sizeof tmpbuf)
tmpbuf[len] = '\0';
-#else /* ! (atarist || DOSISH) */
+# else
s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
':',
&len);
-#endif /* ! (atarist || DOSISH) */
+# endif
if (s < bufend)
s++;
if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
continue; /* don't search dir with too-long name */
if (len
-# if defined(atarist) || defined(DOSISH)
+# ifdef DOSISH
&& tmpbuf[len - 1] != '/'
&& tmpbuf[len - 1] != '\\'
# endif
@@ -3592,6 +3540,7 @@
seen_dot = 1; /* Disable message. */
if (!xfound) {
if (flags & 1) { /* do or die? */
+ /* diag_listed_as: Can't execute %s */
Perl_croak(aTHX_ "Can't %s %s%s%s",
(xfailed ? "execute" : "find"),
(xfailed ? xfailed : scriptname),
@@ -3615,8 +3564,9 @@
#if defined(USE_ITHREADS)
# ifdef OLD_PTHREADS_API
pthread_addr_t t;
- if (pthread_getspecific(PL_thr_key, &t))
- Perl_croak_nocontext("panic: pthread_getspecific");
+ int error = pthread_getspecific(PL_thr_key, &t)
+ if (error)
+ Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
return (void*)t;
# else
# ifdef I_MACH_CTHREADS
@@ -3639,8 +3589,11 @@
# ifdef I_MACH_CTHREADS
cthread_set_data(cthread_self(), t);
# else
- if (pthread_setspecific(PL_thr_key, t))
- Perl_croak_nocontext("panic: pthread_setspecific");
+ {
+ const int error = pthread_setspecific(PL_thr_key, t);
+ if (error)
+ Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
+ }
# endif
#else
PERL_UNUSED_ARG(t);
@@ -3710,104 +3663,10 @@
MGVTBL*
Perl_get_vtbl(pTHX_ int vtbl_id)
{
- const MGVTBL* result;
PERL_UNUSED_CONTEXT;
- switch(vtbl_id) {
- case want_vtbl_sv:
- result = &PL_vtbl_sv;
- break;
- case want_vtbl_env:
- result = &PL_vtbl_env;
- break;
- case want_vtbl_envelem:
- result = &PL_vtbl_envelem;
- break;
- case want_vtbl_sig:
- result = &PL_vtbl_sig;
- break;
- case want_vtbl_sigelem:
- result = &PL_vtbl_sigelem;
- break;
- case want_vtbl_pack:
- result = &PL_vtbl_pack;
- break;
- case want_vtbl_packelem:
- result = &PL_vtbl_packelem;
- break;
- case want_vtbl_dbline:
- result = &PL_vtbl_dbline;
- break;
- case want_vtbl_isa:
- result = &PL_vtbl_isa;
- break;
- case want_vtbl_isaelem:
- result = &PL_vtbl_isaelem;
- break;
- case want_vtbl_arylen:
- result = &PL_vtbl_arylen;
- break;
- case want_vtbl_mglob:
- result = &PL_vtbl_mglob;
- break;
- case want_vtbl_nkeys:
- result = &PL_vtbl_nkeys;
- break;
- case want_vtbl_taint:
- result = &PL_vtbl_taint;
- break;
- case want_vtbl_substr:
- result = &PL_vtbl_substr;
- break;
- case want_vtbl_vec:
- result = &PL_vtbl_vec;
- break;
- case want_vtbl_pos:
- result = &PL_vtbl_pos;
- break;
- case want_vtbl_bm:
- result = &PL_vtbl_bm;
- break;
- case want_vtbl_fm:
- result = &PL_vtbl_fm;
- break;
- case want_vtbl_uvar:
- result = &PL_vtbl_uvar;
- break;
- case want_vtbl_defelem:
- result = &PL_vtbl_defelem;
- break;
- case want_vtbl_regexp:
- result = &PL_vtbl_regexp;
- break;
- case want_vtbl_regdata:
- result = &PL_vtbl_regdata;
- break;
- case want_vtbl_regdatum:
- result = &PL_vtbl_regdatum;
- break;
-#ifdef USE_LOCALE_COLLATE
- case want_vtbl_collxfrm:
- result = &PL_vtbl_collxfrm;
- break;
-#endif
- case want_vtbl_amagic:
- result = &PL_vtbl_amagic;
- break;
- case want_vtbl_amagicelem:
- result = &PL_vtbl_amagicelem;
- break;
- case want_vtbl_backref:
- result = &PL_vtbl_backref;
- break;
- case want_vtbl_utf8:
- result = &PL_vtbl_utf8;
- break;
- default:
- result = NULL;
- break;
- }
- return (MGVTBL*)result;
+ return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
+ ? NULL : PL_magic_vtables + vtbl_id;
}
I32
@@ -3864,13 +3723,15 @@
Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
{
if (ckWARN(WARN_IO)) {
- const char * const name
- = gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL;
+ HEK * const name
+ = gv && (isGV_with_GP(gv))
+ ? GvENAME_HEK((gv))
+ : NULL;
const char * const direction = have == '>' ? "out" : "in";
- if (name && *name)
+ if (name && HEK_LEN(name))
Perl_warner(aTHX_ packWARN(WARN_IO),
- "Filehandle %s opened only for %sput",
+ "Filehandle %"HEKf" opened only for %sput",
name, direction);
else
Perl_warner(aTHX_ packWARN(WARN_IO),
@@ -3896,8 +3757,9 @@
}
if (ckWARN(warn_type)) {
- const char * const name
- = gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL;
+ SV * const name
+ = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ?
+ sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
const char * const pars =
(const char *)(OP_IS_FILETEST(op) ? "" : "()");
const char * const func =
@@ -3909,26 +3771,18 @@
(const char *)
(OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
? "socket" : "filehandle");
- if (name && *name) {
- Perl_warner(aTHX_ packWARN(warn_type),
- "%s%s on %s %s %s", func, pars, vile, type, name);
- if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
+ const bool have_name = name && SvCUR(name);
+ Perl_warner(aTHX_ packWARN(warn_type),
+ "%s%s on %s %s%s%"SVf, func, pars, vile, type,
+ have_name ? " " : "",
+ SVfARG(have_name ? name : &PL_sv_no));
+ if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
Perl_warner(
aTHX_ packWARN(warn_type),
- "\t(Are you trying to call %s%s on dirhandle %s?)\n",
- func, pars, name
+ "\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n",
+ func, pars, have_name ? " " : "",
+ SVfARG(have_name ? name : &PL_sv_no)
);
- }
- else {
- Perl_warner(aTHX_ packWARN(warn_type),
- "%s%s on %s %s", func, pars, vile, type);
- if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
- Perl_warner(
- aTHX_ packWARN(warn_type),
- "\t(Are you trying to call %s%s on dirhandle?)\n",
- func, pars
- );
- }
}
}
@@ -4063,15 +3917,7 @@
year = 1900 + ptm->tm_year;
month = ptm->tm_mon;
mday = ptm->tm_mday;
- /* allow given yday with no month & mday to dominate the result */
- if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
- month = 0;
- mday = 0;
- jday = 1 + ptm->tm_yday;
- }
- else {
- jday = 0;
- }
+ jday = 0;
if (month >= 2)
month+=2;
else
@@ -4166,9 +4012,7 @@
yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
yearday += 14*MONTH_TO_DAYS + 1;
ptm->tm_yday = jday - yearday;
- /* fix tm_wday if not overridden by caller */
- if ((unsigned)ptm->tm_wday > 6)
- ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
+ ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
}
char *
@@ -4281,7 +4125,7 @@
* back into. */
int
-Perl_getcwd_sv(pTHX_ register SV *sv)
+Perl_getcwd_sv(pTHX_ SV *sv)
{
#ifndef PERL_MICRO
dVAR;
@@ -4534,6 +4378,7 @@
} /* end if dotted-decimal */
else
{ /* decimal versions */
+ int j = 0; /* may need this later */
/* special strict case for leading '.' or '0' */
if (strict) {
if (*d == '.') {
@@ -4544,6 +4389,11 @@
}
}
+ /* and we never support negative versions */
+ if ( *d == '-') {
+ BADVERSION(s,errstr,"Invalid version format (negative version number)");
+ }
+
/* consume all of the integer part */
while (isDIGIT(*d))
d++;
@@ -4591,7 +4441,7 @@
}
while (isDIGIT(*d)) {
- d++;
+ d++; j++;
if (*d == '.' && isDIGIT(d[-1])) {
if (alpha) {
BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
@@ -4613,6 +4463,7 @@
if ( ! isDIGIT(d[1]) ) {
BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
}
+ width = j;
d++;
alpha = TRUE;
}
@@ -4664,7 +4515,7 @@
const char *
Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
{
- const char *start;
+ const char *start = s;
const char *pos;
const char *last;
const char *errstr = NULL;
@@ -4672,17 +4523,11 @@
int width = 3;
bool alpha = FALSE;
bool vinf = FALSE;
- AV * const av = newAV();
- SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
+ AV * av;
+ SV * hv;
PERL_ARGS_ASSERT_SCAN_VERSION;
- (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
-
-#ifndef NODEFAULT_SHAREKEYS
- HvSHAREKEYS_on(hv); /* key-sharing on by default */
-#endif
-
while (isSPACE(*s)) /* leading whitespace is OK */
s++;
@@ -4690,6 +4535,7 @@
if (errstr) {
/* "undef" is a special case and not an error */
if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
+ Safefree(start);
Perl_croak(aTHX_ "%s", errstr);
}
}
@@ -4699,6 +4545,15 @@
s++;
pos = s;
+ /* Now that we are through the prescan, start creating the object */
+ av = newAV();
+ hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
+ (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
+
+#ifndef NODEFAULT_SHAREKEYS
+ HvSHAREKEYS_on(hv); /* key-sharing on by default */
+#endif
+
if ( qv )
(void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
if ( alpha )
@@ -4705,7 +4560,7 @@
(void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
if ( !qv && width < 3 )
(void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
-
+
while (isDIGIT(*pos))
pos++;
if (!isALPHA(*pos)) {
@@ -4854,7 +4709,8 @@
dVAR;
SV * const rv = newSV(0);
PERL_ARGS_ASSERT_NEW_VERSION;
- if ( sv_derived_from(ver,"version") ) /* can just copy directly */
+ if ( sv_isobject(ver) && sv_derived_from(ver, "version") )
+ /* can just copy directly */
{
I32 key;
AV * const av = newAV();
@@ -4875,7 +4731,7 @@
if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
(void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
-
+
if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
{
const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
@@ -4946,18 +4802,32 @@
if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
{
+ STRLEN len;
+
/* may get too much accuracy */
char tbuf[64];
+ SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
+ char *buf;
#ifdef USE_LOCALE_NUMERIC
- char *loc = setlocale(LC_NUMERIC, "C");
+ char *loc = savepv(setlocale(LC_NUMERIC, NULL));
+ setlocale(LC_NUMERIC, "C");
#endif
- STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
+ if (sv) {
+ Perl_sv_setpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
+ buf = SvPV(sv, len);
+ }
+ else {
+ len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
+ buf = tbuf;
+ }
#ifdef USE_LOCALE_NUMERIC
setlocale(LC_NUMERIC, loc);
+ Safefree(loc);
#endif
- while (tbuf[len-1] == '0' && len > 0) len--;
- if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */
- version = savepvn(tbuf, len);
+ while (buf[len-1] == '0' && len > 0) len--;
+ if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
+ version = savepvn(buf, len);
+ SvREFCNT_dec(sv);
}
#ifdef SvVOK
else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
@@ -4995,7 +4865,7 @@
}
/* is definitely a v-string */
- if ( saw_decimal >= 2 ) {
+ if ( saw_decimal >= 2 ) {
Safefree(version);
version = nver;
}
@@ -5486,7 +5356,7 @@
Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
/* Stevens says that family must be AF_LOCAL, protocol 0.
I'm going to enforce that, then ignore it, and use TCP (or UDP). */
- dTHX;
+ dTHXa(NULL);
int listener = -1;
int connector = -1;
int acceptor = -1;
@@ -5512,6 +5382,7 @@
return S_socketpair_udp(fd);
#endif
+ aTHXa(PERL_GET_THX);
listener = PerlSock_socket(AF_INET, type, 0);
if (listener == -1)
return -1;
@@ -5587,7 +5458,7 @@
}
#else
/* In any case have a stub so that there's code corresponding
- * to the my_socketpair in global.sym. */
+ * to the my_socketpair in embed.fnc. */
int
Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
#ifdef HAS_SOCKETPAIR
@@ -5704,6 +5575,10 @@
return opt;
}
+#ifdef VMS
+# include <starlet.h>
+#endif
+
U32
Perl_seed(pTHX)
{
@@ -5735,7 +5610,6 @@
#endif
U32 u;
#ifdef VMS
-# include <starlet.h>
/* when[] = (low 32 bits, high 32 bits) of time since epoch
* in 100-ns units, typically incremented ever 10 ms. */
unsigned int when[2];
@@ -5786,64 +5660,87 @@
return u;
}
-UV
-Perl_get_hash_seed(pTHX)
+void
+Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
{
dVAR;
- const char *s = PerlEnv_getenv("PERL_HASH_SEED");
- UV myseed = 0;
+ const char *env_pv;
+ unsigned long i;
- if (s)
- while (isSPACE(*s))
- s++;
- if (s && isDIGIT(*s))
- myseed = (UV)Atoul(s);
- else
-#ifdef USE_HASH_SEED_EXPLICIT
- if (s)
+ PERL_ARGS_ASSERT_GET_HASH_SEED;
+
+ env_pv= PerlEnv_getenv("PERL_HASH_SEED");
+
+ if ( env_pv )
+#ifndef USE_HASH_SEED_EXPLICIT
+ {
+ /* ignore leading spaces */
+ while (isSPACE(*env_pv))
+ env_pv++;
+#ifdef USE_PERL_PERTURB_KEYS
+ /* if they set it to "0" we disable key traversal randomization completely */
+ if (strEQ(env_pv,"0")) {
+ PL_hash_rand_bits_enabled= 0;
+ } else {
+ /* otherwise switch to deterministic mode */
+ PL_hash_rand_bits_enabled= 2;
+ }
#endif
- {
- /* Compute a random seed */
- (void)seedDrand01((Rand_seed_t)seed());
- myseed = (UV)(Drand01() * (NV)UV_MAX);
-#if RANDBITS < (UVSIZE * 8)
- /* Since there are not enough randbits to to reach all
- * the bits of a UV, the low bits might need extra
- * help. Sum in another random number that will
- * fill in the low bits. */
- myseed +=
- (UV)(Drand01() * (NV)((((UV)1) << ((UVSIZE * 8 - RANDBITS))) - 1));
-#endif /* RANDBITS < (UVSIZE * 8) */
- if (myseed == 0) { /* Superparanoia. */
- myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
- if (myseed == 0)
- Perl_croak(aTHX_ "Your random numbers are not that random");
- }
- }
- PL_rehash_seed_set = TRUE;
+ /* ignore a leading 0x... if it is there */
+ if (env_pv[0] == '0' && env_pv[1] == 'x')
+ env_pv += 2;
- return myseed;
-}
+ for( i = 0; isXDIGIT(*env_pv) && i < PERL_HASH_SEED_BYTES; i++ ) {
+ seed_buffer[i] = READ_XDIGIT(env_pv) << 4;
+ if ( isXDIGIT(*env_pv)) {
+ seed_buffer[i] |= READ_XDIGIT(env_pv);
+ }
+ }
+ while (isSPACE(*env_pv))
+ env_pv++;
-#ifdef USE_ITHREADS
-bool
-Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
-{
- const char * const stashpv = CopSTASHPV(c);
- const char * const name = HvNAME_get(hv);
- PERL_UNUSED_CONTEXT;
- PERL_ARGS_ASSERT_STASHPV_HVNAME_MATCH;
+ if (*env_pv && !isXDIGIT(*env_pv)) {
+ Perl_warn(aTHX_ "perl: warning: Non hex character in '$ENV{PERL_HASH_SEED}', seed only partially set\n");
+ }
+ /* should we check for unparsed crap? */
+ /* should we warn about unused hex? */
+ /* should we warn about insufficient hex? */
+ }
+ else
+#endif
+ {
+ (void)seedDrand01((Rand_seed_t)seed());
- if (stashpv == name)
- return TRUE;
- if (stashpv && name)
- if (strEQ(stashpv, name))
- return TRUE;
- return FALSE;
+ for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) {
+ seed_buffer[i] = (unsigned char)(Drand01() * (U8_MAX+1));
+ }
+ }
+#ifdef USE_PERL_PERTURB_KEYS
+ { /* initialize PL_hash_rand_bits from the hash seed.
+ * This value is highly volatile, it is updated every
+ * hash insert, and is used as part of hash bucket chain
+ * randomization and hash iterator randomization. */
+ PL_hash_rand_bits= 0xbe49d17f; /* I just picked a number */
+ for( i = 0; i < sizeof(UV) ; i++ ) {
+ PL_hash_rand_bits += seed_buffer[i % PERL_HASH_SEED_BYTES];
+ PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8);
+ }
+ }
+ env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS");
+ if (env_pv) {
+ if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) {
+ PL_hash_rand_bits_enabled= 0;
+ } else if (strEQ(env_pv,"1") || strEQ(env_pv,"RANDOM")) {
+ PL_hash_rand_bits_enabled= 1;
+ } else if (strEQ(env_pv,"2") || strEQ(env_pv,"DETERMINISTIC")) {
+ PL_hash_rand_bits_enabled= 2;
+ } else {
+ Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv);
+ }
+ }
+#endif
}
-#endif
-
#ifdef PERL_GLOBAL_STRUCT
#define PERL_GLOBAL_STRUCT_INIT
@@ -5868,18 +5765,15 @@
# undef PERLVARA
# undef PERLVARI
# undef PERLVARIC
-# undef PERLVARISC
-# define PERLVAR(var,type) /**/
-# define PERLVARA(var,n,type) /**/
-# define PERLVARI(var,type,init) plvarsp->var = init;
-# define PERLVARIC(var,type,init) plvarsp->var = init;
-# define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
+# define PERLVAR(prefix,var,type) /**/
+# define PERLVARA(prefix,var,n,type) /**/
+# define PERLVARI(prefix,var,type,init) plvarsp->prefix##var = init;
+# define PERLVARIC(prefix,var,type,init) plvarsp->prefix##var = init;
# include "perlvars.h"
# undef PERLVAR
# undef PERLVARA
# undef PERLVARI
# undef PERLVARIC
-# undef PERLVARISC
# ifdef PERL_GLOBAL_STRUCT
plvarsp->Gppaddr =
(Perl_ppaddr_t*)
@@ -6153,7 +6047,6 @@
int
Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
{
- dTHX;
int retval;
va_list ap;
PERL_ARGS_ASSERT_MY_SNPRINTF;
@@ -6172,7 +6065,7 @@
(len > 0 && (Size_t)retval >= len)
#endif
)
- Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
+ Perl_croak_nocontext("panic: my_snprintf buffer overflow");
return retval;
}
@@ -6190,7 +6083,6 @@
int
Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
{
- dTHX;
int retval;
#ifdef NEED_VA_COPY
va_list apc;
@@ -6218,7 +6110,7 @@
(len > 0 && (Size_t)retval >= len)
#endif
)
- Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
+ Perl_croak_nocontext("panic: my_vsnprintf buffer overflow");
return retval;
}
@@ -6259,6 +6151,7 @@
if (bsiz < l + 1) {
(void)safesysfree(buf);
bsiz = l + 1; /* + 1 for the \0. */
+ bufsiz = bsiz * sizeof(char); /* keep bsiz and bufsiz in sync */
buf = (char*)safesysmalloc(bufsiz);
}
memcpy(buf, *environ, l);
@@ -6418,7 +6311,7 @@
}
if (sv) {
SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
- SV *pmsv = sv_derived_from(sv, "version")
+ SV *pmsv = sv_isobject(sv) && sv_derived_from(sv, "version")
? sv : sv_2mortal(new_version(sv));
xssv = upg_version(xssv, 0);
if ( vcmp(pmsv,xssv) ) {
@@ -6512,34 +6405,53 @@
long _ftol2( double dblSource ) { return _ftol( dblSource ); }
#endif
+PERL_STATIC_INLINE bool
+S_gv_has_usable_name(pTHX_ GV *gv)
+{
+ GV **gvp;
+ return GvSTASH(gv)
+ && HvENAME(GvSTASH(gv))
+ && (gvp = (GV **)hv_fetch(
+ GvSTASH(gv), GvNAME(gv),
+ GvNAMEUTF8(gv) ? -GvNAMELEN(gv) : GvNAMELEN(gv), 0
+ ))
+ && *gvp == gv;
+}
+
void
Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
{
dVAR;
SV * const dbsv = GvSVn(PL_DBsub);
- const bool save_taint = PL_tainted;
+ const bool save_taint = TAINT_get;
- /* We do not care about using sv to call CV;
+ /* When we are called from pp_goto (svp is null),
+ * we do not care about using dbsv to call CV;
* it's for informational purposes only.
*/
PERL_ARGS_ASSERT_GET_DB_SUB;
- PL_tainted = FALSE;
+ TAINT_set(FALSE);
save_item(dbsv);
if (!PERLDB_SUB_NN) {
GV *gv = CvGV(cv);
- if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
+ if (!svp) {
+ gv_efullname3(dbsv, gv, NULL);
+ }
+ else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
|| strEQ(GvNAME(gv), "END")
- || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
+ || ( /* Could be imported, and old sub redefined. */
+ (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv))
+ &&
!( (SvTYPE(*svp) == SVt_PVGV)
&& (GvCV((const GV *)*svp) == cv)
- && (gv = (GV *)*svp)
+ /* Use GV from the stack as a fallback. */
+ && S_gv_has_usable_name(aTHX_ gv = (GV *)*svp)
)
)
- )) {
- /* Use GV from the stack as a fallback. */
+ ) {
/* GV is potentially non-unique, or contain different CV. */
SV * const tmp = newRV(MUTABLE_SV(cv));
sv_setsv(dbsv, tmp);
@@ -6546,7 +6458,12 @@
SvREFCNT_dec(tmp);
}
else {
- gv_efullname3(dbsv, gv, NULL);
+ sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv)));
+ sv_catpvs(dbsv, "::");
+ sv_catpvn_flags(
+ dbsv, GvNAME(gv), GvNAMELEN(gv),
+ GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
+ );
}
}
else {
@@ -6557,6 +6474,9 @@
SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
}
TAINT_IF(save_taint);
+#ifdef NO_TAINT_SUPPORT
+ PERL_UNUSED_VAR(save_taint);
+#endif
}
int
@@ -6571,7 +6491,7 @@
return dir->dd_fd;
#else
Perl_die(aTHX_ PL_no_func, "dirfd");
- /* NOT REACHED */
+ assert(0); /* NOT REACHED */
return 0;
#endif
}
@@ -6595,8 +6515,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/util.c
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/util.h
===================================================================
--- trunk/contrib/perl/util.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/util.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -13,7 +13,7 @@
(*(f) == '/' \
|| (strchr(f,':') \
|| ((*(f) == '[' || *(f) == '<') \
- && (isALNUM((f)[1]) || strchr("$-_]>",(f)[1])))))
+ && (isWORDCHAR((f)[1]) || strchr("$-_]>",(f)[1])))))
#else /* !VMS */
# if defined(WIN32) || defined(__CYGWIN__)
@@ -27,11 +27,11 @@
|| ((f)[0] == '\\' && (f)[1] == '\\') /* UNC path */ \
|| ((f)[3] == ':')) /* volume name, currently only sys */
# else /* !NETWARE */
-# if defined(DOSISH) || defined(EPOC) || defined(__SYMBIAN32__)
+# if defined(DOSISH) || defined(__SYMBIAN32__)
# define PERL_FILE_IS_ABSOLUTE(f) \
(*(f) == '/' \
|| ((f)[0] && (f)[1] == ':')) /* drive name */
-# else /* NEITHER DOSISH NOR EPOCISH NOR SYMBIANISH */
+# else /* NEITHER DOSISH NOR SYMBIANISH */
# define PERL_FILE_IS_ABSOLUTE(f) (*(f) == '/')
# endif /* DOSISH */
# endif /* NETWARE */
@@ -57,8 +57,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
Property changes on: trunk/contrib/perl/util.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.3
\ No newline at end of property
Modified: trunk/contrib/perl/warnings.h
===================================================================
--- trunk/contrib/perl/warnings.h 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/warnings.h 2013-12-02 21:18:17 UTC (rev 6438)
@@ -29,68 +29,76 @@
/* Warnings Categories added in Perl 5.008 */
-#define WARN_ALL 0
-#define WARN_CLOSURE 1
-#define WARN_DEPRECATED 2
-#define WARN_EXITING 3
-#define WARN_GLOB 4
-#define WARN_IO 5
-#define WARN_CLOSED 6
-#define WARN_EXEC 7
-#define WARN_LAYER 8
-#define WARN_NEWLINE 9
-#define WARN_PIPE 10
-#define WARN_UNOPENED 11
-#define WARN_MISC 12
-#define WARN_NUMERIC 13
-#define WARN_ONCE 14
-#define WARN_OVERFLOW 15
-#define WARN_PACK 16
-#define WARN_PORTABLE 17
-#define WARN_RECURSION 18
-#define WARN_REDEFINE 19
-#define WARN_REGEXP 20
-#define WARN_SEVERE 21
-#define WARN_DEBUGGING 22
-#define WARN_INPLACE 23
-#define WARN_INTERNAL 24
-#define WARN_MALLOC 25
-#define WARN_SIGNAL 26
-#define WARN_SUBSTR 27
-#define WARN_SYNTAX 28
-#define WARN_AMBIGUOUS 29
-#define WARN_BAREWORD 30
-#define WARN_DIGIT 31
-#define WARN_PARENTHESIS 32
-#define WARN_PRECEDENCE 33
-#define WARN_PRINTF 34
-#define WARN_PROTOTYPE 35
-#define WARN_QW 36
-#define WARN_RESERVED 37
-#define WARN_SEMICOLON 38
-#define WARN_TAINT 39
-#define WARN_THREADS 40
-#define WARN_UNINITIALIZED 41
-#define WARN_UNPACK 42
-#define WARN_UNTIE 43
-#define WARN_UTF8 44
-#define WARN_VOID 45
+#define WARN_ALL 0
+#define WARN_CLOSURE 1
+#define WARN_DEPRECATED 2
+#define WARN_EXITING 3
+#define WARN_GLOB 4
+#define WARN_IO 5
+#define WARN_CLOSED 6
+#define WARN_EXEC 7
+#define WARN_LAYER 8
+#define WARN_NEWLINE 9
+#define WARN_PIPE 10
+#define WARN_UNOPENED 11
+#define WARN_MISC 12
+#define WARN_NUMERIC 13
+#define WARN_ONCE 14
+#define WARN_OVERFLOW 15
+#define WARN_PACK 16
+#define WARN_PORTABLE 17
+#define WARN_RECURSION 18
+#define WARN_REDEFINE 19
+#define WARN_REGEXP 20
+#define WARN_SEVERE 21
+#define WARN_DEBUGGING 22
+#define WARN_INPLACE 23
+#define WARN_INTERNAL 24
+#define WARN_MALLOC 25
+#define WARN_SIGNAL 26
+#define WARN_SUBSTR 27
+#define WARN_SYNTAX 28
+#define WARN_AMBIGUOUS 29
+#define WARN_BAREWORD 30
+#define WARN_DIGIT 31
+#define WARN_PARENTHESIS 32
+#define WARN_PRECEDENCE 33
+#define WARN_PRINTF 34
+#define WARN_PROTOTYPE 35
+#define WARN_QW 36
+#define WARN_RESERVED 37
+#define WARN_SEMICOLON 38
+#define WARN_TAINT 39
+#define WARN_THREADS 40
+#define WARN_UNINITIALIZED 41
+#define WARN_UNPACK 42
+#define WARN_UNTIE 43
+#define WARN_UTF8 44
+#define WARN_VOID 45
/* Warnings Categories added in Perl 5.011 */
-#define WARN_IMPRECISION 46
-#define WARN_ILLEGALPROTO 47
+#define WARN_IMPRECISION 46
+#define WARN_ILLEGALPROTO 47
/* Warnings Categories added in Perl 5.013 */
-#define WARN_NON_UNICODE 48
-#define WARN_NONCHAR 49
-#define WARN_SURROGATE 50
+#define WARN_NON_UNICODE 48
+#define WARN_NONCHAR 49
+#define WARN_SURROGATE 50
-#define WARNsize 13
-#define WARN_ALLstring "\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"
+/* Warnings Categories added in Perl 5.017 */
+#define WARN_EXPERIMENTAL 51
+#define WARN_EXPERIMENTAL__LEXICAL_SUBS 52
+#define WARN_EXPERIMENTAL__LEXICAL_TOPIC 53
+#define WARN_EXPERIMENTAL__REGEX_SETS 54
+#define WARN_EXPERIMENTAL__SMARTMATCH 55
+
+#define WARNsize 14
+#define WARN_ALLstring "\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"
+
#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
Property changes on: trunk/contrib/perl/warnings.h
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.2
\ No newline at end of property
Modified: trunk/contrib/perl/write_buildcustomize.pl
===================================================================
--- trunk/contrib/perl/write_buildcustomize.pl 2013-12-02 20:17:19 UTC (rev 6437)
+++ trunk/contrib/perl/write_buildcustomize.pl 2013-12-02 21:18:17 UTC (rev 6438)
@@ -16,8 +16,11 @@
# needed to build the nonxs modules
# After which, all nonxs modules are in lib, which was always sufficient to
# allow miniperl to build everything else.
+# Term::ReadLine is not here for building but for allowing the debugger to
+# run under miniperl when nothing but miniperl will build :-(.
my @toolchain = qw(cpan/AutoLoader/lib
+ dist/Carp/lib
dist/Cwd dist/Cwd/lib
dist/ExtUtils-Command/lib
dist/ExtUtils-Install/lib
@@ -25,6 +28,7 @@
dist/ExtUtils-Manifest/lib
cpan/File-Path/lib
ext/re
+ dist/Term-ReadLine/lib
);
# Used only in ExtUtils::Liblist::Kid::_win32_ext()
Property changes on: trunk/contrib/perl/write_buildcustomize.pl
___________________________________________________________________
Deleted: cvs2svn:cvs-rev
## -1 +0,0 ##
-1.1.1.1
\ No newline at end of property
More information about the Midnightbsd-cvs
mailing list