summaryrefslogtreecommitdiff
path: root/gnu
diff options
context:
space:
mode:
authorTodd C. Miller <millert@cvs.openbsd.org>2008-09-29 17:19:07 +0000
committerTodd C. Miller <millert@cvs.openbsd.org>2008-09-29 17:19:07 +0000
commit45d08e505d2cf395790337774e37196491e30ec6 (patch)
tree05cdabe5bf91d38bc1c8e5837cbd1cb390f060b5 /gnu
parent55cb1af99119e7bd5f708764e086922b2151860f (diff)
import perl 5.10.0 from CPAN
Diffstat (limited to 'gnu')
-rwxr-xr-xgnu/usr.bin/perl/Cross/Makefile-cross-SH204
-rwxr-xr-xgnu/usr.bin/perl/Cross/cflags-cross-arm3
-rwxr-xr-xgnu/usr.bin/perl/Porting/add-package.pl244
-rwxr-xr-xgnu/usr.bin/perl/Porting/corelist.pl497
-rw-r--r--gnu/usr.bin/perl/README.symbian865
-rw-r--r--gnu/usr.bin/perl/ext/B/t/optree_misc.t392
-rw-r--r--gnu/usr.bin/perl/ext/DynaLoader/dl_symbian.xs21
-rw-r--r--gnu/usr.bin/perl/ext/DynaLoader/t/DynaLoader.t119
-rw-r--r--gnu/usr.bin/perl/ext/POSIX/t/math.t34
-rw-r--r--gnu/usr.bin/perl/ext/POSIX/t/time.t56
-rw-r--r--gnu/usr.bin/perl/ext/Win32CORE/Win32CORE.c158
-rw-r--r--gnu/usr.bin/perl/ext/re/re_top.h5
-rw-r--r--gnu/usr.bin/perl/ext/re/t/lexical_debug.t6
-rw-r--r--gnu/usr.bin/perl/ext/re/t/regop.pl1
-rw-r--r--gnu/usr.bin/perl/generate_uudmap.c147
-rw-r--r--gnu/usr.bin/perl/lib/feature.pm419
-rw-r--r--gnu/usr.bin/perl/lib/perl5db.t2743
-rw-r--r--gnu/usr.bin/perl/lib/unicore/NamedSqProv.txt79
-rwxr-xr-xgnu/usr.bin/perl/mad/Nomad.pm1
-rw-r--r--gnu/usr.bin/perl/mad/P5AST.pm1
-rw-r--r--gnu/usr.bin/perl/mad/PLXML.pm14
-rw-r--r--gnu/usr.bin/perl/mad/t/p55.t17
-rw-r--r--gnu/usr.bin/perl/madly.c4
-rw-r--r--gnu/usr.bin/perl/mathoms.c1241
-rwxr-xr-xgnu/usr.bin/perl/mkppport12
-rw-r--r--gnu/usr.bin/perl/mkppport.lst8
-rw-r--r--gnu/usr.bin/perl/mro.c1811
-rw-r--r--gnu/usr.bin/perl/overload.c153
-rw-r--r--gnu/usr.bin/perl/overload.h145
-rw-r--r--gnu/usr.bin/perl/parser.h95
-rw-r--r--gnu/usr.bin/perl/perly.act1976
-rw-r--r--gnu/usr.bin/perl/perly.tab1743
-rw-r--r--gnu/usr.bin/perl/pod/perlcommunity.pod63
-rw-r--r--gnu/usr.bin/perl/pod/perlreapi.pod498
-rw-r--r--gnu/usr.bin/perl/pod/perlrebackslash.pod497
-rw-r--r--gnu/usr.bin/perl/pod/perlrecharclass.pod1155
-rw-r--r--gnu/usr.bin/perl/pod/perlunifaq.pod58
-rw-r--r--gnu/usr.bin/perl/pod/perlunitut.pod13
-rw-r--r--gnu/usr.bin/perl/regcharclass.h1002
-rwxr-xr-xgnu/usr.bin/perl/regen_perly.pl129
-rw-r--r--gnu/usr.bin/perl/symbian/config.pl1971
-rw-r--r--gnu/usr.bin/perl/t/comp/fold.t151
-rw-r--r--gnu/usr.bin/perl/t/comp/uproto.t79
-rw-r--r--gnu/usr.bin/perl/t/lib/Cname.pm20
-rw-r--r--gnu/usr.bin/perl/t/lib/common.pl233
-rw-r--r--gnu/usr.bin/perl/t/lib/feature/implicit76
-rw-r--r--gnu/usr.bin/perl/t/lib/mypragma.t15
-rw-r--r--gnu/usr.bin/perl/t/lib/no_load.t16
-rw-r--r--gnu/usr.bin/perl/t/lib/proxy_constant_subs.t27
-rw-r--r--gnu/usr.bin/perl/t/lib/warnings/9uninit906
-rw-r--r--gnu/usr.bin/perl/t/mro/basic.t183
-rw-r--r--gnu/usr.bin/perl/t/mro/inconsistent_c3.t5
-rw-r--r--gnu/usr.bin/perl/t/mro/method_caching.t46
-rw-r--r--gnu/usr.bin/perl/t/mro/next_edgecases.t29
-rw-r--r--gnu/usr.bin/perl/t/mro/recursion_c3.t4
-rw-r--r--gnu/usr.bin/perl/t/mro/recursion_dfs.t2
-rw-r--r--gnu/usr.bin/perl/t/op/blocks.t54
-rw-r--r--gnu/usr.bin/perl/t/op/dor.t41
-rw-r--r--gnu/usr.bin/perl/t/op/incfilter.t98
-rw-r--r--gnu/usr.bin/perl/t/op/mydef.t160
-rw-r--r--gnu/usr.bin/perl/t/op/qr.t114
-rw-r--r--gnu/usr.bin/perl/t/op/reset.t113
-rw-r--r--gnu/usr.bin/perl/t/op/smartmatch.t517
-rw-r--r--gnu/usr.bin/perl/t/op/state.t105
-rw-r--r--gnu/usr.bin/perl/t/op/switch.t752
-rw-r--r--gnu/usr.bin/perl/t/run/cloexec.t29
-rw-r--r--gnu/usr.bin/perl/t/uni/cache.t30
-rw-r--r--gnu/usr.bin/perl/t/uni/chr.t41
-rw-r--r--gnu/usr.bin/perl/t/uni/greek.t28
-rw-r--r--gnu/usr.bin/perl/t/uni/latin2.t28
-rw-r--r--gnu/usr.bin/perl/utils/config_data.PL2
-rw-r--r--gnu/usr.bin/perl/win32/Makefile.ce2021
-rw-r--r--gnu/usr.bin/perl/win32/ce-helpers/cecopy-lib.pl1
-rw-r--r--gnu/usr.bin/perl/win32/config_H.ce127
-rw-r--r--gnu/usr.bin/perl/win32/wince.c184
75 files changed, 7919 insertions, 16918 deletions
diff --git a/gnu/usr.bin/perl/Cross/Makefile-cross-SH b/gnu/usr.bin/perl/Cross/Makefile-cross-SH
index 13945ceb197..c6ecf419d4f 100755
--- a/gnu/usr.bin/perl/Cross/Makefile-cross-SH
+++ b/gnu/usr.bin/perl/Cross/Makefile-cross-SH
@@ -12,7 +12,7 @@ Makefile=Makefile-cross-$CROSS_NAME
# H.Merijn Brand [17 Feb 2004]
# This comment is just to ensure that Configure will find variables that
# are removed/replaced in patches on blead, but are still needed in the
-# 5.8.x, 5.6.x and 5.005.x maintenance tracks.
+# 5.8.x, 5.6.x and 5.005.x maintainance tracks.
# metaconfig -m will scan all .SH files on this level (not deeper), and
# not in x2p and other subfolders. This file is as good as any .SH
# patch references
@@ -29,6 +29,11 @@ case "$0" in
*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
esac
+case "$d_dosuid" in
+*define*) suidperl='suidperl' ;;
+*) suidperl='';;
+esac
+
linklibperl='$(LIBPERL)'
shrpldflags='$(LDDLFLAGS)'
ldlibpth=''
@@ -45,7 +50,7 @@ true)
esac
pldlflags="$cccdlflags"
- static_ldflags=''
+ static_target='static_pic'
case "${osname}${osvers}" in
next4*)
ld=libtool
@@ -53,7 +58,7 @@ true)
-compatibility_version 1 -current_version $patchlevel \
-prebind -seg1addr 0x27000000 -install_name \$(shrpdir)/\$@"
;;
- darwin*)
+ rhapsody*|darwin*)
shrpldflags="${ldflags} -dynamiclib \
-compatibility_version \
${api_revision}.${api_version}.${api_subversion} \
@@ -67,7 +72,7 @@ true)
sunos*)
linklibperl="-lperl"
;;
- netbsd*|freebsd[234]*|openbsd*|dragonfly*|bitrig*)
+ netbsd*|freebsd[234]*|openbsd*|dragonfly*)
linklibperl="-L. -lperl"
;;
interix*)
@@ -146,7 +151,7 @@ EOT
;;
*) pldlflags=''
- static_ldflags='CCCDLFLAGS='
+ static_target='static'
;;
esac
@@ -232,8 +237,8 @@ SHRPENV = $shrpenv
# if building a shared libperl.so that might later be linked into
# another application, then it might be appropriate to also build static
# extensions (usually just DynaLoader) with relocatable code (e.g. -fPIC
-# for GNU cc).
-STATIC_LDFLAGS = $static_ldflags
+# for GNU cc). This is handled by ext/util/make_ext.
+STATIC = $static_target
# The following is used to include the current directory in
# the dynamic loader path you are building a shared libperl.
@@ -247,7 +252,7 @@ DYNALOADER = DynaLoader\$(OBJ_EXT)
libs = $perllibs $cryptlib
-public = perl\$(EXE_EXT) utilities translators
+public = perl\$(EXE_EXT) $suidperl utilities translators
shellflags = $shellflags
@@ -324,24 +329,33 @@ $spitshell >>$Makefile <<'!NO!SUBS!'
CONFIGPM = xlib/$(CROSS_NAME)/Config.pm
-private = preplibrary $(CONFIGPM) $(CROSS_LIB)/Config.pod lib/buildcustomize.pl
+private = preplibrary $(CONFIGPM) $(CROSS_LIB)/Config.pod
-shextract = Makefile cflags config.h makedepend \
+shextract = Makefile cflags config.h makeaperl makedepend \
makedir myconfig writemain pod/Makefile
-addedbyconf = UU $(shextract) lib/lib.pm pstruct
+# Files to be built with variable substitution after miniperl is
+# available. Dependencies handled manually below (for now).
+
+pl = pod/pod2html.PL pod/pod2latex.PL pod/pod2man.PL pod/pod2text.PL \
+ pod/pod2usage.PL pod/podchecker.PL pod/podselect.PL
+
+# lib/lib.pm is not listed here because it has a rule of its own.
+plextract = pod/pod2html pod/pod2latex pod/pod2man pod/pod2text \
+ pod/pod2usage pod/podchecker pod/podselect
+
+addedbyconf = UU $(shextract) $(plextract) lib/lib.pm pstruct
# 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
+unidatafiles = lib/unicore/Canonical.pl lib/unicore/Exact.pl \
+ lib/unicore/Properties lib/unicore/Decomposition.pl \
+ lib/unicore/CombiningClass.pl lib/unicore/Name.pl lib/unicore/PVA.pl
# Directories of Unicode data files generated by mktables
unidatadirs = lib/unicore/To lib/unicore/lib
h1 = EXTERN.h INTERN.h XSUB.h av.h xconfig.h cop.h cv.h dosish.h
-h2 = embed.h form.h gv.h handy.h hv.h hv_func.h keywords.h mg.h op.h opcode.h
+h2 = embed.h form.h gv.h handy.h hv.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
@@ -349,7 +363,7 @@ h = $(h1) $(h2) $(h3) $(h4) $(h5)
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
-c3 = taint.c toke.c util.c deb.c run.c universal.c pad.c globals.c keywords.c
+c3 = taint.c toke.c util.c deb.c run.c universal.c xsutils.c pad.c globals.c
c4 = perlio.c perlapi.c numeric.c mathoms.c locale.c pp_pack.c pp_sort.c
c5 = $(madlysrc) $(mallocsrc)
@@ -357,7 +371,7 @@ c = $(c1) $(c2) $(c3) $(c4) $(c5) miniperlmain.c perlmain.c opmini.c
obj1 = $(madlyobj) $(mallocobj) gv$(OBJ_EXT) toke$(OBJ_EXT) perly$(OBJ_EXT) op$(OBJ_EXT) pad$(OBJ_EXT) regcomp$(OBJ_EXT) dump$(OBJ_EXT) util$(OBJ_EXT) mg$(OBJ_EXT) reentr$(OBJ_EXT) mro$(OBJ_EXT)
obj2 = hv$(OBJ_EXT) av$(OBJ_EXT) perl$(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)
+obj3 = doop$(OBJ_EXT) doio$(OBJ_EXT) regexec$(OBJ_EXT) utf8$(OBJ_EXT) taint$(OBJ_EXT) deb$(OBJ_EXT) universal$(OBJ_EXT) xsutils$(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)
obj = $(obj1) $(obj2) $(obj3) $(ARCHOBJS)
@@ -711,14 +725,39 @@ perl.gcov: perl.config.gcov
microperl:
$(MAKE) -f Makefile.micro
+# This version, if specified in Configure, does ONLY those scripts which need
+# set-id emulation. Suidperl must be setuid root. It contains the "taint"
+# checks as well as the special code to validate that the script in question
+# has been invoked correctly.
+
+suidperl$(EXE_EXT): $& sperl$(OBJ_EXT) perlmain$(OBJ_EXT) $(LIBPERL) $(static_ext) ext.libs $(PERLEXPORT)
+ $(SHRPENV) $(LDLIBPTH) $(CC) -o suidperl $(CLDFLAGS) $(CCDLFLAGS) perlmain$(OBJ_EXT) sperl$(OBJ_EXT) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
+
!NO!SUBS!
fi
$spitshell >>$Makefile <<'!NO!SUBS!'
+sperl$(OBJ_EXT): perl.c $(h)
+ $(RMS) sperl.c
+ $(LNS) perl.c sperl.c
+ $(CCCMD) -DIAMSUID sperl.c
+ $(RMS) sperl.c
+
+# We have to call our ./makedir because Ultrix 4.3 make can't handle the line
+# test -d lib/auto || mkdir lib/auto
+# We need to autosplit in two steps because VOS can't handle so many args
+#
.PHONY: preplibrary
preplibrary: miniperl $(CONFIGPM) lib/lib.pm $(PREPLIBRARY_LIBPERL)
+ @sh ./makedir lib/auto
+ @echo " AutoSplitting perl library"
+ $(LDLIBPTH) ./miniperl -Ilib -MCross -e 'use AutoSplit; \
+ autosplit_lib_modules(@ARGV)' lib/*.pm
+ $(LDLIBPTH) ./miniperl -Ilib -MCross -e 'use AutoSplit; \
+ autosplit_lib_modules(@ARGV)' lib/*/*.pm
+ $(MAKE) lib/re.pm
.PHONY: makeppport
makeppport: miniperl$(EXE_EXT) $(CONFIGPM)
@@ -735,16 +774,19 @@ lib/re.pm: ext/re/re.pm
@-rm -f $@
cp ext/re/re.pm lib/re.pm
-lib/buildcustomize.pl: $(MINIPERL_EXE) write_buildcustomize.pl
- $(MINIPERL) write_buildcustomize.pl >lib/buildcustomize.pl
+$(plextract): miniperl $(CONFIGPM) x2p/s2p
+ @-rm -f $@
+ $(LDLIBPTH) ./miniperl -I`pwd`/lib $@.PL
+
+lib/lib.pm: miniperl $(CONFIGPM)
+ @-rm -f $@
+ $(LDLIBPTH) ./miniperl -Ilib -MCross lib/lib_pm.PL
unidatafiles $(unidatafiles): uni.data
uni.data: miniperl$(EXE_EXT) $(CONFIGPM) lib/unicore/mktables
- cd lib/unicore && $(LDLIBPTH) ../../miniperl -I../../lib mktables -P ../../pod -maketest -makelist -p
-# Commented out so always runs, mktables looks at far more files than we
-# can in this makefile to decide if needs to run or not
-# touch uni.data
+ cd lib/unicore && $(LDLIBPTH) ../../miniperl -I../../lib mktables -w
+ touch uni.data
extra.pods: miniperl
-@test ! -f extra.pods || rm -f `cat extra.pods`
@@ -772,10 +814,7 @@ extras.install: perl$(EXE_EXT)
no-install install.perl install.man install.html
META.yml: Porting/makemeta Porting/Maintainers.pl Porting/Maintainers.pm
- $(LDLIBPTH) ./miniperl -Ilib Porting/makemeta -y
-
-META.json: Porting/makemeta Porting/Maintainers.pl Porting/Maintainers.pm
- $(LDLIBPTH) ./miniperl -Ilib Porting/makemeta -j
+ $(LDLIBPTH) ./miniperl -Ilib Porting/makemeta
install-strip:
$(MAKE) STRIPFLAGS=-s install DESTDIR="$(DESTDIR)"
@@ -812,7 +851,8 @@ install.html: all installhtml
--htmlroot=$(privlib)/html \
--splithead=pod/perlipc \
--splititem=pod/perlfunc \
- --ignore=Porting/Maintainers.pm,Porting/pumpkin.pod,Porting/repository.pod \
+ --libpods=perlfunc:perlguts:perlvar:perlrun:perlop \
+ --ignore=Porting/Maintainers.pm,Porting/patching.pod,Porting/pumpkin.pod,Porting/repository.pod \
--verbose
@@ -839,18 +879,23 @@ perly.c: perly.y
perly.h: perly.y
-@sh -c true
-SYM = globvar.sym perlio.sym
+# No compat3.sym here since and including the 5.004_50.
+# No interp.sym since 5.005_03.
+SYM = global.sym globvar.sym perlio.sym pp.sym
SYMH = perlvars.h intrpvar.h
CHMOD_W = chmod +w
# The following files are generated automatically
-# embed.pl: proto.h embed.h embedvar.h perlapi.h perlapi.c
-# opcode.pl: opcode.h opnames.h pp_proto.h
+# autodoc.pl: pod/perlapi.pod pod/perlintern.pod
+# embed.pl: proto.h embed.h embedvar.h global.sym
+# perlapi.h perlapi.c
+# [* embed.pl needs pp.sym generated by opcode.pl! *]
+# keywords.pl: keywords.h
+# opcode.pl: opcode.h opnames.h pp_proto.h pp.sym
# regcomp.pl: regnodes.h
# warnings.pl: warnings.h lib/warnings.pm
-# feature.pl: feature.h lib/feature.pl
# 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
@@ -858,16 +903,21 @@ CHMOD_W = chmod +w
# 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 \
- perlapi.h perlapi.c regnodes.h warnings.h lib/warnings.pm \
- lib/feature.pm feature.h
+AUTOGEN_FILES = keywords.h opcode.h opnames.h pp_proto.h pp.sym proto.h \
+ embed.h embedvar.h global.sym \
+ pod/perlintern.pod pod/perlapi.pod \
+ perlapi.h perlapi.c regnodes.h \
+ warnings.h lib/warnings.pm
-.PHONY: regen_headers regen_all
+.PHONY: regen_headers regen_pods regen_all
regen regen_headers: FORCE
-perl regen.pl
-regen_all: regen
+regen_pods: FORCE
+ -cd pod; $(LDLIBPTH) $(MAKE) regen_pods
+
+regen_all: regen regen_pods
.PHONY: manisort manicheck
@@ -905,17 +955,17 @@ manicheck: FORCE
-$(DYNALOADER): lib/buildcustomize.pl preplibrary FORCE
- @$(LDLIBPTH) $(RUN) ./miniperl$(EXE_EXT) -Ilib make_ext.pl --cross $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) LINKTYPE=static $(STATIC_LDFLAGS)
+$(DYNALOADER): preplibrary FORCE
+ @$(LDLIBPTH) sh ext/util/make_ext_cross $(STATIC) $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL)
-d_dummy $(dynamic_ext): miniperl$(EXE_EXT) lib/buildcustomize.pl preplibrary makeppport $(DYNALOADER) FORCE
- @$(LDLIBPTH) $(RUN) ./miniperl$(EXE_EXT) -Ilib make_ext.pl --cross $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) LINKTYPE=dynamic
+d_dummy $(dynamic_ext): miniperl$(EXE_EXT) preplibrary makeppport $(DYNALOADER) FORCE
+ @$(LDLIBPTH) sh ext/util/make_ext_cross dynamic $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL)
-s_dummy $(static_ext): miniperl$(EXE_EXT) lib/buildcustomize.pl preplibrary makeppport $(DYNALOADER) FORCE
- @$(LDLIBPTH) $(RUN) ./miniperl$(EXE_EXT) -Ilib make_ext.pl --cross $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) LINKTYPE=static $(STATIC_LDFLAGS)
+s_dummy $(static_ext): miniperl$(EXE_EXT) preplibrary makeppport $(DYNALOADER) FORCE
+ @$(LDLIBPTH) sh ext/util/make_ext_cross $(STATIC) $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL)
-n_dummy $(nonxs_ext): miniperl$(EXE_EXT) lib/buildcustomize.pl preplibrary $(DYNALOADER) FORCE
- @$(LDLIBPTH) $(RUN) ./miniperl$(EXE_EXT) -Ilib make_ext.pl --cross $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL)
+n_dummy $(nonxs_ext): miniperl$(EXE_EXT) preplibrary $(DYNALOADER) FORCE
+ @$(LDLIBPTH) sh ext/util/make_ext_cross nonxs $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL)
!NO!SUBS!
$spitshell >>$Makefile <<EOF
@@ -930,18 +980,19 @@ printconfig:
.PHONY: clean _tidy _mopup _cleaner1 _cleaner2 \
realclean _realcleaner clobber _clobber \
- distclean veryclean _verycleaner
+ distclean veryclean _verycleaner \
+ cleanup_unpacked_files unpack_files
-clean: _tidy _mopup
+clean: cleanup_unpacked_files _tidy _mopup
-realclean: _realcleaner _mopup
+realclean: cleanup_unpacked_files _realcleaner _mopup
@echo "Note that '$(MAKE) realclean' does not delete config.sh or Policy.sh"
_clobber:
-@rm -f Cross/run-* Cross/to-* Cross/from-*
rm -f config.sh cppstdin Policy.sh extras.lst
-clobber: _realcleaner _mopup _clobber
+clobber: cleanup_unpacked_files _realcleaner _mopup _clobber
distclean: clobber
@@ -957,11 +1008,13 @@ _mopup:
-@test -f vms/README_vms.pod && rm -f vms/README_vms.pod
-rm -f perl.exp ext.libs extra.pods uni.data opmini.o
-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
-rm -f perl.pixie lib*.so.perl.pixie lib*.so.Addrs
-rm -f perl.Addrs perl.Counts t/perl.Addrs t/perl.Counts *perl.xok
-rm -f cygwin.c libperl*.def libperl*.dll cygperl*.dll *.exe.stackdump
- -rm -f perl$(EXE_EXT) miniperl$(EXE_EXT) $(LIBPERL) libperl.* microperl
+ -rm -f perl$(EXE_EXT) suidperl$(EXE_EXT) miniperl$(EXE_EXT) $(LIBPERL) libperl.* microperl
+ -rm -f opcode.h-old opnames.h-old pp.sym-old pp_proto.h-old
-rm -f config.over
# Do not 'make _tidy' directly.
@@ -970,7 +1023,7 @@ _tidy:
-cd utils; $(LDLIBPTH) $(MAKE) clean
-cd x2p; $(LDLIBPTH) $(MAKE) clean
-@for x in $(DYNALOADER) $(dynamic_ext) $(static_ext) $(nonxs_ext) ; do \
- $(LDLIBPTH) $(RUN) ./miniperl$(EXE_EXT) -Ilib make_ext.pl --target=clean $$x MAKE=$(MAKE) ; \
+ $(LDLIBPTH) sh ext/util/make_ext clean $$x MAKE=$(MAKE) ; \
done
_cleaner1:
@@ -978,22 +1031,16 @@ _cleaner1:
-cd pod; $(LDLIBPTH) $(MAKE) $(CLEAN)
-cd utils; $(LDLIBPTH) $(MAKE) $(CLEAN)
-cd x2p; $(LDLIBPTH) $(MAKE) $(CLEAN)
- -@if test -f miniperl$(EXE_EXT) ; then \
- for x in $(DYNALOADER) $(dynamic_ext) $(static_ext) $(nonxs_ext) ; do \
- $(LDLIBPTH) $(RUN) ./miniperl$(EXE_EXT) -Ilib make_ext.pl --target=$(CLEAN) $$x MAKE=$(MAKE) ; \
- done ; \
- else \
- sh $(CLEAN).sh ; \
- fi
- rm -f realclean.sh veryclean.sh
+ -@for x in $(DYNALOADER) $(dynamic_ext) $(static_ext) $(nonxs_ext) ; do \
+ $(LDLIBPTH) sh ext/util/make_ext $(CLEAN) $$x MAKE=$(MAKE) ; \
+ done
-@test ! -f ./miniperl$(EXE_EXT) || $(LDLIBPTH) ./miniperl$(EXE_EXT) -Ilib mkppport --clean
# Some systems do not support "?", so keep these files separate.
_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/perl$(EXE_EXT) t/rantests
- rm -rf t/tmp*
+ rm -f t/misctmp* t/forktmp* t/tmp* t/c t/perl$(EXE_EXT) t/rantests
rm -f so_locations $(LIBPERL_NONSHR) $(MINIPERL_NONSHR)
rm -rf $(addedbyconf)
rm -f $(FIRSTMAKEFILE) $(FIRSTMAKEFILE).old makefile.old
@@ -1076,15 +1123,14 @@ makedepend: makedepend.SH config.sh
TESTFILE=TEST
-_test_prep:
+_test_prep: unpack_files
cd t && (rm -f $(PERL)$(EXE_EXT); $(LNS) ../$(PERL)$(EXE_EXT) $(PERL)$(EXE_EXT))
# Architecture-neutral stuff:
test_prep_pre: preplibrary utilities $(nonxs_ext)
-test_prep: test_prep_pre miniperl$(EXE_EXT) $(unidatafiles) perl$(EXE_EXT) \
- $(dynamic_ext) $(TEST_PERL_DLL) x2p/s2p x2p/find2perl
+test_prep: test_prep_pre miniperl$(EXE_EXT) $(unidatafiles) perl$(EXE_EXT) $(dynamic_ext) $(TEST_PERL_DLL)
PERL=./perl $(MAKE) _test_prep
_test_tty:
@@ -1093,6 +1139,12 @@ _test_tty:
_test_notty:
cd t && $(PERL_DEBUG) PERL_SKIP_TTY_TEST=1 $(LDLIBPTH) $(PERL) $(TESTFILE) $(TEST_ARGS)
+unpack_files:
+ $(LDLIBPTH) ./miniperl$(EXE_EXT) -Ilib uupacktool.pl -u -m
+
+cleanup_unpacked_files:
+ -@test ! -f ./miniperl$(EXE_EXT) || $(LDLIBPTH) ./miniperl$(EXE_EXT) -Ilib uupacktool.pl -c
+
# The second branch is for testing without a tty or controlling terminal,
# see t/op/stat.t
_test:
@@ -1133,7 +1185,7 @@ test.torture torturetest: test_prep
minitest.utf16: minitest.prep
- cd t && (rm -f perl$(EXE_EXT); $(LNS) ../miniperl$(EXE_EXT) perl$(EXE_EXT)) \
- && $(LDLIBPTH) ./perl TEST -utf16 base/*.t comp/*.t cmd/*.t run/*.t io/*.t op/*.t uni/*.t </dev/tty
+ && $(LDLIBPTH) ./perl TEST -minitest -utf16 base/*.t comp/*.t cmd/*.t run/*.t io/*.t op/*.t uni/*.t </dev/tty
test.utf16 check.utf16: test_prep
PERL=./perl $(MAKE) TEST_ARGS=-utf16 _test
@@ -1192,9 +1244,9 @@ minitest.prep:
# Can't depend on lib/Config.pm because that might be where miniperl
# is crashing.
-minitest: miniperl$(EXE_EXT) minitest.prep
+minitest: miniperl$(EXE_EXT) lib/re.pm minitest.prep
- cd t && (rm -f perl$(EXE_EXT); $(LNS) ../miniperl$(EXE_EXT) perl$(EXE_EXT)) \
- && $(LDLIBPTH) ./perl TEST base/*.t comp/*.t cmd/*.t run/*.t io/*.t op/*.t uni/*.t </dev/tty
+ && $(LDLIBPTH) ./perl TEST -minitest base/*.t comp/*.t cmd/*.t run/*.t io/*.t op/*.t uni/*.t </dev/tty
# Test via harness
@@ -1235,7 +1287,7 @@ noknack: utilities
nokfilenack: utilities
$(LDLIBPTH) ./perl -Ilib utils/perlbug -nok -s '(UNINSTALLED)' -F perl.nok -A
-.PHONY: clist hlist shlist
+.PHONY: clist hlist shlist pllist
clist: $(c)
echo $(c) | tr ' ' $(TRNL) >.clist
@@ -1246,6 +1298,9 @@ hlist: $(h)
shlist: $(sh)
echo $(sh) | tr ' ' $(TRNL) >.shlist
+pllist: $(pl)
+ echo $(pl) | tr ' ' $(TRNL) >.pllist
+
Makefile: Makefile.SH ./config.sh
$(SHELL) Makefile.SH
@@ -1266,7 +1321,7 @@ etags: TAGS
TAGS: emacs/cperl-mode.elc
sh emacs/ptags
-# Let's hope make will not go into an infinite loop on case-insensitive systems
+# Let's hope make will not go into an infinite loop on case-unsensitive systems
# This may also fail if . is in the head of the path, since perl will
# require -Ilib
tags: TAGS
@@ -1280,6 +1335,12 @@ ctags:
!NO!SUBS!
$eunicefix $Makefile
+case `pwd` in
+*SH)
+ $rm -f ../$Makefile
+ $ln $Makefile ../$Makefile
+ ;;
+esac
$rm -f $firstmakefile
# Now do any special processing required before building.
@@ -1329,6 +1390,9 @@ os390|posix-bc)
cd ..
fi
;;
+vmesa)
+ # Do nothing in VM/ESA.
+ ;;
*)
echo "'$osname' is an EBCDIC system I don't know that well." >&4
;;
diff --git a/gnu/usr.bin/perl/Cross/cflags-cross-arm b/gnu/usr.bin/perl/Cross/cflags-cross-arm
index acec8cc80fa..9241d01cca7 100755
--- a/gnu/usr.bin/perl/Cross/cflags-cross-arm
+++ b/gnu/usr.bin/perl/Cross/cflags-cross-arm
@@ -108,6 +108,7 @@ for file do
usersub) ;;
utf8) ;;
util) ;;
+ xsutils) ;;
*) ;;
esac
@@ -148,7 +149,7 @@ if test -f .patch; then
fi
: Can we perhaps use $ansi2knr here
- echo "$CROSSCC -c -DUSE_CROSS_COMPILE -DPERL_CORE $ccflags $stdflags $optimize $warn $extra"
+ echo "$CROSSCC -c -DPERL_CORE $ccflags $stdflags $optimize $warn $extra"
eval "$also "'"$CROSSCC -DUSE_CROSS_COMPILE -DPERL_CORE -c $ccflags $stdflags $optimize $warn $extra"'
. $TOP/Cross/config-arm.sh
diff --git a/gnu/usr.bin/perl/Porting/add-package.pl b/gnu/usr.bin/perl/Porting/add-package.pl
index fc2161d9a90..b403bcaba0e 100755
--- a/gnu/usr.bin/perl/Porting/add-package.pl
+++ b/gnu/usr.bin/perl/Porting/add-package.pl
@@ -8,82 +8,44 @@ use File::Basename;
use FindBin;
my $Opts = {};
-getopts( 'r:p:e:c:vudn', $Opts );
+getopts( 'r:p:e:vud', $Opts );
my $Cwd = cwd();
my $Verbose = 1;
-my $ExcludeRe = $Opts->{e} ? qr/$Opts->{e}/i : undef;
+my $ExcludeRe = $Opts->{e} ? qr/$Opts->{e}/ : undef;
my $Debug = $Opts->{v} || 0;
my $RunDiff = $Opts->{d} || 0;
my $PkgDir = $Opts->{p} || cwd();
-my $Repo = $Opts->{r} or die "Need repository!\n". usage();
-my $Changes = $Opts->{c} || 'Changes ChangeLog';
-my $NoBranch = $Opts->{n} || 0;
+my $MasterRepo = $Opts->{r} or die "Need repository!\n". usage();
### strip trailing slashes;
-$Repo =~ s|/$||;
+$MasterRepo =~ s|/$||;
my $CPV = $Debug ? '-v' : '';
my $TestBin = 'ptardiff';
my $PkgDirRe = quotemeta( $PkgDir .'/' );
-my $BranchName = basename( $PkgDir ) . '.' . $$;
-my $OrigRepo = $Repo;
+my $Repo = $MasterRepo . '-' . basename( $PkgDir ) . '.' . $$;
-### establish working directory, either branch or full copy
-if ( $NoBranch ) {
- ### create a copy of the repo directory
- my $RepoCopy = "$Repo-$BranchName";
- print "Copying repository to $RepoCopy ..." if $Verbose;
-
- ### --archive == -dPpR, but --archive is not portable, and neither
- ### is -d, so settling for -PpR
- system( "cp -PpR -f $Repo $RepoCopy" )
- and die "Copying master repo to $RepoCopy failed: $?";
-
- ### Going forward, use the copy in place of the original repo
- $Repo = $RepoCopy;
+### chdir there
+chdir $PkgDir or die "Could not chdir to $PkgDir: $!";
- print "done\n" if $Verbose;
-}
-else {
- ### create a git branch for the new package
- print "Setting up a branch from blead called '$BranchName'..." if $Verbose;
- chdir $Repo or die "Could not chdir to $Repo: $!";
- unless ( -d '.git' ) {
- die "\n$Repo is not a git repository\n";
- }
- my $status = `git status`;
- unless ( $status =~ /nothing to commit/ims ) {
- die "\nWorking directory not clean. Stopping.\n";
+### set up the repo dir from the master repo
+{ print "Setting up working repo under '$Repo'..." if $Verbose;
+ unless( -d $Repo ) {
+ system( "mkdir -p $Repo" )
+ and die "Could not create working repo '$Repo': $?";
}
- system( "git checkout -b $BranchName blead" )
- and die "Could not create branch '$BranchName': $?";
+
+ system( "cp -Rf $MasterRepo/* $Repo" )
+ and die "Copying master repo to $Repo failed: $?";
print "done\n" if $Verbose;
}
-### chdir there
-chdir $PkgDir or die "Could not chdir to $PkgDir: $!";
-
### copy over all files under lib/
-my @LibFiles;
{ print "Copying libdir..." if $Verbose;
- die "Can't (yet) copy from a repository (found .git or .svn)"
- if -d '.git' || -d '.svn';
die "No lib/ directory found\n" unless -d 'lib';
system( "cp -fR $CPV lib $Repo" ) and die "Copy of lib/ failed: $?";
-
- @LibFiles = map { chomp; $_ }
- ### should we get rid of this file?
- grep { $ExcludeRe && $_ =~ $ExcludeRe
- ? do { warn "Removing $Repo/$_\n";
- system("rm $Repo/$_") and die "rm '$Repo/$_' failed: $?";
- undef
- }
- : 1
- } `find lib -type f`
- or die "Could not detect library files\n";
-
print "done\n" if $Verbose;
}
@@ -94,7 +56,7 @@ my $ModName; # name of the module
my @ModFiles; # the .PMs in this package
{ print "Creating top level dir..." if $Verbose;
- ### make sure we get the shortest file, so we don't accidentally get
+ ### make sure we get the shortest file, so we dont accidentally get
### a subdir
@ModFiles = sort { length($a) <=> length($b) }
map { chomp; $_ }
@@ -138,67 +100,46 @@ my @TestFiles;
? system( "cp -fR $CPV t $TopDir" ) && die "Copy of t/ failed: $?"
: warn "No t/ directory found\n";
- @TestFiles = map { chomp; s|^$TopDirRe||; s|//|/|g; $_ }
+ @TestFiles = map { chomp; s|^$TopDirRe||; $_ }
### should we get rid of this file?
grep { $ExcludeRe && $_ =~ $ExcludeRe
? do { warn "Removing $_\n";
- system("rm $TopDir/$_") and die "rm '$_' failed: $?";
+ system("rm $_") and die "rm '$_' failed: $?";
undef
}
: 1
- } `find t -type f`
+ } `find $TopDir/t -type f`
or die "Could not detect testfiles\n";
print "done\n" if $Verbose;
}
-my $BinDir;
my @BinFiles;
-my $TopBinDir;
BIN: {
- $BinDir = -d 'bin' ? 'bin' :
- -d 'scripts' ? 'scripts' : undef ;
- unless ($BinDir) {
- print "No bin/ or scripts/ directory found\n" if $Verbose;
+ unless (-d 'bin') {
+ print "No bin/ directory found\n" if $Verbose;
last BIN;
}
- my $TopBinDir = "$TopDir/$BinDir/";
- print "Copying $BinDir/* files to $TopBinDir..." if $Verbose;
+ print "Copying bin/* files to $TopDir..." if $Verbose;
- my $CopyCmd = "cp -fR $CPV $BinDir $TopDir";
- print "Running '$CopyCmd'..." if $Verbose;
+ system("cp -fR $CPV bin/* $TopDir/bin/") && die "Copy of bin/ failed: $?";
- system($CopyCmd) && die "Copy of $BinDir failed: $?";
-
- @BinFiles = map { chomp; s|^$TopDirRe||; s|//|/|g; $_ }
+ @BinFiles = map { chomp; s|^$TopDirRe||; $_ }
### should we get rid of this file?
grep { $ExcludeRe && $_ =~ $ExcludeRe
? do { warn "Removing $_\n";
- system("rm $TopDir/$_") and die "rm '$_' failed: $?";
+ system("rm $_") and die "rm '$_' failed: $?";
undef
}
: 1
- } `find $BinDir -type f`
+ } `find $TopDir/bin -type f`
or die "Could not detect binfiles\n";
print "done\n" if $Verbose;
}
-### copy over change log
-my @Changes;
-foreach my $cl (split m/\s+/ => $Changes) {
- -f $cl or next;
- push @Changes, $cl;
- print "Copying $cl files to $TopDir..." if $Verbose;
-
- system( "cp -f $CPV $cl $TopDir" )
- and die "Copy of $cl failed: $?";
-}
-
-
### add files where they are required
my @NewFiles;
-my @ChangedFiles;
{ for my $bin ( map { basename( $_ ) } @BinFiles ) {
print "Registering $bin with system files...\n";
@@ -216,7 +157,6 @@ my @ChangedFiles;
system("$^X -pi -e 's/($TestBin\\|)/$bin|\$1/' $Repo/$file")
and die "Could not add $bin to $file: $?";
print "done\n" if $Verbose;
- push @ChangedFiles, $file;
} else {
print " $bin already mentioned in $file\n" if $Verbose;
}
@@ -234,7 +174,6 @@ my @ChangedFiles;
system("$^X -pi -e 's!($TestBin)!\$1\nutils/$bin!' $Repo/$file")
and die "Could not add $bin to $file: $?";
print "done\n" if $Verbose;
- push @ChangedFiles, $file;
} else {
print " $bin already mentioned in $file\n" if $Verbose;
}
@@ -261,7 +200,7 @@ my @ChangedFiles;
### change the 'updir' path
### make sure to escape the \[ character classes
- my $updir = join ' ', (split('/', $RelTopDir), $BinDir);
+ my $updir = join ' ', (split('/', $RelTopDir), 'bin');
system( "$^X -pi -e'".
's/^(.*?File::Spec->updir, qw\[).+?(\].*)$/'.
"\$1 $updir \$2/' $Repo/$file"
@@ -283,8 +222,8 @@ my @ChangedFiles;
push @NewFiles, $file;
}
- ### add an entry to utils/Makefile.PL for $bin
- { my $file = "utils/Makefile.PL";
+ ### add an entry to utils/Makefile for $bin
+ { my $file = "utils/Makefile";
### not there already?
unless( `grep $bin $Repo/$file` ) {
@@ -312,7 +251,6 @@ my @ChangedFiles;
"' $Repo/$file"
) and die "Could not add $bin as a make directive: $?";
- push @ChangedFiles, $file;
print "done\n" if $Verbose;
} else {
print " $bin already added to $file\n" if $Verbose;
@@ -336,7 +274,6 @@ my @ChangedFiles;
system( "$^X -pi -e's/( $TestBin)/\$1 $bin/' $Repo/$file" )
and die "Could not add $bin to $file: $?\n";
- push @ChangedFiles, $file;
print "done\n" if $Verbose;
} else {
print " $bin already added to $file\n" if $Verbose;
@@ -344,7 +281,7 @@ my @ChangedFiles;
}
### we need some entries in a vms specific file as well..
- ### except, I don't understand how it works or what it does, and it
+ ### except, i dont understand how it works or what it does, and it
### looks all a bit odd... so lets just print a warning...
### the entries look something like this:
# ./vms/descrip_mms.template:utils4 = [.utils]enc2xs.com
@@ -358,8 +295,8 @@ my @ChangedFiles;
print $/.$/;
print " WARNING! You should add entries like the following\n"
. " to $file (Using $TestBin as an example)\n"
- . " Unfortunately I don't understand what these entries\n"
- . " do, so I won't change them automatically:\n\n";
+ . " Unfortunately I dont understand what these entries\n"
+ . " do, so I wont change them automatically:\n\n";
print `grep -nC1 $TestBin $Repo/$file`;
print $/.$/;
@@ -371,6 +308,49 @@ my @ChangedFiles;
}
}
+### binary files must be encoded!
+### XXX use the new 'uupacktool.pl'
+{ my $pack = "$Repo/uupacktool.pl";
+
+ ### pack.pl encodes binary files for us
+ -e $pack or die "Need $pack to encode binary files!";
+
+ ### chdir, so uupacktool writes relative files properly
+ ### into it's header...
+ my $curdir = cwd();
+ chdir($Repo) or die "Could not chdir to '$Repo': $!";
+
+ for my $aref ( \@ModFiles, \@TestFiles, \@BinFiles ) {
+ for my $file ( @$aref ) {
+ my $full = -e $file ? $file :
+ -e "$RelTopDir/$file" ? "$RelTopDir/$file" :
+ die "Can not find $file in $Repo or $TopDir\n";
+
+ if( -f $full && -s _ && -B _ ) {
+ print "Binary file $file needs encoding\n" if $Verbose;
+
+ my $out = $full . '.packed';
+
+ ### does the file exist already?
+ ### and doesn't have +w
+ if( -e $out && not -w _ ) {
+ system("chmod +w $out")
+ and die "Could not set chmod +w to '$out': $!";
+ }
+
+ ### -D to remove the original
+ system("$^X $pack -D -p $full $out")
+ and die "Could not encode $full to $out";
+
+
+ $file .= '.packed';
+ }
+ }
+ }
+
+ chdir($curdir) or die "Could not chdir back to '$curdir': $!";
+}
+
### update the manifest
{ my $file = $Repo . '/MANIFEST';
my @manifest;
@@ -394,10 +374,6 @@ my @ChangedFiles;
basename($_) ." utility\n";
}
- for ( @Changes ) {
- $pkg_files{"$RelTopDir/$_"} = "$RelTopDir/$_\t$ModName change log\n";
- }
-
for ( @NewFiles ) {
$pkg_files{$_} = "$_\tthe ".
do { m/(.+?)\.PL$/; basename($1) } .
@@ -413,7 +389,7 @@ my @ChangedFiles;
push @manifest, values %pkg_files;
- { chmod 0644, $file;
+ { chmod 0755, $file;
open my $fh, ">$file" or die "Could not open $file for writing: $!";
#print $fh sort { lc $a cmp lc $b } @manifest;
### XXX stolen from pod/buildtoc:sub do_manifest
@@ -425,66 +401,34 @@ my @ChangedFiles;
close $fh;
}
- push @ChangedFiles, 'MANIFEST';
}
-
### would you like us to show you a diff?
if( $RunDiff ) {
- if ( $NoBranch ) {
-
- my $diff = $Repo; $diff =~ s/$$/patch/;
-
- ### weird RV ;(
- my $master = basename( $OrigRepo );
- my $repo = basename( $Repo );
- my $chdir = dirname( $OrigRepo );
-
- ### the .patch file is added by an rsync from the APC
- ### but isn't actually in the p4 repo, so exclude it
- my $cmd = "cd $chdir; diff -ruN --exclude=.patch $master $repo > $diff";
+ my $diff = $Repo; $diff =~ s/$$/patch/;
- print "Running: '$cmd'\n";
+ ### weird RV ;(
+ my $master = basename( $MasterRepo );
+ my $repo = basename( $Repo );
+ my $chdir = dirname( $MasterRepo );
- print "Generating diff..." if $Verbose;
-
- system( $cmd );
- #and die "Could not write diff to '$diff': $?";
- die "Could not write diff to '$diff'" unless -e $diff && -s _;
-
- print "done\n" if $Verbose;
- print "\nDiff can be applied with patch -p1 in $OrigRepo\n\n";
- print " Diff written to: $diff\n\n" if $Verbose;
- }
- else {
- my $diff = "$Repo/$BranchName"; $diff =~ s/$$/patch/;
- my $cmd = "cd $Repo; git diff > $diff";
+ ### the .patch file is added by an rsync from the APC
+ ### but isn't actually in the p4 repo, so exclude it
+ my $cmd = "cd $chdir; diff -ruN --exclude=.patch $master $repo > $diff";
- print "Running: '$cmd'\n";
+ print "Running: '$cmd'\n";
- print "Generating diff..." if $Verbose;
+ print "Generating diff..." if $Verbose;
- system( $cmd );
- #and die "Could not write diff to '$diff': $?";
- die "Could not write diff to '$diff'" unless -e $diff && -s _;
+ system( $cmd );
+ #and die "Could not write diff to '$diff': $?";
+ die "Could not write diff to '$diff'" unless -e $diff && -s _;
- print "done\n" if $Verbose;
- print " Diff written to: $diff\n\n" if $Verbose;
- }
-}
-
-
-# add files to git index
-unless ( $NoBranch ) {
- chdir $Repo;
- system( "git add $CPV $_" )
- for ( @LibFiles, @NewFiles, @ChangedFiles,
- map { "$RelTopDir/$_" } @TestFiles, @BinFiles, @Changes );
+ print "done\n" if $Verbose;
+ print "\nDiff can be applied with patch -p1 in $MasterRepo\n\n";
+ print " Diff written to: $diff\n\n" if $Verbose;
}
-# return to original directory
-chdir $Cwd;
-
sub usage {
my $me = basename($0);
return qq[
@@ -492,13 +436,11 @@ sub usage {
Usage: $me -r PERL_REPO_DIR [-p PACKAGE_DIR] [-v] [-d] [-e REGEX]
Options:
- -r Path to perl-core git repository
+ -r Path to perl-core repository
-v Run verbosely
- -c File containing changelog (default 'Changes' or 'ChangeLog')
-e Perl regex matching files that shouldn't be included
-d Create a diff as patch file
-p Path to the package to add. Defaults to cwd()
- -n No branching; repository is not a git repo
\n];
diff --git a/gnu/usr.bin/perl/Porting/corelist.pl b/gnu/usr.bin/perl/Porting/corelist.pl
index fcca6d4ef3e..c32a1769b68 100755
--- a/gnu/usr.bin/perl/Porting/corelist.pl
+++ b/gnu/usr.bin/perl/Porting/corelist.pl
@@ -1,473 +1,46 @@
#!perl
# Generates info for Module::CoreList from this perl tree
-# run this from the root of a perl tree
-#
-# Data is on STDOUT.
-#
-# With an optional arg specifying the root of a CPAN mirror, outputs the
-# %upstream and %bug_tracker hashes too.
+# run this from the root of a clean perl tree
-use autodie;
use strict;
use warnings;
-no warnings 'experimental::autoderef';
use File::Find;
use ExtUtils::MM_Unix;
-use version;
-use lib "Porting";
-use Maintainers qw(%Modules files_to_modules);
-use File::Spec;
-use Parse::CPAN::Meta;
-use IPC::Cmd 'can_run';
-use HTTP::Tiny;
-use IO::Uncompress::Gunzip;
-
-my $corelist_file = 'dist/Module-CoreList/lib/Module/CoreList.pm';
-my $utils_file = 'dist/Module-CoreList/lib/Module/CoreList/Utils.pm';
my %lines;
-my %module_to_file;
-my %modlist;
-
-die "usage: $0 [ cpan-mirror/ ] [ 5.x.y] \n" unless @ARGV <= 2;
-my $cpan = shift;
-my $raw_version = shift || $];
-my $perl_version = version->parse("$raw_version");
-my $perl_vnum = $perl_version->numify;
-my $perl_vstring = $perl_version->normal; # how do we get version.pm to not give us leading v?
-$perl_vstring =~ s/^v//;
-
-if ( !-f 'MANIFEST' ) {
- die "Must be run from the root of a clean perl tree\n";
-}
-
-open( my $corelist_fh, '<', $corelist_file );
-my $corelist = join( '', <$corelist_fh> );
-close $corelist_fh;
-
-unless (
- $corelist =~ /^%released \s* = \s* \(
- .*?
- $perl_vnum \s* => \s* .*?
- \);/ismx
- )
-{
- warn "Adding $perl_vnum to the list of released perl versions. Please consider adding a release date.\n";
- $corelist =~ s/^(%released \s* = \s* .*?) ( \) )
- /$1 $perl_vnum => '????-??-??',\n $2/ismx;
-}
-
-if ($cpan) {
- my $modlistfile = File::Spec->catfile( $cpan, 'modules', '02packages.details.txt' );
- my $content;
-
- my $fh;
- if ( -e $modlistfile ) {
- warn "Reading the module list from $modlistfile";
- open $fh, '<', $modlistfile;
- } elsif ( -e $modlistfile . ".gz" ) {
- my $zcat = can_run('gzcat') || can_run('zcat') or die "Can't find gzcat or zcat";
- warn "Reading the module list from $modlistfile.gz";
- open $fh, '-|', "$zcat $modlistfile.gz";
- } else {
- warn "About to fetch 02packages from ftp.funet.fi. This may take a few minutes\n";
- my $gzipped_content = fetch_url('http://ftp.funet.fi/pub/CPAN/modules/02packages.details.txt.gz');
- unless ($gzipped_content) {
- die "Unable to read 02packages.details.txt from either your CPAN mirror or ftp.funet.fi";
- }
- IO::Uncompress::Gunzip::gunzip(\$gzipped_content, \$content, Transparent => 0)
- or die "Can't gunzip content: $IO::Uncompress::Gunzip::GunzipError";
- }
-
- if ( $fh and !$content ) {
- local $/ = "\n";
- $content = join( '', <$fh> );
- }
-
- die "Incompatible modlist format"
- unless $content =~ /^Columns: +package name, version, path/m;
-
- # Converting the file to a hash is about 5 times faster than a regexp flat
- # lookup.
- for ( split( qr/\n/, $content ) ) {
- next unless /^([A-Za-z_:0-9]+) +[-0-9.undefHASHVERSIONvsetwhenloadingbogus]+ +(\S+)/;
- $modlist{$1} = $2;
- }
-}
-
-find(
- sub {
- /(\.pm|_pm\.PL)$/ or return;
- /PPPort\.pm$/ and return;
- my $module = $File::Find::name;
- $module =~ /\b(demo|t|private)\b/ and return; # demo or test modules
- my $version = MM->parse_version($_);
- defined $version or $version = 'undef';
- $version =~ /\d/ and $version = "'$version'";
-
- # some heuristics to figure out the module name from the file name
- $module =~ s{^(lib|cpan|dist|(?:symbian/)?ext|os2/OS2)/}{}
- and $1 ne 'lib'
- and (
- $module =~ s{\b(\w+)/\1\b}{$1},
- $module =~ s{^B/O}{O},
- $module =~ s{^Devel-PPPort}{Devel},
- $module =~ s{^libnet/}{},
- $module =~ s{^PathTools/}{},
- $module =~ s{REXX/DLL}{DLL},
- $module =~ s{^Encode/encoding}{encoding},
- $module =~ s{^IPC-SysV/}{IPC/},
- $module =~ s{^MIME-Base64/QuotedPrint}{MIME/QuotedPrint},
- $module =~ s{^(?:DynaLoader|Errno|Opcode|XSLoader)/}{},
- $module =~ s{^Sys-Syslog/win32}{Sys-Syslog},
- $module =~ s{^Time-Piece/Seconds}{Time/Seconds},
- );
- $module =~ s{^lib/}{}g;
- $module =~ s{/}{::}g;
- $module =~ s{-}{::}g;
- $module =~ s{^.*::lib::}{}; # turns Foo/lib/Foo.pm into Foo.pm
- $module =~ s/(\.pm|_pm\.PL)$//;
- $lines{$module} = $version;
- $module_to_file{$module} = $File::Find::name;
- },
- 'os2/OS2',
- 'symbian/ext',
- 'lib',
- 'ext',
- 'cpan',
- 'dist'
-);
-
--e 'configpm' and $lines{Config} = "$]";
-
-if ( open my $ucdv, "<", "lib/unicore/version" ) {
- chomp( my $ucd = <$ucdv> );
- $lines{Unicode} = "'$ucd'";
+find(sub {
+ /(\.pm|_pm\.PL)$/ or return;
+ /PPPort\.pm$/ and return;
+ my $module = $File::Find::name;
+ $module =~ /\b(demo|t|private)\b/ and return; # demo or test modules
+ my $version = MM->parse_version($_);
+ defined $version or $version = 'undef';
+ $version =~ /\d/ and $version = "'$version'";
+ # some heuristics to figure out the module name from the file name
+ $module =~ s{^(lib|(win32/|vms/|symbian/)?ext)/}{}
+ and $1 ne 'lib'
+ and ( $module =~ s{^(.*)/lib/\1\b}{$1},
+ $module =~ s{(\w+)/\1\b}{$1},
+ $module =~ s{^B/O}{O},
+ $module =~ s{^IO_Compress_Base/lib/}{},
+ $module =~ s{^IO_Compress_Zlib/(?:lib/)?}{},
+ $module =~ s{^Devel/PPPort}{Devel},
+ $module =~ s{^Encode/encoding}{encoding},
+ $module =~ s{^IPC/SysV/}{IPC/},
+ $module =~ s{^List/Util/lib/Scalar}{Scalar},
+ $module =~ s{^MIME/Base64/QuotedPrint}{MIME/QuotedPrint},
+ $module =~ s{^(?:DynaLoader|Errno|Opcode)/}{},
+ );
+ $module =~ s{/}{::}g;
+ $module =~ s/(\.pm|_pm\.PL)$//;
+ $lines{sprintf "\t%-24s=> $version,\n", "'$module'"}++;
+}, 'lib', 'ext', 'vms/ext', 'symbian/ext');
+
+if (open my $ucdv, "<", "lib/unicore/version") {
+ chomp (my $ucd = <$ucdv>);
+ $lines{sprintf "\t%-24s=> '$ucd',\n", "'Unicode'"}++;
close $ucdv;
-}
-
-my $delta_data = make_corelist_delta(
- $perl_vnum,
- \%lines,
- \%Module::CoreList::version
-);
-
-my $versions_in_release = " " . $perl_vnum . " => {\n";
-$versions_in_release .= " delta_from => $delta_data->{delta_from},\n";
-$versions_in_release .= " changed => {\n";
-foreach my $key (sort keys $delta_data->{changed}) {
- $versions_in_release .= sprintf " %-24s=> %s,\n", "'$key'",
- defined $delta_data->{changed}{$key} ? "'"
- . $delta_data->{changed}{$key} . "'" : "undef";
-}
-$versions_in_release .= " },\n";
-$versions_in_release .= " removed => {\n";
-for my $key (sort keys($delta_data->{removed} || {})) {
- $versions_in_release .= sprintf " %-24s=> %s,\n", "'$key'", 1;
-}
-$versions_in_release .= " }\n";
-$versions_in_release .= " },\n";
-
-$corelist =~ s/^(%delta\s*=\s*.*?)^\s*$perl_vnum\s*=>\s*{.*?},\s*(^\);)$/$1$2/ism;
-$corelist =~ s/^(%delta\s*=\s*.*?)(^\);)$/$1$versions_in_release$2/ism;
-
-exit unless %modlist;
-
-# We have to go through this two stage lookup, given how Maintainers.pl keys its
-# data by "Module", which is really a dist.
-my $file_to_M = files_to_modules( values %module_to_file );
-
-sub slurp_utf8($) {
- open my $fh, "<:utf8", "$_[0]"
- or die "can't open $_[0] for reading: $!";
- return do { local $/; <$fh> };
-}
-
-sub parse_cpan_meta($) {
- return Parse::CPAN::Meta->${
- $_[0] =~ /\A\x7b/ ? \"load_json_string" : \"load_yaml_string"
- }($_[0]);
-}
-
-my %module_to_upstream;
-my %module_to_dist;
-my %dist_to_meta_YAML;
-my %module_to_deprecated;
-while ( my ( $module, $file ) = each %module_to_file ) {
- my $M = $file_to_M->{$file};
- next unless $M;
- next if $Modules{$M}{MAINTAINER} && $Modules{$M}{MAINTAINER} eq 'P5P';
- $module_to_upstream{$module} = $Modules{$M}{UPSTREAM};
- $module_to_deprecated{$module} = 1 if $Modules{$M}{DEPRECATED};
- next
- if defined $module_to_upstream{$module}
- && $module_to_upstream{$module} eq 'blead';
- my $dist = $modlist{$module};
- unless ($dist) {
- warn "Can't find a distribution for $module\n";
- next;
- }
- $module_to_dist{$module} = $dist;
-
- next if exists $dist_to_meta_YAML{$dist};
-
- $dist_to_meta_YAML{$dist} = undef;
-
- # Like it or lump it, this has to be Unix format.
- my $meta_YAML_path = "authors/id/$dist";
- $meta_YAML_path =~ s/(?:tar\.gz|tar\.bz2|zip|tgz)$/meta/
- or die "ERROR: bad meta YAML path: '$meta_YAML_path'";
- my $meta_YAML_url = 'http://ftp.funet.fi/pub/CPAN/' . $meta_YAML_path;
-
- if ( -e "$cpan/$meta_YAML_path" ) {
- $dist_to_meta_YAML{$dist} = parse_cpan_meta(slurp_utf8( $cpan . "/" . $meta_YAML_path ));
- } elsif ( my $content = fetch_url($meta_YAML_url) ) {
- unless ($content) {
- warn "Failed to fetch $meta_YAML_url\n";
- next;
- }
- eval { $dist_to_meta_YAML{$dist} = parse_cpan_meta($content); };
- if ( my $err = $@ ) {
- warn "$meta_YAML_path: ".$err;
- next;
- }
- } else {
- warn "$meta_YAML_path does not exist for $module\n";
-
- # I tried code to open the tarballs with Archive::Tar to find and
- # extract META.yml, but only Text-Tabs+Wrap-2006.1117.tar.gz had one,
- # so it's not worth including.
- next;
- }
-}
-
-my $upstream_stanza = "%upstream = (\n";
-foreach my $module ( sort keys %module_to_upstream ) {
- my $upstream = defined $module_to_upstream{$module} ? "'$module_to_upstream{$module}'" : 'undef';
- $upstream_stanza .= sprintf " %-24s=> %s,\n", "'$module'", $upstream;
-}
-$upstream_stanza .= ");";
-
-$corelist =~ s/^%upstream .*? ;$/$upstream_stanza/ismx;
-
-# Deprecation generation
-{
- my $delta_data = make_corelist_delta(
- $perl_vnum,
- \%module_to_deprecated,
- do { no warnings 'once'; \%Module::CoreList::deprecated },
- );
-
- my $deprecated_stanza = " " . $perl_vnum . " => {\n";
- $deprecated_stanza .= " delta_from => $delta_data->{delta_from},\n";
- $deprecated_stanza .= " changed => {\n";
- foreach my $key (sort keys $delta_data->{changed}) {
- $deprecated_stanza .= sprintf " %-24s=> %s,\n", "'$key'",
- defined $delta_data->{changed}{$key} ? "'"
- . $delta_data->{changed}{$key} . "'" : "undef";
- }
- $deprecated_stanza .= " },\n";
- $deprecated_stanza .= " removed => {\n";
- for my $key (sort keys($delta_data->{removed} || {})) {
- $deprecated_stanza .= sprintf " %-24s=> %s,\n", "'$key'", 1;
- }
- $deprecated_stanza .= " }\n";
- $deprecated_stanza .= " },\n";
-
- $corelist =~ s/^(%deprecated\s*=\s*.*?)^\s*$perl_vnum\s*=>\s*{.*?},\s*(^\);)$/$1$2/ism;
- $corelist =~ s/^(%deprecated\s*=\s*.*?)(^\);)$/$1$deprecated_stanza$2/xism;
-}
-
-my $tracker = "%bug_tracker = (\n";
-foreach my $module ( sort keys %module_to_upstream ) {
- my $upstream = defined $module_to_upstream{$module};
- next
- if defined $upstream and $upstream eq 'blead';
-
- my $bug_tracker;
-
- my $dist = $module_to_dist{$module};
- $bug_tracker = $dist_to_meta_YAML{$dist}->{resources}{bugtracker}
- if $dist;
- $bug_tracker = $bug_tracker->{web} if ref($bug_tracker) eq "HASH";
-
- $bug_tracker = defined $bug_tracker ? quote($bug_tracker) : 'undef';
- next if $bug_tracker eq "'http://rt.perl.org/perlbug/'";
- $tracker .= sprintf " %-24s=> %s,\n", "'$module'", $bug_tracker;
-}
-$tracker .= ");";
-
-$corelist =~ s/^%bug_tracker .*? ;/$tracker/eismx;
-
-write_corelist($corelist,$corelist_file);
-
-open( my $utils_fh, '<', $utils_file );
-my $utils = join( '', <$utils_fh> );
-close $utils_fh;
-
-my %utils = map { ( $_ => 1 ) } parse_utils_lst();
-
-my $delta_utils = make_coreutils_delta($perl_vnum, \%utils);
-
-my $utilities_in_release = " " . $perl_vnum . " => {\n";
-$utilities_in_release .= " delta_from => $delta_utils->{delta_from},\n";
-$utilities_in_release .= " changed => {\n";
-foreach my $key (sort keys $delta_utils->{changed}) {
- $utilities_in_release .= sprintf " %-24s=> %s,\n", "'$key'",
- defined $delta_utils->{changed}{$key} ? "'"
- . $delta_utils->{changed}{$key} . "'" : "undef";
-}
-$utilities_in_release .= " },\n";
-$utilities_in_release .= " removed => {\n";
-for my $key (sort keys($delta_utils->{removed} || {})) {
- $utilities_in_release .= sprintf " %-24s=> %s,\n", "'$key'", 1;
-}
-$utilities_in_release .= " }\n";
-$utilities_in_release .= " },\n";
-
-$utils =~ s/^(my %delta\s*=\s*.*?)^\s*$perl_vnum\s*=>\s*{.*?},\s*(^\);)$/$1$2/ism;
-$utils =~ s/^(my %delta\s*=\s*.*?)(^\);)$/$1$utilities_in_release$2/ism;
-
-write_corelist($utils,$utils_file);
-
-warn "All done. Please check over the following files carefully before committing.\nThanks!\n";
-warn "$corelist_file\n$utils_file\n";
-
-sub write_corelist {
- my $content = shift;
- my $filename = shift;
- open (my $clfh, ">", $filename);
- binmode $clfh;
- print $clfh $content;
- close($clfh);
-}
-
-sub fetch_url {
- my $url = shift;
- my $http = HTTP::Tiny->new;
- my $response = $http->get($url);
- if ($response->{success}) {
- return $response->{content};
- } else {
- warn "Error fetching $url: $response->{status} $response->{reason}\n";
- return;
- }
-}
-
-sub make_corelist_delta {
- my($version, $lines, $existing) = @_;
- # Trust core perl, if someone does use a weird version number the worst that
- # can happen is an extra delta entry for a module.
- my %versions = map { $_ => eval $lines->{$_} } keys %$lines;
-
- # Ensure we have the corelist data loaded from this perl checkout, not the system one.
- require $corelist_file;
-
- my %deltas;
- # Search for the release with the least amount of changes (this avoids having
- # to ask for where this perl was branched from).
- for my $previous (reverse sort keys %$existing) {
- # Shouldn't happen, but ensure we don't load weird data...
- next if $previous > $version || $previous == $version && $previous eq $version;
-
- my $delta = $deltas{$previous} = {};
- ($delta->{changed}, $delta->{removed}) = calculate_delta(
- $existing->{$previous}, \%versions);
- }
-
- my $smallest = (sort {
- ((keys($deltas{$a}->{changed}) + keys($deltas{$a}->{removed})) <=>
- (keys($deltas{$b}->{changed}) + keys($deltas{$b}->{removed}))) ||
- $b <=> $a
- } keys %deltas)[0];
-
- return {
- delta_from => $smallest,
- changed => $deltas{$smallest}{changed},
- removed => $deltas{$smallest}{removed},
- }
-}
-
-sub make_coreutils_delta {
- my($version, $lines) = @_;
- # Trust core perl, if someone does use a weird version number the worst that
- # can happen is an extra delta entry for a module.
- my %utilities = map { $_ => eval $lines->{$_} } keys %$lines;
-
- # Ensure we have the corelist data loaded from this perl checkout, not the system one.
- require $utils_file;
-
- my %deltas;
- # Search for the release with the least amount of changes (this avoids having
- # to ask for where this perl was branched from).
- for my $previous (reverse sort keys %Module::CoreList::Utils::utilities) {
- # Shouldn't happen, but ensure we don't load weird data...
- next if $previous > $version || $previous == $version && $previous eq $version;
-
- my $delta = $deltas{$previous} = {};
- ($delta->{changed}, $delta->{removed}) = calculate_delta(
- $Module::CoreList::Utils::utilities{$previous}, \%utilities);
- }
-
- my $smallest = (sort {
- ((keys($deltas{$a}->{changed}) + keys($deltas{$a}->{removed})) <=>
- (keys($deltas{$b}->{changed}) + keys($deltas{$b}->{removed}))) ||
- $b <=> $a
- } keys %deltas)[0];
-
- return {
- delta_from => $smallest,
- changed => $deltas{$smallest}{changed},
- removed => $deltas{$smallest}{removed},
- }
-}
-
-# Calculate (changed, removed) modules between two versions.
-sub calculate_delta {
- my($from, $to) = @_;
- my(%changed, %removed);
-
- for my $package(keys $from) {
- if(not exists $to->{$package}) {
- $removed{$package} = 1;
- }
- }
-
- for my $package(keys $to) {
- if(!exists $from->{$package}
- || (defined $from->{$package} && !defined $to->{$package})
- || (!defined $from->{$package} && defined $to->{$package})
- || (defined $from->{$package} && defined $to->{$package}
- && $from->{$package} ne $to->{$package})) {
- $changed{$package} = $to->{$package};
- }
- }
-
- return \%changed, \%removed;
-}
-
-sub quote {
- my ($str) = @_;
- # There's gotta be something already doing this properly that we could just
- # reuse, but I can't quite thing of where to look for it, so I'm gonna do
- # the simplest possible thing that'll allow me to release 5.17.7. --rafl
- $str =~ s/'/\\'/g;
- "'${str}'";
-}
-
-sub parse_utils_lst {
- require File::Spec::Unix;
- my @scripts;
- open my $fh, '<', 'utils.lst' or die "$!\n";
- while (<$fh>) {
- chomp;
- my ($file,$extra) = split m!#!;
- $file =~ s!\s+!!g;
- push @scripts, $file;
- $extra =~ s!\s+!!g if $extra;
- if ( $extra and my ($link) = $extra =~ m!^link=(.+?)$! ) {
- push @scripts, $link;
}
- }
- return map { +( File::Spec::Unix->splitpath( $_ ) )[-1] } @scripts;
-}
+print " $] => {\n";
+print sort keys %lines;
+print " },\n";
diff --git a/gnu/usr.bin/perl/README.symbian b/gnu/usr.bin/perl/README.symbian
index 2572631c12a..dea2fde5199 100644
--- a/gnu/usr.bin/perl/README.symbian
+++ b/gnu/usr.bin/perl/README.symbian
@@ -1,432 +1,433 @@
-If you read this file _as_is_, just ignore the funny characters you see.
-It is written in the POD format (see pod/perlpod.pod) which is specially
-designed to be readable as is.
-
-=head1 NAME
-
-perlsymbian - Perl version 5 on Symbian OS
-
-=head1 DESCRIPTION
-
-This document describes various features of the Symbian operating
-system that will affect how Perl version 5 (hereafter just Perl)
-is compiled and/or runs.
-
-B<NOTE: this port (as of 0.4.1) does not compile into a Symbian
-OS GUI application, but instead it results in a Symbian DLL.>
-The DLL includes a C++ class called CPerlBase, which one can then
-(derive from and) use to embed Perl into applications, see F<symbian/README>.
-
-The base port of Perl to Symbian only implements the basic POSIX-like
-functionality; it does not implement any further Symbian or Series 60,
-Series 80, or UIQ bindings for Perl.
-
-It is also possible to generate Symbian executables for "miniperl"
-and "perl", but since there is no standard command line interface
-for Symbian (nor full keyboards in the devices), these are useful
-mainly as demonstrations.
-
-=head2 Compiling Perl on Symbian
-
-(0) You need to have the appropriate Symbian SDK installed.
-
- These instructions have been tested under various Nokia Series 60
- Symbian SDKs (1.2 to 2.6, 2.8 should also work, 1.2 compiles but
- does not work), Series 80 2.0, and Nokia 7710 (Series 90) SDK.
- You can get the SDKs from Forum Nokia (L<http://www.forum.nokia.com/>).
- A very rough port ("it compiles") to UIQ 2.1 has also been made.
-
- A prerequisite for any of the SDKs is to install ActivePerl
- from ActiveState, L<http://www.activestate.com/Products/ActivePerl/>
-
- Having the SDK installed also means that you need to have either
- the Metrowerks CodeWarrior installed (2.8 and 3.0 were used in testing)
- or the Microsoft Visual C++ 6.0 installed (SP3 minimum, SP5 recommended).
-
- Note that for example the Series 60 2.0 VC SDK installation talks
- about ActivePerl build 518, which does no more (as of mid-2005) exist
- at the ActiveState website. The ActivePerl 5.8.4 build 810 was
- used successfully for compiling Perl on Symbian. The 5.6.x ActivePerls
- do not work.
-
- Other SDKs or compilers like Visual.NET, command-line-only
- Visual.NET, Borland, GnuPoc, or sdk2unix have not been tried.
-
- These instructions almost certainly won't work with older Symbian
- releases or other SDKs. Patches to get this port running in other
- releases, SDKs, compilers, platforms, or devices are naturally welcome.
-
-(1) Get a Perl source code distribution (for example the file
- perl-5.9.2.tar.gz is fine) from L<http://www.cpan.org/src/>
- and unpack it in your the C:/Symbian directory of your Windows
- system.
-
-(2) Change to the perl source directory.
-
- cd c:\Symbian\perl-5.x.x
-
-(3) Run the following script using the perl coming with the SDK
-
- perl symbian\config.pl
-
- You must use the cmd.exe, the Cygwin shell will not work.
- The PATH must include the SDK tools, including a Perl,
- which should be the case under cmd.exe. If you do not
- have that, see the end of symbian\sdk.pl for notes of
- how your environment should be set up for Symbian compiles.
-
-(4) Build the project, either by
-
- make all
-
- in cmd.exe or by using either the Metrowerks CodeWarrior
- or the Visual C++ 6.0, or the Visual Studio 8 (the Visual C++
- 2005 Express Edition works fine).
-
- If you use the VC IDE, you will have to run F<symbian\config.pl>
- first using the cmd.exe, and then run 'make win.mf vc6.mf' to generate
- the VC6 makefiles and workspaces. "make vc6" will compile for the VC6,
- and "make cw" for the CodeWarrior.
-
- The following SDK and compiler configurations and Nokia phones were
- tested at some point in time (+ = compiled and PerlApp run, - = not),
- both for Perl 5.8.x and 5.9.x:
-
- SDK | VC | CW |
- --------+----+----+---
- S60 1.2 | + | + | 3650 (*)
- S60 2.0 | + | + | 6600
- S60 2.1 | - | + | 6670
- S60 2.6 | + | + | 6630
- S60 2.8 | + | + | (not tested in a device)
- S80 2.6 | - | + | 9300
- S90 1.1 | + | - | 7710
- UIQ 2.1 | - | + | (not tested in a device)
-
- (*) Compiles but does not work, unfortunately, a problem with Symbian.
-
- If you are using the 'make' directly, it is the GNU make from the SDKs,
- and it will invoke the right make commands for the Windows emulator
- build and the Arm target builds ('thumb' by default) as necessary.
-
- The build scripts assume the 'absolute style' SDK installs under C:,
- the 'subst style' will not work.
-
- If using the VC IDE, to build use for example the File->Open Workspace->
- C:\Symbian\8.0a\S60_2nd_FP2\epoc32\build\symbian\perl\perl\wins\perl.dsw
- The emulator binaries will appear in the same directory.
-
- If using the VC IDE, you will a lot of warnings in the beginning of
- the build because a lot of headers mentioned by the source cannot
- be found, but this is not serious since those headers are not used.
-
- The Metrowerks will give a lot of warnings about unused variables and
- empty declarations, you can ignore those.
-
- When the Windows and Arm DLLs are built do not be scared by a very long
- messages whizzing by: it is the "export freeze" phase where the whole
- (rather large) API of Perl is listed.
-
- Once the build is completed you need to create the DLL SIS file by
-
- make perldll.sis
-
- which will create the file perlXYZ.sis (the XYZ being the Perl version)
- which you can then install into your Symbian device: an easy way
- to do this is to send them via Bluetooth or infrared and just open
- the messages.
-
- Since the total size of all Perl SIS files once installed is
- over 2 MB, it is recommended to do the installation into a
- memory card (drive E:) instead of the C: drive.
-
- The size of the perlXYZ.SIS is about 370 kB but once it is in the
- device it is about one 750 kB (according to the application manager).
-
- The perlXYZ.sis includes only the Perl DLL: to create an additional
- SIS file which includes some of the standard (pure) Perl libraries,
- issue the command
-
- make perllib.sis
-
- Some of the standard Perl libraries are included, but not all:
- see L</HISTORY> or F<symbian\install.cfg> for more details
- (250 kB -> 700 kB).
-
- Some of the standard Perl XS extensions (see L</HISTORY> are
- also available:
-
- make perlext.sis
-
- which will create perlXYZext.sis (290 kB -> 770 kB).
-
- To compile the demonstration application PerlApp you need first to
- install the Perl headers under the SDK.
-
- To install the Perl headers and the class CPerlBase documentation
- so that you no more need the Perl sources around to compile Perl
- applications using the SDK:
-
- make sdkinstall
-
- The destination directory is C:\Symbian\perl\X.Y.Z. For more
- details, see F<symbian\PerlBase.pod>.
-
- Once the headers have been installed, you can create a SIS for
- the PerlApp:
-
- make perlapp.sis
-
- The perlapp.sis (11 kB -> 16 kB) will be built in the symbian
- subdirectory, but a copy will also be made to the main directory.
-
- If you want to package the Perl DLLs (one for WINS, one for ARMI),
- the headers, and the documentation:
-
- make perlsdk.zip
-
- which will create perlXYZsdk.zip that can be used in another
- Windows system with the SDK, without having to compile Perl in
- that system.
-
- If you want to package the PerlApp sources:
-
- make perlapp.zip
-
- If you want to package the perl.exe and miniperl.exe, you
- can use the perlexe.sis and miniperlexe.sis make targets.
- You also probably want the perllib.sis for the libraries
- and maybe even the perlapp.sis for the recognizer.
-
- The make target 'allsis' combines all the above SIS targets.
-
- To clean up after compilation you can use either of
-
- make clean
- make distclean
-
- depending on how clean you want to be.
-
-=head2 Compilation problems
-
-If you see right after "make" this
-
- cat makefile.sh >makefile
- 'cat' is not recognized as an internal or external command,
- operable program or batch file.
-
-it means you need to (re)run the F<symbian\config.pl>.
-
-If you get the error
-
- 'perl' is not recognized as an internal or external command,
- operable program or batch file.
-
-you may need to reinstall the ActivePerl.
-
-If you see this
-
- ren makedef.pl nomakedef.pl
- The system cannot find the file specified.
- C:\Symbian\...\make.exe: [rename_makedef] Error 1 (ignored)
-
-please ignore it since it is nothing serious (the build process of
-renames the Perl makedef.pl as nomakedef.pl to avoid confusing it
-with a makedef.pl of the SDK).
-
-=head2 PerlApp
-
-The PerlApp application demonstrates how to embed Perl interpreters
-to a Symbian application. The "Time" menu item runs the following
-Perl code: C<print "Running in ", $^O, "\n", scalar localtime>,
-the "Oneliner" allows one to type in Perl code, and the "Run"
-opens a file chooser for selecting a Perl file to run.
-
-The PerlApp also is started when the "Perl recognizer" (also included
-and installed) detects a Perl file being activated through the GUI,
-and offers either to install it under \Perl (if the Perl file is in
-the inbox of the messaging application) or to run it (if the Perl file
-is under \Perl).
-
-=head2 sisify.pl
-
-In the symbian subdirectory there is F<sisify.pl> utility which can be used
-to package Perl scripts and/or Perl library directories into SIS files,
-which can be installed to the device. To run the sisify.pl utility,
-you will need to have the 'makesis' and 'uidcrc' utilities already
-installed. If you don't have the Win32 SDKs, you may try for example
-L<http://gnupoc.sourceforge.net/> or L<http://symbianos.org/~andreh/>.
-
-=head2 Using Perl in Symbian
-
-First of all note that you have full access to the Symbian device
-when using Perl: you can do a lot of damage to your device (like
-removing system files) unless you are careful. Please do take
-backups before doing anything.
-
-The Perl port has been done for the most part using the Symbian
-standard POSIX-ish STDLIB library. It is a reasonably complete
-library, but certain corners of such emulation libraries that tend
-to be left unimplemented on non-UNIX platforms have been left
-unimplemented also this time: fork(), signals(), user/group ids,
-select() working for sockets, non-blocking sockets, and so forth.
-See the file F<symbian/config.sh> and look for 'undef' to find the
-unsupported APIs (or from Perl use Config).
-
-The filesystem of Symbian devices uses DOSish syntax, "drives"
-separated from paths by a colon, and backslashes for the path. The
-exact assignment of the drives probably varies between platforms, but
-for example in Series 60 you might see C: as the (flash) main memory,
-D: as the RAM drive, E: as the memory card (MMC), Z: as the ROM. In
-Series 80 D: is the memory card. As far the devices go the NUL: is
-the bit bucket, the COMx: are the serial lines, IRCOMx: are the IR
-ports, TMP: might be C:\System\Temp. Remember to double those
-backslashes in doublequoted strings.
-
-The Perl DLL is installed in \System\Libs\. The Perl libraries and
-extension DLLs are installed in \System\Libs\Perl\X.Y.Z\. The PerlApp
-is installed in \System\Apps\, and the SIS also installs a couple of
-demo scripts in \Perl\ (C:\Mydocs\Perl\ on Nokia 7710).
-
-Note that the Symbian filesystem is very picky: it strongly prefers
-the \ instead of the /.
-
-When doing XS / Symbian C++ programming include first the Symbian
-headers, then any standard C/POSIX headers, then Perl headers, and finally
-any application headers.
-
-New() and Copy() are unfortunately used by both Symbian and Perl code
-so you'll have to play cpp games if you need them. PerlBase.h undefines
-the Perl definitions and redefines them as PerlNew() and PerlCopy().
-
-=head1 TO DO
-
-Lots. See F<symbian/TODO>.
-
-=head1 WARNING
-
-As of Perl Symbian port version 0.4.1 any part of Perl's standard
-regression test suite has not been run on a real Symbian device using
-the ported Perl, so innumerable bugs may lie in wait. Therefore there
-is absolutely no warranty.
-
-=head1 NOTE
-
-When creating and extending application programming interfaces (APIs)
-for Symbian or Series 60 or Series 80 or Series 90 it is suggested
-that trademarks, registered trademarks, or trade names are not used in
-the API names. Instead, developers should consider basing the API
-naming in the existing (C++, or maybe Java) public component and API
-naming, modified as appropriate by the rules of the programming
-language the new APIs are for.
-
-Nokia is a registered trademark of Nokia Corporation. Nokia's product
-names are trademarks or registered trademarks of Nokia. Other product
-and company names mentioned herein may be trademarks or trade names of
-their respective owners.
-
-=head1 AUTHOR
-
-Jarkko Hietaniemi
-
-=head1 COPYRIGHT
-
-Copyright (c) 2004-2005 Nokia. All rights reserved.
-
-Copyright (c) 2006-2007 Jarkko Hietaniemi.
-
-=head1 LICENSE
-
-The Symbian port is licensed under the same terms as Perl itself.
-
-=head1 HISTORY
-
-=over 4
-
-=item *
-
-0.1.0: April 2005
-
-(This will show as "0.01" in the Symbian Installer.)
-
- - The console window is a very simple console indeed: one can
- get the newline with "000" and the "C" button is a backspace.
- Do not expect a terminal capable of vt100 or ANSI sequences.
- The console is also "ASCII", you cannot input e.g. any accented
- letters. Because of obvious physical constraints the console is
- also very small: (in Nokia 6600) 22 columns, 17 rows.
- - The following libraries are available:
- AnyDBM_File AutoLoader base Carp Config Cwd constant
- DynaLoader Exporter File::Spec integer lib strict Symbol
- vars warnings XSLoader
- - The following extensions are available:
- attributes Compress::Zlib Cwd Data::Dumper Devel::Peek Digest::MD5 DynaLoader
- Fcntl File::Glob Filter::Util::Call IO List::Util MIME::Base64
- PerlIO::scalar PerlIO::via SDBM_File Socket Storable Time::HiRes
- - The following extensions are missing for various technical reasons:
- B ByteLoader Devel::DProf Devel::PPPort Encode GDBM_File
- I18N::Langinfo IPC::SysV NDBM_File Opcode PerlIO::encoding POSIX
- re Safe Sys::Hostname Sys::Syslog
- threads threads::shared Unicode::Normalize
- - Using MakeMaker or the Module::* to build and install modules
- is not supported.
- - Building XS other than the ones in the core is not supported.
-
-Since this is 0.something release, any future releases are almost
-guaranteed to be binary incompatible. As a sign of this the Symbian
-symbol exports are kept unfrozen and the .def files fully rebuilt
-every time.
-
-=item *
-
-0.2.0: October 2005
-
- - Perl 5.9.3 (patch level 25741)
- - Compress::Zlib and IO::Zlib supported
- - sisify.pl added
-
-We maintain the binary incompatibility.
-
-=item *
-
-0.3.0: October 2005
-
- - Perl 5.9.3 (patch level 25911)
- - Series 80 2.0 and UIQ 2.1 support
-
-We maintain the binary incompatibility.
-
-=item *
-
-0.4.0: November 2005
-
- - Perl 5.9.3 (patch level 26052)
- - adding a sample Symbian extension
-
-We maintain the binary incompatibility.
-
-=item *
-
-0.4.1: December 2006
-
- - Perl 5.9.5-to-be (patch level 30002)
- - added extensions: Compress/Raw/Zlib, Digest/SHA,
- Hash/Util, Math/BigInt/FastCalc, Text/Soundex, Time/Piece
- - port to S90 1.1 by alexander smishlajev
-
-We maintain the binary incompatibility.
-
-=item *
-
-0.4.2: March 2007
-
- - catchup with Perl 5.9.5-to-be (patch level 30812)
- - tested to build with Microsoft Visual C++ 2005 Express Edition
- (which uses Microsoft Visual C 8, instead of the old VC6),
- SDK used for testing S60_2nd_FP3 aka 8.1a
-
-We maintain the binary incompatibility.
-
-=back
-
-=cut
+If you read this file _as_is_, just ignore the funny characters you see.
+It is written in the POD format (see pod/perlpod.pod) which is specially
+designed to be readable as is.
+
+=head1 NAME
+
+README.symbian - Perl version 5 on Symbian OS
+
+=head1 DESCRIPTION
+
+This document describes various features of the Symbian operating
+system that will affect how Perl version 5 (hereafter just Perl)
+is compiled and/or runs.
+
+B<NOTE: this port (as of 0.4.1) does not compile into a Symbian
+OS GUI application, but instead it results in a Symbian DLL.>
+The DLL includes a C++ class called CPerlBase, which one can then
+(derive from and) use to embed Perl into applications, see F<symbian/README>.
+
+The base port of Perl to Symbian only implements the basic POSIX-like
+functionality; it does not implement any further Symbian or Series 60,
+Series 80, or UIQ bindings for Perl.
+
+It is also possible to generate Symbian executables for "miniperl"
+and "perl", but since there is no standard command line interface
+for Symbian (nor full keyboards in the devices), these are useful
+mainly as demonstrations.
+
+=head2 Compiling Perl on Symbian
+
+(0) You need to have the appropriate Symbian SDK installed.
+
+ These instructions have been tested under various Nokia Series 60
+ Symbian SDKs (1.2 to 2.6, 2.8 should also work, 1.2 compiles but
+ does not work), Series 80 2.0, and Nokia 7710 (Series 90) SDK.
+ You can get the SDKs from Forum Nokia (http://www.forum.nokia.com/).
+ A very rough port ("it compiles") to UIQ 2.1 has also been made.
+
+ A prerequisite for any of the SDKs is to install ActivePerl
+ from ActiveState, http://www.activestate.com/Products/ActivePerl/
+
+ Having the SDK installed also means that you need to have either
+ the Metrowerks CodeWarrior installed (2.8 and 3.0 were used in testing)
+ or the Microsoft Visual C++ 6.0 installed (SP3 minimum, SP5 recommended).
+
+ Note that for example the Series 60 2.0 VC SDK installation talks
+ about ActivePerl build 518, which does no more (as of mid-2005) exist
+ at the ActiveState website. The ActivePerl 5.8.4 build 810 was
+ used successfully for compiling Perl on Symbian. The 5.6.x ActivePerls
+ do not work.
+
+ Other SDKs or compilers like Visual.NET, command-line-only
+ Visual.NET, Borland, GnuPoc, or sdk2unix have not been tried.
+
+ These instructions almost certainly won't work with older Symbian
+ releases or other SDKs. Patches to get this port running in other
+ releases, SDKs, compilers, platforms, or devices are naturally welcome.
+
+(1) Get a Perl source code distribution (for example the file
+ perl-5.9.2.tar.gz is fine) from http://www.cpan.org/src/
+ and unpack it in your the C:/Symbian directory of your Windows
+ system.
+
+(2) Change to the perl source directory.
+
+ cd c:\Symbian\perl-5.x.x
+
+(3) Run the following script using the perl coming with the SDK
+
+ perl symbian\config.pl
+
+ You must use the cmd.exe, the Cygwin shell will not work.
+ The PATH must include the SDK tools, including a Perl,
+ which should be the case under cmd.exe. If you do not
+ have that, see the end of symbian\sdk.pl for notes of
+ how your environment should be set up for Symbian compiles.
+
+(4) Build the project, either by
+
+ make all
+
+ in cmd.exe or by using either the Metrowerks CodeWarrior
+ or the Visual C++ 6.0, or the Visual Studio 8 (the Visual C++
+ 2005 Express Edition works fine).
+
+ If you use the VC IDE, you will have to run F<symbian\config.pl>
+ first using the cmd.exe, and then run 'make win.mf vc6.mf' to generate
+ the VC6 makefiles and workspaces. "make vc6" will compile for the VC6,
+ and "make cw" for the CodeWarrior.
+
+ The following SDK and compiler configurations and Nokia phones were
+ tested at some point in time (+ = compiled and PerlApp run, - = not),
+ both for Perl 5.8.x and 5.9.x:
+
+ SDK | VC | CW |
+ --------+----+----+---
+ S60 1.2 | + | + | 3650 (*)
+ S60 2.0 | + | + | 6600
+ S60 2.1 | - | + | 6670
+ S60 2.6 | + | + | 6630
+ S60 2.8 | + | + | (not tested in a device)
+ S80 2.6 | - | + | 9300
+ S90 1.1 | + | - | 7710
+ UIQ 2.1 | - | + | (not tested in a device)
+
+ (*) Compiles but does not work, unfortunately, a problem with Symbian.
+
+ If you are using the 'make' directly, it is the GNU make from the SDKs,
+ and it will invoke the right make commands for the Windows emulator
+ build and the Arm target builds ('thumb' by default) as necessary.
+
+ The build scripts assume the 'absolute style' SDK installs under C:,
+ the 'subst style' will not work.
+
+ If using the VC IDE, to build use for example the File->Open Workspace->
+ C:\Symbian\8.0a\S60_2nd_FP2\epoc32\build\symbian\perl\perl\wins\perl.dsw
+ The emulator binaries will appear in the same directory.
+
+ If using the VC IDE, you will a lot of warnings in the beginning of
+ the build because a lot of headers mentioned by the source cannot
+ be found, but this is not serious since those headers are not used.
+
+ The Metrowerks will give a lot of warnings about unused variables and
+ empty declarations, you can ignore those.
+
+ When the Windows and Arm DLLs are built do not be scared by a very long
+ messages whizzing by: it is the "export freeze" phase where the whole
+ (rather large) API of Perl is listed.
+
+ Once the build is completed you need to create the DLL SIS file by
+
+ make perldll.sis
+
+ which will create the file perlXYZ.sis (the XYZ being the Perl version)
+ which you can then install into your Symbian device: an easy way
+ to do this is to send them via Bluetooth or infrared and just open
+ the messages.
+
+ Since the total size of all Perl SIS files once installed is
+ over 2 MB, it is recommended to do the installation into a
+ memory card (drive E:) instead of the C: drive.
+
+ The size of the perlXYZ.SIS is about 370 kB but once it is in the
+ device it is about one 750 kB (according to the application manager).
+
+ The perlXYZ.sis includes only the Perl DLL: to create an additional
+ SIS file which includes some of the standard (pure) Perl libraries,
+ issue the command
+
+ make perllib.sis
+
+ Some of the standard Perl libraries are included, but not all:
+ see L</HISTORY> or F<symbian\install.cfg> for more details
+ (250 kB -> 700 kB).
+
+ Some of the standard Perl XS extensions (see L</HISTORY> are
+ also available:
+
+ make perlext.sis
+
+ which will create perlXYZext.sis (290 kB -> 770 kB).
+
+ To compile the demonstration application PerlApp you need first to
+ install the Perl headers under the SDK.
+
+ To install the Perl headers and the class CPerlBase documentation
+ so that you no more need the Perl sources around to compile Perl
+ applications using the SDK:
+
+ make sdkinstall
+
+ The destination directory is C:\Symbian\perl\X.Y.Z. For more
+ details, see F<symbian\PerlBase.pod>.
+
+ Once the headers have been installed, you can create a SIS for
+ the PerlApp:
+
+ make perlapp.sis
+
+ The perlapp.sis (11 kB -> 16 kB) will be built in the symbian
+ subdirectory, but a copy will also be made to the main directory.
+
+ If you want to package the Perl DLLs (one for WINS, one for ARMI),
+ the headers, and the documentation:
+
+ make perlsdk.zip
+
+ which will create perlXYZsdk.zip that can be used in another
+ Windows system with the SDK, without having to compile Perl in
+ that system.
+
+ If you want to package the PerlApp sources:
+
+ make perlapp.zip
+
+ If you want to package the perl.exe and miniperl.exe, you
+ can use the perlexe.sis and miniperlexe.sis make targets.
+ You also probably want the perllib.sis for the libraries
+ and maybe even the perlapp.sis for the recognizer.
+
+ The make target 'allsis' combines all the above SIS targets.
+
+ To clean up after compilation you can use either of
+
+ make clean
+ make distclean
+
+ depending on how clean you want to be.
+
+=head2 Compilation problems
+
+If you see right after "make" this
+
+ cat makefile.sh >makefile
+ 'cat' is not recognized as an internal or external command,
+ operable program or batch file.
+
+it means you need to (re)run the symbian\config.pl.
+
+If you get the error
+
+ 'perl' is not recognized as an internal or external command,
+ operable program or batch file.
+
+you may need to reinstall the ActivePerl.
+
+If you see this
+
+ ren makedef.pl nomakedef.pl
+ The system cannot find the file specified.
+ C:\Symbian\...\make.exe: [rename_makedef] Error 1 (ignored)
+
+please ignore it since it is nothing serious (the build process of
+renames the Perl makedef.pl as nomakedef.pl to avoid confusing it
+with a makedef.pl of the SDK).
+
+=head2 PerlApp
+
+The PerlApp application demonstrates how to embed Perl interpreters
+to a Symbian application. The "Time" menu item runs the following
+Perl code: C<print "Running in ", $^O, "\n", scalar localtime>,
+the "Oneliner" allows one to type in Perl code, and the "Run"
+opens a file chooser for selecting a Perl file to run.
+
+The PerlApp also is started when the "Perl recognizer" (also included
+and installed) detects a Perl file being activated througg the GUI,
+and offers either to install it under \Perl (if the Perl file is in
+the inbox of the messaging application) or to run it (if the Perl file
+is under \Perl).
+
+=head2 sisify.pl
+
+In the symbian subdirectory there is sisify.pl utility which can be
+used to package Perl scripts and/or Perl library directories into SIS
+files, which can be installed to the device. To run the sisify.pl
+utility, you will need to have the 'makesis' and 'uidcrc' utilities
+already installed. If you don't have the Win32 SDKs, you may try
+for example http://gnupoc.sourceforge.net/ or http://symbianos.org/~andreh/.
+
+=head2 Using Perl in Symbian
+
+First of all note that you have full access to the Symbian device
+when using Perl: you can do a lot of damage to your device (like
+removing system files) unless you are careful. Please do take
+backups before doing anything.
+
+The Perl port has been done for the most part using the Symbian
+standard POSIX-ish STDLIB library. It is a reasonably complete
+library, but certain corners of such emulation libraries that tend
+to be left unimplemented on non-UNIX platforms have been left
+unimplemented also this time: fork(), signals(), user/group ids,
+select() working for sockets, non-blocking sockets, and so forth.
+See the file symbian/config.sh and look for 'undef' to find the
+unsupported APIs (or from Perl use Config).
+
+The filesystem of Symbian devices uses DOSish syntax, "drives"
+separated from paths by a colon, and backslashes for the path. The
+exact assignment of the drives probably varies between platforms, but
+for example in Series 60 you might see C: as the (flash) main memory,
+D: as the RAM drive, E: as the memory card (MMC), Z: as the ROM. In
+Series 80 D: is the memory card. As far the devices go the NUL: is
+the bit bucket, the COMx: are the serial lines, IRCOMx: are the IR
+ports, TMP: might be C:\System\Temp. Remember to double those
+backslashes in doublequoted strings.
+
+The Perl DLL is installed in \System\Libs\. The Perl libraries and
+extension DLLs are installed in \System\Libs\Perl\X.Y.Z\. The PerlApp
+is installed in \System\Apps\, and the SIS also installs a couple of
+demo scripts in \Perl\ (C:\Mydocs\Perl\ on Nokia 7710).
+
+Note that the Symbian filesystem is very picky: it strongly prefers
+the \ instead of the /.
+
+When doing XS / Symbian C++ programming include first the Symbian
+headers, then any standard C/POSIX headers, then Perl headers, and finally
+any application headers.
+
+New() and Copy() are unfortunately used by both Symbian and Perl code
+so you'll have to play cpp games if you need them. PerlBase.h undefines
+the Perl definitions and redefines them as PerlNew() and PerlCopy().
+
+=head1 TO DO
+
+Lots. See F<symbian\TODO>.
+
+=head1 WARNING
+
+As of Perl Symbian port version 0.4.1 any part of Perl's standard
+regression test suite has not been run on a real Symbian device using
+the ported Perl, so innumerable bugs may lie in wait. Therefore there
+is absolutely no warranty.
+
+=head1 NOTE
+
+When creating and extending application programming interfaces (APIs)
+for Symbian or Series 60 or Series 80 or Series 90 it is suggested
+that trademarks, registered trademarks, or trade names are not used in
+the API names. Instead, developers should consider basing the API
+naming in the existing (C++, or maybe Java) public component and API
+naming, modified as appropriate by the rules of the programming
+language the new APIs are for.
+
+Nokia is a registered trademark of Nokia Corporation. Nokia's product
+names are trademarks or registered trademarks of Nokia. Other product
+and company names mentioned herein may be trademarks or trade names of
+their respective owners.
+
+=head1 AUTHOR
+
+Jarkko Hietaniemi
+
+=head1 COPYRIGHT
+
+Copyright (c) 2004-2005 Nokia. All rights reserved.
+
+Copyright (c) 2006-2007 Jarkko Hietaniemi.
+
+=head1 LICENSE
+
+The Symbian port is licensed under the same terms as Perl itself.
+
+=head1 HISTORY
+
+=over 4
+
+=item *
+
+0.1.0: April 2005
+
+(This will show as "0.01" in the Symbian Installer.)
+
+ - The console window is a very simple console indeed: one can
+ get the newline with "000" and the "C" button is a backspace.
+ Do not expect a terminal capable of vt100 or ANSI sequences.
+ The console is also "ASCII", you cannot input e.g. any accented
+ letters. Because of obvious physical constraints the console is
+ also very small: (in Nokia 6600) 22 columns, 17 rows.
+ - The following libraries are available:
+ AnyDBM_File AutoLoader base Carp Config Cwd constant
+ DynaLoader Exporter File::Spec integer lib strict Symbol
+ vars warnings XSLoader
+ - The following extensions are available:
+ attrs Compress::Zlib Cwd Data::Dumper Devel::Peek Digest::MD5 DynaLoader
+ Fcntl File::Glob Filter::Util::Call IO List::Util MIME::Base64
+ PerlIO::scalar PerlIO::via SDBM_File Socket Storable Time::HiRes
+ - The following extensions are missing for various technical reasons:
+ B ByteLoader Devel::DProf Devel::PPPort Encode GDBM_File
+ I18N::Langinfo IPC::SysV NDBM_File Opcode PerlIO::encoding POSIX
+ re Safe Sys::Hostname Sys::Syslog
+ threads threads::shared Unicode::Normalize
+ - Using MakeMaker or the Module::* to build and install modules
+ is not supported.
+ - Building XS other than the ones in the core is not supported.
+
+Since this is 0.something release, any future releases are almost
+guaranteed to be binary incompatible. As a sign of this the Symbian
+symbol exports are kept unfrozen and the .def files fully rebuilt
+every time.
+
+=item *
+
+0.2.0: October 2005
+
+ - Perl 5.9.3 (patch level 25741)
+ - Compress::Zlib and IO::Zlib supported
+ - sisify.pl added
+
+We maintain the binary incompatibility.
+
+=item *
+
+0.3.0: October 2005
+
+ - Perl 5.9.3 (patch level 25911)
+ - Series 80 2.0 and UIQ 2.1 support
+
+We maintain the binary incompatibility.
+
+=item *
+
+0.4.0: November 2005
+
+ - Perl 5.9.3 (patch level 26052)
+ - adding a sample Symbian extension
+
+We maintain the binary incompatibility.
+
+=item *
+
+0.4.1: December 2006
+
+ - Perl 5.9.5-to-be (patch level 30002)
+ - added extensions: Compress/Raw/Zlib, Digest/SHA,
+ Hash/Util, Math/BigInt/FastCalc, Text/Soundex, Time/Piece
+ - port to S90 1.1 by alexander smishlajev
+
+We maintain the binary incompatibility.
+
+=item *
+
+0.4.2: March 2007
+
+ - catchup with Perl 5.9.5-to-be (patch level 30812)
+ - tested to build with Microsoft Visual C++ 2005 Express Edition
+ (which uses Microsoft Visual C 8, instead of the old VC6),
+ SDK used for testing S60_2nd_FP3 aka 8.1a
+
+We maintain the binary incompatibility.
+
+=back
+
+=cut
+
diff --git a/gnu/usr.bin/perl/ext/B/t/optree_misc.t b/gnu/usr.bin/perl/ext/B/t/optree_misc.t
index f327bfc036f..bcb0f2ef31a 100644
--- a/gnu/usr.bin/perl/ext/B/t/optree_misc.t
+++ b/gnu/usr.bin/perl/ext/B/t/optree_misc.t
@@ -1,7 +1,13 @@
#!perl
BEGIN {
- unshift @INC, 't';
+ if ($ENV{PERL_CORE}){
+ chdir('t') if -d 't';
+ @INC = ('.', '../lib', '../ext/B/t');
+ } else {
+ unshift @INC, 't';
+ push @INC, "../../t";
+ }
require Config;
if (($Config::Config{'extensions'} !~ /\bB\b/) ){
print "1..0 # Skip -- Perl configured without B module\n";
@@ -10,21 +16,19 @@ BEGIN {
}
use OptreeCheck;
use Config;
-plan tests => 18;
+plan tests => 2;
SKIP: {
-skip "no perlio in this build", 4 unless $Config::Config{useperlio};
+skip "no perlio in this build", 1 unless $Config::Config{useperlio};
-# The regression this was testing is that the first aelemfast, derived
+# The regression this is testing is that the first aelemfast, derived
# from a lexical array, is supposed to be a BASEOP "<0>", while the
# second, from a global, is an SVOP "<$>" or a PADOP "<#>" depending
# on threading. In buggy versions, both showed up as SVOPs/PADOPs. See
# B.xs:cc_opclass() for the relevant code.
-# All this is much simpler, now that aelemfast_lex has been broken out from
-# aelemfast
checkOptree ( name => 'OP_AELEMFAST opclass',
- code => sub { my @x; our @y; $x[127] + $y[-128]},
+ code => sub { my @x; our @y; $x[0] + $y[0]},
strip_open_hints => 1,
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# a <1> leavesub[1 ref] K/REFC,1 ->(end)
@@ -37,12 +41,12 @@ checkOptree ( name => 'OP_AELEMFAST opclass',
# 6 <;> nextstate(main 636 optree_misc.t:25) v:>,<,%,{ ->7
# 9 <2> add[t6] sK/2 ->a
# - <1> ex-aelem sK/2 ->8
-# 7 <0> aelemfast_lex[@x:634,636] sR/127 ->8
+# 7 <0> aelemfast[@x:634,636] sR* ->8
# - <0> ex-const s ->-
# - <1> ex-aelem sK/2 ->9
# - <1> ex-rv2av sKR/1 ->-
-# 8 <#> aelemfast[*y] s/128 ->9
-# - <0> ex-const s/FOLD ->-
+# 8 <#> aelemfast[*y] s ->9
+# - <0> ex-const s ->-
EOT_EOT
# a <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->a
@@ -54,59 +58,14 @@ EOT_EOT
# 6 <;> nextstate(main 636 optree_misc.t:27) v:>,<,%,{ ->7
# 9 <2> add[t4] sK/2 ->a
# - <1> ex-aelem sK/2 ->8
-# 7 <0> aelemfast_lex[@x:634,636] sR/127 ->8
+# 7 <0> aelemfast[@x:634,636] sR* ->8
# - <0> ex-const s ->-
# - <1> ex-aelem sK/2 ->9
# - <1> ex-rv2av sKR/1 ->-
-# 8 <$> aelemfast(*y) s/128 ->9
-# - <0> ex-const s/FOLD ->-
+# 8 <$> aelemfast(*y) s ->9
+# - <0> ex-const s ->-
EONT_EONT
-checkOptree ( name => 'PMOP children',
- code => sub { $foo =~ s/(a)/$1/ },
- strip_open_hints => 1,
- ( $] < 5.017002
- ? (expect => <<'EOT_EOT16', expect_nt => <<'EONT_EONT16')
-# 6 <1> leavesub[1 ref] K/REFC,1 ->(end)
-# - <@> lineseq KP ->6
-# 1 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->2
-# 3 </> subst(/"(a)"/ replstart->4) KS ->6
-# - <1> ex-rv2sv sKRM/1 ->3
-# 2 <#> gvsv[*foo] s ->3
-# 5 <|> substcont(other->3) sK/1 ->(end)
-# - <1> ex-rv2sv sK/1 ->5
-# 4 <#> gvsv[*1] s ->5
-EOT_EOT16
-# 6 <1> leavesub[1 ref] K/REFC,1 ->(end)
-# - <@> lineseq KP ->6
-# 1 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->2
-# 3 </> subst(/"(a)"/ replstart->4) KS ->6
-# - <1> ex-rv2sv sKRM/1 ->3
-# 2 <$> gvsv(*foo) s ->3
-# 5 <|> substcont(other->3) sK/1 ->(end)
-# - <1> ex-rv2sv sK/1 ->5
-# 4 <$> gvsv(*1) s ->5
-EONT_EONT16
-
- : (expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT')));
-# 5 <1> leavesub[1 ref] K/REFC,1 ->(end)
-# - <@> lineseq KP ->5
-# 1 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->2
-# 4 </> subst(/"(a)"/) KS ->5
-# - <1> ex-rv2sv sKRM/1 ->3
-# 2 <#> gvsv[*foo] s ->3
-# - <1> ex-rv2sv sK/1 ->4
-# 3 <#> gvsv[*1] s ->4
-EOT_EOT
-# 5 <1> leavesub[1 ref] K/REFC,1 ->(end)
-# - <@> lineseq KP ->5
-# 1 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->2
-# 4 </> subst(/"(a)"/) KS ->5
-# - <1> ex-rv2sv sKRM/1 ->3
-# 2 <$> gvsv(*foo) s ->3
-# - <1> ex-rv2sv sK/1 ->4
-# 3 <$> gvsv(*1) s ->4
-EONT_EONT
} #skip
@@ -118,7 +77,7 @@ my $t = <<'EOT_EOT';
# 5 <@> index[t2] sK/2 ->6
# - <0> ex-pushmark s ->3
# 3 <$> const[PV "foo"] s ->4
-# 4 <$> const[PVMG "foo"] s ->5
+# 4 <$> const[GV "foo"] s ->5
# - <1> ex-rv2sv sKRM*/1 ->7
# 6 <#> gvsv[*_] s ->7
EOT_EOT
@@ -130,321 +89,20 @@ my $nt = <<'EONT_EONT';
# 5 <@> index[t1] sK/2 ->6
# - <0> ex-pushmark s ->3
# 3 <$> const(PV "foo") s ->4
-# 4 <$> const(PVMG "foo") s ->5
+# 4 <$> const(GV "foo") s ->5
# - <1> ex-rv2sv sKRM*/1 ->7
# 6 <$> gvsv(*_) s ->7
EONT_EONT
+if ($] < 5.009) {
+ $t =~ s/GV /BM /;
+ $nt =~ s/GV /BM /;
+}
+
checkOptree ( name => 'index and PVBM',
prog => '$_ = index q(foo), q(foo)',
strip_open_hints => 1,
expect => $t, expect_nt => $nt);
-my $tmpfile = tempfile();
-open my $fh, '>', $tmpfile or die "Cannot open $tmpfile: $!";
-print $fh "no warnings;format =\n@<<<\n\$a\n@>>>\n\@b\n.";
-close $fh;
-
-checkOptree ( name => 'formats',
- bcopts => 'STDOUT',
- progfile => $tmpfile,
- strip_open_hints => 1,
- skip => ($] < 5.017003),
- expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
-# main::STDOUT (FORMAT):
-# c <1> leavewrite[1 ref] K/REFC,1 ->(end)
-# - <@> lineseq KP ->c
-# 1 <;> nextstate(main 1 -:4) v:>,<,% ->2
-# 5 <@> formline vK/2 ->6
-# 2 <0> pushmark s ->3
-# 3 <$> const[PV "@<<<\n"] s ->4
-# - <@> lineseq lK ->5
-# - <0> ex-nextstate v ->4
-# - <1> ex-rv2sv sK/1 ->-
-# 4 <#> gvsv[*a] s ->5
-# 6 <;> nextstate(main 1 -:6) v:>,<,% ->7
-# b <@> formline sK/2 ->c
-# 7 <0> pushmark s ->8
-# 8 <$> const[PV "@>>>\n"] s ->9
-# - <@> lineseq lK ->b
-# - <0> ex-nextstate v ->9
-# a <1> rv2av[t3] lK/1 ->b
-# 9 <#> gv[*b] s ->a
-EOT_EOT
-# main::STDOUT (FORMAT):
-# c <1> leavewrite[1 ref] K/REFC,1 ->(end)
-# - <@> lineseq KP ->c
-# 1 <;> nextstate(main 1 -:4) v:>,<,% ->2
-# 5 <@> formline vK/2 ->6
-# 2 <0> pushmark s ->3
-# 3 <$> const(PV "@<<<\n") s ->4
-# - <@> lineseq lK ->5
-# - <0> ex-nextstate v ->4
-# - <1> ex-rv2sv sK/1 ->-
-# 4 <$> gvsv(*a) s ->5
-# 6 <;> nextstate(main 1 -:6) v:>,<,% ->7
-# b <@> formline sK/2 ->c
-# 7 <0> pushmark s ->8
-# 8 <$> const(PV "@>>>\n") s ->9
-# - <@> lineseq lK ->b
-# - <0> ex-nextstate v ->9
-# a <1> rv2av[t3] lK/1 ->b
-# 9 <$> gv(*b) s ->a
-EONT_EONT
-
-checkOptree ( name => 'padrange',
- code => sub { my ($x,$y); @a = ($x,$y); ($x,$y) = @a },
- strip_open_hints => 1,
- skip => ($] < 5.017006),
- expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
-# f <1> leavesub[1 ref] K/REFC,1 ->(end)
-# - <@> lineseq KP ->f
-# 1 <;> nextstate(main 1 -e:1) v:>,<,% ->2
-# - <@> list vKP ->3
-# 2 <0> padrange[$x:1,2; $y:1,2] vM/LVINTRO,2 ->3
-# - <0> padsv[$x:1,2] vM/LVINTRO ->-
-# - <0> padsv[$y:1,2] vM/LVINTRO ->-
-# 3 <;> nextstate(main 2 -e:1) v:>,<,% ->4
-# 8 <2> aassign[t4] vKS ->9
-# - <1> ex-list lKP ->5
-# 4 <0> padrange[$x:1,2; $y:1,2] l/2 ->5
-# - <0> padsv[$x:1,2] l ->-
-# - <0> padsv[$y:1,2] l ->-
-# - <1> ex-list lK ->8
-# 5 <0> pushmark s ->6
-# 7 <1> rv2av[t3] lKRM*/1 ->8
-# 6 <#> gv[*a] s ->7
-# 9 <;> nextstate(main 2 -e:1) v:>,<,%,{ ->a
-# e <2> aassign[t6] KS ->f
-# - <1> ex-list lK ->d
-# a <0> pushmark s ->b
-# c <1> rv2av[t5] lK/1 ->d
-# b <#> gv[*a] s ->c
-# - <1> ex-list lKPRM* ->e
-# d <0> padrange[$x:1,2; $y:1,2] lRM/2 ->e
-# - <0> padsv[$x:1,2] lRM* ->-
-# - <0> padsv[$y:1,2] lRM* ->-
-EOT_EOT
-# f <1> leavesub[1 ref] K/REFC,1 ->(end)
-# - <@> lineseq KP ->f
-# 1 <;> nextstate(main 1 -e:1) v:>,<,% ->2
-# - <@> list vKP ->3
-# 2 <0> padrange[$x:1,2; $y:1,2] vM/LVINTRO,2 ->3
-# - <0> padsv[$x:1,2] vM/LVINTRO ->-
-# - <0> padsv[$y:1,2] vM/LVINTRO ->-
-# 3 <;> nextstate(main 2 -e:1) v:>,<,% ->4
-# 8 <2> aassign[t4] vKS ->9
-# - <1> ex-list lKP ->5
-# 4 <0> padrange[$x:1,2; $y:1,2] l/2 ->5
-# - <0> padsv[$x:1,2] l ->-
-# - <0> padsv[$y:1,2] l ->-
-# - <1> ex-list lK ->8
-# 5 <0> pushmark s ->6
-# 7 <1> rv2av[t3] lKRM*/1 ->8
-# 6 <$> gv(*a) s ->7
-# 9 <;> nextstate(main 2 -e:1) v:>,<,%,{ ->a
-# e <2> aassign[t6] KS ->f
-# - <1> ex-list lK ->d
-# a <0> pushmark s ->b
-# c <1> rv2av[t5] lK/1 ->d
-# b <$> gv(*a) s ->c
-# - <1> ex-list lKPRM* ->e
-# d <0> padrange[$x:1,2; $y:1,2] lRM/2 ->e
-# - <0> padsv[$x:1,2] lRM* ->-
-# - <0> padsv[$y:1,2] lRM* ->-
-EONT_EONT
-
-checkOptree ( name => 'padrange and @_',
- code => sub { my ($a,$b) = @_;
- my ($c,$d) = @X::_;
- package Y;
- my ($e,$f) = @_;
- },
- strip_open_hints => 1,
- skip => ($] < 5.017006),
- expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
-# d <1> leavesub[1 ref] K/REFC,1 ->(end)
-# - <@> lineseq KP ->d
-# 1 <;> nextstate(main 1 p3:1) v:>,<,% ->2
-# 3 <2> aassign[t5] vKS ->4
-# - <1> ex-list lK ->-
-# 2 <0> padrange[$a:1,4; $b:1,4] l*/LVINTRO,2 ->3
-# - <1> rv2av[t4] lK/1 ->-
-# - <#> gv[*_] s ->-
-# - <1> ex-list lKPRM* ->3
-# - <0> pushmark sRM*/LVINTRO ->-
-# - <0> padsv[$a:1,4] lRM*/LVINTRO ->-
-# - <0> padsv[$b:1,4] lRM*/LVINTRO ->-
-# 4 <;> nextstate(main 2 p3:2) v:>,<,% ->5
-# 9 <2> aassign[t10] vKS ->a
-# - <1> ex-list lK ->8
-# 5 <0> pushmark s ->6
-# 7 <1> rv2av[t9] lK/1 ->8
-# 6 <#> gv[*X::_] s ->7
-# - <1> ex-list lKPRM* ->9
-# 8 <0> padrange[$c:2,4; $d:2,4] lRM/LVINTRO,2 ->9
-# - <0> padsv[$c:2,4] lRM*/LVINTRO ->-
-# - <0> padsv[$d:2,4] lRM*/LVINTRO ->-
-# a <;> nextstate(Y 3 p3:4) v:>,<,%,{ ->b
-# c <2> aassign[t15] KS ->d
-# - <1> ex-list lK ->-
-# b <0> padrange[$e:3,4; $f:3,4] l*/LVINTRO,2 ->c
-# - <1> rv2av[t14] lK/1 ->-
-# - <#> gv[*_] s ->-
-# - <1> ex-list lKPRM* ->c
-# - <0> pushmark sRM*/LVINTRO ->-
-# - <0> padsv[$e:3,4] lRM*/LVINTRO ->-
-# - <0> padsv[$f:3,4] lRM*/LVINTRO ->-
-EOT_EOT
-# d <1> leavesub[1 ref] K/REFC,1 ->(end)
-# - <@> lineseq KP ->d
-# 1 <;> nextstate(main 1 p3:1) v:>,<,% ->2
-# 3 <2> aassign[t5] vKS ->4
-# - <1> ex-list lK ->-
-# 2 <0> padrange[$a:1,4; $b:1,4] l*/LVINTRO,2 ->3
-# - <1> rv2av[t4] lK/1 ->-
-# - <$> gv(*_) s ->-
-# - <1> ex-list lKPRM* ->3
-# - <0> pushmark sRM*/LVINTRO ->-
-# - <0> padsv[$a:1,4] lRM*/LVINTRO ->-
-# - <0> padsv[$b:1,4] lRM*/LVINTRO ->-
-# 4 <;> nextstate(main 2 p3:2) v:>,<,% ->5
-# 9 <2> aassign[t10] vKS ->a
-# - <1> ex-list lK ->8
-# 5 <0> pushmark s ->6
-# 7 <1> rv2av[t9] lK/1 ->8
-# 6 <$> gv(*X::_) s ->7
-# - <1> ex-list lKPRM* ->9
-# 8 <0> padrange[$c:2,4; $d:2,4] lRM/LVINTRO,2 ->9
-# - <0> padsv[$c:2,4] lRM*/LVINTRO ->-
-# - <0> padsv[$d:2,4] lRM*/LVINTRO ->-
-# a <;> nextstate(Y 3 p3:4) v:>,<,%,{ ->b
-# c <2> aassign[t15] KS ->d
-# - <1> ex-list lK ->-
-# b <0> padrange[$e:3,4; $f:3,4] l*/LVINTRO,2 ->c
-# - <1> rv2av[t14] lK/1 ->-
-# - <$> gv(*_) s ->-
-# - <1> ex-list lKPRM* ->c
-# - <0> pushmark sRM*/LVINTRO ->-
-# - <0> padsv[$e:3,4] lRM*/LVINTRO ->-
-# - <0> padsv[$f:3,4] lRM*/LVINTRO ->-
-EONT_EONT
-
-checkOptree ( name => 'consolidate padranges',
- code => sub { my ($a,$b); my ($c,$d); 1 },
- strip_open_hints => 1,
- skip => ($] < 5.017006),
- expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
-# 5 <1> leavesub[1 ref] K/REFC,1 ->(end)
-# - <@> lineseq KP ->5
-# 1 <;> nextstate(main 900 optree_misc.t:334) v:>,<,% ->2
-# - <@> list vKP ->-
-# 2 <0> padrange[$a:900,902; $b:900,902; $c:901,902; $d:901,902] vM/LVINTRO,4 ->3
-# - <0> padsv[$a:900,902] vM/LVINTRO ->-
-# - <0> padsv[$b:900,902] vM/LVINTRO ->-
-# - <;> nextstate(main 901 optree_misc.t:334) v:>,<,% ->-
-# - <@> list vKP ->3
-# - <0> pushmark vM/LVINTRO ->-
-# - <0> padsv[$c:901,902] vM/LVINTRO ->-
-# - <0> padsv[$d:901,902] vM/LVINTRO ->-
-# 3 <;> nextstate(main 902 optree_misc.t:334) v:>,<,%,{ ->4
-# 4 <$> const[IV 1] s ->5
-EOT_EOT
-# 5 <1> leavesub[1 ref] K/REFC,1 ->(end)
-# - <@> lineseq KP ->5
-# 1 <;> nextstate(main 900 optree_misc.t:334) v:>,<,% ->2
-# - <@> list vKP ->-
-# 2 <0> padrange[$a:900,902; $b:900,902; $c:901,902; $d:901,902] vM/LVINTRO,4 ->3
-# - <0> padsv[$a:900,902] vM/LVINTRO ->-
-# - <0> padsv[$b:900,902] vM/LVINTRO ->-
-# - <;> nextstate(main 901 optree_misc.t:334) v:>,<,% ->-
-# - <@> list vKP ->3
-# - <0> pushmark vM/LVINTRO ->-
-# - <0> padsv[$c:901,902] vM/LVINTRO ->-
-# - <0> padsv[$d:901,902] vM/LVINTRO ->-
-# 3 <;> nextstate(main 902 optree_misc.t:334) v:>,<,%,{ ->4
-# 4 <$> const(IV 1) s ->5
-EONT_EONT
-
-
-checkOptree ( name => 'consolidate padranges and singletons',
- code => sub { my ($a,$b); my $c; my ($d,$e);
- my @f; my $g; my ($h,$i); my %j; 1 },
- strip_open_hints => 1,
- skip => ($] < 5.017006),
- expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
-# 5 <1> leavesub[1 ref] K/REFC,1 ->(end)
-# - <@> lineseq KP ->5
-# 1 <;> nextstate(main 903 optree_misc.t:371) v:>,<,% ->2
-# - <@> list vKP ->-
-# 2 <0> padrange[$a:903,910; $b:903,910; $c:904,910; $d:905,910; $e:905,910; @f:906,910; $g:907,910; $h:908,910; $i:908,910; %j:909,910] vM/LVINTRO,10 ->3
-# - <0> padsv[$a:903,910] vM/LVINTRO ->-
-# - <0> padsv[$b:903,910] vM/LVINTRO ->-
-# - <;> nextstate(main 904 optree_misc.t:371) v:>,<,% ->-
-# - <0> padsv[$c:904,910] vM/LVINTRO ->-
-# - <;> nextstate(main 905 optree_misc.t:371) v:>,<,%,{ ->-
-# - <@> list vKP ->-
-# - <0> pushmark vM/LVINTRO ->-
-# - <0> padsv[$d:905,910] vM/LVINTRO ->-
-# - <0> padsv[$e:905,910] vM/LVINTRO ->-
-# - <;> nextstate(main 906 optree_misc.t:372) v:>,<,%,{ ->-
-# - <0> padav[@f:906,910] vM/LVINTRO ->-
-# - <;> nextstate(main 907 optree_misc.t:372) v:>,<,%,{ ->-
-# - <0> padsv[$g:907,910] vM/LVINTRO ->-
-# - <;> nextstate(main 908 optree_misc.t:372) v:>,<,%,{ ->-
-# - <@> list vKP ->-
-# - <0> pushmark vM/LVINTRO ->-
-# - <0> padsv[$h:908,910] vM/LVINTRO ->-
-# - <0> padsv[$i:908,910] vM/LVINTRO ->-
-# - <;> nextstate(main 909 optree_misc.t:372) v:>,<,%,{ ->-
-# - <0> padhv[%j:909,910] vM/LVINTRO ->3
-# 3 <;> nextstate(main 910 optree_misc.t:372) v:>,<,%,{ ->4
-# 4 <$> const[IV 1] s ->5
-EOT_EOT
-# 5 <1> leavesub[1 ref] K/REFC,1 ->(end)
-# - <@> lineseq KP ->5
-# 1 <;> nextstate(main 903 optree_misc.t:371) v:>,<,% ->2
-# - <@> list vKP ->-
-# 2 <0> padrange[$a:903,910; $b:903,910; $c:904,910; $d:905,910; $e:905,910; @f:906,910; $g:907,910; $h:908,910; $i:908,910; %j:909,910] vM/LVINTRO,10 ->3
-# - <0> padsv[$a:903,910] vM/LVINTRO ->-
-# - <0> padsv[$b:903,910] vM/LVINTRO ->-
-# - <;> nextstate(main 904 optree_misc.t:371) v:>,<,% ->-
-# - <0> padsv[$c:904,910] vM/LVINTRO ->-
-# - <;> nextstate(main 905 optree_misc.t:371) v:>,<,%,{ ->-
-# - <@> list vKP ->-
-# - <0> pushmark vM/LVINTRO ->-
-# - <0> padsv[$d:905,910] vM/LVINTRO ->-
-# - <0> padsv[$e:905,910] vM/LVINTRO ->-
-# - <;> nextstate(main 906 optree_misc.t:372) v:>,<,%,{ ->-
-# - <0> padav[@f:906,910] vM/LVINTRO ->-
-# - <;> nextstate(main 907 optree_misc.t:372) v:>,<,%,{ ->-
-# - <0> padsv[$g:907,910] vM/LVINTRO ->-
-# - <;> nextstate(main 908 optree_misc.t:372) v:>,<,%,{ ->-
-# - <@> list vKP ->-
-# - <0> pushmark vM/LVINTRO ->-
-# - <0> padsv[$h:908,910] vM/LVINTRO ->-
-# - <0> padsv[$i:908,910] vM/LVINTRO ->-
-# - <;> nextstate(main 909 optree_misc.t:372) v:>,<,%,{ ->-
-# - <0> padhv[%j:909,910] vM/LVINTRO ->3
-# 3 <;> nextstate(main 910 optree_misc.t:372) v:>,<,%,{ ->4
-# 4 <$> const(IV 1) s ->5
-EONT_EONT
-
-
-checkOptree ( name => 'm?x?',
- code => sub { m?x?; },
- strip_open_hints => 1,
- expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
-# 3 <1> leavesub[1 ref] K/REFC,1 ->(end)
-# - <@> lineseq KP ->3
-# 1 <;> nextstate(main 914 optree_misc.t:434) v:>,<,%,{ ->2
-# 2 </> match(/"x"/) /RTIME ->3
-EOT_EOT
-# 3 <1> leavesub[1 ref] K/REFC,1 ->(end)
-# - <@> lineseq KP ->3
-# 1 <;> nextstate(main 914 optree_misc.t:434) v:>,<,%,{ ->2
-# 2 </> match(/"x"/) /RTIME ->3
-EONT_EONT
-
+__END__
-unlink $tmpfile;
diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_symbian.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_symbian.xs
index 7f0c0d39006..b2f27321e6a 100644
--- a/gnu/usr.bin/perl/ext/DynaLoader/dl_symbian.xs
+++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_symbian.xs
@@ -78,7 +78,7 @@ void* dlopen(const char *filename, int flags) {
h = new PerlSymbianLibHandle;
if (h) {
h->error = KErrNone;
- h->symbols = (HV *)NULL;
+ h->symbols = Nullhv;
} else
error = KErrNoMemory;
}
@@ -205,7 +205,7 @@ void
dl_install_xsub(perl_name, symref, filename="$Package")
char * perl_name
void * symref
- const char * filename
+ char * filename
CODE:
ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
(void(*)(pTHX_ CV *))symref,
@@ -221,21 +221,4 @@ dl_error()
OUTPUT:
RETVAL
-#if defined(USE_ITHREADS)
-
-void
-CLONE(...)
- CODE:
- MY_CXT_CLONE;
-
- PERL_UNUSED_VAR(items);
-
- /* MY_CXT_CLONE just does a memcpy on the whole structure, so to avoid
- * using Perl variables that belong to another thread, we create our
- * own for this thread.
- */
- MY_CXT.x_dl_last_error = newSVpvn("", 0);
-
-#endif
-
# end.
diff --git a/gnu/usr.bin/perl/ext/DynaLoader/t/DynaLoader.t b/gnu/usr.bin/perl/ext/DynaLoader/t/DynaLoader.t
index ade1f8e52b9..a698a8f19c2 100644
--- a/gnu/usr.bin/perl/ext/DynaLoader/t/DynaLoader.t
+++ b/gnu/usr.bin/perl/ext/DynaLoader/t/DynaLoader.t
@@ -1,5 +1,12 @@
#!/usr/bin/perl -wT
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
+}
+
use strict;
use Config;
use Test::More;
@@ -26,42 +33,32 @@ BEGIN {
'Time::HiRes'=> q| ::is( ref Time::HiRes->can('usleep'),'CODE' ) |, # 5.7.3
);
-plan tests => 26 + keys(%modules) * 3;
+plan tests => 22 + keys(%modules) * 3;
# Try to load the module
use_ok( 'DynaLoader' );
-# Some tests need to be skipped on old Darwin versions.
-# Commit ce12ed1954 added the skip originally, without specifying which
-# darwin version needed it. I know OS X 10.6 (Snow Leopard; darwin 10)
-# supports it, so skip anything before that.
-my $old_darwin = $^O eq 'darwin' && ($Config{osvers} =~ /^(\d+)/)[0] < 10;
# Check functions
can_ok( 'DynaLoader' => 'bootstrap' ); # defined in Perl section
-can_ok( 'DynaLoader' => 'dl_load_flags' ); # defined in Perl section
can_ok( 'DynaLoader' => 'dl_error' ); # defined in XS section
-if ($Config{usedl}) {
- can_ok( 'DynaLoader' => 'dl_find_symbol' ); # defined in XS section
- can_ok( 'DynaLoader' => 'dl_install_xsub' ); # defined in XS section
- can_ok( 'DynaLoader' => 'dl_load_file' ); # defined in XS section
- can_ok( 'DynaLoader' => 'dl_undef_symbols' ); # defined in XS section
- SKIP: {
- skip "unloading unsupported on $^O", 1 if ($old_darwin || $^O eq 'VMS');
- can_ok( 'DynaLoader' => 'dl_unload_file' ); # defined in XS section
- }
-} else {
- foreach my $symbol (qw(dl_find_symbol dl_install_sub dl_load_file
- dl_undef_symbols dl_unload_file)) {
- is(DynaLoader->can($symbol), undef,
- "Without dynamic loading, DynaLoader should not have $symbol");
- }
+can_ok( 'DynaLoader' => 'dl_find_symbol' ); # defined in XS section
+can_ok( 'DynaLoader' => 'dl_install_xsub' ); # defined in XS section
+can_ok( 'DynaLoader' => 'dl_load_file' ); # defined in XS section
+can_ok( 'DynaLoader' => 'dl_load_flags' ); # defined in Perl section
+can_ok( 'DynaLoader' => 'dl_undef_symbols' ); # defined in XS section
+SKIP: {
+ skip "unloading unsupported on $^O", 1 if ($^O eq 'VMS' || $^O eq 'darwin');
+ can_ok( 'DynaLoader' => 'dl_unload_file' ); # defined in XS section
}
-can_ok( 'DynaLoader' => 'dl_expandspec' );
-can_ok( 'DynaLoader' => 'dl_findfile' );
-can_ok( 'DynaLoader' => 'dl_find_symbol_anywhere' );
+TODO: {
+local $TODO = "Test::More::can_ok() seems to have trouble dealing with AutoLoaded functions";
+can_ok( 'DynaLoader' => 'dl_expandspec' ); # defined in AutoLoaded section
+can_ok( 'DynaLoader' => 'dl_findfile' ); # defined in AutoLoaded section
+can_ok( 'DynaLoader' => 'dl_find_symbol_anywhere' ); # defined in AutoLoaded section
+}
# Check error messages
@@ -71,24 +68,16 @@ like( $@, q{/^Usage: DynaLoader::bootstrap\(module\)/},
"calling DynaLoader::bootstrap() with no argument" );
eval { package egg_bacon_sausage_and_spam; DynaLoader::bootstrap("egg_bacon_sausage_and_spam") };
-if ($Config{usedl}) {
- like( $@, q{/^Can't locate loadable object for module egg_bacon_sausage_and_spam/},
- "calling DynaLoader::bootstrap() with a package without binary object" );
-} else {
- like( $@, q{/^Can't load module egg_bacon_sausage_and_spam/},
+like( $@, q{/^Can't locate loadable object for module egg_bacon_sausage_and_spam/},
"calling DynaLoader::bootstrap() with a package without binary object" );
-}
# .. for dl_load_file()
-SKIP: {
- skip "no dl_load_file with dl_none.xs", 2 unless $Config{usedl};
- eval { DynaLoader::dl_load_file() };
- like( $@, q{/^Usage: DynaLoader::dl_load_file\(filename, flags=0\)/},
- "calling DynaLoader::dl_load_file() with no argument" );
+eval { DynaLoader::dl_load_file() };
+like( $@, q{/^Usage: DynaLoader::dl_load_file\(filename, flags=0\)/},
+ "calling DynaLoader::dl_load_file() with no argument" );
- eval { no warnings 'uninitialized'; DynaLoader::dl_load_file(undef) };
- is( $@, '', "calling DynaLoader::dl_load_file() with undefined argument" ); # is this expected ?
-}
+eval { no warnings 'uninitialized'; DynaLoader::dl_load_file(undef) };
+is( $@, '', "calling DynaLoader::dl_load_file() with undefined argument" ); # is this expected ?
my ($dlhandle, $dlerr);
eval { $dlhandle = DynaLoader::dl_load_file("egg_bacon_sausage_and_spam") };
@@ -112,13 +101,11 @@ SKIP: {
# (not at least by that name) that the dl_findfile()
# could find.
skip "dl_findfile test not appropriate on $^O", 1
- if $^O =~ /(win32|vms|openbsd|bitrig|cygwin|vos)/i;
+ if $^O =~ /(win32|vms|openbsd|cygwin)/i;
# Play safe and only try this test if this system
# looks pretty much Unix-like.
skip "dl_findfile test not appropriate on $^O", 1
unless -d '/usr' && -f '/bin/ls';
- skip "dl_findfile test not always appropriate when cross-compiling", 1
- if $Config{usecrosscompile};
cmp_ok( scalar @files, '>=', 1, "array should contain one result result or more: libc => (@files)" );
}
@@ -143,46 +130,12 @@ is( scalar @DynaLoader::dl_modules, scalar keys %modules, "checking number of it
my @loaded_modules = @DynaLoader::dl_modules;
for my $libref (reverse @DynaLoader::dl_librefs) {
- TODO: {
- todo_skip "Can't safely unload with -DPERL_GLOBAL_STRUCT_PRIVATE (RT #119409)", 2
- if $Config{ccflags} =~ /(?:^|\s)-DPERL_GLOBAL_STRUCT_PRIVATE\b/;
- SKIP: {
- skip "unloading unsupported on $^O", 2
- if ($old_darwin || $^O eq 'VMS');
- my $module = pop @loaded_modules;
- skip "File::Glob sets PL_opfreehook", 2 if $module eq 'File::Glob';
- my $r = eval { DynaLoader::dl_unload_file($libref) };
- is( $@, '', "calling dl_unload_file() for $module" );
- is( $r, 1, " - unload was successful" );
- }
- }
+ SKIP: {
+ skip "unloading unsupported on $^O", 2 if ($^O eq 'VMS' || $^O eq 'darwin');
+ my $module = pop @loaded_modules;
+ my $r = eval { DynaLoader::dl_unload_file($libref) };
+ is( $@, '', "calling dl_unload_file() for $module" );
+ is( $r, 1, " - unload was successful" );
+ }
}
-SKIP: {
- skip "mod2fname not defined on this platform", 4
- unless defined &DynaLoader::mod2fname && $Config{d_libname_unique};
-
- is(
- DynaLoader::mod2fname(["Hash", "Util"]),
- "PL_Hash__Util",
- "mod2fname + libname_unique works"
- );
-
- is(
- DynaLoader::mod2fname([("Hash", "Util") x 25]),
- "PL_" . join("_", ("Hash", "Util")x25),
- "mod2fname + libname_unique collapses double __'s for long names"
- );
-
- is(
- DynaLoader::mod2fname([("Haash", "Uttil") x 25]),
- "PL_" . join("_", ("HAsh", "UTil")x25),
- "mod2fname + libname_unique collapses repeated characters for long names"
- );
-
- is(
- DynaLoader::mod2fname([("Hash", "Util")x30]),
- substr(("PL_" . join("_", ("Hash", "Util")x30)), 0, 255 - (length($Config::Config{dlext})+1)),
- "mod2fname + libname_unique correctly truncates long names"
- );
-}
diff --git a/gnu/usr.bin/perl/ext/POSIX/t/math.t b/gnu/usr.bin/perl/ext/POSIX/t/math.t
index bf0c2decc4a..29236898cad 100644
--- a/gnu/usr.bin/perl/ext/POSIX/t/math.t
+++ b/gnu/usr.bin/perl/ext/POSIX/t/math.t
@@ -3,37 +3,17 @@
use strict;
use POSIX;
-use Test::More;
+use Test::More tests => 14;
-# These tests are mainly to make sure that these arithmetic functions
+# These tests are mainly to make sure that these arithmatic functions
# exist and are accessible. They are not meant to be an exhaustive
# test for the interface.
-sub between {
- my ($low, $have, $high, $desc) = @_;
- local $Test::Builder::Level = $Test::Builder::Level + 1;
-
- cmp_ok($have, '>=', $low, $desc);
- cmp_ok($have, '<=', $high, $desc);
-}
-
is(acos(1), 0, "Basic acos(1) test");
-between(3.14, acos(-1), 3.15, 'acos(-1)');
-between(1.57, acos(0), 1.58, 'acos(0)');
is(asin(0), 0, "Basic asin(0) test");
-cmp_ok(asin(1), '>', 1.57, "Basic asin(1) test");
-cmp_ok(asin(-1), '<', -1.57, "Basic asin(-1) test");
-cmp_ok(asin(1), '==', -asin(-1), 'asin(1) == -asin(-1)');
is(atan(0), 0, "Basic atan(0) test");
-between(0.785, atan(1), 0.786, 'atan(1)');
-between(-0.786, atan(-1), -0.785, 'atan(-1)');
-cmp_ok(atan(1), '==', -atan(-1), 'atan(1) == -atan(-1)');
is(cosh(0), 1, "Basic cosh(0) test");
-between(1.54, cosh(1), 1.55, 'cosh(1)');
-between(1.54, cosh(-1), 1.55, 'cosh(-1)');
-is(cosh(1), cosh(-1), 'cosh(1) == cosh(-1)');
is(floor(1.23441242), 1, "Basic floor(1.23441242) test");
-is(floor(-1.23441242), -2, "Basic floor(-1.23441242) test");
is(fmod(3.5, 2.0), 1.5, "Basic fmod(3.5, 2.0) test");
is(join(" ", frexp(1)), "0.5 1", "Basic frexp(1) test");
is(ldexp(0,1), 0, "Basic ldexp(0,1) test");
@@ -41,15 +21,5 @@ is(log10(1), 0, "Basic log10(1) test");
is(log10(10), 1, "Basic log10(10) test");
is(join(" ", modf(1.76)), "0.76 1", "Basic modf(1.76) test");
is(sinh(0), 0, "Basic sinh(0) test");
-between(1.17, sinh(1), 1.18, 'sinh(1)');
-between(-1.18, sinh(-1), -1.17, 'sinh(-1)');
is(tan(0), 0, "Basic tan(0) test");
-between(1.55, tan(1), 1.56, 'tan(1)');
-between(1.55, tan(1), 1.56, 'tan(-1)');
-cmp_ok(tan(1), '==', -tan(-1), 'tan(1) == -tan(-1)');
is(tanh(0), 0, "Basic tanh(0) test");
-between(0.76, tanh(1), 0.77, 'tanh(1)');
-between(-0.77, tanh(-1), -0.76, 'tanh(-1)');
-cmp_ok(tanh(1), '==', -tanh(-1), 'tanh(1) == -tanh(-1)');
-
-done_testing();
diff --git a/gnu/usr.bin/perl/ext/POSIX/t/time.t b/gnu/usr.bin/perl/ext/POSIX/t/time.t
index 472624f3e05..103a1619630 100644
--- a/gnu/usr.bin/perl/ext/POSIX/t/time.t
+++ b/gnu/usr.bin/perl/ext/POSIX/t/time.t
@@ -4,7 +4,7 @@ use strict;
use Config;
use POSIX;
-use Test::More tests => 19;
+use Test::More tests => 9;
# go to UTC to avoid DST issues around the world when testing. SUS3 says that
# null should get you UTC, but some environments want the explicit names.
@@ -28,59 +28,24 @@ SKIP: {
}
}
-if ($^O eq "hpux" && $Config{osvers} >= 11.3) {
- # HP does not support UTC0UTC and/or GMT0GMT, as they state that this is
- # legal syntax but as it has no DST rule, it cannot be used. That is the
- # conclusion of bug
- # QXCR1000896916: Some timezone valuesfailing on 11.31 that work on 11.23
- $ENV{TZ} = "UTC";
-}
-
# asctime and ctime...Let's stay below INT_MAX for 32-bits and
# positive for some picky systems.
-is(asctime(CORE::localtime(0)), ctime(0), "asctime() and ctime() at zero");
-is(asctime(POSIX::localtime(0)), ctime(0), "asctime() and ctime() at zero");
-is(asctime(CORE::localtime(12345678)), ctime(12345678),
- "asctime() and ctime() at 12345678");
-is(asctime(POSIX::localtime(12345678)), ctime(12345678),
- "asctime() and ctime() at 12345678");
+is(asctime(localtime(0)), ctime(0), "asctime() and ctime() at zero");
+is(asctime(localtime(12345678)), ctime(12345678), "asctime() and ctime() at 12345678");
-# Careful! strftime() is locale sensitive. Let's take care of that
-my $orig_loc = 'C';
-if ( $Config{d_setlocale} ) {
- $orig_loc = setlocale(LC_TIME) || die "Cannot get locale information: $!";
- setlocale(LC_TIME, "C") || die "Cannot setlocale() to C: $!";
-}
+# Careful! strftime() is locale sensative. Let's take care of that
+my $orig_loc = setlocale(LC_TIME, "C") || die "Cannot setlocale() to C: $!";
my $jan_16 = 15 * 86400;
-is(ctime($jan_16), strftime("%a %b %d %H:%M:%S %Y\n", CORE::localtime($jan_16)),
- "get ctime() equal to strftime()");
-is(ctime($jan_16), strftime("%a %b %d %H:%M:%S %Y\n", POSIX::localtime($jan_16)),
+is(ctime($jan_16), strftime("%a %b %d %H:%M:%S %Y\n", localtime($jan_16)),
"get ctime() equal to strftime()");
-is(strftime("%Y\x{5e74}%m\x{6708}%d\x{65e5}", CORE::gmtime($jan_16)),
- "1970\x{5e74}01\x{6708}16\x{65e5}",
- "strftime() can handle unicode chars in the format string");
-is(strftime("%Y\x{5e74}%m\x{6708}%d\x{65e5}", POSIX::gmtime($jan_16)),
- "1970\x{5e74}01\x{6708}16\x{65e5}",
- "strftime() can handle unicode chars in the format string");
-
-my $ss = chr 223;
-unlike($ss, qr/\w/, 'Not internally UTF-8 encoded');
-is(ord strftime($ss, CORE::localtime), 223,
- 'Format string has correct character');
-is(ord strftime($ss, POSIX::localtime(time)),
- 223, 'Format string has correct character');
-unlike($ss, qr/\w/, 'Still not internally UTF-8 encoded');
-
-if ( $Config{d_setlocale} ) {
- setlocale(LC_TIME, $orig_loc) || die "Cannot setlocale() back to orig: $!";
-}
+setlocale(LC_TIME, $orig_loc) || die "Cannot setlocale() back to orig: $!";
# clock() seems to have different definitions of what it does between POSIX
# and BSD. Cygwin, Win32, and Linux lean the BSD way. So, the tests just
# check the basics.
like(clock(), qr/\d*/, "clock() returns a numeric value");
-cmp_ok(clock(), '>=', 0, "...and it returns something >= 0");
+ok(clock() >= 0, "...and it returns something >= 0");
SKIP: {
skip "No difftime()", 1 if $Config{d_difftime} ne 'define';
@@ -88,8 +53,7 @@ SKIP: {
}
SKIP: {
- skip "No mktime()", 2 if $Config{d_mktime} ne 'define';
+ skip "No mktime()", 1 if $Config{d_mktime} ne 'define';
my $time = time();
- is(mktime(CORE::localtime($time)), $time, "mktime()");
- is(mktime(POSIX::localtime($time)), $time, "mktime()");
+ is(mktime(localtime($time)), $time, "mktime()");
}
diff --git a/gnu/usr.bin/perl/ext/Win32CORE/Win32CORE.c b/gnu/usr.bin/perl/ext/Win32CORE/Win32CORE.c
index 91759e8082d..7769c7464df 100644
--- a/gnu/usr.bin/perl/ext/Win32CORE/Win32CORE.c
+++ b/gnu/usr.bin/perl/ext/Win32CORE/Win32CORE.c
@@ -10,44 +10,59 @@
#define WIN32_LEAN_AND_MEAN
#include <windows.h>
-#if defined(__CYGWIN__) && !defined(USEIMPORTLIB)
- #undef WIN32
-#endif
-#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
-#if defined(__CYGWIN__) && !defined(USEIMPORTLIB)
- #define EXTCONST extern const
-#endif
#include "perl.h"
#include "XSUB.h"
-
-XS(w32_CORE_all){
- /* I'd use dSAVE_ERRNO() here, but it doesn't save the Win32 error code
- * under cygwin, if that changes this code should change to use that.
- */
- int saved_errno = errno;
+static void
+forward(pTHX_ const char *function)
+{
+ dXSARGS;
DWORD err = GetLastError();
- /* capture the XSANY value before Perl_load_module, the CV's any member will
- * be overwritten by Perl_load_module and subsequent newXSes or pure perl
- * subs
- */
- const char *function = (const char *) XSANY.any_ptr;
Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("Win32",5), newSVnv(0.27));
SetLastError(err);
- errno = saved_errno;
- /* mark and SP from caller are passed through unchanged */
+ SPAGAIN;
+ PUSHMARK(SP-items);
call_pv(function, GIMME_V);
}
-XS_EXTERNAL(boot_Win32CORE)
+#define FORWARD(function) XS(w32_##function){ forward(aTHX_ "Win32::"#function); }
+FORWARD(GetCwd)
+FORWARD(SetCwd)
+FORWARD(GetNextAvailDrive)
+FORWARD(GetLastError)
+FORWARD(SetLastError)
+FORWARD(LoginName)
+FORWARD(NodeName)
+FORWARD(DomainName)
+FORWARD(FsType)
+FORWARD(GetOSVersion)
+FORWARD(IsWinNT)
+FORWARD(IsWin95)
+FORWARD(FormatMessage)
+FORWARD(Spawn)
+FORWARD(GetTickCount)
+FORWARD(GetShortPathName)
+FORWARD(GetFullPathName)
+FORWARD(GetLongPathName)
+FORWARD(CopyFile)
+FORWARD(Sleep)
+
+/* Don't forward Win32::SetChildShowWindow(). It accesses the internal variable
+ * w32_showwindow in thread_intern and is therefore not implemented in Win32.xs.
+ */
+/* FORWARD(SetChildShowWindow) */
+
+#undef FORWARD
+
+XS(boot_Win32CORE)
{
/* This function only exists because writemain.SH, lib/ExtUtils/Embed.pm
* and win32/buildext.pl will all generate references to it. The function
* should never be called though, as Win32CORE.pm doesn't use DynaLoader.
*/
}
-#if !defined(__CYGWIN__) || defined(USEIMPORTLIB)
+#ifdef __CYGWIN__
__declspec(dllexport)
#endif
void
@@ -57,84 +72,27 @@ init_Win32CORE(pTHX)
* is not yet fully initialized, so don't do anything fancy in here.
*/
- static const struct {
- char Win32__GetCwd [sizeof("Win32::GetCwd")];
- char Win32__SetCwd [sizeof("Win32::SetCwd")];
- char Win32__GetNextAvailDrive [sizeof("Win32::GetNextAvailDrive")];
- char Win32__GetLastError [sizeof("Win32::GetLastError")];
- char Win32__SetLastError [sizeof("Win32::SetLastError")];
- char Win32__LoginName [sizeof("Win32::LoginName")];
- char Win32__NodeName [sizeof("Win32::NodeName")];
- char Win32__DomainName [sizeof("Win32::DomainName")];
- char Win32__FsType [sizeof("Win32::FsType")];
- char Win32__GetOSVersion [sizeof("Win32::GetOSVersion")];
- char Win32__IsWinNT [sizeof("Win32::IsWinNT")];
- char Win32__IsWin95 [sizeof("Win32::IsWin95")];
- char Win32__FormatMessage [sizeof("Win32::FormatMessage")];
- char Win32__Spawn [sizeof("Win32::Spawn")];
- char Win32__GetTickCount [sizeof("Win32::GetTickCount")];
- char Win32__GetShortPathName [sizeof("Win32::GetShortPathName")];
- char Win32__GetFullPathName [sizeof("Win32::GetFullPathName")];
- char Win32__GetLongPathName [sizeof("Win32::GetLongPathName")];
- char Win32__CopyFile [sizeof("Win32::CopyFile")];
- char Win32__Sleep [sizeof("Win32::Sleep")];
- } fnname_table = {
- "Win32::GetCwd",
- "Win32::SetCwd",
- "Win32::GetNextAvailDrive",
- "Win32::GetLastError",
- "Win32::SetLastError",
- "Win32::LoginName",
- "Win32::NodeName",
- "Win32::DomainName",
- "Win32::FsType",
- "Win32::GetOSVersion",
- "Win32::IsWinNT",
- "Win32::IsWin95",
- "Win32::FormatMessage",
- "Win32::Spawn",
- "Win32::GetTickCount",
- "Win32::GetShortPathName",
- "Win32::GetFullPathName",
- "Win32::GetLongPathName",
- "Win32::CopyFile",
- "Win32::Sleep"
- };
+ char *file = __FILE__;
- static const unsigned char fnname_lens [] = {
- sizeof("Win32::GetCwd"),
- sizeof("Win32::SetCwd"),
- sizeof("Win32::GetNextAvailDrive"),
- sizeof("Win32::GetLastError"),
- sizeof("Win32::SetLastError"),
- sizeof("Win32::LoginName"),
- sizeof("Win32::NodeName"),
- sizeof("Win32::DomainName"),
- sizeof("Win32::FsType"),
- sizeof("Win32::GetOSVersion"),
- sizeof("Win32::IsWinNT"),
- sizeof("Win32::IsWin95"),
- sizeof("Win32::FormatMessage"),
- sizeof("Win32::Spawn"),
- sizeof("Win32::GetTickCount"),
- sizeof("Win32::GetShortPathName"),
- sizeof("Win32::GetFullPathName"),
- sizeof("Win32::GetLongPathName"),
- sizeof("Win32::CopyFile"),
- sizeof("Win32::Sleep")
- };
- const unsigned char * len = (const unsigned char *)&fnname_lens;
- const char * function = (char *)&fnname_table;
- while (function < (char *)&fnname_table + sizeof(fnname_table)) {
- const char * const file = __FILE__;
- CV * const cv = newXS(function, w32_CORE_all, file);
- XSANY.any_ptr = (void *)function;
- function += *len++;
- }
-
-
- /* Don't forward Win32::SetChildShowWindow(). It accesses the internal variable
- * w32_showwindow in thread_intern and is therefore not implemented in Win32.xs.
- */
+ newXS("Win32::GetCwd", w32_GetCwd, file);
+ newXS("Win32::SetCwd", w32_SetCwd, file);
+ newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
+ newXS("Win32::GetLastError", w32_GetLastError, file);
+ newXS("Win32::SetLastError", w32_SetLastError, file);
+ newXS("Win32::LoginName", w32_LoginName, file);
+ newXS("Win32::NodeName", w32_NodeName, file);
+ newXS("Win32::DomainName", w32_DomainName, file);
+ newXS("Win32::FsType", w32_FsType, file);
+ newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
+ newXS("Win32::IsWinNT", w32_IsWinNT, file);
+ newXS("Win32::IsWin95", w32_IsWin95, file);
+ newXS("Win32::FormatMessage", w32_FormatMessage, file);
+ newXS("Win32::Spawn", w32_Spawn, file);
+ newXS("Win32::GetTickCount", w32_GetTickCount, file);
+ newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
+ newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
+ newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
+ newXS("Win32::CopyFile", w32_CopyFile, file);
+ newXS("Win32::Sleep", w32_Sleep, file);
/* newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file); */
}
diff --git a/gnu/usr.bin/perl/ext/re/re_top.h b/gnu/usr.bin/perl/ext/re/re_top.h
index e73550f9a86..6eb02e33684 100644
--- a/gnu/usr.bin/perl/ext/re/re_top.h
+++ b/gnu/usr.bin/perl/ext/re/re_top.h
@@ -13,7 +13,6 @@
#define Perl_regprop my_regprop
#define Perl_re_intuit_start my_re_intuit_start
#define Perl_re_compile my_re_compile
-#define Perl_re_op_compile my_re_op_compile
#define Perl_regfree_internal my_regfree
#define Perl_re_intuit_string my_re_intuit_string
#define Perl_regdupe_internal my_regdupe
@@ -36,8 +35,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: nil
+ * indent-tabs-mode: t
* End:
*
- * ex: set ts=8 sts=4 sw=4 et:
+ * ex: set ts=8 sts=4 sw=4 noet:
*/
diff --git a/gnu/usr.bin/perl/ext/re/t/lexical_debug.t b/gnu/usr.bin/perl/ext/re/t/lexical_debug.t
index d4b7e629109..3c3f7ba316e 100644
--- a/gnu/usr.bin/perl/ext/re/t/lexical_debug.t
+++ b/gnu/usr.bin/perl/ext/re/t/lexical_debug.t
@@ -1,6 +1,8 @@
#!./perl
BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
require Config;
if (($Config::Config{'extensions'} !~ /\bre\b/) ){
print "1..0 # Skip -- Perl configured without re module\n";
@@ -12,8 +14,8 @@ use strict;
# must use a BEGIN or the prototypes wont be respected meaning
# tests could pass that shouldn't
-BEGIN { require "../../t/test.pl"; }
-my $out = runperl(progfile => "t/lexical_debug.pl", stderr => 1 );
+BEGIN { require "./test.pl"; }
+my $out = runperl(progfile => "../ext/re/t/lexical_debug.pl", stderr => 1 );
print "1..10\n";
diff --git a/gnu/usr.bin/perl/ext/re/t/regop.pl b/gnu/usr.bin/perl/ext/re/t/regop.pl
index 961af390c3c..89693352208 100644
--- a/gnu/usr.bin/perl/ext/re/t/regop.pl
+++ b/gnu/usr.bin/perl/ext/re/t/regop.pl
@@ -7,7 +7,6 @@ my @tests=(
'D:\\dev/perl/ver/28321_/perl.exe'=>
'/(\\.COM|\\.EXE|\\.BAT|\\.CMD|\\.VBS|\\.VBE|\\.JS|\\.JSE|\\.WSF|\\.WSH|\\.pyo|\\.pyc|\\.pyw|\\.py)$/i',
'q'=>'[q]',
- "path_sep:\t8490" => '^(\\S{1,9}):\\s*(\\d+)$'
);
while (@tests) {
my ($str,$pat)=splice @tests,0,2;
diff --git a/gnu/usr.bin/perl/generate_uudmap.c b/gnu/usr.bin/perl/generate_uudmap.c
index b6307c09cf7..664333ef302 100644
--- a/gnu/usr.bin/perl/generate_uudmap.c
+++ b/gnu/usr.bin/perl/generate_uudmap.c
@@ -1,98 +1,5 @@
-/* Originally this program just generated uudmap.h
- However, when we later wanted to generate bitcount.h, it was easier to
- refactor it and keep the same name, than either alternative - rename it,
- or duplicate all of the Makefile logic for a second program. */
-
#include <stdio.h>
#include <stdlib.h>
-/* If it turns out that we need to make this conditional on config.sh derived
- values, it might be easier just to rip out the use of strerrer(). */
-#include <string.h>
-/* If a platform doesn't support errno.h, it's probably so strange that
- "hello world" won't port easily to it. */
-#include <errno.h>
-
-struct mg_data_raw_t {
- unsigned char type;
- const char *value;
- const char *comment;
-};
-
-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);
-}
-
-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++;
- if (count) {
- fputs(", ", out);
- if (!(count & 15)) {
- fputs("\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));
- exit(1);
- }
-}
-
static const char PL_uuemap[]
= "`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
@@ -101,52 +8,36 @@ typedef unsigned char U8;
/* This will ensure it is all zeros. */
static char PL_uudmap[256];
-static char PL_bitcount[256];
-int main(int argc, char **argv) {
+int main() {
size_t i;
- int bits;
- struct mg_data_raw_t *p = mg_data_raw;
-
- 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;
- }
+ char *p;
for (i = 0; i < sizeof(PL_uuemap) - 1; ++i)
- PL_uudmap[(U8)PL_uuemap[i]] = (char)i;
+ PL_uudmap[(U8)PL_uuemap[i]] = i;
/*
* Because ' ' and '`' map to the same value,
* we need to decode them both the same.
*/
PL_uudmap[(U8)' '] = 0;
- 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]++;
- if (bits & 2) PL_bitcount[bits]++;
- if (bits & 4) PL_bitcount[bits]++;
- if (bits & 8) PL_bitcount[bits]++;
- if (bits & 16) PL_bitcount[bits]++;
- if (bits & 32) PL_bitcount[bits]++;
- if (bits & 64) PL_bitcount[bits]++;
- if (bits & 128) PL_bitcount[bits]++;
- }
-
- 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;
+ i = sizeof(PL_uudmap);
+ p = PL_uudmap;
+
+ fputs("{\n ", stdout);
+ while (i--) {
+ printf("%d", *p);
+ p++;
+ if (i) {
+ fputs(", ", stdout);
+ if (!(i & 15)) {
+ fputs("\n ", stdout);
+ }
+ }
}
-
- output_to_file(argv[0], argv[3], &format_mg_data,
- (const void *)mg_data, sizeof(mg_data)/sizeof(mg_data[0]));
+ puts("\n}");
return 0;
}
+
+
diff --git a/gnu/usr.bin/perl/lib/feature.pm b/gnu/usr.bin/perl/lib/feature.pm
index dfcff96cc08..5990b727c8a 100644
--- a/gnu/usr.bin/perl/lib/feature.pm
+++ b/gnu/usr.bin/perl/lib/feature.pm
@@ -1,91 +1,55 @@
-# -*- buffer-read-only: t -*-
-# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
-# This file is built by regen/feature.pl.
-# Any changes made here will be lost!
-
package feature;
-our $VERSION = '1.36_01';
-
-our %feature = (
- fc => 'feature_fc',
- say => 'feature_say',
- state => 'feature_state',
- switch => 'feature_switch',
- evalbytes => 'feature_evalbytes',
- postderef => 'feature_postderef',
- array_base => 'feature_arybase',
- signatures => 'feature_signatures',
- current_sub => 'feature___SUB__',
- lexical_subs => 'feature_lexsubs',
- postderef_qq => 'feature_postderef_qq',
- unicode_eval => 'feature_unieval',
- unicode_strings => 'feature_unicode',
+our $VERSION = '1.11';
+
+# (feature name) => (internal name, used in %^H)
+my %feature = (
+ switch => 'feature_switch',
+ say => "feature_say",
+ state => "feature_state",
);
-our %feature_bundle = (
- "5.10" => [qw(array_base say state switch)],
- "5.11" => [qw(array_base say state switch unicode_strings)],
- "5.15" => [qw(current_sub evalbytes fc say state switch unicode_eval unicode_strings)],
- "all" => [qw(array_base current_sub evalbytes fc lexical_subs postderef postderef_qq say signatures state switch unicode_eval unicode_strings)],
- "default" => [qw(array_base)],
+my %feature_bundle = (
+ "5.10.0" => [qw(switch say state)],
);
-$feature_bundle{"5.12"} = $feature_bundle{"5.11"};
-$feature_bundle{"5.13"} = $feature_bundle{"5.11"};
-$feature_bundle{"5.14"} = $feature_bundle{"5.11"};
-$feature_bundle{"5.16"} = $feature_bundle{"5.15"};
-$feature_bundle{"5.17"} = $feature_bundle{"5.15"};
-$feature_bundle{"5.18"} = $feature_bundle{"5.15"};
-$feature_bundle{"5.19"} = $feature_bundle{"5.15"};
-$feature_bundle{"5.20"} = $feature_bundle{"5.15"};
-$feature_bundle{"5.9.5"} = $feature_bundle{"5.10"};
-
-our $hint_shift = 26;
-our $hint_mask = 0x1c000000;
-our @hint_bundles = qw( default 5.10 5.11 5.15 );
-
-# This gets set (for now) in $^H as well as in %^H,
-# for runtime speed of the uc/lc/ucfirst/lcfirst functions.
-# See HINT_UNI_8_BIT in perl.h.
-our $hint_uni8bit = 0x00000800;
+# latest version here
+$feature_bundle{"5.10"} = $feature_bundle{sprintf("%vd",$^V)};
+
+$feature_bundle{"5.9.5"} = $feature_bundle{"5.10.0"};
# TODO:
# - think about versioned features (use feature switch => 2)
=head1 NAME
-feature - Perl pragma to enable new features
+feature - Perl pragma to enable new syntactic features
=head1 SYNOPSIS
- use feature qw(say switch);
+ use feature qw(switch say);
given ($foo) {
- when (1) { say "\$foo == 1" }
- when ([2,3]) { say "\$foo == 2 || \$foo == 3" }
- when (/^a[bc]d$/) { say "\$foo eq 'abd' || \$foo eq 'acd'" }
- when ($_ > 100) { say "\$foo > 100" }
- default { say "None of the above" }
+ when (1) { say "\$foo == 1" }
+ when ([2,3]) { say "\$foo == 2 || \$foo == 3" }
+ when (/^a[bc]d$/) { say "\$foo eq 'abd' || \$foo eq 'acd'" }
+ when ($_ > 100) { say "\$foo > 100" }
+ default { say "None of the above" }
}
use feature ':5.10'; # loads all features available in perl 5.10
- use v5.10; # implicitly loads :5.10 feature bundle
-
=head1 DESCRIPTION
It is usually impossible to add new syntax to Perl without breaking
-some existing programs. This pragma provides a way to minimize that
-risk. New syntactic constructs, or new semantic meanings to older
-constructs, can be enabled by C<use feature 'foo'>, and will be parsed
-only when the appropriate feature pragma is in scope. (Nevertheless, the
-C<CORE::> prefix provides access to all Perl keywords, regardless of this
-pragma.)
+some existing programs. This pragma provides a way to minimize that
+risk. New syntactic constructs can be enabled by C<use feature 'foo'>,
+and will be parsed only when the appropriate feature pragma is in
+scope.
=head2 Lexical effect
Like other pragmas (C<use strict>, for example), features have a lexical
-effect. C<use feature qw(foo)> will only make the feature "foo" available
+effect. C<use feature qw(foo)> will only make the feature "foo" available
from that point to the end of the enclosing block.
{
@@ -96,7 +60,7 @@ from that point to the end of the enclosing block.
=head2 C<no feature>
-Features can also be turned off by using C<no feature "foo">. This too
+Features can also be turned off by using C<no feature "foo">. This too
has lexical effect.
use feature 'say';
@@ -107,254 +71,64 @@ has lexical effect.
}
say "Yet it is here.";
-C<no feature> with no features specified will reset to the default group. To
-disable I<all> features (an unusual request!) use C<no feature ':all'>.
+C<no feature> with no features specified will turn off all features.
-=head1 AVAILABLE FEATURES
+=head2 The 'switch' feature
+
+C<use feature 'switch'> tells the compiler to enable the Perl 6
+given/when construct.
+
+See L<perlsyn/"Switch statements"> for details.
=head2 The 'say' feature
-C<use feature 'say'> tells the compiler to enable the Perl 6 style
+C<use feature 'say'> tells the compiler to enable the Perl 6
C<say> function.
See L<perlfunc/say> for details.
-This feature is available starting with Perl 5.10.
-
-=head2 The 'state' feature
+=head2 the 'state' feature
C<use feature 'state'> tells the compiler to enable C<state>
variables.
See L<perlsub/"Persistent Private Variables"> for details.
-This feature is available starting with Perl 5.10.
-
-=head2 The 'switch' feature
-
-C<use feature 'switch'> tells the compiler to enable the Perl 6
-given/when construct.
-
-See L<perlsyn/"Switch Statements"> for details.
-
-This feature is available starting with Perl 5.10.
-
-=head2 The 'unicode_strings' feature
-
-C<use feature 'unicode_strings'> tells the compiler to use Unicode rules
-in all string operations executed within its scope (unless they are also
-within the scope of either C<use locale> or C<use bytes>). The same applies
-to all regular expressions compiled within the scope, even if executed outside
-it. It does not change the internal representation of strings, but only how
-they are interpreted.
-
-C<no feature 'unicode_strings'> tells the compiler to use the traditional
-Perl rules wherein the native character set rules is used unless it is
-clear to Perl that Unicode is desired. This can lead to some surprises
-when the behavior suddenly changes. (See
-L<perlunicode/The "Unicode Bug"> for details.) For this reason, if you are
-potentially using Unicode in your program, the
-C<use feature 'unicode_strings'> subpragma is B<strongly> recommended.
-
-This feature is available starting with Perl 5.12; was almost fully
-implemented in Perl 5.14; and extended in Perl 5.16 to cover C<quotemeta>.
-
-=head2 The 'unicode_eval' and 'evalbytes' features
-
-Under the C<unicode_eval> feature, Perl's C<eval> function, when passed a
-string, will evaluate it as a string of characters, ignoring any
-C<use utf8> declarations. C<use utf8> exists to declare the encoding of
-the script, which only makes sense for a stream of bytes, not a string of
-characters. Source filters are forbidden, as they also really only make
-sense on strings of bytes. Any attempt to activate a source filter will
-result in an error.
-
-The C<evalbytes> feature enables the C<evalbytes> keyword, which evaluates
-the argument passed to it as a string of bytes. It dies if the string
-contains any characters outside the 8-bit range. Source filters work
-within C<evalbytes>: they apply to the contents of the string being
-evaluated.
-
-Together, these two features are intended to replace the historical C<eval>
-function, which has (at least) two bugs in it, that cannot easily be fixed
-without breaking existing programs:
-
-=over
-
-=item *
-
-C<eval> behaves differently depending on the internal encoding of the
-string, sometimes treating its argument as a string of bytes, and sometimes
-as a string of characters.
-
-=item *
-
-Source filters activated within C<eval> leak out into whichever I<file>
-scope is currently being compiled. To give an example with the CPAN module
-L<Semi::Semicolons>:
-
- BEGIN { eval "use Semi::Semicolons; # not filtered here " }
- # filtered here!
-
-C<evalbytes> fixes that to work the way one would expect:
-
- use feature "evalbytes";
- BEGIN { evalbytes "use Semi::Semicolons; # filtered " }
- # not filtered
-
-=back
-
-These two features are available starting with Perl 5.16.
-
-=head2 The 'current_sub' feature
-
-This provides the C<__SUB__> token that returns a reference to the current
-subroutine or C<undef> outside of a subroutine.
-
-This feature is available starting with Perl 5.16.
-
-=head2 The 'array_base' feature
-
-This feature supports the legacy C<$[> variable. See L<perlvar/$[> and
-L<arybase>. It is on by default but disabled under C<use v5.16> (see
-L</IMPLICIT LOADING>, below).
-
-This feature is available under this name starting with Perl 5.16. In
-previous versions, it was simply on all the time, and this pragma knew
-nothing about it.
-
-=head2 The 'fc' feature
-
-C<use feature 'fc'> tells the compiler to enable the C<fc> function,
-which implements Unicode casefolding.
-
-See L<perlfunc/fc> for details.
-
-This feature is available from Perl 5.16 onwards.
-
-=head2 The 'lexical_subs' feature
-
-B<WARNING>: This feature is still experimental and the implementation may
-change in future versions of Perl. For this reason, Perl will
-warn when you use the feature, unless you have explicitly disabled the
-warning:
-
- no warnings "experimental::lexical_subs";
-
-This enables declaration of subroutines via C<my sub foo>, C<state sub foo>
-and C<our sub foo> syntax. See L<perlsub/Lexical Subroutines> for details.
-
-This feature is available from Perl 5.18 onwards.
-
-=head2 The 'postderef' and 'postderef_qq' features
-
-B<WARNING>: This feature is still experimental and the implementation may
-change in future versions of Perl. For this reason, Perl will
-warn when you use the feature, unless you have explicitly disabled the
-warning:
-
- no warnings "experimental::postderef";
-
-The 'postderef' feature allows the use of L<postfix dereference
-syntax|perlref/Postfix Dereference Syntax>. For example, it will make the
-following two statements equivalent:
-
- my @x = @{ $h->{a} };
- my @x = $h->{a}->@*;
-
-The 'postderef_qq' feature extends this, for array and scalar dereference, to
-working inside of double-quotish interpolations.
-
-This feature is available from Perl 5.20 onwards.
-
-=head2 The 'signatures' feature
-
-B<WARNING>: This feature is still experimental and the implementation may
-change in future versions of Perl. For this reason, Perl will
-warn when you use the feature, unless you have explicitly disabled the
-warning:
-
- no warnings "experimental::signatures";
-
-This enables unpacking of subroutine arguments into lexical variables
-by syntax such as
-
- sub foo ($left, $right) {
- return $left + $right;
- }
-
-See L<perlsub/Signatures> for details.
-
-This feature is available from Perl 5.20 onwards.
-
=head1 FEATURE BUNDLES
-It's possible to load multiple features together, using
-a I<feature bundle>. The name of a feature bundle is prefixed with
-a colon, to distinguish it from an actual feature.
-
- use feature ":5.10";
-
-The following feature bundles are available:
-
- bundle features included
- --------- -----------------
- :default array_base
-
- :5.10 say state switch array_base
-
- :5.12 say state switch unicode_strings array_base
-
- :5.14 say state switch unicode_strings array_base
+It's possible to load a whole slew of features in one go, using
+a I<feature bundle>. The name of a feature bundle is prefixed with
+a colon, to distinguish it from an actual feature. At present, the
+only feature bundles are C<use feature ":5.10"> and C<use feature ":5.10.0">,
+which both are equivalent to C<use feature qw(switch say state)>.
- :5.16 say state switch unicode_strings
- unicode_eval evalbytes current_sub fc
-
- :5.18 say state switch unicode_strings
- unicode_eval evalbytes current_sub fc
-
- :5.20 say state switch unicode_strings
- unicode_eval evalbytes current_sub fc
-
-The C<:default> bundle represents the feature set that is enabled before
-any C<use feature> or C<no feature> declaration.
-
-Specifying sub-versions such as the C<0> in C<5.14.0> in feature bundles has
-no effect. Feature bundles are guaranteed to be the same for all sub-versions.
-
- use feature ":5.14.0"; # same as ":5.14"
- use feature ":5.14.1"; # same as ":5.14"
+In the forthcoming 5.10.X perl releases, C<use feature ":5.10"> will be
+equivalent to the latest C<use feature ":5.10.X">.
=head1 IMPLICIT LOADING
-Instead of loading feature bundles by name, it is easier to let Perl do
-implicit loading of a feature bundle for you.
-
-There are two ways to load the C<feature> pragma implicitly:
+There are two ways to load the C<feature> pragma implicitly :
=over 4
=item *
-By using the C<-E> switch on the Perl command-line instead of C<-e>.
-That will enable the feature bundle for that version of Perl in the
-main compilation unit (that is, the one-liner that follows C<-E>).
+By using the C<-E> switch on the command-line instead of C<-e>. It enables
+all available features in the main compilation unit (that is, the one-liner.)
=item *
-By explicitly requiring a minimum Perl version number for your program, with
-the C<use VERSION> construct. That is,
+By requiring explicitly a minimal Perl version number for your program, with
+the C<use VERSION> construct, and when the version is higher than or equal to
+5.10.0. That is,
- use v5.10.0;
+ use 5.10.0;
will do an implicit
- no feature ':all';
- use feature ':5.10';
+ use feature ':5.10.0';
-and so on. Note how the trailing sub-version
-is automatically stripped from the
-version.
+and so on.
But to avoid portability warnings (see L<perlfunc/use>), you may prefer:
@@ -362,87 +136,70 @@ But to avoid portability warnings (see L<perlfunc/use>), you may prefer:
with the same effect.
-If the required version is older than Perl 5.10, the ":default" feature
-bundle is automatically loaded instead.
-
=back
=cut
sub import {
my $class = shift;
-
- if (!@_) {
- croak("No features specified");
+ if (@_ == 0) {
+ croak("No features specified");
+ }
+ while (@_) {
+ my $name = shift(@_);
+ if (substr($name, 0, 1) eq ":") {
+ my $v = substr($name, 1);
+ if (!exists $feature_bundle{$v}) {
+ unknown_feature_bundle($v);
+ }
+ unshift @_, @{$feature_bundle{$v}};
+ next;
+ }
+ if (!exists $feature{$name}) {
+ unknown_feature($name);
+ }
+ $^H{$feature{$name}} = 1;
}
-
- __common(1, @_);
}
sub unimport {
my $class = shift;
- # A bare C<no feature> should reset to the default bundle
+ # A bare C<no feature> should disable *all* features
if (!@_) {
- $^H &= ~($hint_uni8bit|$hint_mask);
+ delete @^H{ values(%feature) };
return;
}
- __common(0, @_);
-}
-
-
-sub __common {
- my $import = shift;
- my $bundle_number = $^H & $hint_mask;
- my $features = $bundle_number != $hint_mask
- && $feature_bundle{$hint_bundles[$bundle_number >> $hint_shift]};
- if ($features) {
- # Features are enabled implicitly via bundle hints.
- # Delete any keys that may be left over from last time.
- delete @^H{ values(%feature) };
- $^H |= $hint_mask;
- for (@$features) {
- $^H{$feature{$_}} = 1;
- $^H |= $hint_uni8bit if $_ eq 'unicode_strings';
- }
- }
while (@_) {
- my $name = shift;
- if (substr($name, 0, 1) eq ":") {
- my $v = substr($name, 1);
- if (!exists $feature_bundle{$v}) {
- $v =~ s/^([0-9]+)\.([0-9]+).[0-9]+$/$1.$2/;
- if (!exists $feature_bundle{$v}) {
- unknown_feature_bundle(substr($name, 1));
- }
- }
- unshift @_, @{$feature_bundle{$v}};
- next;
- }
- if (!exists $feature{$name}) {
- unknown_feature($name);
- }
- if ($import) {
- $^H{$feature{$name}} = 1;
- $^H |= $hint_uni8bit if $name eq 'unicode_strings';
- } else {
- delete $^H{$feature{$name}};
- $^H &= ~ $hint_uni8bit if $name eq 'unicode_strings';
- }
+ my $name = shift;
+ if (substr($name, 0, 1) eq ":") {
+ my $v = substr($name, 1);
+ if (!exists $feature_bundle{$v}) {
+ unknown_feature_bundle($v);
+ }
+ unshift @_, @{$feature_bundle{$v}};
+ next;
+ }
+ if (!exists($feature{$name})) {
+ unknown_feature($name);
+ }
+ else {
+ delete $^H{$feature{$name}};
+ }
}
}
sub unknown_feature {
my $feature = shift;
croak(sprintf('Feature "%s" is not supported by Perl %vd',
- $feature, $^V));
+ $feature, $^V));
}
sub unknown_feature_bundle {
my $feature = shift;
croak(sprintf('Feature bundle "%s" is not supported by Perl %vd',
- $feature, $^V));
+ $feature, $^V));
}
sub croak {
@@ -451,5 +208,3 @@ sub croak {
}
1;
-
-# ex: set ro:
diff --git a/gnu/usr.bin/perl/lib/perl5db.t b/gnu/usr.bin/perl/lib/perl5db.t
index 3af7f64e6ef..4553e026891 100644
--- a/gnu/usr.bin/perl/lib/perl5db.t
+++ b/gnu/usr.bin/perl/lib/perl5db.t
@@ -1,4 +1,4 @@
-#!./perl
+#!/usr/bin/perl
BEGIN {
chdir 't' if -d 't';
@@ -8,2723 +8,70 @@ BEGIN {
use strict;
use warnings;
-use Config;
BEGIN {
- if (! -c "/dev/null") {
- print "1..0 # Skip: no /dev/null\n";
- exit 0;
+ if (!-c "/dev/null") {
+ print "1..0 # Skip: no /dev/null\n";
+ exit 0;
}
-
- my $dev_tty = '/dev/tty';
- $dev_tty = 'TT:' if ($^O eq 'VMS');
- if (! -c $dev_tty) {
- print "1..0 # Skip: no $dev_tty\n";
- exit 0;
- }
- if ($ENV{PERL5DB}) {
- print "1..0 # Skip: \$ENV{PERL5DB} is already set to '$ENV{PERL5DB}'\n";
- exit 0;
+ if (!-c "/dev/tty") {
+ print "1..0 # Skip: no /dev/tty\n";
+ exit 0;
}
- $ENV{PERL_RL} = 'Perl'; # Suppress system Term::ReadLine::Gnu
}
-plan(119);
-
-my $rc_filename = '.perldb';
+plan(1);
sub rc {
- open my $rc_fh, '>', $rc_filename
- or die $!;
- print {$rc_fh} @_;
- close ($rc_fh);
-
+ open RC, ">", ".perldb" or die $!;
+ print RC @_;
+ close(RC);
# overly permissive perms gives "Must not source insecure rcfile"
# and hangs at the DB(1> prompt
- chmod 0644, $rc_filename;
-}
-
-sub _slurp
-{
- my $filename = shift;
-
- open my $in, '<', $filename
- or die "Cannot open '$filename' for slurping - $!";
-
- local $/;
- my $contents = <$in>;
-
- close($in);
-
- return $contents;
-}
-
-my $out_fn = 'db.out';
-
-sub _out_contents
-{
- return _slurp($out_fn);
-}
-
-
-# Test for Proxy constants
-{
- rc(
- <<'EOF',
-
-&parse_options("NonStop=0 ReadLine=0 TTY=db.out");
-
-sub afterinit {
- push(@DB::typeahead,
- 'm main->s1',
- 'q',
- );
-}
-
-EOF
- );
-
- my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/proxy-constants');
- is($output, "", "proxy constant subroutines");
-}
-
-# [perl #66110] Call a subroutine inside a regex
-{
- local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
- my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-66110');
- like($output, "All tests successful.", "[perl #66110]");
-}
-# [ perl #116769] Frame=2
-{
- local $ENV{PERLDB_OPTS} = "frame=2 nonstop";
- my $output = runperl( switches => [ '-d' ], prog => 'print q{success}' );
- is( $?, 0, '[perl #116769] frame=2 does not crash debugger, exit == 0' );
- like( $output, 'success' , '[perl #116769] code is run' );
-}
-# [ perl #116771] autotrace
-{
- local $ENV{PERLDB_OPTS} = "autotrace nonstop";
- my $output = runperl( switches => [ '-d' ], prog => 'print q{success}' );
- is( $?, 0, '[perl #116771] autotrace does not crash debugger, exit == 0' );
- like( $output, 'success' , '[perl #116771] code is run' );
-}
-# [ perl #41461] Frame=2 noTTY
-{
- local $ENV{PERLDB_OPTS} = "frame=2 noTTY nonstop";
- rc('');
- my $output = runperl( switches => [ '-d' ], prog => 'print q{success}' );
- is( $?, 0, '[perl #41461] frame=2 noTTY does not crash debugger, exit == 0' );
- like( $output, 'success' , '[perl #41461] code is run' );
-}
-
-package DebugWrap;
-
-sub new {
- my $class = shift;
-
- my $self = bless {}, $class;
-
- $self->_init(@_);
-
- return $self;
-}
-
-sub _cmds {
- my $self = shift;
-
- if (@_) {
- $self->{_cmds} = shift;
- }
-
- return $self->{_cmds};
-}
-
-sub _prog {
- my $self = shift;
-
- if (@_) {
- $self->{_prog} = shift;
- }
-
- return $self->{_prog};
-}
-
-sub _output {
- my $self = shift;
-
- if (@_) {
- $self->{_output} = shift;
- }
-
- return $self->{_output};
-}
-
-sub _include_t
-{
- my $self = shift;
-
- if (@_)
- {
- $self->{_include_t} = shift;
- }
-
- return $self->{_include_t};
-}
-
-sub _stderr_val
-{
- my $self = shift;
-
- if (@_)
- {
- $self->{_stderr_val} = shift;
- }
-
- return $self->{_stderr_val};
-}
-
-sub field
-{
- my $self = shift;
-
- if (@_)
- {
- $self->{field} = shift;
- }
-
- return $self->{field};
-}
-
-sub _switches
-{
- my $self = shift;
-
- if (@_)
- {
- $self->{_switches} = shift;
- }
-
- return $self->{_switches};
-}
-
-sub _contents
-{
- my $self = shift;
-
- if (@_)
- {
- $self->{_contents} = shift;
- }
-
- return $self->{_contents};
-}
-
-sub _init
-{
- my ($self, $args) = @_;
-
- my $cmds = $args->{cmds};
-
- if (ref($cmds) ne 'ARRAY') {
- die "cmds must be an array of commands.";
- }
-
- $self->_cmds($cmds);
-
- my $prog = $args->{prog};
-
- if (ref($prog) ne '' or !defined($prog)) {
- die "prog should be a path to a program file.";
- }
-
- $self->_prog($prog);
-
- $self->_include_t($args->{include_t} ? 1 : 0);
-
- $self->_stderr_val(exists($args->{stderr}) ? $args->{stderr} : 1);
-
- if (exists($args->{switches}))
- {
- $self->_switches($args->{switches});
- }
-
- $self->_run();
-
- return;
-}
-
-sub _quote
-{
- my ($self, $str) = @_;
-
- $str =~ s/(["\@\$\\])/\\$1/g;
- $str =~ s/\n/\\n/g;
- $str =~ s/\r/\\r/g;
-
- return qq{"$str"};
-}
-
-sub _run {
- my $self = shift;
-
- my $rc = qq{&parse_options("NonStop=0 TTY=db.out");\n};
-
- $rc .= join('',
- map { "$_\n"}
- (q#sub afterinit {#,
- q#push (@DB::typeahead,#,
- (map { $self->_quote($_) . "," } @{$self->_cmds()}),
- q#);#,
- q#}#,
- )
- );
-
- # I guess two objects like that cannot be used at the same time.
- # Oh well.
- ::rc($rc);
-
- my $output =
- ::runperl(
- switches =>
- [
- ($self->_switches ? (@{$self->_switches()}) : ('-d')),
- ($self->_include_t ? ('-I', '../lib/perl5db/t') : ())
- ],
- (defined($self->_stderr_val())
- ? (stderr => $self->_stderr_val())
- : ()
- ),
- progfile => $self->_prog()
- );
-
- $self->_output($output);
-
- $self->_contents(::_out_contents());
-
- return;
-}
-
-sub get_output
-{
- return shift->_output();
-}
-
-sub output_like {
- my ($self, $re, $msg) = @_;
-
- local $::Level = $::Level + 1;
- ::like($self->_output(), $re, $msg);
-}
-
-sub output_unlike {
- my ($self, $re, $msg) = @_;
-
- local $::Level = $::Level + 1;
- ::unlike($self->_output(), $re, $msg);
-}
-
-sub contents_like {
- my ($self, $re, $msg) = @_;
-
- local $::Level = $::Level + 1;
- ::like($self->_contents(), $re, $msg);
-}
-
-sub contents_unlike {
- my ($self, $re, $msg) = @_;
-
- local $::Level = $::Level + 1;
- ::unlike($self->_contents(), $re, $msg);
-}
-
-package main;
+ chmod 0644, ".perldb";
+}
+
+my $target = '../lib/perl5db/t/eval-line-bug';
+
+rc(
+ qq|
+ &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
+ \n|,
+
+ qq|
+ sub afterinit {
+ push(\@DB::typeahead,
+ 'b 23',
+ 'n',
+ 'n',
+ 'n',
+ 'c', # line 23
+ 'n',
+ "p \\\@{'main::_<$target'}",
+ 'q',
+ );
+ }\n|,
+);
{
local $ENV{PERLDB_OPTS} = "ReadLine=0";
- my $target = '../lib/perl5db/t/eval-line-bug';
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'b 23',
- 'n',
- 'n',
- 'n',
- 'c', # line 23
- 'n',
- "p \@{'main::_<$target'}",
- 'q',
- ],
- prog => $target,
- }
- );
- $wrapper->contents_like(
- qr/sub factorial/,
- 'The ${main::_<filename} variable in the debugger was not destroyed',
- );
+ runperl(switches => [ '-d' ], progfile => $target);
}
-sub _calc_generic_wrapper
+my $contents;
{
- my $args = shift;
-
- my $extra_opts = delete($args->{extra_opts});
- $extra_opts ||= '';
- local $ENV{PERLDB_OPTS} = "ReadLine=0" . $extra_opts;
- return DebugWrap->new(
- {
- cmds => delete($args->{cmds}),
- prog => delete($args->{prog}),
- %$args,
- }
- );
-}
-
-sub _calc_new_var_wrapper
-{
- my ($args) = @_;
- return _calc_generic_wrapper(
- {
- cmds =>
- [
- 'b 23',
- 'c',
- '$new_var = "Foo"',
- 'x "new_var = <$new_var>\\n"',
- 'q',
- ],
- %$args,
- }
- );
-}
-
-sub _calc_threads_wrapper
-{
- my $args = shift;
-
- return _calc_new_var_wrapper(
- {
- switches => [ '-dt', ],
- stderr => 1,
- %$args
- }
- );
-}
-
-{
- _calc_new_var_wrapper({ prog => '../lib/perl5db/t/eval-line-bug'})
- ->contents_like(
- qr/new_var = <Foo>/,
- "no strict 'vars' in evaluated lines.",
- );
-}
-
-{
- _calc_new_var_wrapper(
- {
- prog => '../lib/perl5db/t/lvalue-bug',
- stderr => undef(),
- },
- )->output_like(
- qr/foo is defined/,
- 'lvalue subs work in the debugger',
- );
-}
-
-{
- _calc_new_var_wrapper(
- {
- prog => '../lib/perl5db/t/symbol-table-bug',
- extra_opts => "NonStop=1",
- stderr => undef(),
- }
- )->output_like(
- qr/Undefined symbols 0/,
- 'there are no undefined values in the symbol table',
- );
-}
-
-SKIP:
-{
- if ( $Config{usethreads} ) {
- skip('This perl has threads, skipping non-threaded debugger tests');
- }
- else {
- my $error = 'This Perl not built to support threads';
- _calc_threads_wrapper(
- {
- prog => '../lib/perl5db/t/eval-line-bug',
- }
- )->output_like(
- qr/\Q$error\E/,
- 'Perl debugger correctly complains that it was not built with threads',
- );
- }
-}
-
-SKIP:
-{
- if ( $Config{usethreads} ) {
- _calc_threads_wrapper(
- {
- prog => '../lib/perl5db/t/symbol-table-bug',
- }
- )->output_like(
- qr/Undefined symbols 0/,
- 'there are no undefined values in the symbol table when running with thread support',
- );
- }
- else {
- skip("This perl is not threaded, skipping threaded debugger tests");
- }
-}
-
-# Test [perl #61222]
-{
- local $ENV{PERLDB_OPTS};
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'm Pie',
- 'q',
- ],
- prog => '../lib/perl5db/t/rt-61222',
- }
- );
-
- $wrapper->contents_unlike(qr/INCORRECT/, "[perl #61222]");
-}
-
-sub _calc_trace_wrapper
-{
- my ($args) = @_;
-
- return _calc_generic_wrapper(
- {
- cmds =>
- [
- 't 2',
- 'c',
- 'q',
- ],
- %$args,
- }
- );
-}
-
-# [perl 104168] level option for tracing
-{
- my $wrapper = _calc_trace_wrapper({ prog => '../lib/perl5db/t/rt-104168' });
- $wrapper->contents_like(qr/level 2/, "[perl #104168] - level 2 appears");
- $wrapper->contents_unlike(qr/baz/, "[perl #104168] - no 'baz'");
-}
-
-# taint tests
-{
- my $wrapper = _calc_trace_wrapper(
- {
- prog => '../lib/perl5db/t/taint',
- extra_opts => ' NonStop=1',
- switches => [ '-d', '-T', ],
- }
- );
-
- my $output = $wrapper->get_output();
- chomp $output if $^O eq 'VMS'; # newline guaranteed at EOF
- is($output, '[$^X][done]', "taint");
-}
-
-# Testing that we can set a line in the middle of the file.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'b ../lib/perl5db/t/MyModule.pm:12',
- 'c',
- q/do { use IO::Handle; STDOUT->autoflush(1); print "Var=$var\n"; }/,
- 'c',
- 'q',
- ],
- include_t => 1,
- prog => '../lib/perl5db/t/filename-line-breakpoint'
- }
- );
-
- $wrapper->output_like(qr/
- ^Var=Bar$
- .*
- ^In\ MyModule\.$
- .*
- ^In\ Main\ File\.$
- .*
- /msx,
- "Can set breakpoint in a line in the middle of the file.");
-}
-
-# Testing that we can set a breakpoint
-{
- my $wrapper = DebugWrap->new(
- {
- prog => '../lib/perl5db/t/breakpoint-bug',
- cmds =>
- [
- 'b 6',
- 'c',
- q/do { use IO::Handle; STDOUT->autoflush(1); print "X={$x}\n"; }/,
- 'c',
- 'q',
- ],
- },
- );
-
- $wrapper->output_like(
- qr/X=\{Two\}/msx,
- "Can set breakpoint in a line."
- );
-}
-
-# Testing that we can disable a breakpoint at a numeric line.
-{
- my $wrapper = DebugWrap->new(
- {
- prog => '../lib/perl5db/t/disable-breakpoints-1',
- cmds =>
- [
- 'b 7',
- 'b 11',
- 'disable 7',
- 'c',
- q/print "X={$x}\n";/,
- 'c',
- 'q',
- ],
- }
- );
-
- $wrapper->output_like(qr/X=\{SecondVal\}/ms,
- "Can set breakpoint in a line.");
-}
-
-# Testing that we can re-enable a breakpoint at a numeric line.
-{
- my $wrapper = DebugWrap->new(
- {
- prog => '../lib/perl5db/t/disable-breakpoints-2',
- cmds =>
- [
- 'b 8',
- 'b 24',
- 'disable 24',
- 'c',
- 'enable 24',
- 'c',
- q/print "X={$x}\n";/,
- 'c',
- 'q',
- ],
- },
- );
-
- $wrapper->output_like(
- qr/
- X=\{SecondValOneHundred\}
- /msx,
- "Can set breakpoint in a line."
- );
-}
-# clean up.
-
-# Disable and enable for breakpoints on outer files.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'b 10',
- 'b ../lib/perl5db/t/EnableModule.pm:14',
- 'disable ../lib/perl5db/t/EnableModule.pm:14',
- 'c',
- 'enable ../lib/perl5db/t/EnableModule.pm:14',
- 'c',
- q/print "X={$x}\n";/,
- 'c',
- 'q',
- ],
- prog => '../lib/perl5db/t/disable-breakpoints-3',
- include_t => 1,
- }
- );
-
- $wrapper->output_like(qr/
- X=\{SecondValTwoHundred\}
- /msx,
- "Can set breakpoint in a line.");
-}
-
-# Testing that the prompt with the information appears.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds => ['q'],
- prog => '../lib/perl5db/t/disable-breakpoints-1',
- }
- );
-
- $wrapper->contents_like(qr/
- ^main::\([^\)]*\bdisable-breakpoints-1:2\):\n
- 2:\s+my\ \$x\ =\ "One";\n
- /msx,
- "Prompt should display the first line of code.");
-}
-
-# Testing that R (restart) and "B *" work.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'b 13',
- 'c',
- 'B *',
- 'b 9',
- 'R',
- 'c',
- q/print "X={$x};dummy={$dummy}\n";/,
- 'q',
- ],
- prog => '../lib/perl5db/t/disable-breakpoints-1',
- }
- );
-
- $wrapper->output_like(qr/
- X=\{FirstVal\};dummy=\{1\}
- /msx,
- "Restart and delete all breakpoints work properly.");
-}
-
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'c 15',
- q/print "X={$x}\n";/,
- 'c',
- 'q',
- ],
- prog => '../lib/perl5db/t/disable-breakpoints-1',
- }
- );
-
- $wrapper->output_like(qr/
- X=\{ThirdVal\}
- /msx,
- "'c line_num' is working properly.");
-}
-
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'n',
- 'n',
- 'b . $exp > 200',
- 'c',
- q/print "Exp={$exp}\n";/,
- 'q',
- ],
- prog => '../lib/perl5db/t/break-on-dot',
- }
- );
-
- $wrapper->output_like(qr/
- Exp=\{256\}
- /msx,
- "'b .' is working correctly.");
-}
-
-# Testing that the prompt with the information appears inside a subroutine call.
-# See https://rt.perl.org/rt3/Ticket/Display.html?id=104820
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'c back',
- 'q',
- ],
- prog => '../lib/perl5db/t/with-subroutine',
- }
- );
-
- $wrapper->contents_like(
- qr/
- ^main::back\([^\)\n]*\bwith-subroutine:15\):[\ \t]*\n
- ^15:\s*print\ "hello\ back\\n";
- /msx,
- "Prompt should display the line of code inside a subroutine.");
-}
-
-# Checking that the p command works.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'p "<<<" . (4*6) . ">>>"',
- 'q',
- ],
- prog => '../lib/perl5db/t/with-subroutine',
- }
- );
-
- $wrapper->contents_like(
- qr/<<<24>>>/,
- "p command works.");
-}
-
-# Tests for x.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- q/x {500 => 600}/,
- 'q',
- ],
- prog => '../lib/perl5db/t/with-subroutine',
- }
- );
-
- $wrapper->contents_like(
- # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
- qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/ms,
- "x command test."
- );
-}
-
-# Tests for x with @_
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'b 10',
- 'c',
- 'x @_',
- 'q',
- ],
- prog => '../lib/perl5db/t/test-passing-at-underscore-to-x-etc',
- }
- );
-
- $wrapper->contents_like(
- # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
- qr/Arg1.*?Capsula.*GreekHumor.*Socrates/ms,
- q/x command test with '@_'./,
- );
-}
-
-# Tests for mutating @_
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'b 10',
- 'c',
- 'shift(@_)',
- 'print "\n\n\n(((" . join(",", @_) . ")))\n\n\n"',
- 'q',
- ],
- prog => '../lib/perl5db/t/test-passing-at-underscore-to-x-etc',
- }
- );
-
- $wrapper->output_like(
- qr/^\(\(\(Capsula,GreekHumor,Socrates\)\)\)$/ms,
- q/Mutating '@_'./,
- );
-}
-
-# Tests for x with AutoTrace=1.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'n',
- 'o AutoTrace=1',
- # So it may fail.
- q/x "failure"/,
- q/x \$x/,
- 'q',
- ],
- prog => '../lib/perl5db/t/with-subroutine',
- }
- );
-
- $wrapper->contents_like(
- # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
- qr/^0\s+SCALAR\([^\)]+\)\n\s+-> 'hello world'\n/ms,
- "x after AutoTrace=1 command is working."
- );
-}
-
-# Tests for "T" (stack trace).
-{
- my $prog_fn = '../lib/perl5db/t/rt-104168';
- my $wrapper = DebugWrap->new(
- {
- prog => $prog_fn,
- cmds =>
- [
- 'c baz',
- 'T',
- 'q',
- ],
- }
- );
- my $re_text = join('',
- map {
- sprintf(
- "%s = %s\\(\\) called from file " .
- "'" . quotemeta($prog_fn) . "' line %s\\n",
- (map { quotemeta($_) } @$_)
- )
- }
- (
- ['.', 'main::baz', 14,],
- ['.', 'main::bar', 9,],
- ['.', 'main::foo', 6],
- )
- );
- $wrapper->contents_like(
- # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
- qr/^$re_text/ms,
- "T command test."
- );
-}
-
-# Test for s.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'b 9',
- 'c',
- 's',
- q/print "X={$x};dummy={$dummy}\n";/,
- 'q',
- ],
- prog => '../lib/perl5db/t/disable-breakpoints-1'
- }
- );
-
- $wrapper->output_like(qr/
- X=\{SecondVal\};dummy=\{1\}
- /msx,
- 'test for s - single step',
- );
-}
-
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'n',
- 'n',
- 'b . $exp > 200',
- 'c',
- q/print "Exp={$exp}\n";/,
- 'q',
- ],
- prog => '../lib/perl5db/t/break-on-dot'
- }
- );
-
- $wrapper->output_like(qr/
- Exp=\{256\}
- /msx,
- "'b .' is working correctly.");
-}
-
-{
- my $prog_fn = '../lib/perl5db/t/rt-104168';
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 's',
- 'q',
- ],
- prog => $prog_fn,
- }
- );
-
- $wrapper->contents_like(
- qr/
- ^main::foo\([^\)\n]*\brt-104168:9\):[\ \t]*\n
- ^9:\s*bar\(\);
- /msx,
- 'Test for the s command.',
- );
-}
-
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 's uncalled_subroutine()',
- 'c',
- 'q',
- ],
-
- prog => '../lib/perl5db/t/uncalled-subroutine'}
- );
-
- $wrapper->output_like(
- qr/<1,2,3,4,5>\n/,
- 'uncalled_subroutine was called after s EXPR()',
- );
-}
-
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'n uncalled_subroutine()',
- 'c',
- 'q',
- ],
- prog => '../lib/perl5db/t/uncalled-subroutine',
- }
- );
-
- $wrapper->output_like(
- qr/<1,2,3,4,5>\n/,
- 'uncalled_subroutine was called after n EXPR()',
- );
-}
-
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'b fact',
- 'c',
- 'c',
- 'c',
- 'n',
- 'print "<$n>"',
- 'q',
- ],
- prog => '../lib/perl5db/t/fact',
- }
- );
-
- $wrapper->output_like(
- qr/<3>/,
- 'b subroutine works fine',
- );
+ local $/;
+ open I, "<", 'db.out' or die $!;
+ $contents = <I>;
+ close(I);
}
-# Test for n with lvalue subs
-DebugWrap->new({
- cmds =>
- [
- 'n', 'print "<$x>\n"',
- 'n', 'print "<$x>\n"',
- 'q',
- ],
- prog => '../lib/perl5db/t/lsub-n',
-})->output_like(
- qr/<1>\n<11>\n/,
- 'n steps over lvalue subs',
+like($contents, qr/sub factorial/,
+ 'The ${main::_<filename} variable in the debugger was not destroyed'
);
-# Test for 'M' (module list).
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'M',
- 'q',
- ],
- prog => '../lib/perl5db/t/load-modules'
- }
- );
-
- $wrapper->contents_like(
- qr[Scalar/Util\.pm],
- 'M (module list) works fine',
- );
-}
-
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'b 14',
- 'c',
- '$flag = 1;',
- 'r',
- 'print "Var=$var\n";',
- 'q',
- ],
- prog => '../lib/perl5db/t/test-r-statement',
- }
- );
-
- $wrapper->output_like(
- qr/
- ^Foo$
- .*?
- ^Bar$
- .*?
- ^Var=Test$
- /msx,
- 'r statement is working properly.',
- );
-}
-
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'l',
- 'q',
- ],
- prog => '../lib/perl5db/t/test-l-statement-1',
- }
- );
-
- $wrapper->contents_like(
- qr/
- ^1==>\s+\$x\ =\ 1;\n
- 2:\s+print\ "1\\n";\n
- 3\s*\n
- 4:\s+\$x\ =\ 2;\n
- 5:\s+print\ "2\\n";\n
- /msx,
- 'l statement is working properly (test No. 1).',
- );
-}
-
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'l',
- q/# After l 1/,
- 'l',
- q/# After l 2/,
- '-',
- q/# After -/,
- 'q',
- ],
- prog => '../lib/perl5db/t/test-l-statement-1',
- }
- );
-
- my $first_l_out = qr/
- 1==>\s+\$x\ =\ 1;\n
- 2:\s+print\ "1\\n";\n
- 3\s*\n
- 4:\s+\$x\ =\ 2;\n
- 5:\s+print\ "2\\n";\n
- 6\s*\n
- 7:\s+\$x\ =\ 3;\n
- 8:\s+print\ "3\\n";\n
- 9\s*\n
- 10:\s+\$x\ =\ 4;\n
- /msx;
-
- my $second_l_out = qr/
- 11:\s+print\ "4\\n";\n
- 12\s*\n
- 13:\s+\$x\ =\ 5;\n
- 14:\s+print\ "5\\n";\n
- 15\s*\n
- 16:\s+\$x\ =\ 6;\n
- 17:\s+print\ "6\\n";\n
- 18\s*\n
- 19:\s+\$x\ =\ 7;\n
- 20:\s+print\ "7\\n";\n
- /msx;
- $wrapper->contents_like(
- qr/
- ^$first_l_out
- [^\n]*?DB<\d+>\ \#\ After\ l\ 1\n
- [\ \t]*\n
- [^\n]*?DB<\d+>\ l\s*\n
- $second_l_out
- [^\n]*?DB<\d+>\ \#\ After\ l\ 2\n
- [\ \t]*\n
- [^\n]*?DB<\d+>\ -\s*\n
- $first_l_out
- [^\n]*?DB<\d+>\ \#\ After\ -\n
- /msx,
- 'l followed by l and then followed by -',
- );
-}
-
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'l fact',
- 'q',
- ],
- prog => '../lib/perl5db/t/test-l-statement-2',
- }
- );
-
- my $first_l_out = qr/
- 6\s+sub\ fact\ \{\n
- 7:\s+my\ \$n\ =\ shift;\n
- 8:\s+if\ \(\$n\ >\ 1\)\ \{\n
- 9:\s+return\ \$n\ \*\ fact\(\$n\ -\ 1\);
- /msx;
-
- $wrapper->contents_like(
- qr/
- DB<1>\s+l\ fact\n
- $first_l_out
- /msx,
- 'l subroutine_name',
- );
-}
-
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'b fact',
- 'c',
- # Repeat several times to avoid @typeahead problems.
- '.',
- '.',
- '.',
- '.',
- 'q',
- ],
- prog => '../lib/perl5db/t/test-l-statement-2',
- }
- );
-
- my $line_out = qr /
- ^main::fact\([^\n]*?:7\):\n
- ^7:\s+my\ \$n\ =\ shift;\n
- /msx;
-
- $wrapper->contents_like(
- qr/
- $line_out
- auto\(-\d+\)\s+DB<\d+>\s+\.\n
- $line_out
- /msx,
- 'Test the "." command',
- );
-}
-
-# Testing that the f command works.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'f ../lib/perl5db/t/MyModule.pm',
- 'b 12',
- 'c',
- q/do { use IO::Handle; STDOUT->autoflush(1); print "Var=$var\n"; }/,
- 'c',
- 'q',
- ],
- include_t => 1,
- prog => '../lib/perl5db/t/filename-line-breakpoint'
- }
- );
-
- $wrapper->output_like(qr/
- ^Var=Bar$
- .*
- ^In\ MyModule\.$
- .*
- ^In\ Main\ File\.$
- .*
- /msx,
- "f command is working.",
- );
-}
-
-# We broke the /pattern/ command because apparently the CORE::eval-s inside
-# lib/perl5db.pl cannot handle lexical variable properly. So we now fix this
-# bug.
-#
-# TODO :
-#
-# 1. Go over the rest of the "eval"s in lib/perl5db.t and see if they cause
-# problems.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- '/for/',
- 'q',
- ],
- prog => '../lib/perl5db/t/eval-line-bug',
- }
- );
-
- $wrapper->contents_like(
- qr/12: \s* for\ my\ \$q\ \(1\ \.\.\ 10\)\ \{/msx,
- "/pat/ command is working and found a match.",
- );
-}
-
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'b 22',
- 'c',
- '?for?',
- 'q',
- ],
- prog => '../lib/perl5db/t/eval-line-bug',
- }
- );
-
- $wrapper->contents_like(
- qr/12: \s* for\ my\ \$q\ \(1\ \.\.\ 10\)\ \{/msx,
- "?pat? command is working and found a match.",
- );
-}
-
-# Test the L command.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'b 6',
- 'b 13 ($q == 5)',
- 'L',
- 'q',
- ],
- prog => '../lib/perl5db/t/eval-line-bug',
- }
- );
-
- $wrapper->contents_like(
- qr#
- ^\S*?eval-line-bug:\n
- \s*6:\s*my\ \$i\ =\ 5;\n
- \s*break\ if\ \(1\)\n
- \s*13:\s*\$i\ \+=\ \$q;\n
- \s*break\ if\ \(\(\$q\ ==\ 5\)\)\n
- #msx,
- "L command is listing breakpoints",
- );
-}
-
-# Test the L command for watch expressions.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'w (5+6)',
- 'L',
- 'q',
- ],
- prog => '../lib/perl5db/t/eval-line-bug',
- }
- );
-
- $wrapper->contents_like(
- qr#
- ^Watch-expressions:\n
- \s*\(5\+6\)\n
- #msx,
- "L command is listing watch expressions",
- );
-}
-
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'w (5+6)',
- 'w (11*23)',
- 'W (5+6)',
- 'L',
- 'q',
- ],
- prog => '../lib/perl5db/t/eval-line-bug',
- }
- );
-
- $wrapper->contents_like(
- qr#
- ^Watch-expressions:\n
- \s*\(11\*23\)\n
- ^auto\(
- #msx,
- "L command is not listing deleted watch expressions",
- );
-}
-
-# Test the L command.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'b 6',
- 'a 13 print $i',
- 'L',
- 'q',
- ],
- prog => '../lib/perl5db/t/eval-line-bug',
- }
- );
-
- $wrapper->contents_like(
- qr#
- ^\S*?eval-line-bug:\n
- \s*6:\s*my\ \$i\ =\ 5;\n
- \s*break\ if\ \(1\)\n
- \s*13:\s*\$i\ \+=\ \$q;\n
- \s*action:\s+print\ \$i\n
- #msx,
- "L command is listing actions and breakpoints",
- );
-}
-
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'S',
- 'q',
- ],
- prog => '../lib/perl5db/t/rt-104168',
- }
- );
-
- $wrapper->contents_like(
- qr#
- ^main::bar\n
- main::baz\n
- main::foo\n
- #msx,
- "S command - 1",
- );
-}
-
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'S ^main::ba',
- 'q',
- ],
- prog => '../lib/perl5db/t/rt-104168',
- }
- );
-
- $wrapper->contents_like(
- qr#
- ^main::bar\n
- main::baz\n
- auto\(
- #msx,
- "S command with regex",
- );
-}
-
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'S !^main::ba',
- 'q',
- ],
- prog => '../lib/perl5db/t/rt-104168',
- }
- );
-
- $wrapper->contents_unlike(
- qr#
- ^main::ba
- #msx,
- "S command with negative regex",
- );
-
- $wrapper->contents_like(
- qr#
- ^main::foo\n
- #msx,
- "S command with negative regex - what it still matches",
- );
-}
-
-# Test the 'a' command.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'a 13 print "\nVar<Q>=$q\n"',
- 'c',
- 'q',
- ],
- prog => '../lib/perl5db/t/eval-line-bug',
- }
- );
-
- my $nl = $^O eq 'VMS' ? "" : "\\\n";
- $wrapper->output_like(qr#
- \nVar<Q>=1$nl
- \nVar<Q>=2$nl
- \nVar<Q>=3
- #msx,
- "a command is working",
- );
-}
-
-# Test the 'a' command with no line number.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'n',
- q/a print "Hello " . (3 * 4) . "\n";/,
- 'c',
- 'q',
- ],
- prog => '../lib/perl5db/t/test-a-statement-1',
- }
- );
-
- $wrapper->output_like(qr#
- (?:^Hello\ 12\n.*?){4}
- #msx,
- "a command with no line number is working",
- );
-}
-
-# Test the 'A' command
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'a 13 print "\nVar<Q>=$q\n"',
- 'A 13',
- 'c',
- 'q',
- ],
- prog => '../lib/perl5db/t/eval-line-bug',
- }
- );
-
- $wrapper->output_like(
- qr#\A\z#msx, # The empty string.
- "A command (for removing actions) is working",
- );
-}
-
-# Test the 'A *' command
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'a 6 print "\nFail!\n"',
- 'a 13 print "\nVar<Q>=$q\n"',
- 'A *',
- 'c',
- 'q',
- ],
- prog => '../lib/perl5db/t/eval-line-bug',
- }
- );
-
- $wrapper->output_like(
- qr#\A\z#msx, # The empty string.
- "'A *' command (for removing all actions) is working",
- );
-}
-
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'n',
- 'w $foo',
- 'c',
- 'print "\nIDX=<$idx>\n"',
- 'q',
- ],
- prog => '../lib/perl5db/t/test-w-statement-1',
- }
- );
-
-
- $wrapper->contents_like(qr#
- \$foo\ changed:\n
- \s+old\ value:\s+'1'\n
- \s+new\ value:\s+'2'\n
- #msx,
- 'w command - watchpoint changed',
- );
- $wrapper->output_like(qr#
- \nIDX=<20>\n
- #msx,
- "w command - correct output from IDX",
- );
-}
-
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'n',
- 'w $foo',
- 'W $foo',
- 'c',
- 'print "\nIDX=<$idx>\n"',
- 'q',
- ],
- prog => '../lib/perl5db/t/test-w-statement-1',
- }
- );
-
- $wrapper->contents_unlike(qr#
- \$foo\ changed:
- #msx,
- 'W command - watchpoint was deleted',
- );
-
- $wrapper->output_like(qr#
- \nIDX=<>\n
- #msx,
- "W command - stopped at end.",
- );
-}
-
-# Test the W * command.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'n',
- 'w $foo',
- 'w ($foo*$foo)',
- 'W *',
- 'c',
- 'print "\nIDX=<$idx>\n"',
- 'q',
- ],
- prog => '../lib/perl5db/t/test-w-statement-1',
- }
- );
-
- $wrapper->contents_unlike(qr#
- \$foo\ changed:
- #msx,
- '"W *" command - watchpoint was deleted',
- );
-
- $wrapper->output_like(qr#
- \nIDX=<>\n
- #msx,
- '"W *" command - stopped at end.',
- );
-}
-
-# Test the 'o' command (without further arguments).
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'o',
- 'q',
- ],
- prog => '../lib/perl5db/t/test-w-statement-1',
- }
- );
-
- $wrapper->contents_like(qr#
- ^\s*warnLevel\ =\ '1'\n
- #msx,
- q#"o" command (without arguments) displays warnLevel#,
- );
-
- $wrapper->contents_like(qr#
- ^\s*signalLevel\ =\ '1'\n
- #msx,
- q#"o" command (without arguments) displays signalLevel#,
- );
-
- $wrapper->contents_like(qr#
- ^\s*dieLevel\ =\ '1'\n
- #msx,
- q#"o" command (without arguments) displays dieLevel#,
- );
-
- $wrapper->contents_like(qr#
- ^\s*hashDepth\ =\ 'N/A'\n
- #msx,
- q#"o" command (without arguments) displays hashDepth#,
- );
-}
-
-# Test the 'o' query command.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'o hashDepth? signalLevel?',
- 'q',
- ],
- prog => '../lib/perl5db/t/test-w-statement-1',
- }
- );
-
- $wrapper->contents_unlike(qr#warnLevel#,
- q#"o" query command does not display warnLevel#,
- );
-
- $wrapper->contents_like(qr#
- ^\s*signalLevel\ =\ '1'\n
- #msx,
- q#"o" query command displays signalLevel#,
- );
-
- $wrapper->contents_unlike(qr#dieLevel#,
- q#"o" query command does not display dieLevel#,
- );
-
- $wrapper->contents_like(qr#
- ^\s*hashDepth\ =\ 'N/A'\n
- #msx,
- q#"o" query command displays hashDepth#,
- );
-}
-
-# Test the 'o' set command.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'o signalLevel=0',
- 'o',
- 'q',
- ],
- prog => '../lib/perl5db/t/test-w-statement-1',
- }
- );
-
- $wrapper->contents_like(qr/
- ^\s*(signalLevel\ =\ '0'\n)
- .*?
- ^\s*\1
- /msx,
- q#o set command works#,
- );
-
- $wrapper->contents_like(qr#
- ^\s*hashDepth\ =\ 'N/A'\n
- #msx,
- q#o set command - hashDepth#,
- );
-}
-
-# Test the '<' and "< ?" commands.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- q/< print "\nX=<$x>\n"/,
- q/b 7/,
- q/< ?/,
- 'c',
- 'q',
- ],
- prog => '../lib/perl5db/t/disable-breakpoints-1',
- }
- );
-
- $wrapper->contents_like(qr/
- ^pre-perl\ commands:\n
- \s*<\ --\ print\ "\\nX=<\$x>\\n"\n
- /msx,
- q#Test < and < ? commands - contents.#,
- );
-
- $wrapper->output_like(qr#
- ^X=<FirstVal>\n
- #msx,
- q#Test < and < ? commands - output.#,
- );
-}
-
-# Test the '< *' command.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- q/< print "\nX=<$x>\n"/,
- q/b 7/,
- q/< */,
- 'c',
- 'q',
- ],
- prog => '../lib/perl5db/t/disable-breakpoints-1',
- }
- );
-
- $wrapper->output_unlike(qr/FirstVal/,
- q#Test the '< *' command.#,
- );
-}
-
-# Test the '>' and "> ?" commands.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- q/$::foo = 500;/,
- q/> print "\nFOO=<$::foo>\n"/,
- q/b 7/,
- q/> ?/,
- 'c',
- 'q',
- ],
- prog => '../lib/perl5db/t/disable-breakpoints-1',
- }
- );
-
- $wrapper->contents_like(qr/
- ^post-perl\ commands:\n
- \s*>\ --\ print\ "\\nFOO=<\$::foo>\\n"\n
- /msx,
- q#Test > and > ? commands - contents.#,
- );
-
- $wrapper->output_like(qr#
- ^FOO=<500>\n
- #msx,
- q#Test > and > ? commands - output.#,
- );
-}
-
-# Test the '> *' command.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- q/> print "\nFOO=<$::foo>\n"/,
- q/b 7/,
- q/> */,
- 'c',
- 'q',
- ],
- prog => '../lib/perl5db/t/disable-breakpoints-1',
- }
- );
-
- $wrapper->output_unlike(qr/FOO=/,
- q#Test the '> *' command.#,
- );
-}
-
-# Test the < and > commands together
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- q/$::lorem = 0;/,
- q/< $::lorem += 10;/,
- q/> print "\nLOREM=<$::lorem>\n"/,
- q/b 7/,
- q/b 5/,
- 'c',
- 'c',
- 'q',
- ],
- prog => '../lib/perl5db/t/disable-breakpoints-1',
- }
- );
-
- $wrapper->output_like(qr#
- ^LOREM=<10>\n
- #msx,
- q#Test < and > commands. #,
- );
-}
-
-# Test the { ? and { [command] commands.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- '{ ?',
- '{ l',
- '{ ?',
- q/b 5/,
- q/c/,
- q/q/,
- ],
- prog => '../lib/perl5db/t/disable-breakpoints-1',
- }
- );
-
- $wrapper->contents_like(qr#
- ^No\ pre-debugger\ actions\.\n
- .*?
- ^pre-debugger\ commands:\n
- \s+\{\ --\ l\n
- .*?
- ^5==>b\s+\$x\ =\ "FirstVal";\n
- 6\s*\n
- 7:\s+\$dummy\+\+;\n
- 8\s*\n
- 9:\s+\$x\ =\ "SecondVal";\n
-
- #msx,
- 'Test the pre-prompt debugger commands',
- );
-}
-
-# Test the { * command.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- '{ q',
- '{ *',
- q/b 5/,
- q/c/,
- q/print (("One" x 5), "\n");/,
- q/q/,
- ],
- prog => '../lib/perl5db/t/disable-breakpoints-1',
- }
- );
-
- $wrapper->contents_like(qr#
- ^All\ \{\ actions\ cleared\.\n
- #msx,
- 'Test the { * command',
- );
-
- $wrapper->output_like(qr/OneOneOneOneOne/,
- '{ * test - output is OK.',
- );
-}
-
-# Test the ! command.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'l 3-5',
- '!',
- 'q',
- ],
- prog => '../lib/perl5db/t/disable-breakpoints-1',
- }
- );
-
- $wrapper->contents_like(qr#
- (^3:\s+my\ \$dummy\ =\ 0;\n
- 4\s*\n
- 5:\s+\$x\ =\ "FirstVal";)\n
- .*?
- ^l\ 3-5\n
- \1
- #msx,
- 'Test the ! command (along with l 3-5)',
- );
-}
-
-# Test the ! -number command.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'l 3-5',
- 'l 2',
- '! -1',
- 'q',
- ],
- prog => '../lib/perl5db/t/disable-breakpoints-1',
- }
- );
-
- $wrapper->contents_like(qr#
- (^3:\s+my\ \$dummy\ =\ 0;\n
- 4\s*\n
- 5:\s+\$x\ =\ "FirstVal";)\n
- .*?
- ^2==\>\s+my\ \$x\ =\ "One";\n
- .*?
- ^l\ 3-5\n
- \1
- #msx,
- 'Test the ! -n command (along with l)',
- );
-}
-
-# Test the 'source' command.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'source ../lib/perl5db/t/source-cmd-test.perldb',
- # If we have a 'q' here, then the typeahead will override the
- # input, and so it won't be reached - solution:
- # put a q inside the .perldb commands.
- # ( This may be a bug or a misfeature. )
- ],
- prog => '../lib/perl5db/t/disable-breakpoints-1',
- }
- );
-
- $wrapper->contents_like(qr#
- ^3:\s+my\ \$dummy\ =\ 0;\n
- 4\s*\n
- 5:\s+\$x\ =\ "FirstVal";\n
- 6\s*\n
- 7:\s+\$dummy\+\+;\n
- 8\s*\n
- 9:\s+\$x\ =\ "SecondVal";\n
- 10\s*\n
- #msx,
- 'Test the source command (along with l)',
- );
-}
-
-# Test the 'source' command being traversed from withing typeahead.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'source ../lib/perl5db/t/source-cmd-test-no-q.perldb',
- 'q',
- ],
- prog => '../lib/perl5db/t/disable-breakpoints-1',
- }
- );
-
- $wrapper->contents_like(qr#
- ^3:\s+my\ \$dummy\ =\ 0;\n
- 4\s*\n
- 5:\s+\$x\ =\ "FirstVal";\n
- 6\s*\n
- 7:\s+\$dummy\+\+;\n
- 8\s*\n
- 9:\s+\$x\ =\ "SecondVal";\n
- 10\s*\n
- #msx,
- 'Test the source command inside a typeahead',
- );
-}
-
-# Test the 'H -number' command.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'l 1-10',
- 'l 5-10',
- 'x "Hello World"',
- 'l 1-5',
- 'b 3',
- 'x (20+4)',
- 'H -7',
- 'q',
- ],
- prog => '../lib/perl5db/t/disable-breakpoints-1',
- }
- );
-
- $wrapper->contents_like(qr#
- ^\d+:\s+H\ -7\n
- \d+:\s+x\ \(20\+4\)\n
- \d+:\s+b\ 3\n
- \d+:\s+l\ 1-5\n
- \d+:\s+x\ "Hello\ World"\n
- \d+:\s+l\ 5-10\n
- \d+:\s+l\ 1-10\n
- #msx,
- 'Test the H -num command',
- );
-}
-
-# Add a test for H (without arguments)
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'l 1-10',
- 'l 5-10',
- 'x "Hello World"',
- 'l 1-5',
- 'b 3',
- 'x (20+4)',
- 'H',
- 'q',
- ],
- prog => '../lib/perl5db/t/disable-breakpoints-1',
- }
- );
-
- $wrapper->contents_like(qr#
- ^\d+:\s+x\ \(20\+4\)\n
- \d+:\s+b\ 3\n
- \d+:\s+l\ 1-5\n
- \d+:\s+x\ "Hello\ World"\n
- \d+:\s+l\ 5-10\n
- \d+:\s+l\ 1-10\n
- #msx,
- 'Test the H command (without a number.)',
- );
-}
-
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- '= quit q',
- '= foobar l',
- 'foobar',
- 'quit',
- ],
- prog => '../lib/perl5db/t/test-l-statement-1',
- }
- );
-
- $wrapper->contents_like(
- qr/
- ^1==>\s+\$x\ =\ 1;\n
- 2:\s+print\ "1\\n";\n
- 3\s*\n
- 4:\s+\$x\ =\ 2;\n
- 5:\s+print\ "2\\n";\n
- /msx,
- 'Test the = (command alias) command.',
- );
-}
-
-# Test the m statement.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'm main',
- 'q',
- ],
- prog => '../lib/perl5db/t/disable-breakpoints-1',
- }
- );
-
- $wrapper->contents_like(qr#
- ^via\ UNIVERSAL:\ DOES$
- #msx,
- "Test m for main - 1",
- );
-
- $wrapper->contents_like(qr#
- ^via\ UNIVERSAL:\ can$
- #msx,
- "Test m for main - 2",
- );
-}
-
-# Test the m statement.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'b 41',
- 'c',
- 'm $obj',
- 'q',
- ],
- prog => '../lib/perl5db/t/test-m-statement-1',
- }
- );
-
- $wrapper->contents_like(qr#^greet$#ms,
- "Test m for obj - 1",
- );
-
- $wrapper->contents_like(qr#^via UNIVERSAL: can$#ms,
- "Test m for obj - 1",
- );
-}
-
-# Test the M command.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'M',
- 'q',
- ],
- prog => '../lib/perl5db/t/test-m-statement-1',
- }
- );
-
- $wrapper->contents_like(qr#
- ^'strict\.pm'\ =>\ '\d+\.\d+\ from
- #msx,
- "Test M",
- );
-
-}
-
-# Test the recallCommand option.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'o recallCommand=%',
- 'l 3-5',
- 'l 2',
- '% -1',
- 'q',
- ],
- prog => '../lib/perl5db/t/disable-breakpoints-1',
- }
- );
-
- $wrapper->contents_like(qr#
- (^3:\s+my\ \$dummy\ =\ 0;\n
- 4\s*\n
- 5:\s+\$x\ =\ "FirstVal";)\n
- .*?
- ^2==\>\s+my\ \$x\ =\ "One";\n
- .*?
- ^l\ 3-5\n
- \1
- #msx,
- 'Test the o recallCommand option',
- );
-}
-
-# Test the dieLevel option
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- q/o dieLevel='1'/,
- q/c/,
- 'q',
- ],
- prog => '../lib/perl5db/t/test-dieLevel-option-1',
- }
- );
-
- $wrapper->output_like(qr#
- ^This\ program\ dies\.\ at\ \S+\ line\ 18\N*\.\n
- .*?
- ^\s+main::baz\(\)\ called\ at\ \S+\ line\ 13\n
- \s+main::bar\(\)\ called\ at\ \S+\ line\ 7\n
- \s+main::foo\(\)\ called\ at\ \S+\ line\ 21\n
- #msx,
- 'Test the o dieLevel option',
- );
-}
-
-# Test the warnLevel option
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- q/o warnLevel='1'/,
- q/c/,
- 'q',
- ],
- prog => '../lib/perl5db/t/test-warnLevel-option-1',
- }
- );
-
- $wrapper->contents_like(qr#
- ^This\ is\ not\ a\ warning\.\ at\ \S+\ line\ 18\N*\.\n
- .*?
- ^\s+main::baz\(\)\ called\ at\ \S+\ line\ 13\n
- \s+main::bar\(\)\ called\ at\ \S+\ line\ 25\n
- \s+main::myfunc\(\)\ called\ at\ \S+\ line\ 28\n
- #msx,
- 'Test the o warnLevel option',
- );
-}
-
-# Test the t command
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 't',
- 'c',
- 'q',
- ],
- prog => '../lib/perl5db/t/disable-breakpoints-1',
- }
- );
-
- $wrapper->contents_like(qr/
- ^main::\([^:]+:15\):\n
- 15:\s+\$dummy\+\+;\n
- main::\([^:]+:17\):\n
- 17:\s+\$x\ =\ "FourthVal";\n
- /msx,
- 'Test the t command (without a number.)',
- );
-}
-
-# Test the o AutoTrace command
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'o AutoTrace',
- 'c',
- 'q',
- ],
- prog => '../lib/perl5db/t/disable-breakpoints-1',
- }
- );
-
- $wrapper->contents_like(qr/
- ^main::\([^:]+:15\):\n
- 15:\s+\$dummy\+\+;\n
- main::\([^:]+:17\):\n
- 17:\s+\$x\ =\ "FourthVal";\n
- /msx,
- 'Test the o AutoTrace command',
- );
-}
-
-# Test the t command with function calls
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 't',
- 'b 18',
- 'c',
- 'x ["foo"]',
- 'x ["bar"]',
- 'q',
- ],
- prog => '../lib/perl5db/t/test-warnLevel-option-1',
- }
- );
-
- $wrapper->contents_like(qr/
- ^main::\([^:]+:28\):\n
- 28:\s+myfunc\(\);\n
- auto\(-\d+\)\s+DB<1>\s+t\n
- Trace\ =\ on\n
- auto\(-\d+\)\s+DB<1>\s+b\ 18\n
- auto\(-\d+\)\s+DB<2>\s+c\n
- main::myfunc\([^:]+:25\):\n
- 25:\s+bar\(\);\n
- /msx,
- 'Test the t command with function calls.',
- );
-}
-
-# Test the o AutoTrace command with function calls
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'o AutoTrace',
- 'b 18',
- 'c',
- 'x ["foo"]',
- 'x ["bar"]',
- 'q',
- ],
- prog => '../lib/perl5db/t/test-warnLevel-option-1',
- }
- );
-
- $wrapper->contents_like(qr/
- ^main::\([^:]+:28\):\n
- 28:\s+myfunc\(\);\n
- auto\(-\d+\)\s+DB<1>\s+o\ AutoTrace\n
- \s+AutoTrace\s+=\s+'1'\n
- auto\(-\d+\)\s+DB<2>\s+b\ 18\n
- auto\(-\d+\)\s+DB<3>\s+c\n
- main::myfunc\([^:]+:25\):\n
- 25:\s+bar\(\);\n
- /msx,
- 'Test the o AutoTrace command with function calls.',
- );
-}
-
-# Test the final message.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'c',
- 'q',
- ],
- prog => '../lib/perl5db/t/test-warnLevel-option-1',
- }
- );
-
- $wrapper->contents_like(qr/
- ^Debugged\ program\ terminated\.
- /msx,
- 'Test the final "Debugged program terminated" message.',
- );
-}
-
-# Test the o inhibit_exit=0 command
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'o inhibit_exit=0',
- 'n',
- 'n',
- 'n',
- 'n',
- 'q',
- ],
- prog => '../lib/perl5db/t/test-warnLevel-option-1',
- }
- );
-
- $wrapper->contents_unlike(qr/
- ^Debugged\ program\ terminated\.
- /msx,
- 'Test the o inhibit_exit=0 command.',
- );
-}
-
-# Test the o PrintRet=1 option
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'o PrintRet=1',
- 'b 29',
- 'c',
- q/$x = 's';/,
- 'b 10',
- 'c',
- 'r',
- 'q',
- ],
- prog => '../lib/perl5db/t/test-PrintRet-option-1',
- }
- );
-
- $wrapper->contents_like(
- qr/scalar context return from main::return_scalar: 20024/,
- "Test o PrintRet=1",
- );
-}
-
-# Test the o PrintRet=0 option
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'o PrintRet=0',
- 'b 29',
- 'c',
- q/$x = 's';/,
- 'b 10',
- 'c',
- 'r',
- 'q',
- ],
- prog => '../lib/perl5db/t/test-PrintRet-option-1',
- }
- );
-
- $wrapper->contents_unlike(
- qr/scalar context/,
- "Test o PrintRet=0",
- );
-}
-
-# Test the o PrintRet=1 option in list context
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'o PrintRet=1',
- 'b 29',
- 'c',
- q/$x = 'l';/,
- 'b 17',
- 'c',
- 'r',
- 'q',
- ],
- prog => '../lib/perl5db/t/test-PrintRet-option-1',
- }
- );
-
- $wrapper->contents_like(
- qr/list context return from main::return_list:\n0\s*'Foo'\n1\s*'Bar'\n2\s*'Baz'\n/,
- "Test o PrintRet=1 in list context",
- );
-}
-
-# Test the o PrintRet=0 option in list context
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'o PrintRet=0',
- 'b 29',
- 'c',
- q/$x = 'l';/,
- 'b 17',
- 'c',
- 'r',
- 'q',
- ],
- prog => '../lib/perl5db/t/test-PrintRet-option-1',
- }
- );
-
- $wrapper->contents_unlike(
- qr/list context/,
- "Test o PrintRet=0 in list context",
- );
-}
-
-# Test the o PrintRet=1 option in void context
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'o PrintRet=1',
- 'b 29',
- 'c',
- q/$x = 'v';/,
- 'b 24',
- 'c',
- 'r',
- 'q',
- ],
- prog => '../lib/perl5db/t/test-PrintRet-option-1',
- }
- );
-
- $wrapper->contents_like(
- qr/void context return from main::return_void/,
- "Test o PrintRet=1 in void context",
- );
-}
-
-# Test the o PrintRet=1 option in void context
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'o PrintRet=0',
- 'b 29',
- 'c',
- q/$x = 'v';/,
- 'b 24',
- 'c',
- 'r',
- 'q',
- ],
- prog => '../lib/perl5db/t/test-PrintRet-option-1',
- }
- );
-
- $wrapper->contents_unlike(
- qr/void context/,
- "Test o PrintRet=0 in void context",
- );
-}
-
-# Test the o frame option.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- # This is to avoid getting the "Debugger program terminated"
- # junk that interferes with the normal output.
- 'o inhibit_exit=0',
- 'b 10',
- 'c',
- 'o frame=255',
- 'c',
- 'q',
- ],
- prog => '../lib/perl5db/t/test-frame-option-1',
- }
- );
-
- $wrapper->contents_like(
- qr/
- in\s*\.=main::my_other_func\(3,\ 1200\)\ from.*?
- out\s*\.=main::my_other_func\(3,\ 1200\)\ from
- /msx,
- "Test o PrintRet=0 in void context",
- );
-}
-
-{ # test t expr
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- # This is to avoid getting the "Debugger program terminated"
- # junk that interferes with the normal output.
- 'o inhibit_exit=0',
- 't fact(3)',
- 'q',
- ],
- prog => '../lib/perl5db/t/fact',
- }
- );
-
- $wrapper->contents_like(
- qr/
- (?:^main::fact.*return\ \$n\ \*\ fact\(\$n\ -\ 1\);.*)
- /msx,
- "Test t expr",
- );
-}
-
-# Test the w for lexical variables expression.
-{
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- # This is to avoid getting the "Debugger program terminated"
- # junk that interferes with the normal output.
- 'w $exp',
- 'n',
- 'n',
- 'n',
- 'n',
- 'q',
- ],
- prog => '../lib/perl5db/t/break-on-dot',
- }
- );
-
- $wrapper->contents_like(
- qr/
-\s+old\ value:\s+'1'\n
-\s+new\ value:\s+'2'\n
- /msx,
- "Test w for lexical values.",
- );
-}
-
-# Test the perldoc command
-# We don't actually run the program, but we need to provide one to the wrapper.
-SKIP:
-{
- $^O eq "linux"
- or skip "man errors aren't especially portable", 1;
- -x '/usr/bin/man'
- or skip "man command seems to be missing", 1;
- local $ENV{LANG} = "C";
- local $ENV{LC_MESSAGES} = "C";
- local $ENV{LC_ALL} = "C";
- my $wrapper = DebugWrap->new(
- {
- cmds =>
- [
- 'perldoc perlrules',
- 'q',
- ],
- prog => '../lib/perl5db/t/fact',
- }
- );
-
- $wrapper->output_like(
- qr/No manual entry for perlrules/,
- 'perldoc command works fine',
- );
-}
+# clean up.
END {
- 1 while unlink ($rc_filename, $out_fn);
+ unlink qw(.perldb db.out);
}
diff --git a/gnu/usr.bin/perl/lib/unicore/NamedSqProv.txt b/gnu/usr.bin/perl/lib/unicore/NamedSqProv.txt
index 2f245a2dace..155fcc92dc8 100644
--- a/gnu/usr.bin/perl/lib/unicore/NamedSqProv.txt
+++ b/gnu/usr.bin/perl/lib/unicore/NamedSqProv.txt
@@ -1,10 +1,10 @@
-# NamedSequencesProv-6.3.0.txt
-# Date: 2013-01-02, 08:37:00 GMT [KW]
+# NamedSequencesProv-5.0.0.txt
+# Date: 2006-05-23, 11:33 PST [KW]
#
# Unicode Character Database
-# Copyright (c) 1991-2013 Unicode, Inc.
+# Copyright (c) 1991-2006 Unicode, Inc.
# For terms of use, see http://www.unicode.org/terms_of_use.html
-# For documentation, see http://www.unicode.org/reports/tr44/
+# For documentation, see UCD.html
#
# Provisional Named Sequences
# Note: This data file contains those named
@@ -14,27 +14,10 @@
# Format:
# Name of Sequence; Code Point Sequence for USI
#
-# Code point sequences in the UCD use spaces as delimiters.
-# The corresponding format for a USI in ISO/IEC 10646 uses
-# comma delimitation and angle brackets. Thus, a named sequence
-# of the form:
-#
-# EXAMPLE NAME;1000 1001 1002
-#
-# in this data file, would correspond to a 10646 USI as follows:
-#
-# <1000, 1001, 1002>
-#
# Note: The order of entries in this file is not significant.
# However, entries are generally in script order corresponding
# to block order in the Unicode Standard, to make it easier
-# to find entries currently in the list.
-
-# ================================================
-
-# Provisional entries for NamedSequences.txt.
-
-# There are currently no provisional named sequences.
+# to find entries in the list.
# ================================================
@@ -50,8 +33,52 @@
# LATIN SMALL LETTER A WITH ACUTE AND OGONEK;00E1 0328
#
# This entry was removed because the sequence was not in NFC,
-# as required. It was replaced with the NFC version of
-# the sequence, based on the Lithuanian additions accepted
-# for Unicode 5.0.
+# as required. It will be replaced with the NFC version of
+# the sequence, based on the Lithuanian additions proposed
+# here for a future version of the standard.
+
+# ================================================
+
+# Provisional entries for NamedSequences.txt.
+
+# Proposed additions for Lithuanian. 2006-05-18
+
+LATIN CAPITAL LETTER A WITH OGONEK AND ACUTE;0104 0301
+LATIN SMALL LETTER A WITH OGONEK AND ACUTE;0105 0301
+LATIN CAPITAL LETTER A WITH OGONEK AND TILDE;0104 0303
+LATIN SMALL LETTER A WITH OGONEK AND TILDE;0105 0303
+LATIN CAPITAL LETTER E WITH OGONEK AND ACUTE;0118 0301
+LATIN SMALL LETTER E WITH OGONEK AND ACUTE;0119 0301
+LATIN CAPITAL LETTER E WITH OGONEK AND TILDE;0118 0303
+LATIN SMALL LETTER E WITH OGONEK AND TILDE;0119 0303
+LATIN CAPITAL LETTER E WITH DOT ABOVE AND ACUTE;0116 0301
+LATIN SMALL LETTER E WITH DOT ABOVE AND ACUTE;0117 0301
+LATIN CAPITAL LETTER E WITH DOT ABOVE AND TILDE;0116 0303
+LATIN SMALL LETTER E WITH DOT ABOVE AND TILDE;0117 0303
+LATIN SMALL LETTER I WITH DOT ABOVE AND GRAVE;0069 0307 0300
+LATIN SMALL LETTER I WITH DOT ABOVE AND TILDE;0069 0307 0303
+LATIN CAPITAL LETTER I WITH OGONEK AND ACUTE;012E 0301
+LATIN SMALL LETTER I WITH OGONEK AND DOT ABOVE AND ACUTE;012F 0307 0301
+LATIN CAPITAL LETTER I WITH OGONEK AND TILDE;012E 0303
+LATIN SMALL LETTER I WITH OGONEK AND DOT ABOVE AND TILDE;012F 0307 0303
+LATIN CAPITAL LETTER J WITH TILDE;004A 0303
+LATIN SMALL LETTER J WITH DOT ABOVE AND TILDE;006A 0307 0303
+LATIN CAPITAL LETTER L WITH TILDE;004C 0303
+LATIN SMALL LETTER L WITH TILDE;006C 0303
+LATIN CAPITAL LETTER M WITH TILDE;004D 0303
+LATIN SMALL LETTER M WITH TILDE;006D 0303
+LATIN CAPITAL LETTER R WITH TILDE;0052 0303
+LATIN SMALL LETTER R WITH TILDE;0072 0303
+LATIN CAPITAL LETTER U WITH OGONEK AND ACUTE;0172 0301
+LATIN SMALL LETTER U WITH OGONEK AND ACUTE;0173 0301
+LATIN CAPITAL LETTER U WITH OGONEK AND TILDE;0172 0303
+LATIN SMALL LETTER U WITH OGONEK AND TILDE;0173 0303
+LATIN CAPITAL LETTER U WITH MACRON AND ACUTE;016A 0301
+LATIN SMALL LETTER U WITH MACRON AND ACUTE;016B 0301
+LATIN CAPITAL LETTER U WITH MACRON AND TILDE;016A 0303
+LATIN SMALL LETTER U WITH MACRON AND TILDE;016B 0303
+
+# Proposed additions for Tamil.
-# EOF
+TAMIL LETTER KSSA;0B95 0BCD 0BB7
+TAMIL LETTER SHRII;0BB6 0BCD 0BB0 0BC0
diff --git a/gnu/usr.bin/perl/mad/Nomad.pm b/gnu/usr.bin/perl/mad/Nomad.pm
index eaac474b783..79da555a4cc 100755
--- a/gnu/usr.bin/perl/mad/Nomad.pm
+++ b/gnu/usr.bin/perl/mad/Nomad.pm
@@ -2838,7 +2838,6 @@ package PLXML::op_enterwrite;
package PLXML::op_leavewrite;
package PLXML::op_prtf;
package PLXML::op_print;
-package PLXML::op_say;
package PLXML::op_sysopen;
package PLXML::op_sysseek;
package PLXML::op_sysread;
diff --git a/gnu/usr.bin/perl/mad/P5AST.pm b/gnu/usr.bin/perl/mad/P5AST.pm
index 13a35e18d07..eaf3bd3e209 100644
--- a/gnu/usr.bin/perl/mad/P5AST.pm
+++ b/gnu/usr.bin/perl/mad/P5AST.pm
@@ -370,7 +370,6 @@ package P5AST::op_enterwrite; @ISA = 'P5AST::baseop_unop';
package P5AST::op_leavewrite; @ISA = 'P5AST::unop';
package P5AST::op_prtf; @ISA = 'P5AST::listop';
package P5AST::op_print; @ISA = 'P5AST::listop';
-package P5AST::op_say; @ISA = 'P5AST::listop';
package P5AST::op_sysopen; @ISA = 'P5AST::listop';
package P5AST::op_sysseek; @ISA = 'P5AST::listop';
package P5AST::op_sysread; @ISA = 'P5AST::listop';
diff --git a/gnu/usr.bin/perl/mad/PLXML.pm b/gnu/usr.bin/perl/mad/PLXML.pm
index ad778601c78..feaf58ff779 100644
--- a/gnu/usr.bin/perl/mad/PLXML.pm
+++ b/gnu/usr.bin/perl/mad/PLXML.pm
@@ -2513,16 +2513,6 @@ sub flags { 'ims@' }
sub args { 'F? L' }
-package PLXML::op_say;
-
-our @ISA = ('PLXML::listop');
-
-sub key { 'say' }
-sub desc { 'say' }
-sub check { 'ck_listiob' }
-sub flags { 'ims@' }
-sub args { 'F? L' }
-
package PLXML::op_sysopen;
@@ -3451,6 +3441,10 @@ sub args { 'S S S' }
# Time calls.
+# NOTE: MacOS patches the 'i' of time() away later when the interpreter
+# is created because in MacOS time() is already returning times > 2**31-1,
+# that is, non-integers.
+
package PLXML::op_time;
our @ISA = ('PLXML::baseop');
diff --git a/gnu/usr.bin/perl/mad/t/p55.t b/gnu/usr.bin/perl/mad/t/p55.t
index fbfa4512202..de18a87f71b 100644
--- a/gnu/usr.bin/perl/mad/t/p55.t
+++ b/gnu/usr.bin/perl/mad/t/p55.t
@@ -64,17 +64,22 @@ use Test::Differences;
our %failing = map { $_, 1 } qw|
../t/comp/require.t
+../t/op/array.t
+../t/op/local.t
+../t/op/substr.t
+
+../t/comp/parser.t
+
../t/op/switch.t
../t/op/attrhand.t
../t/op/symbolcache.t
-../t/op/exec.t
+../t/op/threads.t
-../t/op/state.t
-../t/op/each_array.t
-../t/lib/cygwin.t
+../t/op/exec.t
+../t/io/say.t
|;
my @files;
@@ -144,10 +149,10 @@ eval { require 5.005 }
sub PerlIO::F_UTF8 () { 0x00008000 } # from perliol.h
BEGIN { PerlIO::Layer->find("encoding",1);}
########
-# from ../t/op/array.t
+# TODO from ../t/op/array.t
$[ = 1
########
-# from t/comp/parser.t
+# TODO from t/comp/parser.t
$x = 1 for ($[) = 0;
########
# from t/op/getppid.t
diff --git a/gnu/usr.bin/perl/madly.c b/gnu/usr.bin/perl/madly.c
index d7037328163..11e2e376ded 100644
--- a/gnu/usr.bin/perl/madly.c
+++ b/gnu/usr.bin/perl/madly.c
@@ -19,8 +19,8 @@
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: nil
+ * indent-tabs-mode: t
* End:
*
- * ex: set ts=8 sts=4 sw=4 et:
+ * ex: set ts=8 sts=4 sw=4 noet:
*/
diff --git a/gnu/usr.bin/perl/mathoms.c b/gnu/usr.bin/perl/mathoms.c
index 1132ac80f00..cccaa924859 100644
--- a/gnu/usr.bin/perl/mathoms.c
+++ b/gnu/usr.bin/perl/mathoms.c
@@ -1,7 +1,6 @@
/* mathoms.c
*
- * Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010,
- * 2011, 2012 by Larry Wall and others
+ * Copyright (C) 2005, 2006, 2007, 2007, 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.
@@ -9,15 +8,13 @@
*/
/*
- * Anything that Hobbits had no immediate use for, but were unwilling to
- * throw away, they called a mathom. Their dwellings were apt to become
- * rather crowded with mathoms, and many of the presents that passed from
- * hand to hand were of that sort.
- *
- * [p.5 of _The Lord of the Rings_: "Prologue"]
+ * "Anything that Hobbits had no immediate use for, but were unwilling to
+ * throw away, they called a mathom. Their dwellings were apt to become
+ * rather crowded with mathoms, and many of the presents that passed from
+ * hand to hand were of that sort."
*/
-
+#ifndef NO_MATHOMS
/*
* This file contains mathoms, various binary artifacts from previous
@@ -26,54 +23,41 @@
*
* SMP - Oct. 24, 2005
*
- * The compilation of this file can be suppressed; see INSTALL
- *
*/
#include "EXTERN.h"
#define PERL_IN_MATHOMS_C
#include "perl.h"
-#ifdef NO_MATHOMS
-/* ..." warning: ISO C forbids an empty source file"
- So make sure we have something in here by processing the headers anyway.
- */
-#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_ 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 IV Perl_sv_2iv(pTHX_ register SV *sv);
+PERL_CALLCONV UV Perl_sv_2uv(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 void Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen);
-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 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 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_ SV *sv);
+PERL_CALLCONV STRLEN Perl_sv_utf8_upgrade(pTHX_ register 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);
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, 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 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 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);
@@ -81,21 +65,7 @@ PERL_CALLCONV void Perl_sv_usepvn_mg(pTHX_ SV *sv, char *ptr, STRLEN len);
PERL_CALLCONV void Perl_sv_usepvn(pTHX_ SV *sv, char *ptr, STRLEN len);
PERL_CALLCONV int Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...);
PERL_CALLCONV int Perl_printf_nocontext(const char *format, ...);
-PERL_CALLCONV int Perl_magic_setglob(pTHX_ SV* sv, MAGIC* mg);
-PERL_CALLCONV AV * Perl_newAV(pTHX);
-PERL_CALLCONV HV * Perl_newHV(pTHX);
-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_ SV *sv1, SV *sv2);
-PERL_CALLCONV char * Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp);
-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.
@@ -120,24 +90,19 @@ being zero. See C<SvROK_off>.
void
Perl_sv_unref(pTHX_ SV *sv)
{
- PERL_ARGS_ASSERT_SV_UNREF;
-
sv_unref_flags(sv, 0);
}
/*
=for apidoc sv_taint
-Taint an SV. Use C<SvTAINTED_on> instead.
-
+Taint an SV. Use C<SvTAINTED_on> instead.
=cut
*/
void
Perl_sv_taint(pTHX_ SV *sv)
{
- PERL_ARGS_ASSERT_SV_TAINT;
-
sv_magic((sv), NULL, PERL_MAGIC_taint, NULL, 0);
}
@@ -146,10 +111,8 @@ Perl_sv_taint(pTHX_ SV *sv)
*/
IV
-Perl_sv_2iv(pTHX_ SV *sv)
+Perl_sv_2iv(pTHX_ register SV *sv)
{
- PERL_ARGS_ASSERT_SV_2IV;
-
return sv_2iv_flags(sv, SV_GMAGIC);
}
@@ -158,49 +121,32 @@ Perl_sv_2iv(pTHX_ SV *sv)
*/
UV
-Perl_sv_2uv(pTHX_ SV *sv)
+Perl_sv_2uv(pTHX_ register SV *sv)
{
- PERL_ARGS_ASSERT_SV_2UV;
-
return sv_2uv_flags(sv, SV_GMAGIC);
}
-/* sv_2nv() is now a macro using Perl_sv_2nv_flags();
- * this function provided for binary compatibility only
- */
-
-NV
-Perl_sv_2nv(pTHX_ SV *sv)
-{
- return sv_2nv_flags(sv, SV_GMAGIC);
-}
-
-
/* sv_2pv() is now a macro using Perl_sv_2pv_flags();
* this function provided for binary compatibility only
*/
char *
-Perl_sv_2pv(pTHX_ SV *sv, STRLEN *lp)
+Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
{
- PERL_ARGS_ASSERT_SV_2PV;
-
return sv_2pv_flags(sv, lp, SV_GMAGIC);
}
/*
=for apidoc sv_2pv_nolen
-Like C<sv_2pv()>, but doesn't return the length too. You should usually
+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_ SV *sv)
+Perl_sv_2pv_nolen(pTHX_ register SV *sv)
{
- PERL_ARGS_ASSERT_SV_2PV_NOLEN;
return sv_2pv(sv, NULL);
}
@@ -216,10 +162,8 @@ Usually accessed via the C<SvPVbyte_nolen> macro.
*/
char *
-Perl_sv_2pvbyte_nolen(pTHX_ SV *sv)
+Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
{
- PERL_ARGS_ASSERT_SV_2PVBYTE_NOLEN;
-
return sv_2pvbyte(sv, NULL);
}
@@ -235,10 +179,8 @@ Usually accessed via the C<SvPVutf8_nolen> macro.
*/
char *
-Perl_sv_2pvutf8_nolen(pTHX_ SV *sv)
+Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
{
- PERL_ARGS_ASSERT_SV_2PVUTF8_NOLEN;
-
return sv_2pvutf8(sv, NULL);
}
@@ -247,16 +189,14 @@ Perl_sv_2pvutf8_nolen(pTHX_ SV *sv)
Undo various types of fakery on an SV: 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. See also C<sv_force_normal_flags>.
+an xpvmg. See also C<sv_force_normal_flags>.
=cut
*/
void
-Perl_sv_force_normal(pTHX_ SV *sv)
+Perl_sv_force_normal(pTHX_ register SV *sv)
{
- PERL_ARGS_ASSERT_SV_FORCE_NORMAL;
-
sv_force_normal_flags(sv, 0);
}
@@ -265,10 +205,8 @@ Perl_sv_force_normal(pTHX_ SV *sv)
*/
void
-Perl_sv_setsv(pTHX_ SV *dstr, SV *sstr)
+Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
{
- PERL_ARGS_ASSERT_SV_SETSV;
-
sv_setsv_flags(dstr, sstr, SV_GMAGIC);
}
@@ -279,8 +217,6 @@ Perl_sv_setsv(pTHX_ SV *dstr, SV *sstr)
void
Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
{
- PERL_ARGS_ASSERT_SV_CATPVN;
-
sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
}
@@ -293,10 +229,8 @@ Like C<sv_catpvn>, but also handles 'set' magic.
*/
void
-Perl_sv_catpvn_mg(pTHX_ SV *sv, const char *ptr, STRLEN len)
+Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
{
- PERL_ARGS_ASSERT_SV_CATPVN_MG;
-
sv_catpvn_flags(sv,ptr,len,SV_GMAGIC|SV_SMAGIC);
}
@@ -305,10 +239,8 @@ Perl_sv_catpvn_mg(pTHX_ SV *sv, const char *ptr, STRLEN len)
*/
void
-Perl_sv_catsv(pTHX_ SV *dstr, SV *sstr)
+Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
{
- PERL_ARGS_ASSERT_SV_CATSV;
-
sv_catsv_flags(dstr, sstr, SV_GMAGIC);
}
@@ -321,10 +253,8 @@ Like C<sv_catsv>, but also handles 'set' magic.
*/
void
-Perl_sv_catsv_mg(pTHX_ SV *dsv, SV *ssv)
+Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
{
- PERL_ARGS_ASSERT_SV_CATSV_MG;
-
sv_catsv_flags(dsv,ssv,SV_GMAGIC|SV_SMAGIC);
}
@@ -332,16 +262,14 @@ Perl_sv_catsv_mg(pTHX_ SV *dsv, SV *ssv)
=for apidoc sv_iv
A private implementation of the C<SvIVx> macro for compilers which can't
-cope with complex macro expressions. Always use the macro instead.
+cope with complex macro expressions. Always use the macro instead.
=cut
*/
IV
-Perl_sv_iv(pTHX_ SV *sv)
+Perl_sv_iv(pTHX_ register SV *sv)
{
- PERL_ARGS_ASSERT_SV_IV;
-
if (SvIOK(sv)) {
if (SvIsUV(sv))
return (IV)SvUVX(sv);
@@ -354,16 +282,14 @@ Perl_sv_iv(pTHX_ SV *sv)
=for apidoc sv_uv
A private implementation of the C<SvUVx> macro for compilers which can't
-cope with complex macro expressions. Always use the macro instead.
+cope with complex macro expressions. Always use the macro instead.
=cut
*/
UV
-Perl_sv_uv(pTHX_ SV *sv)
+Perl_sv_uv(pTHX_ register SV *sv)
{
- PERL_ARGS_ASSERT_SV_UV;
-
if (SvIOK(sv)) {
if (SvIsUV(sv))
return SvUVX(sv);
@@ -376,16 +302,14 @@ Perl_sv_uv(pTHX_ SV *sv)
=for apidoc sv_nv
A private implementation of the C<SvNVx> macro for compilers which can't
-cope with complex macro expressions. Always use the macro instead.
+cope with complex macro expressions. Always use the macro instead.
=cut
*/
NV
-Perl_sv_nv(pTHX_ SV *sv)
+Perl_sv_nv(pTHX_ register SV *sv)
{
- PERL_ARGS_ASSERT_SV_NV;
-
if (SvNOK(sv))
return SvNVX(sv);
return sv_2nv(sv);
@@ -399,7 +323,7 @@ Use the C<SvPV_nolen> macro instead
=for apidoc sv_pvn
A private implementation of the C<SvPV> macro for compilers which can't
-cope with complex macro expressions. Always use the macro instead.
+cope with complex macro expressions. Always use the macro instead.
=cut
*/
@@ -407,8 +331,6 @@ cope with complex macro expressions. Always use the macro instead.
char *
Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
{
- PERL_ARGS_ASSERT_SV_PVN;
-
if (SvPOK(sv)) {
*lp = SvCUR(sv);
return SvPVX(sv);
@@ -418,10 +340,8 @@ Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
char *
-Perl_sv_pvn_nomg(pTHX_ SV *sv, STRLEN *lp)
+Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
{
- PERL_ARGS_ASSERT_SV_PVN_NOMG;
-
if (SvPOK(sv)) {
*lp = SvCUR(sv);
return SvPVX(sv);
@@ -436,8 +356,6 @@ Perl_sv_pvn_nomg(pTHX_ SV *sv, STRLEN *lp)
char *
Perl_sv_pv(pTHX_ SV *sv)
{
- PERL_ARGS_ASSERT_SV_PV;
-
if (SvPOK(sv))
return SvPVX(sv);
@@ -451,8 +369,6 @@ Perl_sv_pv(pTHX_ SV *sv)
char *
Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
{
- PERL_ARGS_ASSERT_SV_PVN_FORCE;
-
return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
}
@@ -463,8 +379,6 @@ Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
char *
Perl_sv_pvbyte(pTHX_ SV *sv)
{
- PERL_ARGS_ASSERT_SV_PVBYTE;
-
sv_utf8_downgrade(sv, FALSE);
return sv_pv(sv);
}
@@ -477,7 +391,7 @@ Use C<SvPVbyte_nolen> instead.
=for apidoc sv_pvbyten
A private implementation of the C<SvPVbyte> macro for compilers
-which can't cope with complex macro expressions. Always use the macro
+which can't cope with complex macro expressions. Always use the macro
instead.
=cut
@@ -486,8 +400,6 @@ instead.
char *
Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
{
- PERL_ARGS_ASSERT_SV_PVBYTEN;
-
sv_utf8_downgrade(sv, FALSE);
return sv_pvn(sv,lp);
}
@@ -499,8 +411,6 @@ Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
char *
Perl_sv_pvutf8(pTHX_ SV *sv)
{
- PERL_ARGS_ASSERT_SV_PVUTF8;
-
sv_utf8_upgrade(sv);
return sv_pv(sv);
}
@@ -513,7 +423,7 @@ Use the C<SvPVutf8_nolen> macro instead
=for apidoc sv_pvutf8n
A private implementation of the C<SvPVutf8> macro for compilers
-which can't cope with complex macro expressions. Always use the macro
+which can't cope with complex macro expressions. Always use the macro
instead.
=cut
@@ -522,8 +432,6 @@ instead.
char *
Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
{
- PERL_ARGS_ASSERT_SV_PVUTF8N;
-
sv_utf8_upgrade(sv);
return sv_pvn(sv,lp);
}
@@ -533,10 +441,8 @@ Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
*/
STRLEN
-Perl_sv_utf8_upgrade(pTHX_ SV *sv)
+Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
{
- PERL_ARGS_ASSERT_SV_UTF8_UPGRADE;
-
return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
}
@@ -544,19 +450,9 @@ int
Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...)
{
dTHXs;
- int ret = 0;
va_list(arglist);
-
- /* Easier to special case this here than in embed.pl. (Look at what it
- generates for proto.h) */
-#ifdef PERL_IMPLICIT_CONTEXT
- PERL_ARGS_ASSERT_FPRINTF_NOCONTEXT;
-#endif
-
va_start(arglist, format);
- ret = PerlIO_vprintf(stream, format, arglist);
- va_end(arglist);
- return ret;
+ return PerlIO_vprintf(stream, format, arglist);
}
int
@@ -564,16 +460,8 @@ Perl_printf_nocontext(const char *format, ...)
{
dTHX;
va_list(arglist);
- int ret = 0;
-
-#ifdef PERL_IMPLICIT_CONTEXT
- PERL_ARGS_ASSERT_PRINTF_NOCONTEXT;
-#endif
-
va_start(arglist, format);
- ret = PerlIO_vprintf(PerlIO_stdout(), format, arglist);
- va_end(arglist);
- return ret;
+ return PerlIO_vprintf(PerlIO_stdout(), format, arglist);
}
#if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL))
@@ -597,8 +485,6 @@ Perl_huge(void)
void
Perl_gv_fullname(pTHX_ SV *sv, const GV *gv)
{
- PERL_ARGS_ASSERT_GV_FULLNAME;
-
gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
}
@@ -606,31 +492,25 @@ Perl_gv_fullname(pTHX_ SV *sv, const GV *gv)
void
Perl_gv_efullname(pTHX_ SV *sv, const GV *gv)
{
- PERL_ARGS_ASSERT_GV_EFULLNAME;
-
gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
}
void
Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
{
- PERL_ARGS_ASSERT_GV_FULLNAME3;
-
gv_fullname4(sv, gv, prefix, TRUE);
}
void
Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
{
- PERL_ARGS_ASSERT_GV_EFULLNAME3;
-
gv_efullname4(sv, gv, prefix, TRUE);
}
/*
=for apidoc gv_fetchmethod
-See L</gv_fetchmethod_autoload>.
+See L<gv_fetchmethod_autoload>.
=cut
*/
@@ -638,45 +518,55 @@ See L</gv_fetchmethod_autoload>.
GV *
Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name)
{
- PERL_ARGS_ASSERT_GV_FETCHMETHOD;
-
return gv_fetchmethod_autoload(stash, name, TRUE);
}
HE *
Perl_hv_iternext(pTHX_ HV *hv)
{
- PERL_ARGS_ASSERT_HV_ITERNEXT;
-
return hv_iternext_flags(hv, 0);
}
void
Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
{
- PERL_ARGS_ASSERT_HV_MAGIC;
+ sv_magic((SV*)hv, (SV*)gv, how, NULL, 0);
+}
- sv_magic(MUTABLE_SV(hv), MUTABLE_SV(gv), how, NULL, 0);
+AV *
+Perl_av_fake(pTHX_ register I32 size, register SV **strp)
+{
+ register SV** ary;
+ register AV * const av = (AV*)newSV_type(SVt_PVAV);
+ Newx(ary,size+1,SV*);
+ AvALLOC(av) = ary;
+ Copy(strp,ary,size,SV*);
+ AvREIFY_only(av);
+ AvARRAY(av) = ary;
+ AvFILLp(av) = size - 1;
+ AvMAX(av) = size - 1;
+ while (size--) {
+ assert (*strp);
+ SvTEMP_off(*strp);
+ strp++;
+ }
+ return av;
}
bool
-Perl_do_open(pTHX_ GV *gv, const char *name, I32 len, int as_raw,
+Perl_do_open(pTHX_ GV *gv, register const char *name, I32 len, int as_raw,
int rawmode, int rawperm, PerlIO *supplied_fp)
{
- PERL_ARGS_ASSERT_DO_OPEN;
-
return do_openn(gv, name, len, as_raw, rawmode, rawperm,
supplied_fp, (SV **) NULL, 0);
}
bool
-Perl_do_open9(pTHX_ GV *gv, const char *name, I32 len, int
+Perl_do_open9(pTHX_ GV *gv, register const char *name, I32 len, int
as_raw,
int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs,
I32 num_svs)
{
- PERL_ARGS_ASSERT_DO_OPEN9;
-
PERL_UNUSED_ARG(num_svs);
return do_openn(gv, name, len, as_raw, rawmode, rawperm,
supplied_fp, &svs, 1);
@@ -689,9 +579,6 @@ Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode)
* This is a stub for any XS code which might have been calling it.
*/
const char *name = ":raw";
-
- PERL_ARGS_ASSERT_DO_BINMODE;
-
#ifdef PERLIO_USING_CRLF
if (!(mode & O_BINARY))
name = ":crlf";
@@ -701,14 +588,20 @@ Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode)
#ifndef OS2
bool
-Perl_do_aexec(pTHX_ SV *really, SV **mark, SV **sp)
+Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp)
{
- PERL_ARGS_ASSERT_DO_AEXEC;
-
return do_aexec5(really, mark, sp, 0, 0);
}
#endif
+#ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION
+bool
+Perl_do_exec(pTHX_ const char *cmd)
+{
+ return do_exec3(cmd,0,0);
+}
+#endif
+
/* Backwards compatibility. */
int
Perl_init_i18nl14n(pTHX_ int printwarn)
@@ -716,919 +609,711 @@ Perl_init_i18nl14n(pTHX_ int printwarn)
return init_i18nl10n(printwarn);
}
-bool
-Perl_is_utf8_string_loc(pTHX_ const U8 *s, STRLEN len, const U8 **ep)
+OP *
+Perl_oopsCV(pTHX_ OP *o)
{
- PERL_ARGS_ASSERT_IS_UTF8_STRING_LOC;
-
- return is_utf8_string_loclen(s, len, ep, 0);
+ Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
+ /* STUB */
+ PERL_UNUSED_ARG(o);
+ NORETURN_FUNCTION_END;
}
-/*
-=for apidoc sv_nolocking
-
-Dummy routine which "locks" an SV when there is no locking module present.
-Exists to avoid test for a NULL function pointer and because it could
-potentially warn under some level of strict-ness.
-
-"Superseded" by sv_nosharing().
-
-=cut
-*/
-
-void
-Perl_sv_nolocking(pTHX_ SV *sv)
+PP(pp_padany)
{
- PERL_UNUSED_CONTEXT;
- PERL_UNUSED_ARG(sv);
+ DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
}
-
-/*
-=for apidoc sv_nounlocking
-
-Dummy routine which "unlocks" an SV when there is no locking module present.
-Exists to avoid test for a NULL function pointer and because it could
-potentially warn under some level of strict-ness.
-
-"Superseded" by sv_nosharing().
-
-=cut
-*/
-
-void
-Perl_sv_nounlocking(pTHX_ SV *sv)
+PP(pp_mapstart)
{
- PERL_UNUSED_CONTEXT;
- PERL_UNUSED_ARG(sv);
+ DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
}
-void
-Perl_save_long(pTHX_ long int *longp)
+/* These ops all have the same body as pp_null. */
+PP(pp_scalar)
{
dVAR;
-
- PERL_ARGS_ASSERT_SAVE_LONG;
-
- SSCHECK(3);
- SSPUSHLONG(*longp);
- SSPUSHPTR(longp);
- SSPUSHUV(SAVEt_LONG);
+ return NORMAL;
}
-void
-Perl_save_iv(pTHX_ IV *ivp)
+PP(pp_regcmaybe)
{
dVAR;
-
- PERL_ARGS_ASSERT_SAVE_IV;
-
- SSCHECK(3);
- SSPUSHIV(*ivp);
- SSPUSHPTR(ivp);
- SSPUSHUV(SAVEt_IV);
+ return NORMAL;
}
-void
-Perl_save_nogv(pTHX_ GV *gv)
+PP(pp_lineseq)
{
dVAR;
-
- PERL_ARGS_ASSERT_SAVE_NOGV;
-
- SSCHECK(2);
- SSPUSHPTR(gv);
- SSPUSHUV(SAVEt_NSTAB);
+ return NORMAL;
}
-void
-Perl_save_list(pTHX_ SV **sarg, I32 maxsarg)
+PP(pp_scope)
{
dVAR;
- I32 i;
-
- PERL_ARGS_ASSERT_SAVE_LIST;
-
- for (i = 1; i <= maxsarg; 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 */
- SSPUSHUV(SAVEt_ITEM);
- }
+ return NORMAL;
}
-/*
-=for apidoc sv_usepvn_mg
-
-Like C<sv_usepvn>, but also handles 'set' magic.
-
-=cut
-*/
-
-void
-Perl_sv_usepvn_mg(pTHX_ SV *sv, char *ptr, STRLEN len)
+/* Ops that are calls to do_kv. */
+PP(pp_values)
{
- PERL_ARGS_ASSERT_SV_USEPVN_MG;
-
- sv_usepvn_flags(sv,ptr,len, SV_SMAGIC);
+ return do_kv();
}
-/*
-=for apidoc sv_usepvn
-
-Tells an SV to use C<ptr> to find its string value. Implemented by
-calling C<sv_usepvn_flags> with C<flags> of 0, hence does not handle 'set'
-magic. See C<sv_usepvn_flags>.
-
-=cut
-*/
-
-void
-Perl_sv_usepvn(pTHX_ SV *sv, char *ptr, STRLEN len)
+PP(pp_keys)
{
- PERL_ARGS_ASSERT_SV_USEPVN;
-
- sv_usepvn_flags(sv,ptr,len, 0);
+ return do_kv();
}
-/*
-=for apidoc unpack_str
-
-The engine implementing unpack() Perl function. Note: parameters strbeg,
-new_s and ocnt are not used. This call should not be used, use
-unpackstring instead.
-
-=cut */
-
-I32
-Perl_unpack_str(pTHX_ const char *pat, const char *patend, const char *s,
- const char *strbeg, const char *strend, char **new_s, I32 ocnt,
- U32 flags)
+/* Ops that are simply calls to other ops. */
+PP(pp_dump)
{
- PERL_ARGS_ASSERT_UNPACK_STR;
-
- PERL_UNUSED_ARG(strbeg);
- PERL_UNUSED_ARG(new_s);
- PERL_UNUSED_ARG(ocnt);
-
- return unpackstring(pat, patend, s, strend, flags);
+ return pp_goto();
+ /*NOTREACHED*/
}
-/*
-=for apidoc pack_cat
-
-The engine implementing pack() Perl function. Note: parameters
-next_in_list and flags are not used. This call should not be used; use
-packlist instead.
-
-=cut
-*/
-
-void
-Perl_pack_cat(pTHX_ SV *cat, const char *pat, const char *patend, SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
+PP(pp_dofile)
{
- PERL_ARGS_ASSERT_PACK_CAT;
-
- PERL_UNUSED_ARG(next_in_list);
- PERL_UNUSED_ARG(flags);
-
- packlist(cat, pat, patend, beglist, endlist);
+ return pp_require();
}
-HE *
-Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash)
+PP(pp_dbmclose)
{
- return (HE *)hv_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISSTORE, val, hash);
+ return pp_untie();
}
-bool
-Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
+PP(pp_read)
{
- PERL_ARGS_ASSERT_HV_EXISTS_ENT;
-
- return hv_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISEXISTS, 0, hash)
- ? TRUE : FALSE;
+ return pp_sysread();
}
-HE *
-Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, U32 hash)
+PP(pp_recv)
{
- PERL_ARGS_ASSERT_HV_FETCH_ENT;
-
- return (HE *)hv_common(hv, keysv, NULL, 0, 0,
- (lval ? HV_FETCH_LVALUE : 0), NULL, hash);
+ return pp_sysread();
}
-SV *
-Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
+PP(pp_seek)
{
- PERL_ARGS_ASSERT_HV_DELETE_ENT;
-
- return MUTABLE_SV(hv_common(hv, keysv, NULL, 0, 0, flags | HV_DELETE, NULL,
- hash));
+ return pp_sysseek();
}
-SV**
-Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash,
- int flags)
+PP(pp_fcntl)
{
- return (SV**) hv_common(hv, NULL, key, klen, flags,
- (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
+ return pp_ioctl();
}
-SV**
-Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen_i32, SV *val, U32 hash)
+PP(pp_gsockopt)
{
- STRLEN klen;
- int flags;
-
- if (klen_i32 < 0) {
- klen = -klen_i32;
- flags = HVhek_UTF8;
- } else {
- klen = klen_i32;
- flags = 0;
- }
- return (SV **) hv_common(hv, NULL, key, klen, flags,
- (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
+ return pp_ssockopt();
}
-bool
-Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen_i32)
+PP(pp_getsockname)
{
- STRLEN klen;
- int flags;
-
- PERL_ARGS_ASSERT_HV_EXISTS;
-
- if (klen_i32 < 0) {
- klen = -klen_i32;
- flags = HVhek_UTF8;
- } else {
- klen = klen_i32;
- flags = 0;
- }
- return hv_common(hv, NULL, key, klen, flags, HV_FETCH_ISEXISTS, 0, 0)
- ? TRUE : FALSE;
+ return pp_getpeername();
}
-SV**
-Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval)
+PP(pp_lstat)
{
- STRLEN klen;
- int flags;
-
- PERL_ARGS_ASSERT_HV_FETCH;
-
- if (klen_i32 < 0) {
- klen = -klen_i32;
- flags = HVhek_UTF8;
- } else {
- klen = klen_i32;
- flags = 0;
- }
- return (SV **) hv_common(hv, NULL, key, klen, flags,
- lval ? (HV_FETCH_JUST_SV | HV_FETCH_LVALUE)
- : HV_FETCH_JUST_SV, NULL, 0);
+ return pp_stat();
}
-SV *
-Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 flags)
+PP(pp_fteowned)
{
- STRLEN klen;
- int k_flags;
-
- PERL_ARGS_ASSERT_HV_DELETE;
-
- if (klen_i32 < 0) {
- klen = -klen_i32;
- k_flags = HVhek_UTF8;
- } else {
- klen = klen_i32;
- k_flags = 0;
- }
- return MUTABLE_SV(hv_common(hv, NULL, key, klen, k_flags, flags | HV_DELETE,
- NULL, 0));
+ return pp_ftrowned();
}
-/* Functions after here were made mathoms post 5.10.0 but pre 5.8.9 */
-
-AV *
-Perl_newAV(pTHX)
+PP(pp_ftbinary)
{
- return MUTABLE_AV(newSV_type(SVt_PVAV));
- /* sv_upgrade does AvREAL_only():
- AvALLOC(av) = 0;
- AvARRAY(av) = NULL;
- AvMAX(av) = AvFILLp(av) = -1; */
+ return pp_fttext();
}
-HV *
-Perl_newHV(pTHX)
+PP(pp_localtime)
{
- HV * const hv = MUTABLE_HV(newSV_type(SVt_PVHV));
- assert(!SvOK(hv));
-
- return hv;
+ return pp_gmtime();
}
-void
-Perl_sv_insert(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len,
- const char *const little, const STRLEN littlelen)
+PP(pp_shmget)
{
- PERL_ARGS_ASSERT_SV_INSERT;
- sv_insert_flags(bigstr, offset, len, little, littlelen, SV_GMAGIC);
+ return pp_semget();
}
-void
-Perl_save_freesv(pTHX_ SV *sv)
+PP(pp_shmctl)
{
- dVAR;
- save_freesv(sv);
+ return pp_semctl();
}
-void
-Perl_save_mortalizesv(pTHX_ SV *sv)
+PP(pp_shmread)
{
- dVAR;
-
- PERL_ARGS_ASSERT_SAVE_MORTALIZESV;
-
- save_mortalizesv(sv);
+ return pp_shmwrite();
}
-void
-Perl_save_freeop(pTHX_ OP *o)
+PP(pp_msgget)
{
- dVAR;
- save_freeop(o);
+ return pp_semget();
}
-void
-Perl_save_freepv(pTHX_ char *pv)
+PP(pp_msgctl)
{
- dVAR;
- save_freepv(pv);
+ return pp_semctl();
}
-void
-Perl_save_op(pTHX)
+PP(pp_ghbyname)
{
- dVAR;
- save_op();
+ return pp_ghostent();
}
-#ifdef PERL_DONT_CREATE_GVSV
-GV *
-Perl_gv_SVadd(pTHX_ GV *gv)
+PP(pp_ghbyaddr)
{
- return gv_SVadd(gv);
+ return pp_ghostent();
}
-#endif
-GV *
-Perl_gv_AVadd(pTHX_ GV *gv)
+PP(pp_gnbyname)
{
- return gv_AVadd(gv);
+ return pp_gnetent();
}
-GV *
-Perl_gv_HVadd(pTHX_ GV *gv)
+PP(pp_gnbyaddr)
{
- return gv_HVadd(gv);
+ return pp_gnetent();
}
-GV *
-Perl_gv_IOadd(pTHX_ GV *gv)
+PP(pp_gpbyname)
{
- return gv_IOadd(gv);
+ return pp_gprotoent();
}
-IO *
-Perl_newIO(pTHX)
+PP(pp_gpbynumber)
{
- return MUTABLE_IO(newSV_type(SVt_PVIO));
+ return pp_gprotoent();
}
-I32
-Perl_my_stat(pTHX)
+PP(pp_gsbyname)
{
- return my_stat_flags(SV_GMAGIC);
+ return pp_gservent();
}
-I32
-Perl_my_lstat(pTHX)
+PP(pp_gsbyport)
{
- return my_lstat_flags(SV_GMAGIC);
+ return pp_gservent();
}
-I32
-Perl_sv_eq(pTHX_ SV *sv1, SV *sv2)
+PP(pp_gpwnam)
{
- return sv_eq_flags(sv1, sv2, SV_GMAGIC);
+ return pp_gpwent();
}
-#ifdef USE_LOCALE_COLLATE
-char *
-Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp)
+PP(pp_gpwuid)
{
- return sv_collxfrm_flags(sv, nxp, SV_GMAGIC);
+ return pp_gpwent();
}
-#endif
-bool
-Perl_sv_2bool(pTHX_ SV *const sv)
+PP(pp_ggrnam)
{
- return sv_2bool_flags(sv, SV_GMAGIC);
+ return pp_ggrent();
}
-
-/*
-=for apidoc custom_op_name
-Return the name for a given custom op. This was once used by the OP_NAME
-macro, but is no longer: it has only been kept for compatibility, and
-should not be used.
-
-=for apidoc custom_op_desc
-Return the description of a given custom op. This was once used by the
-OP_DESC macro, but is no longer: it has only been kept for
-compatibility, and should not be used.
-
-=cut
-*/
-
-const char*
-Perl_custom_op_name(pTHX_ const OP* o)
+PP(pp_ggrgid)
{
- PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
- return XopENTRYCUSTOM(o, xop_name);
+ return pp_ggrent();
}
-const char*
-Perl_custom_op_desc(pTHX_ const OP* o)
+PP(pp_ftsize)
{
- PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
- return XopENTRYCUSTOM(o, xop_desc);
+ return pp_ftis();
}
-CV *
-Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
+PP(pp_ftmtime)
{
- return newATTRSUB(floor, o, proto, NULL, block);
+ return pp_ftis();
}
-UV
-Perl_to_utf8_fold(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
+PP(pp_ftatime)
{
- PERL_ARGS_ASSERT_TO_UTF8_FOLD;
+ return pp_ftis();
+}
- return _to_utf8_fold_flags(p, ustrp, lenp, FOLD_FLAGS_FULL);
+PP(pp_ftctime)
+{
+ return pp_ftis();
}
-UV
-Perl_to_utf8_lower(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
+PP(pp_ftzero)
{
- PERL_ARGS_ASSERT_TO_UTF8_LOWER;
+ return pp_ftrowned();
+}
- return _to_utf8_lower_flags(p, ustrp, lenp, FALSE);
+PP(pp_ftsock)
+{
+ return pp_ftrowned();
}
-UV
-Perl_to_utf8_title(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
+PP(pp_ftchr)
{
- PERL_ARGS_ASSERT_TO_UTF8_TITLE;
+ return pp_ftrowned();
+}
- return _to_utf8_title_flags(p, ustrp, lenp, FALSE);
+PP(pp_ftblk)
+{
+ return pp_ftrowned();
}
-UV
-Perl_to_utf8_upper(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
+PP(pp_ftfile)
{
- PERL_ARGS_ASSERT_TO_UTF8_UPPER;
+ return pp_ftrowned();
+}
- return _to_utf8_upper_flags(p, ustrp, lenp, FALSE);
+PP(pp_ftdir)
+{
+ return pp_ftrowned();
}
-SV *
-Perl_sv_mortalcopy(pTHX_ SV *const oldstr)
+PP(pp_ftpipe)
{
- return Perl_sv_mortalcopy_flags(aTHX_ oldstr, SV_GMAGIC);
+ return pp_ftrowned();
}
-UV /* Made into a function, so can be deprecated */
-NATIVE_TO_NEED(const UV enc, const UV ch)
+PP(pp_ftsuid)
{
- PERL_UNUSED_ARG(enc);
- return ch;
+ return pp_ftrowned();
}
-UV /* Made into a function, so can be deprecated */
-ASCII_TO_NEED(const UV enc, const UV ch)
+PP(pp_ftsgid)
{
- PERL_UNUSED_ARG(enc);
- return ch;
+ return pp_ftrowned();
}
-bool
-Perl_is_uni_alnum(pTHX_ UV c)
+PP(pp_ftsvtx)
{
- return isWORDCHAR_uni(c);
+ return pp_ftrowned();
}
-bool
-Perl_is_uni_alnumc(pTHX_ UV c)
+PP(pp_unlink)
{
- return isALNUM_uni(c);
+ return pp_chown();
}
-bool
-Perl_is_uni_alpha(pTHX_ UV c)
+PP(pp_chmod)
{
- return isALPHA_uni(c);
+ return pp_chown();
}
-bool
-Perl_is_uni_ascii(pTHX_ UV c)
+PP(pp_utime)
{
- return isASCII_uni(c);
+ return pp_chown();
}
-bool
-Perl_is_uni_blank(pTHX_ UV c)
+PP(pp_kill)
{
- return isBLANK_uni(c);
+ return pp_chown();
}
-bool
-Perl_is_uni_space(pTHX_ UV c)
+PP(pp_symlink)
{
- return isSPACE_uni(c);
+ return pp_link();
}
-bool
-Perl_is_uni_digit(pTHX_ UV c)
+PP(pp_ftrwrite)
{
- return isDIGIT_uni(c);
+ return pp_ftrread();
}
-bool
-Perl_is_uni_upper(pTHX_ UV c)
+PP(pp_ftrexec)
{
- return isUPPER_uni(c);
+ return pp_ftrread();
}
-bool
-Perl_is_uni_lower(pTHX_ UV c)
+PP(pp_fteread)
{
- return isLOWER_uni(c);
+ return pp_ftrread();
}
-bool
-Perl_is_uni_cntrl(pTHX_ UV c)
+PP(pp_ftewrite)
{
- return isCNTRL_L1(c);
+ return pp_ftrread();
}
-bool
-Perl_is_uni_graph(pTHX_ UV c)
+PP(pp_fteexec)
{
- return isGRAPH_uni(c);
+ return pp_ftrread();
}
-bool
-Perl_is_uni_print(pTHX_ UV c)
+PP(pp_msgsnd)
{
- return isPRINT_uni(c);
+ return pp_shmwrite();
}
-bool
-Perl_is_uni_punct(pTHX_ UV c)
+PP(pp_msgrcv)
{
- return isPUNCT_uni(c);
+ return pp_shmwrite();
}
-bool
-Perl_is_uni_xdigit(pTHX_ UV c)
+PP(pp_syswrite)
{
- return isXDIGIT_uni(c);
+ return pp_send();
}
-bool
-Perl_is_uni_alnum_lc(pTHX_ UV c)
+PP(pp_semop)
{
- return isWORDCHAR_LC_uvchr(c);
+ return pp_shmwrite();
}
-bool
-Perl_is_uni_alnumc_lc(pTHX_ UV c)
+PP(pp_dor)
{
- return isALPHANUMERIC_LC_uvchr(c);
+ return pp_defined();
}
-bool
-Perl_is_uni_idfirst_lc(pTHX_ UV c)
+PP(pp_andassign)
{
- /* XXX Should probably be something that resolves to the old IDFIRST, but
- * this function is deprecated, so not bothering */
- return isIDFIRST_LC_uvchr(c);
+ return pp_and();
}
-bool
-Perl_is_uni_alpha_lc(pTHX_ UV c)
+PP(pp_orassign)
{
- return isALPHA_LC_uvchr(c);
+ return pp_or();
}
-bool
-Perl_is_uni_ascii_lc(pTHX_ UV c)
+PP(pp_dorassign)
+{
+ return pp_defined();
+}
+
+PP(pp_lcfirst)
{
- return isASCII_LC_uvchr(c);
+ return pp_ucfirst();
}
-bool
-Perl_is_uni_blank_lc(pTHX_ UV c)
+PP(pp_slt)
{
- return isBLANK_LC_uvchr(c);
+ return pp_sle();
}
-bool
-Perl_is_uni_space_lc(pTHX_ UV c)
+PP(pp_sgt)
{
- return isSPACE_LC_uvchr(c);
+ return pp_sle();
}
-bool
-Perl_is_uni_digit_lc(pTHX_ UV c)
+PP(pp_sge)
{
- return isDIGIT_LC_uvchr(c);
+ return pp_sle();
}
-bool
-Perl_is_uni_upper_lc(pTHX_ UV c)
+PP(pp_rindex)
{
- return isUPPER_LC_uvchr(c);
+ return pp_index();
}
-bool
-Perl_is_uni_lower_lc(pTHX_ UV c)
+PP(pp_hex)
{
- return isLOWER_LC_uvchr(c);
+ return pp_oct();
}
-bool
-Perl_is_uni_cntrl_lc(pTHX_ UV c)
+PP(pp_pop)
{
- return isCNTRL_LC_uvchr(c);
+ return pp_shift();
}
-bool
-Perl_is_uni_graph_lc(pTHX_ UV c)
+PP(pp_cos)
{
- return isGRAPH_LC_uvchr(c);
+ return pp_sin();
}
-bool
-Perl_is_uni_print_lc(pTHX_ UV c)
+PP(pp_exp)
{
- return isPRINT_LC_uvchr(c);
+ return pp_sin();
}
-bool
-Perl_is_uni_punct_lc(pTHX_ UV c)
+PP(pp_log)
{
- return isPUNCT_LC_uvchr(c);
+ return pp_sin();
}
-bool
-Perl_is_uni_xdigit_lc(pTHX_ UV c)
+PP(pp_sqrt)
{
- return isXDIGIT_LC_uvchr(c);
+ return pp_sin();
}
-U32
-Perl_to_uni_upper_lc(pTHX_ U32 c)
+PP(pp_bit_xor)
{
- /* XXX returns only the first character -- do not use XXX */
- /* XXX no locale support yet */
- STRLEN len;
- U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
- return (U32)to_uni_upper(c, tmpbuf, &len);
+ return pp_bit_or();
}
-U32
-Perl_to_uni_title_lc(pTHX_ U32 c)
+PP(pp_rv2hv)
{
- /* XXX returns only the first character XXX -- do not use XXX */
- /* XXX no locale support yet */
- STRLEN len;
- U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
- return (U32)to_uni_title(c, tmpbuf, &len);
+ return Perl_pp_rv2av(aTHX);
}
-U32
-Perl_to_uni_lower_lc(pTHX_ U32 c)
+U8 *
+Perl_uvuni_to_utf8(pTHX_ U8 *d, UV uv)
{
- /* XXX returns only the first character -- do not use XXX */
- /* XXX no locale support yet */
- STRLEN len;
- U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
- return (U32)to_uni_lower(c, tmpbuf, &len);
+ return Perl_uvuni_to_utf8_flags(aTHX_ d, uv, 0);
}
bool
-Perl_is_utf8_alnum(pTHX_ const U8 *p)
+Perl_is_utf8_string_loc(pTHX_ const U8 *s, STRLEN len, const U8 **ep)
{
- dVAR;
+ return is_utf8_string_loclen(s, len, ep, 0);
+}
- PERL_ARGS_ASSERT_IS_UTF8_ALNUM;
+/*
+=for apidoc sv_nolocking
- /* NOTE: "IsWord", not "IsAlnum", since Alnum is a true
- * descendant of isalnum(3), in other words, it doesn't
- * contain the '_'. --jhi */
- return isWORDCHAR_utf8(p);
-}
+Dummy routine which "locks" an SV when there is no locking module present.
+Exists to avoid test for a NULL function pointer and because it could
+potentially warn under some level of strict-ness.
-bool
-Perl_is_utf8_alnumc(pTHX_ const U8 *p)
-{
- dVAR;
+"Superseded" by sv_nosharing().
- PERL_ARGS_ASSERT_IS_UTF8_ALNUMC;
+=cut
+*/
- return isALPHANUMERIC_utf8(p);
+void
+Perl_sv_nolocking(pTHX_ SV *sv)
+{
+ PERL_UNUSED_CONTEXT;
+ PERL_UNUSED_ARG(sv);
}
-bool
-Perl_is_utf8_alpha(pTHX_ const U8 *p)
-{
- dVAR;
- PERL_ARGS_ASSERT_IS_UTF8_ALPHA;
+/*
+=for apidoc sv_nounlocking
- return isALPHA_utf8(p);
-}
+Dummy routine which "unlocks" an SV when there is no locking module present.
+Exists to avoid test for a NULL function pointer and because it could
+potentially warn under some level of strict-ness.
-bool
-Perl_is_utf8_ascii(pTHX_ const U8 *p)
-{
- dVAR;
+"Superseded" by sv_nosharing().
- PERL_ARGS_ASSERT_IS_UTF8_ASCII;
+=cut
+*/
- return isASCII_utf8(p);
+void
+Perl_sv_nounlocking(pTHX_ SV *sv)
+{
+ PERL_UNUSED_CONTEXT;
+ PERL_UNUSED_ARG(sv);
}
-bool
-Perl_is_utf8_blank(pTHX_ const U8 *p)
+void
+Perl_save_long(pTHX_ long int *longp)
{
dVAR;
-
- PERL_ARGS_ASSERT_IS_UTF8_BLANK;
-
- return isBLANK_utf8(p);
+ SSCHECK(3);
+ SSPUSHLONG(*longp);
+ SSPUSHPTR(longp);
+ SSPUSHINT(SAVEt_LONG);
}
-bool
-Perl_is_utf8_space(pTHX_ const U8 *p)
+void
+Perl_save_iv(pTHX_ IV *ivp)
{
dVAR;
-
- PERL_ARGS_ASSERT_IS_UTF8_SPACE;
-
- return isSPACE_utf8(p);
+ SSCHECK(3);
+ SSPUSHIV(*ivp);
+ SSPUSHPTR(ivp);
+ SSPUSHINT(SAVEt_IV);
}
-bool
-Perl_is_utf8_perl_space(pTHX_ const U8 *p)
+void
+Perl_save_nogv(pTHX_ GV *gv)
{
dVAR;
-
- PERL_ARGS_ASSERT_IS_UTF8_PERL_SPACE;
-
- /* 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);
+ SSCHECK(2);
+ SSPUSHPTR(gv);
+ SSPUSHINT(SAVEt_NSTAB);
}
-bool
-Perl_is_utf8_perl_word(pTHX_ const U8 *p)
+void
+Perl_save_list(pTHX_ register SV **sarg, I32 maxsarg)
{
dVAR;
+ register I32 i;
- PERL_ARGS_ASSERT_IS_UTF8_PERL_WORD;
-
- /* Only true if is an ASCII word character, and ASCII is invariant
- * under utf8, so can just use the macro */
- return isWORDCHAR_A(*p);
+ for (i = 1; i <= maxsarg; i++) {
+ register SV * const sv = newSV(0);
+ sv_setsv(sv,sarg[i]);
+ SSCHECK(3);
+ SSPUSHPTR(sarg[i]); /* remember the pointer */
+ SSPUSHPTR(sv); /* remember the value */
+ SSPUSHINT(SAVEt_ITEM);
+ }
}
-bool
-Perl_is_utf8_digit(pTHX_ const U8 *p)
-{
- dVAR;
+/*
+=for apidoc sv_usepvn_mg
- PERL_ARGS_ASSERT_IS_UTF8_DIGIT;
+Like C<sv_usepvn>, but also handles 'set' magic.
- return isDIGIT_utf8(p);
-}
+=cut
+*/
-bool
-Perl_is_utf8_posix_digit(pTHX_ const U8 *p)
+void
+Perl_sv_usepvn_mg(pTHX_ SV *sv, char *ptr, STRLEN len)
{
- dVAR;
+ sv_usepvn_flags(sv,ptr,len, SV_SMAGIC);
+}
- PERL_ARGS_ASSERT_IS_UTF8_POSIX_DIGIT;
+/*
+=for apidoc sv_usepvn
- /* Only true if is an ASCII digit character, and ASCII is invariant
- * under utf8, so can just use the macro */
- return isDIGIT_A(*p);
+Tells an SV to use C<ptr> to find its string value. Implemented by
+calling C<sv_usepvn_flags> with C<flags> of 0, hence does not handle 'set'
+magic. See C<sv_usepvn_flags>.
+
+=cut
+*/
+
+void
+Perl_sv_usepvn(pTHX_ SV *sv, char *ptr, STRLEN len)
+{
+ sv_usepvn_flags(sv,ptr,len, 0);
}
-bool
-Perl_is_utf8_upper(pTHX_ const U8 *p)
+void
+Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
{
- dVAR;
+ cv_ckproto_len(cv, gv, p, p ? strlen(p) : 0);
+}
- PERL_ARGS_ASSERT_IS_UTF8_UPPER;
+/*
+=for apidoc unpack_str
- return isUPPER_utf8(p);
-}
+The engine implementing unpack() Perl function. Note: parameters strbeg, new_s
+and ocnt are not used. This call should not be used, use unpackstring instead.
-bool
-Perl_is_utf8_lower(pTHX_ const U8 *p)
-{
- dVAR;
+=cut */
- PERL_ARGS_ASSERT_IS_UTF8_LOWER;
+I32
+Perl_unpack_str(pTHX_ const char *pat, const char *patend, const char *s,
+ const char *strbeg, const char *strend, char **new_s, I32 ocnt,
+ U32 flags)
+{
+ PERL_UNUSED_ARG(strbeg);
+ PERL_UNUSED_ARG(new_s);
+ PERL_UNUSED_ARG(ocnt);
- return isLOWER_utf8(p);
+ return unpackstring(pat, patend, s, strend, flags);
}
-bool
-Perl_is_utf8_cntrl(pTHX_ const U8 *p)
-{
- dVAR;
+/*
+=for apidoc pack_cat
- PERL_ARGS_ASSERT_IS_UTF8_CNTRL;
+The engine implementing pack() Perl function. Note: parameters next_in_list and
+flags are not used. This call should not be used; use packlist instead.
- return isCNTRL_utf8(p);
-}
+=cut
+*/
-bool
-Perl_is_utf8_graph(pTHX_ const U8 *p)
+void
+Perl_pack_cat(pTHX_ SV *cat, const char *pat, const char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
{
- dVAR;
+ PERL_UNUSED_ARG(next_in_list);
+ PERL_UNUSED_ARG(flags);
- PERL_ARGS_ASSERT_IS_UTF8_GRAPH;
+ packlist(cat, pat, patend, beglist, endlist);
+}
- return isGRAPH_utf8(p);
+HE *
+Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash)
+{
+ return (HE *)hv_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISSTORE, val, hash);
}
bool
-Perl_is_utf8_print(pTHX_ const U8 *p)
+Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
{
- dVAR;
+ return hv_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISEXISTS, 0, hash)
+ ? TRUE : FALSE;
+}
- PERL_ARGS_ASSERT_IS_UTF8_PRINT;
+HE *
+Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, U32 hash)
+{
+ return (HE *)hv_common(hv, keysv, NULL, 0, 0,
+ (lval ? HV_FETCH_LVALUE : 0), NULL, hash);
+}
- return isPRINT_utf8(p);
+SV *
+Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
+{
+ return (SV *) hv_common(hv, keysv, NULL, 0, 0, flags | HV_DELETE, NULL,
+ hash);
}
-bool
-Perl_is_utf8_punct(pTHX_ const U8 *p)
+SV**
+Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash,
+ int flags)
{
- dVAR;
+ return (SV**) hv_common(hv, NULL, key, klen, flags,
+ (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
+}
- PERL_ARGS_ASSERT_IS_UTF8_PUNCT;
+SV**
+Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen_i32, SV *val, U32 hash)
+{
+ STRLEN klen;
+ int flags;
- return isPUNCT_utf8(p);
+ if (klen_i32 < 0) {
+ klen = -klen_i32;
+ flags = HVhek_UTF8;
+ } else {
+ klen = klen_i32;
+ flags = 0;
+ }
+ return (SV **) hv_common(hv, NULL, key, klen, flags,
+ (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
}
bool
-Perl_is_utf8_xdigit(pTHX_ const U8 *p)
+Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen_i32)
{
- dVAR;
-
- PERL_ARGS_ASSERT_IS_UTF8_XDIGIT;
+ STRLEN klen;
+ int flags;
- return isXDIGIT_utf8(p);
+ if (klen_i32 < 0) {
+ klen = -klen_i32;
+ flags = HVhek_UTF8;
+ } else {
+ klen = klen_i32;
+ flags = 0;
+ }
+ return hv_common(hv, NULL, key, klen, flags, HV_FETCH_ISEXISTS, 0, 0)
+ ? TRUE : FALSE;
}
-bool
-Perl_is_utf8_mark(pTHX_ const U8 *p)
+SV**
+Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval)
{
- dVAR;
-
- PERL_ARGS_ASSERT_IS_UTF8_MARK;
+ STRLEN klen;
+ int flags;
- return _is_utf8_mark(p);
+ if (klen_i32 < 0) {
+ klen = -klen_i32;
+ flags = HVhek_UTF8;
+ } else {
+ klen = klen_i32;
+ flags = 0;
+ }
+ return (SV **) hv_common(hv, NULL, key, klen, flags,
+ lval ? (HV_FETCH_JUST_SV | HV_FETCH_LVALUE)
+ : HV_FETCH_JUST_SV, NULL, 0);
}
-END_EXTERN_C
+SV *
+Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 flags)
+{
+ STRLEN klen;
+ int k_flags;
+
+ if (klen_i32 < 0) {
+ klen = -klen_i32;
+ k_flags = HVhek_UTF8;
+ } else {
+ klen = klen_i32;
+ k_flags = 0;
+ }
+ return (SV *) hv_common(hv, NULL, key, klen, k_flags, flags | HV_DELETE,
+ NULL, 0);
+}
#endif /* NO_MATHOMS */
@@ -1636,8 +1321,8 @@ END_EXTERN_C
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: nil
+ * indent-tabs-mode: t
* End:
*
- * ex: set ts=8 sts=4 sw=4 et:
+ * ex: set ts=8 sts=4 sw=4 noet:
*/
diff --git a/gnu/usr.bin/perl/mkppport b/gnu/usr.bin/perl/mkppport
index 55a74fab9ac..07aa8b22e50 100755
--- a/gnu/usr.bin/perl/mkppport
+++ b/gnu/usr.bin/perl/mkppport
@@ -2,6 +2,7 @@ use strict;
use warnings;
use Getopt::Long;
+use Pod::Usage;
use File::Spec;
use File::Compare qw( compare );
use File::Copy qw( copy );
@@ -11,7 +12,7 @@ sub iterdirs(&);
my $rootdir = dirname($0);
-unshift @INC, File::Spec->catdir($rootdir, qw(cpan ExtUtils-MakeMaker t lib));
+unshift @INC, File::Spec->catfile($rootdir, 't', 'lib');
eval q{ use MakeMaker::Test::Utils qw( which_perl ) };
$@ and die $@;
@@ -21,10 +22,7 @@ my %opt = (
clean => 0,
);
-unless ( GetOptions(\%opt, qw( clean list=s )) ) {
- require Pod::Usage;
- Pod::Usage::pod2usage(2);
-}
+GetOptions(\%opt, qw( clean list=s )) or pod2usage(2);
my $absroot = File::Spec->rel2abs($rootdir);
my @destdirs = readlist($opt{list});
@@ -58,7 +56,7 @@ unshift @INC, File::Spec->catdir($absroot, 'lib');
# Change to Devel::PPPort directory, as it needs the stuff
# from the parts/ directory
-chdir File::Spec->catdir($rootdir, 'cpan', 'Devel-PPPort');
+chdir File::Spec->catdir($rootdir, 'ext', 'Devel', 'PPPort');
# Capture and remove temporary files
my @unlink;
@@ -136,7 +134,7 @@ sub readlist
#----------------------------------------------
sub run
{
- my @args = ("-I" . File::Spec->catdir((File::Spec->updir) x 2, 'lib'), @_);
+ my @args = ("-I" . File::Spec->catdir((File::Spec->updir) x 3, 'lib'), @_);
my $run = $perl =~ m/\s/ ? qq("$perl") : $perl;
for (@args) {
$_ = qq("$_") if $^O eq 'VMS' && /^[^"]/;
diff --git a/gnu/usr.bin/perl/mkppport.lst b/gnu/usr.bin/perl/mkppport.lst
index 2519e31d510..0e37e5e7dd2 100644
--- a/gnu/usr.bin/perl/mkppport.lst
+++ b/gnu/usr.bin/perl/mkppport.lst
@@ -5,9 +5,5 @@
# This file is read by mkppport at build time.
#
-cpan/DB_File
-cpan/IPC-SysV
-cpan/Scalar-List-Utils
-cpan/Time-HiRes
-cpan/Win32API-File
-dist/PathTools
+ext/Time/HiRes
+ext/Win32API/File
diff --git a/gnu/usr.bin/perl/mro.c b/gnu/usr.bin/perl/mro.c
index 1b37ca7cd62..5f9bcfec327 100644
--- a/gnu/usr.bin/perl/mro.c
+++ b/gnu/usr.bin/perl/mro.c
@@ -1,7 +1,6 @@
/* mro.c
*
* Copyright (c) 2007 Brandon L Black
- * 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.
@@ -9,10 +8,8 @@
*/
/*
- * 'Which order shall we go in?' said Frodo. 'Eldest first, or quickest first?
- * You'll be last either way, Master Peregrin.'
- *
- * [p.101 of _The Lord of the Rings_, I/iii: "A Conspiracy Unmasked"]
+ * "Which order shall we go in?" said Frodo. "Eldest first, or quickest first?
+ * You'll be last either way, Master Peregrin."
*/
/*
@@ -27,114 +24,29 @@ These functions are related to the method resolution order of perl classes
#define PERL_IN_MRO_C
#include "perl.h"
-static const struct mro_alg dfs_alg =
- {S_mro_get_linear_isa_dfs, "dfs", 3, 0, 0};
-
-SV *
-Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta,
- const struct mro_alg *const which)
-{
- SV **data;
- PERL_ARGS_ASSERT_MRO_GET_PRIVATE_DATA;
-
- data = (SV **)Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL,
- which->name, which->length, which->kflags,
- HV_FETCH_JUST_SV, NULL, which->hash);
- if (!data)
- return NULL;
-
- /* If we've been asked to look up the private data for the current MRO, then
- cache it. */
- if (smeta->mro_which == which)
- smeta->mro_linear_current = *data;
-
- return *data;
-}
-
-SV *
-Perl_mro_set_private_data(pTHX_ struct mro_meta *const smeta,
- const struct mro_alg *const which, SV *const data)
-{
- PERL_ARGS_ASSERT_MRO_SET_PRIVATE_DATA;
-
- if (!smeta->mro_linear_all) {
- if (smeta->mro_which == which) {
- /* If all we need to store is the current MRO's data, then don't use
- memory on a hash with 1 element - store it direct, and signal
- this by leaving the would-be-hash NULL. */
- smeta->mro_linear_current = data;
- return data;
- } else {
- HV *const hv = newHV();
- /* Start with 2 buckets. It's unlikely we'll need more. */
- HvMAX(hv) = 1;
- smeta->mro_linear_all = hv;
-
- if (smeta->mro_linear_current) {
- /* If we were storing something directly, put it in the hash
- before we lose it. */
- Perl_mro_set_private_data(aTHX_ smeta, smeta->mro_which,
- smeta->mro_linear_current);
- }
- }
- }
-
- /* We get here if we're storing more than one linearisation for this stash,
- or the linearisation we are storing is not that if its current MRO. */
-
- if (smeta->mro_which == which) {
- /* If we've been asked to store the private data for the current MRO,
- then cache it. */
- smeta->mro_linear_current = data;
- }
-
- if (!Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL,
- which->name, which->length, which->kflags,
- HV_FETCH_ISSTORE, data, which->hash)) {
- Perl_croak(aTHX_ "panic: hv_store() failed in set_mro_private_data() "
- "for '%.*s' %d", (int) which->length, which->name,
- which->kflags);
- }
-
- return data;
-}
-
-const struct mro_alg *
-Perl_mro_get_from_name(pTHX_ SV *name) {
- SV **data;
-
- PERL_ARGS_ASSERT_MRO_GET_FROM_NAME;
-
- data = (SV **)Perl_hv_common(aTHX_ PL_registered_mros, name, NULL, 0, 0,
- HV_FETCH_JUST_SV, NULL, 0);
- if (!data)
- return NULL;
- assert(SvTYPE(*data) == SVt_IV);
- assert(SvIOK(*data));
- 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));
-
- PERL_ARGS_ASSERT_MRO_REGISTER;
-
-
- if (!Perl_hv_common(aTHX_ PL_registered_mros, NULL,
- mro->name, mro->length, mro->kflags,
- HV_FETCH_ISSTORE, wrapper, mro->hash)) {
- SvREFCNT_dec_NN(wrapper);
- Perl_croak(aTHX_ "panic: hv_store() failed in mro_register() "
- "for '%.*s' %d", (int) mro->length, mro->name, mro->kflags);
+struct mro_alg {
+ const char *name;
+ AV *(*resolve)(pTHX_ HV* stash, I32 level);
+};
+
+/* First one is the default */
+static struct mro_alg mros[] = {
+ {"dfs", S_mro_get_linear_isa_dfs},
+ {"c3", S_mro_get_linear_isa_c3}
+};
+
+#define NUMBER_OF_MROS (sizeof(mros)/sizeof(struct mro_alg))
+
+static const struct mro_alg *
+S_get_mro_from_name(pTHX_ const char *const name) {
+ const struct mro_alg *algo = mros;
+ const struct mro_alg *const end = mros + NUMBER_OF_MROS;
+ while (algo < end) {
+ if(strEQ(name, algo->name))
+ return algo;
+ ++algo;
}
+ return NULL;
}
struct mro_meta*
@@ -142,14 +54,14 @@ Perl_mro_meta_init(pTHX_ HV* stash)
{
struct mro_meta* newmeta;
- PERL_ARGS_ASSERT_MRO_META_INIT;
+ assert(stash);
assert(HvAUX(stash));
assert(!(HvAUX(stash)->xhv_mro_meta));
Newxz(newmeta, 1, struct mro_meta);
HvAUX(stash)->xhv_mro_meta = newmeta;
newmeta->cache_gen = 1;
newmeta->pkg_gen = 1;
- newmeta->mro_which = &dfs_alg;
+ newmeta->mro_which = mros;
return newmeta;
}
@@ -162,31 +74,20 @@ Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
{
struct mro_meta* newmeta;
- PERL_ARGS_ASSERT_MRO_META_DUP;
+ assert(smeta);
Newx(newmeta, 1, struct mro_meta);
Copy(smeta, newmeta, 1, struct mro_meta);
- if (newmeta->mro_linear_all) {
- newmeta->mro_linear_all
- = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_linear_all, param));
- /* This is just acting as a shortcut pointer, and will be automatically
- updated on the first get. */
- newmeta->mro_linear_current = NULL;
- } else if (newmeta->mro_linear_current) {
- /* Only the current MRO is stored, so this owns the data. */
- newmeta->mro_linear_current
- = sv_dup_inc((const SV *)newmeta->mro_linear_current, param);
- }
-
+ if (newmeta->mro_linear_dfs)
+ newmeta->mro_linear_dfs
+ = (AV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_linear_dfs, param));
+ if (newmeta->mro_linear_c3)
+ newmeta->mro_linear_c3
+ = (AV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_linear_c3, param));
if (newmeta->mro_nextmethod)
newmeta->mro_nextmethod
- = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_nextmethod, param));
- if (newmeta->isa)
- newmeta->isa
- = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->isa, param));
-
- newmeta->super = NULL;
+ = (HV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_nextmethod, param));
return newmeta;
}
@@ -210,7 +111,7 @@ invalidated).
=cut
*/
static AV*
-S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
+S_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level)
{
AV* retval;
GV** gvp;
@@ -218,62 +119,51 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
AV* av;
const HEK* stashhek;
struct mro_meta* meta;
- SV *our_name;
- HV *stored = NULL;
- PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
+ assert(stash);
assert(HvAUX(stash));
- stashhek
- = HvAUX(stash)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(stash)
- ? HvENAME_HEK_NN(stash)
- : HvNAME_HEK(stash);
-
+ stashhek = HvNAME_HEK(stash);
if (!stashhek)
Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
if (level > 100)
- Perl_croak(aTHX_
- "Recursive inheritance detected in package '%"HEKf"'",
- HEKfARG(stashhek));
+ Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
+ HEK_KEY(stashhek));
meta = HvMROMETA(stash);
/* return cache if valid */
- if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) {
+ if((retval = meta->mro_linear_dfs)) {
return retval;
}
/* not in cache, make a new one */
- retval = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
- /* We use this later in this function, but don't need a reference to it
- beyond the end of this function, so reference count is fine. */
- our_name = newSVhek(stashhek);
- av_push(retval, our_name); /* add ourselves at the top */
+ retval = (AV*)sv_2mortal((SV *)newAV());
+ av_push(retval, newSVhek(stashhek)); /* add ourselves at the top */
/* fetch our @ISA */
gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
- /* "stored" is used to keep track of all of the classnames we have added to
- the MRO so far, so we can do a quick exists check and avoid adding
- duplicate classnames to the MRO as we go.
- It's then retained to be re-used as a fast lookup for ->isa(), by adding
- our own name and "UNIVERSAL" to it. */
-
if(av && AvFILLp(av) >= 0) {
+ /* "stored" is used to keep track of all of the classnames
+ we have added to the MRO so far, so we can do a quick
+ exists check and avoid adding duplicate classnames to
+ the MRO as we go. */
+
+ HV* const stored = (HV*)sv_2mortal((SV*)newHV());
SV **svp = AvARRAY(av);
I32 items = AvFILLp(av) + 1;
/* foreach(@ISA) */
while (items--) {
- SV* const sv = *svp ? *svp : &PL_sv_undef;
+ SV* const sv = *svp++;
HV* const basestash = gv_stashsv(sv, 0);
SV *const *subrv_p;
I32 subrv_items;
- svp++;
if (!basestash) {
/* if no stash exists for this @ISA member,
@@ -293,85 +183,16 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
subrv_p = AvARRAY(subrv);
subrv_items = AvFILLp(subrv) + 1;
}
- if (stored) {
- while(subrv_items--) {
- SV *const subsv = *subrv_p++;
- /* LVALUE fetch will create a new undefined SV if necessary
- */
- HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
- assert(he);
- if(HeVAL(he) != &PL_sv_undef) {
- /* It was newly created. Steal it for our new SV, and
- replace it in the hash with the "real" thing. */
- SV *const val = HeVAL(he);
- HEK *const key = HeKEY_hek(he);
-
- HeVAL(he) = &PL_sv_undef;
- /* Save copying by making a shared hash key scalar. We
- inline this here rather than calling
- Perl_newSVpvn_share because we already have the
- scalar, and we already have the hash key. */
- assert(SvTYPE(val) == SVt_NULL);
- sv_upgrade(val, SVt_PV);
- SvPV_set(val, HEK_KEY(share_hek_hek(key)));
- SvCUR_set(val, HEK_LEN(key));
- SvIsCOW_on(val);
- SvPOK_on(val);
- if (HEK_UTF8(key))
- SvUTF8_on(val);
-
- av_push(retval, val);
- }
- }
- } else {
- /* We are the first (or only) parent. We can short cut the
- complexity above, because our @ISA is simply us prepended
- to our parent's @ISA, and our ->isa cache is simply our
- parent's, with our name added. */
- /* newSVsv() is slow. This code is only faster if we can avoid
- it by ensuring that SVs in the arrays are shared hash key
- scalar SVs, because we can "copy" them very efficiently.
- Although to be fair, we can't *ensure* this, as a reference
- to the internal array is returned by mro::get_linear_isa(),
- so we'll have to be defensive just in case someone faffed
- with it. */
- if (basestash) {
- SV **svp;
- stored = MUTABLE_HV(sv_2mortal((SV*)newHVhv(HvMROMETA(basestash)->isa)));
- av_extend(retval, subrv_items);
- AvFILLp(retval) = subrv_items;
- svp = AvARRAY(retval);
- while(subrv_items--) {
- SV *const val = *subrv_p++;
- *++svp = SvIsCOW_shared_hash(val)
- ? newSVhek(SvSHARED_HEK_FROM_PV(SvPVX(val)))
- : newSVsv(val);
- }
- } else {
- /* They have no stash. So create ourselves an ->isa cache
- as if we'd copied it from what theirs should be. */
- stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
- (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
- av_push(retval,
- newSVhek(HeKEY_hek(hv_store_ent(stored, sv,
- &PL_sv_undef, 0))));
+ while(subrv_items--) {
+ SV *const subsv = *subrv_p++;
+ if(!hv_exists_ent(stored, subsv, 0)) {
+ (void)hv_store_ent(stored, subsv, &PL_sv_undef, 0);
+ av_push(retval, newSVsv(subsv));
}
- }
+ }
}
- } else {
- /* We have no parents. */
- stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
- (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
}
- (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
-
- SvREFCNT_inc_simple_void_NN(stored);
- SvTEMP_off(stored);
- SvREADONLY_on(stored);
-
- meta->isa = stored;
-
/* now that we're past the exception dangers, grab our own reference to
the AV we're about to use for the result. The reference owned by the
mortals' stack will be released soon, so everything will balance. */
@@ -382,17 +203,17 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
and we do so by replacing it completely */
SvREADONLY_on(retval);
- return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg,
- MUTABLE_SV(retval)));
+ meta->mro_linear_dfs = retval;
+ return retval;
}
/*
-=for apidoc mro_get_linear_isa
+=for apidoc mro_get_linear_isa_c3
-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*.
+Returns the C3 linearization of @ISA
+the given stash. The return value is a read-only AV*.
+C<level> should be 0 (it is used internally in this
+function's recursion).
You are responsible for C<SvREFCNT_inc()> on the
return value if you plan to store it anywhere
@@ -402,68 +223,238 @@ invalidated).
=cut
*/
-AV*
-Perl_mro_get_linear_isa(pTHX_ HV *stash)
+
+static AV*
+S_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level)
{
+ AV* retval;
+ GV** gvp;
+ GV* gv;
+ AV* isa;
+ const HEK* stashhek;
struct mro_meta* meta;
- AV *isa;
- PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;
- if(!SvOOK(stash))
- Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
+ assert(stash);
+ assert(HvAUX(stash));
+
+ stashhek = HvNAME_HEK(stash);
+ if (!stashhek)
+ Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
+
+ if (level > 100)
+ Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
+ HEK_KEY(stashhek));
meta = HvMROMETA(stash);
- if (!meta->mro_which)
- 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);
+
+ /* return cache if valid */
+ if((retval = meta->mro_linear_c3)) {
+ return retval;
}
- if (!meta->isa) {
- HV *const isa_hash = newHV();
- /* Linearisation didn't build it for us, so do it here. */
- SV *const *svp = AvARRAY(isa);
- SV *const *const svp_end = svp + AvFILLp(isa) + 1;
- const HEK *canon_name = HvENAME_HEK(stash);
- if (!canon_name) canon_name = HvNAME_HEK(stash);
+ /* not in cache, make a new one */
- while (svp < svp_end) {
- (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0);
- }
+ gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
+ isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
+
+ /* For a better idea how the rest of this works, see the much clearer
+ pure perl version in Algorithm::C3 0.01:
+ http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
+ (later versions go about it differently than this code for speed reasons)
+ */
- (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name),
- HEK_LEN(canon_name), HEK_FLAGS(canon_name),
- HV_FETCH_ISSTORE, &PL_sv_undef,
- HEK_HASH(canon_name));
- (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0);
+ if(isa && AvFILLp(isa) >= 0) {
+ SV** seqs_ptr;
+ I32 seqs_items;
+ HV* const tails = (HV*)sv_2mortal((SV*)newHV());
+ AV* const seqs = (AV*)sv_2mortal((SV*)newAV());
+ I32* heads;
- SvREADONLY_on(isa_hash);
+ /* This builds @seqs, which is an array of arrays.
+ The members of @seqs are the MROs of
+ the members of @ISA, followed by @ISA itself.
+ */
+ I32 items = AvFILLp(isa) + 1;
+ SV** isa_ptr = AvARRAY(isa);
+ while(items--) {
+ SV* const isa_item = *isa_ptr++;
+ HV* const isa_item_stash = gv_stashsv(isa_item, 0);
+ if(!isa_item_stash) {
+ /* if no stash, make a temporary fake MRO
+ containing just itself */
+ AV* const isa_lin = newAV();
+ av_push(isa_lin, newSVsv(isa_item));
+ av_push(seqs, (SV*)isa_lin);
+ }
+ else {
+ /* recursion */
+ AV* const isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1);
+ av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa_lin));
+ }
+ }
+ av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa));
+
+ /* This builds "heads", which as an array of integer array
+ indices, one per seq, which point at the virtual "head"
+ of the seq (initially zero) */
+ Newxz(heads, AvFILLp(seqs)+1, I32);
+
+ /* This builds %tails, which has one key for every class
+ mentioned in the tail of any sequence in @seqs (tail meaning
+ everything after the first class, the "head"). The value
+ is how many times this key appears in the tails of @seqs.
+ */
+ seqs_ptr = AvARRAY(seqs);
+ seqs_items = AvFILLp(seqs) + 1;
+ while(seqs_items--) {
+ AV* const seq = (AV*)*seqs_ptr++;
+ I32 seq_items = AvFILLp(seq);
+ if(seq_items > 0) {
+ SV** seq_ptr = AvARRAY(seq) + 1;
+ while(seq_items--) {
+ SV* const seqitem = *seq_ptr++;
+ /* LVALUE fetch will create a new undefined SV if necessary
+ */
+ HE* const he = hv_fetch_ent(tails, seqitem, 1, 0);
+ if(he) {
+ SV* const val = HeVAL(he);
+ /* This will increment undef to 1, which is what we
+ want for a newly created entry. */
+ sv_inc(val);
+ }
+ }
+ }
+ }
- meta->isa = isa_hash;
+ /* Initialize retval to build the return value in */
+ retval = newAV();
+ av_push(retval, newSVhek(stashhek)); /* us first */
+
+ /* This loop won't terminate until we either finish building
+ the MRO, or get an exception. */
+ while(1) {
+ SV* cand = NULL;
+ SV* winner = NULL;
+ int s;
+
+ /* "foreach $seq (@seqs)" */
+ SV** const avptr = AvARRAY(seqs);
+ for(s = 0; s <= AvFILLp(seqs); s++) {
+ SV** svp;
+ AV * const seq = (AV*)(avptr[s]);
+ SV* seqhead;
+ if(!seq) continue; /* skip empty seqs */
+ svp = av_fetch(seq, heads[s], 0);
+ seqhead = *svp; /* seqhead = head of this seq */
+ if(!winner) {
+ HE* tail_entry;
+ SV* val;
+ /* if we haven't found a winner for this round yet,
+ and this seqhead is not in tails (or the count
+ for it in tails has dropped to zero), then this
+ seqhead is our new winner, and is added to the
+ final MRO immediately */
+ cand = seqhead;
+ if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
+ && (val = HeVAL(tail_entry))
+ && (SvIVX(val) > 0))
+ continue;
+ winner = newSVsv(cand);
+ av_push(retval, winner);
+ /* note however that even when we find a winner,
+ we continue looping over @seqs to do housekeeping */
+ }
+ if(!sv_cmp(seqhead, winner)) {
+ /* Once we have a winner (including the iteration
+ where we first found him), inc the head ptr
+ for any seq which had the winner as a head,
+ NULL out any seq which is now empty,
+ and adjust tails for consistency */
+
+ const int new_head = ++heads[s];
+ if(new_head > AvFILLp(seq)) {
+ SvREFCNT_dec(avptr[s]);
+ avptr[s] = NULL;
+ }
+ else {
+ HE* tail_entry;
+ SV* val;
+ /* Because we know this new seqhead used to be
+ a tail, we can assume it is in tails and has
+ a positive value, which we need to dec */
+ svp = av_fetch(seq, new_head, 0);
+ seqhead = *svp;
+ tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
+ val = HeVAL(tail_entry);
+ sv_dec(val);
+ }
+ }
+ }
+
+ /* if we found no candidates, we are done building the MRO.
+ !cand means no seqs have any entries left to check */
+ if(!cand) {
+ Safefree(heads);
+ break;
+ }
+
+ /* If we had candidates, but nobody won, then the @ISA
+ hierarchy is not C3-incompatible */
+ if(!winner) {
+ /* we have to do some cleanup before we croak */
+
+ SvREFCNT_dec(retval);
+ Safefree(heads);
+
+ Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
+ "merging failed on parent '%"SVf"'", HEK_KEY(stashhek), SVfARG(cand));
+ }
+ }
+ }
+ else { /* @ISA was undefined or empty */
+ /* build a retval containing only ourselves */
+ retval = newAV();
+ av_push(retval, newSVhek(stashhek));
}
- return isa;
+ /* we don't want anyone modifying the cache entry but us,
+ and we do so by replacing it completely */
+ SvREADONLY_on(retval);
+
+ meta->mro_linear_c3 = retval;
+ return retval;
+}
+
+/*
+=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
+read-only AV*.
+
+You are responsible for C<SvREFCNT_inc()> on the
+return value if you plan to store it anywhere
+semi-permanently (otherwise it might be deleted
+out from under you the next time the cache is
+invalidated).
+
+=cut
+*/
+AV*
+Perl_mro_get_linear_isa(pTHX_ HV *stash)
+{
+ struct mro_meta* meta;
+
+ assert(stash);
+ if(!SvOOK(stash))
+ Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
+
+ meta = HvMROMETA(stash);
+ if (!meta->mro_which)
+ Perl_croak(aTHX_ "panic: invalid MRO!");
+ return meta->mro_which->resolve(aTHX_ stash, 0);
}
/*
@@ -475,20 +466,6 @@ by the C<setisa> magic, should not need to invoke directly.
=cut
*/
-
-/* Macro to avoid repeating the code five times. */
-#define CLEAR_LINEAR(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) { \
- /* Only the current MRO is stored, so this owns the data. */ \
- SvREFCNT_dec(mEta->mro_linear_current); \
- mEta->mro_linear_current = NULL; \
- }
-
void
Perl_mro_isa_changed_in(pTHX_ HV* stash)
{
@@ -500,26 +477,19 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash)
I32 items;
bool is_universal;
struct mro_meta * meta;
- HV *isa = NULL;
-
- const HEK * const stashhek = HvENAME_HEK(stash);
- const char * const stashname = HvENAME_get(stash);
- const STRLEN stashname_len = HvENAMELEN_get(stash);
- PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
+ const char * const stashname = HvNAME_get(stash);
+ const STRLEN stashname_len = HvNAMELEN_get(stash);
if(!stashname)
Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
-
/* wipe out the cached linearizations for this stash */
meta = HvMROMETA(stash);
- CLEAR_LINEAR(meta);
- if (meta->isa) {
- /* Steal it for our own purposes. */
- isa = (HV *)sv_2mortal((SV *)meta->isa);
- meta->isa = NULL;
- }
+ SvREFCNT_dec((SV*)meta->mro_linear_dfs);
+ SvREFCNT_dec((SV*)meta->mro_linear_c3);
+ meta->mro_linear_dfs = NULL;
+ meta->mro_linear_c3 = NULL;
/* Inc the package generation, since our @ISA changed */
meta->pkg_gen++;
@@ -527,8 +497,8 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash)
/* Wipe the global method cache if this package
is UNIVERSAL or one of its parents */
- svp = hv_fetchhek(PL_isarev, stashhek, 0);
- isarev = svp ? MUTABLE_HV(*svp) : NULL;
+ svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
+ isarev = svp ? (HV*)*svp : NULL;
if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
|| (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
@@ -543,113 +513,33 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash)
/* wipe next::method cache too */
if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
- /* Changes to @ISA might turn overloading on */
- HvAMAGIC_on(stash);
- /* pessimise derefs for now. Will get recalculated by Gv_AMupdate() */
- HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
-
- /* 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. */
+ wiping out their linearization and method caches */
if(isarev) {
- HV *isa_hashes = NULL;
-
- /* 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.
- */
-
- /* First iteration: Wipe everything, but stash away the isa hashes
- * since we still need them for updating PL_isarev.
- */
-
- if(hv_iterinit(isarev)) {
- /* Only create the hash if we need it; i.e., if isarev has
- any elements. */
- isa_hashes = (HV *)sv_2mortal((SV *)newHV());
- }
+ hv_iterinit(isarev);
while((iter = hv_iternext(isarev))) {
- HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0);
+ I32 len;
+ const char* const revkey = hv_iterkey(iter, &len);
+ HV* revstash = gv_stashpvn(revkey, len, 0);
struct mro_meta* revmeta;
if(!revstash) continue;
revmeta = HvMROMETA(revstash);
- CLEAR_LINEAR(revmeta);
+ SvREFCNT_dec((SV*)revmeta->mro_linear_dfs);
+ SvREFCNT_dec((SV*)revmeta->mro_linear_c3);
+ revmeta->mro_linear_dfs = NULL;
+ revmeta->mro_linear_c3 = NULL;
if(!is_universal)
revmeta->cache_gen++;
if(revmeta->mro_nextmethod)
hv_clear(revmeta->mro_nextmethod);
- if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL;
-
- (void)
- hv_store(
- isa_hashes, (const char*)&revstash, sizeof(HV *),
- revmeta->isa ? (SV *)revmeta->isa : &PL_sv_undef, 0
- );
- revmeta->isa = NULL;
- }
-
- /* Second pass: Update PL_isarev. We can just use isa_hashes to
- * avoid another round of stash lookups. */
-
- /* isarev might be deleted from PL_isarev during this loop, so hang
- * on to it. */
- SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)isarev));
-
- if(isa_hashes) {
- hv_iterinit(isa_hashes);
- while((iter = hv_iternext(isa_hashes))) {
- HV* const revstash = *(HV **)HEK_KEY(HeKEY_hek(iter));
- HV * const isa = (HV *)HeVAL(iter);
- const HEK *namehek;
-
- /* We're starting at the 2nd element, skipping revstash */
- linear_mro = mro_get_linear_isa(revstash);
- svp = AvARRAY(linear_mro) + 1;
- items = AvFILLp(linear_mro);
-
- namehek = HvENAME_HEK(revstash);
- if (!namehek) namehek = HvNAME_HEK(revstash);
-
- while (items--) {
- SV* const sv = *svp++;
- HV* mroisarev;
-
- HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
-
- /* That fetch should not fail. But if it had to create
- a new SV for us, then will need to upgrade it to an
- HV (which sv_upgrade() can now do for us). */
-
- mroisarev = MUTABLE_HV(HeVAL(he));
-
- SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
-
- /* This hash only ever contains PL_sv_yes. Storing it
- over itself is almost as cheap as calling hv_exists,
- so on aggregate we expect to save time by not making
- two calls to the common HV code for the case where
- it doesn't exist. */
-
- (void)
- hv_storehek(mroisarev, namehek, &PL_sv_yes);
- }
-
- if((SV *)isa != &PL_sv_undef)
- mro_clean_isarev(
- isa, HEK_KEY(namehek), HEK_LEN(namehek),
- HvMROMETA(revstash)->isa, HEK_HASH(namehek),
- HEK_UTF8(namehek)
- );
- }
}
}
- /* Now iterate our MRO (parents), adding ourselves and everything from
- our isarev to their isarev.
+ /* Now iterate our MRO (parents), and do a few things:
+ 1) instantiate with the "fake" flag if they don't exist
+ 2) flag them as universal if we are universal
+ 3) Add everything from our isarev to their isarev
*/
/* We're starting at the 2nd element, skipping ourselves here */
@@ -664,620 +554,35 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash)
HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
/* That fetch should not fail. But if it had to create a new SV for
- us, then will need to upgrade it to an HV (which sv_upgrade() can
- now do for us. */
-
- mroisarev = MUTABLE_HV(HeVAL(he));
-
- SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
+ us, then we can detect it, because it will not be the correct type.
+ Probably faster and cleaner for us to free that scalar [very little
+ code actually executed to free it] and create a new HV than to
+ copy&paste [SIN!] the code from newHV() to allow us to upgrade the
+ new SV from SVt_NULL. */
+
+ mroisarev = (HV*)HeVAL(he);
+
+ if(SvTYPE(mroisarev) != SVt_PVHV) {
+ SvREFCNT_dec(mroisarev);
+ mroisarev = newHV();
+ HeVAL(he) = (SV *)mroisarev;
+ }
/* This hash only ever contains PL_sv_yes. Storing it over itself is
almost as cheap as calling hv_exists, so on aggregate we expect to
save time by not making two calls to the common HV code for the
case where it doesn't exist. */
- (void)hv_storehek(mroisarev, stashhek, &PL_sv_yes);
- }
-
- /* Delete our name from our former parents' isarevs. */
- if(isa && HvARRAY(isa))
- mro_clean_isarev(isa, stashname, stashname_len, meta->isa,
- HEK_HASH(stashhek), HEK_UTF8(stashhek));
-}
-
-/* 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, U32 hash,
- U32 flags)
-{
- HE* iter;
-
- PERL_ARGS_ASSERT_MRO_CLEAN_ISAREV;
-
- /* 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, 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_common(isarev, NULL, name, len, flags,
- G_DISCARD|HV_DELETE, NULL, hash);
- if(!HvARRAY(isarev) || !HvUSEDKEYS(isarev))
- (void)hv_delete(PL_isarev, key,
- HeKUTF8(iter) ? -klen : klen, G_DISCARD);
- }
- }
- }
-}
-
-/*
-=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
-that is actually being assigned to.
-
-This can also be called with a null first argument to
-indicate that C<oldstash> has been deleted.
-
-This function invalidates isa caches on the old stash, on all subpackages
-nested inside it, and on the subclasses of all those, including
-non-existent packages that have corresponding entries in C<stash>.
-
-It also sets the effective names (C<HvENAME>) on all the stashes as
-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>.
-
-=cut
-*/
-void
-Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash,
- const GV * const gv, U32 flags)
-{
- SV *namesv;
- HEK **namep;
- I32 name_count;
- HV *stashes;
- HE* iter;
-
- PERL_ARGS_ASSERT_MRO_PACKAGE_MOVED;
- assert(stash || oldstash);
-
- /* Determine the name(s) of the location that stash was assigned to
- * or from which oldstash was removed.
- *
- * We cannot reliably use the name in oldstash, because it may have
- * been deleted from the location in the symbol table that its name
- * suggests, as in this case:
- *
- * $globref = \*foo::bar::;
- * Symbol::delete_package("foo");
- * *$globref = \%baz::;
- * *$globref = *frelp::;
- * # calls mro_package_moved(%frelp::, %baz::, *$globref, NULL, 0)
- *
- * So we get it from the gv. But, since the gv may no longer be in the
- * symbol table, we check that first. The only reliable way to tell is
- * to see whether its stash has an effective name and whether the gv
- * resides in that stash under its name. That effective name may be
- * different from what gv_fullname4 would use.
- * If flags & 1, the caller has asked us to skip the check.
- */
- if(!(flags & 1)) {
- SV **svp;
- if(
- !GvSTASH(gv) || !HvENAME(GvSTASH(gv)) ||
- !(svp = hv_fetchhek(GvSTASH(gv), GvNAME_HEK(gv), 0)) ||
- *svp != (SV *)gv
- ) return;
- }
- assert(SvOOK(GvSTASH(gv)));
- assert(GvNAMELEN(gv));
- assert(GvNAME(gv)[GvNAMELEN(gv) - 1] == ':');
- assert(GvNAMELEN(gv) == 1 || GvNAME(gv)[GvNAMELEN(gv) - 2] == ':');
- name_count = HvAUX(GvSTASH(gv))->xhv_name_count;
- if (!name_count) {
- name_count = 1;
- namep = &HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_name;
- }
- else {
- namep = HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_names;
- if (name_count < 0) ++namep, name_count = -name_count - 1;
- }
- if (name_count == 1) {
- if (HEK_LEN(*namep) == 4 && strnEQ(HEK_KEY(*namep), "main", 4)) {
- namesv = GvNAMELEN(gv) == 1
- ? newSVpvs_flags(":", SVs_TEMP)
- : newSVpvs_flags("", SVs_TEMP);
- }
- else {
- namesv = sv_2mortal(newSVhek(*namep));
- if (GvNAMELEN(gv) == 1) sv_catpvs(namesv, ":");
- else sv_catpvs(namesv, "::");
- }
- if (GvNAMELEN(gv) != 1) {
- sv_catpvn_flags(
- namesv, GvNAME(gv), GvNAMELEN(gv) - 2,
- /* skip trailing :: */
- GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
- );
- }
- }
- else {
- SV *aname;
- namesv = sv_2mortal((SV *)newAV());
- while (name_count--) {
- if(HEK_LEN(*namep) == 4 && strnEQ(HEK_KEY(*namep), "main", 4)){
- aname = GvNAMELEN(gv) == 1
- ? newSVpvs(":")
- : newSVpvs("");
- namep++;
- }
- else {
- aname = newSVhek(*namep++);
- if (GvNAMELEN(gv) == 1) sv_catpvs(aname, ":");
- else sv_catpvs(aname, "::");
- }
- if (GvNAMELEN(gv) != 1) {
- sv_catpvn_flags(
- aname, GvNAME(gv), GvNAMELEN(gv) - 2,
- /* skip trailing :: */
- GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
- );
+ (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
+
+ if(isarev) {
+ hv_iterinit(isarev);
+ while((iter = hv_iternext(isarev))) {
+ I32 revkeylen;
+ char* const revkey = hv_iterkey(iter, &revkeylen);
+ (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
}
- av_push((AV *)namesv, aname);
- }
- }
-
- /* Get a list of all the affected classes. */
- /* We cannot simply pass them all to mro_isa_changed_in to avoid
- the list, as that function assumes that only one package has
- changed. It does not work with:
-
- @foo::ISA = qw( B B::B );
- *B:: = delete $::{"A::"};
-
- as neither B nor B::B can be updated before the other, since they
- will reset caches on foo, which will see either B or B::B with the
- wrong name. The names must be set on *all* affected stashes before
- we do anything else. (And linearisations must be cleared, too.)
- */
- stashes = (HV *) sv_2mortal((SV *)newHV());
- mro_gather_and_rename(
- stashes, (HV *) sv_2mortal((SV *)newHV()),
- stash, oldstash, namesv
- );
-
- /* Once the caches have been wiped on all the classes, call
- mro_isa_changed_in on each. */
- hv_iterinit(stashes);
- while((iter = hv_iternext(stashes))) {
- HV * const stash = *(HV **)HEK_KEY(HeKEY_hek(iter));
- if(HvENAME(stash)) {
- /* We have to restore the original meta->isa (that
- mro_gather_and_rename set aside for us) this way, in case
- one class in this list is a superclass of a another class
- that we have already encountered. In such a case, meta->isa
- will have been overwritten without old entries being deleted
- from PL_isarev. */
- struct mro_meta * const meta = HvMROMETA(stash);
- if(meta->isa != (HV *)HeVAL(iter)){
- SvREFCNT_dec(meta->isa);
- meta->isa
- = HeVAL(iter) == &PL_sv_yes
- ? NULL
- : (HV *)HeVAL(iter);
- HeVAL(iter) = NULL; /* We donated our reference count. */
- }
- mro_isa_changed_in(stash);
- }
- }
-}
-
-STATIC void
-S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes,
- HV *stash, HV *oldstash, SV *namesv)
-{
- XPVHV* xhv;
- HE *entry;
- I32 riter = -1;
- I32 items = 0;
- const bool stash_had_name = stash && HvENAME(stash);
- bool fetched_isarev = FALSE;
- HV *seen = NULL;
- HV *isarev = NULL;
- SV **svp = NULL;
-
- PERL_ARGS_ASSERT_MRO_GATHER_AND_RENAME;
-
- /* We use the seen_stashes hash to keep track of which packages have
- been encountered so far. This must be separate from the main list of
- stashes, as we need to distinguish between stashes being assigned
- and stashes being replaced/deleted. (A nested stash can be on both
- sides of an assignment. We cannot simply skip iterating through a
- stash on the right if we have seen it on the left, as it will not
- get its ename assigned to it.)
-
- To avoid allocating extra SVs, instead of a bitfield we can make
- bizarre use of immortals:
-
- &PL_sv_undef: seen on the left (oldstash)
- &PL_sv_no : seen on the right (stash)
- &PL_sv_yes : seen on both sides
-
- */
-
- if(oldstash) {
- /* Add to the big list. */
- struct mro_meta * meta;
- HE * const entry
- = (HE *)
- hv_common(
- seen_stashes, NULL, (const char *)&oldstash, sizeof(HV *), 0,
- HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
- );
- if(HeVAL(entry) == &PL_sv_undef || HeVAL(entry) == &PL_sv_yes) {
- oldstash = NULL;
- goto check_stash;
- }
- HeVAL(entry)
- = HeVAL(entry) == &PL_sv_no ? &PL_sv_yes : &PL_sv_undef;
- meta = HvMROMETA(oldstash);
- (void)
- hv_store(
- stashes, (const char *)&oldstash, sizeof(HV *),
- meta->isa
- ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
- : &PL_sv_yes,
- 0
- );
- CLEAR_LINEAR(meta);
-
- /* Update the effective name. */
- if(HvENAME_get(oldstash)) {
- const HEK * const enamehek = HvENAME_HEK(oldstash);
- if(SvTYPE(namesv) == SVt_PVAV) {
- items = AvFILLp((AV *)namesv) + 1;
- svp = AvARRAY((AV *)namesv);
- }
- else {
- items = 1;
- svp = &namesv;
- }
- while (items--) {
- const U32 name_utf8 = SvUTF8(*svp);
- STRLEN len;
- 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
- * 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
- * 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, 0, 0,
- name_utf8 ? HVhek_UTF8 : 0);
- isarev = (HV *)hv_delete(PL_isarev, name,
- name_utf8 ? -(I32)len : (I32)len, 0);
- fetched_isarev=TRUE;
- }
- }
- }
- }
- }
- check_stash:
- if(stash) {
- if(SvTYPE(namesv) == SVt_PVAV) {
- items = AvFILLp((AV *)namesv) + 1;
- svp = AvARRAY((AV *)namesv);
- }
- else {
- items = 1;
- 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, 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
- * 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
- * [perl #77358].)
- *
- * If it did have a name, then its previous name is still
- * used in isa caches, and there is no need for
- * mro_package_moved to call mro_isa_changed_in.
- */
-
- entry
- = (HE *)
- hv_common(
- seen_stashes, NULL, (const char *)&stash, sizeof(HV *), 0,
- HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
- );
- if(HeVAL(entry) == &PL_sv_yes || HeVAL(entry) == &PL_sv_no)
- stash = NULL;
- else {
- HeVAL(entry)
- = HeVAL(entry) == &PL_sv_undef ? &PL_sv_yes : &PL_sv_no;
- if(!stash_had_name)
- {
- struct mro_meta * const meta = HvMROMETA(stash);
- (void)
- hv_store(
- stashes, (const char *)&stash, sizeof(HV *),
- meta->isa
- ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
- : &PL_sv_yes,
- 0
- );
- CLEAR_LINEAR(meta);
- }
- }
- }
-
- if(!stash && !oldstash)
- /* Both stashes have been encountered already. */
- return;
-
- /* Add all the subclasses to the big list. */
- if(!fetched_isarev) {
- /* If oldstash is not null, then we can use its HvENAME to look up
- the isarev hash, since all its subclasses will be listed there.
- It will always have an HvENAME. It the HvENAME was removed
- above, then fetch_isarev will be true, and this code will not be
- reached.
-
- If oldstash is null, then this is an empty spot with no stash in
- it, so subclasses could be listed in isarev hashes belonging to
- any of the names, so we have to check all of them.
- */
- assert(!oldstash || HvENAME(oldstash));
- if (oldstash) {
- /* Extra variable to avoid a compiler warning */
- const HEK * const hvename = HvENAME_HEK(oldstash);
- fetched_isarev = TRUE;
- svp = hv_fetchhek(PL_isarev, hvename, 0);
- if (svp) isarev = MUTABLE_HV(*svp);
- }
- else if(SvTYPE(namesv) == SVt_PVAV) {
- items = AvFILLp((AV *)namesv) + 1;
- svp = AvARRAY((AV *)namesv);
- }
- else {
- items = 1;
- svp = &namesv;
- }
- }
- if(
- isarev || !fetched_isarev
- ) {
- while (fetched_isarev || items--) {
- HE *iter;
-
- if (!fetched_isarev) {
- HE * const he = hv_fetch_ent(PL_isarev, *svp++, 0, 0);
- if (!he || !(isarev = MUTABLE_HV(HeVAL(he)))) continue;
- }
-
- hv_iterinit(isarev);
- while((iter = hv_iternext(isarev))) {
- HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0);
- struct mro_meta * meta;
-
- if(!revstash) continue;
- meta = HvMROMETA(revstash);
- (void)
- hv_store(
- stashes, (const char *)&revstash, sizeof(HV *),
- meta->isa
- ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
- : &PL_sv_yes,
- 0
- );
- CLEAR_LINEAR(meta);
}
-
- if (fetched_isarev) break;
- }
- }
-
- /* This is partly based on code in hv_iternext_flags. We are not call-
- ing that here, as we want to avoid resetting the hash iterator. */
-
- /* Skip the entire loop if the hash is empty. */
- if(oldstash && HvUSEDKEYS(oldstash)) {
- xhv = (XPVHV*)SvANY(oldstash);
- seen = (HV *) sv_2mortal((SV *)newHV());
-
- /* Iterate through entries in the oldstash, adding them to the
- list, meanwhile doing the equivalent of $seen{$key} = 1.
- */
-
- while (++riter <= (I32)xhv->xhv_max) {
- entry = (HvARRAY(oldstash))[riter];
-
- /* Iterate through the entries in this list */
- for(; entry; entry = HeNEXT(entry)) {
- const char* key;
- I32 len;
-
- /* If this entry is not a glob, ignore it.
- Try the next. */
- if (!isGV(HeVAL(entry))) continue;
-
- key = hv_iterkey(entry, &len);
- if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
- || (len == 1 && key[0] == ':')) {
- HV * const oldsubstash = GvHV(HeVAL(entry));
- SV ** const stashentry
- = stash ? hv_fetch(stash, key, HeUTF8(entry) ? -(I32)len : (I32)len, 0) : NULL;
- HV *substash = NULL;
-
- /* Avoid main::main::main::... */
- if(oldsubstash == oldstash) continue;
-
- if(
- (
- stashentry && *stashentry && isGV(*stashentry)
- && (substash = GvHV(*stashentry))
- )
- || (oldsubstash && HvENAME_get(oldsubstash))
- )
- {
- /* Add :: and the key (minus the trailing ::)
- to each name. */
- SV *subname;
- if(SvTYPE(namesv) == SVt_PVAV) {
- SV *aname;
- items = AvFILLp((AV *)namesv) + 1;
- svp = AvARRAY((AV *)namesv);
- subname = sv_2mortal((SV *)newAV());
- while (items--) {
- aname = newSVsv(*svp++);
- if (len == 1)
- sv_catpvs(aname, ":");
- else {
- sv_catpvs(aname, "::");
- sv_catpvn_flags(
- aname, key, len-2,
- HeUTF8(entry)
- ? SV_CATUTF8 : SV_CATBYTES
- );
- }
- av_push((AV *)subname, aname);
- }
- }
- else {
- subname = sv_2mortal(newSVsv(namesv));
- if (len == 1) sv_catpvs(subname, ":");
- else {
- sv_catpvs(subname, "::");
- sv_catpvn_flags(
- subname, key, len-2,
- HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES
- );
- }
- }
- mro_gather_and_rename(
- stashes, seen_stashes,
- substash, oldsubstash, subname
- );
- }
-
- (void)hv_store(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len, &PL_sv_yes, 0);
- }
- }
- }
- }
-
- /* Skip the entire loop if the hash is empty. */
- if (stash && HvUSEDKEYS(stash)) {
- xhv = (XPVHV*)SvANY(stash);
- riter = -1;
-
- /* Iterate through the new stash, skipping $seen{$key} items,
- calling mro_gather_and_rename(stashes,seen,entry,NULL, ...). */
- while (++riter <= (I32)xhv->xhv_max) {
- entry = (HvARRAY(stash))[riter];
-
- /* Iterate through the entries in this list */
- for(; entry; entry = HeNEXT(entry)) {
- const char* key;
- I32 len;
-
- /* If this entry is not a glob, ignore it.
- Try the next. */
- if (!isGV(HeVAL(entry))) continue;
-
- key = hv_iterkey(entry, &len);
- if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
- || (len == 1 && key[0] == ':')) {
- HV *substash;
-
- /* If this entry was seen when we iterated through the
- oldstash, skip it. */
- 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. */
-
- substash = GvHV(HeVAL(entry));
- if(substash) {
- SV *subname;
-
- /* Avoid checking main::main::main::... */
- if(substash == stash) continue;
-
- /* Add :: and the key (minus the trailing ::)
- to each name. */
- if(SvTYPE(namesv) == SVt_PVAV) {
- SV *aname;
- items = AvFILLp((AV *)namesv) + 1;
- svp = AvARRAY((AV *)namesv);
- subname = sv_2mortal((SV *)newAV());
- while (items--) {
- aname = newSVsv(*svp++);
- if (len == 1)
- sv_catpvs(aname, ":");
- else {
- sv_catpvs(aname, "::");
- sv_catpvn_flags(
- aname, key, len-2,
- HeUTF8(entry)
- ? SV_CATUTF8 : SV_CATBYTES
- );
- }
- av_push((AV *)subname, aname);
- }
- }
- else {
- subname = sv_2mortal(newSVsv(namesv));
- if (len == 1) sv_catpvs(subname, ":");
- else {
- sv_catpvs(subname, "::");
- sv_catpvn_flags(
- subname, key, len-2,
- HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES
- );
- }
- }
- mro_gather_and_rename(
- stashes, seen_stashes,
- substash, NULL, subname
- );
- }
- }
- }
- }
}
}
@@ -1289,7 +594,7 @@ of the given stash, so that they might notice
the changes in this one.
Ideally, all instances of C<PL_sub_generation++> in
-perl source outside of F<mro.c> should be
+perl source outside of C<mro.c> should be
replaced by calls to this.
Perl automatically handles most of the common
@@ -1314,13 +619,11 @@ via, C<mro::method_changed_in(classname)>.
void
Perl_mro_method_changed_in(pTHX_ HV *stash)
{
- const char * const stashname = HvENAME_get(stash);
- const STRLEN stashname_len = HvENAMELEN_get(stash);
-
- SV ** const svp = hv_fetchhek(PL_isarev, HvENAME_HEK(stash), 0);
- HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
+ const char * const stashname = HvNAME_get(stash);
+ const STRLEN stashname_len = HvNAMELEN_get(stash);
- PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
+ SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
+ HV * const isarev = svp ? (HV*)*svp : NULL;
if(!stashname)
Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
@@ -1328,9 +631,6 @@ Perl_mro_method_changed_in(pTHX_ HV *stash)
/* 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"))
@@ -1346,7 +646,9 @@ Perl_mro_method_changed_in(pTHX_ HV *stash)
hv_iterinit(isarev);
while((iter = hv_iternext(isarev))) {
- HV* const revstash = gv_stashsv(hv_iterkeysv(iter), 0);
+ I32 len;
+ const char* const revkey = hv_iterkey(iter, &len);
+ HV* const revstash = gv_stashpvn(revkey, len, 0);
struct mro_meta* mrometa;
if(!revstash) continue;
@@ -1354,58 +656,227 @@ Perl_mro_method_changed_in(pTHX_ HV *stash)
mrometa->cache_gen++;
if(mrometa->mro_nextmethod)
hv_clear(mrometa->mro_nextmethod);
- if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL;
}
}
+}
+
+/* These two are static helpers for next::method and friends,
+ and re-implement a bunch of the code from pp_caller() in
+ a more efficient manner for this particular usage.
+*/
- /* The method change may be due to *{$package . "::()"} = \&nil; in
- overload.pm. */
- HvAMAGIC_on(stash);
- /* pessimise derefs for now. Will get recalculated by Gv_AMupdate() */
- HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
+STATIC I32
+__dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
+ I32 i;
+ for (i = startingblock; i >= 0; i--) {
+ if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
+ }
+ return i;
}
+#include "XSUB.h"
+
+XS(XS_mro_get_linear_isa);
+XS(XS_mro_set_mro);
+XS(XS_mro_get_mro);
+XS(XS_mro_get_isarev);
+XS(XS_mro_is_universal);
+XS(XS_mro_invalidate_method_caches);
+XS(XS_mro_method_changed_in);
+XS(XS_mro_get_pkg_gen);
+XS(XS_mro_nextcan);
+
void
-Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
+Perl_boot_core_mro(pTHX)
{
- const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name);
-
- PERL_ARGS_ASSERT_MRO_SET_MRO;
+ dVAR;
+ static const char file[] = __FILE__;
+ newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
+ newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
+ newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
+ newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
+ newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
+ newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
+ newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
+ newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$");
+ newXS("mro::_nextcan", XS_mro_nextcan, file);
+}
+
+XS(XS_mro_get_linear_isa) {
+ dVAR;
+ dXSARGS;
+ AV* RETVAL;
+ HV* class_stash;
+ SV* classname;
+
+ PERL_UNUSED_ARG(cv);
+
+ if(items < 1 || items > 2)
+ Perl_croak(aTHX_ "Usage: mro::get_linear_isa(classname [, type ])");
+
+ classname = ST(0);
+ class_stash = gv_stashsv(classname, 0);
+
+ if(!class_stash) {
+ /* No stash exists yet, give them just the classname */
+ AV* isalin = newAV();
+ av_push(isalin, newSVsv(classname));
+ ST(0) = sv_2mortal(newRV_noinc((SV*)isalin));
+ XSRETURN(1);
+ }
+ else if(items > 1) {
+ const char* const which = SvPV_nolen(ST(1));
+ const struct mro_alg *const algo = S_get_mro_from_name(aTHX_ which);
+ if (!algo)
+ Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
+ RETVAL = algo->resolve(aTHX_ class_stash, 0);
+ }
+ else {
+ RETVAL = mro_get_linear_isa(class_stash);
+ }
+
+ ST(0) = newRV_inc((SV*)RETVAL);
+ sv_2mortal(ST(0));
+ XSRETURN(1);
+}
+
+XS(XS_mro_set_mro)
+{
+ dVAR;
+ dXSARGS;
+ SV* classname;
+ const char* whichstr;
+ const struct mro_alg *which;
+ HV* class_stash;
+ struct mro_meta* meta;
+
+ PERL_UNUSED_ARG(cv);
+
+ if (items != 2)
+ Perl_croak(aTHX_ "Usage: mro::set_mro(classname, type)");
+
+ classname = ST(0);
+ whichstr = SvPV_nolen(ST(1));
+ class_stash = gv_stashsv(classname, GV_ADD);
+ if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
+ meta = HvMROMETA(class_stash);
+
+ which = S_get_mro_from_name(aTHX_ whichstr);
if (!which)
- Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name);
+ Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
if(meta->mro_which != which) {
- if (meta->mro_linear_current && !meta->mro_linear_all) {
- /* If we were storing something directly, put it in the hash before
- we lose it. */
- Perl_mro_set_private_data(aTHX_ meta, meta->mro_which,
- MUTABLE_SV(meta->mro_linear_current));
- }
- meta->mro_which = which;
- /* Scrub our cached pointer to the private data. */
- meta->mro_linear_current = NULL;
+ meta->mro_which = which;
/* Only affects local method cache, not
even child classes */
meta->cache_gen++;
if(meta->mro_nextmethod)
hv_clear(meta->mro_nextmethod);
}
+
+ XSRETURN_EMPTY;
}
-#include "XSUB.h"
-XS(XS_mro_method_changed_in);
+XS(XS_mro_get_mro)
+{
+ dVAR;
+ dXSARGS;
+ SV* classname;
+ HV* class_stash;
-void
-Perl_boot_core_mro(pTHX)
+ PERL_UNUSED_ARG(cv);
+
+ if (items != 1)
+ Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
+
+ classname = ST(0);
+ class_stash = gv_stashsv(classname, 0);
+
+ ST(0) = sv_2mortal(newSVpv(class_stash
+ ? HvMROMETA(class_stash)->mro_which->name
+ : "dfs", 0));
+ XSRETURN(1);
+}
+
+XS(XS_mro_get_isarev)
{
dVAR;
- static const char file[] = __FILE__;
+ dXSARGS;
+ SV* classname;
+ HE* he;
+ HV* isarev;
+ AV* ret_array;
- Perl_mro_register(aTHX_ &dfs_alg);
+ PERL_UNUSED_ARG(cv);
- newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
+ if (items != 1)
+ Perl_croak(aTHX_ "Usage: mro::get_isarev(classname)");
+
+ classname = ST(0);
+
+ SP -= items;
+
+
+ he = hv_fetch_ent(PL_isarev, classname, 0, 0);
+ isarev = he ? (HV*)HeVAL(he) : NULL;
+
+ ret_array = newAV();
+ if(isarev) {
+ HE* iter;
+ hv_iterinit(isarev);
+ while((iter = hv_iternext(isarev)))
+ av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
+ }
+ XPUSHs(sv_2mortal(newRV_noinc((SV*)ret_array)));
+
+ PUTBACK;
+ return;
+}
+
+XS(XS_mro_is_universal)
+{
+ dVAR;
+ dXSARGS;
+ SV* classname;
+ HV* isarev;
+ char* classname_pv;
+ STRLEN classname_len;
+ HE* he;
+
+ PERL_UNUSED_ARG(cv);
+
+ if (items != 1)
+ Perl_croak(aTHX_ "Usage: mro::is_universal(classname)");
+
+ classname = ST(0);
+
+ classname_pv = SvPV(classname,classname_len);
+
+ he = hv_fetch_ent(PL_isarev, classname, 0, 0);
+ isarev = he ? (HV*)HeVAL(he) : NULL;
+
+ if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
+ || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
+ XSRETURN_YES;
+ else
+ XSRETURN_NO;
+}
+
+XS(XS_mro_invalidate_method_caches)
+{
+ dVAR;
+ dXSARGS;
+
+ PERL_UNUSED_ARG(cv);
+
+ if (items != 0)
+ Perl_croak(aTHX_ "Usage: mro::invalidate_all_method_caches()");
+
+ PL_sub_generation++;
+
+ XSRETURN_EMPTY;
}
XS(XS_mro_method_changed_in)
@@ -1415,8 +886,10 @@ XS(XS_mro_method_changed_in)
SV* classname;
HV* class_stash;
+ PERL_UNUSED_ARG(cv);
+
if(items != 1)
- croak_xs_usage(cv, "classname");
+ Perl_croak(aTHX_ "Usage: mro::method_changed_in(classname)");
classname = ST(0);
@@ -1428,12 +901,232 @@ XS(XS_mro_method_changed_in)
XSRETURN_EMPTY;
}
+XS(XS_mro_get_pkg_gen)
+{
+ dVAR;
+ dXSARGS;
+ SV* classname;
+ HV* class_stash;
+
+ PERL_UNUSED_ARG(cv);
+
+ if(items != 1)
+ Perl_croak(aTHX_ "Usage: mro::get_pkg_gen(classname)");
+
+ classname = ST(0);
+
+ class_stash = gv_stashsv(classname, 0);
+
+ SP -= items;
+
+ XPUSHs(sv_2mortal(newSViv(
+ class_stash ? HvMROMETA(class_stash)->pkg_gen : 0
+ )));
+
+ PUTBACK;
+ return;
+}
+
+XS(XS_mro_nextcan)
+{
+ dVAR;
+ dXSARGS;
+ SV* self = ST(0);
+ const I32 throw_nomethod = SvIVX(ST(1));
+ register I32 cxix = cxstack_ix;
+ register const PERL_CONTEXT *ccstack = cxstack;
+ const PERL_SI *top_si = PL_curstackinfo;
+ HV* selfstash;
+ SV *stashname;
+ const char *fq_subname;
+ const char *subname;
+ STRLEN stashname_len;
+ STRLEN subname_len;
+ SV* sv;
+ GV** gvp;
+ AV* linear_av;
+ SV** linear_svp;
+ const char *hvname;
+ I32 entries;
+ struct mro_meta* selfmeta;
+ HV* nmcache;
+ I32 i;
+
+ PERL_UNUSED_ARG(cv);
+
+ SP -= items;
+
+ if(sv_isobject(self))
+ selfstash = SvSTASH(SvRV(self));
+ else
+ selfstash = gv_stashsv(self, 0);
+
+ assert(selfstash);
+
+ hvname = HvNAME_get(selfstash);
+ if (!hvname)
+ Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
+
+ /* This block finds the contextually-enclosing fully-qualified subname,
+ much like looking at (caller($i))[3] until you find a real sub that
+ isn't ANON, etc (also skips over pureperl next::method, etc) */
+ for(i = 0; i < 2; i++) {
+ cxix = __dopoptosub_at(ccstack, cxix);
+ for (;;) {
+ GV* cvgv;
+ STRLEN fq_subname_len;
+
+ /* we may be in a higher stacklevel, so dig down deeper */
+ while (cxix < 0) {
+ if(top_si->si_type == PERLSI_MAIN)
+ Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
+ top_si = top_si->si_prev;
+ ccstack = top_si->si_cxstack;
+ cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
+ }
+
+ if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
+ || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
+ cxix = __dopoptosub_at(ccstack, cxix - 1);
+ continue;
+ }
+
+ {
+ const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
+ if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
+ if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
+ cxix = dbcxix;
+ continue;
+ }
+ }
+ }
+
+ cvgv = CvGV(ccstack[cxix].blk_sub.cv);
+
+ if(!isGV(cvgv)) {
+ cxix = __dopoptosub_at(ccstack, cxix - 1);
+ continue;
+ }
+
+ /* we found a real sub here */
+ sv = sv_2mortal(newSV(0));
+
+ gv_efullname3(sv, cvgv, NULL);
+
+ fq_subname = SvPVX(sv);
+ fq_subname_len = SvCUR(sv);
+
+ subname = strrchr(fq_subname, ':');
+ if(!subname)
+ Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
+
+ subname++;
+ subname_len = fq_subname_len - (subname - fq_subname);
+ if(subname_len == 8 && strEQ(subname, "__ANON__")) {
+ cxix = __dopoptosub_at(ccstack, cxix - 1);
+ continue;
+ }
+ break;
+ }
+ cxix--;
+ }
+
+ /* If we made it to here, we found our context */
+
+ /* Initialize the next::method cache for this stash
+ if necessary */
+ selfmeta = HvMROMETA(selfstash);
+ if(!(nmcache = selfmeta->mro_nextmethod)) {
+ nmcache = selfmeta->mro_nextmethod = newHV();
+ }
+ else { /* Use the cached coderef if it exists */
+ HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
+ if (cache_entry) {
+ SV* const val = HeVAL(cache_entry);
+ if(val == &PL_sv_undef) {
+ if(throw_nomethod)
+ Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
+ XSRETURN_EMPTY;
+ }
+ XPUSHs(sv_2mortal(newRV_inc(val)));
+ XSRETURN(1);
+ }
+ }
+
+ /* beyond here is just for cache misses, so perf isn't as critical */
+
+ stashname_len = subname - fq_subname - 2;
+ stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
+
+ linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
+
+ linear_svp = AvARRAY(linear_av);
+ entries = AvFILLp(linear_av) + 1;
+
+ /* Walk down our MRO, skipping everything up
+ to the contextually enclosing class */
+ while (entries--) {
+ SV * const linear_sv = *linear_svp++;
+ assert(linear_sv);
+ if(sv_eq(linear_sv, stashname))
+ break;
+ }
+
+ /* Now search the remainder of the MRO for the
+ same method name as the contextually enclosing
+ method */
+ if(entries > 0) {
+ while (entries--) {
+ SV * const linear_sv = *linear_svp++;
+ HV* curstash;
+ GV* candidate;
+ CV* cand_cv;
+
+ assert(linear_sv);
+ curstash = gv_stashsv(linear_sv, FALSE);
+
+ if (!curstash) {
+ if (ckWARN(WARN_SYNTAX))
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
+ (void*)linear_sv, hvname);
+ continue;
+ }
+
+ assert(curstash);
+
+ gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
+ if (!gvp) continue;
+
+ candidate = *gvp;
+ assert(candidate);
+
+ if (SvTYPE(candidate) != SVt_PVGV)
+ gv_init(candidate, curstash, subname, subname_len, TRUE);
+
+ /* Notably, we only look for real entries, not method cache
+ entries, because in C3 the method cache of a parent is not
+ valid for the child */
+ if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
+ SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
+ (void)hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
+ XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv)));
+ XSRETURN(1);
+ }
+ }
+ }
+
+ (void)hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
+ if(throw_nomethod)
+ Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
+ XSRETURN_EMPTY;
+}
+
/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: nil
+ * indent-tabs-mode: t
* End:
*
- * ex: set ts=8 sts=4 sw=4 et:
+ * ex: set ts=8 sts=4 sw=4 noet:
*/
diff --git a/gnu/usr.bin/perl/overload.c b/gnu/usr.bin/perl/overload.c
index cd28df4c936..eaaef2154e4 100644
--- a/gnu/usr.bin/perl/overload.c
+++ b/gnu/usr.bin/perl/overload.c
@@ -2,21 +2,20 @@
*
* overload.c
*
- * Copyright (C) 1997, 1998, 2000, 2001, 2005, 2006, 2007, 2011
- * by Larry Wall and others
+ * Copyright (C) 1997, 1998, 2000, 2001, 2005, 2006, 2007 by Larry Wall
+ * and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*
- * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
- * This file is built by regen/overload.pl.
- * Any changes made here will be lost!
+ * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ * This file is built by overload.pl
*/
#define AMG_id2name(id) (PL_AMG_names[id]+1)
#define AMG_id2namelen(id) (PL_AMG_namelens[id]-1)
-static const U8 PL_AMG_namelens[NofAMmeth] = {
+const U8 PL_AMG_namelens[NofAMmeth] = {
2,
4,
4,
@@ -83,84 +82,80 @@ static const U8 PL_AMG_namelens[NofAMmeth] = {
2,
3,
3,
- 3,
- 3
+ 7
};
-static const char * const PL_AMG_names[NofAMmeth] = {
+char * const PL_AMG_names[NofAMmeth] = {
/* Names kept in the symbol table. fallback => "()", the rest has
"(" prepended. The only other place in perl which knows about
this convention is AMG_id2name (used for debugging output and
'nomethod' only), the only other place which has it hardwired is
overload.pm. */
- "()", /* fallback */
- "(${}", /* to_sv */
- "(@{}", /* to_av */
- "(%{}", /* to_hv */
- "(*{}", /* to_gv */
- "(&{}", /* to_cv */
- "(++", /* inc */
- "(--", /* dec */
- "(bool", /* bool_ */
- "(0+", /* numer */
- "(\"\"", /* string */
- "(!", /* not */
- "(=", /* copy */
- "(abs", /* abs */
- "(neg", /* neg */
- "(<>", /* iter */
- "(int", /* int */
- "(<", /* lt */
- "(<=", /* le */
- "(>", /* gt */
- "(>=", /* ge */
- "(==", /* eq */
- "(!=", /* ne */
- "(lt", /* slt */
- "(le", /* sle */
- "(gt", /* sgt */
- "(ge", /* sge */
- "(eq", /* seq */
- "(ne", /* sne */
- "(nomethod", /* nomethod */
- "(+", /* add */
- "(+=", /* add_ass */
- "(-", /* subtr */
- "(-=", /* subtr_ass */
- "(*", /* mult */
- "(*=", /* mult_ass */
- "(/", /* div */
- "(/=", /* div_ass */
- "(%", /* modulo */
- "(%=", /* modulo_ass */
- "(**", /* pow */
- "(**=", /* pow_ass */
- "(<<", /* lshift */
- "(<<=", /* lshift_ass */
- "(>>", /* rshift */
- "(>>=", /* rshift_ass */
- "(&", /* band */
- "(&=", /* band_ass */
- "(|", /* bor */
- "(|=", /* bor_ass */
- "(^", /* bxor */
- "(^=", /* bxor_ass */
- "(<=>", /* ncmp */
- "(cmp", /* scmp */
- "(~", /* compl */
- "(atan2", /* atan2 */
- "(cos", /* cos */
- "(sin", /* sin */
- "(exp", /* exp */
- "(log", /* log */
- "(sqrt", /* sqrt */
- "(x", /* repeat */
- "(x=", /* repeat_ass */
- "(.", /* concat */
- "(.=", /* concat_ass */
- "(~~", /* smart */
- "(-X", /* ftest */
- "(qr"
+ "()",
+ "(${}",
+ "(@{}",
+ "(%{}",
+ "(*{}",
+ "(&{}",
+ "(++",
+ "(--",
+ "(bool",
+ "(0+",
+ "(\"\"",
+ "(!",
+ "(=",
+ "(abs",
+ "(neg",
+ "(<>",
+ "(int",
+ "(<",
+ "(<=",
+ "(>",
+ "(>=",
+ "(==",
+ "(!=",
+ "(lt",
+ "(le",
+ "(gt",
+ "(ge",
+ "(eq",
+ "(ne",
+ "(nomethod",
+ "(+",
+ "(+=",
+ "(-",
+ "(-=",
+ "(*",
+ "(*=",
+ "(/",
+ "(/=",
+ "(%",
+ "(%=",
+ "(**",
+ "(**=",
+ "(<<",
+ "(<<=",
+ "(>>",
+ "(>>=",
+ "(&",
+ "(&=",
+ "(|",
+ "(|=",
+ "(^",
+ "(^=",
+ "(<=>",
+ "(cmp",
+ "(~",
+ "(atan2",
+ "(cos",
+ "(sin",
+ "(exp",
+ "(log",
+ "(sqrt",
+ "(x",
+ "(x=",
+ "(.",
+ "(.=",
+ "(~~",
+ "DESTROY"
};
-
-/* ex: set ro: */
diff --git a/gnu/usr.bin/perl/overload.h b/gnu/usr.bin/perl/overload.h
index 1628ac00252..17505851226 100644
--- a/gnu/usr.bin/perl/overload.h
+++ b/gnu/usr.bin/perl/overload.h
@@ -2,90 +2,87 @@
*
* overload.h
*
- * Copyright (C) 1997, 1998, 2000, 2001, 2005, 2006, 2007, 2011
- * by Larry Wall and others
+ * Copyright (C) 1997, 1998, 2000, 2001, 2005, 2006, 2007 by Larry Wall
+ * and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*
- * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
- * This file is built by regen/overload.pl.
- * Any changes made here will be lost!
+ * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ * This file is built by overload.pl
*/
enum {
- fallback_amg, /* 0x00 fallback */
- to_sv_amg, /* 0x01 ${} */
- to_av_amg, /* 0x02 @{} */
- to_hv_amg, /* 0x03 %{} */
- to_gv_amg, /* 0x04 *{} */
- to_cv_amg, /* 0x05 &{} */
- inc_amg, /* 0x06 ++ */
- dec_amg, /* 0x07 -- */
- bool__amg, /* 0x08 bool */
- numer_amg, /* 0x09 0+ */
- string_amg, /* 0x0a "" */
- not_amg, /* 0x0b ! */
- copy_amg, /* 0x0c = */
- abs_amg, /* 0x0d abs */
- neg_amg, /* 0x0e neg */
- iter_amg, /* 0x0f <> */
- int_amg, /* 0x10 int */
- lt_amg, /* 0x11 < */
- le_amg, /* 0x12 <= */
- gt_amg, /* 0x13 > */
- ge_amg, /* 0x14 >= */
- eq_amg, /* 0x15 == */
- ne_amg, /* 0x16 != */
- slt_amg, /* 0x17 lt */
- sle_amg, /* 0x18 le */
- sgt_amg, /* 0x19 gt */
- sge_amg, /* 0x1a ge */
- seq_amg, /* 0x1b eq */
- sne_amg, /* 0x1c ne */
- nomethod_amg, /* 0x1d nomethod */
- add_amg, /* 0x1e + */
- add_ass_amg, /* 0x1f += */
- subtr_amg, /* 0x20 - */
- subtr_ass_amg, /* 0x21 -= */
- mult_amg, /* 0x22 * */
- mult_ass_amg, /* 0x23 *= */
- div_amg, /* 0x24 / */
- div_ass_amg, /* 0x25 /= */
- modulo_amg, /* 0x26 % */
- modulo_ass_amg, /* 0x27 %= */
- pow_amg, /* 0x28 ** */
- pow_ass_amg, /* 0x29 **= */
- lshift_amg, /* 0x2a << */
- lshift_ass_amg, /* 0x2b <<= */
- rshift_amg, /* 0x2c >> */
- rshift_ass_amg, /* 0x2d >>= */
- band_amg, /* 0x2e & */
- band_ass_amg, /* 0x2f &= */
- bor_amg, /* 0x30 | */
- bor_ass_amg, /* 0x31 |= */
- bxor_amg, /* 0x32 ^ */
- bxor_ass_amg, /* 0x33 ^= */
- ncmp_amg, /* 0x34 <=> */
- scmp_amg, /* 0x35 cmp */
- compl_amg, /* 0x36 ~ */
- atan2_amg, /* 0x37 atan2 */
- cos_amg, /* 0x38 cos */
- sin_amg, /* 0x39 sin */
- exp_amg, /* 0x3a exp */
- log_amg, /* 0x3b log */
- sqrt_amg, /* 0x3c sqrt */
- repeat_amg, /* 0x3d x */
- repeat_ass_amg, /* 0x3e x= */
- concat_amg, /* 0x3f . */
- concat_ass_amg, /* 0x40 .= */
- smart_amg, /* 0x41 ~~ */
- ftest_amg, /* 0x42 -X */
- regexp_amg, /* 0x43 qr */
+ fallback_amg,
+ to_sv_amg,
+ to_av_amg,
+ to_hv_amg,
+ to_gv_amg,
+ to_cv_amg,
+ inc_amg,
+ dec_amg,
+ bool__amg,
+ numer_amg,
+ string_amg,
+ not_amg,
+ copy_amg,
+ abs_amg,
+ neg_amg,
+ iter_amg,
+ int_amg,
+ lt_amg,
+ le_amg,
+ gt_amg,
+ ge_amg,
+ eq_amg,
+ ne_amg,
+ slt_amg,
+ sle_amg,
+ sgt_amg,
+ sge_amg,
+ seq_amg,
+ sne_amg,
+ nomethod_amg,
+ add_amg,
+ add_ass_amg,
+ subtr_amg,
+ subtr_ass_amg,
+ mult_amg,
+ mult_ass_amg,
+ div_amg,
+ div_ass_amg,
+ modulo_amg,
+ modulo_ass_amg,
+ pow_amg,
+ pow_ass_amg,
+ lshift_amg,
+ lshift_ass_amg,
+ rshift_amg,
+ rshift_ass_amg,
+ band_amg,
+ band_ass_amg,
+ bor_amg,
+ bor_ass_amg,
+ bxor_amg,
+ bxor_ass_amg,
+ ncmp_amg,
+ scmp_amg,
+ compl_amg,
+ atan2_amg,
+ cos_amg,
+ sin_amg,
+ exp_amg,
+ log_amg,
+ sqrt_amg,
+ repeat_amg,
+ repeat_ass_amg,
+ concat_amg,
+ concat_ass_amg,
+ smart_amg,
+ DESTROY_amg,
max_amg_code
/* Do not leave a trailing comma here. C9X allows it, C89 doesn't. */
};
#define NofAMmeth max_amg_code
-/* ex: set ro: */
diff --git a/gnu/usr.bin/perl/parser.h b/gnu/usr.bin/perl/parser.h
index ff5867e4427..3cb31355fa6 100644
--- a/gnu/usr.bin/perl/parser.h
+++ b/gnu/usr.bin/perl/parser.h
@@ -1,12 +1,12 @@
/* parser.h
*
- * Copyright (c) 2006, 2007, 2009, 2010, 2011 Larry Wall and others
+ * Copyright (c) 2006, 2007, 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)
@@ -15,22 +15,12 @@ typedef struct {
YYSTYPE val; /* semantic value */
short state;
I32 savestack_ix; /* size of savestack at this state */
- CV *compcv; /* value of PL_compcv when this value was created */
+ AV *comppad; /* value of PL_comppad when this value was created */
#ifdef DEBUGGING
const char *name; /* token/rule name for -Dpv */
#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 */
-} LEXSHARED;
-
typedef struct yy_parser {
/* parser state */
@@ -49,13 +39,12 @@ typedef struct yy_parser {
/* lexer state */
- I32 lex_brackets; /* square and curly bracket count */
+ I32 lex_brackets; /* bracket count */
I32 lex_casemods; /* casemod count */
char *lex_brackstack;/* what kind of brackets to pop */
char *lex_casestack; /* what kind of case mods in effect */
U8 lex_defer; /* state after determined token */
- U8 lex_dojoin; /* doing an array interpolation
- 1 = @{...} 2 = ->@ */
+ bool lex_dojoin; /* doing an array interpolation */
U8 lex_expect; /* expect after determined token */
U8 expect; /* how to interpret ambiguous tokens */
I32 lex_formbrack; /* bracket count at outer format level */
@@ -63,40 +52,32 @@ typedef struct yy_parser {
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 named list or unary operator */
+ OPCODE last_lop_op; /* last list 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 */
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 */
+ /* XXX I32 space */
SUBLEXINFO sublex_info;
- LEXSHARED *lex_shared;
SV *linestr; /* current chunk of src text */
- 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 *bufptr;
+ char *oldbufptr;
+ char *oldoldbufptr;
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 */
- /* 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;
+ line_t copline; /* current line number */
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 */
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;
@@ -123,55 +104,7 @@ typedef struct yy_parser {
COP *saved_curcop; /* the previous PL_curcop */
char tokenbuf[256];
- line_t herelines; /* number of lines in here-doc */
- line_t preambling; /* line # when processing $ENV{PERL5DB} */
- 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 */
- PERL_BITFIELD16 saw_infix_sigil:1; /* saw & or * or % operator */
-} 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 */
-#define PARSE_OPTIONAL 0x00000001
-
-/* values for lex_fakeeof */
-enum {
- LEX_FAKEEOF_NEVER, /* don't fake EOF */
- LEX_FAKEEOF_CLOSING, /* fake EOF at unmatched closing punctuation */
- LEX_FAKEEOF_NONEXPR, /* ... and at token that can't be in expression */
- LEX_FAKEEOF_LOWLOGIC, /* ... and at low-precedence logic operator */
- LEX_FAKEEOF_COMMA, /* ... and at comma */
- LEX_FAKEEOF_ASSIGN, /* ... and at assignment operator */
- LEX_FAKEEOF_IFELSE, /* ... and at ?: operator */
- LEX_FAKEEOF_RANGE, /* ... and at range operator */
- LEX_FAKEEOF_LOGIC, /* ... and at logic operator */
- LEX_FAKEEOF_BITWISE, /* ... and at bitwise operator */
- LEX_FAKEEOF_COMPARE, /* ... and at comparison operator */
- LEX_FAKEEOF_MAX
-};
+} yy_parser;
+
-/*
- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: nil
- * End:
- *
- * ex: set ts=8 sts=4 sw=4 et:
- */
diff --git a/gnu/usr.bin/perl/perly.act b/gnu/usr.bin/perl/perly.act
index cb5e9ba227d..61c8f5b44a2 100644
--- a/gnu/usr.bin/perl/perly.act
+++ b/gnu/usr.bin/perl/perly.act
@@ -1,1004 +1,824 @@
-/* -*- buffer-read-only: t -*-
- !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
- This file is built by regen_perly.pl from perly.y.
- Any changes made here will be lost!
- */
-
case 2:
-#line 142 "perly.y"
- {
- PL_parser->expect = XSTATE;
- }
+#line 137 "perly.y"
+ { (yyval.ival) = (ps[(1) - (2)].val.ival); newPROG(block_end((ps[(1) - (2)].val.ival),(ps[(2) - (2)].val.opval))); ;}
break;
case 3:
-#line 146 "perly.y"
- {
- newPROG(block_end((ps[(3) - (4)].val.ival),(ps[(4) - (4)].val.opval)));
- (yyval.ival) = 0;
- }
+#line 142 "perly.y"
+ { if (PL_parser->copline > (line_t)IVAL((ps[(1) - (4)].val.i_tkval)))
+ PL_parser->copline = (line_t)IVAL((ps[(1) - (4)].val.i_tkval));
+ (yyval.opval) = block_end((ps[(2) - (4)].val.ival), (ps[(3) - (4)].val.opval));
+ TOKEN_GETMAD((ps[(1) - (4)].val.i_tkval),(yyval.opval),'{');
+ TOKEN_GETMAD((ps[(4) - (4)].val.i_tkval),(yyval.opval),'}');
+ ;}
break;
case 4:
#line 151 "perly.y"
- {
- parser->expect = XTERM;
- }
+ { (yyval.ival) = block_start(TRUE); ;}
break;
case 5:
#line 155 "perly.y"
- {
- PL_eval_root = (ps[(3) - (3)].val.opval);
- (yyval.ival) = 0;
- }
+ { (yyval.ival) = (I32) allocmy("$_"); ;}
break;
case 6:
-#line 160 "perly.y"
+#line 159 "perly.y"
{
- parser->expect = XBLOCK;
- }
+ PL_parser->expect = XSTATE; (yyval.ival) = block_start(TRUE);
+ ;}
break;
case 7:
-#line 164 "perly.y"
- {
- PL_pad_reset_pending = TRUE;
- PL_eval_root = (ps[(3) - (3)].val.opval);
- (yyval.ival) = 0;
- yyunlex();
- parser->yychar = YYEOF;
- }
+#line 166 "perly.y"
+ { if (PL_parser->copline > (line_t)IVAL((ps[(1) - (4)].val.i_tkval)))
+ PL_parser->copline = (line_t)IVAL((ps[(1) - (4)].val.i_tkval));
+ (yyval.opval) = block_end((ps[(2) - (4)].val.ival), (ps[(3) - (4)].val.opval));
+ TOKEN_GETMAD((ps[(1) - (4)].val.i_tkval),(yyval.opval),'{');
+ TOKEN_GETMAD((ps[(4) - (4)].val.i_tkval),(yyval.opval),'}');
+ ;}
break;
case 8:
-#line 172 "perly.y"
- {
- parser->expect = XSTATE;
- }
+#line 175 "perly.y"
+ { (yyval.ival) = block_start(FALSE); ;}
break;
case 9:
-#line 176 "perly.y"
- {
- PL_pad_reset_pending = TRUE;
- PL_eval_root = (ps[(3) - (3)].val.opval);
- (yyval.ival) = 0;
- yyunlex();
- parser->yychar = YYEOF;
- }
+#line 180 "perly.y"
+ { (yyval.opval) = Nullop; ;}
break;
case 10:
-#line 184 "perly.y"
+#line 182 "perly.y"
{
- parser->expect = XSTATE;
- }
+ (yyval.opval) = IF_MAD(
+ append_list(OP_LINESEQ,
+ (LISTOP*)(ps[(1) - (2)].val.opval), (LISTOP*)(ps[(2) - (2)].val.opval)),
+ (ps[(1) - (2)].val.opval));
+ ;}
break;
case 11:
-#line 188 "perly.y"
- {
- PL_pad_reset_pending = TRUE;
- PL_eval_root = (ps[(3) - (3)].val.opval);
- (yyval.ival) = 0;
- yyunlex();
- parser->yychar = YYEOF;
- }
+#line 189 "perly.y"
+ { (yyval.opval) = append_list(OP_LINESEQ,
+ (LISTOP*)(ps[(1) - (2)].val.opval), (LISTOP*)(ps[(2) - (2)].val.opval));
+ PL_pad_reset_pending = TRUE;
+ if ((ps[(1) - (2)].val.opval) && (ps[(2) - (2)].val.opval))
+ PL_hints |= HINT_BLOCK_SCOPE;
+ ;}
break;
case 12:
-#line 196 "perly.y"
- {
- parser->expect = XSTATE;
- }
- break;
-
- case 13:
-#line 200 "perly.y"
- {
- PL_eval_root = (ps[(3) - (3)].val.opval);
- (yyval.ival) = 0;
- }
+#line 199 "perly.y"
+ { (yyval.opval) = newSTATEOP(0, PVAL((ps[(1) - (2)].val.p_tkval)), (ps[(2) - (2)].val.opval));
+ TOKEN_GETMAD((ps[(1) - (2)].val.p_tkval),((LISTOP*)(yyval.opval))->op_first,'L'); ;}
break;
case 14:
-#line 208 "perly.y"
- { if (PL_parser->copline > (line_t)IVAL((ps[(1) - (4)].val.i_tkval)))
- PL_parser->copline = (line_t)IVAL((ps[(1) - (4)].val.i_tkval));
- (yyval.opval) = block_end((ps[(2) - (4)].val.ival), (ps[(3) - (4)].val.opval));
- TOKEN_GETMAD((ps[(1) - (4)].val.i_tkval),(yyval.opval),'{');
- TOKEN_GETMAD((ps[(4) - (4)].val.i_tkval),(yyval.opval),'}');
- }
+#line 203 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 15:
-#line 218 "perly.y"
- { if (PL_parser->copline > (line_t)IVAL((ps[(1) - (7)].val.i_tkval)))
- PL_parser->copline = (line_t)IVAL((ps[(1) - (7)].val.i_tkval));
- (yyval.opval) = block_end((ps[(2) - (7)].val.ival), (ps[(5) - (7)].val.opval));
- TOKEN_GETMAD((ps[(1) - (7)].val.i_tkval),(yyval.opval),'{');
- TOKEN_GETMAD((ps[(7) - (7)].val.i_tkval),(yyval.opval),'}');
- }
+#line 205 "perly.y"
+ { (yyval.opval) = newSTATEOP(0, PVAL((ps[(1) - (2)].val.p_tkval)), (ps[(2) - (2)].val.opval)); ;}
break;
case 16:
-#line 227 "perly.y"
- { (yyval.ival) = block_start(TRUE); }
+#line 207 "perly.y"
+ {
+ if (PVAL((ps[(1) - (2)].val.p_tkval))) {
+ (yyval.opval) = newSTATEOP(0, PVAL((ps[(1) - (2)].val.p_tkval)), newOP(OP_NULL, 0));
+ TOKEN_GETMAD((ps[(1) - (2)].val.p_tkval),(yyval.opval),'L');
+ TOKEN_GETMAD((ps[(2) - (2)].val.i_tkval),((LISTOP*)(yyval.opval))->op_first,';');
+ }
+ else {
+ (yyval.opval) = IF_MAD(
+ newOP(OP_NULL, 0),
+ Nullop);
+ PL_parser->copline = NOLINE;
+ TOKEN_FREE((ps[(1) - (2)].val.p_tkval));
+ TOKEN_GETMAD((ps[(2) - (2)].val.i_tkval),(yyval.opval),';');
+ }
+ PL_parser->expect = XSTATE;
+ ;}
break;
case 17:
-#line 231 "perly.y"
- { if (PL_parser->copline > (line_t)IVAL((ps[(1) - (4)].val.i_tkval)))
- PL_parser->copline = (line_t)IVAL((ps[(1) - (4)].val.i_tkval));
- (yyval.opval) = block_end((ps[(2) - (4)].val.ival), (ps[(3) - (4)].val.opval));
- TOKEN_GETMAD((ps[(1) - (4)].val.i_tkval),(yyval.opval),'{');
- TOKEN_GETMAD((ps[(4) - (4)].val.i_tkval),(yyval.opval),'}');
- }
+#line 224 "perly.y"
+ {
+ (yyval.opval) = newSTATEOP(0, PVAL((ps[(1) - (3)].val.p_tkval)), (ps[(2) - (3)].val.opval));
+ PL_parser->expect = XSTATE;
+ DO_MAD({
+ /* sideff might already have a nexstate */
+ OP* op = ((LISTOP*)(yyval.opval))->op_first;
+ if (op) {
+ while (op->op_sibling &&
+ op->op_sibling->op_type == OP_NEXTSTATE)
+ op = op->op_sibling;
+ token_getmad((ps[(1) - (3)].val.p_tkval),op,'L');
+ token_getmad((ps[(3) - (3)].val.i_tkval),op,';');
+ }
+ })
+ ;}
break;
case 18:
-#line 240 "perly.y"
- { (yyval.ival) = block_start(FALSE); }
+#line 243 "perly.y"
+ { (yyval.opval) = Nullop; ;}
break;
case 19:
#line 245 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 20:
#line 247 "perly.y"
- { (yyval.opval) = op_append_list(OP_LINESEQ, (ps[(1) - (2)].val.opval), (ps[(2) - (2)].val.opval));
- PL_pad_reset_pending = TRUE;
- if ((ps[(1) - (2)].val.opval) && (ps[(2) - (2)].val.opval))
- PL_hints |= HINT_BLOCK_SCOPE;
- }
+ { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval));
+ TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'i');
+ ;}
break;
case 21:
-#line 256 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+#line 251 "perly.y"
+ { (yyval.opval) = newLOGOP(OP_OR, 0, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval));
+ TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'i');
+ ;}
break;
case 22:
-#line 258 "perly.y"
- { (yyval.opval) = op_append_list(OP_LINESEQ, (ps[(1) - (2)].val.opval), (ps[(2) - (2)].val.opval));
- PL_pad_reset_pending = TRUE;
- if ((ps[(1) - (2)].val.opval) && (ps[(2) - (2)].val.opval))
- PL_hints |= HINT_BLOCK_SCOPE;
- }
+#line 255 "perly.y"
+ { (yyval.opval) = newLOOPOP(OPf_PARENS, 1, scalar((ps[(3) - (3)].val.opval)), (ps[(1) - (3)].val.opval));
+ TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'w');
+ ;}
break;
case 23:
-#line 267 "perly.y"
- {
- if((ps[(1) - (1)].val.opval)) {
- (yyval.opval) = newSTATEOP(0, NULL, (ps[(1) - (1)].val.opval));
- } else {
- (yyval.opval) = IF_MAD(newOP(OP_NULL, 0), NULL);
- }
- }
+#line 259 "perly.y"
+ { (yyval.opval) = newLOOPOP(OPf_PARENS, 1, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval));
+ TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'w');
+ ;}
break;
case 24:
-#line 275 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+#line 263 "perly.y"
+ { (yyval.opval) = newFOROP(0, NULL, (line_t)IVAL((ps[(2) - (3)].val.i_tkval)),
+ Nullop, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval), Nullop);
+ TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),((LISTOP*)(yyval.opval))->op_first->op_sibling,'w');
+ ;}
break;
case 25:
-#line 279 "perly.y"
- {
- (yyval.opval) = newSTATEOP(SVf_UTF8
- * PVAL((ps[(1) - (2)].val.p_tkval))[strlen(PVAL((ps[(1) - (2)].val.p_tkval)))+1],
- PVAL((ps[(1) - (2)].val.p_tkval)), (ps[(2) - (2)].val.opval));
- TOKEN_GETMAD((ps[(1) - (2)].val.p_tkval),
- (ps[(2) - (2)].val.opval) ? cLISTOPx((yyval.opval))->op_first : (yyval.opval), 'L');
- }
+#line 271 "perly.y"
+ { (yyval.opval) = Nullop; ;}
break;
case 26:
-#line 287 "perly.y"
- {
- (yyval.opval) = newSTATEOP(SVf_UTF8
- * PVAL((ps[(1) - (2)].val.p_tkval))[strlen(PVAL((ps[(1) - (2)].val.p_tkval)))+1],
- PVAL((ps[(1) - (2)].val.p_tkval)), (ps[(2) - (2)].val.opval));
- TOKEN_GETMAD((ps[(1) - (2)].val.p_tkval), cLISTOPx((yyval.opval))->op_first, 'L');
- }
+#line 273 "perly.y"
+ { ((ps[(2) - (2)].val.opval))->op_flags |= OPf_PARENS; (yyval.opval) = scope((ps[(2) - (2)].val.opval));
+ TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'o');
+ ;}
break;
case 27:
-#line 297 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+#line 277 "perly.y"
+ { PL_parser->copline = (line_t)IVAL((ps[(1) - (6)].val.i_tkval));
+ (yyval.opval) = newCONDOP(0, (ps[(3) - (6)].val.opval), scope((ps[(5) - (6)].val.opval)), (ps[(6) - (6)].val.opval));
+ PL_hints |= HINT_BLOCK_SCOPE;
+ TOKEN_GETMAD((ps[(1) - (6)].val.i_tkval),(yyval.opval),'I');
+ TOKEN_GETMAD((ps[(2) - (6)].val.i_tkval),(yyval.opval),'(');
+ TOKEN_GETMAD((ps[(4) - (6)].val.i_tkval),(yyval.opval),')');
+ ;}
break;
case 28:
-#line 299 "perly.y"
- {
- (yyval.opval) = newOP(OP_NULL,0);
- TOKEN_GETMAD((ps[(1) - (1)].val.i_tkval),(yyval.opval),'p');
- }
+#line 288 "perly.y"
+ { PL_parser->copline = (line_t)IVAL((ps[(1) - (7)].val.i_tkval));
+ (yyval.opval) = block_end((ps[(3) - (7)].val.ival),
+ newCONDOP(0, (ps[(4) - (7)].val.opval), scope((ps[(6) - (7)].val.opval)), (ps[(7) - (7)].val.opval)));
+ TOKEN_GETMAD((ps[(1) - (7)].val.i_tkval),(yyval.opval),'I');
+ TOKEN_GETMAD((ps[(2) - (7)].val.i_tkval),(yyval.opval),'(');
+ TOKEN_GETMAD((ps[(5) - (7)].val.i_tkval),(yyval.opval),')');
+ ;}
break;
case 29:
-#line 304 "perly.y"
- {
- CV *fmtcv = PL_compcv;
-#ifdef MAD
- (yyval.opval) = newFORM((ps[(2) - (4)].val.ival), (ps[(3) - (4)].val.opval), (ps[(4) - (4)].val.opval));
- prepend_madprops((ps[(1) - (4)].val.i_tkval)->tk_mad, (yyval.opval), 'F');
- (ps[(1) - (4)].val.i_tkval)->tk_mad = 0;
- token_free((ps[(1) - (4)].val.i_tkval));
-#else
- newFORM((ps[(2) - (4)].val.ival), (ps[(3) - (4)].val.opval), (ps[(4) - (4)].val.opval));
- (yyval.opval) = (OP*)NULL;
-#endif
- if (CvOUTSIDE(fmtcv) && !CvEVAL(CvOUTSIDE(fmtcv))) {
- SvREFCNT_inc_simple_void(fmtcv);
- pad_add_anon(fmtcv, OP_NULL);
- }
- }
+#line 296 "perly.y"
+ { PL_parser->copline = (line_t)IVAL((ps[(1) - (7)].val.i_tkval));
+ (yyval.opval) = block_end((ps[(3) - (7)].val.ival),
+ newCONDOP(0, (ps[(4) - (7)].val.opval), scope((ps[(6) - (7)].val.opval)), (ps[(7) - (7)].val.opval)));
+ TOKEN_GETMAD((ps[(1) - (7)].val.i_tkval),(yyval.opval),'I');
+ TOKEN_GETMAD((ps[(2) - (7)].val.i_tkval),(yyval.opval),'(');
+ TOKEN_GETMAD((ps[(5) - (7)].val.i_tkval),(yyval.opval),')');
+ ;}
break;
case 30:
-#line 321 "perly.y"
- {
- if ((ps[(2) - (3)].val.opval)->op_type == OP_CONST) {
- const char *const name =
- SvPV_nolen_const(((SVOP*)(ps[(2) - (3)].val.opval))->op_sv);
- if (strEQ(name, "BEGIN") || strEQ(name, "END")
- || strEQ(name, "INIT") || strEQ(name, "CHECK")
- || strEQ(name, "UNITCHECK"))
- CvSPECIAL_on(PL_compcv);
- }
- else
- /* State subs inside anonymous subs need to be
- clonable themselves. */
- if (CvANON(CvOUTSIDE(PL_compcv))
- || CvCLONE(CvOUTSIDE(PL_compcv))
- || !PadnameIsSTATE(PadlistNAMESARRAY(CvPADLIST(
- CvOUTSIDE(PL_compcv)
- ))[(ps[(2) - (3)].val.opval)->op_targ]))
- CvCLONE_on(PL_compcv);
- PL_parser->in_my = 0;
- PL_parser->in_my_stash = NULL;
- }
+#line 307 "perly.y"
+ { (yyval.opval) = block_end((ps[(3) - (6)].val.ival),
+ newWHENOP((ps[(4) - (6)].val.opval), scope((ps[(6) - (6)].val.opval)))); ;}
break;
case 31:
-#line 343 "perly.y"
- {
- SvREFCNT_inc_simple_void(PL_compcv);
-#ifdef MAD
- {
- OP* o = newSVOP(OP_ANONCODE, 0,
- (SV*)(
-#endif
- (ps[(2) - (7)].val.opval)->op_type == OP_CONST
- ? newATTRSUB((ps[(3) - (7)].val.ival), (ps[(2) - (7)].val.opval), (ps[(5) - (7)].val.opval), (ps[(6) - (7)].val.opval), (ps[(7) - (7)].val.opval))
- : newMYSUB((ps[(3) - (7)].val.ival), (ps[(2) - (7)].val.opval), (ps[(5) - (7)].val.opval), (ps[(6) - (7)].val.opval), (ps[(7) - (7)].val.opval))
-#ifdef MAD
- ));
- (yyval.opval) = newOP(OP_NULL,0);
- op_getmad(o,(yyval.opval),'&');
- op_getmad((ps[(2) - (7)].val.opval),(yyval.opval),'n');
- op_getmad((ps[(5) - (7)].val.opval),(yyval.opval),'s');
- op_getmad((ps[(6) - (7)].val.opval),(yyval.opval),'a');
- token_getmad((ps[(1) - (7)].val.i_tkval),(yyval.opval),'d');
- append_madprops((ps[(7) - (7)].val.opval)->op_madprop, (yyval.opval), 0);
- (ps[(7) - (7)].val.opval)->op_madprop = 0;
- }
-#else
- ;
- (yyval.opval) = (OP*)NULL;
-#endif
- intro_my();
- }
+#line 310 "perly.y"
+ { (yyval.opval) = newWHENOP(0, scope((ps[(2) - (2)].val.opval))); ;}
break;
case 32:
-#line 371 "perly.y"
- {
-#ifdef MAD
- (yyval.opval) = package((ps[(3) - (4)].val.opval));
- token_getmad((ps[(1) - (4)].val.i_tkval),(yyval.opval),'o');
- if ((ps[(2) - (4)].val.opval))
- package_version((ps[(2) - (4)].val.opval));
- token_getmad((ps[(4) - (4)].val.i_tkval),(yyval.opval),';');
-#else
- package((ps[(3) - (4)].val.opval));
- if ((ps[(2) - (4)].val.opval))
- package_version((ps[(2) - (4)].val.opval));
- (yyval.opval) = (OP*)NULL;
-#endif
- }
+#line 315 "perly.y"
+ { (yyval.opval) = Nullop; ;}
break;
case 33:
-#line 386 "perly.y"
- { CvSPECIAL_on(PL_compcv); /* It's a BEGIN {} */ }
+#line 317 "perly.y"
+ { (yyval.opval) = scope((ps[(2) - (2)].val.opval));
+ TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'o');
+ ;}
break;
case 34:
-#line 388 "perly.y"
- {
- SvREFCNT_inc_simple_void(PL_compcv);
-#ifdef MAD
- (yyval.opval) = utilize(IVAL((ps[(1) - (7)].val.i_tkval)), (ps[(2) - (7)].val.ival), (ps[(4) - (7)].val.opval), (ps[(5) - (7)].val.opval), (ps[(6) - (7)].val.opval));
- token_getmad((ps[(1) - (7)].val.i_tkval),(yyval.opval),'o');
- token_getmad((ps[(7) - (7)].val.i_tkval),(yyval.opval),';');
- if (PL_parser->rsfp_filters &&
- AvFILLp(PL_parser->rsfp_filters) >= 0)
- append_madprops(newMADPROP('!', MAD_NULL, NULL, 0), (yyval.opval), 0);
-#else
- utilize(IVAL((ps[(1) - (7)].val.i_tkval)), (ps[(2) - (7)].val.ival), (ps[(4) - (7)].val.opval), (ps[(5) - (7)].val.opval), (ps[(6) - (7)].val.opval));
- (yyval.opval) = (OP*)NULL;
-#endif
- }
+#line 324 "perly.y"
+ { OP *innerop;
+ PL_parser->copline = (line_t)(ps[(2) - (9)].val.i_tkval);
+ (yyval.opval) = block_end((ps[(4) - (9)].val.ival),
+ newSTATEOP(0, PVAL((ps[(1) - (9)].val.p_tkval)),
+ innerop = newWHILEOP(0, 1, (LOOP*)Nullop,
+ IVAL((ps[(2) - (9)].val.i_tkval)), (ps[(5) - (9)].val.opval), (ps[(8) - (9)].val.opval), (ps[(9) - (9)].val.opval), (ps[(7) - (9)].val.ival))));
+ TOKEN_GETMAD((ps[(1) - (9)].val.p_tkval),innerop,'L');
+ TOKEN_GETMAD((ps[(2) - (9)].val.i_tkval),innerop,'W');
+ TOKEN_GETMAD((ps[(3) - (9)].val.i_tkval),innerop,'(');
+ TOKEN_GETMAD((ps[(6) - (9)].val.i_tkval),innerop,')');
+ ;}
break;
case 35:
-#line 403 "perly.y"
- {
- (yyval.opval) = block_end((ps[(3) - (7)].val.ival),
- newCONDOP(0, (ps[(4) - (7)].val.opval), op_scope((ps[(6) - (7)].val.opval)), (ps[(7) - (7)].val.opval)));
- TOKEN_GETMAD((ps[(1) - (7)].val.i_tkval),(yyval.opval),'I');
- TOKEN_GETMAD((ps[(2) - (7)].val.i_tkval),(yyval.opval),'(');
- TOKEN_GETMAD((ps[(5) - (7)].val.i_tkval),(yyval.opval),')');
- PL_parser->copline = (line_t)IVAL((ps[(1) - (7)].val.i_tkval));
- }
+#line 337 "perly.y"
+ { OP *innerop;
+ PL_parser->copline = (line_t)(ps[(2) - (9)].val.i_tkval);
+ (yyval.opval) = block_end((ps[(4) - (9)].val.ival),
+ newSTATEOP(0, PVAL((ps[(1) - (9)].val.p_tkval)),
+ innerop = newWHILEOP(0, 1, (LOOP*)Nullop,
+ IVAL((ps[(2) - (9)].val.i_tkval)), (ps[(5) - (9)].val.opval), (ps[(8) - (9)].val.opval), (ps[(9) - (9)].val.opval), (ps[(7) - (9)].val.ival))));
+ TOKEN_GETMAD((ps[(1) - (9)].val.p_tkval),innerop,'L');
+ TOKEN_GETMAD((ps[(2) - (9)].val.i_tkval),innerop,'W');
+ TOKEN_GETMAD((ps[(3) - (9)].val.i_tkval),innerop,'(');
+ TOKEN_GETMAD((ps[(6) - (9)].val.i_tkval),innerop,')');
+ ;}
break;
case 36:
-#line 412 "perly.y"
- {
- (yyval.opval) = block_end((ps[(3) - (7)].val.ival),
- newCONDOP(0, (ps[(4) - (7)].val.opval), op_scope((ps[(6) - (7)].val.opval)), (ps[(7) - (7)].val.opval)));
- TOKEN_GETMAD((ps[(1) - (7)].val.i_tkval),(yyval.opval),'I');
- TOKEN_GETMAD((ps[(2) - (7)].val.i_tkval),(yyval.opval),'(');
- TOKEN_GETMAD((ps[(5) - (7)].val.i_tkval),(yyval.opval),')');
- PL_parser->copline = (line_t)IVAL((ps[(1) - (7)].val.i_tkval));
- }
+#line 349 "perly.y"
+ { OP *innerop;
+ (yyval.opval) = block_end((ps[(4) - (10)].val.ival),
+ innerop = newFOROP(0, PVAL((ps[(1) - (10)].val.p_tkval)), (line_t)IVAL((ps[(2) - (10)].val.i_tkval)),
+ (ps[(5) - (10)].val.opval), (ps[(7) - (10)].val.opval), (ps[(9) - (10)].val.opval), (ps[(10) - (10)].val.opval)));
+ TOKEN_GETMAD((ps[(1) - (10)].val.p_tkval),((LISTOP*)innerop)->op_first,'L');
+ TOKEN_GETMAD((ps[(2) - (10)].val.i_tkval),((LISTOP*)innerop)->op_first->op_sibling,'W');
+ TOKEN_GETMAD((ps[(3) - (10)].val.i_tkval),((LISTOP*)innerop)->op_first->op_sibling,'d');
+ TOKEN_GETMAD((ps[(6) - (10)].val.i_tkval),((LISTOP*)innerop)->op_first->op_sibling,'(');
+ TOKEN_GETMAD((ps[(8) - (10)].val.i_tkval),((LISTOP*)innerop)->op_first->op_sibling,')');
+ ;}
break;
case 37:
-#line 421 "perly.y"
- {
- const PADOFFSET offset = pad_findmy_pvs("$_", 0);
- (yyval.opval) = block_end((ps[(3) - (6)].val.ival),
- newGIVENOP((ps[(4) - (6)].val.opval), op_scope((ps[(6) - (6)].val.opval)),
- offset == NOT_IN_PAD
- || PAD_COMPNAME_FLAGS_isOUR(offset)
- ? 0
- : offset));
- PL_parser->copline = (line_t)IVAL((ps[(1) - (6)].val.i_tkval));
- }
+#line 360 "perly.y"
+ { OP *innerop;
+ (yyval.opval) = block_end((ps[(5) - (9)].val.ival),
+ innerop = newFOROP(0, PVAL((ps[(1) - (9)].val.p_tkval)), (line_t)IVAL((ps[(2) - (9)].val.i_tkval)),
+ mod((ps[(3) - (9)].val.opval), OP_ENTERLOOP), (ps[(6) - (9)].val.opval), (ps[(8) - (9)].val.opval), (ps[(9) - (9)].val.opval)));
+ TOKEN_GETMAD((ps[(1) - (9)].val.p_tkval),((LISTOP*)innerop)->op_first,'L');
+ TOKEN_GETMAD((ps[(2) - (9)].val.i_tkval),((LISTOP*)innerop)->op_first->op_sibling,'W');
+ TOKEN_GETMAD((ps[(4) - (9)].val.i_tkval),((LISTOP*)innerop)->op_first->op_sibling,'(');
+ TOKEN_GETMAD((ps[(7) - (9)].val.i_tkval),((LISTOP*)innerop)->op_first->op_sibling,')');
+ ;}
break;
case 38:
-#line 432 "perly.y"
- { (yyval.opval) = block_end((ps[(3) - (6)].val.ival), newWHENOP((ps[(4) - (6)].val.opval), op_scope((ps[(6) - (6)].val.opval)))); }
+#line 370 "perly.y"
+ { OP *innerop;
+ (yyval.opval) = block_end((ps[(4) - (8)].val.ival),
+ innerop = newFOROP(0, PVAL((ps[(1) - (8)].val.p_tkval)), (line_t)IVAL((ps[(2) - (8)].val.i_tkval)),
+ Nullop, (ps[(5) - (8)].val.opval), (ps[(7) - (8)].val.opval), (ps[(8) - (8)].val.opval)));
+ TOKEN_GETMAD((ps[(1) - (8)].val.p_tkval),((LISTOP*)innerop)->op_first,'L');
+ TOKEN_GETMAD((ps[(2) - (8)].val.i_tkval),((LISTOP*)innerop)->op_first->op_sibling,'W');
+ TOKEN_GETMAD((ps[(3) - (8)].val.i_tkval),((LISTOP*)innerop)->op_first->op_sibling,'(');
+ TOKEN_GETMAD((ps[(6) - (8)].val.i_tkval),((LISTOP*)innerop)->op_first->op_sibling,')');
+ ;}
break;
case 39:
-#line 434 "perly.y"
- { (yyval.opval) = newWHENOP(0, op_scope((ps[(2) - (2)].val.opval))); }
+#line 382 "perly.y"
+ { OP *forop;
+ PL_parser->copline = (line_t)IVAL((ps[(2) - (12)].val.i_tkval));
+ forop = newSTATEOP(0, PVAL((ps[(1) - (12)].val.p_tkval)),
+ newWHILEOP(0, 1, (LOOP*)Nullop,
+ IVAL((ps[(2) - (12)].val.i_tkval)), scalar((ps[(7) - (12)].val.opval)),
+ (ps[(12) - (12)].val.opval), (ps[(10) - (12)].val.opval), (ps[(9) - (12)].val.ival)));
+#ifdef MAD
+ forop = newUNOP(OP_NULL, 0, append_elem(OP_LINESEQ,
+ newSTATEOP(0,
+ CopLABEL_alloc(((ps[(1) - (12)].val.p_tkval))->tk_lval.pval),
+ ((ps[(5) - (12)].val.opval) ? (ps[(5) - (12)].val.opval) : newOP(OP_NULL, 0)) ),
+ forop));
+
+ token_getmad((ps[(2) - (12)].val.i_tkval),forop,'3');
+ token_getmad((ps[(3) - (12)].val.i_tkval),forop,'(');
+ token_getmad((ps[(6) - (12)].val.i_tkval),forop,'1');
+ token_getmad((ps[(8) - (12)].val.i_tkval),forop,'2');
+ token_getmad((ps[(11) - (12)].val.i_tkval),forop,')');
+ token_getmad((ps[(1) - (12)].val.p_tkval),forop,'L');
+#else
+ if ((ps[(5) - (12)].val.opval)) {
+ forop = append_elem(OP_LINESEQ,
+ newSTATEOP(0, CopLABEL_alloc((ps[(1) - (12)].val.p_tkval)), (ps[(5) - (12)].val.opval)),
+ forop);
+ }
+
+
+#endif
+ (yyval.opval) = block_end((ps[(4) - (12)].val.ival), forop); ;}
break;
case 40:
-#line 436 "perly.y"
- {
- (yyval.opval) = block_end((ps[(3) - (8)].val.ival),
- newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
- (ps[(4) - (8)].val.opval), (ps[(7) - (8)].val.opval), (ps[(8) - (8)].val.opval), (ps[(6) - (8)].val.ival)));
- TOKEN_GETMAD((ps[(1) - (8)].val.i_tkval),(yyval.opval),'W');
- TOKEN_GETMAD((ps[(2) - (8)].val.i_tkval),(yyval.opval),'(');
- TOKEN_GETMAD((ps[(5) - (8)].val.i_tkval),(yyval.opval),')');
- PL_parser->copline = (line_t)IVAL((ps[(1) - (8)].val.i_tkval));
- }
+#line 412 "perly.y"
+ { (yyval.opval) = newSTATEOP(0, PVAL((ps[(1) - (3)].val.p_tkval)),
+ newWHILEOP(0, 1, (LOOP*)Nullop,
+ NOLINE, Nullop, (ps[(2) - (3)].val.opval), (ps[(3) - (3)].val.opval), 0));
+ TOKEN_GETMAD((ps[(1) - (3)].val.p_tkval),((LISTOP*)(yyval.opval))->op_first,'L'); ;}
break;
case 41:
-#line 446 "perly.y"
- {
- (yyval.opval) = block_end((ps[(3) - (8)].val.ival),
- newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
- (ps[(4) - (8)].val.opval), (ps[(7) - (8)].val.opval), (ps[(8) - (8)].val.opval), (ps[(6) - (8)].val.ival)));
- TOKEN_GETMAD((ps[(1) - (8)].val.i_tkval),(yyval.opval),'W');
- TOKEN_GETMAD((ps[(2) - (8)].val.i_tkval),(yyval.opval),'(');
- TOKEN_GETMAD((ps[(5) - (8)].val.i_tkval),(yyval.opval),')');
- PL_parser->copline = (line_t)IVAL((ps[(1) - (8)].val.i_tkval));
- }
+#line 420 "perly.y"
+ { PL_parser->copline = (line_t) (ps[(2) - (8)].val.i_tkval);
+ (yyval.opval) = block_end((ps[(4) - (8)].val.ival),
+ newSTATEOP(0, PVAL((ps[(1) - (8)].val.p_tkval)),
+ newGIVENOP((ps[(6) - (8)].val.opval), scope((ps[(8) - (8)].val.opval)),
+ (PADOFFSET) (ps[(5) - (8)].val.ival)) )); ;}
break;
case 42:
-#line 457 "perly.y"
- {
- OP *initop = IF_MAD((ps[(4) - (11)].val.opval) ? (ps[(4) - (11)].val.opval) : newOP(OP_NULL, 0), (ps[(4) - (11)].val.opval));
- OP *forop = newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
- scalar((ps[(6) - (11)].val.opval)), (ps[(11) - (11)].val.opval), (ps[(9) - (11)].val.opval), (ps[(8) - (11)].val.ival));
- if (initop) {
- forop = op_prepend_elem(OP_LINESEQ, initop,
- op_append_elem(OP_LINESEQ,
- newOP(OP_UNSTACK, OPf_SPECIAL),
- forop));
- }
- DO_MAD({ forop = newUNOP(OP_NULL, 0, forop); })
- (yyval.opval) = block_end((ps[(3) - (11)].val.ival), forop);
- TOKEN_GETMAD((ps[(1) - (11)].val.i_tkval),(yyval.opval),'3');
- TOKEN_GETMAD((ps[(2) - (11)].val.i_tkval),(yyval.opval),'(');
- TOKEN_GETMAD((ps[(5) - (11)].val.i_tkval),(yyval.opval),'1');
- TOKEN_GETMAD((ps[(7) - (11)].val.i_tkval),(yyval.opval),'2');
- TOKEN_GETMAD((ps[(10) - (11)].val.i_tkval),(yyval.opval),')');
- PL_parser->copline = (line_t)IVAL((ps[(1) - (11)].val.i_tkval));
- }
+#line 429 "perly.y"
+ { (yyval.ival) = (PL_min_intro_pending &&
+ PL_max_intro_pending >= PL_min_intro_pending);
+ intro_my(); ;}
break;
case 43:
-#line 477 "perly.y"
- {
- (yyval.opval) = block_end((ps[(3) - (9)].val.ival), newFOROP(0, (ps[(4) - (9)].val.opval), (ps[(6) - (9)].val.opval), (ps[(8) - (9)].val.opval), (ps[(9) - (9)].val.opval)));
- TOKEN_GETMAD((ps[(1) - (9)].val.i_tkval),(yyval.opval),'W');
- TOKEN_GETMAD((ps[(2) - (9)].val.i_tkval),(yyval.opval),'d');
- TOKEN_GETMAD((ps[(5) - (9)].val.i_tkval),(yyval.opval),'(');
- TOKEN_GETMAD((ps[(7) - (9)].val.i_tkval),(yyval.opval),')');
- PL_parser->copline = (line_t)IVAL((ps[(1) - (9)].val.i_tkval));
- }
- break;
-
- case 44:
-#line 486 "perly.y"
- {
- (yyval.opval) = block_end((ps[(4) - (8)].val.ival), newFOROP(0,
- op_lvalue((ps[(2) - (8)].val.opval), OP_ENTERLOOP), (ps[(5) - (8)].val.opval), (ps[(7) - (8)].val.opval), (ps[(8) - (8)].val.opval)));
- TOKEN_GETMAD((ps[(1) - (8)].val.i_tkval),(yyval.opval),'W');
- TOKEN_GETMAD((ps[(3) - (8)].val.i_tkval),(yyval.opval),'(');
- TOKEN_GETMAD((ps[(6) - (8)].val.i_tkval),(yyval.opval),')');
- PL_parser->copline = (line_t)IVAL((ps[(1) - (8)].val.i_tkval));
- }
+#line 435 "perly.y"
+ { (yyval.opval) = Nullop; ;}
break;
case 45:
-#line 495 "perly.y"
- {
- (yyval.opval) = block_end((ps[(3) - (7)].val.ival),
- newFOROP(0, (OP*)NULL, (ps[(4) - (7)].val.opval), (ps[(6) - (7)].val.opval), (ps[(7) - (7)].val.opval)));
- TOKEN_GETMAD((ps[(1) - (7)].val.i_tkval),(yyval.opval),'W');
- TOKEN_GETMAD((ps[(2) - (7)].val.i_tkval),(yyval.opval),'(');
- TOKEN_GETMAD((ps[(5) - (7)].val.i_tkval),(yyval.opval),')');
- PL_parser->copline = (line_t)IVAL((ps[(1) - (7)].val.i_tkval));
- }
- break;
-
- case 46:
-#line 504 "perly.y"
- {
- /* a block is a loop that happens once */
- (yyval.opval) = newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
- (OP*)NULL, (ps[(1) - (2)].val.opval), (ps[(2) - (2)].val.opval), 0);
- }
+#line 441 "perly.y"
+ { YYSTYPE tmplval;
+ (void)scan_num("1", &tmplval);
+ (yyval.opval) = tmplval.opval; ;}
break;
case 47:
-#line 510 "perly.y"
- {
- package((ps[(3) - (5)].val.opval));
- if ((ps[(2) - (5)].val.opval)) {
- package_version((ps[(2) - (5)].val.opval));
- }
- }
+#line 449 "perly.y"
+ { (yyval.opval) = invert(scalar((ps[(1) - (1)].val.opval))); ;}
break;
case 48:
-#line 517 "perly.y"
- {
- /* a block is a loop that happens once */
- (yyval.opval) = newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
- (OP*)NULL, block_end((ps[(5) - (8)].val.ival), (ps[(7) - (8)].val.opval)), (OP*)NULL, 0);
- TOKEN_GETMAD((ps[(4) - (8)].val.i_tkval),(yyval.opval),'{');
- TOKEN_GETMAD((ps[(8) - (8)].val.i_tkval),(yyval.opval),'}');
- if (PL_parser->copline > (line_t)IVAL((ps[(4) - (8)].val.i_tkval)))
- PL_parser->copline = (line_t)IVAL((ps[(4) - (8)].val.i_tkval));
- }
+#line 454 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); ;}
break;
case 49:
-#line 527 "perly.y"
- {
- PL_parser->expect = XSTATE;
- (yyval.opval) = (ps[(1) - (2)].val.opval);
- TOKEN_GETMAD((ps[(2) - (2)].val.i_tkval),(yyval.opval),';');
- }
+#line 458 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); ;}
break;
case 50:
-#line 533 "perly.y"
- {
- PL_parser->expect = XSTATE;
- (yyval.opval) = IF_MAD(newOP(OP_NULL, 0), (OP*)NULL);
- TOKEN_GETMAD((ps[(1) - (1)].val.i_tkval),(yyval.opval),';');
- PL_parser->copline = NOLINE;
- }
+#line 462 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); ;}
break;
case 51:
-#line 543 "perly.y"
- { OP *list;
- if ((ps[(2) - (2)].val.opval)) {
- OP *term = (ps[(2) - (2)].val.opval);
- DO_MAD(term = newUNOP(OP_NULL, 0, term));
- list = op_append_elem(OP_LIST, (ps[(1) - (2)].val.opval), term);
- }
- else {
+#line 467 "perly.y"
+ {
#ifdef MAD
- OP *op = newNULLLIST();
- list = op_append_elem(OP_LIST, (ps[(1) - (2)].val.opval), op);
+ YYSTYPE tmplval;
+ tmplval.pval = NULL;
+ (yyval.p_tkval) = newTOKEN(OP_NULL, tmplval, 0);
#else
- list = (ps[(1) - (2)].val.opval);
+ (yyval.p_tkval) = NULL;
#endif
- }
- if (PL_parser->copline == NOLINE)
- PL_parser->copline = CopLINE(PL_curcop)-1;
- else PL_parser->copline--;
- (yyval.opval) = newSTATEOP(0, NULL,
- convert(OP_FORMLINE, 0, list));
- }
- break;
-
- case 52:
-#line 566 "perly.y"
- { (yyval.opval) = NULL; }
+ ;}
break;
case 53:
-#line 568 "perly.y"
- { (yyval.opval) = op_unscope((ps[(2) - (3)].val.opval)); }
+#line 481 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 54:
-#line 573 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+#line 483 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 55:
-#line 575 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+#line 485 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 56:
-#line 577 "perly.y"
- { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval));
- TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'i');
- }
+#line 487 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 57:
-#line 581 "perly.y"
- { (yyval.opval) = newLOGOP(OP_OR, 0, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval));
- TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'i');
- }
+#line 489 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 58:
-#line 585 "perly.y"
- { (yyval.opval) = newLOOPOP(OPf_PARENS, 1, scalar((ps[(3) - (3)].val.opval)), (ps[(1) - (3)].val.opval));
- TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'w');
- }
+#line 494 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 59:
-#line 589 "perly.y"
- { (yyval.opval) = newLOOPOP(OPf_PARENS, 1, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval));
- TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'w');
- }
+#line 498 "perly.y"
+ { (yyval.opval) = newOP(OP_NULL,0);
+ TOKEN_GETMAD((ps[(1) - (1)].val.i_tkval),(yyval.opval),'p');
+ ;}
break;
case 60:
-#line 593 "perly.y"
- { (yyval.opval) = newFOROP(0, (OP*)NULL, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval), (OP*)NULL);
- TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'w');
- PL_parser->copline = (line_t)IVAL((ps[(2) - (3)].val.i_tkval));
- }
+#line 504 "perly.y"
+ { SvREFCNT_inc_simple_void(PL_compcv);
+#ifdef MAD
+ (yyval.opval) = newFORM((ps[(2) - (4)].val.ival), (ps[(3) - (4)].val.opval), (ps[(4) - (4)].val.opval));
+ prepend_madprops((ps[(1) - (4)].val.i_tkval)->tk_mad, (yyval.opval), 'F');
+ (ps[(1) - (4)].val.i_tkval)->tk_mad = 0;
+ token_free((ps[(1) - (4)].val.i_tkval));
+#else
+ newFORM((ps[(2) - (4)].val.ival), (ps[(3) - (4)].val.opval), (ps[(4) - (4)].val.opval));
+ (yyval.opval) = Nullop;
+#endif
+ ;}
break;
case 61:
-#line 598 "perly.y"
- { (yyval.opval) = newWHENOP((ps[(3) - (3)].val.opval), op_scope((ps[(1) - (3)].val.opval))); }
+#line 517 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 62:
-#line 603 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+#line 518 "perly.y"
+ { (yyval.opval) = Nullop; ;}
break;
case 63:
-#line 605 "perly.y"
- {
- ((ps[(2) - (2)].val.opval))->op_flags |= OPf_PARENS;
- (yyval.opval) = op_scope((ps[(2) - (2)].val.opval));
- TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'o');
- }
+#line 523 "perly.y"
+ { SvREFCNT_inc_simple_void(PL_compcv);
+#ifdef MAD
+ (yyval.opval) = newMYSUB((ps[(2) - (6)].val.ival), (ps[(3) - (6)].val.opval), (ps[(4) - (6)].val.opval), (ps[(5) - (6)].val.opval), (ps[(6) - (6)].val.opval));
+ token_getmad((ps[(1) - (6)].val.i_tkval),(yyval.opval),'d');
+#else
+ newMYSUB((ps[(2) - (6)].val.ival), (ps[(3) - (6)].val.opval), (ps[(4) - (6)].val.opval), (ps[(5) - (6)].val.opval), (ps[(6) - (6)].val.opval));
+ (yyval.opval) = Nullop;
+#endif
+ ;}
break;
case 64:
-#line 611 "perly.y"
- { PL_parser->copline = (line_t)IVAL((ps[(1) - (6)].val.i_tkval));
- (yyval.opval) = newCONDOP(0,
- newSTATEOP(OPf_SPECIAL,NULL,(ps[(3) - (6)].val.opval)),
- op_scope((ps[(5) - (6)].val.opval)), (ps[(6) - (6)].val.opval));
- PL_hints |= HINT_BLOCK_SCOPE;
- TOKEN_GETMAD((ps[(1) - (6)].val.i_tkval),(yyval.opval),'I');
- TOKEN_GETMAD((ps[(2) - (6)].val.i_tkval),(yyval.opval),'(');
- TOKEN_GETMAD((ps[(4) - (6)].val.i_tkval),(yyval.opval),')');
- }
+#line 536 "perly.y"
+ { SvREFCNT_inc_simple_void(PL_compcv);
+#ifdef MAD
+ {
+ OP* o = newSVOP(OP_ANONCODE, 0,
+ (SV*)newATTRSUB((ps[(2) - (6)].val.ival), (ps[(3) - (6)].val.opval), (ps[(4) - (6)].val.opval), (ps[(5) - (6)].val.opval), (ps[(6) - (6)].val.opval)));
+ (yyval.opval) = newOP(OP_NULL,0);
+ op_getmad(o,(yyval.opval),'&');
+ op_getmad((ps[(3) - (6)].val.opval),(yyval.opval),'n');
+ op_getmad((ps[(4) - (6)].val.opval),(yyval.opval),'s');
+ op_getmad((ps[(5) - (6)].val.opval),(yyval.opval),'a');
+ token_getmad((ps[(1) - (6)].val.i_tkval),(yyval.opval),'d');
+ append_madprops((ps[(6) - (6)].val.opval)->op_madprop, (yyval.opval), 0);
+ (ps[(6) - (6)].val.opval)->op_madprop = 0;
+ }
+#else
+ newATTRSUB((ps[(2) - (6)].val.ival), (ps[(3) - (6)].val.opval), (ps[(4) - (6)].val.opval), (ps[(5) - (6)].val.opval), (ps[(6) - (6)].val.opval));
+ (yyval.opval) = Nullop;
+#endif
+ ;}
break;
case 65:
-#line 624 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+#line 558 "perly.y"
+ { (yyval.ival) = start_subparse(FALSE, 0);
+ SAVEFREESV(PL_compcv); ;}
break;
case 66:
-#line 626 "perly.y"
- {
- (yyval.opval) = op_scope((ps[(2) - (2)].val.opval));
- TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'o');
- }
+#line 564 "perly.y"
+ { (yyval.ival) = start_subparse(FALSE, CVf_ANON);
+ SAVEFREESV(PL_compcv); ;}
break;
case 67:
-#line 634 "perly.y"
- { (yyval.ival) = (PL_min_intro_pending &&
- PL_max_intro_pending >= PL_min_intro_pending);
- intro_my(); }
+#line 569 "perly.y"
+ { (yyval.ival) = start_subparse(TRUE, 0);
+ SAVEFREESV(PL_compcv); ;}
break;
case 68:
-#line 640 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
- break;
-
- case 70:
-#line 646 "perly.y"
- { YYSTYPE tmplval;
- (void)scan_num("1", &tmplval);
- (yyval.opval) = tmplval.opval; }
- break;
-
- case 72:
-#line 654 "perly.y"
- { (yyval.opval) = invert(scalar((ps[(1) - (1)].val.opval))); }
- break;
-
- case 73:
-#line 659 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); }
- break;
-
- case 74:
-#line 663 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); }
- break;
-
- case 75:
-#line 667 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); }
- break;
-
- case 76:
-#line 670 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
- break;
-
- case 77:
-#line 671 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
- break;
-
- case 78:
-#line 675 "perly.y"
- { (yyval.ival) = start_subparse(FALSE, 0);
- SAVEFREESV(PL_compcv); }
- break;
-
- case 79:
-#line 681 "perly.y"
- { (yyval.ival) = start_subparse(FALSE, CVf_ANON);
- SAVEFREESV(PL_compcv); }
- break;
-
- case 80:
-#line 686 "perly.y"
- { (yyval.ival) = start_subparse(TRUE, 0);
- SAVEFREESV(PL_compcv); }
+#line 574 "perly.y"
+ { const char *const name = SvPV_nolen_const(((SVOP*)(ps[(1) - (1)].val.opval))->op_sv);
+ if (strEQ(name, "BEGIN") || strEQ(name, "END")
+ || strEQ(name, "INIT") || strEQ(name, "CHECK")
+ || strEQ(name, "UNITCHECK"))
+ CvSPECIAL_on(PL_compcv);
+ (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
- case 83:
-#line 697 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+ case 69:
+#line 584 "perly.y"
+ { (yyval.opval) = Nullop; ;}
break;
- case 85:
-#line 703 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+ case 71:
+#line 590 "perly.y"
+ { (yyval.opval) = Nullop; ;}
break;
- case 86:
-#line 705 "perly.y"
+ case 72:
+#line 592 "perly.y"
{ (yyval.opval) = (ps[(2) - (2)].val.opval);
TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),':');
- }
+ ;}
break;
- case 87:
-#line 709 "perly.y"
+ case 73:
+#line 596 "perly.y"
{ (yyval.opval) = IF_MAD(
newOP(OP_NULL, 0),
- (OP*)NULL
+ Nullop
);
TOKEN_GETMAD((ps[(1) - (1)].val.i_tkval),(yyval.opval),':');
- }
+ ;}
break;
- case 88:
-#line 719 "perly.y"
+ case 74:
+#line 606 "perly.y"
{ (yyval.opval) = (ps[(2) - (2)].val.opval);
TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),':');
- }
+ ;}
break;
- case 89:
-#line 723 "perly.y"
+ case 75:
+#line 610 "perly.y"
{ (yyval.opval) = IF_MAD(
newOP(OP_NULL, 0),
- (OP*)NULL
+ Nullop
);
TOKEN_GETMAD((ps[(1) - (1)].val.i_tkval),(yyval.opval),':');
- }
- break;
-
- case 90:
-#line 732 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+ ;}
break;
- case 91:
-#line 734 "perly.y"
- {
- if (!FEATURE_SIGNATURES_IS_ENABLED)
- Perl_croak(aTHX_ "Experimental "
- "subroutine signatures not enabled");
- Perl_ck_warner_d(aTHX_
- packWARN(WARN_EXPERIMENTAL__SIGNATURES),
- "The signatures feature is experimental");
- (yyval.opval) = parse_subsignature();
- }
+ case 76:
+#line 619 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
- case 92:
-#line 744 "perly.y"
- {
- (yyval.opval) = op_append_list(OP_LINESEQ, (ps[(2) - (3)].val.opval),
- newSTATEOP(0, NULL, sawparens(newNULLLIST())));
- PL_parser->expect = XBLOCK;
- }
+ case 77:
+#line 620 "perly.y"
+ { (yyval.opval) = IF_MAD(
+ newOP(OP_NULL,0),
+ Nullop
+ );
+ PL_parser->expect = XSTATE;
+ TOKEN_GETMAD((ps[(1) - (1)].val.i_tkval),(yyval.opval),';');
+ ;}
break;
- case 93:
-#line 753 "perly.y"
+ case 78:
+#line 630 "perly.y"
{
- if (PL_parser->copline > (line_t)IVAL((ps[(3) - (5)].val.i_tkval)))
- PL_parser->copline = (line_t)IVAL((ps[(3) - (5)].val.i_tkval));
- (yyval.opval) = block_end((ps[(1) - (5)].val.ival),
- op_append_list(OP_LINESEQ, (ps[(2) - (5)].val.opval), (ps[(4) - (5)].val.opval)));
- TOKEN_GETMAD((ps[(3) - (5)].val.i_tkval),(yyval.opval),'{');
- TOKEN_GETMAD((ps[(5) - (5)].val.i_tkval),(yyval.opval),'}');
- }
+#ifdef MAD
+ (yyval.opval) = package((ps[(2) - (3)].val.opval));
+ token_getmad((ps[(1) - (3)].val.i_tkval),(yyval.opval),'o');
+ token_getmad((ps[(3) - (3)].val.i_tkval),(yyval.opval),';');
+#else
+ package((ps[(2) - (3)].val.opval));
+ (yyval.opval) = Nullop;
+#endif
+ ;}
break;
- case 94:
-#line 764 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ case 79:
+#line 643 "perly.y"
+ { CvSPECIAL_on(PL_compcv); /* It's a BEGIN {} */ ;}
break;
- case 95:
-#line 765 "perly.y"
- { (yyval.opval) = IF_MAD(
- newOP(OP_NULL,0),
- (OP*)NULL
- );
- PL_parser->expect = XSTATE;
- TOKEN_GETMAD((ps[(1) - (1)].val.i_tkval),(yyval.opval),';');
- }
+ case 80:
+#line 645 "perly.y"
+ { SvREFCNT_inc_simple_void(PL_compcv);
+#ifdef MAD
+ (yyval.opval) = utilize(IVAL((ps[(1) - (7)].val.i_tkval)), (ps[(2) - (7)].val.ival), (ps[(4) - (7)].val.opval), (ps[(5) - (7)].val.opval), (ps[(6) - (7)].val.opval));
+ token_getmad((ps[(1) - (7)].val.i_tkval),(yyval.opval),'o');
+ token_getmad((ps[(7) - (7)].val.i_tkval),(yyval.opval),';');
+ if (PL_parser->rsfp_filters &&
+ AvFILLp(PL_parser->rsfp_filters) >= 0)
+ append_madprops(newMADPROP('!', MAD_PV, "", 0), (yyval.opval), 0);
+#else
+ utilize(IVAL((ps[(1) - (7)].val.i_tkval)), (ps[(2) - (7)].val.ival), (ps[(4) - (7)].val.opval), (ps[(5) - (7)].val.opval), (ps[(6) - (7)].val.opval));
+ (yyval.opval) = Nullop;
+#endif
+ ;}
break;
- case 96:
-#line 776 "perly.y"
+ case 81:
+#line 662 "perly.y"
{ (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval));
TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 97:
-#line 780 "perly.y"
+ case 82:
+#line 666 "perly.y"
{ (yyval.opval) = newLOGOP(IVAL((ps[(2) - (3)].val.i_tkval)), 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval));
TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 98:
-#line 784 "perly.y"
+ case 83:
+#line 670 "perly.y"
{ (yyval.opval) = newLOGOP(OP_DOR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval));
TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 100:
-#line 792 "perly.y"
+ case 85:
+#line 678 "perly.y"
{
#ifdef MAD
OP* op = newNULLLIST();
token_getmad((ps[(2) - (2)].val.i_tkval),op,',');
- (yyval.opval) = op_append_elem(OP_LIST, (ps[(1) - (2)].val.opval), op);
+ (yyval.opval) = append_elem(OP_LIST, (ps[(1) - (2)].val.opval), op);
#else
(yyval.opval) = (ps[(1) - (2)].val.opval);
#endif
- }
+ ;}
break;
- case 101:
-#line 802 "perly.y"
+ case 86:
+#line 688 "perly.y"
{
OP* term = (ps[(3) - (3)].val.opval);
DO_MAD(
term = newUNOP(OP_NULL, 0, term);
token_getmad((ps[(2) - (3)].val.i_tkval),term,',');
)
- (yyval.opval) = op_append_elem(OP_LIST, (ps[(1) - (3)].val.opval), term);
- }
+ (yyval.opval) = append_elem(OP_LIST, (ps[(1) - (3)].val.opval), term);
+ ;}
break;
- case 103:
-#line 815 "perly.y"
+ case 88:
+#line 701 "perly.y"
{ (yyval.opval) = convert(IVAL((ps[(1) - (3)].val.i_tkval)), OPf_STACKED,
- op_prepend_elem(OP_LIST, newGVREF(IVAL((ps[(1) - (3)].val.i_tkval)),(ps[(2) - (3)].val.opval)), (ps[(3) - (3)].val.opval)) );
+ prepend_elem(OP_LIST, newGVREF(IVAL((ps[(1) - (3)].val.i_tkval)),(ps[(2) - (3)].val.opval)), (ps[(3) - (3)].val.opval)) );
TOKEN_GETMAD((ps[(1) - (3)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 104:
-#line 820 "perly.y"
+ case 89:
+#line 706 "perly.y"
{ (yyval.opval) = convert(IVAL((ps[(1) - (5)].val.i_tkval)), OPf_STACKED,
- op_prepend_elem(OP_LIST, newGVREF(IVAL((ps[(1) - (5)].val.i_tkval)),(ps[(3) - (5)].val.opval)), (ps[(4) - (5)].val.opval)) );
+ prepend_elem(OP_LIST, newGVREF(IVAL((ps[(1) - (5)].val.i_tkval)),(ps[(3) - (5)].val.opval)), (ps[(4) - (5)].val.opval)) );
TOKEN_GETMAD((ps[(1) - (5)].val.i_tkval),(yyval.opval),'o');
TOKEN_GETMAD((ps[(2) - (5)].val.i_tkval),(yyval.opval),'(');
TOKEN_GETMAD((ps[(5) - (5)].val.i_tkval),(yyval.opval),')');
- }
+ ;}
break;
- case 105:
-#line 827 "perly.y"
+ case 90:
+#line 713 "perly.y"
{ (yyval.opval) = convert(OP_ENTERSUB, OPf_STACKED,
- op_append_elem(OP_LIST,
- op_prepend_elem(OP_LIST, scalar((ps[(1) - (6)].val.opval)), (ps[(5) - (6)].val.opval)),
+ append_elem(OP_LIST,
+ prepend_elem(OP_LIST, scalar((ps[(1) - (6)].val.opval)), (ps[(5) - (6)].val.opval)),
newUNOP(OP_METHOD, 0, (ps[(3) - (6)].val.opval))));
TOKEN_GETMAD((ps[(2) - (6)].val.i_tkval),(yyval.opval),'A');
TOKEN_GETMAD((ps[(4) - (6)].val.i_tkval),(yyval.opval),'(');
TOKEN_GETMAD((ps[(6) - (6)].val.i_tkval),(yyval.opval),')');
- }
+ ;}
break;
- case 106:
-#line 836 "perly.y"
+ case 91:
+#line 722 "perly.y"
{ (yyval.opval) = convert(OP_ENTERSUB, OPf_STACKED,
- op_append_elem(OP_LIST, scalar((ps[(1) - (3)].val.opval)),
+ append_elem(OP_LIST, scalar((ps[(1) - (3)].val.opval)),
newUNOP(OP_METHOD, 0, (ps[(3) - (3)].val.opval))));
TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'A');
- }
+ ;}
break;
- case 107:
-#line 842 "perly.y"
+ case 92:
+#line 728 "perly.y"
{ (yyval.opval) = convert(OP_ENTERSUB, OPf_STACKED,
- op_append_elem(OP_LIST,
- op_prepend_elem(OP_LIST, (ps[(2) - (3)].val.opval), (ps[(3) - (3)].val.opval)),
+ append_elem(OP_LIST,
+ prepend_elem(OP_LIST, (ps[(2) - (3)].val.opval), (ps[(3) - (3)].val.opval)),
newUNOP(OP_METHOD, 0, (ps[(1) - (3)].val.opval))));
- }
+ ;}
break;
- case 108:
-#line 848 "perly.y"
+ case 93:
+#line 734 "perly.y"
{ (yyval.opval) = convert(OP_ENTERSUB, OPf_STACKED,
- op_append_elem(OP_LIST,
- op_prepend_elem(OP_LIST, (ps[(2) - (5)].val.opval), (ps[(4) - (5)].val.opval)),
+ append_elem(OP_LIST,
+ prepend_elem(OP_LIST, (ps[(2) - (5)].val.opval), (ps[(4) - (5)].val.opval)),
newUNOP(OP_METHOD, 0, (ps[(1) - (5)].val.opval))));
TOKEN_GETMAD((ps[(3) - (5)].val.i_tkval),(yyval.opval),'(');
TOKEN_GETMAD((ps[(5) - (5)].val.i_tkval),(yyval.opval),')');
- }
+ ;}
break;
- case 109:
-#line 856 "perly.y"
+ case 94:
+#line 742 "perly.y"
{ (yyval.opval) = convert(IVAL((ps[(1) - (2)].val.i_tkval)), 0, (ps[(2) - (2)].val.opval));
TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 110:
-#line 860 "perly.y"
+ case 95:
+#line 746 "perly.y"
{ (yyval.opval) = convert(IVAL((ps[(1) - (4)].val.i_tkval)), 0, (ps[(3) - (4)].val.opval));
TOKEN_GETMAD((ps[(1) - (4)].val.i_tkval),(yyval.opval),'o');
TOKEN_GETMAD((ps[(2) - (4)].val.i_tkval),(yyval.opval),'(');
TOKEN_GETMAD((ps[(4) - (4)].val.i_tkval),(yyval.opval),')');
- }
+ ;}
break;
- case 111:
-#line 866 "perly.y"
+ case 96:
+#line 752 "perly.y"
{ SvREFCNT_inc_simple_void(PL_compcv);
- (yyval.opval) = newANONATTRSUB((ps[(2) - (3)].val.ival), 0, (OP*)NULL, (ps[(3) - (3)].val.opval)); }
+ (yyval.opval) = newANONATTRSUB((ps[(2) - (3)].val.ival), 0, Nullop, (ps[(3) - (3)].val.opval)); ;}
break;
- case 112:
-#line 869 "perly.y"
+ case 97:
+#line 755 "perly.y"
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
- op_append_elem(OP_LIST,
- op_prepend_elem(OP_LIST, (ps[(4) - (5)].val.opval), (ps[(5) - (5)].val.opval)), (ps[(1) - (5)].val.opval)));
- }
+ append_elem(OP_LIST,
+ prepend_elem(OP_LIST, (ps[(4) - (5)].val.opval), (ps[(5) - (5)].val.opval)), (ps[(1) - (5)].val.opval)));
+ ;}
break;
- case 115:
-#line 884 "perly.y"
+ case 100:
+#line 770 "perly.y"
{ (yyval.opval) = newBINOP(OP_GELEM, 0, (ps[(1) - (5)].val.opval), scalar((ps[(3) - (5)].val.opval)));
PL_parser->expect = XOPERATOR;
TOKEN_GETMAD((ps[(2) - (5)].val.i_tkval),(yyval.opval),'{');
TOKEN_GETMAD((ps[(4) - (5)].val.i_tkval),(yyval.opval),';');
TOKEN_GETMAD((ps[(5) - (5)].val.i_tkval),(yyval.opval),'}');
- }
+ ;}
break;
- case 116:
-#line 891 "perly.y"
+ case 101:
+#line 777 "perly.y"
{ (yyval.opval) = newBINOP(OP_AELEM, 0, oopsAV((ps[(1) - (4)].val.opval)), scalar((ps[(3) - (4)].val.opval)));
TOKEN_GETMAD((ps[(2) - (4)].val.i_tkval),(yyval.opval),'[');
TOKEN_GETMAD((ps[(4) - (4)].val.i_tkval),(yyval.opval),']');
- }
+ ;}
break;
- case 117:
-#line 896 "perly.y"
+ case 102:
+#line 782 "perly.y"
{ (yyval.opval) = newBINOP(OP_AELEM, 0,
ref(newAVREF((ps[(1) - (5)].val.opval)),OP_RV2AV),
scalar((ps[(4) - (5)].val.opval)));
TOKEN_GETMAD((ps[(2) - (5)].val.i_tkval),(yyval.opval),'a');
TOKEN_GETMAD((ps[(3) - (5)].val.i_tkval),(yyval.opval),'[');
TOKEN_GETMAD((ps[(5) - (5)].val.i_tkval),(yyval.opval),']');
- }
+ ;}
break;
- case 118:
-#line 904 "perly.y"
+ case 103:
+#line 790 "perly.y"
{ (yyval.opval) = newBINOP(OP_AELEM, 0,
ref(newAVREF((ps[(1) - (4)].val.opval)),OP_RV2AV),
scalar((ps[(3) - (4)].val.opval)));
TOKEN_GETMAD((ps[(2) - (4)].val.i_tkval),(yyval.opval),'[');
TOKEN_GETMAD((ps[(4) - (4)].val.i_tkval),(yyval.opval),']');
- }
+ ;}
break;
- case 119:
-#line 911 "perly.y"
+ case 104:
+#line 797 "perly.y"
{ (yyval.opval) = newBINOP(OP_HELEM, 0, oopsHV((ps[(1) - (5)].val.opval)), jmaybe((ps[(3) - (5)].val.opval)));
PL_parser->expect = XOPERATOR;
TOKEN_GETMAD((ps[(2) - (5)].val.i_tkval),(yyval.opval),'{');
TOKEN_GETMAD((ps[(4) - (5)].val.i_tkval),(yyval.opval),';');
TOKEN_GETMAD((ps[(5) - (5)].val.i_tkval),(yyval.opval),'}');
- }
+ ;}
break;
- case 120:
-#line 918 "perly.y"
+ case 105:
+#line 804 "perly.y"
{ (yyval.opval) = newBINOP(OP_HELEM, 0,
ref(newHVREF((ps[(1) - (6)].val.opval)),OP_RV2HV),
jmaybe((ps[(4) - (6)].val.opval)));
@@ -1007,11 +827,11 @@ case 2:
TOKEN_GETMAD((ps[(3) - (6)].val.i_tkval),(yyval.opval),'{');
TOKEN_GETMAD((ps[(5) - (6)].val.i_tkval),(yyval.opval),';');
TOKEN_GETMAD((ps[(6) - (6)].val.i_tkval),(yyval.opval),'}');
- }
+ ;}
break;
- case 121:
-#line 928 "perly.y"
+ case 106:
+#line 814 "perly.y"
{ (yyval.opval) = newBINOP(OP_HELEM, 0,
ref(newHVREF((ps[(1) - (5)].val.opval)),OP_RV2HV),
jmaybe((ps[(3) - (5)].val.opval)));
@@ -1019,144 +839,136 @@ case 2:
TOKEN_GETMAD((ps[(2) - (5)].val.i_tkval),(yyval.opval),'{');
TOKEN_GETMAD((ps[(4) - (5)].val.i_tkval),(yyval.opval),';');
TOKEN_GETMAD((ps[(5) - (5)].val.i_tkval),(yyval.opval),'}');
- }
+ ;}
break;
- case 122:
-#line 937 "perly.y"
+ case 107:
+#line 823 "perly.y"
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
newCVREF(0, scalar((ps[(1) - (4)].val.opval))));
TOKEN_GETMAD((ps[(2) - (4)].val.i_tkval),(yyval.opval),'a');
TOKEN_GETMAD((ps[(3) - (4)].val.i_tkval),(yyval.opval),'(');
TOKEN_GETMAD((ps[(4) - (4)].val.i_tkval),(yyval.opval),')');
- }
+ ;}
break;
- case 123:
-#line 944 "perly.y"
+ case 108:
+#line 830 "perly.y"
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
- op_append_elem(OP_LIST, (ps[(4) - (5)].val.opval),
+ append_elem(OP_LIST, (ps[(4) - (5)].val.opval),
newCVREF(0, scalar((ps[(1) - (5)].val.opval)))));
TOKEN_GETMAD((ps[(2) - (5)].val.i_tkval),(yyval.opval),'a');
TOKEN_GETMAD((ps[(3) - (5)].val.i_tkval),(yyval.opval),'(');
TOKEN_GETMAD((ps[(5) - (5)].val.i_tkval),(yyval.opval),')');
- }
+ ;}
break;
- case 124:
-#line 953 "perly.y"
+ case 109:
+#line 839 "perly.y"
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
- op_append_elem(OP_LIST, (ps[(3) - (4)].val.opval),
+ append_elem(OP_LIST, (ps[(3) - (4)].val.opval),
newCVREF(0, scalar((ps[(1) - (4)].val.opval)))));
TOKEN_GETMAD((ps[(2) - (4)].val.i_tkval),(yyval.opval),'(');
TOKEN_GETMAD((ps[(4) - (4)].val.i_tkval),(yyval.opval),')');
- }
+ ;}
break;
- case 125:
-#line 960 "perly.y"
+ case 110:
+#line 846 "perly.y"
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
newCVREF(0, scalar((ps[(1) - (3)].val.opval))));
TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'(');
TOKEN_GETMAD((ps[(3) - (3)].val.i_tkval),(yyval.opval),')');
- }
+ ;}
break;
- case 126:
-#line 966 "perly.y"
+ case 111:
+#line 852 "perly.y"
{ (yyval.opval) = newSLICEOP(0, (ps[(5) - (6)].val.opval), (ps[(2) - (6)].val.opval));
TOKEN_GETMAD((ps[(1) - (6)].val.i_tkval),(yyval.opval),'(');
TOKEN_GETMAD((ps[(3) - (6)].val.i_tkval),(yyval.opval),')');
TOKEN_GETMAD((ps[(4) - (6)].val.i_tkval),(yyval.opval),'[');
TOKEN_GETMAD((ps[(6) - (6)].val.i_tkval),(yyval.opval),']');
- }
- break;
-
- case 127:
-#line 973 "perly.y"
- { (yyval.opval) = newSLICEOP(0, (ps[(3) - (4)].val.opval), (ps[(1) - (4)].val.opval));
- TOKEN_GETMAD((ps[(2) - (4)].val.i_tkval),(yyval.opval),'[');
- TOKEN_GETMAD((ps[(4) - (4)].val.i_tkval),(yyval.opval),']');
- }
+ ;}
break;
- case 128:
-#line 978 "perly.y"
- { (yyval.opval) = newSLICEOP(0, (ps[(4) - (5)].val.opval), (OP*)NULL);
+ case 112:
+#line 859 "perly.y"
+ { (yyval.opval) = newSLICEOP(0, (ps[(4) - (5)].val.opval), Nullop);
TOKEN_GETMAD((ps[(1) - (5)].val.i_tkval),(yyval.opval),'(');
TOKEN_GETMAD((ps[(2) - (5)].val.i_tkval),(yyval.opval),')');
TOKEN_GETMAD((ps[(3) - (5)].val.i_tkval),(yyval.opval),'[');
TOKEN_GETMAD((ps[(5) - (5)].val.i_tkval),(yyval.opval),']');
- }
+ ;}
break;
- case 129:
-#line 988 "perly.y"
+ case 113:
+#line 869 "perly.y"
{ (yyval.opval) = newASSIGNOP(OPf_STACKED, (ps[(1) - (3)].val.opval), IVAL((ps[(2) - (3)].val.i_tkval)), (ps[(3) - (3)].val.opval));
TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 130:
-#line 992 "perly.y"
+ case 114:
+#line 873 "perly.y"
{ (yyval.opval) = newBINOP(IVAL((ps[(2) - (3)].val.i_tkval)), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval)));
TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 131:
-#line 996 "perly.y"
+ case 115:
+#line 877 "perly.y"
{ if (IVAL((ps[(2) - (3)].val.i_tkval)) != OP_REPEAT)
scalar((ps[(1) - (3)].val.opval));
(yyval.opval) = newBINOP(IVAL((ps[(2) - (3)].val.i_tkval)), 0, (ps[(1) - (3)].val.opval), scalar((ps[(3) - (3)].val.opval)));
TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 132:
-#line 1002 "perly.y"
+ case 116:
+#line 883 "perly.y"
{ (yyval.opval) = newBINOP(IVAL((ps[(2) - (3)].val.i_tkval)), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval)));
TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 133:
-#line 1006 "perly.y"
+ case 117:
+#line 887 "perly.y"
{ (yyval.opval) = newBINOP(IVAL((ps[(2) - (3)].val.i_tkval)), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval)));
TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 134:
-#line 1010 "perly.y"
+ case 118:
+#line 891 "perly.y"
{ (yyval.opval) = newBINOP(IVAL((ps[(2) - (3)].val.i_tkval)), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval)));
TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 135:
-#line 1014 "perly.y"
+ case 119:
+#line 895 "perly.y"
{ (yyval.opval) = newBINOP(IVAL((ps[(2) - (3)].val.i_tkval)), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval)));
TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 136:
-#line 1018 "perly.y"
+ case 120:
+#line 899 "perly.y"
{ (yyval.opval) = newBINOP(IVAL((ps[(2) - (3)].val.i_tkval)), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval)));
TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 137:
-#line 1022 "perly.y"
+ case 121:
+#line 903 "perly.y"
{ (yyval.opval) = newBINOP(IVAL((ps[(2) - (3)].val.i_tkval)), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval)));
TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 138:
-#line 1026 "perly.y"
+ case 122:
+#line 907 "perly.y"
{
(yyval.opval) = newRANGE(IVAL((ps[(2) - (3)].val.i_tkval)), scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval)));
DO_MAD({
@@ -1166,342 +978,338 @@ case 2:
op = (UNOP*)op->op_first; /* get to flip */
op = (UNOP*)op->op_first; /* get to range */
token_getmad((ps[(2) - (3)].val.i_tkval),(OP*)op,'o');
- });
- }
+ })
+ ;}
break;
- case 139:
-#line 1038 "perly.y"
+ case 123:
+#line 919 "perly.y"
{ (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval));
TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 140:
-#line 1042 "perly.y"
+ case 124:
+#line 923 "perly.y"
{ (yyval.opval) = newLOGOP(OP_OR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval));
TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 141:
-#line 1046 "perly.y"
+ case 125:
+#line 927 "perly.y"
{ (yyval.opval) = newLOGOP(OP_DOR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval));
TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 142:
-#line 1050 "perly.y"
+ case 126:
+#line 931 "perly.y"
{ (yyval.opval) = bind_match(IVAL((ps[(2) - (3)].val.i_tkval)), (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval));
TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),
((yyval.opval)->op_type == OP_NOT
? ((UNOP*)(yyval.opval))->op_first : (yyval.opval)),
'~');
- }
+ ;}
break;
- case 143:
-#line 1060 "perly.y"
+ case 127:
+#line 941 "perly.y"
{ (yyval.opval) = newUNOP(OP_NEGATE, 0, scalar((ps[(2) - (2)].val.opval)));
TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 144:
-#line 1064 "perly.y"
+ case 128:
+#line 945 "perly.y"
{ (yyval.opval) = IF_MAD(
newUNOP(OP_NULL, 0, (ps[(2) - (2)].val.opval)),
(ps[(2) - (2)].val.opval)
);
TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'+');
- }
+ ;}
break;
- case 145:
-#line 1071 "perly.y"
+ case 129:
+#line 952 "perly.y"
{ (yyval.opval) = newUNOP(OP_NOT, 0, scalar((ps[(2) - (2)].val.opval)));
TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 146:
-#line 1075 "perly.y"
+ case 130:
+#line 956 "perly.y"
{ (yyval.opval) = newUNOP(OP_COMPLEMENT, 0, scalar((ps[(2) - (2)].val.opval)));
TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 147:
-#line 1079 "perly.y"
+ case 131:
+#line 960 "perly.y"
{ (yyval.opval) = newUNOP(OP_POSTINC, 0,
- op_lvalue(scalar((ps[(1) - (2)].val.opval)), OP_POSTINC));
+ mod(scalar((ps[(1) - (2)].val.opval)), OP_POSTINC));
TOKEN_GETMAD((ps[(2) - (2)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 148:
-#line 1084 "perly.y"
+ case 132:
+#line 965 "perly.y"
{ (yyval.opval) = newUNOP(OP_POSTDEC, 0,
- op_lvalue(scalar((ps[(1) - (2)].val.opval)), OP_POSTDEC));
- TOKEN_GETMAD((ps[(2) - (2)].val.i_tkval),(yyval.opval),'o');
- }
- break;
-
- case 149:
-#line 1089 "perly.y"
- { (yyval.opval) = convert(OP_JOIN, 0,
- op_append_elem(
- OP_LIST,
- newSVREF(scalar(
- newSVOP(OP_CONST,0,
- newSVpvs("\""))
- )),
- (ps[(1) - (2)].val.opval)
- ));
+ mod(scalar((ps[(1) - (2)].val.opval)), OP_POSTDEC));
TOKEN_GETMAD((ps[(2) - (2)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 150:
-#line 1101 "perly.y"
+ case 133:
+#line 970 "perly.y"
{ (yyval.opval) = newUNOP(OP_PREINC, 0,
- op_lvalue(scalar((ps[(2) - (2)].val.opval)), OP_PREINC));
+ mod(scalar((ps[(2) - (2)].val.opval)), OP_PREINC));
TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 151:
-#line 1106 "perly.y"
+ case 134:
+#line 975 "perly.y"
{ (yyval.opval) = newUNOP(OP_PREDEC, 0,
- op_lvalue(scalar((ps[(2) - (2)].val.opval)), OP_PREDEC));
+ mod(scalar((ps[(2) - (2)].val.opval)), OP_PREDEC));
TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 152:
-#line 1115 "perly.y"
+ case 135:
+#line 984 "perly.y"
{ (yyval.opval) = newANONLIST((ps[(2) - (3)].val.opval));
TOKEN_GETMAD((ps[(1) - (3)].val.i_tkval),(yyval.opval),'[');
TOKEN_GETMAD((ps[(3) - (3)].val.i_tkval),(yyval.opval),']');
- }
+ ;}
break;
- case 153:
-#line 1120 "perly.y"
- { (yyval.opval) = newANONLIST((OP*)NULL);
+ case 136:
+#line 989 "perly.y"
+ { (yyval.opval) = newANONLIST(Nullop);
TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'[');
TOKEN_GETMAD((ps[(2) - (2)].val.i_tkval),(yyval.opval),']');
- }
+ ;}
break;
- case 154:
-#line 1125 "perly.y"
+ case 137:
+#line 994 "perly.y"
{ (yyval.opval) = newANONHASH((ps[(2) - (4)].val.opval));
TOKEN_GETMAD((ps[(1) - (4)].val.i_tkval),(yyval.opval),'{');
TOKEN_GETMAD((ps[(3) - (4)].val.i_tkval),(yyval.opval),';');
TOKEN_GETMAD((ps[(4) - (4)].val.i_tkval),(yyval.opval),'}');
- }
+ ;}
break;
- case 155:
-#line 1131 "perly.y"
- { (yyval.opval) = newANONHASH((OP*)NULL);
+ case 138:
+#line 1000 "perly.y"
+ { (yyval.opval) = newANONHASH(Nullop);
TOKEN_GETMAD((ps[(1) - (3)].val.i_tkval),(yyval.opval),'{');
TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),';');
TOKEN_GETMAD((ps[(3) - (3)].val.i_tkval),(yyval.opval),'}');
- }
+ ;}
break;
- case 156:
-#line 1137 "perly.y"
+ case 139:
+#line 1006 "perly.y"
{ SvREFCNT_inc_simple_void(PL_compcv);
(yyval.opval) = newANONATTRSUB((ps[(2) - (5)].val.ival), (ps[(3) - (5)].val.opval), (ps[(4) - (5)].val.opval), (ps[(5) - (5)].val.opval));
TOKEN_GETMAD((ps[(1) - (5)].val.i_tkval),(yyval.opval),'o');
OP_GETMAD((ps[(3) - (5)].val.opval),(yyval.opval),'s');
OP_GETMAD((ps[(4) - (5)].val.opval),(yyval.opval),'a');
- }
+ ;}
break;
- case 157:
-#line 1148 "perly.y"
+ case 140:
+#line 1017 "perly.y"
{ (yyval.opval) = dofile((ps[(2) - (2)].val.opval), IVAL((ps[(1) - (2)].val.i_tkval)));
TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 158:
-#line 1152 "perly.y"
- { (yyval.opval) = newUNOP(OP_NULL, OPf_SPECIAL, op_scope((ps[(2) - (2)].val.opval)));
+ case 141:
+#line 1021 "perly.y"
+ { (yyval.opval) = newUNOP(OP_NULL, OPf_SPECIAL, scope((ps[(2) - (2)].val.opval)));
TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'D');
- }
+ ;}
break;
- case 163:
-#line 1162 "perly.y"
+ case 142:
+#line 1025 "perly.y"
+ { (yyval.opval) = newUNOP(OP_ENTERSUB,
+ OPf_SPECIAL|OPf_STACKED,
+ prepend_elem(OP_LIST,
+ scalar(newCVREF(
+ (OPpENTERSUB_AMPER<<8),
+ scalar((ps[(2) - (4)].val.opval))
+ )),Nullop)); dep();
+ TOKEN_GETMAD((ps[(1) - (4)].val.i_tkval),(yyval.opval),'o');
+ TOKEN_GETMAD((ps[(3) - (4)].val.i_tkval),(yyval.opval),'(');
+ TOKEN_GETMAD((ps[(4) - (4)].val.i_tkval),(yyval.opval),')');
+ ;}
+ break;
+
+ case 143:
+#line 1037 "perly.y"
+ { (yyval.opval) = newUNOP(OP_ENTERSUB,
+ OPf_SPECIAL|OPf_STACKED,
+ append_elem(OP_LIST,
+ (ps[(4) - (5)].val.opval),
+ scalar(newCVREF(
+ (OPpENTERSUB_AMPER<<8),
+ scalar((ps[(2) - (5)].val.opval))
+ )))); dep();
+ TOKEN_GETMAD((ps[(1) - (5)].val.i_tkval),(yyval.opval),'o');
+ TOKEN_GETMAD((ps[(3) - (5)].val.i_tkval),(yyval.opval),'(');
+ TOKEN_GETMAD((ps[(5) - (5)].val.i_tkval),(yyval.opval),')');
+ ;}
+ break;
+
+ case 144:
+#line 1050 "perly.y"
+ { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED,
+ prepend_elem(OP_LIST,
+ scalar(newCVREF(0,scalar((ps[(2) - (4)].val.opval)))), Nullop)); dep();
+ TOKEN_GETMAD((ps[(1) - (4)].val.i_tkval),(yyval.opval),'o');
+ TOKEN_GETMAD((ps[(3) - (4)].val.i_tkval),(yyval.opval),'(');
+ TOKEN_GETMAD((ps[(4) - (4)].val.i_tkval),(yyval.opval),')');
+ ;}
+ break;
+
+ case 145:
+#line 1058 "perly.y"
+ { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED,
+ prepend_elem(OP_LIST,
+ (ps[(4) - (5)].val.opval),
+ scalar(newCVREF(0,scalar((ps[(2) - (5)].val.opval)))))); dep();
+ TOKEN_GETMAD((ps[(1) - (5)].val.i_tkval),(yyval.opval),'o');
+ TOKEN_GETMAD((ps[(3) - (5)].val.i_tkval),(yyval.opval),'(');
+ TOKEN_GETMAD((ps[(5) - (5)].val.i_tkval),(yyval.opval),')');
+ ;}
+ break;
+
+ case 150:
+#line 1074 "perly.y"
{ (yyval.opval) = newCONDOP(0, (ps[(1) - (5)].val.opval), (ps[(3) - (5)].val.opval), (ps[(5) - (5)].val.opval));
TOKEN_GETMAD((ps[(2) - (5)].val.i_tkval),(yyval.opval),'?');
TOKEN_GETMAD((ps[(4) - (5)].val.i_tkval),(yyval.opval),':');
- }
+ ;}
break;
- case 164:
-#line 1167 "perly.y"
- { (yyval.opval) = newUNOP(OP_REFGEN, 0, op_lvalue((ps[(2) - (2)].val.opval),OP_REFGEN));
+ case 151:
+#line 1079 "perly.y"
+ { (yyval.opval) = newUNOP(OP_REFGEN, 0, mod((ps[(2) - (2)].val.opval),OP_REFGEN));
TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 165:
-#line 1171 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ case 152:
+#line 1083 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
- case 166:
-#line 1173 "perly.y"
+ case 153:
+#line 1085 "perly.y"
{ (yyval.opval) = localize((ps[(2) - (2)].val.opval),IVAL((ps[(1) - (2)].val.i_tkval)));
TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'k');
- }
+ ;}
break;
- case 167:
-#line 1177 "perly.y"
+ case 154:
+#line 1089 "perly.y"
{ (yyval.opval) = sawparens(IF_MAD(newUNOP(OP_NULL,0,(ps[(2) - (3)].val.opval)), (ps[(2) - (3)].val.opval)));
TOKEN_GETMAD((ps[(1) - (3)].val.i_tkval),(yyval.opval),'(');
TOKEN_GETMAD((ps[(3) - (3)].val.i_tkval),(yyval.opval),')');
- }
- break;
-
- case 168:
-#line 1182 "perly.y"
- { (yyval.opval) = IF_MAD(newUNOP(OP_NULL,0,(ps[(1) - (1)].val.opval)), (ps[(1) - (1)].val.opval)); }
+ ;}
break;
- case 169:
-#line 1184 "perly.y"
+ case 155:
+#line 1094 "perly.y"
{ (yyval.opval) = sawparens(newNULLLIST());
TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'(');
TOKEN_GETMAD((ps[(2) - (2)].val.i_tkval),(yyval.opval),')');
- }
+ ;}
break;
- case 170:
-#line 1189 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ case 156:
+#line 1099 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
- case 171:
-#line 1191 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ case 157:
+#line 1101 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
- case 172:
-#line 1193 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ case 158:
+#line 1103 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
- case 173:
-#line 1195 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ case 159:
+#line 1105 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
- case 174:
-#line 1197 "perly.y"
- { (yyval.opval) = newUNOP(OP_AV2ARYLEN, 0, ref((ps[(1) - (1)].val.opval), OP_AV2ARYLEN));}
+ case 160:
+#line 1107 "perly.y"
+ { (yyval.opval) = newUNOP(OP_AV2ARYLEN, 0, ref((ps[(1) - (1)].val.opval), OP_AV2ARYLEN));;}
break;
- case 175:
-#line 1199 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ case 161:
+#line 1109 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
- case 176:
-#line 1201 "perly.y"
- { (yyval.opval) = op_prepend_elem(OP_ASLICE,
+ case 162:
+#line 1111 "perly.y"
+ { (yyval.opval) = prepend_elem(OP_ASLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_ASLICE, 0,
list((ps[(3) - (4)].val.opval)),
ref((ps[(1) - (4)].val.opval), OP_ASLICE)));
- if ((yyval.opval) && (ps[(1) - (4)].val.opval))
- (yyval.opval)->op_private |=
- (ps[(1) - (4)].val.opval)->op_private & OPpSLICEWARNING;
- TOKEN_GETMAD((ps[(2) - (4)].val.i_tkval),(yyval.opval),'[');
- TOKEN_GETMAD((ps[(4) - (4)].val.i_tkval),(yyval.opval),']');
- }
- break;
-
- case 177:
-#line 1213 "perly.y"
- { (yyval.opval) = op_prepend_elem(OP_KVASLICE,
- newOP(OP_PUSHMARK, 0),
- newLISTOP(OP_KVASLICE, 0,
- list((ps[(3) - (4)].val.opval)),
- ref(oopsAV((ps[(1) - (4)].val.opval)), OP_KVASLICE)));
- if ((yyval.opval) && (ps[(1) - (4)].val.opval))
- (yyval.opval)->op_private |=
- (ps[(1) - (4)].val.opval)->op_private & OPpSLICEWARNING;
TOKEN_GETMAD((ps[(2) - (4)].val.i_tkval),(yyval.opval),'[');
TOKEN_GETMAD((ps[(4) - (4)].val.i_tkval),(yyval.opval),']');
- }
+ ;}
break;
- case 178:
-#line 1225 "perly.y"
- { (yyval.opval) = op_prepend_elem(OP_HSLICE,
+ case 163:
+#line 1120 "perly.y"
+ { (yyval.opval) = prepend_elem(OP_HSLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_HSLICE, 0,
list((ps[(3) - (5)].val.opval)),
ref(oopsHV((ps[(1) - (5)].val.opval)), OP_HSLICE)));
- if ((yyval.opval) && (ps[(1) - (5)].val.opval))
- (yyval.opval)->op_private |=
- (ps[(1) - (5)].val.opval)->op_private & OPpSLICEWARNING;
- PL_parser->expect = XOPERATOR;
- TOKEN_GETMAD((ps[(2) - (5)].val.i_tkval),(yyval.opval),'{');
- TOKEN_GETMAD((ps[(4) - (5)].val.i_tkval),(yyval.opval),';');
- TOKEN_GETMAD((ps[(5) - (5)].val.i_tkval),(yyval.opval),'}');
- }
- break;
-
- case 179:
-#line 1239 "perly.y"
- { (yyval.opval) = op_prepend_elem(OP_KVHSLICE,
- newOP(OP_PUSHMARK, 0),
- newLISTOP(OP_KVHSLICE, 0,
- list((ps[(3) - (5)].val.opval)),
- ref((ps[(1) - (5)].val.opval), OP_KVHSLICE)));
- if ((yyval.opval) && (ps[(1) - (5)].val.opval))
- (yyval.opval)->op_private |=
- (ps[(1) - (5)].val.opval)->op_private & OPpSLICEWARNING;
PL_parser->expect = XOPERATOR;
TOKEN_GETMAD((ps[(2) - (5)].val.i_tkval),(yyval.opval),'{');
TOKEN_GETMAD((ps[(4) - (5)].val.i_tkval),(yyval.opval),';');
TOKEN_GETMAD((ps[(5) - (5)].val.i_tkval),(yyval.opval),'}');
- }
+ ;}
break;
- case 180:
-#line 1253 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ case 164:
+#line 1131 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
- case 181:
-#line 1255 "perly.y"
- { (yyval.opval) = newUNOP(OP_ENTERSUB, 0, scalar((ps[(1) - (1)].val.opval))); }
+ case 165:
+#line 1133 "perly.y"
+ { (yyval.opval) = newUNOP(OP_ENTERSUB, 0, scalar((ps[(1) - (1)].val.opval))); ;}
break;
- case 182:
-#line 1257 "perly.y"
+ case 166:
+#line 1135 "perly.y"
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[(1) - (3)].val.opval)));
TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'(');
TOKEN_GETMAD((ps[(3) - (3)].val.i_tkval),(yyval.opval),')');
- }
+ ;}
break;
- case 183:
-#line 1262 "perly.y"
+ case 167:
+#line 1140 "perly.y"
{
(yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
- op_append_elem(OP_LIST, (ps[(3) - (4)].val.opval), scalar((ps[(1) - (4)].val.opval))));
+ append_elem(OP_LIST, (ps[(3) - (4)].val.opval), scalar((ps[(1) - (4)].val.opval))));
DO_MAD({
OP* op = (yyval.opval);
if (op->op_type == OP_CONST) { /* defeat const fold */
@@ -1509,159 +1317,110 @@ case 2:
}
token_getmad((ps[(2) - (4)].val.i_tkval),op,'(');
token_getmad((ps[(4) - (4)].val.i_tkval),op,')');
- });
- }
+ })
+ ;}
break;
- case 184:
-#line 1275 "perly.y"
+ case 168:
+#line 1153 "perly.y"
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
- op_append_elem(OP_LIST, (ps[(3) - (3)].val.opval), scalar((ps[(2) - (3)].val.opval))));
+ append_elem(OP_LIST, (ps[(3) - (3)].val.opval), scalar((ps[(2) - (3)].val.opval))));
TOKEN_GETMAD((ps[(1) - (3)].val.i_tkval),(yyval.opval),'o');
- }
- break;
-
- case 185:
-#line 1280 "perly.y"
- { (yyval.opval) = newSVREF((ps[(1) - (4)].val.opval));
- TOKEN_GETMAD((ps[(3) - (4)].val.i_tkval),(yyval.opval),'$');
- }
- break;
-
- case 186:
-#line 1284 "perly.y"
- { (yyval.opval) = newAVREF((ps[(1) - (4)].val.opval));
- TOKEN_GETMAD((ps[(3) - (4)].val.i_tkval),(yyval.opval),'@');
- }
- break;
-
- case 187:
-#line 1288 "perly.y"
- { (yyval.opval) = newHVREF((ps[(1) - (4)].val.opval));
- TOKEN_GETMAD((ps[(3) - (4)].val.i_tkval),(yyval.opval),'%');
- }
- break;
-
- case 188:
-#line 1292 "perly.y"
- { (yyval.opval) = newUNOP(OP_ENTERSUB, 0,
- scalar(newCVREF(IVAL((ps[(3) - (4)].val.i_tkval)),(ps[(1) - (4)].val.opval))));
- TOKEN_GETMAD((ps[(3) - (4)].val.i_tkval),(yyval.opval),'&');
- }
+ ;}
break;
- case 189:
-#line 1297 "perly.y"
- { (yyval.opval) = newGVREF(0,(ps[(1) - (4)].val.opval));
- TOKEN_GETMAD((ps[(3) - (4)].val.i_tkval),(yyval.opval),'*');
- }
- break;
-
- case 190:
-#line 1301 "perly.y"
+ case 169:
+#line 1158 "perly.y"
{ (yyval.opval) = newOP(IVAL((ps[(1) - (1)].val.i_tkval)), OPf_SPECIAL);
PL_hints |= HINT_BLOCK_SCOPE;
TOKEN_GETMAD((ps[(1) - (1)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 191:
-#line 1306 "perly.y"
+ case 170:
+#line 1163 "perly.y"
{ (yyval.opval) = newLOOPEX(IVAL((ps[(1) - (2)].val.i_tkval)),(ps[(2) - (2)].val.opval));
TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 192:
-#line 1310 "perly.y"
+ case 171:
+#line 1167 "perly.y"
{ (yyval.opval) = newUNOP(OP_NOT, 0, scalar((ps[(2) - (2)].val.opval)));
TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 193:
-#line 1314 "perly.y"
+ case 172:
+#line 1171 "perly.y"
{ (yyval.opval) = newOP(IVAL((ps[(1) - (1)].val.i_tkval)), 0);
TOKEN_GETMAD((ps[(1) - (1)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 194:
-#line 1318 "perly.y"
+ case 173:
+#line 1175 "perly.y"
{ (yyval.opval) = newUNOP(IVAL((ps[(1) - (2)].val.i_tkval)), 0, (ps[(2) - (2)].val.opval));
TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 195:
-#line 1322 "perly.y"
+ case 174:
+#line 1179 "perly.y"
{ (yyval.opval) = newUNOP(IVAL((ps[(1) - (2)].val.i_tkval)), 0, (ps[(2) - (2)].val.opval));
TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 196:
-#line 1326 "perly.y"
+ case 175:
+#line 1183 "perly.y"
{ (yyval.opval) = newOP(OP_REQUIRE, (ps[(1) - (1)].val.i_tkval) ? OPf_SPECIAL : 0);
TOKEN_GETMAD((ps[(1) - (1)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 197:
-#line 1330 "perly.y"
+ case 176:
+#line 1187 "perly.y"
{ (yyval.opval) = newUNOP(OP_REQUIRE, (ps[(1) - (2)].val.i_tkval) ? OPf_SPECIAL : 0, (ps[(2) - (2)].val.opval));
TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 198:
-#line 1334 "perly.y"
- { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[(1) - (1)].val.opval))); }
+ case 177:
+#line 1191 "perly.y"
+ { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[(1) - (1)].val.opval))); ;}
break;
- case 199:
-#line 1336 "perly.y"
+ case 178:
+#line 1193 "perly.y"
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
- op_append_elem(OP_LIST, (ps[(2) - (2)].val.opval), scalar((ps[(1) - (2)].val.opval)))); }
+ append_elem(OP_LIST, (ps[(2) - (2)].val.opval), scalar((ps[(1) - (2)].val.opval)))); ;}
break;
- case 200:
-#line 1339 "perly.y"
+ case 179:
+#line 1196 "perly.y"
{ (yyval.opval) = newOP(IVAL((ps[(1) - (1)].val.i_tkval)), 0);
TOKEN_GETMAD((ps[(1) - (1)].val.i_tkval),(yyval.opval),'o');
- }
+ ;}
break;
- case 201:
-#line 1343 "perly.y"
+ case 180:
+#line 1200 "perly.y"
{ (yyval.opval) = newOP(IVAL((ps[(1) - (3)].val.i_tkval)), 0);
TOKEN_GETMAD((ps[(1) - (3)].val.i_tkval),(yyval.opval),'o');
TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'(');
TOKEN_GETMAD((ps[(3) - (3)].val.i_tkval),(yyval.opval),')');
- }
- break;
-
- case 202:
-#line 1349 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
- break;
-
- case 203:
-#line 1351 "perly.y"
- { (yyval.opval) = (ps[(1) - (3)].val.opval);
- TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'(');
- TOKEN_GETMAD((ps[(3) - (3)].val.i_tkval),(yyval.opval),')');
- }
+ ;}
break;
- case 204:
-#line 1356 "perly.y"
+ case 181:
+#line 1206 "perly.y"
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
- scalar((ps[(1) - (1)].val.opval))); }
+ scalar((ps[(1) - (1)].val.opval))); ;}
break;
- case 205:
-#line 1359 "perly.y"
+ case 182:
+#line 1209 "perly.y"
{ (yyval.opval) = (IVAL((ps[(1) - (3)].val.i_tkval)) == OP_NOT)
? newUNOP(IVAL((ps[(1) - (3)].val.i_tkval)), 0, newSVOP(OP_CONST, 0, newSViv(0)))
: newOP(IVAL((ps[(1) - (3)].val.i_tkval)), OPf_SPECIAL);
@@ -1669,219 +1428,178 @@ case 2:
TOKEN_GETMAD((ps[(1) - (3)].val.i_tkval),(yyval.opval),'o');
TOKEN_GETMAD((ps[(2) - (3)].val.i_tkval),(yyval.opval),'(');
TOKEN_GETMAD((ps[(3) - (3)].val.i_tkval),(yyval.opval),')');
- }
+ ;}
break;
- case 206:
-#line 1368 "perly.y"
+ case 183:
+#line 1218 "perly.y"
{ (yyval.opval) = newUNOP(IVAL((ps[(1) - (4)].val.i_tkval)), 0, (ps[(3) - (4)].val.opval));
TOKEN_GETMAD((ps[(1) - (4)].val.i_tkval),(yyval.opval),'o');
TOKEN_GETMAD((ps[(2) - (4)].val.i_tkval),(yyval.opval),'(');
TOKEN_GETMAD((ps[(4) - (4)].val.i_tkval),(yyval.opval),')');
- }
- break;
-
- case 207:
-#line 1374 "perly.y"
- {
- if ( (ps[(1) - (1)].val.opval)->op_type != OP_TRANS
- && (ps[(1) - (1)].val.opval)->op_type != OP_TRANSR
- && (((PMOP*)(ps[(1) - (1)].val.opval))->op_pmflags & PMf_HAS_CV))
- {
- (yyval.ival) = start_subparse(FALSE, CVf_ANON);
- SAVEFREESV(PL_compcv);
- } else
- (yyval.ival) = 0;
- }
- break;
-
- case 208:
-#line 1385 "perly.y"
- { (yyval.opval) = pmruntime((ps[(1) - (5)].val.opval), (ps[(4) - (5)].val.opval), 1, (ps[(2) - (5)].val.ival));
- TOKEN_GETMAD((ps[(3) - (5)].val.i_tkval),(yyval.opval),'(');
- TOKEN_GETMAD((ps[(5) - (5)].val.i_tkval),(yyval.opval),')');
- }
+ ;}
break;
- case 211:
-#line 1392 "perly.y"
- {
- (yyval.opval) = newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0),
- newSVOP(OP_CONST, 0, newSVpvs("Unimplemented")));
- TOKEN_GETMAD((ps[(1) - (1)].val.i_tkval),(yyval.opval),'X');
- }
+ case 184:
+#line 1224 "perly.y"
+ { (yyval.opval) = pmruntime((ps[(1) - (4)].val.opval), (ps[(3) - (4)].val.opval), 1);
+ TOKEN_GETMAD((ps[(2) - (4)].val.i_tkval),(yyval.opval),'(');
+ TOKEN_GETMAD((ps[(4) - (4)].val.i_tkval),(yyval.opval),')');
+ ;}
break;
- case 213:
-#line 1402 "perly.y"
+ case 187:
+#line 1234 "perly.y"
{ (yyval.opval) = my_attrs((ps[(2) - (3)].val.opval),(ps[(3) - (3)].val.opval));
DO_MAD(
token_getmad((ps[(1) - (3)].val.i_tkval),(yyval.opval),'d');
append_madprops((ps[(3) - (3)].val.opval)->op_madprop, (yyval.opval), 'a');
(ps[(3) - (3)].val.opval)->op_madprop = 0;
- );
- }
+ )
+ ;}
break;
- case 214:
-#line 1410 "perly.y"
+ case 188:
+#line 1242 "perly.y"
{ (yyval.opval) = localize((ps[(2) - (2)].val.opval),IVAL((ps[(1) - (2)].val.i_tkval)));
TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'d');
- }
+ ;}
break;
- case 215:
-#line 1417 "perly.y"
+ case 189:
+#line 1249 "perly.y"
{ (yyval.opval) = sawparens((ps[(2) - (3)].val.opval));
TOKEN_GETMAD((ps[(1) - (3)].val.i_tkval),(yyval.opval),'(');
TOKEN_GETMAD((ps[(3) - (3)].val.i_tkval),(yyval.opval),')');
- }
+ ;}
break;
- case 216:
-#line 1422 "perly.y"
+ case 190:
+#line 1254 "perly.y"
{ (yyval.opval) = sawparens(newNULLLIST());
TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'(');
TOKEN_GETMAD((ps[(2) - (2)].val.i_tkval),(yyval.opval),')');
- }
+ ;}
break;
- case 217:
-#line 1427 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ case 191:
+#line 1259 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
+ break;
+
+ case 192:
+#line 1261 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
- case 218:
-#line 1429 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ case 193:
+#line 1263 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
- case 219:
-#line 1431 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ case 194:
+#line 1268 "perly.y"
+ { (yyval.opval) = Nullop; ;}
break;
- case 220:
-#line 1436 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+ case 195:
+#line 1270 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
- case 221:
-#line 1438 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ case 196:
+#line 1274 "perly.y"
+ { (yyval.opval) = Nullop; ;}
break;
- case 222:
-#line 1442 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+ case 197:
+#line 1276 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
- case 223:
-#line 1444 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ case 198:
+#line 1278 "perly.y"
+ {
+#ifdef MAD
+ OP* op = newNULLLIST();
+ token_getmad((ps[(2) - (2)].val.i_tkval),op,',');
+ (yyval.opval) = append_elem(OP_LIST, (ps[(1) - (2)].val.opval), op);
+#else
+ (yyval.opval) = (ps[(1) - (2)].val.opval);
+#endif
+
+ ;}
break;
- case 224:
-#line 1450 "perly.y"
- { PL_parser->in_my = 0; (yyval.opval) = my((ps[(1) - (1)].val.opval)); }
+ case 199:
+#line 1293 "perly.y"
+ { PL_parser->in_my = 0; (yyval.opval) = my((ps[(1) - (1)].val.opval)); ;}
break;
- case 225:
-#line 1454 "perly.y"
+ case 200:
+#line 1297 "perly.y"
{ (yyval.opval) = newCVREF(IVAL((ps[(1) - (2)].val.i_tkval)),(ps[(2) - (2)].val.opval));
TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'&');
- }
+ ;}
break;
- case 226:
-#line 1460 "perly.y"
+ case 201:
+#line 1303 "perly.y"
{ (yyval.opval) = newSVREF((ps[(2) - (2)].val.opval));
TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'$');
- }
+ ;}
break;
- case 227:
-#line 1466 "perly.y"
+ case 202:
+#line 1309 "perly.y"
{ (yyval.opval) = newAVREF((ps[(2) - (2)].val.opval));
- if ((yyval.opval)) (yyval.opval)->op_private |= IVAL((ps[(1) - (2)].val.i_tkval));
TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'@');
- }
+ ;}
break;
- case 228:
-#line 1473 "perly.y"
+ case 203:
+#line 1315 "perly.y"
{ (yyval.opval) = newHVREF((ps[(2) - (2)].val.opval));
- if ((yyval.opval)) (yyval.opval)->op_private |= IVAL((ps[(1) - (2)].val.i_tkval));
TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'%');
- }
+ ;}
break;
- case 229:
-#line 1480 "perly.y"
+ case 204:
+#line 1321 "perly.y"
{ (yyval.opval) = newAVREF((ps[(2) - (2)].val.opval));
TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'l');
- }
- break;
-
- case 230:
-#line 1484 "perly.y"
- { (yyval.opval) = newAVREF((ps[(1) - (4)].val.opval));
- TOKEN_GETMAD((ps[(3) - (4)].val.i_tkval),(yyval.opval),'l');
- }
+ ;}
break;
- case 231:
-#line 1490 "perly.y"
+ case 205:
+#line 1327 "perly.y"
{ (yyval.opval) = newGVREF(0,(ps[(2) - (2)].val.opval));
TOKEN_GETMAD((ps[(1) - (2)].val.i_tkval),(yyval.opval),'*');
- }
+ ;}
break;
- case 233:
-#line 1497 "perly.y"
- { (yyval.opval) = newAVREF((ps[(1) - (3)].val.opval));
- TOKEN_GETMAD((ps[(3) - (3)].val.i_tkval),(yyval.opval),'@');
- }
- break;
-
- case 235:
-#line 1504 "perly.y"
- { (yyval.opval) = newHVREF((ps[(1) - (3)].val.opval));
- TOKEN_GETMAD((ps[(3) - (3)].val.i_tkval),(yyval.opval),'@');
- }
+ case 206:
+#line 1334 "perly.y"
+ { (yyval.opval) = scalar((ps[(1) - (1)].val.opval)); ;}
break;
- case 237:
-#line 1511 "perly.y"
- { (yyval.opval) = newGVREF(0,(ps[(1) - (3)].val.opval));
- TOKEN_GETMAD((ps[(3) - (3)].val.i_tkval),(yyval.opval),'*');
- }
+ case 207:
+#line 1336 "perly.y"
+ { (yyval.opval) = scalar((ps[(1) - (1)].val.opval)); ;}
break;
- case 238:
-#line 1518 "perly.y"
- { (yyval.opval) = scalar((ps[(1) - (1)].val.opval)); }
+ case 208:
+#line 1338 "perly.y"
+ { (yyval.opval) = scope((ps[(1) - (1)].val.opval)); ;}
break;
- case 239:
-#line 1520 "perly.y"
- { (yyval.opval) = scalar((ps[(1) - (1)].val.opval)); }
+ case 209:
+#line 1341 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
- case 240:
-#line 1522 "perly.y"
- { (yyval.opval) = op_scope((ps[(1) - (1)].val.opval)); }
- break;
- case 241:
-#line 1525 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
- break;
+/* Line 1267 of yacc.c. */
default: break;
-
-/* Generated from:
- * bb8245a1a537b2afb2445b3973f63b210f9ec346a1955071aef7d05ba97196ae perly.y
- * 5c9d2a0262457fe9b70073fc8ad6c188f812f38ad57712b7e2f53daa01b297cc regen_perly.pl
- * ex: set ro: */
diff --git a/gnu/usr.bin/perl/perly.tab b/gnu/usr.bin/perl/perly.tab
index 4f5a86a7721..bb232a5306e 100644
--- a/gnu/usr.bin/perl/perly.tab
+++ b/gnu/usr.bin/perl/perly.tab
@@ -1,25 +1,19 @@
-/* -*- buffer-read-only: t -*-
- !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
- This file is built by regen_perly.pl from perly.y.
- Any changes made here will be lost!
- */
-
-#define YYFINAL 14
+#define YYFINAL 3
/* YYLAST -- Last index in YYTABLE. */
-#define YYLAST 2731
+#define YYLAST 2049
/* YYNTOKENS -- Number of terminals. */
-#define YYNTOKENS 105
+#define YYNTOKENS 90
/* YYNNTS -- Number of nonterminals. */
-#define YYNNTS 72
+#define YYNNTS 65
/* YYNRULES -- Number of rules. */
-#define YYNRULES 241
+#define YYNRULES 209
/* YYNRULES -- Number of states. */
-#define YYNSTATES 475
+#define YYNSTATES 419
/* YYTRANSLATE(YYLEX) -- Bison symbol number corresponding to YYLEX. */
#define YYUNDEFTOK 2
-#define YYMAXUTOK 338
+#define YYMAXUTOK 325
#define YYTRANSLATE(YYX) \
((unsigned int) (YYX) <= YYMAXUTOK ? yytranslate[YYX] : YYUNDEFTOK)
@@ -30,16 +24,16 @@ static const yytype_uint8 yytranslate[] =
0, 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, 91, 2, 2, 15, 17, 19, 2,
- 103, 102, 18, 14, 80, 13, 22, 2, 2, 2,
- 2, 2, 2, 2, 2, 2, 2, 2, 83, 20,
- 2, 21, 2, 82, 16, 2, 2, 2, 2, 2,
+ 2, 2, 2, 77, 2, 2, 9, 11, 13, 2,
+ 88, 87, 12, 8, 66, 7, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 69, 14,
+ 2, 2, 2, 68, 10, 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, 11, 2, 12, 2, 2, 2, 2, 2, 2,
+ 2, 5, 2, 6, 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, 9, 2, 10, 92, 2, 2, 2,
+ 2, 2, 2, 3, 2, 4, 78, 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, 2,
@@ -52,15 +46,14 @@ static const yytype_uint8 yytranslate[] =
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, 2, 2, 2, 2, 1, 2, 3, 4,
- 5, 6, 7, 8, 23, 24, 25, 26, 27, 28,
- 29, 30, 31, 32, 33, 34, 35, 36, 37, 38,
- 39, 40, 41, 42, 43, 44, 45, 46, 47, 48,
- 49, 50, 51, 52, 53, 54, 55, 56, 57, 58,
- 59, 60, 61, 62, 63, 64, 65, 66, 67, 68,
- 69, 70, 71, 72, 73, 74, 75, 76, 77, 78,
- 79, 81, 84, 85, 86, 87, 88, 89, 90, 93,
- 94, 95, 96, 97, 98, 99, 100, 101, 104
+ 2, 2, 2, 2, 2, 2, 1, 2, 15, 16,
+ 17, 18, 19, 20, 21, 22, 23, 24, 25, 26,
+ 27, 28, 29, 30, 31, 32, 33, 34, 35, 36,
+ 37, 38, 39, 40, 41, 42, 43, 44, 45, 46,
+ 47, 48, 49, 50, 51, 52, 53, 54, 55, 56,
+ 57, 58, 59, 60, 61, 62, 63, 64, 65, 67,
+ 70, 71, 72, 73, 74, 75, 76, 79, 80, 81,
+ 82, 83, 84, 85, 86, 89
};
#if YYDEBUG
@@ -68,149 +61,131 @@ static const yytype_uint8 yytranslate[] =
YYRHS. */
static const yytype_uint16 yyprhs[] =
{
- 0, 0, 3, 4, 9, 10, 14, 15, 19, 20,
- 24, 25, 29, 30, 34, 39, 47, 48, 53, 54,
- 55, 58, 59, 62, 64, 66, 69, 72, 74, 76,
- 81, 82, 90, 95, 96, 104, 112, 120, 127, 134,
- 137, 146, 155, 167, 177, 186, 194, 197, 198, 207,
- 210, 212, 215, 216, 220, 222, 224, 228, 232, 236,
- 240, 244, 248, 249, 252, 259, 260, 263, 264, 265,
- 267, 268, 270, 272, 274, 276, 278, 280, 281, 282,
- 283, 284, 286, 288, 289, 291, 292, 295, 297, 300,
- 302, 303, 304, 308, 314, 316, 318, 322, 326, 330,
- 332, 335, 339, 341, 345, 351, 358, 362, 366, 372,
- 375, 380, 381, 387, 389, 391, 397, 402, 408, 413,
- 419, 426, 432, 437, 443, 448, 452, 459, 464, 470,
- 474, 478, 482, 486, 490, 494, 498, 502, 506, 510,
- 514, 518, 522, 526, 529, 532, 535, 538, 541, 544,
- 547, 550, 553, 557, 560, 565, 569, 575, 578, 581,
- 583, 585, 587, 589, 595, 598, 600, 603, 607, 609,
- 612, 614, 616, 618, 620, 622, 624, 629, 634, 640,
- 646, 648, 650, 654, 659, 663, 668, 673, 678, 683,
- 688, 690, 693, 696, 698, 701, 704, 706, 709, 711,
- 714, 716, 720, 722, 726, 728, 732, 737, 738, 744,
- 746, 748, 750, 752, 756, 759, 763, 766, 768, 770,
- 772, 773, 775, 776, 778, 780, 783, 786, 789, 792,
- 795, 800, 803, 805, 809, 811, 815, 817, 821, 823,
- 825, 827
+ 0, 0, 3, 6, 11, 12, 13, 14, 19, 20,
+ 21, 24, 27, 30, 32, 34, 37, 40, 44, 46,
+ 48, 52, 56, 60, 64, 68, 69, 72, 79, 87,
+ 95, 102, 105, 106, 109, 119, 129, 140, 150, 159,
+ 172, 176, 185, 186, 187, 189, 190, 192, 194, 196,
+ 198, 200, 201, 203, 205, 207, 209, 211, 213, 215,
+ 217, 222, 224, 225, 232, 239, 240, 241, 242, 244,
+ 245, 247, 248, 251, 253, 256, 258, 260, 262, 266,
+ 267, 275, 279, 283, 287, 289, 292, 296, 298, 302,
+ 308, 315, 319, 323, 329, 332, 337, 338, 344, 346,
+ 348, 354, 359, 365, 370, 376, 383, 389, 394, 400,
+ 405, 409, 416, 422, 426, 430, 434, 438, 442, 446,
+ 450, 454, 458, 462, 466, 470, 474, 478, 481, 484,
+ 487, 490, 493, 496, 499, 502, 506, 509, 514, 518,
+ 524, 527, 530, 535, 541, 546, 552, 554, 556, 558,
+ 560, 566, 569, 571, 574, 578, 581, 583, 585, 587,
+ 589, 591, 593, 598, 604, 606, 608, 612, 617, 621,
+ 623, 626, 629, 631, 634, 637, 639, 642, 644, 647,
+ 649, 653, 655, 659, 664, 669, 671, 673, 677, 680,
+ 684, 687, 689, 691, 693, 694, 696, 697, 699, 702,
+ 704, 707, 710, 713, 716, 719, 722, 724, 726, 728
};
/* YYRHS -- A `-1'-separated list of the rules' RHS. */
static const yytype_int16 yyrhs[] =
{
- 106, 0, -1, -1, 3, 107, 115, 118, -1, -1,
- 4, 108, 165, -1, -1, 5, 109, 113, -1, -1,
- 6, 110, 122, -1, -1, 7, 111, 120, -1, -1,
- 8, 112, 118, -1, 9, 115, 118, 10, -1, 21,
- 115, 20, 74, 119, 20, 22, -1, -1, 9, 117,
- 118, 10, -1, -1, -1, 118, 120, -1, -1, 119,
- 126, -1, 122, -1, 121, -1, 36, 122, -1, 36,
- 121, -1, 35, -1, 104, -1, 37, 141, 138, 114,
- -1, -1, 38, 142, 139, 123, 143, 144, 149, -1,
- 40, 23, 23, 20, -1, -1, 41, 139, 124, 23,
- 23, 164, 20, -1, 44, 103, 115, 135, 102, 116,
- 129, -1, 45, 103, 115, 137, 102, 116, 129, -1,
- 50, 103, 115, 135, 102, 116, -1, 51, 103, 115,
- 135, 102, 116, -1, 52, 113, -1, 42, 103, 115,
- 133, 102, 131, 116, 130, -1, 43, 103, 115, 134,
- 102, 131, 116, 130, -1, 49, 103, 115, 136, 20,
- 133, 20, 131, 136, 102, 116, -1, 49, 70, 115,
- 166, 103, 135, 102, 116, 130, -1, 49, 168, 103,
- 115, 135, 102, 116, 130, -1, 49, 103, 115, 135,
- 102, 116, 130, -1, 113, 130, -1, -1, 40, 23,
- 23, 9, 115, 125, 118, 10, -1, 128, 20, -1,
- 20, -1, 26, 127, -1, -1, 73, 118, 74, -1,
- 1, -1, 150, -1, 150, 44, 150, -1, 150, 45,
- 150, -1, 150, 42, 150, -1, 150, 43, 134, -1,
- 150, 49, 150, -1, 150, 51, 150, -1, -1, 46,
- 116, -1, 47, 103, 135, 102, 116, 129, -1, -1,
- 48, 113, -1, -1, -1, 128, -1, -1, 150, -1,
- 150, -1, 150, -1, 132, -1, 134, -1, 23, -1,
- -1, -1, -1, -1, 23, -1, 28, -1, -1, 26,
- -1, -1, 72, 26, -1, 72, -1, 72, 26, -1,
- 72, -1, -1, -1, 103, 147, 102, -1, 115, 146,
- 9, 118, 10, -1, 148, -1, 20, -1, 150, 78,
- 150, -1, 150, 77, 150, -1, 150, 76, 150, -1,
- 151, -1, 151, 80, -1, 151, 80, 160, -1, 160,
- -1, 60, 176, 151, -1, 58, 103, 176, 150, 102,
- -1, 160, 101, 154, 103, 165, 102, -1, 160, 101,
- 154, -1, 24, 176, 164, -1, 25, 176, 103, 165,
- 102, -1, 60, 164, -1, 58, 103, 165, 102, -1,
- -1, 33, 140, 113, 153, 164, -1, 24, -1, 168,
- -1, 175, 9, 150, 20, 10, -1, 168, 11, 150,
- 12, -1, 160, 101, 11, 150, 12, -1, 155, 11,
- 150, 12, -1, 168, 9, 150, 20, 10, -1, 160,
- 101, 9, 150, 20, 10, -1, 155, 9, 150, 20,
- 10, -1, 160, 101, 103, 102, -1, 160, 101, 103,
- 150, 102, -1, 155, 103, 150, 102, -1, 155, 103,
- 102, -1, 103, 150, 102, 11, 150, 12, -1, 29,
- 11, 150, 12, -1, 103, 102, 11, 150, 12, -1,
- 160, 81, 160, -1, 160, 95, 160, -1, 160, 63,
- 160, -1, 160, 64, 160, -1, 160, 89, 160, -1,
- 160, 61, 160, -1, 160, 62, 160, -1, 160, 88,
- 160, -1, 160, 87, 160, -1, 160, 54, 160, -1,
- 160, 86, 160, -1, 160, 85, 160, -1, 160, 84,
- 160, -1, 160, 90, 160, -1, 13, 160, -1, 14,
- 160, -1, 91, 160, -1, 92, 160, -1, 160, 98,
- -1, 160, 97, -1, 160, 96, -1, 100, 160, -1,
- 99, 160, -1, 11, 150, 12, -1, 11, 12, -1,
- 67, 150, 20, 10, -1, 67, 20, 10, -1, 39,
- 140, 143, 144, 148, -1, 66, 160, -1, 66, 113,
- -1, 156, -1, 157, -1, 158, -1, 159, -1, 160,
- 82, 160, 83, 160, -1, 93, 160, -1, 162, -1,
- 69, 160, -1, 103, 150, 102, -1, 29, -1, 103,
- 102, -1, 168, -1, 172, -1, 170, -1, 169, -1,
- 171, -1, 155, -1, 173, 11, 150, 12, -1, 174,
- 11, 150, 12, -1, 173, 9, 150, 20, 10, -1,
- 174, 9, 150, 20, 10, -1, 26, -1, 167, -1,
- 167, 103, 102, -1, 167, 103, 150, 102, -1, 68,
- 142, 164, -1, 160, 101, 15, 18, -1, 160, 101,
- 16, 18, -1, 160, 101, 17, 18, -1, 160, 101,
- 19, 18, -1, 160, 101, 18, 18, -1, 53, -1,
- 53, 160, -1, 79, 151, -1, 59, -1, 59, 113,
- -1, 59, 160, -1, 71, -1, 71, 160, -1, 32,
- -1, 32, 160, -1, 56, -1, 56, 103, 102, -1,
- 30, -1, 30, 103, 102, -1, 31, -1, 57, 103,
- 102, -1, 57, 103, 150, 102, -1, -1, 27, 161,
- 103, 151, 102, -1, 23, -1, 152, -1, 55, -1,
- 34, -1, 70, 163, 145, -1, 70, 163, -1, 103,
- 150, 102, -1, 103, 102, -1, 168, -1, 170, -1,
- 169, -1, -1, 151, -1, -1, 150, -1, 168, -1,
- 19, 176, -1, 15, 176, -1, 16, 176, -1, 17,
- 176, -1, 65, 176, -1, 160, 101, 65, 18, -1,
- 18, 176, -1, 169, -1, 160, 101, 16, -1, 170,
- -1, 160, 101, 17, -1, 172, -1, 160, 101, 18,
- -1, 23, -1, 168, -1, 113, -1, 28, -1
+ 91, 0, -1, 95, 98, -1, 3, 93, 98, 4,
+ -1, -1, -1, -1, 3, 97, 98, 4, -1, -1,
+ -1, 98, 115, -1, 98, 99, -1, 114, 102, -1,
+ 105, -1, 106, -1, 114, 103, -1, 114, 14, -1,
+ 114, 100, 14, -1, 1, -1, 132, -1, 132, 32,
+ 132, -1, 132, 33, 132, -1, 132, 30, 132, -1,
+ 132, 31, 110, -1, 132, 37, 132, -1, -1, 34,
+ 96, -1, 35, 88, 111, 87, 96, 101, -1, 32,
+ 88, 93, 111, 87, 96, 101, -1, 33, 88, 93,
+ 113, 87, 96, 101, -1, 39, 88, 93, 111, 87,
+ 96, -1, 40, 92, -1, -1, 36, 92, -1, 114,
+ 30, 88, 93, 109, 87, 107, 96, 104, -1, 114,
+ 31, 88, 93, 110, 87, 107, 96, 104, -1, 114,
+ 37, 57, 93, 147, 88, 111, 87, 96, 104, -1,
+ 114, 37, 149, 88, 93, 111, 87, 96, 104, -1,
+ 114, 37, 88, 93, 111, 87, 96, 104, -1, 114,
+ 37, 88, 93, 112, 14, 109, 14, 107, 112, 87,
+ 96, -1, 114, 92, 104, -1, 114, 38, 88, 93,
+ 94, 111, 87, 96, -1, -1, -1, 100, -1, -1,
+ 132, -1, 132, -1, 132, -1, 108, -1, 110, -1,
+ -1, 24, -1, 117, -1, 120, -1, 119, -1, 129,
+ -1, 130, -1, 116, -1, 89, -1, 25, 123, 118,
+ 92, -1, 15, -1, -1, 58, 121, 124, 125, 126,
+ 128, -1, 26, 121, 124, 125, 126, 128, -1, -1,
+ -1, -1, 15, -1, -1, 18, -1, -1, 60, 18,
+ -1, 60, -1, 60, 18, -1, 60, -1, 92, -1,
+ 14, -1, 28, 15, 14, -1, -1, 29, 121, 131,
+ 15, 15, 145, 14, -1, 132, 64, 132, -1, 132,
+ 63, 132, -1, 132, 62, 132, -1, 133, -1, 133,
+ 66, -1, 133, 66, 142, -1, 142, -1, 47, 154,
+ 133, -1, 45, 88, 154, 132, 87, -1, 142, 86,
+ 136, 88, 146, 87, -1, 142, 86, 136, -1, 16,
+ 154, 145, -1, 17, 154, 88, 146, 87, -1, 47,
+ 145, -1, 45, 88, 146, 87, -1, -1, 23, 122,
+ 92, 135, 145, -1, 16, -1, 149, -1, 153, 3,
+ 132, 14, 4, -1, 149, 5, 132, 6, -1, 142,
+ 86, 5, 132, 6, -1, 137, 5, 132, 6, -1,
+ 149, 3, 132, 14, 4, -1, 142, 86, 3, 132,
+ 14, 4, -1, 137, 3, 132, 14, 4, -1, 142,
+ 86, 88, 87, -1, 142, 86, 88, 132, 87, -1,
+ 137, 88, 132, 87, -1, 137, 88, 87, -1, 88,
+ 132, 87, 5, 132, 6, -1, 88, 87, 5, 132,
+ 6, -1, 142, 67, 142, -1, 142, 81, 142, -1,
+ 142, 50, 142, -1, 142, 51, 142, -1, 142, 75,
+ 142, -1, 142, 48, 142, -1, 142, 49, 142, -1,
+ 142, 74, 142, -1, 142, 73, 142, -1, 142, 42,
+ 142, -1, 142, 72, 142, -1, 142, 71, 142, -1,
+ 142, 70, 142, -1, 142, 76, 142, -1, 7, 142,
+ -1, 8, 142, -1, 77, 142, -1, 78, 142, -1,
+ 142, 83, -1, 142, 82, -1, 85, 142, -1, 84,
+ 142, -1, 5, 132, 6, -1, 5, 6, -1, 54,
+ 132, 14, 4, -1, 54, 14, 4, -1, 27, 122,
+ 125, 126, 92, -1, 53, 142, -1, 53, 92, -1,
+ 53, 15, 88, 87, -1, 53, 15, 88, 132, 87,
+ -1, 53, 149, 88, 87, -1, 53, 149, 88, 132,
+ 87, -1, 138, -1, 139, -1, 140, -1, 141, -1,
+ 142, 68, 142, 69, 142, -1, 79, 142, -1, 143,
+ -1, 56, 142, -1, 88, 132, 87, -1, 88, 87,
+ -1, 149, -1, 153, -1, 151, -1, 150, -1, 152,
+ -1, 137, -1, 150, 5, 132, 6, -1, 150, 3,
+ 132, 14, 4, -1, 18, -1, 148, -1, 148, 88,
+ 87, -1, 148, 88, 132, 87, -1, 55, 15, 145,
+ -1, 41, -1, 41, 142, -1, 65, 133, -1, 46,
+ -1, 46, 92, -1, 46, 142, -1, 59, -1, 59,
+ 142, -1, 22, -1, 22, 142, -1, 43, -1, 43,
+ 88, 87, -1, 21, -1, 44, 88, 87, -1, 44,
+ 88, 132, 87, -1, 19, 88, 133, 87, -1, 15,
+ -1, 134, -1, 57, 144, 127, -1, 57, 144, -1,
+ 88, 132, 87, -1, 88, 87, -1, 149, -1, 151,
+ -1, 150, -1, -1, 133, -1, -1, 132, -1, 132,
+ 66, -1, 149, -1, 13, 154, -1, 9, 154, -1,
+ 10, 154, -1, 11, 154, -1, 52, 154, -1, 12,
+ 154, -1, 15, -1, 149, -1, 92, -1, 20, -1
};
/* YYRLINE[YYN] -- source line where rule number YYN was defined. */
static const yytype_uint16 yyrline[] =
{
- 0, 142, 142, 141, 151, 150, 160, 159, 172, 171,
- 184, 183, 196, 195, 207, 217, 227, 230, 240, 245,
- 246, 256, 257, 266, 274, 278, 286, 296, 298, 303,
- 321, 320, 370, 386, 385, 402, 411, 420, 431, 433,
- 435, 445, 455, 476, 485, 494, 503, 510, 509, 526,
- 532, 542, 566, 567, 572, 574, 576, 580, 584, 588,
- 592, 597, 603, 604, 610, 624, 625, 634, 640, 641,
- 646, 649, 653, 658, 662, 666, 670, 671, 675, 681,
- 686, 691, 692, 697, 698, 703, 704, 708, 718, 722,
- 732, 734, 733, 752, 764, 765, 775, 779, 783, 787,
- 791, 801, 810, 814, 819, 826, 835, 841, 847, 855,
- 859, 866, 865, 876, 877, 881, 890, 895, 903, 910,
- 917, 927, 936, 943, 952, 959, 965, 972, 977, 987,
- 991, 995, 1001, 1005, 1009, 1013, 1017, 1021, 1025, 1037,
- 1041, 1045, 1049, 1059, 1063, 1070, 1074, 1078, 1083, 1088,
- 1100, 1105, 1114, 1119, 1124, 1130, 1136, 1147, 1151, 1157,
- 1158, 1159, 1160, 1161, 1166, 1170, 1172, 1176, 1181, 1183,
- 1188, 1190, 1192, 1194, 1196, 1198, 1200, 1212, 1224, 1238,
- 1252, 1254, 1256, 1261, 1274, 1279, 1283, 1287, 1291, 1296,
- 1300, 1305, 1309, 1313, 1317, 1321, 1325, 1329, 1333, 1335,
- 1338, 1342, 1348, 1350, 1355, 1358, 1367, 1374, 1373, 1389,
- 1390, 1391, 1397, 1401, 1409, 1416, 1421, 1426, 1428, 1430,
- 1435, 1437, 1442, 1443, 1449, 1453, 1459, 1465, 1472, 1479,
- 1483, 1489, 1495, 1496, 1502, 1503, 1509, 1510, 1517, 1519,
- 1521, 1524
+ 0, 135, 135, 141, 151, 155, 159, 165, 175, 180,
+ 181, 188, 198, 201, 202, 204, 206, 223, 242, 244,
+ 246, 250, 254, 258, 262, 271, 272, 276, 287, 295,
+ 306, 309, 315, 316, 323, 336, 348, 359, 369, 379,
+ 411, 419, 429, 435, 436, 441, 444, 448, 453, 457,
+ 461, 467, 476, 480, 482, 484, 486, 488, 493, 497,
+ 503, 517, 518, 522, 535, 558, 564, 569, 574, 584,
+ 585, 590, 591, 595, 605, 609, 619, 620, 629, 643,
+ 642, 661, 665, 669, 673, 677, 687, 696, 700, 705,
+ 712, 721, 727, 733, 741, 745, 752, 751, 762, 763,
+ 767, 776, 781, 789, 796, 803, 813, 822, 829, 838,
+ 845, 851, 858, 868, 872, 876, 882, 886, 890, 894,
+ 898, 902, 906, 918, 922, 926, 930, 940, 944, 951,
+ 955, 959, 964, 969, 974, 983, 988, 993, 999, 1005,
+ 1016, 1020, 1024, 1036, 1049, 1057, 1069, 1070, 1071, 1072,
+ 1073, 1078, 1082, 1084, 1088, 1093, 1098, 1100, 1102, 1104,
+ 1106, 1108, 1110, 1119, 1130, 1132, 1134, 1139, 1152, 1157,
+ 1162, 1166, 1170, 1174, 1178, 1182, 1186, 1190, 1192, 1195,
+ 1199, 1205, 1208, 1217, 1223, 1228, 1229, 1233, 1241, 1248,
+ 1253, 1258, 1260, 1262, 1267, 1269, 1274, 1275, 1277, 1292,
+ 1296, 1302, 1308, 1314, 1320, 1326, 1333, 1335, 1337, 1340
};
#endif
@@ -219,32 +194,28 @@ static const yytype_uint16 yyrline[] =
First, the terminals, then, starting at YYNTOKENS, nonterminals. */
static const char *const yytname[] =
{
- "$end", "error", "$undefined", "GRAMPROG", "GRAMEXPR", "GRAMBLOCK",
- "GRAMBARESTMT", "GRAMFULLSTMT", "GRAMSTMTSEQ", "'{'", "'}'", "'['",
- "']'", "'-'", "'+'", "'$'", "'@'", "'%'", "'*'", "'&'", "';'", "'='",
- "'.'", "WORD", "METHOD", "FUNCMETH", "THING", "PMFUNC", "PRIVATEREF",
- "QWLIST", "FUNC0OP", "FUNC0SUB", "UNIOPSUB", "LSTOPSUB", "PLUGEXPR",
- "PLUGSTMT", "LABEL", "FORMAT", "SUB", "ANONSUB", "PACKAGE", "USE",
- "WHILE", "UNTIL", "IF", "UNLESS", "ELSE", "ELSIF", "CONTINUE", "FOR",
- "GIVEN", "WHEN", "DEFAULT", "LOOPEX", "DOTDOT", "YADAYADA", "FUNC0",
- "FUNC1", "FUNC", "UNIOP", "LSTOP", "RELOP", "EQOP", "MULOP", "ADDOP",
- "DOLSHARP", "DO", "HASHBRACK", "NOAMP", "LOCAL", "MY", "REQUIRE",
- "COLONATTR", "FORMLBRACK", "FORMRBRACK", "PREC_LOW", "DOROP", "OROP",
- "ANDOP", "NOTOP", "','", "ASSIGNOP", "'?'", "':'", "DORDOR", "OROR",
- "ANDAND", "BITOROP", "BITANDOP", "SHIFTOP", "MATCHOP", "'!'", "'~'",
- "REFGEN", "UMINUS", "POWOP", "POSTJOIN", "POSTDEC", "POSTINC", "PREDEC",
- "PREINC", "ARROW", "')'", "'('", "PEG", "$accept", "grammar", "$@1",
- "$@2", "$@3", "$@4", "$@5", "$@6", "block", "formblock", "remember",
- "mblock", "mremember", "stmtseq", "formstmtseq", "fullstmt",
- "labfullstmt", "barestmt", "$@7", "$@8", "$@9", "formline", "formarg",
- "sideff", "else", "cont", "mintro", "nexpr", "texpr", "iexpr", "mexpr",
- "mnexpr", "miexpr", "formname", "startsub", "startanonsub",
- "startformsub", "subname", "proto", "subattrlist", "myattrlist",
- "subsignature", "@10", "realsubbody", "optsubbody", "expr", "listexpr",
- "listop", "@11", "method", "subscripted", "termbinop", "termunop",
- "anonymous", "termdo", "term", "@12", "myattrterm", "myterm",
- "optlistexpr", "optexpr", "my_scalar", "amper", "scalar", "ary", "hsh",
- "arylen", "star", "sliceme", "kvslice", "gelem", "indirob", 0
+ "$end", "error", "$undefined", "'{'", "'}'", "'['", "']'", "'-'", "'+'",
+ "'$'", "'@'", "'%'", "'*'", "'&'", "';'", "WORD", "METHOD", "FUNCMETH",
+ "THING", "PMFUNC", "PRIVATEREF", "FUNC0SUB", "UNIOPSUB", "LSTOPSUB",
+ "LABEL", "FORMAT", "SUB", "ANONSUB", "PACKAGE", "USE", "WHILE", "UNTIL",
+ "IF", "UNLESS", "ELSE", "ELSIF", "CONTINUE", "FOR", "GIVEN", "WHEN",
+ "DEFAULT", "LOOPEX", "DOTDOT", "FUNC0", "FUNC1", "FUNC", "UNIOP",
+ "LSTOP", "RELOP", "EQOP", "MULOP", "ADDOP", "DOLSHARP", "DO",
+ "HASHBRACK", "NOAMP", "LOCAL", "MY", "MYSUB", "REQUIRE", "COLONATTR",
+ "PREC_LOW", "DOROP", "OROP", "ANDOP", "NOTOP", "','", "ASSIGNOP", "'?'",
+ "':'", "DORDOR", "OROR", "ANDAND", "BITOROP", "BITANDOP", "SHIFTOP",
+ "MATCHOP", "'!'", "'~'", "REFGEN", "UMINUS", "POWOP", "POSTDEC",
+ "POSTINC", "PREDEC", "PREINC", "ARROW", "')'", "'('", "PEG", "$accept",
+ "prog", "block", "remember", "mydefsv", "progstart", "mblock",
+ "mremember", "lineseq", "line", "sideff", "else", "cond", "case", "cont",
+ "loop", "switch", "mintro", "nexpr", "texpr", "iexpr", "mexpr", "mnexpr",
+ "miexpr", "label", "decl", "peg", "format", "formname", "mysubrout",
+ "subrout", "startsub", "startanonsub", "startformsub", "subname",
+ "proto", "subattrlist", "myattrlist", "subbody", "package", "use", "@1",
+ "expr", "argexpr", "listop", "@2", "method", "subscripted", "termbinop",
+ "termunop", "anonymous", "termdo", "term", "myattrterm", "myterm",
+ "listexpr", "listexprcom", "my_scalar", "amper", "scalar", "ary", "hsh",
+ "arylen", "star", "indirob", 0
};
#endif
@@ -253,834 +224,661 @@ static const char *const yytname[] =
token YYLEX-NUM. */
static const yytype_uint16 yytoknum[] =
{
- 0, 256, 257, 258, 259, 260, 261, 262, 263, 123,
- 125, 91, 93, 45, 43, 36, 64, 37, 42, 38,
- 59, 61, 46, 264, 265, 266, 267, 268, 269, 270,
- 271, 272, 273, 274, 275, 276, 277, 278, 279, 280,
- 281, 282, 283, 284, 285, 286, 287, 288, 289, 290,
- 291, 292, 293, 294, 295, 296, 297, 298, 299, 300,
- 301, 302, 303, 304, 305, 306, 307, 308, 309, 310,
- 311, 312, 313, 314, 315, 316, 317, 318, 319, 320,
- 44, 321, 63, 58, 322, 323, 324, 325, 326, 327,
- 328, 33, 126, 329, 330, 331, 332, 333, 334, 335,
- 336, 337, 41, 40, 338
+ 0, 256, 257, 123, 125, 91, 93, 45, 43, 36,
+ 64, 37, 42, 38, 59, 258, 259, 260, 261, 262,
+ 263, 264, 265, 266, 267, 268, 269, 270, 271, 272,
+ 273, 274, 275, 276, 277, 278, 279, 280, 281, 282,
+ 283, 284, 285, 286, 287, 288, 289, 290, 291, 292,
+ 293, 294, 295, 296, 297, 298, 299, 300, 301, 302,
+ 303, 304, 305, 306, 307, 308, 44, 309, 63, 58,
+ 310, 311, 312, 313, 314, 315, 316, 33, 126, 317,
+ 318, 319, 320, 321, 322, 323, 324, 41, 40, 325
};
# endif
/* YYR1[YYN] -- Symbol number of symbol that rule YYN derives. */
static const yytype_uint8 yyr1[] =
{
- 0, 105, 107, 106, 108, 106, 109, 106, 110, 106,
- 111, 106, 112, 106, 113, 114, 115, 116, 117, 118,
- 118, 119, 119, 120, 120, 121, 121, 122, 122, 122,
- 123, 122, 122, 124, 122, 122, 122, 122, 122, 122,
- 122, 122, 122, 122, 122, 122, 122, 125, 122, 122,
- 122, 126, 127, 127, 128, 128, 128, 128, 128, 128,
- 128, 128, 129, 129, 129, 130, 130, 131, 132, 132,
- 133, 133, 134, 135, 136, 137, 138, 138, 139, 140,
- 141, 142, 142, 143, 143, 144, 144, 144, 145, 145,
- 146, 147, 146, 148, 149, 149, 150, 150, 150, 150,
- 151, 151, 151, 152, 152, 152, 152, 152, 152, 152,
- 152, 153, 152, 154, 154, 155, 155, 155, 155, 155,
- 155, 155, 155, 155, 155, 155, 155, 155, 155, 156,
- 156, 156, 156, 156, 156, 156, 156, 156, 156, 156,
- 156, 156, 156, 157, 157, 157, 157, 157, 157, 157,
- 157, 157, 158, 158, 158, 158, 158, 159, 159, 160,
- 160, 160, 160, 160, 160, 160, 160, 160, 160, 160,
- 160, 160, 160, 160, 160, 160, 160, 160, 160, 160,
- 160, 160, 160, 160, 160, 160, 160, 160, 160, 160,
- 160, 160, 160, 160, 160, 160, 160, 160, 160, 160,
- 160, 160, 160, 160, 160, 160, 160, 161, 160, 160,
- 160, 160, 160, 162, 162, 163, 163, 163, 163, 163,
- 164, 164, 165, 165, 166, 167, 168, 169, 170, 171,
- 171, 172, 173, 173, 174, 174, 175, 175, 176, 176,
- 176, 176
+ 0, 90, 91, 92, 93, 94, 95, 96, 97, 98,
+ 98, 98, 99, 99, 99, 99, 99, 99, 100, 100,
+ 100, 100, 100, 100, 100, 101, 101, 101, 102, 102,
+ 103, 103, 104, 104, 105, 105, 105, 105, 105, 105,
+ 105, 106, 107, 108, 108, 109, 109, 110, 111, 112,
+ 113, 114, 114, 115, 115, 115, 115, 115, 115, 116,
+ 117, 118, 118, 119, 120, 121, 122, 123, 124, 125,
+ 125, 126, 126, 126, 127, 127, 128, 128, 129, 131,
+ 130, 132, 132, 132, 132, 133, 133, 133, 134, 134,
+ 134, 134, 134, 134, 134, 134, 135, 134, 136, 136,
+ 137, 137, 137, 137, 137, 137, 137, 137, 137, 137,
+ 137, 137, 137, 138, 138, 138, 138, 138, 138, 138,
+ 138, 138, 138, 138, 138, 138, 138, 139, 139, 139,
+ 139, 139, 139, 139, 139, 140, 140, 140, 140, 140,
+ 141, 141, 141, 141, 141, 141, 142, 142, 142, 142,
+ 142, 142, 142, 142, 142, 142, 142, 142, 142, 142,
+ 142, 142, 142, 142, 142, 142, 142, 142, 142, 142,
+ 142, 142, 142, 142, 142, 142, 142, 142, 142, 142,
+ 142, 142, 142, 142, 142, 142, 142, 143, 143, 144,
+ 144, 144, 144, 144, 145, 145, 146, 146, 146, 147,
+ 148, 149, 150, 151, 152, 153, 154, 154, 154, 154
};
/* YYR2[YYN] -- Number of symbols composing right hand side of rule YYN. */
static const yytype_uint8 yyr2[] =
{
- 0, 2, 0, 4, 0, 3, 0, 3, 0, 3,
- 0, 3, 0, 3, 4, 7, 0, 4, 0, 0,
- 2, 0, 2, 1, 1, 2, 2, 1, 1, 4,
- 0, 7, 4, 0, 7, 7, 7, 6, 6, 2,
- 8, 8, 11, 9, 8, 7, 2, 0, 8, 2,
- 1, 2, 0, 3, 1, 1, 3, 3, 3, 3,
- 3, 3, 0, 2, 6, 0, 2, 0, 0, 1,
- 0, 1, 1, 1, 1, 1, 1, 0, 0, 0,
- 0, 1, 1, 0, 1, 0, 2, 1, 2, 1,
- 0, 0, 3, 5, 1, 1, 3, 3, 3, 1,
- 2, 3, 1, 3, 5, 6, 3, 3, 5, 2,
- 4, 0, 5, 1, 1, 5, 4, 5, 4, 5,
- 6, 5, 4, 5, 4, 3, 6, 4, 5, 3,
- 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
- 3, 3, 3, 2, 2, 2, 2, 2, 2, 2,
- 2, 2, 3, 2, 4, 3, 5, 2, 2, 1,
- 1, 1, 1, 5, 2, 1, 2, 3, 1, 2,
- 1, 1, 1, 1, 1, 1, 4, 4, 5, 5,
- 1, 1, 3, 4, 3, 4, 4, 4, 4, 4,
- 1, 2, 2, 1, 2, 2, 1, 2, 1, 2,
- 1, 3, 1, 3, 1, 3, 4, 0, 5, 1,
- 1, 1, 1, 3, 2, 3, 2, 1, 1, 1,
- 0, 1, 0, 1, 1, 2, 2, 2, 2, 2,
- 4, 2, 1, 3, 1, 3, 1, 3, 1, 1,
- 1, 1
+ 0, 2, 2, 4, 0, 0, 0, 4, 0, 0,
+ 2, 2, 2, 1, 1, 2, 2, 3, 1, 1,
+ 3, 3, 3, 3, 3, 0, 2, 6, 7, 7,
+ 6, 2, 0, 2, 9, 9, 10, 9, 8, 12,
+ 3, 8, 0, 0, 1, 0, 1, 1, 1, 1,
+ 1, 0, 1, 1, 1, 1, 1, 1, 1, 1,
+ 4, 1, 0, 6, 6, 0, 0, 0, 1, 0,
+ 1, 0, 2, 1, 2, 1, 1, 1, 3, 0,
+ 7, 3, 3, 3, 1, 2, 3, 1, 3, 5,
+ 6, 3, 3, 5, 2, 4, 0, 5, 1, 1,
+ 5, 4, 5, 4, 5, 6, 5, 4, 5, 4,
+ 3, 6, 5, 3, 3, 3, 3, 3, 3, 3,
+ 3, 3, 3, 3, 3, 3, 3, 2, 2, 2,
+ 2, 2, 2, 2, 2, 3, 2, 4, 3, 5,
+ 2, 2, 4, 5, 4, 5, 1, 1, 1, 1,
+ 5, 2, 1, 2, 3, 2, 1, 1, 1, 1,
+ 1, 1, 4, 5, 1, 1, 3, 4, 3, 1,
+ 2, 2, 1, 2, 2, 1, 2, 1, 2, 1,
+ 3, 1, 3, 4, 4, 1, 1, 3, 2, 3,
+ 2, 1, 1, 1, 0, 1, 0, 1, 2, 1,
+ 2, 2, 2, 2, 2, 2, 1, 1, 1, 1
};
-/* YYDEFACT[STATE-NAME] -- Default reduction number in state STATE-NUM.
- Performed when YYTABLE doesn't specify something else to do. Zero
+/* YYDEFACT[STATE-NAME] -- Default rule to reduce with in state
+ STATE-NUM when YYTABLE doesn't specify something else to do. Zero
means the default is an error. */
static const yytype_uint8 yydefact[] =
{
- 0, 2, 4, 6, 8, 10, 12, 0, 16, 222,
- 0, 0, 0, 19, 1, 19, 0, 0, 0, 0,
- 0, 0, 0, 0, 209, 0, 0, 180, 207, 168,
- 202, 204, 198, 79, 212, 79, 190, 211, 200, 0,
- 0, 193, 220, 0, 0, 0, 0, 0, 0, 196,
- 0, 0, 0, 0, 0, 0, 0, 223, 99, 210,
- 175, 159, 160, 161, 162, 102, 165, 5, 181, 170,
- 173, 172, 174, 171, 0, 0, 0, 16, 7, 54,
- 50, 27, 80, 0, 0, 78, 0, 0, 0, 0,
- 0, 0, 0, 0, 28, 65, 9, 0, 55, 0,
- 11, 24, 23, 0, 0, 153, 0, 143, 144, 238,
- 241, 240, 239, 226, 227, 228, 231, 225, 220, 0,
- 0, 0, 0, 199, 0, 83, 191, 0, 0, 222,
- 194, 195, 238, 221, 109, 239, 0, 229, 158, 157,
- 0, 0, 81, 82, 220, 166, 0, 214, 217, 219,
- 218, 197, 192, 145, 146, 164, 151, 150, 169, 0,
- 0, 0, 0, 100, 0, 0, 0, 0, 0, 0,
+ 6, 0, 9, 1, 51, 52, 67, 65, 0, 65,
+ 65, 59, 11, 13, 14, 0, 10, 58, 53, 55,
+ 54, 56, 57, 62, 0, 0, 79, 0, 18, 4,
+ 0, 0, 0, 0, 0, 0, 0, 0, 16, 185,
+ 0, 0, 164, 0, 181, 177, 66, 66, 0, 0,
+ 0, 0, 0, 0, 0, 0, 169, 179, 0, 0,
+ 172, 194, 0, 0, 0, 0, 0, 0, 175, 0,
+ 0, 0, 0, 0, 0, 0, 32, 0, 12, 15,
+ 19, 84, 186, 161, 146, 147, 148, 149, 87, 152,
+ 165, 156, 159, 158, 160, 157, 61, 0, 68, 69,
+ 78, 0, 69, 9, 136, 0, 127, 128, 206, 209,
+ 208, 207, 201, 202, 203, 205, 200, 194, 0, 0,
+ 178, 0, 69, 4, 4, 4, 4, 4, 4, 0,
+ 4, 4, 31, 170, 0, 0, 196, 173, 174, 206,
+ 195, 94, 207, 0, 204, 185, 141, 140, 156, 0,
+ 0, 194, 153, 0, 188, 191, 193, 192, 176, 171,
+ 129, 130, 151, 134, 133, 155, 0, 0, 40, 17,
+ 0, 0, 0, 0, 0, 0, 0, 0, 85, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 149, 148, 147, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 19, 77, 78, 0, 33, 16,
- 16, 16, 16, 16, 16, 0, 16, 16, 39, 0,
- 46, 49, 0, 0, 0, 0, 0, 0, 26, 25,
- 20, 152, 107, 222, 0, 0, 203, 111, 84, 85,
- 201, 205, 0, 0, 0, 103, 155, 0, 184, 216,
- 0, 89, 213, 0, 167, 98, 97, 96, 101, 0,
- 0, 125, 0, 138, 134, 135, 131, 132, 129, 0,
- 141, 140, 139, 137, 136, 133, 142, 130, 0, 0,
- 0, 233, 235, 237, 0, 113, 0, 0, 106, 114,
- 182, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 76, 0, 30, 0, 0, 70, 0, 0, 0, 0,
- 0, 16, 0, 0, 66, 58, 59, 72, 56, 57,
- 60, 61, 0, 0, 127, 220, 87, 16, 206, 110,
- 0, 154, 215, 88, 0, 0, 0, 118, 124, 0,
- 0, 0, 185, 186, 187, 189, 188, 230, 122, 0,
- 222, 183, 0, 116, 0, 176, 0, 177, 0, 14,
- 16, 29, 83, 16, 32, 0, 0, 71, 0, 0,
- 73, 75, 0, 0, 224, 69, 74, 0, 0, 55,
- 0, 0, 0, 108, 208, 112, 86, 90, 156, 104,
- 128, 0, 121, 163, 0, 117, 123, 0, 119, 178,
- 179, 115, 0, 85, 47, 220, 67, 67, 0, 0,
- 0, 0, 70, 0, 0, 0, 91, 0, 126, 120,
- 105, 0, 16, 19, 0, 0, 0, 18, 62, 62,
- 0, 65, 0, 0, 37, 38, 0, 19, 21, 95,
- 94, 31, 0, 34, 65, 65, 19, 0, 0, 35,
- 36, 0, 45, 67, 65, 92, 0, 0, 48, 40,
- 41, 0, 63, 0, 65, 0, 44, 93, 0, 52,
- 22, 17, 0, 43, 0, 15, 19, 51, 0, 0,
- 0, 62, 42, 53, 64
+ 0, 0, 0, 0, 0, 0, 0, 132, 131, 0,
+ 0, 0, 0, 0, 0, 0, 60, 70, 71, 0,
+ 71, 51, 135, 92, 196, 0, 96, 71, 45, 0,
+ 0, 0, 0, 0, 4, 5, 0, 180, 182, 0,
+ 197, 0, 0, 88, 0, 0, 138, 0, 168, 190,
+ 0, 75, 187, 0, 154, 33, 22, 23, 47, 20,
+ 21, 24, 83, 82, 81, 86, 0, 0, 110, 0,
+ 122, 118, 119, 115, 116, 113, 0, 125, 124, 123,
+ 121, 120, 117, 126, 114, 0, 0, 98, 0, 91,
+ 99, 166, 0, 0, 0, 0, 0, 0, 73, 0,
+ 194, 0, 3, 0, 184, 194, 0, 0, 46, 0,
+ 0, 48, 50, 0, 0, 199, 44, 49, 0, 0,
+ 19, 0, 0, 0, 183, 198, 95, 0, 142, 0,
+ 144, 0, 137, 189, 74, 0, 0, 0, 103, 109,
+ 0, 0, 0, 107, 0, 196, 167, 0, 101, 0,
+ 162, 0, 72, 77, 76, 64, 0, 63, 93, 97,
+ 139, 42, 42, 0, 0, 0, 0, 45, 0, 0,
+ 0, 89, 143, 145, 112, 0, 106, 150, 0, 102,
+ 108, 0, 104, 163, 100, 80, 0, 0, 8, 25,
+ 25, 0, 32, 0, 0, 0, 30, 111, 105, 90,
+ 32, 32, 9, 0, 0, 28, 29, 0, 38, 42,
+ 32, 41, 34, 35, 51, 26, 0, 32, 0, 37,
+ 7, 0, 36, 0, 0, 0, 25, 39, 27
};
/* YYDEFGOTO[NTERM-NUM]. */
static const yytype_int16 yydefgoto[] =
{
- -1, 7, 8, 9, 10, 11, 12, 13, 111, 351,
- 377, 418, 436, 103, 447, 220, 101, 102, 352, 294,
- 413, 460, 467, 97, 439, 210, 415, 366, 356, 306,
- 359, 368, 362, 291, 198, 124, 195, 144, 229, 317,
- 242, 407, 426, 378, 431, 98, 58, 59, 315, 278,
- 60, 61, 62, 63, 64, 65, 120, 66, 147, 134,
- 67, 363, 68, 69, 70, 71, 72, 73, 74, 75,
- 76, 113
+ -1, 1, 110, 103, 312, 2, 379, 392, 4, 12,
+ 306, 395, 78, 79, 168, 13, 14, 376, 307, 297,
+ 247, 300, 309, 303, 15, 16, 17, 18, 97, 19,
+ 20, 24, 121, 23, 99, 208, 289, 242, 345, 21,
+ 22, 101, 301, 81, 82, 295, 279, 83, 84, 85,
+ 86, 87, 88, 89, 154, 141, 231, 304, 90, 91,
+ 92, 93, 94, 95, 112
};
/* YYPACT[STATE-NUM] -- Index in YYTABLE of the portion describing
STATE-NUM. */
-#define YYPACT_NINF -401
+#define YYPACT_NINF -376
static const yytype_int16 yypact[] =
{
- 709, -401, -401, -401, -401, -401, -401, 15, -401, 2565,
- 19, 1216, 1120, -401, -401, -401, 1825, 2565, 2565, 379,
- 379, 379, 379, 379, -401, 379, 379, -401, -401, 13,
- -51, -401, 2565, -401, -401, -401, 2565, -401, -45, -39,
- -17, 1732, 1639, 379, 1732, 1916, 26, 2565, 10, 2565,
- 2565, 2565, 2565, 2565, 2565, 2565, 2007, -21, 11, -401,
- 1, -401, -401, -401, -401, 2585, -401, -401, -7, 54,
- 108, 131, -401, 91, 156, 221, 92, -401, -401, -401,
- -401, -401, -401, 26, 99, -401, 20, 52, 53, 65,
- -11, 69, 89, 19, -401, 116, -401, 158, 368, 1120,
- -401, -401, -401, 448, 544, -401, -1, 250, 250, -401,
- -401, -401, -401, -401, -401, -401, -401, -401, 2565, 90,
- 94, 2565, 96, 1901, 19, 182, 2585, 125, 2100, 1639,
- -401, 1901, 1545, 11, -401, 1466, 2565, -401, -401, 1901,
- 208, 68, -401, -401, 2565, 1901, 2193, 167, -401, -401,
- -401, 1901, 11, 250, 250, 250, 520, 520, 231, 139,
- 2565, 2565, 2565, 2565, 2565, 2565, 2286, 2565, 2565, 2565,
- 2565, 2565, 2565, 2565, 2565, 2565, 2565, 2565, 2565, 2565,
- 2565, 2565, -401, -401, -401, 63, 2379, 2565, 2565, 2565,
- 2565, 2565, 2565, 2565, -401, 222, -401, 223, -401, -401,
- -401, -401, -401, -401, -401, 141, -401, -401, -401, 19,
- -401, -401, 2565, 2565, 2565, 2565, 2565, 2565, -401, -401,
- -401, -401, -401, 2565, 2565, 61, -401, -401, -401, 191,
- -401, -401, 160, 162, 2565, 11, -401, 257, -401, -401,
- 213, 247, -401, 2565, 269, 199, 199, -401, 2585, 75,
- 72, -401, 233, 1298, 1810, 1624, 529, 273, 2585, 295,
- 342, 342, 1436, 1515, 1717, 1348, 250, 250, 2565, 2565,
- 515, 267, 288, 289, 290, -401, 296, 2472, 178, -401,
- -401, 349, 157, 93, 248, 98, 255, 103, 263, 640,
- -401, 297, -401, 12, 264, 2565, 2565, 2565, 2565, 301,
- 1310, -401, 2565, 2565, -401, -21, -401, -21, -21, -21,
- -21, -21, 217, -66, -401, 2565, 302, -401, -401, -401,
- 418, -401, -401, -401, 118, 2565, 311, -401, -401, 2565,
- 266, 124, -401, -401, -401, -401, -401, -401, -401, 434,
- 2565, -401, 317, -401, 320, -401, 340, -401, 343, -401,
- -401, -401, 182, -401, -401, 329, 252, -21, 253, 258,
- -21, -401, 259, 261, -401, -401, -401, 271, 366, 227,
- 2565, 285, 287, -401, -401, -401, -401, 292, -401, -401,
- -401, 129, -401, 2630, 388, -401, -401, 298, -401, -401,
- -401, -401, 394, 191, -401, 2565, -401, -401, 399, 399,
- 2565, 399, 2565, 314, 399, 399, -401, 409, -401, -401,
- -401, 346, 401, -401, 403, 399, 399, -401, 23, 23,
- 331, 116, 414, 399, -401, -401, 333, -401, -401, -401,
- -401, -401, 736, -401, 116, 116, -401, 399, 339, -401,
- -401, 399, -401, -401, 116, -401, 832, 9, -401, -401,
- -401, 928, -401, 2565, 116, 1403, -401, -401, 425, 380,
- -401, -401, 350, -401, 353, -401, -401, -401, 399, 399,
- 1024, 23, -401, -401, -401
+ -376, 31, -376, -376, 89, -376, -376, -376, 28, -376,
+ -376, -376, -376, -376, -376, 291, -376, -376, -376, -376,
+ -376, -376, -376, 53, 84, 86, -376, 84, -376, -376,
+ 867, 1703, 1703, 650, 650, 650, 650, 650, -376, -376,
+ 650, 650, -376, 44, -376, 1703, -376, -376, 49, 57,
+ 79, 95, 14, 96, 114, 100, 1703, 128, 139, 145,
+ 639, 555, 650, 723, 949, 153, 1703, 35, 1703, 1703,
+ 1703, 1703, 1703, 1703, 1703, 1031, 200, 239, -376, -376,
+ 1029, 188, -376, 16, -376, -376, -376, -376, 1879, -376,
+ 171, 131, 202, -376, -376, 261, -376, 100, -376, 250,
+ -376, 254, 250, -376, -376, 10, 132, 132, -376, -376,
+ -376, -376, -376, -376, -376, -376, -376, 1703, 187, 1703,
+ 898, 100, 250, -376, -376, -376, -376, -376, -376, 191,
+ -376, -376, -376, 1879, 198, 1115, 555, -376, 898, 1763,
+ 188, -376, 784, 1703, -376, 201, -376, 898, 19, 284,
+ 13, 1703, 898, 1199, 231, -376, -376, -376, 898, 188,
+ 132, 132, 132, 9, 9, 288, 107, 100, -376, -376,
+ 1703, 1703, 1703, 1703, 1703, 1703, 1703, 1703, 1703, 1703,
+ 1703, 1283, 1703, 1703, 1703, 1703, 1703, 1703, 1703, 1703,
+ 1703, 1703, 1703, 1703, 1703, 1703, 1703, -376, -376, 23,
+ 1367, 1703, 1703, 1703, 1703, 1703, -376, -376, 235, 282,
+ 235, 197, -376, -376, 1703, 59, -376, 235, 1703, 1703,
+ 1703, 1703, 310, 387, -376, -376, 1703, -376, -376, 148,
+ 319, 252, 1703, 188, 1451, 1535, -376, 337, -376, -376,
+ 194, 331, -376, 1703, 346, -376, 112, -376, 112, 112,
+ 112, 112, 298, 298, -376, 1879, 34, 77, -376, 253,
+ 1963, 852, 710, 503, 671, 1879, 1837, 375, 375, 542,
+ 625, 755, 457, 132, 132, 1703, 1703, -376, 1619, 264,
+ -376, -376, 297, 117, 80, 134, 88, 210, 345, 15,
+ 1703, 15, -376, 280, -376, 1703, 100, 285, 112, 286,
+ 287, 112, -376, 290, 283, -376, -376, -376, 293, 364,
+ 468, 1703, 1703, 303, -376, -376, -376, 302, -376, 349,
+ -376, 358, -376, -376, -376, 129, 1703, 403, -376, -376,
+ 1703, 263, 167, -376, 431, 1703, -376, 411, -376, 412,
+ -376, 413, -376, -376, -376, -376, 377, -376, -376, -376,
+ -376, -376, -376, 416, 416, 1703, 416, 1703, 340, 342,
+ 416, -376, -376, -376, -376, 203, -376, 1921, 433, -376,
+ -376, 348, -376, -376, -376, -376, 416, 416, -376, 21,
+ 21, 351, 200, 439, 416, 416, -376, -376, -376, -376,
+ 200, 200, -376, 416, 366, -376, -376, 416, -376, -376,
+ 200, -376, -376, -376, 329, -376, 1703, 200, 469, -376,
+ -376, 368, -376, 372, 416, 416, 21, -376, -376
};
/* YYPGOTO[NTERM-NUM]. */
static const yytype_int16 yypgoto[] =
{
- -401, -401, -401, -401, -401, -401, -401, -401, -10, -401,
- 22, -103, -401, -12, -401, 444, 359, 7, -401, -401,
- -401, -401, -401, -295, -400, 88, -381, -401, 67, -189,
- -280, 21, -401, -401, 274, 467, -401, 438, 173, 133,
- -401, -401, -401, 117, -401, -3, -33, -401, -401, -401,
- -401, -401, -401, -401, -401, 80, -401, -401, -401, -111,
- -121, -401, -401, 18, 480, 483, -401, -401, -401, -401,
- -401, 25
+ -376, -376, -13, -61, -376, -376, 1487, -376, -102, -376,
+ 445, -375, -376, -376, -120, -376, -376, -319, -376, 105,
+ 63, -206, 55, -376, -376, -376, -376, -376, -376, -376,
+ -376, 72, 420, -376, 441, -12, -180, -376, 178, -376,
+ -376, -376, -15, -58, -376, -376, -376, -376, -376, -376,
+ -376, -376, 56, -376, -376, -113, -202, -376, -376, -27,
+ 406, 422, -376, -376, 17
};
/* YYTABLE[YYPACT[STATE-NUM]]. What to do in state STATE-NUM. If
positive, shift that token. If negative, reduce the rule which
- number is the opposite. If YYTABLE_NINF, syntax error. */
-#define YYTABLE_NINF -237
+ number is the opposite. If zero, do what YYDEFACT says.
+ If YYTABLE_NINF, syntax error. */
+#define YYTABLE_NINF -186
static const yytype_int16 yytable[] =
{
- 78, 95, 95, 104, 19, 365, 57, 222, 233, 133,
- 164, 221, 165, 106, 163, 14, 416, 152, 96, 440,
- 367, 353, 371, 372, 121, 19, 20, 21, 77, 458,
- 15, 130, 354, 238, 138, 459, 374, 112, 112, 112,
- 112, 112, 141, 112, 112, 114, 115, 116, 117, 142,
- 118, 119, 122, 159, 143, 160, 161, 162, 127, 203,
- 135, 112, 455, 187, 128, 188, 148, 136, 137, 437,
- 438, 474, 268, 314, 269, 160, 161, 162, 270, 271,
- 272, 273, 274, 208, 327, 133, 129, 275, 237, 95,
- 403, 163, 204, 95, 95, 326, 186, 107, 108, 194,
- -236, 193, 312, 235, 166, 343, 219, 358, 205, 361,
- 345, 133, 123, 146, 227, 347, 126, -232, 225, -232,
- 420, 131, 197, 199, 139, 232, 57, 145, 276, 151,
- 380, 153, 154, 155, 156, 157, 385, 160, 161, 162,
- -234, 408, -234, 240, 160, 161, 162, 135, 160, 161,
- 162, 160, 161, 162, 234, 200, 201, 245, 246, 247,
- 365, 249, 250, 252, 209, 189, 277, 190, 202, 160,
- 161, 162, 206, 462, 160, 161, 162, 342, 211, 160,
- 161, 162, 289, 281, 282, 283, 284, 285, 286, 287,
- 288, 313, 207, 223, 160, 161, 162, 224, 226, 304,
- 160, 161, 162, 279, 375, 160, 161, 162, 228, 305,
- 307, 308, 309, 310, 311, 160, 161, 162, 236, 387,
- 57, 295, 296, 297, 298, 299, 300, 230, 302, 303,
- 191, 320, 192, 160, 161, 162, 160, 161, 162, 241,
- 324, 244, 243, 248, 301, 290, 293, 253, 254, 255,
- 256, 257, 258, 259, 260, 261, 262, 263, 264, 265,
- 266, 267, 318, 316, 319, 330, 331, 321, 344, 212,
- 213, 214, 215, 323, 339, 346, 216, 162, 217, 95,
- 325, 340, 133, 348, 414, 333, 384, 355, 112, 160,
- 161, 162, 357, 307, 360, 307, 419, 369, 421, 360,
- 360, 424, 425, 160, 161, 162, 334, 335, 336, 160,
- 161, 162, 434, 435, 337, 322, 19, 364, 350, 373,
- 444, 382, 381, 370, 160, 161, 162, 388, 376, -73,
- 389, 160, 161, 162, 452, 328, 170, 57, 454, 160,
- 161, 162, 160, 161, 162, 181, 182, 183, 184, 167,
- 390, 185, 395, 391, 396, 397, 168, 169, 170, 171,
- 398, 399, 133, 180, 400, 471, 472, 360, 181, 182,
- 183, 184, 392, 401, 185, 394, 172, 173, 329, 174,
- 175, 176, 177, 178, 179, 180, 402, 404, 77, 405,
- 181, 182, 183, 184, 19, 406, 185, 360, 409, 357,
- 410, 432, 109, 168, 169, 170, 171, 110, 417, 383,
- 212, 213, 214, 215, 411, 446, 423, 216, 427, 217,
- 428, 429, 95, 433, 451, 160, 161, 162, 176, 177,
- 178, 179, 180, 441, 443, 445, 95, 181, 182, 183,
- 184, 95, 453, 185, 160, 161, 162, 465, -13, 79,
- 360, 341, 468, 466, 470, 469, 100, 77, 218, 16,
- 95, 17, 18, 19, 20, 21, 22, 23, 80, 422,
- 292, 24, 25, 26, 27, 28, 464, 29, 30, 31,
- 32, 33, 34, 81, 99, 82, 83, 35, 84, 85,
- 86, 87, 88, 89, 160, 161, 162, 90, 91, 92,
- 93, 36, 125, 37, 38, 39, 40, 41, 42, 442,
- 160, 161, 162, 43, 44, 45, 46, 47, 48, 49,
- 379, 196, 449, 450, 77, 393, 412, 50, 149, 430,
- 19, 150, 456, 332, 0, 0, 386, 0, 109, 51,
- 52, 53, 463, 110, -3, 79, 0, 54, 55, 0,
- 0, 56, 94, 77, 0, 16, 0, 17, 18, 19,
- 20, 21, 22, 23, 80, 0, 0, 24, 25, 26,
- 27, 28, 0, 29, 30, 31, 32, 33, 34, 81,
- 99, 82, 83, 35, 84, 85, 86, 87, 88, 89,
- 0, 0, 0, 90, 91, 92, 93, 36, 0, 37,
- 38, 39, 40, 41, 42, 0, 0, 0, 0, 43,
- 44, 45, 46, 47, 48, 49, -237, -237, -237, 180,
- 0, 185, 0, 50, 181, 182, 183, 184, 0, 0,
- 185, 0, 0, 0, 0, 51, 52, 53, 0, 0,
- 0, 79, 0, 54, 55, 0, 0, 56, 94, 77,
- 349, 16, 0, 17, 18, 19, 20, 21, 22, 23,
- 80, 0, 0, 24, 25, 26, 27, 28, 0, 29,
- 30, 31, 32, 33, 34, 81, 99, 82, 83, 35,
- 84, 85, 86, 87, 88, 89, 0, 0, 0, 90,
- 91, 92, 93, 36, 0, 37, 38, 39, 40, 41,
- 42, 0, 0, 0, 0, 43, 44, 45, 46, 47,
- 48, 49, 1, 2, 3, 4, 5, 6, 0, 50,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 51, 52, 53, 0, 0, 0, 79, 0, 54,
- 55, 0, 0, 56, 94, 77, 448, 16, 0, 17,
- 18, 19, 20, 21, 22, 23, 80, 0, 0, 24,
- 25, 26, 27, 28, 0, 29, 30, 31, 32, 33,
- 34, 81, 99, 82, 83, 35, 84, 85, 86, 87,
- 88, 89, 0, 0, 0, 90, 91, 92, 93, 36,
- 0, 37, 38, 39, 40, 41, 42, 0, 0, 0,
- 0, 43, 44, 45, 46, 47, 48, 49, 0, 0,
- 0, 0, 0, 0, 0, 50, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 51, 52, 53,
- 0, 0, 0, 79, 0, 54, 55, 0, 0, 56,
- 94, 77, 457, 16, 0, 17, 18, 19, 20, 21,
- 22, 23, 80, 0, 0, 24, 25, 26, 27, 28,
- 0, 29, 30, 31, 32, 33, 34, 81, 99, 82,
- 83, 35, 84, 85, 86, 87, 88, 89, 0, 0,
- 0, 90, 91, 92, 93, 36, 0, 37, 38, 39,
- 40, 41, 42, 0, 0, 0, 0, 43, 44, 45,
- 46, 47, 48, 49, 0, 0, 0, 0, 0, 0,
- 0, 50, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 51, 52, 53, 0, 0, 0, 79,
- 0, 54, 55, 0, 0, 56, 94, 77, 461, 16,
- 0, 17, 18, 19, 20, 21, 22, 23, 80, 0,
- 0, 24, 25, 26, 27, 28, 0, 29, 30, 31,
- 32, 33, 34, 81, 99, 82, 83, 35, 84, 85,
- 86, 87, 88, 89, 0, 0, 0, 90, 91, 92,
- 93, 36, 0, 37, 38, 39, 40, 41, 42, 0,
- 0, 0, 0, 43, 44, 45, 46, 47, 48, 49,
- 0, 0, 0, 0, 0, 0, 0, 50, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 51,
- 52, 53, 0, 0, 0, 79, 0, 54, 55, 0,
- 0, 56, 94, 77, 0, 16, 0, 17, 18, 19,
- 20, 21, 22, 23, 80, 0, 0, 24, 25, 26,
- 27, 28, 0, 29, 30, 31, 32, 33, 34, 81,
- 99, 82, 83, 35, 84, 85, 86, 87, 88, 89,
- 0, 0, 0, 90, 91, 92, 93, 36, 0, 37,
- 38, 39, 40, 41, 42, 0, 0, 0, 0, 43,
- 44, 45, 46, 47, 48, 49, 0, 0, 473, 0,
- 0, 0, 0, 50, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 51, 52, 53, 0, 0,
- 0, 79, 0, 54, 55, 0, 0, 56, 94, 77,
- 0, 16, 0, 17, 18, 19, 20, 21, 22, 23,
- 80, 0, 0, 24, 25, 26, 27, 28, 0, 29,
- 30, 31, 32, 33, 34, 81, 99, 82, 83, 35,
- 84, 85, 86, 87, 88, 89, 0, 0, 0, 90,
- 91, 92, 93, 36, 0, 37, 38, 39, 40, 41,
- 42, 0, 0, 0, 0, 43, 44, 45, 46, 47,
- 48, 49, 0, 0, 0, 0, 0, 0, 0, 50,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 51, 52, 53, 0, 0, 0, 79, 0, 54,
- 55, 0, 0, 56, 94, 77, 0, 16, 0, 17,
- 18, 19, 20, 21, 22, 23, 80, 0, 0, 24,
- 25, 26, 27, 28, 0, 29, 30, 31, 32, 33,
- 34, 81, 0, 82, 83, 35, 84, 85, 86, 87,
- 88, 89, 0, 0, 0, 90, 91, 92, 93, 36,
- 0, 37, 38, 39, 40, 41, 42, 0, 0, 0,
- 0, 43, 44, 45, 46, 47, 48, 49, 0, 0,
- 0, 0, 0, 0, 0, 50, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 51, 52, 53,
- 0, 79, 0, 0, 0, 54, 55, 0, 0, 56,
- 94, 16, 0, 17, 18, 19, 20, 21, 22, 23,
- -68, 0, 0, 24, 25, 26, 27, 28, 0, 29,
- 30, 31, 32, 33, 34, 0, 0, 0, 0, 35,
- 0, 0, -237, 0, 0, 0, 0, 0, 0, 168,
- 169, 170, 171, 36, 0, 37, 38, 39, 40, 41,
- 42, 0, 0, 0, 0, 43, 44, 45, 46, 47,
- 48, 49, 174, 175, 176, 177, 178, 179, 180, 50,
- 0, 0, 0, 181, 182, 183, 184, 0, 0, 185,
- 0, 51, 52, 53, 79, 0, 0, 0, 0, 54,
- 55, 170, 171, 56, 16, 0, 17, 18, 19, 20,
- 21, 22, 23, 0, 0, 0, 24, 25, 26, 27,
- 28, 0, 29, 30, 31, 32, 33, 34, 180, 0,
- 0, 0, 35, 181, 182, 183, 184, 0, 0, 185,
- 0, 0, 0, 0, 0, 0, 36, 0, 37, 38,
- 39, 40, 41, 42, 0, 0, -170, 0, 43, 44,
- 45, 46, 47, 48, 49, 187, 0, 188, -170, 0,
- 0, 0, 50, 0, 0, 0, -170, 0, 0, 0,
- 0, 0, 0, 0, 51, 52, 53, 168, 169, 170,
- 171, 0, 54, 55, 0, -68, 56, 0, -170, -170,
- -170, -170, 0, 0, 0, -170, 0, -170, 0, 0,
- -170, 0, 0, 177, 178, 179, 180, -170, -170, -170,
- -170, 181, 182, 183, 184, 0, 0, 185, 0, 0,
- 0, 0, -170, -170, -170, -209, -170, -170, -170, -170,
- -170, -170, -170, -170, -170, -170, -170, -209, 0, 0,
- 0, -170, -170, -170, -170, -209, 0, -170, -170, 0,
- 0, 0, 0, 0, 0, 0, 168, 169, 170, 171,
- 0, 0, 0, 0, 0, 0, 0, -209, -209, -209,
- -209, 0, 0, 0, -209, 0, -209, 0, 0, -209,
- 0, 0, 0, 178, 179, 180, -209, -209, -209, -209,
- 181, 182, 183, 184, 0, 0, 185, 0, 0, 0,
- 0, -209, -209, -209, 0, -209, -209, -209, -209, -209,
- -209, -209, -209, -209, -209, -209, 0, 0, 0, 0,
- -209, -209, -209, -209, 0, 0, -209, -209, 77, 0,
- 16, 0, 17, 18, 19, 20, 21, 22, 23, 0,
- 0, 0, 132, 25, 26, 27, 28, 110, 29, 30,
- 31, 32, 33, 34, 0, 0, 0, 0, 35, 0,
- 0, 0, 0, 0, 0, 168, -237, 170, 171, 0,
- 0, 0, 36, 0, 37, 38, 39, 40, 41, 42,
- 0, 0, 0, 0, 43, 44, 45, 46, 47, 48,
- 49, 0, 0, 179, 180, 0, 0, 0, 50, 181,
- 182, 183, 184, 0, 0, 185, 0, 0, 0, 0,
- 51, 52, 53, 0, 0, 0, 0, 0, 54, 55,
- 0, 77, 56, 16, 0, 17, 18, 19, 20, 21,
- 22, 23, 0, 0, 0, 24, 25, 26, 27, 28,
- 0, 29, 30, 31, 32, 33, 34, 0, 0, 0,
- 0, 35, 0, 0, 0, 0, 0, 0, 168, 169,
- 170, 171, 0, 0, 0, 36, 0, 37, 38, 39,
- 40, 41, 42, 0, 0, 0, 0, 43, 44, 45,
- 46, 47, 48, 49, 0, 0, 179, 180, 0, 0,
- 0, 50, 181, 182, 183, 184, 0, 0, 185, 0,
- 0, 0, 0, 51, 52, 53, 0, 0, 0, 0,
- 0, 54, 55, 0, 0, 56, 16, 105, 17, 18,
- 19, 20, 21, 22, 23, 0, 0, 0, 24, 25,
- 26, 27, 28, 0, 29, 30, 31, 32, 33, 34,
- 0, 0, 0, 0, 35, 0, 0, 0, 0, 0,
- 0, -237, 0, 170, 171, 0, 0, 0, 36, 0,
- 37, 38, 39, 40, 41, 42, 0, 0, 0, 0,
- 43, 44, 45, 46, 47, 48, 49, 0, 0, 179,
- 180, 0, 0, 0, 50, 181, 182, 183, 184, 0,
- 0, 185, 0, 0, 0, 0, 51, 52, 53, 0,
- 0, 0, 0, 0, 54, 55, 0, 16, 56, 17,
- 18, 19, 20, 21, 22, 23, 140, 0, 0, 24,
- 25, 26, 27, 28, 0, 29, 30, 31, 32, 33,
- 34, 0, 0, 0, 0, 35, 0, 0, 0, 0,
- 0, 0, 0, 0, 170, 171, 0, 0, 0, 36,
- 0, 37, 38, 39, 40, 41, 42, 0, 0, 0,
- 0, 43, 44, 45, 46, 47, 48, 49, 0, 0,
- 179, 180, 0, 0, 0, 50, 181, 182, 183, 184,
- 0, 0, 185, 0, 0, 0, 0, 51, 52, 53,
- 0, 0, 0, 0, 0, 54, 55, 0, 16, 56,
- 17, 18, 19, 20, 21, 22, 23, 0, 0, 0,
- 24, 25, 26, 27, 28, 0, 29, 30, 31, 32,
- 33, 34, 0, 0, 0, 0, 35, 0, 0, 0,
+ 80, 211, 76, 140, 213, 396, 111, 111, 111, 111,
+ 111, 159, 293, 111, 111, 105, 212, 308, 29, 179,
+ 313, 180, 201, 33, 202, 129, 275, 237, 276, 343,
+ 291, 3, 33, 377, 142, 111, 148, 296, 238, 277,
+ 155, 418, 132, 25, 33, 34, 35, 137, 327, 150,
+ 146, 113, 114, 115, 116, 393, 394, 117, 118, 140,
+ 166, 215, 218, 219, 220, 221, 222, 223, 96, 225,
+ 226, 127, 175, 176, 177, 175, 176, 177, 143, 144,
+ 408, 26, 27, 328, 206, 233, 338, 106, 107, -2,
+ 210, -186, -186, 140, 340, 199, 175, 176, 177, 98,
+ 100, 120, 128, 29, 181, 358, 359, 235, 216, 142,
+ 217, 278, 133, 5, 6, 7, 138, 8, 9, 147,
+ 229, 230, 152, 153, 158, 178, 160, 161, 162, 163,
+ 164, 337, 119, 371, 201, 364, 202, 123, 240, 175,
+ 176, 177, 175, 176, 177, 124, 294, 10, 339, 381,
+ 175, 176, 177, 232, 245, 246, 248, 249, 250, 251,
+ 252, 253, 254, 311, 256, 257, 259, 125, 151, 175,
+ 176, 177, 280, 369, 175, 176, 177, 346, 11, 175,
+ 176, 177, 349, 126, 130, 282, 283, 284, 285, 286,
+ 287, 175, 176, 177, 244, 305, 175, 176, 177, 230,
+ 411, 292, 131, 298, 248, 203, 248, 204, 310, 387,
+ 175, 176, 177, 196, 197, 198, 134, 317, 199, 319,
+ 321, 5, 6, 7, 341, 8, 9, 135, 325, 175,
+ 176, 177, 140, 136, 255, 314, 167, 140, 260, 261,
+ 262, 263, 264, 265, 266, 267, 268, 269, 270, 271,
+ 272, 273, 274, 169, 178, 10, 175, 176, 177, 200,
+ 331, 332, 398, 334, 205, 175, 176, 177, 207, 209,
+ 402, 403, 175, 176, 177, 214, 344, 368, 344, 224,
+ 409, 323, 299, 350, 302, 227, 11, 412, 236, 234,
+ 404, 241, 28, 243, 29, 288, 30, 290, 31, 32,
+ 33, 34, 35, 36, 37, 38, 39, 40, 41, 42,
+ 43, 365, 44, 45, 46, 175, 176, 177, 47, 33,
+ 230, 48, 49, 50, 51, 175, 176, 177, 52, 53,
+ 54, 55, 56, 410, 57, 58, 59, 60, 61, 316,
+ 329, 322, 298, 62, 63, 64, 65, 66, 67, 324,
+ 68, 326, 335, 5, 6, 7, 69, 8, 9, 175,
+ 176, 177, 177, 342, 175, 176, 177, 348, 70, 71,
+ 72, 355, 351, 352, 353, 73, 74, 354, 357, 75,
+ 356, 175, 176, 177, 336, 315, 367, 10, 28, 361,
+ 360, 375, 30, 80, 31, 32, 33, 34, 35, 36,
+ 37, -43, 39, 40, 41, 42, 43, 366, 44, 45,
+ 46, 175, 176, 177, 47, 372, 373, 374, 11, 378,
+ 175, 176, 177, 183, 184, 185, 186, 384, 56, 385,
+ 57, 58, 59, 60, 61, 389, 362, 388, 397, 62,
+ 63, 64, 65, 66, 67, 363, 68, 191, 192, 193,
+ 194, 195, 69, 399, 406, 414, 196, 197, 198, 415,
+ 77, 199, 383, 413, 70, 71, 72, 122, 102, 347,
+ 28, 73, 74, 156, 30, 75, 31, 32, 33, 34,
+ 35, 36, 37, 0, 39, 40, 41, 42, 43, 157,
+ 44, 45, 46, 175, 176, 177, 47, 0, 170, 171,
+ 172, 173, 0, 0, 0, 174, 0, 185, 186, 0,
+ 56, 0, 57, 58, 59, 60, 61, 0, 370, 0,
+ 0, 62, 63, 64, 65, 66, 67, 0, 68, 0,
+ 175, 176, 177, 195, 69, 0, 0, 0, 196, 197,
+ 198, 0, 0, 199, 0, 0, 70, 71, 72, 0,
+ 0, 0, 0, 73, 74, -48, -43, 75, 29, 0,
+ 30, 0, 31, 32, 33, 34, 35, 36, 37, 0,
+ 139, 40, 41, 42, 43, 109, 44, 45, 46, 195,
+ 0, 0, 47, 0, 196, 197, 198, 0, 0, 199,
+ 183, 184, 185, 186, 0, 0, 56, 0, 57, 58,
+ 59, 60, 61, 0, 0, 0, 0, 62, 63, 64,
+ 65, 66, 67, 0, 68, 192, 193, 194, 195, 0,
+ 69, 0, 0, 196, 197, 198, 0, 0, 199, 0,
+ 0, 0, 70, 71, 72, 0, 0, 0, 0, 73,
+ 74, 0, 29, 75, 30, 0, 31, 32, 33, 34,
+ 35, 36, 37, 29, 39, 40, 41, 42, 43, 33,
+ 44, 45, 46, 0, 0, 108, 47, 0, 0, 0,
+ 109, 0, 0, 183, 184, 185, 186, 0, 0, 0,
+ 56, 0, 57, 58, 59, 60, 61, 0, 0, 0,
+ 0, 62, 63, 64, 65, 66, 67, 0, 68, 193,
+ 194, 195, 0, 0, 69, 0, 196, 197, 198, 0,
+ 0, 199, 0, 0, 0, 0, 70, 71, 72, 0,
+ 0, 185, 0, 73, 74, 0, 29, 75, 30, 0,
+ 31, 32, 33, 34, 35, 36, 37, 0, 145, 40,
+ 41, 42, 43, 0, 44, 45, 46, 195, 0, 0,
+ 47, 0, 196, 197, 198, 0, 0, 199, 183, -186,
+ 185, 186, 0, 0, 56, 0, 57, 58, 59, 60,
+ 61, 0, 0, 0, 0, 62, 63, 64, 65, 66,
+ 67, 0, 68, 0, 0, 194, 195, 201, 69, 202,
+ -156, 196, 197, 198, 0, 0, 199, 0, -156, 0,
+ 70, 71, 72, 183, 184, 185, 186, 73, 74, 0,
+ 0, 75, 0, 0, -156, -156, -156, -156, 0, 0,
+ 0, -156, 0, 0, 0, 0, -156, 0, 0, 0,
+ 194, 195, -156, -156, -156, -156, 196, 197, 198, 0,
+ 0, 199, 0, 0, 0, 0, -156, -156, -156, 0,
+ -156, -156, -156, -156, -156, -156, -156, -156, -156, -156,
+ -156, 0, 0, 0, 0, -156, -156, -156, 0, 0,
+ -156, -156, 30, 104, 31, 32, 33, 34, 35, 36,
+ 37, 0, 39, 40, 41, 42, 43, 0, 44, 45,
+ 46, 0, 0, 0, 47, 0, 0, 0, 0, 0,
+ -186, 0, 185, 186, 0, 0, 0, 0, 56, 0,
+ 57, 58, 59, 60, 61, 0, 0, 0, 0, 62,
+ 63, 64, 65, 66, 67, 0, 68, 194, 195, 0,
+ 0, 0, 69, 196, 197, 198, 0, 0, 199, 0,
+ 0, 0, 0, 0, 70, 71, 72, 0, 185, 186,
+ 0, 73, 74, 0, 30, 75, 31, 32, 33, 34,
+ 35, 36, 37, 149, 39, 40, 41, 42, 43, 0,
+ 44, 45, 46, 194, 195, 0, 47, 0, 0, 196,
+ 197, 198, 0, 0, 199, 0, 0, 0, 0, 0,
+ 56, 0, 57, 58, 59, 60, 61, 0, 0, 0,
+ 0, 62, 63, 64, 65, 66, 67, 0, 68, 0,
+ 0, 0, 0, 0, 69, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 70, 71, 72, 0,
+ 0, 0, 0, 73, 74, 0, 30, 75, 31, 32,
+ 33, 34, 35, 36, 37, 0, 39, 40, 41, 42,
+ 43, 0, 44, 45, 46, 0, 0, 0, 47, 170,
+ 171, 172, 173, 0, 0, 0, 174, 0, 0, 0,
+ 0, 0, 56, 0, 57, 58, 59, 60, 61, 0,
+ 0, 0, 0, 62, 63, 64, 65, 66, 67, 0,
+ 68, 175, 176, 177, 0, 0, 69, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 70, 71,
+ 72, 0, 0, 0, 0, 73, 74, 0, 165, 75,
+ 30, 0, 31, 32, 33, 34, 35, 36, 37, 0,
+ 39, 40, 41, 42, 43, 0, 44, 45, 46, 0,
+ 0, 0, 47, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 56, 0, 57, 58,
+ 59, 60, 61, 0, 0, 0, 0, 62, 63, 64,
+ 65, 66, 67, 0, 68, 0, 0, 0, 0, 0,
+ 69, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 70, 71, 72, 0, 0, 0, 0, 73,
+ 74, 0, 228, 75, 30, 0, 31, 32, 33, 34,
+ 35, 36, 37, 0, 39, 40, 41, 42, 43, 0,
+ 44, 45, 46, 0, 0, 0, 47, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 36, 0, 37, 38, 39, 40, 41, 42, 0, 0,
- 0, 0, 43, 44, 45, 46, 47, 48, 49, 0,
- 0, 0, 0, 0, 0, 0, 50, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 51, 52,
- 53, 0, 0, 0, 0, 0, 54, 55, 0, 158,
- 56, 16, 0, 17, 18, 19, 20, 21, 22, 23,
- 0, 0, 0, 24, 25, 26, 27, 28, 0, 29,
- 30, 31, 32, 33, 34, 0, 0, 0, 0, 35,
+ 56, 0, 57, 58, 59, 60, 61, 0, 0, 0,
+ 0, 62, 63, 64, 65, 66, 67, 0, 68, 0,
+ 0, 0, 0, 0, 69, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 70, 71, 72, 0,
+ 0, 0, 0, 73, 74, 0, 239, 75, 30, 0,
+ 31, 32, 33, 34, 35, 36, 37, 0, 39, 40,
+ 41, 42, 43, 0, 44, 45, 46, 0, 0, 0,
+ 47, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 56, 0, 57, 58, 59, 60,
+ 61, 0, 0, 0, 0, 62, 63, 64, 65, 66,
+ 67, 0, 68, 0, 0, 0, 0, 0, 69, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 36, 0, 37, 38, 39, 40, 41,
- 42, 0, 0, 0, 0, 43, 44, 45, 46, 47,
- 48, 49, 0, 0, 0, 0, 0, 0, 0, 50,
+ 70, 71, 72, 0, 0, 0, 0, 73, 74, 0,
+ 258, 75, 30, 0, 31, 32, 33, 34, 35, 36,
+ 37, 0, 39, 40, 41, 42, 43, 0, 44, 45,
+ 46, 0, 0, 0, 47, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 56, 0,
+ 57, 58, 59, 60, 61, 0, 0, 0, 0, 62,
+ 63, 64, 65, 66, 67, 0, 68, 0, 0, 0,
+ 0, 0, 69, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 70, 71, 72, 0, 0, 0,
+ 0, 73, 74, 0, 281, 75, 30, 0, 31, 32,
+ 33, 34, 35, 36, 37, 0, 39, 40, 41, 42,
+ 43, 0, 44, 45, 46, 0, 0, 0, 47, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 51, 52, 53, 0, 0, 0, 0, 0, 54,
- 55, 0, 231, 56, 16, 0, 17, 18, 19, 20,
- 21, 22, 23, 0, 0, 0, 24, 25, 26, 27,
- 28, 0, 29, 30, 31, 32, 33, 34, 0, 0,
- 0, 0, 35, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 36, 0, 37, 38,
- 39, 40, 41, 42, 0, 0, 0, 0, 43, 44,
- 45, 46, 47, 48, 49, 0, 0, 0, 0, 0,
- 0, 0, 50, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 51, 52, 53, 0, 0, 0,
- 0, 0, 54, 55, 0, 239, 56, 16, 0, 17,
- 18, 19, 20, 21, 22, 23, 0, 0, 0, 24,
- 25, 26, 27, 28, 0, 29, 30, 31, 32, 33,
- 34, 0, 0, 0, 0, 35, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 36,
- 0, 37, 38, 39, 40, 41, 42, 0, 0, 0,
- 0, 43, 44, 45, 46, 47, 48, 49, 0, 0,
- 0, 0, 0, 0, 0, 50, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 51, 52, 53,
- 0, 0, 0, 0, 0, 54, 55, 0, 251, 56,
- 16, 0, 17, 18, 19, 20, 21, 22, 23, 0,
- 0, 0, 24, 25, 26, 27, 28, 0, 29, 30,
- 31, 32, 33, 34, 0, 0, 0, 0, 35, 0,
+ 0, 0, 56, 0, 57, 58, 59, 60, 61, 0,
+ 0, 0, 0, 62, 63, 64, 65, 66, 67, 0,
+ 68, 0, 0, 0, 0, 0, 69, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 70, 71,
+ 72, 0, 0, 0, 0, 73, 74, 0, 318, 75,
+ 30, 0, 31, 32, 33, 34, 35, 36, 37, 0,
+ 39, 40, 41, 42, 43, 0, 44, 45, 46, 0,
+ 0, 0, 47, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 56, 0, 57, 58,
+ 59, 60, 61, 0, 0, 0, 0, 62, 63, 64,
+ 65, 66, 67, 0, 68, 0, 0, 0, 0, 0,
+ 69, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 70, 71, 72, 0, 0, 0, 0, 73,
+ 74, 0, 320, 75, 30, 0, 31, 32, 33, 34,
+ 35, 36, 37, 0, 39, 40, 41, 42, 43, 0,
+ 44, 45, 46, 0, 0, 0, 47, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 36, 0, 37, 38, 39, 40, 41, 42,
- 0, 0, 0, 0, 43, 44, 45, 46, 47, 48,
- 49, 0, 0, 0, 0, 0, 0, 0, 50, 0,
+ 56, 0, 57, 58, 59, 60, 61, 0, 0, 0,
+ 0, 62, 63, 64, 65, 66, 67, 0, 68, 0,
+ 0, 0, 0, 0, 69, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 70, 71, 72, 0,
+ 0, 0, 0, 73, 74, 0, 333, 75, 30, 0,
+ 31, 32, 33, 34, 35, 36, 37, 0, 39, 40,
+ 41, 42, 43, 0, 44, 45, 46, 0, 0, 0,
+ 47, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 56, 0, 57, 58, 59, 60,
+ 61, 0, 0, 0, 0, 62, 63, 64, 65, 66,
+ 67, 0, 68, 0, 0, 0, 0, 0, 69, -185,
+ 0, 0, 0, 0, 0, 0, 0, -185, 0, 0,
+ 70, 71, 72, 0, 0, 0, 0, 73, 74, 0,
+ 0, 75, 0, -185, -185, -185, -185, 0, 0, 0,
+ -185, 0, 0, 0, 0, -185, 0, 0, 0, 0,
+ 0, -185, -185, -185, -185, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, -185, -185, -185, 0, -185,
+ -185, -185, -185, -185, -185, -185, -185, -185, -185, -185,
+ 0, 380, 0, 382, -185, -185, -185, 386, 0, -185,
+ -185, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 390, 391, 0, 0, 0, 0, 0,
+ 0, 400, 401, 0, 0, 0, 0, 0, 0, 182,
+ 405, 0, 0, 0, 407, 183, 184, 185, 186, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 51, 52, 53, 0, 0, 0, 0, 0, 54, 55,
- 0, 280, 56, 16, 0, 17, 18, 19, 20, 21,
- 22, 23, 0, 0, 0, 24, 25, 26, 27, 28,
- 0, 29, 30, 31, 32, 33, 34, 0, 0, 0,
- 0, 35, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 36, 0, 37, 38, 39,
- 40, 41, 42, 0, 0, 0, 0, 43, 44, 45,
- 46, 47, 48, 49, 0, 0, 0, 0, 0, 0,
- 0, 50, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 51, 52, 53, 0, 0, 0, 0,
- 0, 54, 55, 0, 338, 56, 16, 0, 17, 18,
- 19, 20, 21, 22, 23, 0, 0, 0, 24, 25,
- 26, 27, 28, 0, 29, 30, 31, 32, 33, 34,
- 0, 0, 0, 0, 35, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 36, 0,
- 37, 38, 39, 40, 41, 42, 0, 0, 0, 0,
- 43, 44, 45, 46, 47, 48, 49, 0, 0, 167,
- 0, 0, 0, 0, 50, 0, 168, 169, 170, 171,
- 0, 0, 0, 0, 0, 0, 51, 52, 53, 0,
- 0, 0, 0, 0, 54, 55, 172, 173, 56, 174,
- 175, 176, 177, 178, 179, 180, 0, 0, 0, 0,
- 181, 182, 183, 184, 167, 0, 185, 0, 0, 0,
- 0, 168, 169, 170, 171, 0, 0, 0, 0, 0,
+ 0, 416, 417, 0, 187, 188, 330, 189, 190, 191,
+ 192, 193, 194, 195, 0, 0, 0, 0, 196, 197,
+ 198, 182, 0, 199, 0, 0, 0, 183, 184, 185,
+ 186, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 187, 188, 0, 189,
+ 190, 191, 192, 193, 194, 195, 0, 0, 0, 0,
+ 196, 197, 198, 182, 0, 199, 0, 0, 0, 183,
+ 184, 185, 186, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 188,
+ 0, 189, 190, 191, 192, 193, 194, 195, 0, 0,
+ 0, 0, 196, 197, 198, -186, 0, 199, 0, 0,
+ 0, 183, 184, 185, 186, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 173, 0, 174, 175, 176, 177, 178, 179,
- 180, 0, 0, 0, 0, 181, 182, 183, 184, 0,
- 0, 185
+ 0, 0, 0, 189, 190, 191, 192, 193, 194, 195,
+ 0, 0, 0, 0, 196, 197, 198, 0, 0, 199
};
-#define yypact_value_is_default(yystate) \
- ((yystate) == (-401))
-
-#define yytable_value_is_error(yytable_value) \
- ((yytable_value) == (-237))
-
static const yytype_int16 yycheck[] =
{
- 10, 11, 12, 15, 15, 300, 9, 118, 129, 42,
- 9, 12, 11, 16, 80, 0, 397, 50, 11, 419,
- 300, 9, 302, 303, 11, 15, 16, 17, 9, 20,
- 8, 41, 20, 144, 44, 26, 102, 19, 20, 21,
- 22, 23, 45, 25, 26, 20, 21, 22, 23, 23,
- 25, 26, 103, 56, 28, 76, 77, 78, 103, 70,
- 42, 43, 443, 9, 103, 11, 48, 42, 43, 46,
- 47, 471, 9, 12, 11, 76, 77, 78, 15, 16,
- 17, 18, 19, 93, 12, 118, 103, 24, 20, 99,
- 370, 80, 103, 103, 104, 20, 103, 17, 18, 77,
- 9, 9, 223, 136, 103, 12, 99, 296, 90, 298,
- 12, 144, 32, 103, 124, 12, 36, 9, 121, 11,
- 400, 41, 23, 103, 44, 128, 129, 47, 65, 49,
- 12, 51, 52, 53, 54, 55, 12, 76, 77, 78,
- 9, 12, 11, 146, 76, 77, 78, 129, 76, 77,
- 78, 76, 77, 78, 129, 103, 103, 160, 161, 162,
- 455, 164, 165, 166, 48, 9, 103, 11, 103, 76,
- 77, 78, 103, 453, 76, 77, 78, 20, 20, 76,
- 77, 78, 194, 186, 187, 188, 189, 190, 191, 192,
- 193, 224, 103, 103, 76, 77, 78, 103, 102, 209,
- 76, 77, 78, 185, 315, 76, 77, 78, 26, 212,
- 213, 214, 215, 216, 217, 76, 77, 78, 10, 340,
- 223, 199, 200, 201, 202, 203, 204, 102, 206, 207,
- 9, 234, 11, 76, 77, 78, 76, 77, 78, 72,
- 243, 102, 11, 163, 103, 23, 23, 167, 168, 169,
- 170, 171, 172, 173, 174, 175, 176, 177, 178, 179,
- 180, 181, 102, 72, 102, 268, 269, 10, 20, 42,
- 43, 44, 45, 26, 277, 20, 49, 78, 51, 289,
- 11, 103, 315, 20, 395, 18, 20, 23, 270, 76,
- 77, 78, 295, 296, 297, 298, 399, 300, 401, 302,
- 303, 404, 405, 76, 77, 78, 18, 18, 18, 76,
- 77, 78, 415, 416, 18, 102, 15, 299, 21, 102,
- 423, 10, 325, 301, 76, 77, 78, 10, 26, 102,
- 10, 76, 77, 78, 437, 102, 63, 340, 441, 76,
- 77, 78, 76, 77, 78, 95, 96, 97, 98, 54,
- 10, 101, 23, 10, 102, 102, 61, 62, 63, 64,
- 102, 102, 395, 90, 103, 468, 469, 370, 95, 96,
- 97, 98, 350, 102, 101, 353, 81, 82, 83, 84,
- 85, 86, 87, 88, 89, 90, 20, 102, 9, 102,
- 95, 96, 97, 98, 15, 103, 101, 400, 10, 402,
- 102, 413, 23, 61, 62, 63, 64, 28, 9, 329,
- 42, 43, 44, 45, 20, 427, 102, 49, 9, 51,
- 74, 20, 432, 20, 436, 76, 77, 78, 86, 87,
- 88, 89, 90, 102, 20, 102, 446, 95, 96, 97,
- 98, 451, 103, 101, 76, 77, 78, 22, 0, 1,
- 453, 102, 102, 73, 466, 102, 12, 9, 99, 11,
- 470, 13, 14, 15, 16, 17, 18, 19, 20, 402,
- 196, 23, 24, 25, 26, 27, 455, 29, 30, 31,
- 32, 33, 34, 35, 36, 37, 38, 39, 40, 41,
- 42, 43, 44, 45, 76, 77, 78, 49, 50, 51,
- 52, 53, 35, 55, 56, 57, 58, 59, 60, 421,
- 76, 77, 78, 65, 66, 67, 68, 69, 70, 71,
- 102, 83, 434, 435, 9, 352, 393, 79, 48, 412,
- 15, 48, 444, 18, -1, -1, 102, -1, 23, 91,
- 92, 93, 454, 28, 0, 1, -1, 99, 100, -1,
- -1, 103, 104, 9, -1, 11, -1, 13, 14, 15,
- 16, 17, 18, 19, 20, -1, -1, 23, 24, 25,
- 26, 27, -1, 29, 30, 31, 32, 33, 34, 35,
- 36, 37, 38, 39, 40, 41, 42, 43, 44, 45,
- -1, -1, -1, 49, 50, 51, 52, 53, -1, 55,
- 56, 57, 58, 59, 60, -1, -1, -1, -1, 65,
- 66, 67, 68, 69, 70, 71, 96, 97, 98, 90,
- -1, 101, -1, 79, 95, 96, 97, 98, -1, -1,
- 101, -1, -1, -1, -1, 91, 92, 93, -1, -1,
- -1, 1, -1, 99, 100, -1, -1, 103, 104, 9,
- 10, 11, -1, 13, 14, 15, 16, 17, 18, 19,
- 20, -1, -1, 23, 24, 25, 26, 27, -1, 29,
- 30, 31, 32, 33, 34, 35, 36, 37, 38, 39,
- 40, 41, 42, 43, 44, 45, -1, -1, -1, 49,
- 50, 51, 52, 53, -1, 55, 56, 57, 58, 59,
- 60, -1, -1, -1, -1, 65, 66, 67, 68, 69,
- 70, 71, 3, 4, 5, 6, 7, 8, -1, 79,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, 91, 92, 93, -1, -1, -1, 1, -1, 99,
- 100, -1, -1, 103, 104, 9, 10, 11, -1, 13,
- 14, 15, 16, 17, 18, 19, 20, -1, -1, 23,
- 24, 25, 26, 27, -1, 29, 30, 31, 32, 33,
- 34, 35, 36, 37, 38, 39, 40, 41, 42, 43,
- 44, 45, -1, -1, -1, 49, 50, 51, 52, 53,
- -1, 55, 56, 57, 58, 59, 60, -1, -1, -1,
- -1, 65, 66, 67, 68, 69, 70, 71, -1, -1,
- -1, -1, -1, -1, -1, 79, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, 91, 92, 93,
- -1, -1, -1, 1, -1, 99, 100, -1, -1, 103,
- 104, 9, 10, 11, -1, 13, 14, 15, 16, 17,
- 18, 19, 20, -1, -1, 23, 24, 25, 26, 27,
- -1, 29, 30, 31, 32, 33, 34, 35, 36, 37,
- 38, 39, 40, 41, 42, 43, 44, 45, -1, -1,
- -1, 49, 50, 51, 52, 53, -1, 55, 56, 57,
- 58, 59, 60, -1, -1, -1, -1, 65, 66, 67,
- 68, 69, 70, 71, -1, -1, -1, -1, -1, -1,
- -1, 79, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, 91, 92, 93, -1, -1, -1, 1,
- -1, 99, 100, -1, -1, 103, 104, 9, 10, 11,
- -1, 13, 14, 15, 16, 17, 18, 19, 20, -1,
- -1, 23, 24, 25, 26, 27, -1, 29, 30, 31,
- 32, 33, 34, 35, 36, 37, 38, 39, 40, 41,
- 42, 43, 44, 45, -1, -1, -1, 49, 50, 51,
- 52, 53, -1, 55, 56, 57, 58, 59, 60, -1,
- -1, -1, -1, 65, 66, 67, 68, 69, 70, 71,
- -1, -1, -1, -1, -1, -1, -1, 79, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, 91,
- 92, 93, -1, -1, -1, 1, -1, 99, 100, -1,
- -1, 103, 104, 9, -1, 11, -1, 13, 14, 15,
- 16, 17, 18, 19, 20, -1, -1, 23, 24, 25,
- 26, 27, -1, 29, 30, 31, 32, 33, 34, 35,
- 36, 37, 38, 39, 40, 41, 42, 43, 44, 45,
- -1, -1, -1, 49, 50, 51, 52, 53, -1, 55,
- 56, 57, 58, 59, 60, -1, -1, -1, -1, 65,
- 66, 67, 68, 69, 70, 71, -1, -1, 74, -1,
- -1, -1, -1, 79, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 91, 92, 93, -1, -1,
- -1, 1, -1, 99, 100, -1, -1, 103, 104, 9,
- -1, 11, -1, 13, 14, 15, 16, 17, 18, 19,
- 20, -1, -1, 23, 24, 25, 26, 27, -1, 29,
- 30, 31, 32, 33, 34, 35, 36, 37, 38, 39,
- 40, 41, 42, 43, 44, 45, -1, -1, -1, 49,
- 50, 51, 52, 53, -1, 55, 56, 57, 58, 59,
- 60, -1, -1, -1, -1, 65, 66, 67, 68, 69,
- 70, 71, -1, -1, -1, -1, -1, -1, -1, 79,
+ 15, 103, 15, 61, 117, 380, 33, 34, 35, 36,
+ 37, 69, 214, 40, 41, 30, 6, 223, 3, 3,
+ 226, 5, 3, 9, 5, 52, 3, 14, 5, 14,
+ 210, 0, 9, 352, 61, 62, 63, 217, 151, 16,
+ 67, 416, 55, 15, 9, 10, 11, 60, 14, 64,
+ 63, 34, 35, 36, 37, 34, 35, 40, 41, 117,
+ 75, 119, 123, 124, 125, 126, 127, 128, 15, 130,
+ 131, 57, 62, 63, 64, 62, 63, 64, 61, 62,
+ 399, 9, 10, 6, 97, 143, 6, 31, 32, 0,
+ 102, 82, 83, 151, 6, 86, 62, 63, 64, 15,
+ 14, 45, 88, 3, 88, 311, 312, 88, 121, 136,
+ 122, 88, 56, 24, 25, 26, 60, 28, 29, 63,
+ 135, 136, 66, 88, 68, 66, 70, 71, 72, 73,
+ 74, 14, 88, 335, 3, 6, 5, 88, 153, 62,
+ 63, 64, 62, 63, 64, 88, 87, 58, 14, 355,
+ 62, 63, 64, 136, 167, 170, 171, 172, 173, 174,
+ 175, 176, 177, 224, 179, 180, 181, 88, 15, 62,
+ 63, 64, 199, 6, 62, 63, 64, 290, 89, 62,
+ 63, 64, 295, 88, 88, 200, 201, 202, 203, 204,
+ 205, 62, 63, 64, 87, 222, 62, 63, 64, 214,
+ 406, 4, 88, 218, 219, 3, 221, 5, 223, 6,
+ 62, 63, 64, 81, 82, 83, 88, 232, 86, 234,
+ 235, 24, 25, 26, 14, 28, 29, 88, 243, 62,
+ 63, 64, 290, 88, 178, 87, 36, 295, 182, 183,
+ 184, 185, 186, 187, 188, 189, 190, 191, 192, 193,
+ 194, 195, 196, 14, 66, 58, 62, 63, 64, 88,
+ 275, 276, 382, 278, 3, 62, 63, 64, 18, 15,
+ 390, 391, 62, 63, 64, 88, 289, 14, 291, 88,
+ 400, 87, 219, 296, 221, 87, 89, 407, 4, 88,
+ 392, 60, 1, 5, 3, 60, 5, 15, 7, 8,
+ 9, 10, 11, 12, 13, 14, 15, 16, 17, 18,
+ 19, 326, 21, 22, 23, 62, 63, 64, 27, 9,
+ 335, 30, 31, 32, 33, 62, 63, 64, 37, 38,
+ 39, 40, 41, 4, 43, 44, 45, 46, 47, 87,
+ 87, 4, 357, 52, 53, 54, 55, 56, 57, 18,
+ 59, 5, 88, 24, 25, 26, 65, 28, 29, 62,
+ 63, 64, 64, 18, 62, 63, 64, 87, 77, 78,
+ 79, 88, 87, 87, 87, 84, 85, 87, 14, 88,
+ 87, 62, 63, 64, 87, 66, 330, 58, 1, 87,
+ 87, 14, 5, 408, 7, 8, 9, 10, 11, 12,
+ 13, 14, 15, 16, 17, 18, 19, 4, 21, 22,
+ 23, 62, 63, 64, 27, 4, 4, 4, 89, 3,
+ 62, 63, 64, 48, 49, 50, 51, 87, 41, 87,
+ 43, 44, 45, 46, 47, 87, 87, 4, 87, 52,
+ 53, 54, 55, 56, 57, 87, 59, 72, 73, 74,
+ 75, 76, 65, 14, 88, 87, 81, 82, 83, 87,
+ 15, 86, 357, 408, 77, 78, 79, 47, 27, 291,
+ 1, 84, 85, 67, 5, 88, 7, 8, 9, 10,
+ 11, 12, 13, -1, 15, 16, 17, 18, 19, 67,
+ 21, 22, 23, 62, 63, 64, 27, -1, 30, 31,
+ 32, 33, -1, -1, -1, 37, -1, 50, 51, -1,
+ 41, -1, 43, 44, 45, 46, 47, -1, 87, -1,
+ -1, 52, 53, 54, 55, 56, 57, -1, 59, -1,
+ 62, 63, 64, 76, 65, -1, -1, -1, 81, 82,
+ 83, -1, -1, 86, -1, -1, 77, 78, 79, -1,
+ -1, -1, -1, 84, 85, 87, 87, 88, 3, -1,
+ 5, -1, 7, 8, 9, 10, 11, 12, 13, -1,
+ 15, 16, 17, 18, 19, 20, 21, 22, 23, 76,
+ -1, -1, 27, -1, 81, 82, 83, -1, -1, 86,
+ 48, 49, 50, 51, -1, -1, 41, -1, 43, 44,
+ 45, 46, 47, -1, -1, -1, -1, 52, 53, 54,
+ 55, 56, 57, -1, 59, 73, 74, 75, 76, -1,
+ 65, -1, -1, 81, 82, 83, -1, -1, 86, -1,
+ -1, -1, 77, 78, 79, -1, -1, -1, -1, 84,
+ 85, -1, 3, 88, 5, -1, 7, 8, 9, 10,
+ 11, 12, 13, 3, 15, 16, 17, 18, 19, 9,
+ 21, 22, 23, -1, -1, 15, 27, -1, -1, -1,
+ 20, -1, -1, 48, 49, 50, 51, -1, -1, -1,
+ 41, -1, 43, 44, 45, 46, 47, -1, -1, -1,
+ -1, 52, 53, 54, 55, 56, 57, -1, 59, 74,
+ 75, 76, -1, -1, 65, -1, 81, 82, 83, -1,
+ -1, 86, -1, -1, -1, -1, 77, 78, 79, -1,
+ -1, 50, -1, 84, 85, -1, 3, 88, 5, -1,
+ 7, 8, 9, 10, 11, 12, 13, -1, 15, 16,
+ 17, 18, 19, -1, 21, 22, 23, 76, -1, -1,
+ 27, -1, 81, 82, 83, -1, -1, 86, 48, 49,
+ 50, 51, -1, -1, 41, -1, 43, 44, 45, 46,
+ 47, -1, -1, -1, -1, 52, 53, 54, 55, 56,
+ 57, -1, 59, -1, -1, 75, 76, 3, 65, 5,
+ 6, 81, 82, 83, -1, -1, 86, -1, 14, -1,
+ 77, 78, 79, 48, 49, 50, 51, 84, 85, -1,
+ -1, 88, -1, -1, 30, 31, 32, 33, -1, -1,
+ -1, 37, -1, -1, -1, -1, 42, -1, -1, -1,
+ 75, 76, 48, 49, 50, 51, 81, 82, 83, -1,
+ -1, 86, -1, -1, -1, -1, 62, 63, 64, -1,
+ 66, 67, 68, 69, 70, 71, 72, 73, 74, 75,
+ 76, -1, -1, -1, -1, 81, 82, 83, -1, -1,
+ 86, 87, 5, 6, 7, 8, 9, 10, 11, 12,
+ 13, -1, 15, 16, 17, 18, 19, -1, 21, 22,
+ 23, -1, -1, -1, 27, -1, -1, -1, -1, -1,
+ 48, -1, 50, 51, -1, -1, -1, -1, 41, -1,
+ 43, 44, 45, 46, 47, -1, -1, -1, -1, 52,
+ 53, 54, 55, 56, 57, -1, 59, 75, 76, -1,
+ -1, -1, 65, 81, 82, 83, -1, -1, 86, -1,
+ -1, -1, -1, -1, 77, 78, 79, -1, 50, 51,
+ -1, 84, 85, -1, 5, 88, 7, 8, 9, 10,
+ 11, 12, 13, 14, 15, 16, 17, 18, 19, -1,
+ 21, 22, 23, 75, 76, -1, 27, -1, -1, 81,
+ 82, 83, -1, -1, 86, -1, -1, -1, -1, -1,
+ 41, -1, 43, 44, 45, 46, 47, -1, -1, -1,
+ -1, 52, 53, 54, 55, 56, 57, -1, 59, -1,
+ -1, -1, -1, -1, 65, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 77, 78, 79, -1,
+ -1, -1, -1, 84, 85, -1, 5, 88, 7, 8,
+ 9, 10, 11, 12, 13, -1, 15, 16, 17, 18,
+ 19, -1, 21, 22, 23, -1, -1, -1, 27, 30,
+ 31, 32, 33, -1, -1, -1, 37, -1, -1, -1,
+ -1, -1, 41, -1, 43, 44, 45, 46, 47, -1,
+ -1, -1, -1, 52, 53, 54, 55, 56, 57, -1,
+ 59, 62, 63, 64, -1, -1, 65, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 77, 78,
+ 79, -1, -1, -1, -1, 84, 85, -1, 87, 88,
+ 5, -1, 7, 8, 9, 10, 11, 12, 13, -1,
+ 15, 16, 17, 18, 19, -1, 21, 22, 23, -1,
+ -1, -1, 27, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 41, -1, 43, 44,
+ 45, 46, 47, -1, -1, -1, -1, 52, 53, 54,
+ 55, 56, 57, -1, 59, -1, -1, -1, -1, -1,
+ 65, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, 77, 78, 79, -1, -1, -1, -1, 84,
+ 85, -1, 87, 88, 5, -1, 7, 8, 9, 10,
+ 11, 12, 13, -1, 15, 16, 17, 18, 19, -1,
+ 21, 22, 23, -1, -1, -1, 27, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, 91, 92, 93, -1, -1, -1, 1, -1, 99,
- 100, -1, -1, 103, 104, 9, -1, 11, -1, 13,
- 14, 15, 16, 17, 18, 19, 20, -1, -1, 23,
- 24, 25, 26, 27, -1, 29, 30, 31, 32, 33,
- 34, 35, -1, 37, 38, 39, 40, 41, 42, 43,
- 44, 45, -1, -1, -1, 49, 50, 51, 52, 53,
- -1, 55, 56, 57, 58, 59, 60, -1, -1, -1,
- -1, 65, 66, 67, 68, 69, 70, 71, -1, -1,
- -1, -1, -1, -1, -1, 79, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, 91, 92, 93,
- -1, 1, -1, -1, -1, 99, 100, -1, -1, 103,
- 104, 11, -1, 13, 14, 15, 16, 17, 18, 19,
- 20, -1, -1, 23, 24, 25, 26, 27, -1, 29,
- 30, 31, 32, 33, 34, -1, -1, -1, -1, 39,
- -1, -1, 54, -1, -1, -1, -1, -1, -1, 61,
- 62, 63, 64, 53, -1, 55, 56, 57, 58, 59,
- 60, -1, -1, -1, -1, 65, 66, 67, 68, 69,
- 70, 71, 84, 85, 86, 87, 88, 89, 90, 79,
- -1, -1, -1, 95, 96, 97, 98, -1, -1, 101,
- -1, 91, 92, 93, 1, -1, -1, -1, -1, 99,
- 100, 63, 64, 103, 11, -1, 13, 14, 15, 16,
- 17, 18, 19, -1, -1, -1, 23, 24, 25, 26,
- 27, -1, 29, 30, 31, 32, 33, 34, 90, -1,
- -1, -1, 39, 95, 96, 97, 98, -1, -1, 101,
- -1, -1, -1, -1, -1, -1, 53, -1, 55, 56,
- 57, 58, 59, 60, -1, -1, 0, -1, 65, 66,
- 67, 68, 69, 70, 71, 9, -1, 11, 12, -1,
- -1, -1, 79, -1, -1, -1, 20, -1, -1, -1,
- -1, -1, -1, -1, 91, 92, 93, 61, 62, 63,
- 64, -1, 99, 100, -1, 102, 103, -1, 42, 43,
- 44, 45, -1, -1, -1, 49, -1, 51, -1, -1,
- 54, -1, -1, 87, 88, 89, 90, 61, 62, 63,
- 64, 95, 96, 97, 98, -1, -1, 101, -1, -1,
- -1, -1, 76, 77, 78, 0, 80, 81, 82, 83,
- 84, 85, 86, 87, 88, 89, 90, 12, -1, -1,
- -1, 95, 96, 97, 98, 20, -1, 101, 102, -1,
- -1, -1, -1, -1, -1, -1, 61, 62, 63, 64,
- -1, -1, -1, -1, -1, -1, -1, 42, 43, 44,
- 45, -1, -1, -1, 49, -1, 51, -1, -1, 54,
- -1, -1, -1, 88, 89, 90, 61, 62, 63, 64,
- 95, 96, 97, 98, -1, -1, 101, -1, -1, -1,
- -1, 76, 77, 78, -1, 80, 81, 82, 83, 84,
- 85, 86, 87, 88, 89, 90, -1, -1, -1, -1,
- 95, 96, 97, 98, -1, -1, 101, 102, 9, -1,
- 11, -1, 13, 14, 15, 16, 17, 18, 19, -1,
- -1, -1, 23, 24, 25, 26, 27, 28, 29, 30,
- 31, 32, 33, 34, -1, -1, -1, -1, 39, -1,
- -1, -1, -1, -1, -1, 61, 62, 63, 64, -1,
- -1, -1, 53, -1, 55, 56, 57, 58, 59, 60,
- -1, -1, -1, -1, 65, 66, 67, 68, 69, 70,
- 71, -1, -1, 89, 90, -1, -1, -1, 79, 95,
- 96, 97, 98, -1, -1, 101, -1, -1, -1, -1,
- 91, 92, 93, -1, -1, -1, -1, -1, 99, 100,
- -1, 9, 103, 11, -1, 13, 14, 15, 16, 17,
- 18, 19, -1, -1, -1, 23, 24, 25, 26, 27,
- -1, 29, 30, 31, 32, 33, 34, -1, -1, -1,
- -1, 39, -1, -1, -1, -1, -1, -1, 61, 62,
- 63, 64, -1, -1, -1, 53, -1, 55, 56, 57,
- 58, 59, 60, -1, -1, -1, -1, 65, 66, 67,
- 68, 69, 70, 71, -1, -1, 89, 90, -1, -1,
- -1, 79, 95, 96, 97, 98, -1, -1, 101, -1,
- -1, -1, -1, 91, 92, 93, -1, -1, -1, -1,
- -1, 99, 100, -1, -1, 103, 11, 12, 13, 14,
- 15, 16, 17, 18, 19, -1, -1, -1, 23, 24,
- 25, 26, 27, -1, 29, 30, 31, 32, 33, 34,
- -1, -1, -1, -1, 39, -1, -1, -1, -1, -1,
- -1, 61, -1, 63, 64, -1, -1, -1, 53, -1,
- 55, 56, 57, 58, 59, 60, -1, -1, -1, -1,
- 65, 66, 67, 68, 69, 70, 71, -1, -1, 89,
- 90, -1, -1, -1, 79, 95, 96, 97, 98, -1,
- -1, 101, -1, -1, -1, -1, 91, 92, 93, -1,
- -1, -1, -1, -1, 99, 100, -1, 11, 103, 13,
- 14, 15, 16, 17, 18, 19, 20, -1, -1, 23,
- 24, 25, 26, 27, -1, 29, 30, 31, 32, 33,
- 34, -1, -1, -1, -1, 39, -1, -1, -1, -1,
- -1, -1, -1, -1, 63, 64, -1, -1, -1, 53,
- -1, 55, 56, 57, 58, 59, 60, -1, -1, -1,
- -1, 65, 66, 67, 68, 69, 70, 71, -1, -1,
- 89, 90, -1, -1, -1, 79, 95, 96, 97, 98,
- -1, -1, 101, -1, -1, -1, -1, 91, 92, 93,
- -1, -1, -1, -1, -1, 99, 100, -1, 11, 103,
- 13, 14, 15, 16, 17, 18, 19, -1, -1, -1,
- 23, 24, 25, 26, 27, -1, 29, 30, 31, 32,
- 33, 34, -1, -1, -1, -1, 39, -1, -1, -1,
+ 41, -1, 43, 44, 45, 46, 47, -1, -1, -1,
+ -1, 52, 53, 54, 55, 56, 57, -1, 59, -1,
+ -1, -1, -1, -1, 65, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 77, 78, 79, -1,
+ -1, -1, -1, 84, 85, -1, 87, 88, 5, -1,
+ 7, 8, 9, 10, 11, 12, 13, -1, 15, 16,
+ 17, 18, 19, -1, 21, 22, 23, -1, -1, -1,
+ 27, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 41, -1, 43, 44, 45, 46,
+ 47, -1, -1, -1, -1, 52, 53, 54, 55, 56,
+ 57, -1, 59, -1, -1, -1, -1, -1, 65, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- 53, -1, 55, 56, 57, 58, 59, 60, -1, -1,
- -1, -1, 65, 66, 67, 68, 69, 70, 71, -1,
- -1, -1, -1, -1, -1, -1, 79, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, 91, 92,
- 93, -1, -1, -1, -1, -1, 99, 100, -1, 102,
- 103, 11, -1, 13, 14, 15, 16, 17, 18, 19,
- -1, -1, -1, 23, 24, 25, 26, 27, -1, 29,
- 30, 31, 32, 33, 34, -1, -1, -1, -1, 39,
+ 77, 78, 79, -1, -1, -1, -1, 84, 85, -1,
+ 87, 88, 5, -1, 7, 8, 9, 10, 11, 12,
+ 13, -1, 15, 16, 17, 18, 19, -1, 21, 22,
+ 23, -1, -1, -1, 27, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 41, -1,
+ 43, 44, 45, 46, 47, -1, -1, -1, -1, 52,
+ 53, 54, 55, 56, 57, -1, 59, -1, -1, -1,
+ -1, -1, 65, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 77, 78, 79, -1, -1, -1,
+ -1, 84, 85, -1, 87, 88, 5, -1, 7, 8,
+ 9, 10, 11, 12, 13, -1, 15, 16, 17, 18,
+ 19, -1, 21, 22, 23, -1, -1, -1, 27, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, 53, -1, 55, 56, 57, 58, 59,
- 60, -1, -1, -1, -1, 65, 66, 67, 68, 69,
- 70, 71, -1, -1, -1, -1, -1, -1, -1, 79,
+ -1, -1, 41, -1, 43, 44, 45, 46, 47, -1,
+ -1, -1, -1, 52, 53, 54, 55, 56, 57, -1,
+ 59, -1, -1, -1, -1, -1, 65, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 77, 78,
+ 79, -1, -1, -1, -1, 84, 85, -1, 87, 88,
+ 5, -1, 7, 8, 9, 10, 11, 12, 13, -1,
+ 15, 16, 17, 18, 19, -1, 21, 22, 23, -1,
+ -1, -1, 27, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 41, -1, 43, 44,
+ 45, 46, 47, -1, -1, -1, -1, 52, 53, 54,
+ 55, 56, 57, -1, 59, -1, -1, -1, -1, -1,
+ 65, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, 77, 78, 79, -1, -1, -1, -1, 84,
+ 85, -1, 87, 88, 5, -1, 7, 8, 9, 10,
+ 11, 12, 13, -1, 15, 16, 17, 18, 19, -1,
+ 21, 22, 23, -1, -1, -1, 27, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, 91, 92, 93, -1, -1, -1, -1, -1, 99,
- 100, -1, 102, 103, 11, -1, 13, 14, 15, 16,
- 17, 18, 19, -1, -1, -1, 23, 24, 25, 26,
- 27, -1, 29, 30, 31, 32, 33, 34, -1, -1,
- -1, -1, 39, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, 53, -1, 55, 56,
- 57, 58, 59, 60, -1, -1, -1, -1, 65, 66,
- 67, 68, 69, 70, 71, -1, -1, -1, -1, -1,
- -1, -1, 79, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, 91, 92, 93, -1, -1, -1,
- -1, -1, 99, 100, -1, 102, 103, 11, -1, 13,
- 14, 15, 16, 17, 18, 19, -1, -1, -1, 23,
- 24, 25, 26, 27, -1, 29, 30, 31, 32, 33,
- 34, -1, -1, -1, -1, 39, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, 53,
- -1, 55, 56, 57, 58, 59, 60, -1, -1, -1,
- -1, 65, 66, 67, 68, 69, 70, 71, -1, -1,
- -1, -1, -1, -1, -1, 79, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, 91, 92, 93,
- -1, -1, -1, -1, -1, 99, 100, -1, 102, 103,
- 11, -1, 13, 14, 15, 16, 17, 18, 19, -1,
- -1, -1, 23, 24, 25, 26, 27, -1, 29, 30,
- 31, 32, 33, 34, -1, -1, -1, -1, 39, -1,
+ 41, -1, 43, 44, 45, 46, 47, -1, -1, -1,
+ -1, 52, 53, 54, 55, 56, 57, -1, 59, -1,
+ -1, -1, -1, -1, 65, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 77, 78, 79, -1,
+ -1, -1, -1, 84, 85, -1, 87, 88, 5, -1,
+ 7, 8, 9, 10, 11, 12, 13, -1, 15, 16,
+ 17, 18, 19, -1, 21, 22, 23, -1, -1, -1,
+ 27, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 41, -1, 43, 44, 45, 46,
+ 47, -1, -1, -1, -1, 52, 53, 54, 55, 56,
+ 57, -1, 59, -1, -1, -1, -1, -1, 65, 6,
+ -1, -1, -1, -1, -1, -1, -1, 14, -1, -1,
+ 77, 78, 79, -1, -1, -1, -1, 84, 85, -1,
+ -1, 88, -1, 30, 31, 32, 33, -1, -1, -1,
+ 37, -1, -1, -1, -1, 42, -1, -1, -1, -1,
+ -1, 48, 49, 50, 51, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, 62, 63, 64, -1, 66,
+ 67, 68, 69, 70, 71, 72, 73, 74, 75, 76,
+ -1, 354, -1, 356, 81, 82, 83, 360, -1, 86,
+ 87, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 376, 377, -1, -1, -1, -1, -1,
+ -1, 384, 385, -1, -1, -1, -1, -1, -1, 42,
+ 393, -1, -1, -1, 397, 48, 49, 50, 51, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, 53, -1, 55, 56, 57, 58, 59, 60,
- -1, -1, -1, -1, 65, 66, 67, 68, 69, 70,
- 71, -1, -1, -1, -1, -1, -1, -1, 79, -1,
+ -1, 414, 415, -1, 67, 68, 69, 70, 71, 72,
+ 73, 74, 75, 76, -1, -1, -1, -1, 81, 82,
+ 83, 42, -1, 86, -1, -1, -1, 48, 49, 50,
+ 51, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 67, 68, -1, 70,
+ 71, 72, 73, 74, 75, 76, -1, -1, -1, -1,
+ 81, 82, 83, 42, -1, 86, -1, -1, -1, 48,
+ 49, 50, 51, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 68,
+ -1, 70, 71, 72, 73, 74, 75, 76, -1, -1,
+ -1, -1, 81, 82, 83, 42, -1, 86, -1, -1,
+ -1, 48, 49, 50, 51, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- 91, 92, 93, -1, -1, -1, -1, -1, 99, 100,
- -1, 102, 103, 11, -1, 13, 14, 15, 16, 17,
- 18, 19, -1, -1, -1, 23, 24, 25, 26, 27,
- -1, 29, 30, 31, 32, 33, 34, -1, -1, -1,
- -1, 39, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 53, -1, 55, 56, 57,
- 58, 59, 60, -1, -1, -1, -1, 65, 66, 67,
- 68, 69, 70, 71, -1, -1, -1, -1, -1, -1,
- -1, 79, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, 91, 92, 93, -1, -1, -1, -1,
- -1, 99, 100, -1, 102, 103, 11, -1, 13, 14,
- 15, 16, 17, 18, 19, -1, -1, -1, 23, 24,
- 25, 26, 27, -1, 29, 30, 31, 32, 33, 34,
- -1, -1, -1, -1, 39, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, 53, -1,
- 55, 56, 57, 58, 59, 60, -1, -1, -1, -1,
- 65, 66, 67, 68, 69, 70, 71, -1, -1, 54,
- -1, -1, -1, -1, 79, -1, 61, 62, 63, 64,
- -1, -1, -1, -1, -1, -1, 91, 92, 93, -1,
- -1, -1, -1, -1, 99, 100, 81, 82, 103, 84,
- 85, 86, 87, 88, 89, 90, -1, -1, -1, -1,
- 95, 96, 97, 98, 54, -1, 101, -1, -1, -1,
- -1, 61, 62, 63, 64, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, 82, -1, 84, 85, 86, 87, 88, 89,
- 90, -1, -1, -1, -1, 95, 96, 97, 98, -1,
- -1, 101
+ -1, -1, -1, 70, 71, 72, 73, 74, 75, 76,
+ -1, -1, -1, -1, 81, 82, 83, -1, -1, 86
};
/* YYSTOS[STATE-NUM] -- The (internal number of the) accessing
symbol of state STATE-NUM. */
static const yytype_uint8 yystos[] =
{
- 0, 3, 4, 5, 6, 7, 8, 106, 107, 108,
- 109, 110, 111, 112, 0, 115, 11, 13, 14, 15,
- 16, 17, 18, 19, 23, 24, 25, 26, 27, 29,
- 30, 31, 32, 33, 34, 39, 53, 55, 56, 57,
- 58, 59, 60, 65, 66, 67, 68, 69, 70, 71,
- 79, 91, 92, 93, 99, 100, 103, 150, 151, 152,
- 155, 156, 157, 158, 159, 160, 162, 165, 167, 168,
- 169, 170, 171, 172, 173, 174, 175, 9, 113, 1,
- 20, 35, 37, 38, 40, 41, 42, 43, 44, 45,
- 49, 50, 51, 52, 104, 113, 122, 128, 150, 36,
- 120, 121, 122, 118, 118, 12, 150, 160, 160, 23,
- 28, 113, 168, 176, 176, 176, 176, 176, 176, 176,
- 161, 11, 103, 160, 140, 140, 160, 103, 103, 103,
- 113, 160, 23, 151, 164, 168, 176, 176, 113, 160,
- 20, 150, 23, 28, 142, 160, 103, 163, 168, 169,
- 170, 160, 151, 160, 160, 160, 160, 160, 102, 150,
- 76, 77, 78, 80, 9, 11, 103, 54, 61, 62,
- 63, 64, 81, 82, 84, 85, 86, 87, 88, 89,
- 90, 95, 96, 97, 98, 101, 103, 9, 11, 9,
- 11, 9, 11, 9, 115, 141, 142, 23, 139, 103,
- 103, 103, 103, 70, 103, 168, 103, 103, 113, 48,
- 130, 20, 42, 43, 44, 45, 49, 51, 121, 122,
- 120, 12, 164, 103, 103, 150, 102, 113, 26, 143,
- 102, 102, 150, 165, 176, 151, 10, 20, 164, 102,
- 150, 72, 145, 11, 102, 150, 150, 150, 160, 150,
- 150, 102, 150, 160, 160, 160, 160, 160, 160, 160,
- 160, 160, 160, 160, 160, 160, 160, 160, 9, 11,
- 15, 16, 17, 18, 19, 24, 65, 103, 154, 168,
- 102, 150, 150, 150, 150, 150, 150, 150, 150, 118,
- 23, 138, 139, 23, 124, 115, 115, 115, 115, 115,
- 115, 103, 115, 115, 113, 150, 134, 150, 150, 150,
- 150, 150, 165, 151, 12, 153, 72, 144, 102, 102,
- 150, 10, 102, 26, 150, 11, 20, 12, 102, 83,
- 150, 150, 18, 18, 18, 18, 18, 18, 102, 150,
- 103, 102, 20, 12, 20, 12, 20, 12, 20, 10,
- 21, 114, 123, 9, 20, 23, 133, 150, 134, 135,
- 150, 134, 137, 166, 168, 128, 132, 135, 136, 150,
- 115, 135, 135, 102, 102, 164, 26, 115, 148, 102,
- 12, 150, 10, 160, 20, 12, 102, 165, 10, 10,
- 10, 10, 115, 143, 115, 23, 102, 102, 102, 102,
- 103, 102, 20, 135, 102, 102, 103, 146, 12, 10,
- 102, 20, 144, 125, 164, 131, 131, 9, 116, 116,
- 135, 116, 133, 102, 116, 116, 147, 9, 74, 20,
- 148, 149, 118, 20, 116, 116, 117, 46, 47, 129,
- 129, 102, 130, 20, 116, 102, 118, 119, 10, 130,
- 130, 118, 116, 103, 116, 131, 130, 10, 20, 26,
- 126, 10, 135, 130, 136, 22, 73, 127, 102, 102,
- 118, 116, 116, 74, 129
+ 0, 91, 95, 0, 98, 24, 25, 26, 28, 29,
+ 58, 89, 99, 105, 106, 114, 115, 116, 117, 119,
+ 120, 129, 130, 123, 121, 15, 121, 121, 1, 3,
+ 5, 7, 8, 9, 10, 11, 12, 13, 14, 15,
+ 16, 17, 18, 19, 21, 22, 23, 27, 30, 31,
+ 32, 33, 37, 38, 39, 40, 41, 43, 44, 45,
+ 46, 47, 52, 53, 54, 55, 56, 57, 59, 65,
+ 77, 78, 79, 84, 85, 88, 92, 100, 102, 103,
+ 132, 133, 134, 137, 138, 139, 140, 141, 142, 143,
+ 148, 149, 150, 151, 152, 153, 15, 118, 15, 124,
+ 14, 131, 124, 93, 6, 132, 142, 142, 15, 20,
+ 92, 149, 154, 154, 154, 154, 154, 154, 154, 88,
+ 142, 122, 122, 88, 88, 88, 88, 57, 88, 149,
+ 88, 88, 92, 142, 88, 88, 88, 92, 142, 15,
+ 133, 145, 149, 154, 154, 15, 92, 142, 149, 14,
+ 132, 15, 142, 88, 144, 149, 150, 151, 142, 133,
+ 142, 142, 142, 142, 142, 87, 132, 36, 104, 14,
+ 30, 31, 32, 33, 37, 62, 63, 64, 66, 3,
+ 5, 88, 42, 48, 49, 50, 51, 67, 68, 70,
+ 71, 72, 73, 74, 75, 76, 81, 82, 83, 86,
+ 88, 3, 5, 3, 5, 3, 92, 18, 125, 15,
+ 125, 98, 6, 145, 88, 133, 92, 125, 93, 93,
+ 93, 93, 93, 93, 88, 93, 93, 87, 87, 132,
+ 132, 146, 154, 133, 88, 88, 4, 14, 145, 87,
+ 132, 60, 127, 5, 87, 92, 132, 110, 132, 132,
+ 132, 132, 132, 132, 132, 142, 132, 132, 87, 132,
+ 142, 142, 142, 142, 142, 142, 142, 142, 142, 142,
+ 142, 142, 142, 142, 142, 3, 5, 16, 88, 136,
+ 149, 87, 132, 132, 132, 132, 132, 132, 60, 126,
+ 15, 126, 4, 146, 87, 135, 126, 109, 132, 110,
+ 111, 132, 110, 113, 147, 149, 100, 108, 111, 112,
+ 132, 93, 94, 111, 87, 66, 87, 132, 87, 132,
+ 87, 132, 4, 87, 18, 132, 5, 14, 6, 87,
+ 69, 132, 132, 87, 132, 88, 87, 14, 6, 14,
+ 6, 14, 18, 14, 92, 128, 145, 128, 87, 145,
+ 92, 87, 87, 87, 87, 88, 87, 14, 111, 111,
+ 87, 87, 87, 87, 6, 132, 4, 142, 14, 6,
+ 87, 146, 4, 4, 4, 14, 107, 107, 3, 96,
+ 96, 111, 96, 109, 87, 87, 96, 6, 4, 87,
+ 96, 96, 97, 34, 35, 101, 101, 87, 104, 14,
+ 96, 96, 104, 104, 98, 96, 88, 96, 107, 104,
+ 4, 111, 104, 112, 87, 87, 96, 96, 101
};
typedef enum {
@@ -1090,35 +888,26 @@ typedef enum {
/* type of each token/terminal */
static const toketypes yy_type_tab[] =
{
- toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival,
- toketype_ival, toketype_ival, toketype_ival, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval,
- toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval,
- toketype_i_tkval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval,
+ toketype_ival, toketype_ival, toketype_ival, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval,
+ toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_opval, toketype_opval, toketype_opval,
toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval,
- toketype_opval, toketype_p_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval,
+ toketype_p_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval,
toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval,
toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval,
- toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval,
toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval,
- toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_ival, toketype_ival, toketype_ival,
+ toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval, toketype_i_tkval,
toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival,
toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival,
toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival,
- toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_i_tkval, toketype_ival, toketype_ival, toketype_ival,
- toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_opval, toketype_opval, toketype_ival,
- toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval,
- toketype_opval, toketype_opval, toketype_ival, toketype_ival, toketype_ival, toketype_opval, toketype_opval,
- toketype_opval, toketype_opval, toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval,
- toketype_opval, toketype_opval, toketype_opval, toketype_ival, toketype_ival,
- toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval,
- toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval,
- toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval,
- toketype_opval, toketype_opval, toketype_opval, toketype_ival, toketype_opval, toketype_opval,
+ toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_i_tkval, toketype_ival,
+ toketype_ival, toketype_opval, toketype_ival, toketype_ival, toketype_ival, toketype_opval,
+ toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval,
+ toketype_opval, toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval,
+ toketype_opval, toketype_p_tkval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval,
+ toketype_opval, toketype_ival, toketype_ival, toketype_ival, toketype_opval,
+ toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_ival,
+ toketype_opval, toketype_opval, toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval,
+ toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval,
toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval,
- toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval
+ toketype_opval, toketype_opval, toketype_opval
};
-
-/* Generated from:
- * bb8245a1a537b2afb2445b3973f63b210f9ec346a1955071aef7d05ba97196ae perly.y
- * 5c9d2a0262457fe9b70073fc8ad6c188f812f38ad57712b7e2f53daa01b297cc regen_perly.pl
- * ex: set ro: */
diff --git a/gnu/usr.bin/perl/pod/perlcommunity.pod b/gnu/usr.bin/perl/pod/perlcommunity.pod
index 2acb0e2399b..993c9563dbc 100644
--- a/gnu/usr.bin/perl/pod/perlcommunity.pod
+++ b/gnu/usr.bin/perl/pod/perlcommunity.pod
@@ -14,15 +14,15 @@ evidence that the Perl users apply TMTOWTDI to all endeavors, not just
programming. From websites, to IRC, to mailing lists, there is more than one
way to get involved in the community.
-=head2 Where to Find the Community
+=head2 Where to find the community
There is a central directory for the Perl community: L<http://perl.org>
maintained by the Perl Foundation (L<http://www.perlfoundation.org/>),
which tracks and provides services for a variety of other community sites.
-=head2 Mailing Lists and Newsgroups
+=head2 Mailing lists and Newsgroups
-Perl runs on e-mail; there is no doubt about it. The Camel book was originally
+Perl runs on e-mail, there is no doubt about it. The Camel book was originally
written mostly over e-mail and today Perl's development is co-ordinated through
mailing lists. The largest repository of Perl mailing lists is located at
L<http://lists.perl.org>.
@@ -41,7 +41,7 @@ The Perl community has a rather large IRC presence. For starters, it has its
own IRC network, L<irc://irc.perl.org>. General (not help-oriented) chat can be
found at L<irc://irc.perl.org/#perl>. Many other more specific chats are also
hosted on the network. Information about irc.perl.org is located on the
-network's website: L<http://www.irc.perl.org>. For a more help-oriented #perl,
+network's website: L<http://www.irc.perl.org>. For a more help oriented #perl,
check out L<irc://irc.freenode.net/#perl>. Perl 6 development also has a
presence in L<irc://irc.freenode.net/#perl6>. Most Perl-related channels will
be kind enough to point you in the right direction if you ask nicely.
@@ -52,7 +52,7 @@ with varying activity levels.
=head2 Websites
Perl websites come in a variety of forms, but they fit into two large
-categories: forums and news websites. There are many Perl-related
+categories: forums and news websites. There are many Perl related
websites, so only a few of the community's largest are mentioned here.
=head3 News sites
@@ -61,21 +61,15 @@ websites, so only a few of the community's largest are mentioned here.
=item L<http://perl.com/>
-Run by O'Reilly Media (the publisher of L<the Camel Book|perlbook>, among other
+Run by O'Reilly Media (The publisher of L<the Camel Book|perlbook> among other
Perl-related literature), perl.com provides current Perl news, articles, and
resources for Perl developers as well as a directory of other useful websites.
-=item L<http://blogs.perl.org/>
-
-Many members of the community have a Perl-related blog on this site. If
-you'd like to join them, you can sign up for free.
-
=item L<http://use.perl.org/>
-use Perl; used to provide a slashdot-style news/blog website covering all
-things Perl, from minutes of the meetings of the Perl 6 Design team to
-conference announcements with (ir)relevant discussion. It no longer accepts
-updates, but you can still use the site to read old entries and comments.
+use Perl; provides a slashdot-style Perl news website covering all things Perl,
+from minutes of the meetings of the Perl 6 Design team to conference
+announcements with (ir)relevant discussion.
=back
@@ -89,24 +83,18 @@ PerlMonks is one of the largest Perl forums, and describes itself as "A place
for individuals to polish, improve, and showcase their Perl skills." and "A
community which allows everyone to grow and learn from each other."
-=item L<http://stackoverflow.com/>
-
-Stack Overflow is a free question-and-answer site for programmers. It's not
-focussed solely on Perl, but it does have an active group of users who do
-their best to help people with their Perl programming questions.
-
=back
=head2 User Groups
-Many cities around the world have local Perl Mongers chapters. A Perl Mongers
+Many cities around the world have local PerlMongers chapters. A PerlMongers
chapter is a local user group which typically holds regular in-person meetings,
both social and technical; helps organize local conferences, workshops, and
hackathons; and provides a mailing list or other continual contact method for
its members to keep in touch.
-To find your local Perl Mongers (or PM as they're commonly abbreviated) group
-check the international Perl Mongers directory at L<http://www.pm.org/>.
+To find your local PerlMongers (or PM as they're commonly abbreviated) group
+check the international PerlMongers directory at L<http://www.pm.org/>.
=head2 Workshops
@@ -131,7 +119,7 @@ L<irc://irc.perl.org/#perl>.
If you have never been to a hackathon, here are a few basic things you need to
know before attending: have a working laptop and know how to use it; check out
-the involved projects beforehand; have the necessary version control client;
+the involved projects before hand; have the necessary version control client;
and bring backup equipment (an extra LAN cable, additional power strips, etc.)
because someone will forget.
@@ -144,24 +132,21 @@ Europe, Asia) in a stunning grassroots display by the Perl community. For more
information about either conference, check out their respective web pages:
OSCON L<http://conferences.oreillynet.com/>; YAPC L<http://www.yapc.org>.
-A relatively new conference franchise with a large Perl portion is the
+A relatively new conference franchize with a large Perl portion is the
Open Source Developers Conference or OSDC. First held in Australia it has
-recently also spread to Israel and France. More information can be found at:
-L<http://www.osdc.com.au/> for Australia, L<http://www.osdc.org.il>
-for Israel, and L<http://www.osdc.fr/> for France.
+recently also spread to Israel. More information can be found at:
+L<http://www.osdc.com.au/> for Australia, and L<http://www.osdc.org.il>
+for Israel.
=head2 Calendar of Perl Events
-The Perl Review, L<http://www.theperlreview.com> maintains a website
-and Google calendar
-(L<http://www.theperlreview.com/community_calendar>) for tracking
-workshops, hackathons, Perl Mongers meetings, and other events. Views
-of this calendar are at L<http://www.perl.org/events.html> and
-L<http://www.yapc.org>.
-
-Not every event or Perl Mongers group is on that calendar, so don't lose
-heart if you don't see yours posted. To have your event or group listed,
-contact brian d foy (brian@theperlreview.com).
+The Perl Foundation maintains a website and Google calendar for tracking
+Workshops, Hackathons, Perl Mongers meetings, and the larger conventions
+mentioned above. The web page is located at
+L<http://www.perl.org/events.html>; the Google calendar is named
+I<Perl Events>. Disclaimer: not every Perl Mongers group is on that calendar,
+so don't lose heart if you don't see yours posted. Read the section above
+on L<"User Groups"> to find yours.
=head1 AUTHOR
diff --git a/gnu/usr.bin/perl/pod/perlreapi.pod b/gnu/usr.bin/perl/pod/perlreapi.pod
index 3e25626cc57..f8e9984341f 100644
--- a/gnu/usr.bin/perl/pod/perlreapi.pod
+++ b/gnu/usr.bin/perl/pod/perlreapi.pod
@@ -1,58 +1,39 @@
=head1 NAME
-perlreapi - Perl regular expression plugin interface
+perlreapi - perl regular expression plugin interface
=head1 DESCRIPTION
-As of Perl 5.9.5 there is a new interface for plugging and using
-regular expression engines other than the default one.
+As of Perl 5.9.5 there is a new interface for plugging and using other
+regular expression engines than the default one.
Each engine is supposed to provide access to a constant structure of the
following format:
typedef struct regexp_engine {
- REGEXP* (*comp) (pTHX_
- const SV * const pattern, const U32 flags);
- I32 (*exec) (pTHX_
- REGEXP * const rx,
- char* stringarg,
- char* strend, char* strbeg,
- SSize_t minend, SV* sv,
+ REGEXP* (*comp) (pTHX_ const SV * const pattern, const U32 flags);
+ I32 (*exec) (pTHX_ REGEXP * const rx, char* stringarg, char* strend,
+ char* strbeg, I32 minend, SV* screamer,
void* data, U32 flags);
- char* (*intuit) (pTHX_
- REGEXP * const rx, SV *sv,
- const char * const strbeg,
- char *strpos, char *strend, U32 flags,
+ char* (*intuit) (pTHX_ REGEXP * const rx, SV *sv, char *strpos,
+ char *strend, U32 flags,
struct re_scream_pos_data_s *data);
SV* (*checkstr) (pTHX_ REGEXP * const rx);
void (*free) (pTHX_ REGEXP * const rx);
- void (*numbered_buff_FETCH) (pTHX_
- REGEXP * const rx,
- const I32 paren,
- SV * const sv);
- void (*numbered_buff_STORE) (pTHX_
- REGEXP * const rx,
- const I32 paren,
- SV const * const value);
- I32 (*numbered_buff_LENGTH) (pTHX_
- REGEXP * const rx,
- const SV * const sv,
- const I32 paren);
- SV* (*named_buff) (pTHX_
- REGEXP * const rx,
- SV * const key,
- SV * const value,
- U32 flags);
- SV* (*named_buff_iter) (pTHX_
- REGEXP * const rx,
- const SV * const lastkey,
+ void (*numbered_buff_FETCH) (pTHX_ REGEXP * const rx, const I32 paren,
+ SV * const sv);
+ void (*numbered_buff_STORE) (pTHX_ REGEXP * const rx, const I32 paren,
+ SV const * const value);
+ I32 (*numbered_buff_LENGTH) (pTHX_ REGEXP * const rx, const SV * const sv,
+ const I32 paren);
+ SV* (*named_buff) (pTHX_ REGEXP * const rx, SV * const key,
+ SV * const value, U32 flags);
+ SV* (*named_buff_iter) (pTHX_ REGEXP * const rx, const SV * const lastkey,
const U32 flags);
SV* (*qr_package)(pTHX_ REGEXP * const rx);
#ifdef USE_ITHREADS
void* (*dupe) (pTHX_ REGEXP * const rx, CLONE_PARAMS *param);
#endif
- REGEXP* (*op_comp) (...);
-
When a regexp is compiled, its C<engine> field is then set to point at
the appropriate structure, so that when it needs to be used Perl can find
@@ -60,11 +41,11 @@ the right routines to do so.
In order to install a new regexp handler, C<$^H{regcomp}> is set
to an integer which (when casted appropriately) resolves to one of these
-structures. When compiling, the C<comp> method is executed, and the
-resulting C<regexp> structure's engine field is expected to point back at
+structures. When compiling, the C<comp> method is executed, and the
+resulting regexp structure's engine field is expected to point back at
the same structure.
-The pTHX_ symbol in the definition is a macro used by Perl under threading
+The pTHX_ symbol in the definition is a macro used by perl under threading
to provide an extra argument to the routine holding a pointer back to
the interpreter that is executing the regexp. So under threading all
routines get an extra argument.
@@ -77,43 +58,43 @@ routines get an extra argument.
Compile the pattern stored in C<pattern> using the given C<flags> and
return a pointer to a prepared C<REGEXP> structure that can perform
-the match. See L</The REGEXP structure> below for an explanation of
+the match. See L</The REGEXP structure> below for an explanation of
the individual fields in the REGEXP struct.
The C<pattern> parameter is the scalar that was used as the
-pattern. Previous versions of Perl would pass two C<char*> indicating
-the start and end of the stringified pattern; the following snippet can
+pattern. previous versions of perl would pass two C<char*> indicating
+the start and end of the stringified pattern, the following snippet can
be used to get the old parameters:
STRLEN plen;
char* exp = SvPV(pattern, plen);
char* xend = exp + plen;
-Since any scalar can be passed as a pattern, it's possible to implement
+Since any scalar can be passed as a pattern it's possible to implement
an engine that does something with an array (C<< "ook" =~ [ qw/ eek
hlagh / ] >>) or with the non-stringified form of a compiled regular
-expression (C<< "ook" =~ qr/eek/ >>). Perl's own engine will always
-stringify everything using the snippet above, but that doesn't mean
+expression (C<< "ook" =~ qr/eek/ >>). perl's own engine will always
+stringify everything using the snippet above but that doesn't mean
other engines have to.
The C<flags> parameter is a bitfield which indicates which of the
-C<msixp> flags the regex was compiled with. It also contains
-additional info, such as if C<use locale> is in effect.
+C<msixp> flags the regex was compiled with. It also contains
+additional info such as whether C<use locale> is in effect.
The C<eogc> flags are stripped out before being passed to the comp
-routine. The regex engine does not need to know if any of these
-are set, as those flags should only affect what Perl does with the
+routine. The regex engine does not need to know whether any of these
+are set as those flags should only affect what perl does with the
pattern and its match variables, not how it gets compiled and
executed.
By the time the comp callback is called, some of these flags have
-already had effect (noted below where applicable). However most of
-their effect occurs after the comp callback has run, in routines that
+already had effect (noted below where applicable). However most of
+their effect occurs after the comp callback has run in routines that
read the C<< rx->extflags >> field which it populates.
In general the flags should be preserved in C<< rx->extflags >> after
compilation, although the regex engine might want to add or delete
-some of them to invoke or disable some special behavior in Perl. The
+some of them to invoke or disable some special behavior in perl. The
flags along with any special behavior they cause are documented below:
The pattern modifiers:
@@ -132,45 +113,43 @@ as a multi-line string.
=item C</x> - RXf_PMf_EXTENDED
-If present on a regex, C<"#"> comments will be handled differently by the
+If present on a regex C<#> comments will be handled differently by the
tokenizer in some cases.
TODO: Document those cases.
=item C</p> - RXf_PMf_KEEPCOPY
-TODO: Document this
+=back
+
+Additional flags:
+
+=over 4
-=item Character set
+=item RXf_PMf_LOCALE
-The character set rules are determined by an enum that is contained
-in this field. This is still experimental and subject to change, but
-the current interface returns the rules by use of the in-line function
-C<get_regex_charset(const U32 flags)>. The only currently documented
-value returned from it is REGEX_LOCALE_CHARSET, which is set if
-C<use locale> is in effect. If present in C<< rx->extflags >>,
-C<split> will use the locale dependent definition of whitespace
-when RXf_SKIPWHITE or RXf_WHITE is in effect. ASCII whitespace
-is defined as per L<isSPACE|perlapi/isSPACE>, and by the internal
-macros C<is_utf8_space> under UTF-8, and C<isSPACE_LC> under C<use
+Set if C<use locale> is in effect. If present in C<< rx->extflags >>
+C<split> will use the locale dependent definition of whitespace under
+when RXf_SKIPWHITE or RXf_WHITE are in effect. Under ASCII whitespace
+is defined as per L<isSPACE|perlapi/ISSPACE>, and by the internal
+macros C<is_utf8_space> under UTF-8 and C<isSPACE_LC> under C<use
locale>.
-=back
+=item RXf_UTF8
-Additional flags:
+Set if the pattern is L<SvUTF8()|perlapi/SvUTF8>, set by Perl_pmruntime.
-=over 4
+A regex engine may want to set or disable this flag during
+compilation. The perl engine for instance may upgrade non-UTF-8
+strings to UTF-8 if the pattern includes constructs such as C<\x{...}>
+that can only match Unicode values.
=item RXf_SPLIT
-This flag was removed in perl 5.18.0. C<split ' '> is now special-cased
-solely in the parser. RXf_SPLIT is still #defined, so you can test for it.
-This is how it used to work:
-
If C<split> is invoked as C<split ' '> or with no arguments (which
-really means C<split(' ', $_)>, see L<split|perlfunc/split>), Perl will
-set this flag. The regex engine can then check for it and set the
-SKIPWHITE and WHITE extflags. To do this, the Perl engine does:
+really means C<split(' ', $_)>, see L<split|perlfunc/split>), perl will
+set this flag. The regex engine can then check for it and set the
+SKIPWHITE and WHITE extflags. To do this the perl engine does:
if (flags & RXf_SPLIT && r->prelen == 1 && r->precomp[0] == ' ')
r->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
@@ -184,16 +163,13 @@ the C<split> operator.
=item RXf_SKIPWHITE
-This flag was removed in perl 5.18.0. It is still #defined, so you can
-set it, but doing so will have no effect. This is how it used to work:
-
If the flag is present in C<< rx->extflags >> C<split> will delete
whitespace from the start of the subject string before it's operated
-on. What is considered whitespace depends on if the subject is a
-UTF-8 string and if the C<RXf_PMf_LOCALE> flag is set.
+on. What is considered whitespace depends on whether the subject is a
+UTF-8 string and whether the C<RXf_PMf_LOCALE> flag is set.
-If RXf_WHITE is set in addition to this flag, C<split> will behave like
-C<split " "> under the Perl engine.
+If RXf_WHITE is set in addition to this flag C<split> will behave like
+C<split " "> under the perl engine.
=item RXf_START_ONLY
@@ -201,122 +177,52 @@ Tells the split operator to split the target string on newlines
(C<\n>) without invoking the regex engine.
Perl's engine sets this if the pattern is C</^/> (C<plen == 1 && *exp
-== '^'>), even under C</^/s>; see L<split|perlfunc>. Of course a
+== '^'>), even under C</^/s>, see L<split|perlfunc>. Of course a
different regex engine might want to use the same optimizations
with a different syntax.
=item RXf_WHITE
Tells the split operator to split the target string on whitespace
-without invoking the regex engine. The definition of whitespace varies
-depending on if the target string is a UTF-8 string and on
-if RXf_PMf_LOCALE is set.
+without invoking the regex engine. The definition of whitespace varies
+depending on whether the target string is a UTF-8 string and on
+whether RXf_PMf_LOCALE is set.
Perl's engine sets this flag if the pattern is C<\s+>.
=item RXf_NULL
Tells the split operator to split the target string on
-characters. The definition of character varies depending on if
+characters. The definition of character varies depending on whether
the target string is a UTF-8 string.
Perl's engine sets this flag on empty patterns, this optimization
-makes C<split //> much faster than it would otherwise be. It's even
+makes C<split //> much faster than it would otherwise be. It's even
faster than C<unpack>.
-=item RXf_NO_INPLACE_SUBST
-
-Added in perl 5.18.0, this flag indicates that a regular expression might
-perform an operation that would interfere with inplace substitution. For
-instance it might contain lookbehind, or assign to non-magical variables
-(such as $REGMARK and $REGERROR) during matching. C<s///> will skip
-certain optimisations when this is set.
-
=back
=head2 exec
I32 exec(pTHX_ REGEXP * const rx,
char *stringarg, char* strend, char* strbeg,
- SSize_t minend, SV* sv,
+ I32 minend, SV* screamer,
void* data, U32 flags);
-Execute a regexp. The arguments are
-
-=over 4
-
-=item rx
-
-The regular expression to execute.
-
-=item sv
-
-This is the SV to be matched against. Note that the
-actual char array to be matched against is supplied by the arguments
-described below; the SV is just used to determine UTF8ness, C<pos()> etc.
-
-=item strbeg
-
-Pointer to the physical start of the string.
-
-=item strend
-
-Pointer to the character following the physical end of the string (i.e.
-the C<\0>, if any).
-
-=item stringarg
-
-Pointer to the position in the string where matching should start; it might
-not be equal to C<strbeg> (for example in a later iteration of C</.../g>).
-
-=item minend
-
-Minimum length of string (measured in bytes from C<stringarg>) that must
-match; if the engine reaches the end of the match but hasn't reached this
-position in the string, it should fail.
-
-=item data
-
-Optimisation data; subject to change.
-
-=item flags
-
-Optimisation flags; subject to change.
-
-=back
+Execute a regexp.
=head2 intuit
- char* intuit(pTHX_
- REGEXP * const rx,
- SV *sv,
- const char * const strbeg,
- char *strpos,
- char *strend,
- const U32 flags,
- struct re_scream_pos_data_s *data);
+ char* intuit(pTHX_ REGEXP * const rx,
+ SV *sv, char *strpos, char *strend,
+ const U32 flags, struct re_scream_pos_data_s *data);
Find the start position where a regex match should be attempted,
-or possibly if the regex engine should not be run because the
-pattern can't match. This is called, as appropriate, by the core,
-depending on the values of the C<extflags> member of the C<regexp>
+or possibly whether the regex engine should not be run because the
+pattern can't match. This is called as appropriate by the core
+depending on the values of the extflags member of the regexp
structure.
-Arguments:
-
- rx: the regex to match against
- sv: the SV being matched: only used for utf8 flag; the string
- itself is accessed via the pointers below. Note that on
- something like an overloaded SV, SvPOK(sv) may be false
- and the string pointers may point to something unrelated to
- the SV itself.
- strbeg: real beginning of string
- strpos: the point in the string at which to begin matching
- strend: pointer to the byte following the last char of the string
- flags currently unused; set to 0
- data: currently unused; set to NULL
-
-
=head2 checkstr
SV* checkstr(pTHX_ REGEXP * const rx);
@@ -328,33 +234,22 @@ by C<split> for optimising matches.
void free(pTHX_ REGEXP * const rx);
-Called by Perl when it is freeing a regexp pattern so that the engine
+Called by perl when it is freeing a regexp pattern so that the engine
can release any resources pointed to by the C<pprivate> member of the
-C<regexp> structure. This is only responsible for freeing private data;
-Perl will handle releasing anything else contained in the C<regexp> structure.
+regexp structure. This is only responsible for freeing private data;
+perl will handle releasing anything else contained in the regexp structure.
=head2 Numbered capture callbacks
Called to get/set the value of C<$`>, C<$'>, C<$&> and their named
-equivalents, ${^PREMATCH}, ${^POSTMATCH} and ${^MATCH}, as well as the
-numbered capture groups (C<$1>, C<$2>, ...).
-
-The C<paren> parameter will be C<1> for C<$1>, C<2> for C<$2> and so
-forth, and have these symbolic values for the special variables:
-
- ${^PREMATCH} RX_BUFF_IDX_CARET_PREMATCH
- ${^POSTMATCH} RX_BUFF_IDX_CARET_POSTMATCH
- ${^MATCH} RX_BUFF_IDX_CARET_FULLMATCH
- $` RX_BUFF_IDX_PREMATCH
- $' RX_BUFF_IDX_POSTMATCH
- $& RX_BUFF_IDX_FULLMATCH
-
-Note that in Perl 5.17.3 and earlier, the last three constants were also
-used for the caret variants of the variables.
+equivalents, ${^PREMATCH}, ${^POSTMATCH} and $^{MATCH}, as well as the
+numbered capture buffers (C<$1>, C<$2>, ...).
+The C<paren> parameter will be C<-2> for C<$`>, C<-1> for C<$'>, C<0>
+for C<$&>, C<1> for C<$1> and so forth.
The names have been chosen by analogy with L<Tie::Scalar> methods
-names with an additional B<LENGTH> callback for efficiency. However
+names with an additional B<LENGTH> callback for efficiency. However
named capture variables are currently not tied internally but
implemented via magic.
@@ -363,33 +258,31 @@ implemented via magic.
void numbered_buff_FETCH(pTHX_ REGEXP * const rx, const I32 paren,
SV * const sv);
-Fetch a specified numbered capture. C<sv> should be set to the scalar
+Fetch a specified numbered capture. C<sv> should be set to the scalar
to return, the scalar is passed as an argument rather than being
-returned from the function because when it's called Perl already has a
+returned from the function because when it's called perl already has a
scalar to store the value, creating another one would be
-redundant. The scalar can be set with C<sv_setsv>, C<sv_setpvn> and
+redundant. The scalar can be set with C<sv_setsv>, C<sv_setpvn> and
friends, see L<perlapi>.
-This callback is where Perl untaints its own capture variables under
-taint mode (see L<perlsec>). See the C<Perl_reg_numbered_buff_fetch>
+This callback is where perl untaints its own capture variables under
+taint mode (see L<perlsec>). See the C<Perl_reg_numbered_buff_fetch>
function in F<regcomp.c> for how to untaint capture variables if
that's something you'd like your engine to do as well.
=head3 numbered_buff_STORE
- void (*numbered_buff_STORE) (pTHX_
- REGEXP * const rx,
- const I32 paren,
+ void (*numbered_buff_STORE) (pTHX_ REGEXP * const rx, const I32 paren,
SV const * const value);
-Set the value of a numbered capture variable. C<value> is the scalar
-that is to be used as the new value. It's up to the engine to make
+Set the value of a numbered capture variable. C<value> is the scalar
+that is to be used as the new value. It's up to the engine to make
sure this is used as the new value (or reject it).
Example:
if ("ook" =~ /(o*)/) {
- # 'paren' will be '1' and 'value' will be 'ee'
+ # `paren' will be `1' and `value' will be `ee'
$1 =~ tr/o/e/;
}
@@ -398,10 +291,8 @@ variables, to do this in another engine use the following callback
(copied from C<Perl_reg_numbered_buff_store>):
void
- Example_reg_numbered_buff_store(pTHX_
- REGEXP * const rx,
- const I32 paren,
- SV const * const value)
+ Example_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
+ SV const * const value)
{
PERL_UNUSED_ARG(rx);
PERL_UNUSED_ARG(paren);
@@ -411,14 +302,14 @@ variables, to do this in another engine use the following callback
Perl_croak(aTHX_ PL_no_modify);
}
-Actually Perl will not I<always> croak in a statement that looks
-like it would modify a numbered capture variable. This is because the
-STORE callback will not be called if Perl can determine that it
-doesn't have to modify the value. This is exactly how tied variables
+Actually perl will not I<always> croak in a statement that looks
+like it would modify a numbered capture variable. This is because the
+STORE callback will not be called if perl can determine that it
+doesn't have to modify the value. This is exactly how tied variables
behave in the same situation:
package CaptureVar;
- use parent 'Tie::Scalar';
+ use base 'Tie::Scalar';
sub TIESCALAR { bless [] }
sub FETCH { undef }
@@ -426,26 +317,24 @@ behave in the same situation:
package main;
- tie my $sv => "CaptureVar";
+ tie my $sv => "CatptureVar";
$sv =~ y/a/b/;
-Because C<$sv> is C<undef> when the C<y///> operator is applied to it,
+Because C<$sv> is C<undef> when the C<y///> operator is applied to it
the transliteration won't actually execute and the program won't
-C<die>. This is different to how 5.8 and earlier versions behaved
-since the capture variables were READONLY variables then; now they'll
+C<die>. This is different to how 5.8 and earlier versions behaved
+since the capture variables were READONLY variables then, now they'll
just die when assigned to in the default engine.
=head3 numbered_buff_LENGTH
- I32 numbered_buff_LENGTH (pTHX_
- REGEXP * const rx,
- const SV * const sv,
+ I32 numbered_buff_LENGTH (pTHX_ REGEXP * const rx, const SV * const sv,
const I32 paren);
-Get the C<length> of a capture variable. There's a special callback
-for this so that Perl doesn't have to do a FETCH and run C<length> on
-the result, since the length is (in Perl's case) known from an offset
-stored in C<< rx->offs >>, this is much more efficient:
+Get the C<length> of a capture variable. There's a special callback
+for this so that perl doesn't have to do a FETCH and run C<length> on
+the result, since the length is (in perl's case) known from an offset
+stored in C<<rx->offs> this is much more efficient:
I32 s1 = rx->offs[paren].start;
I32 s2 = rx->offs[paren].end;
@@ -457,7 +346,7 @@ L<is_utf8_string_loclen|perlapi/is_utf8_string_loclen>.
=head2 Named capture callbacks
-Called to get/set the value of C<%+> and C<%->, as well as by some
+Called to get/set the value of C<%+> and C<%-> as well as by some
utility functions in L<re>.
There are two callbacks, C<named_buff> is called in all the cases the
@@ -466,7 +355,7 @@ would be on changes to C<%+> and C<%-> and C<named_buff_iter> in the
same cases as FIRSTKEY and NEXTKEY.
The C<flags> parameter can be used to determine which of these
-operations the callbacks should respond to. The following flags are
+operations the callbacks should respond to, the following flags are
currently defined:
Which L<Tie::Hash> operation is being performed from the Perl level on
@@ -481,13 +370,13 @@ C<%+> or C<%+>, if any:
RXapif_FIRSTKEY
RXapif_NEXTKEY
-If C<%+> or C<%-> is being operated on, if any.
+Whether C<%+> or C<%-> is being operated on, if any.
RXapif_ONE /* %+ */
RXapif_ALL /* %- */
-If this is being called as C<re::regname>, C<re::regnames> or
-C<re::regnames_count>, if any. The first two will be combined with
+Whether this is being called as C<re::regname>, C<re::regnames> or
+C<re::regnames_count>, if any. The first two will be combined with
C<RXapif_ONE> or C<RXapif_ALL>.
RXapif_REGNAME
@@ -495,10 +384,10 @@ C<RXapif_ONE> or C<RXapif_ALL>.
RXapif_REGNAMES_COUNT
Internally C<%+> and C<%-> are implemented with a real tied interface
-via L<Tie::Hash::NamedCapture>. The methods in that package will call
-back into these functions. However the usage of
+via L<Tie::Hash::NamedCapture>. The methods in that package will call
+back into these functions. However the usage of
L<Tie::Hash::NamedCapture> for this purpose might change in future
-releases. For instance this might be implemented by magic instead
+releases. For instance this might be implemented by magic instead
(would need an extension to mgvtbl).
=head3 named_buff
@@ -508,9 +397,7 @@ releases. For instance this might be implemented by magic instead
=head3 named_buff_iter
- SV* (*named_buff_iter) (pTHX_
- REGEXP * const rx,
- const SV * const lastkey,
+ SV* (*named_buff_iter) (pTHX_ REGEXP * const rx, const SV * const lastkey,
const U32 flags);
=head2 qr_package
@@ -518,12 +405,12 @@ releases. For instance this might be implemented by magic instead
SV* qr_package(pTHX_ REGEXP * const rx);
The package the qr// magic object is blessed into (as seen by C<ref
-qr//>). It is recommended that engines change this to their package
-name for identification regardless of if they implement methods
+qr//>). It is recommended that engines change this to their package
+name for identification regardless of whether they implement methods
on the object.
The package this method returns should also have the internal
-C<Regexp> package in its C<@ISA>. C<< qr//->isa("Regexp") >> should always
+C<Regexp> package in its C<@ISA>. C<qr//->isa("Regexp")> should always
be true regardless of what engine is being used.
Example implementation might be:
@@ -555,12 +442,12 @@ Functions>.
void* dupe(pTHX_ REGEXP * const rx, CLONE_PARAMS *param);
On threaded builds a regexp may need to be duplicated so that the pattern
-can be used by multiple threads. This routine is expected to handle the
+can be used by multiple threads. This routine is expected to handle the
duplication of any private data pointed to by the C<pprivate> member of
-the C<regexp> structure. It will be called with the preconstructed new
-C<regexp> structure as an argument, the C<pprivate> member will point at
+the regexp structure. It will be called with the preconstructed new
+regexp structure as an argument, the C<pprivate> member will point at
the B<old> private structure, and it is this routine's responsibility to
-construct a copy and return a pointer to it (which Perl will then use to
+construct a copy and return a pointer to it (which perl will then use to
overwrite the field as passed to this routine.)
This allows the engine to dupe its private data but also if necessary
@@ -568,30 +455,24 @@ modify the final structure if it really must.
On unthreaded builds this field doesn't exist.
-=head2 op_comp
-
-This is private to the Perl core and subject to change. Should be left
-null.
-
=head1 The REGEXP structure
-The REGEXP struct is defined in F<regexp.h>.
-All regex engines must be able to
+The REGEXP struct is defined in F<regexp.h>. All regex engines must be able to
correctly build such a structure in their L</comp> routine.
-The REGEXP structure contains all the data that Perl needs to be aware of
-to properly work with the regular expression. It includes data about
-optimisations that Perl can use to determine if the regex engine should
+The REGEXP structure contains all the data that perl needs to be aware of
+to properly work with the regular expression. It includes data about
+optimisations that perl can use to determine if the regex engine should
really be used, and various other control info that is needed to properly
-execute patterns in various contexts, such as if the pattern anchored in
-some way, or what flags were used during the compile, or if the
-program contains special constructs that Perl needs to be aware of.
+execute patterns in various contexts such as is the pattern anchored in
+some way, or what flags were used during the compile, or whether the
+program contains special constructs that perl needs to be aware of.
In addition it contains two fields that are intended for the private
-use of the regex engine that compiled the pattern. These are the
-C<intflags> and C<pprivate> members. C<pprivate> is a void pointer to
-an arbitrary structure, whose use and management is the responsibility
-of the compiling engine. Perl will never modify either of these
+use of the regex engine that compiled the pattern. These are the
+C<intflags> and C<pprivate> members. C<pprivate> is a void pointer to
+an arbitrary structure whose use and management is the responsibility
+of the compiling engine. perl will never modify either of these
values.
typedef struct regexp {
@@ -601,40 +482,32 @@ values.
/* what re is this a lightweight copy of? */
struct regexp* mother_re;
- /* Information about the match that the Perl core uses to manage
- * things */
+ /* Information about the match that the perl core uses to manage things */
U32 extflags; /* Flags used both externally and internally */
- I32 minlen; /* mininum possible number of chars in */
- string to match */
- I32 minlenret; /* mininum possible number of chars in $& */
+ I32 minlen; /* mininum possible length of string to match */
+ I32 minlenret; /* mininum possible length of $& */
U32 gofs; /* chars left of pos that we search from */
/* substring data about strings that must appear
in the final match, used for optimisations */
struct reg_substr_data *substrs;
- U32 nparens; /* number of capture groups */
+ U32 nparens; /* number of capture buffers */
/* private engine specific data */
U32 intflags; /* Engine Specific Internal flags */
void *pprivate; /* Data private to the regex engine which
created this object. */
- /* Data about the last/current match. These are modified during
- * matching*/
- U32 lastparen; /* highest close paren matched ($+) */
- U32 lastcloseparen; /* last close paren matched ($^N) */
+ /* Data about the last/current match. These are modified during matching*/
+ U32 lastparen; /* last open paren matched */
+ U32 lastcloseparen; /* last close paren matched */
regexp_paren_pair *swap; /* Swap copy of *offs */
- regexp_paren_pair *offs; /* Array of offsets for (@-) and
- (@+) */
+ regexp_paren_pair *offs; /* Array of offsets for (@-) and (@+) */
- char *subbeg; /* saved or original string so \digit works
- forever. */
+ char *subbeg; /* saved or original string so \digit works forever. */
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 */
I32 prelen; /* length of precomp */
@@ -643,8 +516,7 @@ values.
char *wrapped; /* wrapped version of the pattern */
I32 wraplen; /* length of wrapped */
- I32 seen_evals; /* number of eval groups in the pattern - for
- security checks */
+ I32 seen_evals; /* number of eval groups in the pattern - for security checks */
HV *paren_names; /* Optional hash of paren names */
/* Refcount of this regexp */
@@ -655,13 +527,13 @@ The fields are discussed in more detail below:
=head2 C<engine>
-This field points at a C<regexp_engine> structure which contains pointers
-to the subroutines that are to be used for performing a match. It
+This field points at a regexp_engine structure which contains pointers
+to the subroutines that are to be used for performing a match. It
is the compiling routine's responsibility to populate this field before
returning the regexp object.
Internally this is set to C<NULL> unless a custom engine is specified in
-C<$^H{regcomp}>, Perl's own set of callbacks can be accessed in the struct
+C<$^H{regcomp}>, perl's own set of callbacks can be accessed in the struct
pointed to by C<RE_ENGINE_PTR>.
=head2 C<mother_re>
@@ -670,22 +542,21 @@ TODO, see L<http://www.mail-archive.com/perl5-changes@perl.org/msg17328.html>
=head2 C<extflags>
-This will be used by Perl to see what flags the regexp was compiled
+This will be used by perl to see what flags the regexp was compiled
with, this will normally be set to the value of the flags parameter by
-the L<comp|/comp> callback. See the L<comp|/comp> documentation for
+the L<comp|/comp> callback. See the L<comp|/comp> documentation for
valid flags.
=head2 C<minlen> C<minlenret>
-The minimum string length (in characters) required for the pattern to match.
-This is used to
+The minimum string length required for the pattern to match. This is used to
prune the search space by not bothering to match any closer to the end of a
-string than would allow a match. For instance there is no point in even
+string than would allow a match. For instance there is no point in even
starting the regex engine if the minlen is 10 but the string is only 5
-characters long. There is no way that the pattern can match.
+characters long. There is no way that the pattern can match.
-C<minlenret> is the minimum length (in characters) of the string that would
-be found in $& after a match.
+C<minlenret> is the minimum length of the string that would be found
+in $& after a match.
The difference between C<minlen> and C<minlenret> can be seen in the
following pattern:
@@ -693,11 +564,10 @@ following pattern:
/ns(?=\d)/
where the C<minlen> would be 3 but C<minlenret> would only be 2 as the \d is
-required to match but is not actually
-included in the matched content. This
+required to match but is not actually included in the matched content. This
distinction is particularly important as the substitution logic uses the
-C<minlenret> to tell if it can do in-place substitutions (these can
-result in considerable speed-up).
+C<minlenret> to tell whether it can do in-place substitution which can result in
+considerable speedup.
=head2 C<gofs>
@@ -705,11 +575,11 @@ Left offset from pos() to start match at.
=head2 C<substrs>
-Substring data about strings that must appear in the final match. This
-is currently only used internally by Perl's engine, but might be
+Substring data about strings that must appear in the final match. This
+is currently only used internally by perl's engine for but might be
used in the future for all engines for optimisations.
-=head2 C<nparens>, C<lastparen>, and C<lastcloseparen>
+=head2 C<nparens>, C<lasparen>, and C<lastcloseparen>
These fields are used to keep track of how many paren groups could be matched
in the pattern, which was the last open paren to be entered, and which was
@@ -722,14 +592,13 @@ this is the same as C<extflags> unless the engine chose to modify one of them.
=head2 C<pprivate>
-A void* pointing to an engine-defined
-data structure. The Perl engine uses the
+A void* pointing to an engine-defined data structure. The perl engine uses the
C<regexp_internal> structure (see L<perlreguts/Base Structures>) but a custom
engine should use something else.
=head2 C<swap>
-Unused. Left in for compatibility with Perl 5.10.0.
+TODO: document
=head2 C<offs>
@@ -743,17 +612,16 @@ C<regexp_paren_pair> struct is defined as follows:
} regexp_paren_pair;
If C<< ->offs[num].start >> or C<< ->offs[num].end >> is C<-1> then that
-capture group did not match.
-C<< ->offs[0].start/end >> represents C<$&> (or
-C<${^MATCH}> under C<//p>) and C<< ->offs[paren].end >> matches C<$$paren> where
+capture buffer did not match. C<< ->offs[0].start/end >> represents C<$&> (or
+C<${^MATCH> under C<//p>) and C<< ->offs[paren].end >> matches C<$$paren> where
C<$paren >= 1>.
=head2 C<precomp> C<prelen>
-Used for optimisations. C<precomp> holds a copy of the pattern that
-was compiled and C<prelen> its length. When a new pattern is to be
+Used for optimisations. C<precomp> holds a copy of the pattern that
+was compiled and C<prelen> its length. When a new pattern is to be
compiled (such as inside a loop) the internal C<regcomp> operator
-checks if the last compiled C<REGEXP>'s C<precomp> and C<prelen>
+checks whether the last compiled C<REGEXP>'s C<precomp> and C<prelen>
are equivalent to the new one, and if so uses the old pattern instead
of compiling a new one.
@@ -765,8 +633,8 @@ The relevant snippet from C<Perl_pp_regcomp>:
=head2 C<paren_names>
-This is a hash used internally to track named capture groups and their
-offsets. The keys are the names of the buffers the values are dualvars,
+This is a hash used internally to track named capture buffers and their
+offsets. The keys are the names of the buffers the values are dualvars,
with the IV slot holding the number of buffers with the given name and the
pv being an embedded array of I32. The values may also be contained
independently in the data array in cases where named backreferences are
@@ -776,32 +644,18 @@ used.
Holds information on the longest string that must occur at a fixed
offset from the start of the pattern, and the longest string that must
-occur at a floating offset from the start of the pattern. Used to do
+occur at a floating offset from the start of the pattern. Used to do
Fast-Boyer-Moore searches on the string to find out if its worth using
the regex engine at all, and if so where in the string to search.
-=head2 C<subbeg> C<sublen> C<saved_copy> C<suboffset> C<subcoffset>
-
-Used during the execution phase for managing search and replace patterns,
-and for providing the text for C<$&>, C<$1> etc. C<subbeg> points to a
-buffer (either the original string, or a copy in the case of
-C<RX_MATCH_COPIED(rx)>), and C<sublen> is the length of the buffer. The
-C<RX_OFFS> start and end indices index into this buffer.
+=head2 C<subbeg> C<sublen> C<saved_copy>
-In the presence of the C<REXEC_COPY_STR> flag, but with the addition of
-the C<REXEC_COPY_SKIP_PRE> or C<REXEC_COPY_SKIP_POST> flags, an engine
-can choose not to copy the full buffer (although it must still do so in
-the presence of C<RXf_PMf_KEEPCOPY> or the relevant bits being set in
-C<PL_sawampersand>). In this case, it may set C<suboffset> to indicate the
-number of bytes from the logical start of the buffer to the physical start
-(i.e. C<subbeg>). It should also set C<subcoffset>, the number of
-characters in the offset. The latter is needed to support C<@-> and C<@+>
-which work in characters, not bytes.
+Used during execution phase for managing search and replace patterns.
=head2 C<wrapped> C<wraplen>
-Stores the string C<qr//> stringifies to. The Perl engine for example
-stores C<(?^:eek)> in the case of C<qr/eek/>.
+Stores the string C<qr//> stringifies to. The perl engine for example
+stores C<(?-xism:eek)> in the case of C<qr/eek/>.
When using a custom engine that doesn't support the C<(?:)> construct
for inline modifiers, it's probably best to have C<qr//> stringify to
@@ -817,15 +671,13 @@ engine understand a construct like C<(?:)>.
=head2 C<seen_evals>
-This stores the number of eval groups in
-the pattern. This is used for security
+This stores the number of eval groups in the pattern. This is used for security
purposes when embedding compiled regexes into larger patterns with C<qr//>.
=head2 C<refcnt>
-The number of times the structure is referenced. When
-this falls to 0, the regexp is automatically freed
-by a call to pregfree. This should be set to 1 in
+The number of times the structure is referenced. When this falls to 0 the
+regexp is automatically freed by a call to pregfree. This should be set to 1 in
each engine's L</comp> routine.
=head1 HISTORY
diff --git a/gnu/usr.bin/perl/pod/perlrebackslash.pod b/gnu/usr.bin/perl/pod/perlrebackslash.pod
index 230e76dea8b..ddd7abee380 100644
--- a/gnu/usr.bin/perl/pod/perlrebackslash.pod
+++ b/gnu/usr.bin/perl/pod/perlrebackslash.pod
@@ -16,6 +16,7 @@ Most sequences are described in detail in different documents; the primary
purpose of this document is to have a quick reference guide describing all
backslash and escape sequences.
+
=head2 The backslash
In a regular expression, the backslash can perform one of two tasks:
@@ -24,16 +25,17 @@ it either takes away the special meaning of the character following it
or it is the start of a backslash or escape sequence.
The rules determining what it is are quite simple: if the character
-following the backslash is an ASCII punctuation (non-word) character (that is,
-anything that is not a letter, digit, or underscore), then the backslash just
-takes away any special meaning of the character following it.
-
-If the character following the backslash is an ASCII letter or an ASCII digit,
-then the sequence may be special; if so, it's listed below. A few letters have
-not been used yet, so escaping them with a backslash doesn't change them to be
-special. A future version of Perl may assign a special meaning to them, so if
-you have warnings turned on, Perl issues a warning if you use such a
-sequence. [1].
+following the backslash is a punctuation (non-word) character (that is,
+anything that is not a letter, digit or underscore), then the backslash
+just takes away the special meaning (if any) of the character following
+it.
+
+If the character following the backslash is a letter or a digit, then the
+sequence may be special; if so, it's listed below. A few letters have not
+been used yet, and escaping them with a backslash is safe for now, but a
+future version of Perl may assign a special meaning to it. However, if you
+have warnings turned on, Perl will issue a warning if you use such a sequence.
+[1].
It is however guaranteed that backslash or escape sequences never have a
punctuation character following the backslash, not now, and not in a future
@@ -48,9 +50,9 @@ backslash.
=item [1]
-There is one exception. If you use an alphanumeric character as the
+There is one exception. If you use an alphanumerical character as the
delimiter of your pattern (which you probably shouldn't do for readability
-reasons), you have to escape the delimiter if you want to match
+reasons), you will have to escape the delimiter if you want to match
it. Perl won't warn then. See also L<perlop/Gory details of parsing
quoted constructs>.
@@ -59,67 +61,57 @@ quoted constructs>.
=head2 All the sequences and escapes
-Those not usable within a bracketed character class (like C<[\da-z]>) are marked
-as C<Not in [].>
-
- \000 Octal escape sequence. See also \o{}.
- \1 Absolute backreference. Not in [].
+ \000 Octal escape sequence.
+ \1 Absolute backreference.
\a Alarm or bell.
- \A Beginning of string. Not in [].
- \b Word/non-word boundary. (Backspace in []).
- \B Not a word/non-word boundary. Not in [].
- \cX Control-X.
- \C Single octet, even under UTF-8. Not in [].
- (Deprecated)
+ \A Beginning of string.
+ \b Word/non-word boundary. (Backspace in a char class).
+ \B Not a word/non-word boundary.
+ \cX Control-X (X can be any ASCII character).
+ \C Single octet, even under UTF-8.
\d Character class for digits.
\D Character class for non-digits.
\e Escape character.
- \E Turn off \Q, \L and \U processing. Not in [].
+ \E Turn off \Q, \L and \U processing.
\f Form feed.
- \F Foldcase till \E. Not in [].
\g{}, \g1 Named, absolute or relative backreference.
- Not in [].
- \G Pos assertion. Not in [].
- \h Character class for horizontal whitespace.
- \H Character class for non horizontal whitespace.
- \k{}, \k<>, \k'' Named backreference. Not in [].
- \K Keep the stuff left of \K. Not in [].
- \l Lowercase next character. Not in [].
- \L Lowercase till \E. Not in [].
+ \G Pos assertion.
+ \h Character class for horizontal white space.
+ \H Character class for non horizontal white space.
+ \k{}, \k<>, \k'' Named backreference.
+ \K Keep the stuff left of \K.
+ \l Lowercase next character.
+ \L Lowercase till \E.
\n (Logical) newline character.
- \N Any character but newline. Not in [].
- \N{} Named or numbered (Unicode) character or sequence.
- \o{} Octal escape sequence.
- \p{}, \pP Character with the given Unicode property.
- \P{}, \PP Character without the given Unicode property.
- \Q Quote (disable) pattern metacharacters till \E. Not
- in [].
+ \N{} Named (Unicode) character.
+ \p{}, \pP Character with a Unicode property.
+ \P{}, \PP Character without a Unicode property.
+ \Q Quotemeta till \E.
\r Return character.
- \R Generic new line. Not in [].
- \s Character class for whitespace.
- \S Character class for non whitespace.
+ \R Generic new line.
+ \s Character class for white space.
+ \S Character class for non white space.
\t Tab character.
- \u Titlecase next character. Not in [].
- \U Uppercase till \E. Not in [].
- \v Character class for vertical whitespace.
- \V Character class for non vertical whitespace.
+ \u Titlecase next character.
+ \U Uppercase till \E.
+ \v Character class for vertical white space.
+ \V Character class for non vertical white space.
\w Character class for word characters.
\W Character class for non-word characters.
\x{}, \x00 Hexadecimal escape sequence.
- \X Unicode "extended grapheme cluster". Not in [].
- \z End of string. Not in [].
- \Z End of string. Not in [].
+ \X Extended Unicode "combining character sequence".
+ \z End of string.
+ \Z End of string.
=head2 Character Escapes
=head3 Fixed characters
A handful of characters have a dedicated I<character escape>. The following
-table shows them, along with their ASCII code points (in decimal and hex),
-their ASCII name, the control escape on ASCII platforms and a short
-description. (For EBCDIC platforms, see L<perlebcdic/OPERATOR DIFFERENCES>.)
+table shows them, along with their code points (in decimal and hex), their
+ASCII name, the control escape (see below) and a short description.
- Seq. Code Point ASCII Cntrl Description.
+ Seq. Code Point ASCII Cntr Description.
Dec Hex
\a 7 07 BEL \cG alarm or bell
\b 8 08 BS \cH backspace [1]
@@ -133,13 +125,13 @@ description. (For EBCDIC platforms, see L<perlebcdic/OPERATOR DIFFERENCES>.)
=item [1]
-C<\b> is the backspace character only inside a character class. Outside a
+C<\b> is only the backspace character inside a character class. Outside a
character class, C<\b> is a word/non-word boundary.
=item [2]
-C<\n> matches a logical newline. Perl converts between C<\n> and your
-OS's native newline character when reading from or writing to text files.
+C<\n> matches a logical newline. Perl will convert between C<\n> and your
+OSses native newline character when reading from or writing to text files.
=back
@@ -150,18 +142,10 @@ OS's native newline character when reading from or writing to text files.
=head3 Control characters
C<\c> is used to denote a control character; the character following C<\c>
-determines the value of the construct. For example the value of C<\cA> is
-C<chr(1)>, and the value of C<\cb> is C<chr(2)>, etc.
-The gory details are in L<perlop/"Regexp Quote-Like Operators">. A complete
-list of what C<chr(1)>, etc. means for ASCII and EBCDIC platforms is in
-L<perlebcdic/OPERATOR DIFFERENCES>.
-
-Note that C<\c\> alone at the end of a regular expression (or doubled-quoted
-string) is not valid. The backslash must be followed by another character.
-That is, C<\c\I<X>> means C<chr(28) . 'I<X>'> for all characters I<X>.
-
-To write platform-independent code, you must use C<\N{I<NAME>}> instead, like
-C<\N{ESCAPE}> or C<\N{U+001B}>, see L<charnames>.
+is the name of the control character. For instance, C</\cM/> matches the
+character I<control-M> (a carriage return, code point 13). The case of the
+character following C<\c> doesn't matter: C<\cM> and C<\cm> match the same
+character.
Mnemonic: I<c>ontrol character.
@@ -169,41 +153,20 @@ Mnemonic: I<c>ontrol character.
$str =~ /\cK/; # Matches if $str contains a vertical tab (control-K).
-=head3 Named or numbered characters and character sequences
-
-Unicode characters have a Unicode name and numeric code point (ordinal)
-value. Use the
-C<\N{}> construct to specify a character by either of these values.
-Certain sequences of characters also have names.
-
-To specify by name, the name of the character or character sequence goes
-between the curly braces.
-
-To specify a character by Unicode code point, use the form C<\N{U+I<code
-point>}>, where I<code point> is a number in hexadecimal that gives the
-code point that Unicode has assigned to the desired character. It is
-customary but not required to use leading zeros to pad the number to 4
-digits. Thus C<\N{U+0041}> means C<LATIN CAPITAL LETTER A>, and you will
-rarely see it written without the two leading zeros. C<\N{U+0041}> means
-"A" even on EBCDIC machines (where the ordinal value of "A" is not 0x41).
-
-It is even possible to give your own names to characters and character
-sequences. For details, see L<charnames>.
+=head3 Named characters
-(There is an expanded internal form that you may see in debug output:
-C<\N{U+I<code point>.I<code point>...}>.
-The C<...> means any number of these I<code point>s separated by dots.
-This represents the sequence formed by the characters. This is an internal
-form only, subject to change, and you should not try to use it yourself.)
+All Unicode characters have a Unicode name, and characters in various scripts
+have names as well. It is even possible to give your own names to characters.
+You can use a character by name by using the C<\N{}> construct; the name of
+the character goes between the curly braces. You do have to C<use charnames>
+to load the names of the characters, otherwise Perl will complain you use
+a name it doesn't know about. For more details, see L<charnames>.
Mnemonic: I<N>amed character.
-Note that a character or character sequence expressed as a named
-or numbered character is considered a character without special
-meaning by the regex engine, and will match "as is".
-
=head4 Example
+ use charnames ':full'; # Loads the Unicode names.
$str =~ /\N{THAI CHARACTER SO SO}/; # Matches the Thai SO SO character
use charnames 'Cyrillic'; # Loads Cyrillic names.
@@ -211,57 +174,29 @@ meaning by the regex engine, and will match "as is".
=head3 Octal escapes
-There are two forms of octal escapes. Each is used to specify a character by
-its code point specified in octal notation.
-
-One form, available starting in Perl 5.14 looks like C<\o{...}>, where the dots
-represent one or more octal digits. It can be used for any Unicode character.
-
-It was introduced to avoid the potential problems with the other form,
-available in all Perls. That form consists of a backslash followed by three
-octal digits. One problem with this form is that it can look exactly like an
-old-style backreference (see
-L</Disambiguation rules between old-style octal escapes and backreferences>
-below.) You can avoid this by making the first of the three digits always a
-zero, but that makes \077 the largest code point specifiable.
-
-In some contexts, a backslash followed by two or even one octal digits may be
-interpreted as an octal escape, sometimes with a warning, and because of some
-bugs, sometimes with surprising results. Also, if you are creating a regex
-out of smaller snippets concatenated together, and you use fewer than three
-digits, the beginning of one snippet may be interpreted as adding digits to the
-ending of the snippet before it. See L</Absolute referencing> for more
-discussion and examples of the snippet problem.
-
-Note that a character expressed as an octal escape is considered
-a character without special meaning by the regex engine, and will match
+Octal escapes consist of a backslash followed by two or three octal digits
+matching the code point of the character you want to use. This allows for
+512 characters (C<\00> up to C<\777>) that can be expressed this way.
+Enough in pre-Unicode days, but most Unicode characters cannot be escaped
+this way.
+
+Note that a character that is expressed as an octal escape is considered
+as a character without special meaning by the regex engine, and will match
"as is".
-To summarize, the C<\o{}> form is always safe to use, and the other form is
-safe to use for code points through \077 when you use exactly three digits to
-specify them.
+=head4 Examples
-Mnemonic: I<0>ctal or I<o>ctal.
+ $str = "Perl";
+ $str =~ /\120/; # Match, "\120" is "P".
+ $str =~ /\120+/; # Match, "\120" is "P", it is repeated at least once.
+ $str =~ /P\053/; # No match, "\053" is "+" and taken literally.
-=head4 Examples (assuming an ASCII platform)
+=head4 Caveat
- $str = "Perl";
- $str =~ /\o{120}/; # Match, "\120" is "P".
- $str =~ /\120/; # Same.
- $str =~ /\o{120}+/; # Match, "\120" is "P",
- # it's repeated at least once.
- $str =~ /\120+/; # Same.
- $str =~ /P\053/; # No match, "\053" is "+" and taken literally.
- /\o{23073}/ # Black foreground, white background smiling face.
- /\o{4801234567}/ # Raises a warning, and yields chr(4).
-
-=head4 Disambiguation rules between old-style octal escapes and backreferences
-
-Octal escapes of the C<\000> form outside of bracketed character classes
-potentially clash with old-style backreferences (see L</Absolute referencing>
-below). They both consist of a backslash followed by numbers. So Perl has to
-use heuristics to determine whether it is a backreference or an octal escape.
-Perl uses the following rules to disambiguate:
+Octal escapes potentially clash with backreferences. They both consist
+of a backslash followed by numbers. So Perl has to use heuristics to
+determine whether it is a backreference or an octal escape. Perl uses
+the following rules:
=over 4
@@ -275,44 +210,39 @@ If the first digit following the backslash is a 0, it's an octal escape.
=item 3
-If the number following the backslash is N (in decimal), and Perl already
-has seen N capture groups, Perl considers this a backreference. Otherwise,
-it considers it an octal escape. If N has more than three digits, Perl
-takes only the first three for the octal escape; the rest are matched as is.
+If the number following the backslash is N (decimal), and Perl already has
+seen N capture groups, Perl will consider this to be a backreference.
+Otherwise, it will consider it to be an octal escape. Note that if N > 999,
+Perl only takes the first three digits for the octal escape; the rest is
+matched as is.
my $pat = "(" x 999;
$pat .= "a";
$pat .= ")" x 999;
/^($pat)\1000$/; # Matches 'aa'; there are 1000 capture groups.
/^$pat\1000$/; # Matches 'a@0'; there are 999 capture groups
- # and \1000 is seen as \100 (a '@') and a '0'.
+ # and \1000 is seen as \100 (a '@') and a '0'.
=back
-You can force a backreference interpretation always by using the C<\g{...}>
-form. You can the force an octal interpretation always by using the C<\o{...}>
-form, or for numbers up through \077 (= 63 decimal), by using three digits,
-beginning with a "0".
-
=head3 Hexadecimal escapes
-Like octal escapes, there are two forms of hexadecimal escapes, but both start
-with the same thing, C<\x>. This is followed by either exactly two hexadecimal
-digits forming a number, or a hexadecimal number of arbitrary length surrounded
-by curly braces. The hexadecimal number is the code point of the character you
-want to express.
+Hexadecimal escapes start with C<\x> and are then either followed by
+two digit hexadecimal number, or a hexadecimal number of arbitrary length
+surrounded by curly braces. The hexadecimal number is the code point of
+the character you want to express.
-Note that a character expressed as one of these escapes is considered a
-character without special meaning by the regex engine, and will match
+Note that a character that is expressed as a hexadecimal escape is considered
+as a character without special meaning by the regex engine, and will match
"as is".
Mnemonic: heI<x>adecimal.
-=head4 Examples (assuming an ASCII platform)
+=head4 Examples
$str = "Perl";
$str =~ /\x50/; # Match, "\x50" is "P".
- $str =~ /\x50+/; # Match, "\x50" is "P", it is repeated at least once
+ $str =~ /\x50+/; # Match, "\x50" is "P", it is repeated at least once.
$str =~ /P\x2B/; # No match, "\x2B" is "+" and taken literally.
/\x{2603}\x{2602}/ # Snowman with an umbrella.
@@ -326,29 +256,22 @@ Mnemonic: heI<x>adecimal.
A number of backslash sequences have to do with changing the character,
or characters following them. C<\l> will lowercase the character following
it, while C<\u> will uppercase (or, more accurately, titlecase) the
-character following it. They provide functionality similar to the
-functions C<lcfirst> and C<ucfirst>.
+character following it. (They perform similar functionality as the
+functions C<lcfirst> and C<ucfirst>).
To uppercase or lowercase several characters, one might want to use
C<\L> or C<\U>, which will lowercase/uppercase all characters following
-them, until either the end of the pattern or the next occurrence of
-C<\E>, whichever comes first. They provide functionality similar to what
-the functions C<lc> and C<uc> provide.
-
-C<\Q> is used to quote (disable) pattern metacharacters, up to the next
-C<\E> or the end of the pattern. C<\Q> adds a backslash to any character
-that could have special meaning to Perl. In the ASCII range, it quotes
-every character that isn't a letter, digit, or underscore. See
-L<perlfunc/quotemeta> for details on what gets quoted for non-ASCII
-code points. Using this ensures that any character between C<\Q> and
-C<\E> will be matched literally, not interpreted as a metacharacter by
-the regex engine.
+them, until either the end of the pattern, or the next occurrence of
+C<\E>, whatever comes first. They perform similar functionality as the
+functions C<lc> and C<uc> do.
-C<\F> can be used to casefold all characters following, up to the next C<\E>
-or the end of the pattern. It provides the functionality similar to
-the C<fc> function.
+C<\Q> is used to escape all characters following, up to the next C<\E>
+or the end of the pattern. C<\Q> adds a backslash to any character that
+isn't a letter, digit or underscore. This will ensure that any character
+between C<\Q> and C<\E> is matched literally, and will not be interpreted
+by the regexp engine.
-Mnemonic: I<L>owercase, I<U>ppercase, I<F>old-case, I<Q>uotemeta, I<E>nd.
+Mnemonic: I<L>owercase, I<U>ppercase, I<Q>uotemeta, I<E>nd.
=head4 Examples
@@ -367,22 +290,15 @@ the character classes are written as a backslash sequence. We will briefly
discuss those here; full details of character classes can be found in
L<perlrecharclass>.
-C<\w> is a character class that matches any single I<word> character
-(letters, digits, Unicode marks, and connector punctuation (like the
-underscore)). C<\d> is a character class that matches any decimal
-digit, while the character class C<\s> matches any whitespace character.
+C<\w> is a character class that matches any I<word> character (letters,
+digits, underscore). C<\d> is a character class that matches any digit,
+while the character class C<\s> matches any white space character.
New in perl 5.10.0 are the classes C<\h> and C<\v> which match horizontal
-and vertical whitespace characters.
-
-The exact set of characters matched by C<\d>, C<\s>, and C<\w> varies
-depending on various pragma and regular expression modifiers. It is
-possible to restrict the match to the ASCII range by using the C</a>
-regular expression modifier. See L<perlrecharclass>.
+and vertical white space characters.
The uppercase variants (C<\W>, C<\D>, C<\S>, C<\H>, and C<\V>) are
-character classes that match, respectively, any character that isn't a
-word character, digit, whitespace, horizontal whitespace, or vertical
-whitespace.
+character classes that match any character that isn't a word character,
+digit, white space, horizontal white space or vertical white space.
Mnemonics: I<w>ord, I<d>igit, I<s>pace, I<h>orizontal, I<v>ertical.
@@ -393,11 +309,12 @@ match a character that matches the given Unicode property; properties
include things like "letter", or "thai character". Capitalizing the
sequence to C<\PP> and C<\P{Property}> make the sequence match a character
that doesn't match the given Unicode property. For more details, see
-L<perlrecharclass/Backslash sequences> and
+L<perlrecharclass/Backslashed sequences> and
L<perlunicode/Unicode Character Properties>.
Mnemonic: I<p>roperty.
+
=head2 Referencing
If capturing parenthesis are used in a regular expression, we can refer
@@ -409,51 +326,41 @@ absolutely, relatively, and by name.
=head3 Absolute referencing
-Either C<\gI<N>> (starting in Perl 5.10.0), or C<\I<N>> (old-style) where I<N>
-is a positive (unsigned) decimal number of any length is an absolute reference
-to a capturing group.
-
-I<N> refers to the Nth set of parentheses, so C<\gI<N>> refers to whatever has
-been matched by that set of parentheses. Thus C<\g1> refers to the first
-capture group in the regex.
-
-The C<\gI<N>> form can be equivalently written as C<\g{I<N>}>
-which avoids ambiguity when building a regex by concatenating shorter
-strings. Otherwise if you had a regex C<qr/$a$b/>, and C<$a> contained
-C<"\g1">, and C<$b> contained C<"37">, you would get C</\g137/> which is
-probably not what you intended.
-
-In the C<\I<N>> form, I<N> must not begin with a "0", and there must be at
-least I<N> capturing groups, or else I<N> is considered an octal escape
-(but something like C<\18> is the same as C<\0018>; that is, the octal escape
-C<"\001"> followed by a literal digit C<"8">).
-
-Mnemonic: I<g>roup.
+A backslash sequence that starts with a backslash and is followed by a
+number is an absolute reference (but be aware of the caveat mentioned above).
+If the number is I<N>, it refers to the Nth set of parenthesis - whatever
+has been matched by that set of parenthesis has to be matched by the C<\N>
+as well.
=head4 Examples
- /(\w+) \g1/; # Finds a duplicated word, (e.g. "cat cat").
- /(\w+) \1/; # Same thing; written old-style.
- /(.)(.)\g2\g1/; # Match a four letter palindrome (e.g. "ABBA").
+ /(\w+) \1/; # Finds a duplicated word, (e.g. "cat cat").
+ /(.)(.)\2\1/; # Match a four letter palindrome (e.g. "ABBA").
=head3 Relative referencing
-C<\g-I<N>> (starting in Perl 5.10.0) is used for relative addressing. (It can
-be written as C<\g{-I<N>>.) It refers to the I<N>th group before the
-C<\g{-I<N>}>.
+New in perl 5.10.0 is a different way of referring to capture buffers: C<\g>.
+C<\g> takes a number as argument, with the number in curly braces (the
+braces are optional). If the number (N) does not have a sign, it's a reference
+to the Nth capture group (so C<\g{2}> is equivalent to C<\2> - except that
+C<\g> always refers to a capture group and will never be seen as an octal
+escape). If the number is negative, the reference is relative, referring to
+the Nth group before the C<\g{-N}>.
-The big advantage of this form is that it makes it much easier to write
+The big advantage of C<\g{-N}> is that it makes it much easier to write
patterns with references that can be interpolated in larger patterns,
even if the larger pattern also contains capture groups.
+Mnemonic: I<g>roup.
+
=head4 Examples
- /(A) # Group 1
- ( # Group 2
- (B) # Group 3
- \g{-1} # Refers to group 3 (B)
- \g{-3} # Refers to group 1 (A)
+ /(A) # Buffer 1
+ ( # Buffer 2
+ (B) # Buffer 3
+ \g{-1} # Refers to buffer 3 (B)
+ \g{-3} # Refers to buffer 1 (A)
)
/x; # Matches "ABBA".
@@ -462,15 +369,17 @@ even if the larger pattern also contains capture groups.
=head3 Named referencing
-C<\g{I<name>}> (starting in Perl 5.10.0) can be used to back refer to a
-named capture group, dispensing completely with having to think about capture
-buffer positions.
+Also new in perl 5.10.0 is the use of named capture buffers, which can be
+referred to by name. This is done with C<\g{name}>, which is a
+backreference to the capture buffer with the name I<name>.
To be compatible with .Net regular expressions, C<\g{name}> may also be
written as C<\k{name}>, C<< \k<name> >> or C<\k'name'>.
-To prevent any ambiguity, I<name> must not start with a digit nor contain a
-hyphen.
+Note that C<\g{}> has the potential to be ambiguous, as it could be a named
+reference, or an absolute or relative reference (if its argument is numeric).
+However, names are not allowed to start with digits, nor are allowed to
+contain a hyphen, so there is no ambiguity.
=head4 Examples
@@ -482,7 +391,7 @@ hyphen.
=head2 Assertions
-Assertions are conditions that have to be true; they don't actually
+Assertions are conditions that have to be true -- they don't actually
match parts of the substring. There are six assertions that are written as
backslash sequences.
@@ -491,7 +400,7 @@ backslash sequences.
=item \A
C<\A> only matches at the beginning of the string. If the C</m> modifier
-isn't used, then C</\A/> is equivalent to C</^/>. However, if the C</m>
+isn't used, then C</\A/> is equivalent with C</^/>. However, if the C</m>
modifier is used, then C</^/> matches internal newlines, but the meaning
of C</\A/> isn't changed by the C</m> modifier. C<\A> matches at the beginning
of the string regardless whether the C</m> modifier is used.
@@ -499,27 +408,26 @@ of the string regardless whether the C</m> modifier is used.
=item \z, \Z
C<\z> and C<\Z> match at the end of the string. If the C</m> modifier isn't
-used, then C</\Z/> is equivalent to C</$/>; that is, it matches at the
-end of the string, or one before the newline at the end of the string. If the
+used, then C</\Z/> is equivalent with C</$/>, that is, it matches at the
+end of the string, or before the newline at the end of the string. If the
C</m> modifier is used, then C</$/> matches at internal newlines, but the
meaning of C</\Z/> isn't changed by the C</m> modifier. C<\Z> matches at
the end of the string (or just before a trailing newline) regardless whether
the C</m> modifier is used.
-C<\z> is just like C<\Z>, except that it does not match before a trailing
-newline. C<\z> matches at the end of the string only, regardless of the
-modifiers used, and not just before a newline. It is how to anchor the
-match to the true end of the string under all conditions.
+C<\z> is just like C<\Z>, except that it will not match before a trailing
+newline. C<\z> will only match at the end of the string - regardless of the
+modifiers used, and not before a newline.
=item \G
-C<\G> is usually used only in combination with the C</g> modifier. If the
-C</g> modifier is used and the match is done in scalar context, Perl
-remembers where in the source string the last match ended, and the next time,
+C<\G> is usually only used in combination with the C</g> modifier. If the
+C</g> modifier is used (and the match is done in scalar context), Perl will
+remember where in the source string the last match ended, and the next time,
it will start the match from where it ended the previous time.
-C<\G> matches the point where the previous match on that string ended,
-or the beginning of that string if there was no previous match.
+C<\G> matches the point where the previous match ended, or the beginning
+of the string if there was no previous match.
=for later add link to perlremodifiers
@@ -532,17 +440,7 @@ matches at any place between characters where C<\b> doesn't match. C<\b>
and C<\B> assume there's a non-word character before the beginning and after
the end of the source string; so C<\b> will match at the beginning (or end)
of the source string if the source string begins (or ends) with a word
-character. Otherwise, C<\B> will match.
-
-Do not use something like C<\b=head\d\b> and expect it to match the
-beginning of a line. It can't, because for there to be a boundary before
-the non-word "=", there must be a word character immediately previous.
-All boundary determinations look for word characters alone, not for
-non-words characters nor for string ends. It may help to understand how
-<\b> and <\B> work by equating them as follows:
-
- \b really means (?:(?<=\w)(?!\w)|(?<!\w)(?=\w))
- \B really means (?:(?<=\w)(?=\w)|(?<!\w)(?!\w))
+character. Otherwise, C<\B> will match.
Mnemonic: I<b>oundary.
@@ -570,85 +468,56 @@ Mnemonic: I<b>oundary.
=head2 Misc
Here we document the backslash sequences that don't fall in one of the
-categories above. These are:
+categories above. They are:
=over 4
=item \C
-(Deprecated.) C<\C> always matches a single octet, even if the source
-string is encoded
+C<\C> always matches a single octet, even if the source string is encoded
in UTF-8 format, and the character to be matched is a multi-octet character.
-This is very dangerous, because it violates
-the logical character abstraction and can cause UTF-8 sequences to become malformed.
-
-Use C<utf8::encode()> instead.
+C<\C> was introduced in perl 5.6.
Mnemonic: oI<C>tet.
=item \K
-This appeared in perl 5.10.0. Anything matched left of C<\K> is
-not included in C<$&>, and will not be replaced if the pattern is
-used in a substitution. This lets you write C<s/PAT1 \K PAT2/REPL/x>
+This is new in perl 5.10.0. Anything that is matched left of C<\K> is
+not included in C<$&> - and will not be replaced if the pattern is
+used in a substitution. This will allow you to write C<s/PAT1 \K PAT2/REPL/x>
instead of C<s/(PAT1) PAT2/${1}REPL/x> or C<s/(?<=PAT1) PAT2/REPL/x>.
Mnemonic: I<K>eep.
-=item \N
-
-This feature, available starting in v5.12, matches any character
-that is B<not> a newline. It is a short-hand for writing C<[^\n]>, and is
-identical to the C<.> metasymbol, except under the C</s> flag, which changes
-the meaning of C<.>, but not C<\N>.
-
-Note that C<\N{...}> can mean a
-L<named or numbered character
-|/Named or numbered characters and character sequences>.
-
-Mnemonic: Complement of I<\n>.
-
=item \R
-X<\R>
-
-C<\R> matches a I<generic newline>; that is, anything considered a
-linebreak sequence by Unicode. This includes all characters matched by
-C<\v> (vertical whitespace), and the multi character sequence C<"\x0D\x0A">
-(carriage return followed by a line feed, sometimes called the network
-newline; it's the end of line sequence used in Microsoft text files opened
-in binary mode). C<\R> is equivalent to C<< (?>\x0D\x0A|\v) >>. (The
-reason it doesn't backtrack is that the sequence is considered
-inseparable. That means that
- "\x0D\x0A" =~ /^\R\x0A$/ # No match
-
-fails, because the C<\R> matches the entire string, and won't backtrack
-to match just the C<"\x0D">.) Since
-C<\R> can match a sequence of more than one character, it cannot be put
-inside a bracketed character class; C</[\R]/> is an error; use C<\v>
-instead. C<\R> was introduced in perl 5.10.0.
-
-Note that this does not respect any locale that might be in effect; it
-matches according to the platform's native character set.
+C<\R> matches a I<generic newline>, that is, anything that is considered
+a newline by Unicode. This includes all characters matched by C<\v>
+(vertical white space), and the multi character sequence C<"\x0D\x0A">
+(carriage return followed by a line feed, aka the network newline, or
+the newline used in Windows text files). C<\R> is equivalent with
+C<< (?>\x0D\x0A)|\v) >>. Since C<\R> can match a more than one character,
+it cannot be put inside a bracketed character class; C</[\R]/> is an error.
+C<\R> was introduced in perl 5.10.0.
Mnemonic: none really. C<\R> was picked because PCRE already uses C<\R>,
and more importantly because Unicode recommends such a regular expression
-metacharacter, and suggests C<\R> as its notation.
+metacharacter, and suggests C<\R> as the notation.
=item \X
-X<\X>
-This matches a Unicode I<extended grapheme cluster>.
+This matches an extended Unicode I<combining character sequence>, and
+is equivalent to C<< (?>\PM\pM*) >>. C<\PM> matches any character that is
+not considered a Unicode mark character, while C<\pM> matches any character
+that is considered a Unicode mark character; so C<\X> matches any non
+mark character followed by zero or more mark characters. Mark characters
+include (but are not restricted to) I<combining characters> and
+I<vowel signs>.
C<\X> matches quite well what normal (non-Unicode-programmer) usage
-would consider a single character. As an example, consider a G with some sort
-of diacritic mark, such as an arrow. There is no such single character in
-Unicode, but one can be composed by using a G followed by a Unicode "COMBINING
-UPWARDS ARROW BELOW", and would be displayed by Unicode-aware software as if it
-were a single character.
-
-The match is greedy and non-backtracking, so that the cluster is never
-broken up into smaller components.
+would consider a single character: for example a base character
+(the C<\PM> above), for example a letter, followed by zero or more
+diacritics, which are I<combining characters> (the C<\pM*> above).
Mnemonic: eI<X>tended Unicode character.
@@ -656,13 +525,15 @@ Mnemonic: eI<X>tended Unicode character.
=head4 Examples
- $str =~ s/foo\Kbar/baz/g; # Change any 'bar' following a 'foo' to 'baz'
- $str =~ s/(.)\K\g1//g; # Delete duplicated characters.
+ "\x{256}" =~ /^\C\C$/; # Match as chr (256) takes 2 octets in UTF-8.
+
+ $str =~ s/foo\Kbar/baz/g; # Change any 'bar' following a 'foo' to 'baz'.
+ $str =~ s/(.)\K\1//g; # Delete duplicated characters.
"\n" =~ /^\R$/; # Match, \n is a generic newline.
"\r" =~ /^\R$/; # Match, \r is a generic newline.
"\r\n" =~ /^\R$/; # Match, \r\n is a generic newline.
- "P\x{307}" =~ /^\X$/ # \X matches a P with a dot above.
+ "P\x{0307}" =~ /^\X$/ # \X matches a P with a dot above.
=cut
diff --git a/gnu/usr.bin/perl/pod/perlrecharclass.pod b/gnu/usr.bin/perl/pod/perlrecharclass.pod
index 5e823323d21..4af2c9793d7 100644
--- a/gnu/usr.bin/perl/pod/perlrecharclass.pod
+++ b/gnu/usr.bin/perl/pod/perlrecharclass.pod
@@ -1,5 +1,4 @@
=head1 NAME
-X<character class>
perlrecharclass - Perl Regular Expression Character Classes
@@ -9,29 +8,25 @@ The top level documentation about Perl regular expressions
is found in L<perlre>.
This manual page discusses the syntax and use of character
-classes in Perl regular expressions.
+classes in Perl Regular Expressions.
-A character class is a way of denoting a set of characters
+A character class is a way of denoting a set of characters,
in such a way that one character of the set is matched.
-It's important to remember that: matching a character class
+It's important to remember that matching a character class
consumes exactly one character in the source string. (The source
string is the string the regular expression is matched against.)
There are three types of character classes in Perl regular
-expressions: the dot, backslash sequences, and the form enclosed in square
-brackets. Keep in mind, though, that often the term "character class" is used
-to mean just the bracketed form. Certainly, most Perl documentation does that.
+expressions: the dot, backslashed sequences, and the bracketed form.
=head2 The dot
The dot (or period), C<.> is probably the most used, and certainly
the most well-known character class. By default, a dot matches any
-character, except for the newline. That default can be changed to
-add matching the newline by using the I<single line> modifier: either
-for the entire regular expression with the C</s> modifier, or
-locally with C<(?s)>. (The C<L</\N>> backslash sequence, described
-below, matches any character except newline without regard to the
-I<single line> modifier.)
+character, except for the newline. The default can be changed to
+add matching the newline with the I<single line> modifier: either
+for the entire regular expression using the C</s> modifier, or
+locally using C<(?s)>.
Here are some examples:
@@ -43,367 +38,171 @@ Here are some examples:
"\n" =~ /(?s:.)/ # Match (local 'single line' modifier)
"ab" =~ /^.$/ # No match (dot matches one character)
-=head2 Backslash sequences
-X<\w> X<\W> X<\s> X<\S> X<\d> X<\D> X<\p> X<\P>
-X<\N> X<\v> X<\V> X<\h> X<\H>
-X<word> X<whitespace>
-A backslash sequence is a sequence of characters, the first one of which is a
-backslash. Perl ascribes special meaning to many such sequences, and some of
-these are character classes. That is, they match a single character each,
-provided that the character belongs to the specific set of characters defined
-by the sequence.
+=head2 Backslashed sequences
-Here's a list of the backslash sequences that are character classes. They
-are discussed in more detail below. (For the backslash sequences that aren't
-character classes, see L<perlrebackslash>.)
+Perl regular expressions contain many backslashed sequences that
+constitute a character class. That is, they will match a single
+character, if that character belongs to a specific set of characters
+(defined by the sequence). A backslashed sequence is a sequence of
+characters starting with a backslash. Not all backslashed sequences
+are character class; for a full list, see L<perlrebackslash>.
- \d Match a decimal digit character.
- \D Match a non-decimal-digit character.
+Here's a list of the backslashed sequences, which are discussed in
+more detail below.
+
+ \d Match a digit character.
+ \D Match a non-digit character.
\w Match a "word" character.
\W Match a non-"word" character.
- \s Match a whitespace character.
- \S Match a non-whitespace character.
- \h Match a horizontal whitespace character.
- \H Match a character that isn't horizontal whitespace.
- \v Match a vertical whitespace character.
- \V Match a character that isn't vertical whitespace.
- \N Match a character that isn't a newline.
- \pP, \p{Prop} Match a character that has the given Unicode property.
- \PP, \P{Prop} Match a character that doesn't have the Unicode property
-
-=head3 \N
-
-C<\N>, available starting in v5.12, like the dot, matches any
-character that is not a newline. The difference is that C<\N> is not influenced
-by the I<single line> regular expression modifier (see L</The dot> above). Note
-that the form C<\N{...}> may mean something completely different. When the
-C<{...}> is a L<quantifier|perlre/Quantifiers>, it means to match a non-newline
-character that many times. For example, C<\N{3}> means to match 3
-non-newlines; C<\N{5,}> means to match 5 or more non-newlines. But if C<{...}>
-is not a legal quantifier, it is presumed to be a named character. See
-L<charnames> for those. For example, none of C<\N{COLON}>, C<\N{4F}>, and
-C<\N{F4}> contain legal quantifiers, so Perl will try to find characters whose
-names are respectively C<COLON>, C<4F>, and C<F4>.
+ \s Match a white space character.
+ \S Match a non-white space character.
+ \h Match a horizontal white space character.
+ \H Match a character that isn't horizontal white space.
+ \v Match a vertical white space character.
+ \V Match a character that isn't vertical white space.
+ \pP, \p{Prop} Match a character matching a Unicode property.
+ \PP, \P{Prop} Match a character that doesn't match a Unicode property.
=head3 Digits
-C<\d> matches a single character considered to be a decimal I<digit>.
-If the C</a> regular expression modifier is in effect, it matches [0-9].
-Otherwise, it
-matches anything that is matched by C<\p{Digit}>, which includes [0-9].
-(An unlikely possible exception is that under locale matching rules, the
-current locale might not have C<[0-9]> matched by C<\d>, and/or might match
-other characters whose code point is less than 256. The only such locale
-definitions that are legal would be to match C<[0-9]> plus another set of
-10 consecutive digit characters; anything else would be in violation of
-the C language standard, but Perl doesn't currently assume anything in
-regard to this.)
-
-What this means is that unless the C</a> modifier is in effect C<\d> not
-only matches the digits '0' - '9', but also Arabic, Devanagari, and
-digits from other languages. This may cause some confusion, and some
-security issues.
-
-Some digits that C<\d> matches look like some of the [0-9] ones, but
-have different values. For example, BENGALI DIGIT FOUR (U+09EA) looks
-very much like an ASCII DIGIT EIGHT (U+0038). An application that
-is expecting only the ASCII digits might be misled, or if the match is
-C<\d+>, the matched string might contain a mixture of digits from
-different writing systems that look like they signify a number different
-than they actually do. L<Unicode::UCD/num()> can
-be used to safely
-calculate the value, returning C<undef> if the input string contains
-such a mixture.
-
-What C<\p{Digit}> means (and hence C<\d> except under the C</a>
-modifier) is C<\p{General_Category=Decimal_Number}>, or synonymously,
-C<\p{General_Category=Digit}>. Starting with Unicode version 4.1, this
-is the same set of characters matched by C<\p{Numeric_Type=Decimal}>.
-But Unicode also has a different property with a similar name,
-C<\p{Numeric_Type=Digit}>, which matches a completely different set of
-characters. These characters are things such as C<CIRCLED DIGIT ONE>
-or subscripts, or are from writing systems that lack all ten digits.
-
-The design intent is for C<\d> to exactly match the set of characters
-that can safely be used with "normal" big-endian positional decimal
-syntax, where, for example 123 means one 'hundred', plus two 'tens',
-plus three 'ones'. This positional notation does not necessarily apply
-to characters that match the other type of "digit",
-C<\p{Numeric_Type=Digit}>, and so C<\d> doesn't match them.
-
-The Tamil digits (U+0BE6 - U+0BEF) can also legally be
-used in old-style Tamil numbers in which they would appear no more than
-one in a row, separated by characters that mean "times 10", "times 100",
-etc. (See L<http://www.unicode.org/notes/tn21>.)
-
-Any character not matched by C<\d> is matched by C<\D>.
-
-=head3 Word characters
-
-A C<\w> matches a single alphanumeric character (an alphabetic character, or a
-decimal digit); or a connecting punctuation character, such as an
-underscore ("_"); or a "mark" character (like some sort of accent) that
-attaches to one of those. It does not match a whole word. To match a
-whole word, use C<\w+>. This isn't the same thing as matching an
-English word, but in the ASCII range it is the same as a string of
-Perl-identifier characters.
-
-=over
-
-=item If the C</a> modifier is in effect ...
-
-C<\w> matches the 63 characters [a-zA-Z0-9_].
-
-=item otherwise ...
-
-=over
-
-=item For code points above 255 ...
-
-C<\w> matches the same as C<\p{Word}> matches in this range. That is,
-it matches Thai letters, Greek letters, etc. This includes connector
-punctuation (like the underscore) which connect two words together, or
-diacritics, such as a C<COMBINING TILDE> and the modifier letters, which
-are generally used to add auxiliary markings to letters.
-
-=item For code points below 256 ...
-
-=over
-
-=item if locale rules are in effect ...
-
-C<\w> matches the platform's native underscore character plus whatever
-the locale considers to be alphanumeric.
-
-=item if Unicode rules are in effect ...
-
-C<\w> matches exactly what C<\p{Word}> matches.
-
-=item otherwise ...
-
-C<\w> matches [a-zA-Z0-9_].
-
-=back
-
-=back
-
-=back
-
-Which rules apply are determined as described in L<perlre/Which character set modifier is in effect?>.
-
-There are a number of security issues with the full Unicode list of word
-characters. See L<http://unicode.org/reports/tr36>.
-
-Also, for a somewhat finer-grained set of characters that are in programming
-language identifiers beyond the ASCII range, you may wish to instead use the
-more customized L</Unicode Properties>, C<\p{ID_Start}>,
-C<\p{ID_Continue}>, C<\p{XID_Start}>, and C<\p{XID_Continue}>. See
-L<http://unicode.org/reports/tr31>.
-
-Any character not matched by C<\w> is matched by C<\W>.
-
-=head3 Whitespace
-
-C<\s> matches any single character considered whitespace.
-
-=over
-
-=item If the C</a> modifier is in effect ...
-
-In all Perl versions, C<\s> matches the 5 characters [\t\n\f\r ]; that
-is, the horizontal tab,
-the newline, the form feed, the carriage return, and the space.
-Starting in Perl v5.18, experimentally, it also matches the vertical tab, C<\cK>.
-See note C<[1]> below for a discussion of this.
-
-=item otherwise ...
-
-=over
-
-=item For code points above 255 ...
-
-C<\s> matches exactly the code points above 255 shown with an "s" column
-in the table below.
-
-=item For code points below 256 ...
-
-=over
-
-=item if locale rules are in effect ...
-
-C<\s> matches whatever the locale considers to be whitespace.
-
-=item if Unicode rules are in effect ...
-
-C<\s> matches exactly the characters shown with an "s" column in the
-table below.
+C<\d> matches a single character that is considered to be a I<digit>.
+What is considered a digit depends on the internal encoding of
+the source string. If the source string is in UTF-8 format, C<\d>
+not only matches the digits '0' - '9', but also Arabic, Devanagari and
+digits from other languages. Otherwise, if there is a locale in effect,
+it will match whatever characters the locale considers digits. Without
+a locale, C<\d> matches the digits '0' to '9'.
+See L</Locale, Unicode and UTF-8>.
-=item otherwise ...
+Any character that isn't matched by C<\d> will be matched by C<\D>.
-C<\s> matches [\t\n\f\r ] and, starting, experimentally in Perl
-v5.18, the vertical tab, C<\cK>.
-(See note C<[1]> below for a discussion of this.)
-Note that this list doesn't include the non-breaking space.
-
-=back
-
-=back
-
-=back
-
-Which rules apply are determined as described in L<perlre/Which character set modifier is in effect?>.
-
-Any character not matched by C<\s> is matched by C<\S>.
-
-C<\h> matches any character considered horizontal whitespace;
-this includes the platform's space and tab characters and several others
-listed in the table below. C<\H> matches any character
-not considered horizontal whitespace. They use the platform's native
-character set, and do not consider any locale that may otherwise be in
-use.
+=head3 Word characters
-C<\v> matches any character considered vertical whitespace;
-this includes the platform's carriage return and line feed characters (newline)
-plus several other characters, all listed in the table below.
-C<\V> matches any character not considered vertical whitespace.
-They use the platform's native character set, and do not consider any
-locale that may otherwise be in use.
+C<\w> matches a single I<word> character: an alphanumeric character
+(that is, an alphabetic character, or a digit), or the underscore (C<_>).
+What is considered a word character depends on the internal encoding
+of the string. If it's in UTF-8 format, C<\w> matches those characters
+that are considered word characters in the Unicode database. That is, it
+not only matches ASCII letters, but also Thai letters, Greek letters, etc.
+If the source string isn't in UTF-8 format, C<\w> matches those characters
+that are considered word characters by the current locale. Without
+a locale in effect, C<\w> matches the ASCII letters, digits and the
+underscore.
+
+Any character that isn't matched by C<\w> will be matched by C<\W>.
+
+=head3 White space
+
+C<\s> matches any single character that is consider white space. In the
+ASCII range, C<\s> matches the horizontal tab (C<\t>), the new line
+(C<\n>), the form feed (C<\f>), the carriage return (C<\r>), and the
+space (the vertical tab, C<\cK> is not matched by C<\s>). The exact set
+of characters matched by C<\s> depends on whether the source string is
+in UTF-8 format. If it is, C<\s> matches what is considered white space
+in the Unicode database. Otherwise, if there is a locale in effect, C<\s>
+matches whatever is considered white space by the current locale. Without
+a locale, C<\s> matches the five characters mentioned in the beginning
+of this paragraph. Perhaps the most notable difference is that C<\s>
+matches a non-breaking space only if the non-breaking space is in a
+UTF-8 encoded string.
+
+Any character that isn't matched by C<\s> will be matched by C<\S>.
+
+C<\h> will match any character that is considered horizontal white space;
+this includes the space and the tab characters. C<\H> will match any character
+that is not considered horizontal white space.
+
+C<\v> will match any character that is considered vertical white space;
+this includes the carriage return and line feed characters (newline).
+C<\V> will match any character that is not considered vertical white space.
C<\R> matches anything that can be considered a newline under Unicode
rules. It's not a character class, as it can match a multi-character
sequence. Therefore, it cannot be used inside a bracketed character
-class; use C<\v> instead (vertical whitespace). It uses the platform's
-native character set, and does not consider any locale that may
-otherwise be in use.
-Details are discussed in L<perlrebackslash>.
+class. Details are discussed in L<perlrebackslash>.
+
+C<\h>, C<\H>, C<\v>, C<\V>, and C<\R> are new in perl 5.10.0.
-Note that unlike C<\s> (and C<\d> and C<\w>), C<\h> and C<\v> always match
-the same characters, without regard to other factors, such as the active
-locale or whether the source string is in UTF-8 format.
+Note that unlike C<\s>, C<\d> and C<\w>, C<\h> and C<\v> always match
+the same characters, regardless whether the source string is in UTF-8
+format or not. The set of characters they match is also not influenced
+by locale.
-One might think that C<\s> is equivalent to C<[\h\v]>. This is indeed true
-starting in Perl v5.18, but prior to that, the sole difference was that the
-vertical tab (C<"\cK">) was not matched by C<\s>.
+One might think that C<\s> is equivalent with C<[\h\v]>. This is not true.
+The vertical tab (C<"\x0b">) is not matched by C<\s>, it is however
+considered vertical white space. Furthermore, if the source string is
+not in UTF-8 format, the next line (C<"\x85">) and the no-break space
+(C<"\xA0">) are not matched by C<\s>, but are by C<\v> and C<\h> respectively.
+If the source string is in UTF-8 format, both the next line and the
+no-break space are matched by C<\s>.
The following table is a complete listing of characters matched by
-C<\s>, C<\h> and C<\v> as of Unicode 6.3.
+C<\s>, C<\h> and C<\v>.
-The first column gives the Unicode code point of the character (in hex format),
+The first column gives the code point of the character (in hex format),
the second column gives the (Unicode) name. The third column indicates
-by which class(es) the character is matched (assuming no locale is in
-effect that changes the C<\s> matching).
-
- 0x0009 CHARACTER TABULATION h s
- 0x000a LINE FEED (LF) vs
- 0x000b LINE TABULATION vs [1]
- 0x000c FORM FEED (FF) vs
- 0x000d CARRIAGE RETURN (CR) vs
- 0x0020 SPACE h s
- 0x0085 NEXT LINE (NEL) vs [2]
- 0x00a0 NO-BREAK SPACE h s [2]
- 0x1680 OGHAM SPACE MARK h s
- 0x2000 EN QUAD h s
- 0x2001 EM QUAD h s
- 0x2002 EN SPACE h s
- 0x2003 EM SPACE h s
- 0x2004 THREE-PER-EM SPACE h s
- 0x2005 FOUR-PER-EM SPACE h s
- 0x2006 SIX-PER-EM SPACE h s
- 0x2007 FIGURE SPACE h s
- 0x2008 PUNCTUATION SPACE h s
- 0x2009 THIN SPACE h s
- 0x200a HAIR SPACE h s
- 0x2028 LINE SEPARATOR vs
- 0x2029 PARAGRAPH SEPARATOR vs
- 0x202f NARROW NO-BREAK SPACE h s
- 0x205f MEDIUM MATHEMATICAL SPACE h s
- 0x3000 IDEOGRAPHIC SPACE h s
+by which class(es) the character is matched.
+
+ 0x00009 CHARACTER TABULATION h s
+ 0x0000a LINE FEED (LF) vs
+ 0x0000b LINE TABULATION v
+ 0x0000c FORM FEED (FF) vs
+ 0x0000d CARRIAGE RETURN (CR) vs
+ 0x00020 SPACE h s
+ 0x00085 NEXT LINE (NEL) vs [1]
+ 0x000a0 NO-BREAK SPACE h s [1]
+ 0x01680 OGHAM SPACE MARK h s
+ 0x0180e MONGOLIAN VOWEL SEPARATOR h s
+ 0x02000 EN QUAD h s
+ 0x02001 EM QUAD h s
+ 0x02002 EN SPACE h s
+ 0x02003 EM SPACE h s
+ 0x02004 THREE-PER-EM SPACE h s
+ 0x02005 FOUR-PER-EM SPACE h s
+ 0x02006 SIX-PER-EM SPACE h s
+ 0x02007 FIGURE SPACE h s
+ 0x02008 PUNCTUATION SPACE h s
+ 0x02009 THIN SPACE h s
+ 0x0200a HAIR SPACE h s
+ 0x02028 LINE SEPARATOR vs
+ 0x02029 PARAGRAPH SEPARATOR vs
+ 0x0202f NARROW NO-BREAK SPACE h s
+ 0x0205f MEDIUM MATHEMATICAL SPACE h s
+ 0x03000 IDEOGRAPHIC SPACE h s
=over 4
=item [1]
-Prior to Perl v5.18, C<\s> did not match the vertical tab. The change
-in v5.18 is considered an experiment, which means it could be backed out
-in v5.22 if experience indicates that it breaks too much
-existing code. If this change adversely affects you, send email to
-C<perlbug@perl.org>; if it affects you positively, email
-C<perlthanks@perl.org>. In the meantime, C<[^\S\cK]> (obscurely)
-matches what C<\s> traditionally did.
+NEXT LINE and NO-BREAK SPACE only match C<\s> if the source string is in
+UTF-8 format.
-=item [2]
+=back
-NEXT LINE and NO-BREAK SPACE may or may not match C<\s> depending
-on the rules in effect. See
-L<the beginning of this section|/Whitespace>.
+It is worth noting that C<\d>, C<\w>, etc, match single characters, not
+complete numbers or words. To match a number (that consists of integers),
+use C<\d+>; to match a word, use C<\w+>.
-=back
=head3 Unicode Properties
-C<\pP> and C<\p{Prop}> are character classes to match characters that fit given
-Unicode properties. One letter property names can be used in the C<\pP> form,
-with the property name following the C<\p>, otherwise, braces are required.
-When using braces, there is a single form, which is just the property name
-enclosed in the braces, and a compound form which looks like C<\p{name=value}>,
-which means to match if the property "name" for the character has that particular
-"value".
-For instance, a match for a number can be written as C</\pN/> or as
-C</\p{Number}/>, or as C</\p{Number=True}/>.
-Lowercase letters are matched by the property I<Lowercase_Letter> which
-has the short form I<Ll>. They need the braces, so are written as C</\p{Ll}/> or
-C</\p{Lowercase_Letter}/>, or C</\p{General_Category=Lowercase_Letter}/>
-(the underscores are optional).
-C</\pLl/> is valid, but means something different.
+C<\pP> and C<\p{Prop}> are character classes to match characters that
+fit given Unicode classes. One letter classes can be used in the C<\pP>
+form, with the class name following the C<\p>, otherwise, the property
+name is enclosed in braces, and follows the C<\p>. For instance, a
+match for a number can be written as C</\pN/> or as C</\p{Number}/>.
+Lowercase letters are matched by the property I<LowercaseLetter> which
+has as short form I<Ll>. They have to be written as C</\p{Ll}/> or
+C</\p{LowercaseLetter}/>. C</\pLl/> is valid, but means something different.
It matches a two character string: a letter (Unicode property C<\pL>),
followed by a lowercase C<l>.
-If locale rules are not in effect, the use of
-a Unicode property will force the regular expression into using Unicode
-rules, if it isn't already.
-
-Note that almost all properties are immune to case-insensitive matching.
-That is, adding a C</i> regular expression modifier does not change what
-they match. There are two sets that are affected. The first set is
-C<Uppercase_Letter>,
-C<Lowercase_Letter>,
-and C<Titlecase_Letter>,
-all of which match C<Cased_Letter> under C</i> matching.
-The second set is
-C<Uppercase>,
-C<Lowercase>,
-and C<Titlecase>,
-all of which match C<Cased> under C</i> matching.
-(The difference between these sets is that some things, such as Roman
-numerals, come in both upper and lower case, so they are C<Cased>, but
-aren't considered to be letters, so they aren't C<Cased_Letter>s. They're
-actually C<Letter_Number>s.)
-This set also includes its subsets C<PosixUpper> and C<PosixLower>, both
-of which under C</i> match C<PosixAlpha>.
-
-For more details on Unicode properties, see L<perlunicode/Unicode
-Character Properties>; for a
-complete list of possible properties, see
-L<perluniprops/Properties accessible through \p{} and \P{}>,
-which notes all forms that have C</i> differences.
-It is also possible to define your own properties. This is discussed in
+For a list of possible properties, see
+L<perlunicode/Unicode Character Properties>. It is also possible to
+defined your own properties. This is discussed in
L<perlunicode/User-Defined Character Properties>.
-Unicode properties are defined (surprise!) only on Unicode code points.
-Starting in v5.20, when matching against C<\p> and C<\P>, Perl treats
-non-Unicode code points (those above the legal Unicode maximum of
-0x10FFFF) as if they were typical unassigned Unicode code points.
-
-Prior to v5.20, Perl raised a warning and made all matches fail on
-non-Unicode code points. This could be somewhat surprising:
-
- chr(0x110000) =~ \p{ASCII_Hex_Digit=True} # Fails on Perls < v5.20.
- chr(0x110000) =~ \p{ASCII_Hex_Digit=False} # Also fails on Perls
- # < v5.20
-
-Even though these two matches might be thought of as complements, until
-v5.20 they were so only on Unicode code points.
=head4 Examples
@@ -411,14 +210,14 @@ v5.20 they were so only on Unicode code points.
"7" =~ /\w/ # Match, "7" is a 'word' character as well.
"a" =~ /\d/ # No match, "a" isn't a digit.
"7" =~ /\d/ # Match, "7" is a digit.
- " " =~ /\s/ # Match, a space is whitespace.
+ " " =~ /\s/ # Match, a space is white space.
"a" =~ /\D/ # Match, "a" is a non-digit.
"7" =~ /\D/ # No match, "7" is not a non-digit.
- " " =~ /\S/ # No match, a space is not non-whitespace.
+ " " =~ /\S/ # No match, a space is not non-white space.
- " " =~ /\h/ # Match, space is horizontal whitespace.
- " " =~ /\v/ # No match, space is not vertical whitespace.
- "\r" =~ /\v/ # Match, a return is vertical whitespace.
+ " " =~ /\h/ # Match, space is horizontal white space.
+ " " =~ /\v/ # No match, space is not vertical white space.
+ "\r" =~ /\v/ # Match, a return is vertical white space.
"a" =~ /\pL/ # Match, "a" is a letter.
"a" =~ /\p{Lu}/ # No match, /\p{Lu}/ matches upper case letters.
@@ -426,23 +225,19 @@ v5.20 they were so only on Unicode code points.
"\x{0e0b}" =~ /\p{Thai}/ # Match, \x{0e0b} is the character
# 'THAI CHARACTER SO SO', and that's in
# Thai Unicode class.
- "a" =~ /\P{Lao}/ # Match, as "a" is not a Laotian character.
+ "a" =~ /\P{Lao}/ # Match, as "a" is not a Laoian character.
-It is worth emphasizing that C<\d>, C<\w>, etc, match single characters, not
-complete numbers or words. To match a number (that consists of digits),
-use C<\d+>; to match a word, use C<\w+>. But be aware of the security
-considerations in doing so, as mentioned above.
=head2 Bracketed Character Classes
The third form of character class you can use in Perl regular expressions
-is the bracketed character class. In its simplest form, it lists the characters
-that may be matched, surrounded by square brackets, like this: C<[aeiou]>.
-This matches one of C<a>, C<e>, C<i>, C<o> or C<u>. Like the other
-character classes, exactly one character is matched.* To match
-a longer string consisting of characters mentioned in the character
-class, follow the character class with a L<quantifier|perlre/Quantifiers>. For
-instance, C<[aeiou]+> matches one or more lowercase English vowels.
+is the bracketed form. In its simplest form, it lists the characters
+that may be matched inside square brackets, like this: C<[aeiou]>.
+This matches one of C<a>, C<e>, C<i>, C<o> or C<u>. Just as the other
+character classes, exactly one character will be matched. To match
+a longer string consisting of characters mentioned in the characters
+class, follow the character class with a quantifier. For instance,
+C<[aeiou]+> matches a string of one or more lowercase ASCII vowels.
Repeating a character in a character class has no
effect; it's considered to be in the set only once.
@@ -455,36 +250,10 @@ Examples:
# a single character.
"ae" =~ /^[aeiou]+$/ # Match, due to the quantifier.
- -------
-
-* There is an exception to a bracketed character class matching a
-single character only. When the class is to match caselessly under C</i>
-matching rules, and a character that is explicitly mentioned inside the
-class matches a
-multiple-character sequence caselessly under Unicode rules, the class
-(when not L<inverted|/Negation>) will also match that sequence. For
-example, Unicode says that the letter C<LATIN SMALL LETTER SHARP S>
-should match the sequence C<ss> under C</i> rules. Thus,
-
- 'ss' =~ /\A\N{LATIN SMALL LETTER SHARP S}\z/i # Matches
- 'ss' =~ /\A[aeioust\N{LATIN SMALL LETTER SHARP S}]\z/i # Matches
-
-For this to happen, the character must be explicitly specified, and not
-be part of a multi-character range (not even as one of its endpoints).
-(L</Character Ranges> will be explained shortly.) Therefore,
-
- 'ss' =~ /\A[\0-\x{ff}]\z/i # Doesn't match
- 'ss' =~ /\A[\0-\N{LATIN SMALL LETTER SHARP S}]\z/i # No match
- 'ss' =~ /\A[\xDF-\xDF]\z/i # Matches on ASCII platforms, since \XDF
- # is LATIN SMALL LETTER SHARP S, and the
- # range is just a single element
-
-Note that it isn't a good idea to specify these types of ranges anyway.
-
=head3 Special Characters Inside a Bracketed Character Class
Most characters that are meta characters in regular expressions (that
-is, characters that carry a special meaning like C<.>, C<*>, or C<(>) lose
+is, characters that carry a special meaning like C<*> or C<(>) lose
their special meaning and can be used inside a character class without
the need to escape them. For instance, C<[()]> matches either an opening
parenthesis, or a closing parenthesis, and the parens inside the character
@@ -496,40 +265,17 @@ escaped with a backslash, although this is sometimes not needed, in which
case the backslash may be omitted.
The sequence C<\b> is special inside a bracketed character class. While
-outside the character class, C<\b> is an assertion indicating a point
+outside the character class C<\b> is an assertion indicating a point
that does not have either two word characters or two non-word characters
on either side, inside a bracketed character class, C<\b> matches a
backspace character.
-The sequences
-C<\a>,
-C<\c>,
-C<\e>,
-C<\f>,
-C<\n>,
-C<\N{I<NAME>}>,
-C<\N{U+I<hex char>}>,
-C<\r>,
-C<\t>,
-and
-C<\x>
-are also special and have the same meanings as they do outside a
-bracketed character class. (However, inside a bracketed character
-class, if C<\N{I<NAME>}> expands to a sequence of characters, only the first
-one in the sequence is used, with a warning.)
-
-Also, a backslash followed by two or three octal digits is considered an octal
-number.
-
-A C<[> is not special inside a character class, unless it's the start of a
-POSIX character class (see L</POSIX Character Classes> below). It normally does
-not need escaping.
-
-A C<]> is normally either the end of a POSIX character class (see
-L</POSIX Character Classes> below), or it signals the end of the bracketed
-character class. If you want to include a C<]> in the set of characters, you
-must generally escape it.
+A C<[> is not special inside a character class, unless it's the start
+of a POSIX character class (see below). It normally does not need escaping.
+A C<]> is either the end of a POSIX character class (see below), or it
+signals the end of the bracketed character class. Normally it needs
+escaping if you want to include a C<]> in the set of characters.
However, if the C<]> is the I<first> (or the second if the first
character is a caret) character of a bracketed character class, it
does not denote the end of the class (as you cannot have an empty class)
@@ -539,8 +285,8 @@ escaping.
Examples:
"+" =~ /[+?*]/ # Match, "+" in a character class is not special.
- "\cH" =~ /[\b]/ # Match, \b inside in a character class.
- # is equivalent to a backspace.
+ "\cH" =~ /[\b]/ # Match, \b inside in a character class
+ # is equivalent with a backspace.
"]" =~ /[][]/ # Match, as the character class contains.
# both [ and ].
"[]" =~ /[[]]/ # Match, the pattern contains a character class
@@ -550,32 +296,32 @@ Examples:
=head3 Character Ranges
It is not uncommon to want to match a range of characters. Luckily, instead
-of listing all characters in the range, one may use the hyphen (C<->).
+of listing all the characters in the range, one may use the hyphen (C<->).
If inside a bracketed character class you have two characters separated
-by a hyphen, it's treated as if all characters between the two were in
+by a hyphen, it's treated as if all the characters between the two are in
the class. For instance, C<[0-9]> matches any ASCII digit, and C<[a-m]>
matches any lowercase letter from the first half of the ASCII alphabet.
Note that the two characters on either side of the hyphen are not
-necessarily both letters or both digits. Any character is possible,
+necessary both letters or both digits. Any character is possible,
although not advisable. C<['-?]> contains a range of characters, but
-most people will not know which characters that means. Furthermore,
+most people will not know which characters that will be. Furthermore,
such ranges may lead to portability problems if the code has to run on
a platform that uses a different character set, such as EBCDIC.
-If a hyphen in a character class cannot syntactically be part of a range, for
-instance because it is the first or the last character of the character class,
-or if it immediately follows a range, the hyphen isn't special, and so is
-considered a character to be matched literally. If you want a hyphen in
-your set of characters to be matched and its position in the class is such
-that it could be considered part of a range, you must escape that hyphen
-with a backslash.
+If a hyphen in a character class cannot be part of a range, for instance
+because it is the first or the last character of the character class,
+or if it immediately follows a range, the hyphen isn't special, and will be
+considered a character that may be matched. You have to escape the hyphen
+with a backslash if you want to have a hyphen in your set of characters to
+be matched, and its position in the class is such that it can be considered
+part of a range.
Examples:
[a-z] # Matches a character that is a lower case ASCII letter.
- [a-fz] # Matches any letter between 'a' and 'f' (inclusive) or
- # the letter 'z'.
+ [a-fz] # Matches any letter between 'a' and 'f' (inclusive) or the
+ # letter 'z'.
[-z] # Matches either a hyphen ('-') or the letter 'z'.
[a-f-m] # Matches any letter between 'a' and 'f' (inclusive), the
# hyphen ('-'), or the letter 'm'.
@@ -587,28 +333,13 @@ Examples:
It is also possible to instead list the characters you do not want to
match. You can do so by using a caret (C<^>) as the first character in the
-character class. For instance, C<[^a-z]> matches any character that is not a
-lowercase ASCII letter, which therefore includes more than a million
-Unicode code points. The class is said to be "negated" or "inverted".
+character class. For instance, C<[^a-z]> matches a character that is not a
+lowercase ASCII letter.
This syntax make the caret a special character inside a bracketed character
class, but only if it is the first character of the class. So if you want
-the caret as one of the characters to match, either escape the caret or
-else don't list it first.
-
-In inverted bracketed character classes, Perl ignores the Unicode rules
-that normally say that certain characters should match a sequence of
-multiple characters under caseless C</i> matching. Following those
-rules could lead to highly confusing situations:
-
- "ss" =~ /^[^\xDF]+$/ui; # Matches!
-
-This should match any sequences of characters that aren't C<\xDF> nor
-what C<\xDF> matches under C</i>. C<"s"> isn't C<\xDF>, but Unicode
-says that C<"ss"> is what C<\xDF> matches under C</i>. So which one
-"wins"? Do you fail the match because the string has C<ss> or accept it
-because it has an C<s> followed by another C<s>? Perl has chosen the
-latter.
+to have the caret as one of the characters you want to match, you either
+have to escape the caret, or not list it first.
Examples:
@@ -619,18 +350,11 @@ Examples:
=head3 Backslash Sequences
-You can put any backslash sequence character class (with the exception of
-C<\N> and C<\R>) inside a bracketed character class, and it will act just
-as if you had put all characters matched by the backslash sequence inside the
-character class. For instance, C<[a-f\d]> matches any decimal digit, or any
-of the lowercase letters between 'a' and 'f' inclusive.
-
-C<\N> within a bracketed character class must be of the forms C<\N{I<name>}>
-or C<\N{U+I<hex char>}>, and NOT be the form that matches non-newlines,
-for the same reason that a dot C<.> inside a bracketed character class loses
-its special meaning: it matches nearly anything, which generally isn't what you
-want to happen.
-
+You can put a backslash sequence character class inside a bracketed character
+class, and it will act just as if you put all the characters matched by
+the backslash sequence inside the character class. For instance,
+C<[a-f\d]> will match any digit, or any of the lowercase letters between
+'a' and 'f' inclusive.
Examples:
@@ -640,21 +364,14 @@ Examples:
# character, nor a parenthesis.
Backslash sequence character classes cannot form one of the endpoints
-of a range. Thus, you can't say:
-
- /[\p{Thai}-\d]/ # Wrong!
+of a range.
-=head3 POSIX Character Classes
-X<character class> X<\p> X<\p{}>
-X<alpha> X<alnum> X<ascii> X<blank> X<cntrl> X<digit> X<graph>
-X<lower> X<print> X<punct> X<space> X<upper> X<word> X<xdigit>
+=head3 Posix Character Classes
-POSIX character classes have the form C<[:class:]>, where I<class> is the
-name, and the C<[:> and C<:]> delimiters. POSIX character classes only appear
+Posix character classes have the form C<[:class:]>, where I<class> is
+name, and the C<[:> and C<:]> delimiters. Posix character classes appear
I<inside> bracketed character classes, and are a convenient and descriptive
-way of listing a group of characters.
-
-Be careful about the syntax,
+way of listing a group of characters. Be careful about the syntax,
# Correct:
$string =~ /[[:alpha:]]/
@@ -665,444 +382,144 @@ Be careful about the syntax,
The latter pattern would be a character class consisting of a colon,
and the letters C<a>, C<l>, C<p> and C<h>.
-POSIX character classes can be part of a larger bracketed character class.
-For example,
-
- [01[:alpha:]%]
-
-is valid and matches '0', '1', any alphabetic character, and the percent sign.
-
Perl recognizes the following POSIX character classes:
- alpha Any alphabetical character ("[A-Za-z]").
- alnum Any alphanumeric character ("[A-Za-z0-9]").
- ascii Any character in the ASCII character set.
- blank A GNU extension, equal to a space or a horizontal tab ("\t").
- cntrl Any control character. See Note [2] below.
- digit Any decimal digit ("[0-9]"), equivalent to "\d".
- graph Any printable character, excluding a space. See Note [3] below.
- lower Any lowercase character ("[a-z]").
- print Any printable character, including a space. See Note [4] below.
- punct Any graphical character excluding "word" characters. Note [5].
- space Any whitespace character. "\s" including the vertical tab
- ("\cK").
- upper Any uppercase character ("[A-Z]").
- word A Perl extension ("[A-Za-z0-9_]"), equivalent to "\w".
- xdigit Any hexadecimal digit ("[0-9a-fA-F]").
-
-Most POSIX character classes have two Unicode-style C<\p> property
-counterparts. (They are not official Unicode properties, but Perl extensions
-derived from official Unicode properties.) The table below shows the relation
-between POSIX character classes and these counterparts.
-
-One counterpart, in the column labelled "ASCII-range Unicode" in
-the table, matches only characters in the ASCII character set.
-
-The other counterpart, in the column labelled "Full-range Unicode", matches any
-appropriate characters in the full Unicode character set. For example,
-C<\p{Alpha}> matches not just the ASCII alphabetic characters, but any
-character in the entire Unicode character set considered alphabetic.
-An entry in the column labelled "backslash sequence" is a (short)
-equivalent.
-
- [[:...:]] ASCII-range Full-range backslash Note
- Unicode Unicode sequence
- -----------------------------------------------------
- alpha \p{PosixAlpha} \p{XPosixAlpha}
- alnum \p{PosixAlnum} \p{XPosixAlnum}
- ascii \p{ASCII}
- blank \p{PosixBlank} \p{XPosixBlank} \h [1]
- or \p{HorizSpace} [1]
- cntrl \p{PosixCntrl} \p{XPosixCntrl} [2]
- digit \p{PosixDigit} \p{XPosixDigit} \d
- graph \p{PosixGraph} \p{XPosixGraph} [3]
- lower \p{PosixLower} \p{XPosixLower}
- print \p{PosixPrint} \p{XPosixPrint} [4]
- punct \p{PosixPunct} \p{XPosixPunct} [5]
- \p{PerlSpace} \p{XPerlSpace} \s [6]
- space \p{PosixSpace} \p{XPosixSpace} [6]
- upper \p{PosixUpper} \p{XPosixUpper}
- word \p{PosixWord} \p{XPosixWord} \w
- xdigit \p{PosixXDigit} \p{XPosixXDigit}
+ alpha Any alphabetical character.
+ alnum Any alphanumerical character.
+ ascii Any ASCII character.
+ blank A GNU extension, equal to a space or a horizontal tab (C<\t>).
+ cntrl Any control character.
+ digit Any digit, equivalent to C<\d>.
+ graph Any printable character, excluding a space.
+ lower Any lowercase character.
+ print Any printable character, including a space.
+ punct Any punctuation character.
+ space Any white space character. C<\s> plus the vertical tab (C<\cK>).
+ upper Any uppercase character.
+ word Any "word" character, equivalent to C<\w>.
+ xdigit Any hexadecimal digit, '0' - '9', 'a' - 'f', 'A' - 'F'.
+
+The exact set of characters matched depends on whether the source string
+is internally in UTF-8 format or not. See L</Locale, Unicode and UTF-8>.
+
+Most POSIX character classes have C<\p> counterparts. The difference
+is that the C<\p> classes will always match according to the Unicode
+properties, regardless whether the string is in UTF-8 format or not.
+
+The following table shows the relation between POSIX character classes
+and the Unicode properties:
+
+ [[:...:]] \p{...} backslash
+
+ alpha IsAlpha
+ alnum IsAlnum
+ ascii IsASCII
+ blank
+ cntrl IsCntrl
+ digit IsDigit \d
+ graph IsGraph
+ lower IsLower
+ print IsPrint
+ punct IsPunct
+ space IsSpace
+ IsSpacePerl \s
+ upper IsUpper
+ word IsWord
+ xdigit IsXDigit
+
+Some character classes may have a non-obvious name:
=over 4
-=item [1]
-
-C<\p{Blank}> and C<\p{HorizSpace}> are synonyms.
-
-=item [2]
+=item cntrl
-Control characters don't produce output as such, but instead usually control
-the terminal somehow: for example, newline and backspace are control characters.
-In the ASCII range, characters whose code points are between 0 and 31 inclusive,
-plus 127 (C<DEL>) are control characters.
+Any control character. Usually, control characters don't produce output
+as such, but instead control the terminal somehow: for example newline
+and backspace are control characters. All characters with C<ord()> less
+than 32 are usually classified as control characters (in ASCII, the ISO
+Latin character sets, and Unicode), as is the character C<ord()> value
+of 127 (C<DEL>).
-=item [3]
+=item graph
Any character that is I<graphical>, that is, visible. This class consists
-of all alphanumeric characters and all punctuation characters.
-
-=item [4]
-
-All printable characters, which is the set of all graphical characters
-plus those whitespace characters which are not also controls.
-
-=item [5]
-
-C<\p{PosixPunct}> and C<[[:punct:]]> in the ASCII range match all
-non-controls, non-alphanumeric, non-space characters:
-C<[-!"#$%&'()*+,./:;<=E<gt>?@[\\\]^_`{|}~]> (although if a locale is in effect,
-it could alter the behavior of C<[[:punct:]]>).
+of all the alphanumerical characters and all punctuation characters.
-The similarly named property, C<\p{Punct}>, matches a somewhat different
-set in the ASCII range, namely
-C<[-!"#%&'()*,./:;?@[\\\]_{}]>. That is, it is missing the nine
-characters C<[$+E<lt>=E<gt>^`|~]>.
-This is because Unicode splits what POSIX considers to be punctuation into two
-categories, Punctuation and Symbols.
+=item print
-C<\p{XPosixPunct}> and (under Unicode rules) C<[[:punct:]]>, match what
-C<\p{PosixPunct}> matches in the ASCII range, plus what C<\p{Punct}>
-matches. This is different than strictly matching according to
-C<\p{Punct}>. Another way to say it is that
-if Unicode rules are in effect, C<[[:punct:]]> matches all characters
-that Unicode considers punctuation, plus all ASCII-range characters that
-Unicode considers symbols.
+All printable characters, which is the set of all the graphical characters
+plus the space.
-=item [6]
+=item punct
-C<\p{XPerlSpace}> and C<\p{Space}> match identically starting with Perl
-v5.18. In earlier versions, these differ only in that in non-locale
-matching, C<\p{XPerlSpace}> does not match the vertical tab, C<\cK>.
-Same for the two ASCII-only range forms.
+Any punctuation (special) character.
=back
-There are various other synonyms that can be used besides the names
-listed in the table. For example, C<\p{PosixAlpha}> can be written as
-C<\p{Alpha}>. All are listed in
-L<perluniprops/Properties accessible through \p{} and \P{}>.
-
-Both the C<\p> counterparts always assume Unicode rules are in effect.
-On ASCII platforms, this means they assume that the code points from 128
-to 255 are Latin-1, and that means that using them under locale rules is
-unwise unless the locale is guaranteed to be Latin-1 or UTF-8. In contrast, the
-POSIX character classes are useful under locale rules. They are
-affected by the actual rules in effect, as follows:
-
-=over
-
-=item If the C</a> modifier, is in effect ...
-
-Each of the POSIX classes matches exactly the same as their ASCII-range
-counterparts.
-
-=item otherwise ...
-
-=over
-
-=item For code points above 255 ...
-
-The POSIX class matches the same as its Full-range counterpart.
-
-=item For code points below 256 ...
-
-=over
-
-=item if locale rules are in effect ...
-
-The POSIX class matches according to the locale, except:
-
-=over
-
-=item C<word>
-
-also includes the platform's native underscore character, no matter what
-the locale is.
-
-=item C<ascii>
-
-on platforms that don't have the POSIX C<ascii> extension, this matches
-just the platform's native ASCII-range characters.
-
-=item C<blank>
-
-on platforms that don't have the POSIX C<blank> extension, this matches
-just the platform's native tab and space characters.
-
-=back
-
-=item if Unicode rules are in effect ...
-
-The POSIX class matches the same as the Full-range counterpart.
-
-=item otherwise ...
-
-The POSIX class matches the same as the ASCII range counterpart.
-
-=back
-
-=back
-
-=back
-
-Which rules apply are determined as described in
-L<perlre/Which character set modifier is in effect?>.
-
-It is proposed to change this behavior in a future release of Perl so that
-whether or not Unicode rules are in effect would not change the
-behavior: Outside of locale, the POSIX classes
-would behave like their ASCII-range counterparts. If you wish to
-comment on this proposal, send email to C<perl5-porters@perl.org>.
-
-=head4 Negation of POSIX character classes
-X<character class, negation>
+=head4 Negation
A Perl extension to the POSIX character class is the ability to
negate it. This is done by prefixing the class name with a caret (C<^>).
Some examples:
- POSIX ASCII-range Full-range backslash
- Unicode Unicode sequence
- -----------------------------------------------------
- [[:^digit:]] \P{PosixDigit} \P{XPosixDigit} \D
- [[:^space:]] \P{PosixSpace} \P{XPosixSpace}
- \P{PerlSpace} \P{XPerlSpace} \S
- [[:^word:]] \P{PerlWord} \P{XPosixWord} \W
-
-The backslash sequence can mean either ASCII- or Full-range Unicode,
-depending on various factors as described in L<perlre/Which character set modifier is in effect?>.
+ POSIX Unicode Backslash
+ [[:^digit:]] \P{IsDigit} \D
+ [[:^space:]] \P{IsSpace} \S
+ [[:^word:]] \P{IsWord} \W
=head4 [= =] and [. .]
-Perl recognizes the POSIX character classes C<[=class=]> and
-C<[.class.]>, but does not (yet?) support them. Any attempt to use
-either construct raises an exception.
+Perl will recognize the POSIX character classes C<[=class=]>, and
+C<[.class.]>, but does not (yet?) support this construct. Use of
+such a constructs will lead to an error.
+
=head4 Examples
/[[:digit:]]/ # Matches a character that is a digit.
/[01[:lower:]]/ # Matches a character that is either a
# lowercase letter, or '0' or '1'.
- /[[:digit:][:^xdigit:]]/ # Matches a character that can be anything
- # except the letters 'a' to 'f' and 'A' to
- # 'F'. This is because the main character
- # class is composed of two POSIX character
- # classes that are ORed together, one that
- # matches any digit, and the other that
- # matches anything that isn't a hex digit.
- # The OR adds the digits, leaving only the
- # letters 'a' to 'f' and 'A' to 'F' excluded.
-
-=head3 Extended Bracketed Character Classes
-X<character class>
-X<set operations>
-
-This is a fancy bracketed character class that can be used for more
-readable and less error-prone classes, and to perform set operations,
-such as intersection. An example is
-
- /(?[ \p{Thai} & \p{Digit} ])/
-
-This will match all the digit characters that are in the Thai script.
-
-This is an experimental feature available starting in 5.18, and is
-subject to change as we gain field experience with it. Any attempt to
-use it will raise a warning, unless disabled via
-
- no warnings "experimental::regex_sets";
-
-Comments on this feature are welcome; send email to
-C<perl5-porters@perl.org>.
-
-We can extend the example above:
-
- /(?[ ( \p{Thai} + \p{Lao} ) & \p{Digit} ])/
-
-This matches digits that are in either the Thai or Laotian scripts.
-
-Notice the white space in these examples. This construct always has
-the C<E<sol>x> modifier turned on within it.
-
-The available binary operators are:
-
- & intersection
- + union
- | another name for '+', hence means union
- - subtraction (the result matches the set consisting of those
- code points matched by the first operand, excluding any that
- are also matched by the second operand)
- ^ symmetric difference (the union minus the intersection). This
- is like an exclusive or, in that the result is the set of code
- points that are matched by either, but not both, of the
- operands.
+ /[[:digit:][:^xdigit:]]/ # Matches a character that can be anything,
+ # but the letters 'a' to 'f' in either case.
+ # This is because the character class contains
+ # all digits, and anything that isn't a
+ # hex digit, resulting in a class containing
+ # all characters, but the letters 'a' to 'f'
+ # and 'A' to 'F'.
-There is one unary operator:
- ! complement
+=head2 Locale, Unicode and UTF-8
-All the binary operators left associate, and are of equal precedence.
-The unary operator right associates, and has higher precedence. Use
-parentheses to override the default associations. Some feedback we've
-received indicates a desire for intersection to have higher precedence
-than union. This is something that feedback from the field may cause us
-to change in future releases; you may want to parenthesize copiously to
-avoid such changes affecting your code, until this feature is no longer
-considered experimental.
+Some of the character classes have a somewhat different behaviour depending
+on the internal encoding of the source string, and the locale that is
+in effect.
-The main restriction is that everything is a metacharacter. Thus,
-you cannot refer to single characters by doing something like this:
+C<\w>, C<\d>, C<\s> and the POSIX character classes (and their negations,
+including C<\W>, C<\D>, C<\S>) suffer from this behaviour.
- /(?[ a + b ])/ # Syntax error!
+The rule is that if the source string is in UTF-8 format, the character
+classes match according to the Unicode properties. If the source string
+isn't, then the character classes match according to whatever locale is
+in effect. If there is no locale, they match the ASCII defaults
+(52 letters, 10 digits and underscore for C<\w>, 0 to 9 for C<\d>, etc).
-The easiest way to specify an individual typable character is to enclose
-it in brackets:
+This usually means that if you are matching against characters whose C<ord()>
+values are between 128 and 255 inclusive, your character class may match
+or not depending on the current locale, and whether the source string is
+in UTF-8 format. The string will be in UTF-8 format if it contains
+characters whose C<ord()> value exceeds 255. But a string may be in UTF-8
+format without it having such characters.
- /(?[ [a] + [b] ])/
+For portability reasons, it may be better to not use C<\w>, C<\d>, C<\s>
+or the POSIX character classes, and use the Unicode properties instead.
-(This is the same thing as C<[ab]>.) You could also have said the
-equivalent:
-
- /(?[[ a b ]])/
-
-(You can, of course, specify single characters by using, C<\x{...}>,
-C<\N{...}>, etc.)
-
-This last example shows the use of this construct to specify an ordinary
-bracketed character class without additional set operations. Note the
-white space within it; C<E<sol>x> is turned on even within bracketed
-character classes, except you can't have comments inside them. Hence,
-
- (?[ [#] ])
-
-matches the literal character "#". To specify a literal white space character,
-you can escape it with a backslash, like:
-
- /(?[ [ a e i o u \ ] ])/
-
-This matches the English vowels plus the SPACE character.
-All the other escapes accepted by normal bracketed character classes are
-accepted here as well; but unrecognized escapes that generate warnings
-in normal classes are fatal errors here.
-
-All warnings from these class elements are fatal, as well as some
-practices that don't currently warn. For example you cannot say
-
- /(?[ [ \xF ] ])/ # Syntax error!
-
-You have to have two hex digits after a braceless C<\x> (use a leading
-zero to make two). These restrictions are to lower the incidence of
-typos causing the class to not match what you thought it would.
-
-If a regular bracketed character class contains a C<\p{}> or C<\P{}> and
-is matched against a non-Unicode code point, a warning may be
-raised, as the result is not Unicode-defined. No such warning will come
-when using this extended form.
-
-The final difference between regular bracketed character classes and
-these, is that it is not possible to get these to match a
-multi-character fold. Thus,
-
- /(?[ [\xDF] ])/iu
-
-does not match the string C<ss>.
-
-You don't have to enclose POSIX class names inside double brackets,
-hence both of the following work:
-
- /(?[ [:word:] - [:lower:] ])/
- /(?[ [[:word:]] - [[:lower:]] ])/
-
-Any contained POSIX character classes, including things like C<\w> and C<\D>
-respect the C<E<sol>a> (and C<E<sol>aa>) modifiers.
-
-C<< (?[ ]) >> is a regex-compile-time construct. Any attempt to use
-something which isn't knowable at the time the containing regular
-expression is compiled is a fatal error. In practice, this means
-just three limitations:
-
-=over 4
-
-=item 1
-
-This construct cannot be used within the scope of
-C<use locale> (or the C<E<sol>l> regex modifier).
-
-=item 2
-
-Any
-L<user-defined property|perlunicode/"User-Defined Character Properties">
-used must be already defined by the time the regular expression is
-compiled (but note that this construct can be used instead of such
-properties).
-
-=item 3
-
-A regular expression that otherwise would compile
-using C<E<sol>d> rules, and which uses this construct will instead
-use C<E<sol>u>. Thus this construct tells Perl that you don't want
-C<E<sol>d> rules for the entire regular expression containing it.
-
-=back
-
-The C<E<sol>x> processing within this class is an extended form.
-Besides the characters that are considered white space in normal C</x>
-processing, there are 5 others, recommended by the Unicode standard:
-
- U+0085 NEXT LINE
- U+200E LEFT-TO-RIGHT MARK
- U+200F RIGHT-TO-LEFT MARK
- U+2028 LINE SEPARATOR
- U+2029 PARAGRAPH SEPARATOR
-
-Note that skipping white space applies only to the interior of this
-construct. There must not be any space between any of the characters
-that form the initial C<(?[>. Nor may there be space between the
-closing C<])> characters.
-
-Just as in all regular expressions, the pattern can be built up by
-including variables that are interpolated at regex compilation time.
-Care must be taken to ensure that you are getting what you expect. For
-example:
-
- my $thai_or_lao = '\p{Thai} + \p{Lao}';
- ...
- qr/(?[ \p{Digit} & $thai_or_lao ])/;
-
-compiles to
-
- qr/(?[ \p{Digit} & \p{Thai} + \p{Lao} ])/;
-
-But this does not have the effect that someone reading the code would
-likely expect, as the intersection applies just to C<\p{Thai}>,
-excluding the Laotian. Pitfalls like this can be avoided by
-parenthesizing the component pieces:
-
- my $thai_or_lao = '( \p{Thai} + \p{Lao} )';
-
-But any modifiers will still apply to all the components:
-
- my $lower = '\p{Lower} + \p{Digit}';
- qr/(?[ \p{Greek} & $lower ])/i;
-
-matches upper case things. You can avoid surprises by making the
-components into instances of this construct by compiling them:
-
- my $thai_or_lao = qr/(?[ \p{Thai} + \p{Lao} ])/;
- my $lower = qr/(?[ \p{Lower} + \p{Digit} ])/;
-
-When these are embedded in another pattern, what they match does not
-change, regardless of parenthesization or what modifiers are in effect
-in that outer pattern.
+=head4 Examples
-Due to the way that Perl parses things, your parentheses and brackets
-may need to be balanced, even including comments. If you run into any
-examples, please send them to C<perlbug@perl.org>, so that we can have a
-concrete example for this man page.
+ $str = "\xDF"; # $str is not in UTF-8 format.
+ $str =~ /^\w/; # No match, as $str isn't in UTF-8 format.
+ $str .= "\x{0e0b}"; # Now $str is in UTF-8 format.
+ $str =~ /^\w/; # Match! $str is now in UTF-8 format.
+ chop $str;
+ $str =~ /^\w/; # Still a match! $str remains in UTF-8 format.
-We may change it so that things that remain legal uses in normal bracketed
-character classes might become illegal within this experimental
-construct. One proposal, for example, is to forbid adjacent uses of the
-same character, as in C<(?[ [aa] ])>. The motivation for such a change
-is that this usage is likely a typo, as the second "a" adds nothing.
+=cut
diff --git a/gnu/usr.bin/perl/pod/perlunifaq.pod b/gnu/usr.bin/perl/pod/perlunifaq.pod
index 19eadd4cab1..b2913349cc4 100644
--- a/gnu/usr.bin/perl/pod/perlunifaq.pod
+++ b/gnu/usr.bin/perl/pod/perlunifaq.pod
@@ -11,7 +11,7 @@ read after L<perlunitut>.
No, and this isn't really a Unicode FAQ.
-Perl has an abstracted interface for all supported character encodings, so this
+Perl has an abstracted interface for all supported character encodings, so they
is actually a generic C<Encode> tutorial and C<Encode> FAQ. But many people
think that Unicode is special and magical, and I didn't want to disappoint
them, so I decided to call the document a Unicode tutorial.
@@ -25,7 +25,7 @@ To find out which character encodings your Perl supports, run:
=head2 Which version of perl should I use?
Well, if you can, upgrade to the most recent, but certainly C<5.8.1> or newer.
-The tutorial and FAQ assume the latest release.
+The tutorial and FAQ are based on the status quo as of C<5.8.8>.
You should also check your modules, and upgrade them if necessary. For example,
HTML::Entities requires version >= 1.32 to function correctly, even though the
@@ -84,12 +84,12 @@ or encode anymore, on things that use the layered handle.
You can provide this layer when C<open>ing the file:
- open my $fh, '>:encoding(UTF-8)', $filename; # auto encoding on write
- open my $fh, '<:encoding(UTF-8)', $filename; # auto decoding on read
+ open my $fh, '>:encoding(UTF-8)', $filename; # auto encoding on write
+ open my $fh, '<:encoding(UTF-8)', $filename; # auto decoding on read
Or if you already have an open filehandle:
- binmode $fh, ':encoding(UTF-8)';
+ binmode $fh, ':encoding(UTF-8)';
Some database drivers for DBI can also automatically encode and decode, but
that is sometimes limited to the UTF-8 encoding.
@@ -136,35 +136,22 @@ concern, and you can just C<eval> dumped data as always.
=head2 Why do regex character classes sometimes match only in the ASCII range?
-Starting in Perl 5.14 (and partially in Perl 5.12), just put a
-C<use feature 'unicode_strings'> near the beginning of your program.
-Within its lexical scope you shouldn't have this problem. It also is
-automatically enabled under C<use feature ':5.12'> or C<use v5.12> or
-using C<-E> on the command line for Perl 5.12 or higher.
-
-The rationale for requiring this is to not break older programs that
-rely on the way things worked before Unicode came along. Those older
-programs knew only about the ASCII character set, and so may not work
-properly for additional characters. When a string is encoded in UTF-8,
-Perl assumes that the program is prepared to deal with Unicode, but when
-the string isn't, Perl assumes that only ASCII
-is wanted, and so those characters that are not ASCII
-characters aren't recognized as to what they would be in Unicode.
-C<use feature 'unicode_strings'> tells Perl to treat all characters as
-Unicode, whether the string is encoded in UTF-8 or not, thus avoiding
-the problem.
-
-However, on earlier Perls, or if you pass strings to subroutines outside
-the feature's scope, you can force Unicode rules by changing the
-encoding to UTF-8 by doing C<utf8::upgrade($string)>. This can be used
-safely on any string, as it checks and does not change strings that have
-already been upgraded.
+=head2 Why do some characters not uppercase or lowercase correctly?
-For a more detailed discussion, see L<Unicode::Semantics> on CPAN.
+It seemed like a good idea at the time, to keep the semantics the same for
+standard strings, when Perl got Unicode support. While it might be repaired
+in the future, we now have to deal with the fact that Perl treats equal
+strings differently, depending on the internal state.
-=head2 Why do some characters not uppercase or lowercase correctly?
+Affected are C<uc>, C<lc>, C<ucfirst>, C<lcfirst>, C<\U>, C<\L>, C<\u>, C<\l>,
+C<\d>, C<\s>, C<\w>, C<\D>, C<\S>, C<\W>, C</.../i>, C<(?i:...)>,
+C</[[:posix:]]/>.
-See the answer to the previous question.
+To force Unicode semantics, you can upgrade the internal representation to
+by doing C<utf8::upgrade($string)>. This does not change strings that were
+already upgraded.
+
+For a more detailed discussion, see L<Unicode::Semantics> on CPAN.
=head2 How can I determine if a string is a text string or a binary string?
@@ -205,7 +192,7 @@ These are alternate syntaxes for C<decode('utf8', ...)> and C<encode('utf8',
This is a term used both for characters with an ordinal value greater than 127,
characters with an ordinal value greater than 255, or any character occupying
-more than one byte, depending on the context.
+than one byte, depending on the context.
The Perl warning "Wide character in ..." is caused by a character with an
ordinal value greater than 255. With no specified encoding layer, Perl tries to
@@ -228,9 +215,7 @@ use C<is_utf8>, C<_utf8_on> or C<_utf8_off> at all.
The UTF8 flag, also called SvUTF8, is an internal flag that indicates that the
current internal representation is UTF-8. Without the flag, it is assumed to be
-ISO-8859-1. Perl converts between these automatically. (Actually Perl usually
-assumes the representation is ASCII; see L</Why do regex character classes
-sometimes match only in the ASCII range?> above.)
+ISO-8859-1. Perl converts between these automatically.
One of Perl's internal formats happens to be UTF-8. Unfortunately, Perl can't
keep a secret, so everyone knows about this. That is the source of much
@@ -276,8 +261,7 @@ Instead of C<decode> and C<encode>, you could use C<_utf8_on> and C<_utf8_off>,
but this is considered bad style. Especially C<_utf8_on> can be dangerous, for
the same reason that C<:utf8> can.
-There are some shortcuts for oneliners;
-see L<-C|perlrun/-C [numberE<sol>list]> in L<perlrun>.
+There are some shortcuts for oneliners; see C<-C> in L<perlrun>.
=head2 What's the difference between C<UTF-8> and C<utf8>?
diff --git a/gnu/usr.bin/perl/pod/perlunitut.pod b/gnu/usr.bin/perl/pod/perlunitut.pod
index 9e5af04ec79..6c7dfb057e2 100644
--- a/gnu/usr.bin/perl/pod/perlunitut.pod
+++ b/gnu/usr.bin/perl/pod/perlunitut.pod
@@ -37,13 +37,11 @@ You may have to re-read this entire section a few times...
=head3 Unicode
B<Unicode> is a character set with room for lots of characters. The ordinal
-value of a character is called a B<code point>. (But in practice, the
-distinction between code point and character is blurred, so the terms often
-are used interchangeably.)
+value of a character is called a B<code point>.
-There are many, many code points, but computers work with bytes, and a byte has
-room for only 256 values. Unicode has many more characters than that,
-so you need a method to make these accessible.
+There are many, many code points, but computers work with bytes, and a byte can
+have only 256 values. Unicode has many more characters, so you need a method
+to make these accessible.
Unicode is encoded using several competing encodings, of which UTF-8 is the
most used. In a Unicode encoding, multiple subsequent bytes can be used to
@@ -66,6 +64,9 @@ B<Text strings>, or B<character strings> are made of characters. Bytes are
irrelevant here, and so are encodings. Each character is just that: the
character.
+Text strings are also called B<Unicode strings>, because in Perl, every text
+string is a Unicode string.
+
On a text string, you would do things like:
$text =~ s/foo/bar/;
diff --git a/gnu/usr.bin/perl/regcharclass.h b/gnu/usr.bin/perl/regcharclass.h
index 5e34ec0d916..f9a1558d66a 100644
--- a/gnu/usr.bin/perl/regcharclass.h
+++ b/gnu/usr.bin/perl/regcharclass.h
@@ -1,762 +1,454 @@
-/* -*- buffer-read-only: t -*-
+/* -*- buffer-read-only: t -*-
*
* regcharclass.h
*
- * Copyright (C) 2007, 2011 by Larry Wall and others
+ * Copyright (C) 2007, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*
* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
- * This file is built by regen/regcharclass.pl.
+ * This file is built by Porting/regcharclass.pl.
+ *
* Any changes made here will be lost!
- * WARNING: These macros are for internal Perl core use only, and may be
- * changed or removed without notice.
+ *
*/
-
-#ifndef H_REGCHARCLASS /* Guard against nested #includes */
-#define H_REGCHARCLASS 1
-
/*
LNBREAK: Line Break: \R
"\x0D\x0A" # CRLF - Network (Windows) line ending
- \p{VertSpace}
+ 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
*/
/*** GENERATED CODE ***/
+#define is_LNBREAK(s,is_utf8) \
+( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0C ) ? 1 \
+: ( 0x0D == ((U8*)s)[0] ) ? \
+ ( ( 0x0A == ((U8*)s)[1] ) ? 2 : 1 ) \
+: ( 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 ) \
+: ( 0x85 == ((U8*)s)[0] ) )
+
+/*** GENERATED CODE ***/
#define is_LNBREAK_safe(s,e,is_utf8) \
( ((e)-(s) > 2) ? \
- ( ( 0x0A <= NATIVE_TO_LATIN1(((U8*)s)[0]) && NATIVE_TO_LATIN1(((U8*)s)[0]) <= 0x0C ) ? 1\
- : ( 0x0D == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x0A == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? 2 : 1 ) \
+ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0C ) ? 1 \
+ : ( 0x0D == ((U8*)s)[0] ) ? \
+ ( ( 0x0A == ((U8*)s)[1] ) ? 2 : 1 ) \
: ( is_utf8 ) ? \
- ( ( 0xC2 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x85 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? 2 : 0 ) \
- : ( ( ( 0xE2 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) && ( 0x80 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ) && ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) & 0xFE ) == 0xA8 ) ) ? 3 : 0 )\
- : ( 0x85 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ) \
+ ( ( 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 ) \
+ : ( 0x85 == ((U8*)s)[0] ) ) \
: ((e)-(s) > 1) ? \
- ( ( 0x0A <= NATIVE_TO_LATIN1(((U8*)s)[0]) && NATIVE_TO_LATIN1(((U8*)s)[0]) <= 0x0C ) ? 1\
- : ( 0x0D == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x0A == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? 2 : 1 ) \
+ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0C ) ? 1 \
+ : ( 0x0D == ((U8*)s)[0] ) ? \
+ ( ( 0x0A == ((U8*)s)[1] ) ? 2 : 1 ) \
: ( is_utf8 ) ? \
- ( ( ( 0xC2 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) && ( 0x85 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ) ? 2 : 0 )\
- : ( 0x85 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ) \
+ ( ( ( 0xC2 == ((U8*)s)[0] ) && ( 0x85 == ((U8*)s)[1] ) ) ? 2 : 0 ) \
+ : ( 0x85 == ((U8*)s)[0] ) ) \
: ((e)-(s) > 0) ? \
- ( ( 0x0A <= NATIVE_TO_LATIN1(((U8*)s)[0]) && NATIVE_TO_LATIN1(((U8*)s)[0]) <= 0x0D ) ? 1\
+ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) ? 1 \
: ( !( is_utf8 ) ) ? \
- ( 0x85 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) \
+ ( 0x85 == ((U8*)s)[0] ) \
: 0 ) \
: 0 )
/*** GENERATED CODE ***/
+#define is_LNBREAK_utf8(s) \
+( ( 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 ) \
+: ( 0xE2 == ((U8*)s)[0] ) ? \
+ ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0xA8 == ((U8*)s)[2] || 0xA9 == ((U8*)s)[2] ) ) ? 3 : 0 )\
+: 0 )
+
+/*** GENERATED CODE ***/
#define is_LNBREAK_utf8_safe(s,e) \
( ((e)-(s) > 2) ? \
- ( ( 0x0A <= NATIVE_TO_LATIN1(((U8*)s)[0]) && NATIVE_TO_LATIN1(((U8*)s)[0]) <= 0x0C ) ? 1\
- : ( 0x0D == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x0A == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? 2 : 1 ) \
- : ( 0xC2 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x85 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? 2 : 0 ) \
- : ( ( ( 0xE2 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) && ( 0x80 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ) && ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) & 0xFE ) == 0xA8 ) ) ? 3 : 0 )\
+ ( ( 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 ) \
+ : ( 0xE2 == ((U8*)s)[0] ) ? \
+ ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0xA8 == ((U8*)s)[2] || 0xA9 == ((U8*)s)[2] ) ) ? 3 : 0 )\
+ : 0 ) \
: ((e)-(s) > 1) ? \
- ( ( 0x0A <= NATIVE_TO_LATIN1(((U8*)s)[0]) && NATIVE_TO_LATIN1(((U8*)s)[0]) <= 0x0C ) ? 1\
- : ( 0x0D == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x0A == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? 2 : 1 ) \
- : ( ( 0xC2 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) && ( 0x85 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ) ? 2 : 0 )\
+ ( ( 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 ) \
: ((e)-(s) > 0) ? \
- ( 0x0A <= NATIVE_TO_LATIN1(((U8*)s)[0]) && NATIVE_TO_LATIN1(((U8*)s)[0]) <= 0x0D )\
+ ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) \
: 0 )
/*** GENERATED CODE ***/
+#define is_LNBREAK_latin1(s) \
+( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0C ) ? 1 \
+: ( 0x0D == ((U8*)s)[0] ) ? \
+ ( ( 0x0A == ((U8*)s)[1] ) ? 2 : 1 ) \
+: ( 0x85 == ((U8*)s)[0] ) )
+
+/*** GENERATED CODE ***/
#define is_LNBREAK_latin1_safe(s,e) \
( ((e)-(s) > 1) ? \
- ( ( ( 0x0A <= NATIVE_TO_LATIN1(((U8*)s)[0]) && NATIVE_TO_LATIN1(((U8*)s)[0]) <= 0x0C ) || 0x85 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? 1\
- : ( 0x0D == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x0A == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? 2 : 1 ) \
- : 0 ) \
+ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0C ) ? 1 \
+ : ( 0x0D == ((U8*)s)[0] ) ? \
+ ( ( 0x0A == ((U8*)s)[1] ) ? 2 : 1 ) \
+ : ( 0x85 == ((U8*)s)[0] ) ) \
: ((e)-(s) > 0) ? \
- ( ( 0x0A <= NATIVE_TO_LATIN1(((U8*)s)[0]) && NATIVE_TO_LATIN1(((U8*)s)[0]) <= 0x0D ) || 0x85 == NATIVE_TO_LATIN1(((U8*)s)[0]) )\
+ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) || 0x85 == ((U8*)s)[0] )\
: 0 )
/*
HORIZWS: Horizontal Whitespace: \h \H
- \p{HorizSpace}
+ 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
*/
/*** GENERATED CODE ***/
-#define is_HORIZWS_high(s) \
-( ( 0xE1 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( 0x9A == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0x80 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
-: ( 0xE2 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x80 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0x8A ) || 0xAF == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ? 3 : 0 )\
- : ( ( 0x81 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0x9F == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
-: ( ( ( 0xE3 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) && ( 0x80 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ) && ( 0x80 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )
-
-/*** GENERATED CODE ***/
-#define is_HORIZWS_cp_high(cp) \
-( 0x1680 == NATIVE_TO_UNI(cp) || ( 0x1680 < NATIVE_TO_UNI(cp) && \
-( ( 0x2000 <= NATIVE_TO_UNI(cp) && NATIVE_TO_UNI(cp) <= 0x200A ) || ( 0x200A < NATIVE_TO_UNI(cp) &&\
-( 0x202F == NATIVE_TO_UNI(cp) || ( 0x202F < NATIVE_TO_UNI(cp) && \
-( 0x205F == NATIVE_TO_UNI(cp) || 0x3000 == NATIVE_TO_UNI(cp) ) ) ) ) ) ) )
-
-/*
- VERTWS: Vertical Whitespace: \v \V
-
- \p{VertSpace}
-*/
-/*** GENERATED CODE ***/
-#define is_VERTWS_high(s) \
-( ( ( ( 0xE2 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) && ( 0x80 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ) && ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) & 0xFE ) == 0xA8 ) ) ? 3 : 0 )
+#define is_HORIZWS(s,is_utf8) \
+( ( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] ) ? 1 \
+: ( is_utf8 ) ? \
+ ( ( 0xC2 == ((U8*)s)[0] ) ? \
+ ( ( 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 ) \
+ : 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 ) \
+: ( 0xA0 == ((U8*)s)[0] ) )
/*** GENERATED CODE ***/
-#define is_VERTWS_cp_high(cp) \
-( 0x2028 == NATIVE_TO_UNI(cp) || 0x2029 == NATIVE_TO_UNI(cp) )
-
-/*
- XDIGIT: Hexadecimal digits
-
- \p{XDigit}
-*/
-/*** GENERATED CODE ***/
-#define is_XDIGIT_high(s) \
-( ( 0xEF == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0xBC == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( ( 0x90 <= NATIVE_TO_LATIN1(((U8*)s)[2]) && NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0x99 ) || ( 0xA1 <= NATIVE_TO_LATIN1(((U8*)s)[2]) && NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0xA6 ) ) ? 3 : 0 )\
- : ( ( 0xBD == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0x81 <= NATIVE_TO_LATIN1(((U8*)s)[2]) && NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0x86 ) ) ? 3 : 0 )\
+#define is_HORIZWS_safe(s,e,is_utf8) \
+( ((e)-(s) > 2) ? \
+ ( ( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] ) ? 1 \
+ : ( is_utf8 ) ? \
+ ( ( 0xC2 == ((U8*)s)[0] ) ? \
+ ( ( 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 ) \
+ : 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 ) \
+ : ( 0xA0 == ((U8*)s)[0] ) ) \
+: ((e)-(s) > 1) ? \
+ ( ( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] ) ? 1 \
+ : ( is_utf8 ) ? \
+ ( ( ( 0xC2 == ((U8*)s)[0] ) && ( 0xA0 == ((U8*)s)[1] ) ) ? 2 : 0 ) \
+ : ( 0xA0 == ((U8*)s)[0] ) ) \
+: ((e)-(s) > 0) ? \
+ ( ( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] ) ? 1 \
+ : ( !( is_utf8 ) ) ? \
+ ( 0xA0 == ((U8*)s)[0] ) \
+ : 0 ) \
: 0 )
/*** GENERATED CODE ***/
-#define is_XDIGIT_cp_high(cp) \
-( ( 0xFF10 <= NATIVE_TO_UNI(cp) && NATIVE_TO_UNI(cp) <= 0xFF19 ) || ( 0xFF19 < NATIVE_TO_UNI(cp) &&\
-( ( 0xFF21 <= NATIVE_TO_UNI(cp) && NATIVE_TO_UNI(cp) <= 0xFF26 ) || ( 0xFF41 <= NATIVE_TO_UNI(cp) && NATIVE_TO_UNI(cp) <= 0xFF46 ) ) ) )
-
-/*
- XPERLSPACE: \p{XPerlSpace}
-
- \p{XPerlSpace}
-*/
-/*** GENERATED CODE ***/
-#define is_XPERLSPACE_high(s) \
-( ( 0xE1 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( 0x9A == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0x80 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
-: ( 0xE2 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x80 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0x8A ) || ( NATIVE_TO_LATIN1(((U8*)s)[2]) & 0xFE ) == 0xA8 || 0xAF == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ? 3 : 0 )\
- : ( ( 0x81 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0x9F == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
-: ( ( ( 0xE3 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) && ( 0x80 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ) && ( 0x80 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )
-
-/*** GENERATED CODE ***/
-#define is_XPERLSPACE_cp_high(cp) \
-( 0x1680 == NATIVE_TO_UNI(cp) || ( 0x1680 < NATIVE_TO_UNI(cp) && \
-( ( 0x2000 <= NATIVE_TO_UNI(cp) && NATIVE_TO_UNI(cp) <= 0x200A ) || ( 0x200A < NATIVE_TO_UNI(cp) &&\
-( 0x2028 == NATIVE_TO_UNI(cp) || ( 0x2028 < NATIVE_TO_UNI(cp) && \
-( 0x2029 == NATIVE_TO_UNI(cp) || ( 0x2029 < NATIVE_TO_UNI(cp) && \
-( 0x202F == NATIVE_TO_UNI(cp) || ( 0x202F < NATIVE_TO_UNI(cp) && \
-( 0x205F == NATIVE_TO_UNI(cp) || 0x3000 == NATIVE_TO_UNI(cp) ) ) ) ) ) ) ) ) ) ) )
-
-/*
- REPLACEMENT: Unicode REPLACEMENT CHARACTER
-
- 0xFFFD
-*/
-/*** GENERATED CODE ***/
-#define is_REPLACEMENT_utf8_safe(s,e) \
-( ( ( ( ( ((e) - (s)) >= 3 ) && ( 0xEF == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ) && ( 0xBF == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ) && ( 0xBD == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )
-
-/*
- NONCHAR: Non character code points
-
- \p{Nchar}
-*/
-/*** GENERATED CODE ***/
-#define is_NONCHAR_utf8(s) \
-( ( 0xEF == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0xB7 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( 0x90 <= NATIVE_TO_LATIN1(((U8*)s)[2]) && NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0xAF ) ? 3 : 0 )\
- : ( ( 0xBF == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( NATIVE_TO_LATIN1(((U8*)s)[2]) >= 0xBE ) ) ? 3 : 0 )\
-: ( 0xF0 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( ( NATIVE_TO_LATIN1(((U8*)s)[1]) == 0x9F || ( ( NATIVE_TO_LATIN1(((U8*)s)[1]) & 0xEF ) == 0xAF ) ) && ( 0xBF == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) && ( NATIVE_TO_LATIN1(((U8*)s)[3]) >= 0xBE ) ) ? 4 : 0 )\
-: ( 0xF1 <= NATIVE_TO_LATIN1(((U8*)s)[0]) && NATIVE_TO_LATIN1(((U8*)s)[0]) <= 0xF3 ) ?\
- ( ( ( ( ( NATIVE_TO_LATIN1(((U8*)s)[1]) & 0xCF ) == 0x8F ) && ( 0xBF == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) && ( NATIVE_TO_LATIN1(((U8*)s)[3]) >= 0xBE ) ) ? 4 : 0 )\
-: ( ( ( ( 0xF4 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) && ( 0x8F == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ) && ( 0xBF == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) && ( NATIVE_TO_LATIN1(((U8*)s)[3]) >= 0xBE ) ) ? 4 : 0 )
-
-/*
- SURROGATE: Surrogate characters
-
- \p{Gc=Cs}
-*/
-/*** GENERATED CODE ***/
-#define is_SURROGATE_utf8(s) \
-( ( ( 0xED == NATIVE_TO_LATIN1(((U8*)s)[0]) ) && ( NATIVE_TO_LATIN1(((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 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x84 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- 3 \
- : ( ( 0x85 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0x9F ) ) ? 3 : 0 )\
-: ( ( ( 0xEA == NATIVE_TO_LATIN1(((U8*)s)[0]) ) && ( 0xA5 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ) && ( 0xA0 <= NATIVE_TO_LATIN1(((U8*)s)[2]) && NATIVE_TO_LATIN1(((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 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x85 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) >= 0xA0 ) ? 3 : 0 ) \
- : ( ( 0x86 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0xA7 ) ) ? 3 : 0 )\
-: ( 0xEA == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( NATIVE_TO_LATIN1(((U8*)s)[1]) >= 0xB0 ) ? \
- 3 \
+#define is_HORIZWS_utf8(s) \
+( ( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] ) ? 1 \
+: ( 0xC2 == ((U8*)s)[0] ) ? \
+ ( ( 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 ) \
+ : 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 ) \
-: ( 0xEB == NATIVE_TO_LATIN1(((U8*)s)[0]) || 0xEC == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ?\
- 3 \
-: ( 0xED == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( NATIVE_TO_LATIN1(((U8*)s)[1]) <= 0x9D ) ? \
- 3 \
- : ( 0x9E == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0xA3 ) || ( NATIVE_TO_LATIN1(((U8*)s)[2]) >= 0xB0 ) ) ? 3 : 0 )\
- : ( ( 0x9F == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0x86 ) ) ? 3 : 0 )\
+: ( 0xE3 == ((U8*)s)[0] ) ? \
+ ( ( ( 0x80 == ((U8*)s)[1] ) && ( 0x80 == ((U8*)s)[2] ) ) ? 3 : 0 ) \
: 0 )
-/*
- GCB_Prepend: Grapheme_Cluster_Break=Prepend
-
- \p{_X_GCB_Prepend}
-*/
-/*** GENERATED CODE ***/
-#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 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) && ( 0x9F == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ) && ( 0x87 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) && ( NATIVE_TO_LATIN1(((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 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( NATIVE_TO_LATIN1(((U8*)s)[1]) & 0xFC ) == 0x84 ) ? \
- 3 \
+#define is_HORIZWS_utf8_safe(s,e) \
+( ((e)-(s) > 2) ? \
+ ( ( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] ) ? 1 \
+ : ( 0xC2 == ((U8*)s)[0] ) ? \
+ ( ( 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 ) \
+ : 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 ) \
-: ( 0xEA == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0xA5 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( 0xA0 <= NATIVE_TO_LATIN1(((U8*)s)[2]) && NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0xBC ) ? 3 : 0 )\
- : ( NATIVE_TO_LATIN1(((U8*)s)[1]) >= 0xB0 ) ? \
- 3 \
+: ((e)-(s) > 1) ? \
+ ( ( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] ) ? 1 \
+ : ( 0xC2 == ((U8*)s)[0] ) ? \
+ ( ( 0xA0 == ((U8*)s)[1] ) ? 2 : 0 ) \
: 0 ) \
-: ( 0xEB == NATIVE_TO_LATIN1(((U8*)s)[0]) || 0xEC == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ?\
- 3 \
-: ( 0xED == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( NATIVE_TO_LATIN1(((U8*)s)[1]) <= 0x9D ) ? \
- 3 \
- : ( 0x9E == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0xA3 ) || ( NATIVE_TO_LATIN1(((U8*)s)[2]) >= 0xB0 ) ) ? 3 : 0 )\
- : ( ( 0x9F == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0x86 ) || ( 0x8B <= NATIVE_TO_LATIN1(((U8*)s)[2]) && NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0xBB ) ) ) ? 3 : 0 )\
-: ( ( ( ( 0xF0 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) && ( 0x9F == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ) && ( 0x87 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) && ( NATIVE_TO_LATIN1(((U8*)s)[3]) >= 0xA6 ) ) ? 4 : 0 )
-
-/*
- GCB_T: Grapheme_Cluster_Break=T
+: ((e)-(s) > 0) ? \
+ ( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] ) \
+: 0 )
- \p{_X_GCB_T}
-*/
/*** GENERATED CODE ***/
-#define is_GCB_T_utf8(s) \
-( ( 0xE1 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x86 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) >= 0xA8 ) ? 3 : 0 ) \
- : ( 0x87 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- 3 \
- : 0 ) \
-: ( ( ( 0xED == NATIVE_TO_LATIN1(((U8*)s)[0]) ) && ( 0x9F == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ) && ( 0x8B <= NATIVE_TO_LATIN1(((U8*)s)[2]) && NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0xBB ) ) ? 3 : 0 )
+#define is_HORIZWS_latin1(s) \
+( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] || 0xA0 == ((U8*)s)[0] )
-/*
- GCB_V: Grapheme_Cluster_Break=V
-
- \p{_X_GCB_V}
-*/
/*** GENERATED CODE ***/
-#define is_GCB_V_utf8(s) \
-( ( 0xE1 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x85 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) >= 0xA0 ) ? 3 : 0 ) \
- : ( ( 0x86 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0xA7 ) ) ? 3 : 0 )\
-: ( 0xED == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x9E == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) >= 0xB0 ) ? 3 : 0 ) \
- : ( ( 0x9F == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0x86 ) ) ? 3 : 0 )\
+#define is_HORIZWS_latin1_safe(s,e) \
+( ((e)-(s) > 0) ? \
+ ( 0x09 == ((U8*)s)[0] || 0x20 == ((U8*)s)[0] || 0xA0 == ((U8*)s)[0] ) \
: 0 )
-/*
- QUOTEMETA: Meta-characters that \Q should quote
-
- \p{_Perl_Quotemeta}
-*/
/*** GENERATED CODE ***/
-#define is_QUOTEMETA_high(s) \
-( ( 0xCD == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x8F == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? 2 : 0 ) \
-: ( 0xD8 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x9C == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? 2 : 0 ) \
-: ( 0xE1 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x85 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( 0x9F == NATIVE_TO_LATIN1(((U8*)s)[2]) || 0xA0 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ? 3 : 0 )\
- : ( 0x9A == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( 0x80 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ? 3 : 0 ) \
- : ( 0x9E == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) & 0xFE ) == 0xB4 ) ? 3 : 0 ) \
- : ( ( 0xA0 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0x8B <= NATIVE_TO_LATIN1(((U8*)s)[2]) && NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0x8E ) ) ? 3 : 0 )\
-: ( 0xE2 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x80 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0xBE ) ? 3 : 0 ) \
- : ( 0x81 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( ( 0x81 <= NATIVE_TO_LATIN1(((U8*)s)[2]) && NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0x93 ) || ( 0x95 <= NATIVE_TO_LATIN1(((U8*)s)[2]) && NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0xAF ) ) ? 3 : 0 )\
- : ( 0x86 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) >= 0x90 ) ? 3 : 0 ) \
- : ( ( 0x87 <= NATIVE_TO_LATIN1(((U8*)s)[1]) && NATIVE_TO_LATIN1(((U8*)s)[1]) <= 0x90 ) || ( 0x94 <= NATIVE_TO_LATIN1(((U8*)s)[1]) && NATIVE_TO_LATIN1(((U8*)s)[1]) <= 0x9C ) || ( 0x9F <= NATIVE_TO_LATIN1(((U8*)s)[1]) && NATIVE_TO_LATIN1(((U8*)s)[1]) <= 0xAF ) || ( NATIVE_TO_LATIN1(((U8*)s)[1]) & 0xFE ) == 0xB8 ) ?\
- 3 \
- : ( 0x91 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0x9F ) ? 3 : 0 ) \
- : ( 0x9D == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0xB5 ) ? 3 : 0 ) \
- : ( ( 0x9E == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( NATIVE_TO_LATIN1(((U8*)s)[2]) >= 0x94 ) ) ? 3 : 0 )\
-: ( 0xE3 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x80 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0x83 ) || ( 0x88 <= NATIVE_TO_LATIN1(((U8*)s)[2]) && NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0xA0 ) || 0xB0 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ? 3 : 0 )\
- : ( ( 0x85 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0xA4 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
-: ( 0xEF == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0xB4 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) >= 0xBE ) ? 3 : 0 ) \
- : ( 0xB8 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0x8F ) ? 3 : 0 ) \
- : ( 0xB9 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( 0x85 == NATIVE_TO_LATIN1(((U8*)s)[2]) || 0x86 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ? 3 : 0 )\
- : ( 0xBB == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( 0xBF == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ? 3 : 0 ) \
- : ( 0xBE == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( 0xA0 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ? 3 : 0 ) \
- : ( ( 0xBF == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0xB0 <= NATIVE_TO_LATIN1(((U8*)s)[2]) && NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0xB8 ) ) ? 3 : 0 )\
-: ( 0xF0 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( ( 0x9D == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0x85 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) && ( 0xB3 <= NATIVE_TO_LATIN1(((U8*)s)[3]) && NATIVE_TO_LATIN1(((U8*)s)[3]) <= 0xBA ) ) ? 4 : 0 )\
-: ( ( 0xF3 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) && ( 0xA0 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ) ? 4 : 0 )
+#define is_HORIZWS_cp(cp) \
+( 0x09 == cp || ( 0x09 < cp && \
+( 0x20 == cp || ( 0x20 < cp && \
+( 0xA0 == cp || ( 0xA0 < cp && \
+( 0x1680 == cp || ( 0x1680 < cp && \
+( 0x180E == cp || ( 0x180E < cp && \
+( ( 0x2000 <= cp && cp <= 0x200A ) || ( 0x200A < cp && \
+( 0x202F == cp || ( 0x202F < cp && \
+( 0x205F == cp || ( 0x205F < cp && \
+0x3000 == cp ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) )
/*
- MULTI_CHAR_FOLD: multi-char strings that are folded to by a single character
+ VERTWS: Vertical Whitespace: \v \V
- do regen/regcharclass_multi_char_folds.pl
- &regcharclass_multi_char_folds::multi_char_folds(1)
+ 0x0A # LF
+ 0x0B # VT
+ 0x0C # FF
+ 0x0D # CR
+ 0x85 # NEL
+ 0x2028 # LINE SEPARATOR
+ 0x2029 # PARAGRAPH SEPARATOR
*/
/*** GENERATED CODE ***/
-#define is_MULTI_CHAR_FOLD_utf8_safe_part0(s,e) \
-( ( 0x73 == NATIVE_TO_LATIN1(((U8*)s)[1]) || 0x74 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? 2 : 0 )
-
-
-/*** GENERATED CODE ***/
-#define is_MULTI_CHAR_FOLD_utf8_safe_part1(s,e) \
-( ( 0x74 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( 0xCC == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0x88 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
- : ( 0x77 == NATIVE_TO_LATIN1(((U8*)s)[0]) || 0x79 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ?\
- ( ( ( 0xCC == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0x8A == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
- : ( 0xC5 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( ( 0xBF == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0xC5 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) && ( 0xBF == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) ? 4 : 0 )\
- : ( 0xCA == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( 0xBC == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0x6E == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
- : ( 0xCE == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( NATIVE_TO_LATIN1(((U8*)s)[1]) & 0xFD ) == 0xAC ) ? \
- ( ( ( 0xCE == NATIVE_TO_LATIN1(((U8*)s)[2]) ) && ( 0xB9 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) ? 4 : 0 )\
- : ( 0xB1 == NATIVE_TO_LATIN1(((U8*)s)[1]) || 0xB7 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ?\
- ( ( 0xCD == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ? \
- ( ( 0x82 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ? \
- ( ( ( 0xCE == NATIVE_TO_LATIN1(((U8*)s)[4]) ) && ( 0xB9 == NATIVE_TO_LATIN1(((U8*)s)[5]) ) ) ? 6 : 4 )\
- : 0 ) \
- : ( ( 0xCE == NATIVE_TO_LATIN1(((U8*)s)[2]) ) && ( 0xB9 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) ? 4 : 0 )\
- : ( 0xB9 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( 0xCC == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ? \
- ( ( 0x88 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ? \
- ( ( 0xCC == NATIVE_TO_LATIN1(((U8*)s)[4]) ) ? \
- ( ( ( NATIVE_TO_LATIN1(((U8*)s)[5]) & 0xFE ) == 0x80 ) ? 6 : 0 )\
- : ( ( 0xCD == NATIVE_TO_LATIN1(((U8*)s)[4]) ) && ( 0x82 == NATIVE_TO_LATIN1(((U8*)s)[5]) ) ) ? 6 : 0 )\
- : 0 ) \
- : ( ( 0xCD == NATIVE_TO_LATIN1(((U8*)s)[2]) ) && ( 0x82 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) ? 4 : 0 )\
- : 0 ) \
- : ( 0xCF == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x81 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( ( 0xCC == NATIVE_TO_LATIN1(((U8*)s)[2]) ) && ( 0x93 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) ? 4 : 0 )\
- : ( 0x85 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( 0xCC == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ? \
- ( ( 0x88 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ? \
- ( ( 0xCC == NATIVE_TO_LATIN1(((U8*)s)[4]) ) ? \
- ( ( ( NATIVE_TO_LATIN1(((U8*)s)[5]) & 0xFE ) == 0x80 ) ? 6 : 0 )\
- : ( ( 0xCD == NATIVE_TO_LATIN1(((U8*)s)[4]) ) && ( 0x82 == NATIVE_TO_LATIN1(((U8*)s)[5]) ) ) ? 6 : 0 )\
- : ( 0x93 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ? \
- ( ( 0xCC == NATIVE_TO_LATIN1(((U8*)s)[4]) ) ? \
- ( ( ( NATIVE_TO_LATIN1(((U8*)s)[5]) & 0xFE ) == 0x80 ) ? 6 : 4 )\
- : ( ( 0xCD == NATIVE_TO_LATIN1(((U8*)s)[4]) ) && ( 0x82 == NATIVE_TO_LATIN1(((U8*)s)[5]) ) ) ? 6 : 4 )\
- : 0 ) \
- : ( ( 0xCD == NATIVE_TO_LATIN1(((U8*)s)[2]) ) && ( 0x82 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) ? 4 : 0 )\
- : ( 0x89 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( 0xCD == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ? \
- ( ( 0x82 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ? \
- ( ( ( 0xCE == NATIVE_TO_LATIN1(((U8*)s)[4]) ) && ( 0xB9 == NATIVE_TO_LATIN1(((U8*)s)[5]) ) ) ? 6 : 4 )\
- : 0 ) \
- : ( ( 0xCE == NATIVE_TO_LATIN1(((U8*)s)[2]) ) && ( 0xB9 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) ? 4 : 0 )\
- : ( ( ( 0x8E == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0xCE == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) && ( 0xB9 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) ? 4 : 0 )\
- : ( 0xD5 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0xA5 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( ( 0xD6 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) && ( 0x82 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) ? 4 : 0 )\
- : ( 0xB4 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( ( 0xD5 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) && ( ( ( NATIVE_TO_LATIN1(((U8*)s)[3]) & 0xF7 ) == 0xA5 ) || NATIVE_TO_LATIN1(((U8*)s)[3]) == 0xAB || NATIVE_TO_LATIN1(((U8*)s)[3]) == 0xB6 ) ) ? 4 : 0 )\
- : ( ( ( 0xBE == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0xD5 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) && ( 0xB6 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) ? 4 : 0 )\
- : ( 0xE1 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0xBC == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( ( ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) & 0xD8 ) == 0x80 ) && ( 0xCE == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) && ( 0xB9 == NATIVE_TO_LATIN1(((U8*)s)[4]) ) ) ? 5 : 0 )\
- : ( ( ( ( 0xBD == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) & 0xF8 ) == 0xA0 ) || ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) & 0xFB ) == 0xB0 ) || NATIVE_TO_LATIN1(((U8*)s)[2]) == 0xBC ) ) && ( 0xCE == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) && ( 0xB9 == NATIVE_TO_LATIN1(((U8*)s)[4]) ) ) ? 5 : 0 )\
- : 0 )
-
-
-/*** GENERATED CODE ***/
-#define is_MULTI_CHAR_FOLD_utf8_safe_part2(s,e) \
-( ( 0x61 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( 0xCA == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0xBE == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
- : ( 0x66 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x66 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( 0x69 == NATIVE_TO_LATIN1(((U8*)s)[2]) || 0x6C == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ? 3 : 2 )\
- : ( 0x69 == NATIVE_TO_LATIN1(((U8*)s)[1]) || 0x6C == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? 2 : 0 )\
- : ( 0x68 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( 0xCC == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0xB1 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
- : ( 0x69 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( 0xCC == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0x87 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
- : ( 0x6A == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( 0xCC == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0x8C == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
- : ( 0x73 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x73 == NATIVE_TO_LATIN1(((U8*)s)[1]) || 0x74 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? 2 : 0 )\
- : ( 0x74 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( 0xCC == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0x88 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
- : ( 0x77 == NATIVE_TO_LATIN1(((U8*)s)[0]) || 0x79 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ?\
- ( ( ( 0xCC == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0x8A == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
- : ( 0xC5 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( ( 0xBF == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0xC5 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) && ( 0xBF == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) ? 4 : 0 )\
- : ( 0xCA == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( 0xBC == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0x6E == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
- : ( 0xCE == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( NATIVE_TO_LATIN1(((U8*)s)[1]) & 0xFD ) == 0xAC ) ? \
- ( ( ( 0xCE == NATIVE_TO_LATIN1(((U8*)s)[2]) ) && ( 0xB9 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) ? 4 : 0 )\
- : ( 0xB1 == NATIVE_TO_LATIN1(((U8*)s)[1]) || 0xB7 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ?\
- ( ( 0xCD == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ? \
- ( ( 0x82 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ? 4 : 0 ) \
- : ( ( 0xCE == NATIVE_TO_LATIN1(((U8*)s)[2]) ) && ( 0xB9 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) ? 4 : 0 )\
- : ( ( ( 0xB9 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0xCD == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) && ( 0x82 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) ? 4 : 0 )\
- : ( 0xCF == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x81 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( ( 0xCC == NATIVE_TO_LATIN1(((U8*)s)[2]) ) && ( 0x93 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) ? 4 : 0 )\
- : ( 0x85 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( 0xCC == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ? \
- ( ( 0x93 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ? 4 : 0 ) \
- : ( ( 0xCD == NATIVE_TO_LATIN1(((U8*)s)[2]) ) && ( 0x82 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) ? 4 : 0 )\
- : ( 0x89 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( 0xCD == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ? \
- ( ( 0x82 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ? 4 : 0 ) \
- : ( ( 0xCE == NATIVE_TO_LATIN1(((U8*)s)[2]) ) && ( 0xB9 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) ? 4 : 0 )\
- : ( ( ( 0x8E == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0xCE == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) && ( 0xB9 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) ? 4 : 0 )\
- : ( 0xD5 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0xA5 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( ( 0xD6 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) && ( 0x82 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) ? 4 : 0 )\
- : ( 0xB4 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( ( 0xD5 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) && ( ( ( NATIVE_TO_LATIN1(((U8*)s)[3]) & 0xF7 ) == 0xA5 ) || NATIVE_TO_LATIN1(((U8*)s)[3]) == 0xAB || NATIVE_TO_LATIN1(((U8*)s)[3]) == 0xB6 ) ) ? 4 : 0 )\
- : ( ( ( 0xBE == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0xD5 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) && ( 0xB6 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) ? 4 : 0 )\
- : 0 )
-
+#define is_VERTWS(s,is_utf8) \
+( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) ? 1 \
+: ( 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 ) \
+: ( 0x85 == ((U8*)s)[0] ) )
/*** GENERATED CODE ***/
-#define is_MULTI_CHAR_FOLD_utf8_safe_part3(s,e) \
+#define is_VERTWS_safe(s,e,is_utf8) \
( ((e)-(s) > 2) ? \
- ( ( 0x61 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( 0xCA == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0xBE == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
- : ( 0x66 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x66 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( 0x69 == NATIVE_TO_LATIN1(((U8*)s)[2]) || 0x6C == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ? 3 : 2 )\
- : ( 0x69 == NATIVE_TO_LATIN1(((U8*)s)[1]) || 0x6C == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? 2 : 0 )\
- : ( 0x68 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( 0xCC == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0xB1 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
- : ( 0x69 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( 0xCC == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0x87 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
- : ( 0x6A == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( 0xCC == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0x8C == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
- : ( 0x73 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x73 == NATIVE_TO_LATIN1(((U8*)s)[1]) || 0x74 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? 2 : 0 )\
- : ( 0x74 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( 0xCC == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0x88 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
- : ( 0x77 == NATIVE_TO_LATIN1(((U8*)s)[0]) || 0x79 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ?\
- ( ( ( 0xCC == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0x8A == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
- : ( ( ( 0xCA == NATIVE_TO_LATIN1(((U8*)s)[0]) ) && ( 0xBC == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ) && ( 0x6E == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
+ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) ? 1 \
+ : ( 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 ) \
+ : ( 0x85 == ((U8*)s)[0] ) ) \
: ((e)-(s) > 1) ? \
- ( ( 0x66 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x66 == NATIVE_TO_LATIN1(((U8*)s)[1]) || 0x69 == NATIVE_TO_LATIN1(((U8*)s)[1]) || 0x6C == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? 2 : 0 )\
- : ( ( 0x73 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) && ( 0x73 == NATIVE_TO_LATIN1(((U8*)s)[1]) || 0x74 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ) ? 2 : 0 )\
+ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) ? 1 \
+ : ( is_utf8 ) ? \
+ ( ( ( 0xC2 == ((U8*)s)[0] ) && ( 0x85 == ((U8*)s)[1] ) ) ? 2 : 0 ) \
+ : ( 0x85 == ((U8*)s)[0] ) ) \
+: ((e)-(s) > 0) ? \
+ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) ? 1 \
+ : ( !( is_utf8 ) ) ? \
+ ( 0x85 == ((U8*)s)[0] ) \
+ : 0 ) \
: 0 )
-
/*** GENERATED CODE ***/
-#define is_MULTI_CHAR_FOLD_utf8_safe_part4(s,e) \
-( ( 0x61 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( 0xCA == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0xBE == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
- : ( 0x66 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x66 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( 0x69 == NATIVE_TO_LATIN1(((U8*)s)[2]) || 0x6C == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ? 3 : 2 )\
- : ( 0x69 == NATIVE_TO_LATIN1(((U8*)s)[1]) || 0x6C == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? 2 : 0 )\
- : ( 0x68 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( 0xCC == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0xB1 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
- : ( 0x69 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( 0xCC == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0x87 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
- : ( 0x6A == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( 0xCC == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0x8C == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
- : ( 0x73 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? is_MULTI_CHAR_FOLD_utf8_safe_part0(s,e) : is_MULTI_CHAR_FOLD_utf8_safe_part1(s,e) )
-
+#define is_VERTWS_utf8(s) \
+( ( 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 )
/*** GENERATED CODE ***/
-#define is_MULTI_CHAR_FOLD_utf8_safe_part5(s,e) \
-( ((e)-(s) > 4) ? \
- ( ( 0x61 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( 0xCA == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0xBE == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
- : ( 0x66 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x66 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( 0x69 == NATIVE_TO_LATIN1(((U8*)s)[2]) || 0x6C == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ? 3 : 2 )\
- : ( 0x69 == NATIVE_TO_LATIN1(((U8*)s)[1]) || 0x6C == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? 2 : 0 )\
- : ( 0x68 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( 0xCC == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0xB1 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
- : ( 0x69 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( 0xCC == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0x87 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
- : ( 0x6A == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( 0xCC == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0x8C == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
- : ( 0x73 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x73 == NATIVE_TO_LATIN1(((U8*)s)[1]) || 0x74 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? 2 : 0 )\
- : ( 0x74 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( 0xCC == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0x88 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
- : ( 0x77 == NATIVE_TO_LATIN1(((U8*)s)[0]) || 0x79 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ?\
- ( ( ( 0xCC == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0x8A == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
- : ( 0xC5 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( ( 0xBF == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0xC5 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) && ( 0xBF == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) ? 4 : 0 )\
- : ( 0xCA == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( 0xBC == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0x6E == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
- : ( 0xCE == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( NATIVE_TO_LATIN1(((U8*)s)[1]) & 0xFD ) == 0xAC ) ? \
- ( ( ( 0xCE == NATIVE_TO_LATIN1(((U8*)s)[2]) ) && ( 0xB9 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) ? 4 : 0 )\
- : ( 0xB1 == NATIVE_TO_LATIN1(((U8*)s)[1]) || 0xB7 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ?\
- ( ( 0xCD == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ? \
- ( ( 0x82 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ? 4 : 0 ) \
- : ( ( 0xCE == NATIVE_TO_LATIN1(((U8*)s)[2]) ) && ( 0xB9 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) ? 4 : 0 )\
- : ( ( ( 0xB9 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0xCD == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) && ( 0x82 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) ? 4 : 0 )\
- : ( 0xCF == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x81 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( ( 0xCC == NATIVE_TO_LATIN1(((U8*)s)[2]) ) && ( 0x93 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) ? 4 : 0 )\
- : ( 0x85 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( 0xCC == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ? \
- ( ( 0x93 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ? 4 : 0 ) \
- : ( ( 0xCD == NATIVE_TO_LATIN1(((U8*)s)[2]) ) && ( 0x82 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) ? 4 : 0 )\
- : ( 0x89 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( 0xCD == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ? \
- ( ( 0x82 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ? 4 : 0 ) \
- : ( ( 0xCE == NATIVE_TO_LATIN1(((U8*)s)[2]) ) && ( 0xB9 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) ? 4 : 0 )\
- : ( ( ( 0x8E == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0xCE == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) && ( 0xB9 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) ? 4 : 0 )\
- : ( 0xD5 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0xA5 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( ( 0xD6 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) && ( 0x82 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) ? 4 : 0 )\
- : ( 0xB4 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( ( 0xD5 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) && ( ( ( NATIVE_TO_LATIN1(((U8*)s)[3]) & 0xF7 ) == 0xA5 ) || NATIVE_TO_LATIN1(((U8*)s)[3]) == 0xAB || NATIVE_TO_LATIN1(((U8*)s)[3]) == 0xB6 ) ) ? 4 : 0 )\
- : ( ( ( 0xBE == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( 0xD5 == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) && ( 0xB6 == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) ? 4 : 0 )\
- : ( 0xE1 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0xBC == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( ( ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) & 0xD8 ) == 0x80 ) && ( 0xCE == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) && ( 0xB9 == NATIVE_TO_LATIN1(((U8*)s)[4]) ) ) ? 5 : 0 )\
- : ( ( ( ( 0xBD == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) & 0xF8 ) == 0xA0 ) || ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) & 0xFB ) == 0xB0 ) || NATIVE_TO_LATIN1(((U8*)s)[2]) == 0xBC ) ) && ( 0xCE == NATIVE_TO_LATIN1(((U8*)s)[3]) ) ) && ( 0xB9 == NATIVE_TO_LATIN1(((U8*)s)[4]) ) ) ? 5 : 0 )\
+#define is_VERTWS_utf8_safe(s,e) \
+( ((e)-(s) > 2) ? \
+ ( ( 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 ) \
-: ((e)-(s) > 3) ? is_MULTI_CHAR_FOLD_utf8_safe_part2(s,e) : is_MULTI_CHAR_FOLD_utf8_safe_part3(s,e) )
-
+: ((e)-(s) > 1) ? \
+ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) ? 1 \
+ : ( 0xC2 == ((U8*)s)[0] ) ? \
+ ( ( 0x85 == ((U8*)s)[1] ) ? 2 : 0 ) \
+ : 0 ) \
+: ((e)-(s) > 0) ? \
+ ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) \
+: 0 )
/*** GENERATED CODE ***/
-#define is_MULTI_CHAR_FOLD_utf8_safe(s,e) \
-( ((e)-(s) > 5) ? is_MULTI_CHAR_FOLD_utf8_safe_part4(s,e) : is_MULTI_CHAR_FOLD_utf8_safe_part5(s,e) )
-
-/*
- MULTI_CHAR_FOLD: multi-char strings that are folded to by a single character
+#define is_VERTWS_latin1(s) \
+( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) || 0x85 == ((U8*)s)[0] )
- &regcharclass_multi_char_folds::multi_char_folds(0)
-*/
/*** GENERATED CODE ***/
-#define is_MULTI_CHAR_FOLD_latin1_safe(s,e) \
-( ((e)-(s) > 2) ? \
- ( ( ( NATIVE_TO_LATIN1(((U8*)s)[0]) & 0xDF ) == 0x46 ) ? \
- ( ( ( NATIVE_TO_LATIN1(((U8*)s)[1]) & 0xDF ) == 0x46 ) ? \
- ( ( ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) & 0xDF ) == 0x49 ) || ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) & 0xDF ) == 0x4C ) ) ? 3 : 2 )\
- : ( ( ( NATIVE_TO_LATIN1(((U8*)s)[1]) & 0xDF ) == 0x49 ) || ( ( NATIVE_TO_LATIN1(((U8*)s)[1]) & 0xDF ) == 0x4C ) ) ? 2 : 0 )\
- : ( ( ( NATIVE_TO_LATIN1(((U8*)s)[0]) & 0xDF ) == 0x53 ) && ( ( ( NATIVE_TO_LATIN1(((U8*)s)[1]) & 0xDF ) == 0x53 ) || ( ( NATIVE_TO_LATIN1(((U8*)s)[1]) & 0xDF ) == 0x54 ) ) ) ? 2 : 0 )\
-: ((e)-(s) > 1) ? \
- ( ( ( NATIVE_TO_LATIN1(((U8*)s)[0]) & 0xDF ) == 0x46 ) ? \
- ( ( ( ( NATIVE_TO_LATIN1(((U8*)s)[1]) & 0xDF ) == 0x46 ) || ( ( NATIVE_TO_LATIN1(((U8*)s)[1]) & 0xDF ) == 0x49 ) || ( ( NATIVE_TO_LATIN1(((U8*)s)[1]) & 0xDF ) == 0x4C ) ) ? 2 : 0 )\
- : ( ( ( NATIVE_TO_LATIN1(((U8*)s)[0]) & 0xDF ) == 0x53 ) && ( ( ( NATIVE_TO_LATIN1(((U8*)s)[1]) & 0xDF ) == 0x53 ) || ( ( NATIVE_TO_LATIN1(((U8*)s)[1]) & 0xDF ) == 0x54 ) ) ) ? 2 : 0 )\
+#define is_VERTWS_latin1_safe(s,e) \
+( ((e)-(s) > 0) ? \
+ ( ( 0x0A <= ((U8*)s)[0] && ((U8*)s)[0] <= 0x0D ) || 0x85 == ((U8*)s)[0] )\
: 0 )
-/*
- FOLDS_TO_MULTI: characters that fold to multi-char strings
-
- \p{_Perl_Folds_To_Multi_Char}
-*/
/*** GENERATED CODE ***/
-#define is_FOLDS_TO_MULTI_utf8(s) \
-( ( 0xC3 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x9F == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? 2 : 0 ) \
-: ( 0xC4 == NATIVE_TO_LATIN1(((U8*)s)[0]) || 0xC7 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ?\
- ( ( 0xB0 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? 2 : 0 ) \
-: ( 0xC5 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x89 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? 2 : 0 ) \
-: ( 0xCE == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( NATIVE_TO_LATIN1(((U8*)s)[1]) & 0xDF ) == 0x90 ) ? 2 : 0 ) \
-: ( 0xD6 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x87 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? 2 : 0 ) \
-: ( 0xE1 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0xBA == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( ( 0x96 <= NATIVE_TO_LATIN1(((U8*)s)[2]) && NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0x9A ) || 0x9E == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ? 3 : 0 )\
- : ( 0xBD == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) & 0xF9 ) == 0x90 ) ? 3 : 0 ) \
- : ( 0xBE == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? \
- ( ( ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) & 0xE0 ) == 0x80 ) || ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) & 0xF0 ) == 0xA0 ) || ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) & 0xFA ) == 0xB2 ) || ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) & 0xF7 ) == 0xB4 ) ) ? 3 : 0 )\
- : ( ( 0xBF == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) & 0xCA ) == 0x82 ) || ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) & 0xF7 ) == 0x84 ) || NATIVE_TO_LATIN1(((U8*)s)[2]) == 0xA4 || ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) & 0xF7 ) == 0xB4 ) ) ) ? 3 : 0 )\
-: ( ( ( 0xEF == NATIVE_TO_LATIN1(((U8*)s)[0]) ) && ( 0xAC == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ) && ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0x86 ) || ( 0x93 <= NATIVE_TO_LATIN1(((U8*)s)[2]) && NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0x97 ) ) ) ? 3 : 0 )
+#define is_VERTWS_cp(cp) \
+( ( 0x0A <= cp && cp <= 0x0D ) || ( 0x0D < cp && \
+( 0x85 == cp || ( 0x85 < cp && \
+( 0x2028 == cp || ( 0x2028 < cp && \
+0x2029 == cp ) ) ) ) ) )
/*
- PROBLEMATIC_LOCALE_FOLD: characters whose fold is problematic under locale
+ TRICKYFOLD: Problematic fold case letters.
- \p{_Perl_Problematic_Locale_Folds}
+ 0x00DF # LATIN1 SMALL LETTER SHARP S
+ 0x0390 # GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
+ 0x03B0 # GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
*/
/*** GENERATED CODE ***/
-#define is_PROBLEMATIC_LOCALE_FOLD_utf8(s) \
-( ( ( NATIVE_TO_LATIN1(((U8*)s)[0]) & 0x80 ) == 0x00 ) ? 1 \
-: ( ( NATIVE_TO_LATIN1(((U8*)s)[0]) & 0xFE ) == 0xC2 ) ? \
- 2 \
-: ( 0xC4 == NATIVE_TO_LATIN1(((U8*)s)[0]) || 0xC7 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ?\
- ( ( 0xB0 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? 2 : 0 ) \
-: ( 0xC5 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x89 == NATIVE_TO_LATIN1(((U8*)s)[1]) || 0xB8 == NATIVE_TO_LATIN1(((U8*)s)[1]) || 0xBF == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? 2 : 0 )\
-: ( 0xCE == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( NATIVE_TO_LATIN1(((U8*)s)[1]) & 0xDF ) == 0x9C ) ? 2 : 0 ) \
-: ( 0xE1 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( 0xBA == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( ( 0x96 <= NATIVE_TO_LATIN1(((U8*)s)[2]) && NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0x9A ) || 0x9E == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
-: ( 0xE2 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( 0x84 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) & 0xFE ) == 0xAA ) ) ? 3 : 0 )\
-: ( ( ( 0xEF == NATIVE_TO_LATIN1(((U8*)s)[0]) ) && ( 0xAC == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ) && ( NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0x86 ) ) ? 3 : 0 )
+#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 ) \
+ : 0 ) \
+: ( 0xDF == ((U8*)s)[0] ) )
/*** GENERATED CODE ***/
-#define is_PROBLEMATIC_LOCALE_FOLD_cp(cp) \
-( NATIVE_TO_UNI(cp) <= 0xFF || ( 0xFF < NATIVE_TO_UNI(cp) && \
-( 0x130 == NATIVE_TO_UNI(cp) || ( 0x130 < NATIVE_TO_UNI(cp) && \
-( 0x149 == NATIVE_TO_UNI(cp) || ( 0x149 < NATIVE_TO_UNI(cp) && \
-( 0x178 == NATIVE_TO_UNI(cp) || ( 0x178 < NATIVE_TO_UNI(cp) && \
-( 0x17F == NATIVE_TO_UNI(cp) || ( 0x17F < NATIVE_TO_UNI(cp) && \
-( 0x1F0 == NATIVE_TO_UNI(cp) || ( 0x1F0 < NATIVE_TO_UNI(cp) && \
-( 0x39C == NATIVE_TO_UNI(cp) || ( 0x39C < NATIVE_TO_UNI(cp) && \
-( 0x3BC == NATIVE_TO_UNI(cp) || ( 0x3BC < NATIVE_TO_UNI(cp) && \
-( ( 0x1E96 <= NATIVE_TO_UNI(cp) && NATIVE_TO_UNI(cp) <= 0x1E9A ) || ( 0x1E9A < NATIVE_TO_UNI(cp) &&\
-( 0x1E9E == NATIVE_TO_UNI(cp) || ( 0x1E9E < NATIVE_TO_UNI(cp) && \
-( 0x212A == NATIVE_TO_UNI(cp) || ( 0x212A < NATIVE_TO_UNI(cp) && \
-( 0x212B == NATIVE_TO_UNI(cp) || ( 0xFB00 <= NATIVE_TO_UNI(cp) && NATIVE_TO_UNI(cp) <= 0xFB06 ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) )
-
-/*
- PROBLEMATIC_LOCALE_FOLDEDS_START: The first folded character of folds which are problematic under locale
+#define is_TRICKYFOLD_safe(s,e,is_utf8) \
+( ((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] ) \
+ : 0 ) \
+: 0 )
- \p{_Perl_Problematic_Locale_Foldeds_Start}
-*/
/*** GENERATED CODE ***/
-#define is_PROBLEMATIC_LOCALE_FOLDEDS_START_utf8(s) \
-( ( ( NATIVE_TO_LATIN1(((U8*)s)[0]) & 0x80 ) == 0x00 ) ? 1 \
-: ( ( NATIVE_TO_LATIN1(((U8*)s)[0]) & 0xFE ) == 0xC2 ) ? \
- 2 \
-: ( 0xC4 == NATIVE_TO_LATIN1(((U8*)s)[0]) || 0xC7 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ?\
- ( ( 0xB0 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? 2 : 0 ) \
-: ( 0xC5 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x89 == NATIVE_TO_LATIN1(((U8*)s)[1]) || 0xB8 == NATIVE_TO_LATIN1(((U8*)s)[1]) || 0xBF == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? 2 : 0 )\
-: ( 0xCA == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0xBC == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? 2 : 0 ) \
-: ( 0xCE == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( NATIVE_TO_LATIN1(((U8*)s)[1]) & 0xDF ) == 0x9C ) ? 2 : 0 ) \
-: ( 0xE1 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( 0xBA == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( ( 0x96 <= NATIVE_TO_LATIN1(((U8*)s)[2]) && NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0x9A ) || 0x9E == NATIVE_TO_LATIN1(((U8*)s)[2]) ) ) ? 3 : 0 )\
-: ( 0xE2 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( ( 0x84 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) && ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) & 0xFE ) == 0xAA ) ) ? 3 : 0 )\
-: ( ( ( 0xEF == NATIVE_TO_LATIN1(((U8*)s)[0]) ) && ( 0xAC == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ) && ( NATIVE_TO_LATIN1(((U8*)s)[2]) <= 0x86 ) ) ? 3 : 0 )
+#define is_TRICKYFOLD_cp(cp) \
+( 0xDF == cp || ( 0xDF < cp && \
+( 0x390 == cp || ( 0x390 < cp && \
+0x3B0 == cp ) ) ) )
/*** GENERATED CODE ***/
-#define is_PROBLEMATIC_LOCALE_FOLDEDS_START_cp(cp) \
-( NATIVE_TO_UNI(cp) <= 0xFF || ( 0xFF < NATIVE_TO_UNI(cp) && \
-( 0x130 == NATIVE_TO_UNI(cp) || ( 0x130 < NATIVE_TO_UNI(cp) && \
-( 0x149 == NATIVE_TO_UNI(cp) || ( 0x149 < NATIVE_TO_UNI(cp) && \
-( 0x178 == NATIVE_TO_UNI(cp) || ( 0x178 < NATIVE_TO_UNI(cp) && \
-( 0x17F == NATIVE_TO_UNI(cp) || ( 0x17F < NATIVE_TO_UNI(cp) && \
-( 0x1F0 == NATIVE_TO_UNI(cp) || ( 0x1F0 < NATIVE_TO_UNI(cp) && \
-( 0x2BC == NATIVE_TO_UNI(cp) || ( 0x2BC < NATIVE_TO_UNI(cp) && \
-( 0x39C == NATIVE_TO_UNI(cp) || ( 0x39C < NATIVE_TO_UNI(cp) && \
-( 0x3BC == NATIVE_TO_UNI(cp) || ( 0x3BC < NATIVE_TO_UNI(cp) && \
-( ( 0x1E96 <= NATIVE_TO_UNI(cp) && NATIVE_TO_UNI(cp) <= 0x1E9A ) || ( 0x1E9A < NATIVE_TO_UNI(cp) &&\
-( 0x1E9E == NATIVE_TO_UNI(cp) || ( 0x1E9E < NATIVE_TO_UNI(cp) && \
-( 0x212A == NATIVE_TO_UNI(cp) || ( 0x212A < NATIVE_TO_UNI(cp) && \
-( 0x212B == NATIVE_TO_UNI(cp) || ( 0xFB00 <= NATIVE_TO_UNI(cp) && NATIVE_TO_UNI(cp) <= 0xFB06 ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) )
-
-/*
- PATWS: pattern white space
+#define what_TRICKYFOLD(s,is_utf8) \
+( ( 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 )
- \p{PatWS}
-*/
/*** GENERATED CODE ***/
-#define is_PATWS_safe(s,e,is_utf8) \
-( ((e) > (s)) ? \
- ( ( ( 0x09 <= NATIVE_TO_LATIN1(((U8*)s)[0]) && NATIVE_TO_LATIN1(((U8*)s)[0]) <= 0x0D ) || 0x20 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? 1\
- : (! is_utf8 ) ? \
- ( 0x85 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) \
- : (((e) - (s)) >= UTF8SKIP(s)) ? \
- ( ( 0xC2 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x85 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? 2 : 0 ) \
- : ( ( ( 0xE2 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) && ( 0x80 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ) && ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) & 0xFE ) == 0x8E || ( NATIVE_TO_LATIN1(((U8*)s)[2]) & 0xFE ) == 0xA8 ) ) ? 3 : 0 )\
+#define what_TRICKYFOLD_safe(s,e,is_utf8) \
+( ((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 ) \
+: ((e)-(s) > 0) ? \
+ ( ( ( !( is_utf8 ) ) && ( 0xDF == ((U8*)s)[0] ) ) ? 0xDF : 0 ) \
: 0 )
/*** GENERATED CODE ***/
-#define is_PATWS_non_low_safe(s,e,is_utf8) \
-( ((e) > (s)) ? \
- ( (! is_utf8) ? \
- ( 0x85 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) \
- : (((e) - (s)) >= UTF8SKIP(s)) ? \
- ( ( 0xC2 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) ? \
- ( ( 0x85 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ? 2 : 0 ) \
- : ( ( ( 0xE2 == NATIVE_TO_LATIN1(((U8*)s)[0]) ) && ( 0x80 == NATIVE_TO_LATIN1(((U8*)s)[1]) ) ) && ( ( NATIVE_TO_LATIN1(((U8*)s)[2]) & 0xFE ) == 0x8E || ( NATIVE_TO_LATIN1(((U8*)s)[2]) & 0xFE ) == 0xA8 ) ) ? 3 : 0 )\
+#define what_len_TRICKYFOLD(s,is_utf8,len) \
+( ( 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 ) \
-: 0 )
+: ( 0xDF == ((U8*)s)[0] ) ? len=1, 0xDF : 0 )
/*** GENERATED CODE ***/
-#define is_PATWS_cp(cp) \
-( ( 0x09 <= NATIVE_TO_UNI(cp) && NATIVE_TO_UNI(cp) <= 0x0D ) || ( 0x0D < NATIVE_TO_UNI(cp) &&\
-( 0x20 == NATIVE_TO_UNI(cp) || ( 0x20 < NATIVE_TO_UNI(cp) && \
-( 0x85 == NATIVE_TO_UNI(cp) || ( 0x85 < NATIVE_TO_UNI(cp) && \
-( 0x200E == NATIVE_TO_UNI(cp) || ( 0x200E < NATIVE_TO_UNI(cp) && \
-( 0x200F == NATIVE_TO_UNI(cp) || ( 0x200F < NATIVE_TO_UNI(cp) && \
-( 0x2028 == NATIVE_TO_UNI(cp) || 0x2029 == NATIVE_TO_UNI(cp) ) ) ) ) ) ) ) ) ) ) )
-
-
-#endif /* H_REGCHARCLASS */
+#define what_len_TRICKYFOLD_safe(s,e,is_utf8,len) \
+( ((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 )
/* ex: set ro: */
diff --git a/gnu/usr.bin/perl/regen_perly.pl b/gnu/usr.bin/perl/regen_perly.pl
index b96275639c5..fb01dbd8242 100755
--- a/gnu/usr.bin/perl/regen_perly.pl
+++ b/gnu/usr.bin/perl/regen_perly.pl
@@ -2,7 +2,7 @@
#
# regen_perly.pl, DAPM 12-Feb-04
#
-# Copyright (c) 2004, 2005, 2006, 2009, 2010, 2011 Larry Wall
+# Copyright (c) 2004, 2005 Larry Wall
#
# Given an input file perly.y, run bison on it and produce
# the following output files:
@@ -29,14 +29,11 @@
# it may work elsewhere but no specific attempt has been made to make it
# portable.
-use 5.006;
sub usage { die "usage: $0 [ -b bison_executable ] [ file.y ]\n" }
use warnings;
use strict;
-BEGIN { require 'regen/regen_lib.pl'; }
-
my $bison = 'bison';
if (@ARGV >= 2 and $ARGV[0] eq '-b') {
@@ -64,52 +61,46 @@ die "$0: must be run on an ASCII system\n" unless ord 'A' == 65;
# this; 1.35+ does
# * Must produce output which is extractable by the regexes below
# * Must produce the right values.
-# These last two constraints may well be met by earlier versions, but
+# These last two contstraints may well be met by earlier versions, but
# I simply haven't tested them yet. If it works for you, then modify
# the test below to allow that version too. DAPM Feb 04.
my $version = `$bison -V`;
-unless ($version) { die <<EOF; }
-Could not find a version of bison in your path. Please install bison.
-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; }
+unless ($version =~ /\b(1\.875[a-z]?|2\.[013])\b/) { die <<EOF; }
You have the wrong version of bison in your path; currently 1.875
-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
+2.0, 2.1 or 2.3 is required. Try installing
+ http://ftp.gnu.org/gnu/bison/bison-2.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");
-open my $ctmp_fh, '<', $tmpc_file or die "Can't open $tmpc_file: $!\n";
+open CTMPFILE, $tmpc_file or die "Can't open $tmpc_file: $!\n";
my $clines;
-{ local $/; $clines = <$ctmp_fh>; }
+{ local $/; $clines = <CTMPFILE>; }
die "failed to read $tmpc_file: length mismatch\n"
unless length $clines == -s $tmpc_file;
-close $ctmp_fh;
+close CTMPFILE;
my ($actlines, $tablines) = extract($clines);
-our %tokens;
$tablines .= make_type_tab($y_file, $tablines);
-my ($act_fh, $tab_fh, $h_fh) = map {
- open_new($_, '>', { by => $0, from => $y_file });
-} $act_file, $tab_file, $h_file;
+chmod 0644, $act_file;
+open ACTFILE, ">$act_file" or die "can't open $act_file: $!\n";
+print ACTFILE $actlines;
+close ACTFILE;
+chmod 0444, $act_file;
-print $act_fh $actlines;
-
-print $tab_fh $tablines;
+chmod 0644, $tab_file;
+open TABFILE, ">$tab_file" or die "can't open $tab_file: $!\n";
+print TABFILE $tablines;
+close TABFILE;
+chmod 0444, $tab_file;
unlink $tmpc_file;
@@ -117,60 +108,25 @@ unlink $tmpc_file;
# C<#line 30 "perly.y"> confuses the Win32 resource compiler and the
# 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";
-
+open TMPH_FILE, $tmph_file or die "Can't open $tmph_file: $!\n";
+chmod 0644, $h_file;
+open H_FILE, ">$h_file" or die "Can't open $h_file: $!\n";
my $endcore_done = 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;
+while (<TMPH_FILE>) {
+ print H_FILE "#ifdef PERL_CORE\n" if $. == 1;
if (!$endcore_done and /YYSTYPE_IS_DECLARED/) {
- 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
+ print H_FILE "#endif /* PERL_CORE */\n";
$endcore_done = 1;
}
next if /^#line \d+ ".*"/;
- if (not defined $gather_tokens) {
- $gather_tokens = 1 if /^\s* enum \s* yytokentype \s* \{/x;
- }
- elsif ($gather_tokens) {
- if (/^\# \s* endif/x) { # The #endif just after the end of the token enum
- $gather_tokens = 0;
- $_ .= "\n/* Tokens. */\n$tokens";
- }
- else {
- my ($tok, $val) = /(\w+) \s* = \s* (\d+)/x;
- $tokens .= "#define $tok $val\n" if $tok;
- }
- }
- print $h_fh $_;
+ print H_FILE $_;
}
-close $tmph_fh;
+close TMPH_FILE;
+close H_FILE;
+chmod 0444, $h_file;
unlink $tmph_file;
-foreach ($act_fh, $tab_fh, $h_fh) {
- read_only_bottom_close_and_rename($_, ['regen_perly.pl', $y_file]);
-}
+print "rebuilt: $h_file $tab_file $act_file\n";
exit 0;
@@ -197,16 +153,13 @@ sub extract {
$clines =~ m@
switch \s* \( \s* \w+ \s* \) \s* { \s*
(
- case \s* \d+ \s* :
- \s*
- (?: \s* /\* .*? \*/ \s* )* # optional C-comments
- \s*
+ case \s* \d+ \s* : \s*
\#line [^\n]+"\Q$y_file\E"
.*?
)
}
\s*
- (?: \s* /\* .*? \*/ \s* )* # optional C-comments
+ ( \s* /\* .*? \*/ \s* )* # optional C-comments
\s*
(
\#line[^\n]+\.c"
@@ -219,9 +172,6 @@ sub extract {
or die "Can't extract actions from $tmpc_file\n";
$actlines = $1;
- # Remove extraneous comments from bison 2.4
- $actlines =~ s!\s* /\* \s* Line \s* \d+ \s* of \s* yacc\.c \s* \*/!!gx;
-
# C<#line 188 "perlytmp.c"> gets picked up by make depend, so remove them.
$actlines =~ s/^#line \d+ "\Q$tmpc_file\E".*$//gm;
@@ -266,7 +216,6 @@ sub extract {
sub make_type_tab {
my ($y_file, $tablines) = @_;
- my %just_tokens;
my %tokens;
my %types;
my $default_token;
@@ -286,22 +235,16 @@ sub make_type_tab {
}
next unless /^%(token|type)/;
- s/^%((token)|type)\s+<(\w+)>\s+//
+ s/^%(token|type)\s+<(\w+)>\s+//
or die "$y_file: unparseable token/type line: $_";
- for (split ' ', $_) {
- $tokens{$_} = $3;
- if ($2) {
- $just_tokens{$_} = $3;
- }
- }
- $types{$3} = 1;
+ $tokens{$_} = $2 for (split ' ', $_);
+ $types{$2} = 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
@@ -311,7 +254,7 @@ sub make_type_tab {
{ "toketype_" .
(defined $tokens{$1} ? $tokens{$1} : $default_token)
}ge;
- $fields =~ s/, \s* (?:0|YY_NULL) \s* $//x
+ $fields =~ s/, \s* 0 \s* $//x
or die "make_type_tab: couldn't delete trailing ',0'\n";
return
diff --git a/gnu/usr.bin/perl/symbian/config.pl b/gnu/usr.bin/perl/symbian/config.pl
index ab739fed631..079fa1540fa 100644
--- a/gnu/usr.bin/perl/symbian/config.pl
+++ b/gnu/usr.bin/perl/symbian/config.pl
@@ -1,995 +1,976 @@
-#!/usr/bin/perl -w
-
-# Copyright (c) 2004-2005 Nokia. All rights reserved.
-# This utility is licensed under the same terms as Perl itself.
-
-use strict;
-use lib "symbian";
-
-print "Configuring...\n";
-print "Configuring with: Perl version $] ($^X)\n";
-
-do "sanity.pl" or die $@;
-
-my %VERSION = %{ do "version.pl" or die $@ };
-
-printf "Configuring for: Perl version $VERSION{REVISION}.%03d%03d\n",
- $VERSION{VERSION}, $VERSION{SUBVERSION};
-
-my $VERSION = "$VERSION{REVISION}$VERSION{VERSION}$VERSION{SUBVERSION}";
-my $R_V_SV = "$VERSION{REVISION}.$VERSION{VERSION}.$VERSION{SUBVERSION}";
-
-my ($SYMBIAN_ROOT, $SYMBIAN_VERSION, $SDK_NAME, $SDK_VARIANT, $SDK_VERSION) =
- @{ do "sdk.pl" or die $@ };
-my %PORT = %{ do "port.pl" or die $@ };
-
-if ($SYMBIAN_ROOT eq 'C:\Symbian\Series60_1_2_CW') {
- ( $SYMBIAN_VERSION, $SDK_VERSION ) = qw(6.1 1.2);
-}
-
-my $WIN = $ENV{WIN} ; # 'wins', 'winscw' (from sdk.pl)
-my $ARM = 'thumb'; # 'thumb', 'armv5'
-my $S60SDK = $ENV{S60SDK}; # qw(1.2 2.0 2.1 2.6) (from sdk.pl)
- if ($SDK_VARIANT eq 'S60' && $S60SDK =~ /^5\./) {
- $ARM = 'armv5'; # 'thumb', 'armv5' # Configuration for S60 5th Edition SDK v1.0
- }
-my $S80SDK = $ENV{S80SDK}; # qw(2.0) (from sdk.pl)
-my $S90SDK = $ENV{S90SDK}; # qw(1.1) (from sdk.pl)
-my $UIQSDK = $ENV{UIQSDK}; # qw(2.0 2.1) (from sdk.pl)
-
-my $UREL = $ENV{UREL}; # from sdk.pl
-$UREL =~ s/-ARM-/$ARM/;
-my $UARM = $ENV{UARM}; # from sdk.pl
-
-die "$0: SDK not recognized\n"
- if !defined($SYMBIAN_VERSION) ||
- !defined($SDK_VERSION) ||
- (!defined($S60SDK) && !defined($S80SDK) && !defined($S90SDK) && !defined($UIQSDK));
-
-die "$0: does not know which Windows compiler to use\n"
- unless defined $WIN;
-
-print "Symbian $SYMBIAN_VERSION SDK $SDK_VARIANT $SDK_VERSION ($WIN) installed at $SYMBIAN_ROOT\n";
-
-my $CWD = do "cwd.pl" or die $@;
-print "Build directory $CWD\n";
-
-die "$0: '+' in cwd does not work with Series 60 SDK 1.2\n"
- if defined $S60SDK && $S60SDK eq '1.2' && $CWD =~ /\+/;
-
-my @unclean;
-my @mmp;
-
-sub create_mmp {
- my ( $target, $type, @x ) = @_;
- my $miniperl = $target eq 'miniperl';
- my $perl = $target eq 'perl';
- my $mmp = "$target.mmp";
- my $targetpath = $miniperl
- || $perl ? "TARGETPATH\t\\System\\Apps\\Perl" : "";
- if ( open( my $fh, ">$mmp" ) ) {
- print "\t$mmp\n";
- push @mmp, $mmp;
- push @unclean, $mmp;
- print $fh <<__EOF__;
-TARGET $target.$type
-TARGETTYPE $type
-__EOF__
- if ($SDK_VARIANT eq 'S60' && $S60SDK =~ /^5\./) {
- print $fh "UID\t0 0xEA3E9181\n" if $miniperl;
- print $fh "UID\t0 0xED04DD86\n" if $perl;
- print $fh "UID\t0x1000008d 0xE8667302\n" unless $miniperl || $perl;
- print $fh "CAPABILITY\tNONE\n";
- } else {
- print $targetpath;
- print $fh "EPOCHEAPSIZE\t1024 8388608";
- print $fh "EPOCSTACKSIZE\t65536";
- }
- print $fh <<__EOF__;
-EXPORTUNFROZEN
-SRCDBG
-__EOF__
- if ($SDK_VARIANT eq 'S60') {
- print $fh "MACRO\t__SERIES60__\n";
- print $fh "MACRO\t__SERIES60_1X__\n" if $S60SDK =~ /^1\./;
- print $fh "MACRO\t__SERIES60_2X__\n" if $S60SDK =~ /^2\./;
- print $fh "MACRO\t__SERIES60_3X__\n" if $S60SDK =~ /^5\./;
- }
- if ($SDK_VARIANT eq 'S80') {
- print $fh "MACRO\t__SERIES80__\n";
- print $fh "MACRO\t__SERIES80_1X__\n" if $S80SDK =~ /^1\./;
- print $fh "MACRO\t__SERIES80_2X__\n" if $S80SDK =~ /^2\./;
- }
- if ($SDK_VARIANT eq 'S90') {
- print $fh "MACRO\t__SERIES90__\n";
- }
- if ($SDK_VARIANT eq 'UIQ') {
- print $fh "MACRO\t__UIQ__\n";
- print $fh "MACRO\t__UIQ_1X__\n" if $UIQSDK =~ /^1\./;
- print $fh "MACRO\t__UIQ_2X__\n" if $UIQSDK =~ /^2\./;
- }
- my ( @c, %c );
- @c = map { glob } qw(*.c); # Find the .c files.
- @c = map { lc } @c; # Lowercase the names.
- @c = grep { !/malloc\.c/ } @c; # Use the system malloc.
- @c = grep { !/madly\.c/ } @c; # mad is undef.
- @c = grep { !/main\.c/ } @c; # main.c must be explicit.
- push @c, map { lc } @x;
- @c = map { s:^\.\./::; $_ } @c; # Remove the leading ../
- @c = map { $c{$_}++ } @c; # Uniquefy.
- @c = sort keys %c; # Beautify.
-
- for (@c) {
- print $fh "SOURCE\t\t$_\n";
- }
- print $fh <<__EOF__;
-SOURCEPATH $CWD
-USERINCLUDE $CWD
-USERINCLUDE $CWD\\ext\\DynaLoader
-USERINCLUDE $CWD\\symbian
-SYSTEMINCLUDE \\epoc32\\include\\libc
-SYSTEMINCLUDE \\epoc32\\include
-LIBRARY euser.lib
-LIBRARY estlib.lib
-LIBRARY eikcore.lib
-LIBRARY cone.lib
-LIBRARY efsrv.lib
-__EOF__
- if ( $miniperl || $perl || $type eq 'dll' ) {
- print $fh <<__EOF__;
-LIBRARY charconv.lib
-LIBRARY hal.lib
-LIBRARY estor.lib
-__EOF__
- }
- if ($SDK_VARIANT =~ /^S[689]0$/) {
- print $fh <<__EOF__;
-LIBRARY commonengine.lib
-__EOF__
- }
- if (defined $S60SDK) {
- print $fh <<__EOF__;
-LIBRARY avkon.lib
-LIBRARY commondialogs.lib
-__EOF__
- }
- if ((defined $S80SDK) or (defined $S90SDK)) {
- print $fh <<__EOF__;
-LIBRARY eikctl.lib
-LIBRARY eikcoctl.lib
-LIBRARY eikdlg.lib
-LIBRARY ckndlg.lib
-__EOF__
- }
- if (defined $UIQSDK) {
- print $fh <<__EOF__;
-LIBRARY eikctl.lib
-LIBRARY eikcoctl.lib
-LIBRARY eikdlg.lib
-LIBRARY qikctl.lib
-__EOF__
- }
- if ( $type eq 'exe' ) {
- print $fh <<__EOF__;
-STATICLIBRARY ecrt0.lib
-__EOF__
- }
- if ($miniperl) {
- print $fh <<__EOF__;
-MACRO PERL_MINIPERL
-__EOF__
- }
- if ($perl) {
- print $fh <<__EOF__;
-MACRO PERL_PERL
-__EOF__
- }
- print $fh <<__EOF__;
-MACRO PERL_CORE
-MACRO MULTIPLICITY
-MACRO PERL_IMPLICIT_CONTEXT
-__EOF__
- unless ( $miniperl || $perl ) {
- print $fh <<__EOF__;
-MACRO PERL_GLOBAL_STRUCT
-MACRO PERL_GLOBAL_STRUCT_PRIVATE
-__EOF__
- }
- unless ($miniperl || $perl ) {
- if ($SDK_VARIANT eq 'S60' && $S60SDK =~ /^5\./) {
- print $fh "START RESOURCE\tsymbian\\PerlUi.rss\nEND\n";
- } else {
- print $fh "RESOURCE\tsymbian\\PerlUi.rss";
- }
- }
- close $fh;
- }
- else {
- warn "$0: failed to open $mmp for writing: $!\n";
- }
-}
-
-sub create_bld_inf {
- if ( open( BLD_INF, ">bld.inf" ) ) {
- print "\tbld.inf\n";
- push @unclean, "bld.inf";
- print BLD_INF <<__EOF__;
-PRJ_PLATFORMS
-${WIN} ${ARM}
-PRJ_MMPFILES
-__EOF__
- for (@mmp) { print BLD_INF $_, "\n" }
- close BLD_INF;
- }
- else {
- warn "$0: failed to open bld.inf for writing: $!\n";
- }
-}
-
-my %config;
-
-sub load_config_sh {
- if ( open( CONFIG_SH, "symbian/config.sh" ) ) {
- while (<CONFIG_SH>) {
- if (/^(\w+)=['"]?(.*?)["']?$/) {
- my ( $var, $val ) = ( $1, $2 );
- $val =~ s/x.y.z/$R_V_SV/gi;
- $val =~ s/thumb/$ARM/gi;
- $val = "C:$val" if (defined($S90SDK) and ($val =~ /^(\/|\\\\)system[\/\\]/i));
- $val = "'$SYMBIAN_VERSION'" if $var eq 'osvers';
- $val = "'$SDK_VERSION'" if $var eq 'sdkvers';
- $config{$var} = $val;
- }
- }
- close CONFIG_SH;
- }
- else {
- warn "$0: failed to open symbian\\config.sh for reading: $!\n";
- }
-}
-
-sub create_config_h {
- load_config_sh();
- if ( open( CONFIG_H, ">config.h" ) ) {
- print "\tconfig.h\n";
- push @unclean, "config.h";
- if ( open( CONFIG_H_SH, "config_h.SH" ) ) {
- while (<CONFIG_H_SH>) {
- last if /\#ifndef _config_h_/;
- }
- print CONFIG_H <<__EOF__;
-/*
- * Package name : perl
- * Source directory : .
- * Configuration time:
- * Configured by :
- * Target system : symbian
- */
-
-#ifndef _config_h_
-__EOF__
- while (<CONFIG_H_SH>) {
- last if /!GROK!THIS/;
- s/\$(\w+)/exists $config{$1} ? $config{$1} : (warn "$0: config.sh missing '$1'\n", "")/eg;
- s/^#undef\s+(\S+).+/#undef $1/g;
- s:\Q/**/::;
- print CONFIG_H;
- }
- close CONFIG_H_SH;
- }
- else {
- warn "$0: failed to open ../config_h.SH for reading: $!\n";
- }
- close CONFIG_H;
- }
- else {
- warn "$0: failed to open config.h for writing: $!\n";
- }
-}
-
-sub create_DynaLoader_cpp {
- print "\text\\DynaLoader\\DynaLoader.cpp\n";
- system(
-q[xsubpp ext\DynaLoader\dl_symbian.xs >ext\DynaLoader\DynaLoader.cpp]
- ) == 0
- or die "$0: creating DynaLoader.cpp failed: $!\n";
- push @unclean, 'ext\DynaLoader\DynaLoader.cpp';
-
-}
-
-sub create_symbian_port_h {
- print "\tsymbian\\symbian_port.h\n";
- if ( open( SYMBIAN_PORT_H, ">symbian/symbian_port.h" ) ) {
- my ($sdkmajor, $sdkminor);
- if ($SDK_VARIANT eq 'S60') {
- $S60SDK =~ /^(\d+)\.(\d+)$/;
- ($sdkmajor, $sdkminor) = ($1, $2);
- }
- if ($SDK_VARIANT eq 'S80') {
- $S80SDK =~ /^(\d+)\.(\d+)$/;
- ($sdkmajor, $sdkminor) = ($1, $2);
- }
- if ($SDK_VARIANT eq 'S90') {
- $S90SDK =~ /^(\d+)\.(\d+)$/;
- ($sdkmajor, $sdkminor) = ($1, $2);
- }
- if ($SDK_VARIANT eq 'UIQ') {
- $UIQSDK =~ /^(\d+)\.(\d+)$/;
- ($sdkmajor, $sdkminor) = ($1, $2);
- }
- print SYMBIAN_PORT_H <<__EOF__;
-/* Copyright (c) 2004-2005, Nokia. All rights reserved. */
-
-#ifndef __symbian_port_h__
-#define __symbian_port_h__
-
-#define PERL_SYMBIANPORT_MAJOR $PORT{dll}->{MAJOR}
-#define PERL_SYMBIANPORT_MINOR $PORT{dll}->{MINOR}
-#define PERL_SYMBIANPORT_PATCH $PORT{dll}->{PATCH}
-
-#define PERL_SYMBIANSDK_FLAVOR L"$SDK_VARIANT"
-#define PERL_SYMBIANSDK_MAJOR $sdkmajor
-#define PERL_SYMBIANSDK_MINOR $sdkminor
-
-#endif /* #ifndef __symbian_port_h__ */
-__EOF__
- close(SYMBIAN_PORT_H);
- push @unclean, 'symbian\symbian_port.h';
- }
- else {
- warn "$0: failed to open symbian/symbian_port.h for writing: $!\n";
- }
-}
-
-sub create_perlmain_c {
- print "\tperlmain.c\n";
- system(
-q[perl -ne "print qq[ char *file = __FILE__;\n] if /dXSUB_SYS/;print unless /PERL_UNUSED_CONTEXT/;print qq[ newXS(\"DynaLoader::boot_DynaLoader\", boot_DynaLoader, file);\n] if /dXSUB_SYS/;print qq[EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);\n] if /Do not delete this line/" miniperlmain.c > perlmain.c]
- ) == 0
- or die "$0: Creating perlmain.c failed: $!\n";
- push @unclean, 'perlmain.c';
-}
-
-sub create_PerlApp_pkg {
- print "\tsymbian\\PerlApp.pkg\n";
- if ( open( PERLAPP_PKG, ">symbian\\PerlApp.pkg" ) ) {
- my $ProductId =
- defined $S60SDK ?
-qq[;Supports Series 60 v0.9\n(0x101F6F88), 0, 0, 0, {"Series60ProductID"}\n] :
- defined $S80SDK ?
-qq[;Supports Series 80 v2.0\n(0x101F8ED2), 0, 0, 0, {"Series80ProductID"}\n] :
- defined $S90SDK ?
-qq[;Supports Series 90 v1.1\n(0x101FBE05), 0, 0, 0, {"Series90ProductID"}\n] :
- defined $UIQSDK && $SDK_VERSION =~ /^(\d)\.(\d)$/ ?
-qq[;Supports UIQ v2.1\n(0x101F617B), $1, $2, 0, {"UIQ21ProductID"}\n] :
- ";Supports Series NN";
- my $APPS = $UREL;
- if (($SDK_VARIANT eq 'S60' && $SDK_VERSION ne '1.2' || $WIN eq 'winscw') || defined $S80SDK || defined $S90SDK) { # Do only if not in S60 1.2 VC.
- $APPS =~ s!\\epoc32\\release\\(.+)\\$UARM$!\\epoc32\\data\\z\\system\\apps\\PerlApp!i;
- }
- # TODO: in S60 3.0 there will be no more recognizers.
- my $mdl = qq["$UREL\\PerlRecog.mdl"-"!:\\system\\recogs\\PerlRecog.mdl";];
- my $AIF = $SDK_VARIANT =~ /^S[689]0/ ? qq["$APPS\\PerlApp.aif"-"!:\\system\\apps\\PerlApp\\PerlApp.aif"] : "";
- print PERLAPP_PKG <<__EOF__;
-; !!!!!! DO NOT EDIT THIS FILE !!!!!!
-; This file is built by symbian\\config.pl.
-; Any changes made here will be lost!
-;
-; PerlApp.pkg
-;
-; Note that the demo_pl needs to be run to create the demo .pl scripts.
-;
-; Languages
-&EN;
-
-; Standard SIS file header
-#{"PerlApp"},(0x102015F6),0,2,0
-
-$ProductId
-
-; Files
-"$UREL\\PerlApp.APP"-"!:\\system\\apps\\PerlApp\\PerlApp.app"
-$mdl
-"$APPS\\PerlApp.rsc"-"!:\\system\\apps\\PerlApp\\PerlApp.rsc"
-$AIF
-__EOF__
- if ( open( DEMOS, "perl symbian\\demo_pl list |" ) ) {
- while (<DEMOS>) {
- chomp;
- if (defined $S90SDK) {
- print PERLAPP_PKG qq["$_"-"!:\\Mydocs\\Perl\\$_"\n];
- } else {
- print PERLAPP_PKG qq["$_"-"!:\\Perl\\$_"\n];
- }
- }
- close(DEMOS);
- }
- close(PERLAPP_PKG);
- }
- else {
- die "$0: symbian\\PerlApp.pkg: $!\n";
- }
- push @unclean, 'symbian\PerlApp.pkg';
-}
-
-print "Creating...\n";
-create_mmp(
- 'miniperl', 'exe',
- 'miniperlmain.c', 'symbian\symbian_stubs.c',
- 'symbian\PerlBase.cpp',
- 'symbian\PerlUi.cpp',
- 'symbian\PerlUtil.cpp',
- 'symbian\symbian_utils.cpp',
-);
-create_mmp(
- "perl", 'exe',
- 'perlmain.c', 'symbian\symbian_stubs.c',
- 'symbian\symbian_utils.cpp',
- 'symbian\PerlBase.cpp',
- 'symbian\PerlUi.cpp',
- 'symbian\PerlUtil.cpp',
- 'ext\DynaLoader\DynaLoader.cpp',
-);
-
-create_mmp(
- "perl$VERSION", 'dll',
- 'symbian\symbian_dll.cpp', 'symbian\symbian_stubs.c',
- 'symbian\symbian_utils.cpp',
- 'symbian\PerlBase.cpp',
- 'symbian\PerlUi.cpp',
- 'symbian\PerlUtil.cpp',
- 'ext\DynaLoader\DynaLoader.cpp',
-);
-
-create_bld_inf();
-create_config_h();
-create_perlmain_c();
-create_symbian_port_h();
-create_DynaLoader_cpp();
-create_PerlApp_pkg();
-
-if ( open( PERLAPP_MMP, ">symbian/PerlApp.mmp" ) ) {
- my @MACRO;
- my @LIB;
- push @MACRO, 'PERL_IMPLICIT_CONTEXT';
- push @MACRO, 'MULTIPLICITY';
- if (defined $S60SDK) {
- push @MACRO, '__SERIES60__';
- push @MACRO, '__SERIES60_1X__' if $S60SDK =~ /^1\./;
- push @MACRO, '__SERIES60_2X__' if $S60SDK =~ /^2\./;
- push @LIB, <<__EOF__;
-LIBRARY avkon.lib
-LIBRARY commondialogs.lib
-__EOF__
- }
- if (defined $S80SDK) {
- push @MACRO, '__SERIES80__';
- push @MACRO, '__SERIES80_1X__' if $S80SDK =~ /^1\./;
- push @MACRO, '__SERIES80_2X__' if $S80SDK =~ /^2\./;
- push @LIB, <<__EOF__;
-LIBRARY eikctl.lib
-LIBRARY eikcoctl.lib
-LIBRARY eikdlg.lib
-LIBRARY ckndlg.lib
-__EOF__
- }
- if (defined $S90SDK) {
- push @MACRO, '__SERIES90__';
- push @LIB, <<__EOF__;
-LIBRARY eikctl.lib
-LIBRARY eikcoctl.lib
-LIBRARY eikdlg.lib
-LIBRARY ckndlg.lib
-__EOF__
- }
- if (defined $UIQSDK) {
- push @MACRO, '__UIQ__';
- push @MACRO, '__UIQ_1X__' if $UIQSDK =~ /^1\./;
- push @MACRO, '__UIQ_2X__' if $UIQSDK =~ /^2\./;
- push @LIB, <<__EOF__;
-LIBRARY eikctl.lib
-LIBRARY eikcoctl.lib
-LIBRARY eikdlg.lib
-LIBRARY qikctl.lib
-__EOF__
- }
- print PERLAPP_MMP <<__EOF__;
-// !!!!!! DO NOT EDIT THIS FILE !!!!!!
-// This file is built by symbian\\config.pl.
-// Any changes made here will be lost!
-TARGET PerlApp.app
-TARGETTYPE app
-UID 0x100039CE 0x102015F6
-TARGETPATH \\system\\apps\\PerlApp
-SRCDBG
-EXPORTUNFROZEN
-SOURCEPATH .
-SOURCE PerlApp.cpp
-
-USERINCLUDE .
-USERINCLUDE ..
-USERINCLUDE \\symbian\\perl\\$R_V_SV\\include
-
-SYSTEMINCLUDE \\epoc32\\include
-SYSTEMINCLUDE \\epoc32\\include\\libc
-
-LIBRARY apparc.lib
-LIBRARY bafl.lib
-LIBRARY charconv.lib
-LIBRARY cone.lib
-LIBRARY efsrv.lib
-LIBRARY eikcore.lib
-LIBRARY estlib.lib
-LIBRARY euser.lib
-LIBRARY perl$VERSION.lib
-@LIB
-RESOURCE perlapp.rss
-__EOF__
- if (@MACRO) {
- for my $macro (@MACRO) {
- print PERLAPP_MMP <<__EOF__;
-MACRO $macro
-__EOF__
- }
- }
- if ($SDK_VARIANT =~ /^S[689]0$/) {
- print PERLAPP_MMP <<__EOF__;
-AIF PerlApp.aif . PerlAppAif.rss
-__EOF__
- }
- close(PERLAPP_MMP);
- push @unclean, 'symbian\PerlApp.mmp';
-}
-else {
- warn "$0: failed to create symbian\\PerlApp.mmp";
-}
-
-if ( open( MAKEFILE, ">Makefile" ) ) {
- my $perl = "perl$VERSION";
- my $windef1 = "$SYMBIAN_ROOT\\Epoc32\\Build$CWD\\$perl\\$WIN\\$perl.def";
- my $windef2 = "..\\BWINS\\${perl}u.def";
- my $armdef1 = "$SYMBIAN_ROOT\\Epoc32\\Build$CWD\\$perl\\$ARM\\$perl.def";
- my $armdef2 = "..\\BMARM\\${perl}u.def";
- my $MF = $WIN eq 'wins' ? 'vc6' : $WIN eq 'winscw' ? 'cw_ide' : "UNKNOWN";
- print "\tMakefile\n";
- print MAKEFILE <<__EOF__;
-help:
- \@echo === Perl for Symbian ===
- \@echo Useful targets:
- \@echo all win arm clean
- \@echo perldll.sis perlext.sis perlsdk.zip
-
-WIN = ${WIN}
-ARM = ${ARM}
-
-all: build
-
-build: rename_makedef build_${WIN} build_arm
-
-@unclean: symbian\\config.pl
- perl symbian\\config.pl
-
-build_${WIN}: abld.bat perldll_${WIN}
-
-build_vc6: abld.bat perldll_wins
-
-build_vc7: abld.bat perldll_wins
-
-build_cw: abld.bat perldll_winscw
-
-build_arm: abld.bat perl_arm miniperl_arm perldll_arm
-
-miniperl_win miniperl_${WIN}: miniperl.mmp abld.bat rename_makedef
- abld build ${WIN} udeb miniperl
-
-miniperl_arm: miniperl.mmp abld.bat rename_makedef
- abld build \$(ARM) $UARM miniperl
-
-miniperl: miniperl_${WIN} miniperl_arm
-
-perl: perl_${WIN} perl_arm
-
-perl_win perl_${WIN}: perl.mmp abld.bat rename_makedef
- abld build ${WIN} perl
-
-perl_arm: perl.mmp abld.bat rename_makedef
- abld build \$(ARM) $UARM perl
-
-perldll_win perldll_${WIN}: perl${VERSION}_${WIN} freeze_${WIN} perl${VERSION}_${WIN}
-
-perl${VERSION}_win perl${VERSION}_${WIN}: perl$VERSION.mmp abld.bat rename_makedef
- abld build ${WIN} perl$VERSION
-
-perldll_arm: perl${VERSION}_arm freeze_arm perl${VERSION}_arm
-
-perl${VERSION}_arm: perl$VERSION.mmp abld.bat rename_makedef
- abld build \$(ARM) $UARM perl$VERSION
-
-perldll perl$VERSION: perldll_${WIN} perldll_arm
-
-win ${WIN}: miniperl_${WIN} perl_${WIN} perldll_${WIN}
-
-thumb arm: miniperl_arm perl_arm perldll_arm
-
-rename_makedef:
- -ren makedef.pl nomakedef.pl
-
-# Symbian SDK has a makedef.pl of its own,
-# and we don't need Perl's.
-rerename_makedef:
- -ren nomakedef.pl makedef.pl
-
-symbian\\PerlUi.rss: symbian\\PerlUi$SDK_VARIANT.rss
- copy symbian\\PerlUi$SDK_VARIANT.rss symbian\\PerlUi.rss
-
-abld.bat abld: bld.inf symbian\\PerlUi.rss
- bldmake bldfiles
-
-vc6: win.mf vc6.mf build_vc6
-
-vc7: win.mf vc7.mf build_vc7
-
-cw: win.mf cw.mf build_cw
-
-${WIN}_miniperl.mf: abld.bat symbian\\config.pl
- abld makefile ${MF} miniperl
- echo > ${WIN}_miniperl.mf
-
-${WIN}_perl.mf: abld.bat symbian\\config.pl
- abld makefile ${MF} perl
- echo > ${WIN}_perl.mf
-
-${WIN}_${VERSION}.mf: abld.bat symbian\\config.pl
- abld makefile ${MF} perl${VERSION}
- echo > ${WIN}_${VERSION}.mf
-
-symbian\\${WIN}.mf:
- cd symbian; make ${WIN}.mf
-
-${WIN}.mf: ${WIN}_miniperl.mf ${WIN}_perl.mf ${WIN}_${VERSION}.mf symbian\\${WIN}.mf
-
-arm_miniperl.mf: abld.bat symbian\\config.pl
- echo > arm_miniperl.mf
-
-arm_perl.mf: abld.bat symbian\\config.pl
- echo > arm_perl.mf
-
-arm_${VERSION}.mf: abld.bat symbian\\config.pl
- echo > arm_${VERSION}.mf
-
-arm.mf: arm_miniperl.mf arm_perl.mf arm_${VERSION}.mf
-
-win.mf: vc6.mf cw.mf
- echo > win.mf
-
-vc6.mf: abld.bat symbian\\config.pl
- abld makefile vc6
- echo > vc6.mf
-
-vc7.mf: abld.bat symbian\\config.pl
- abld makefile vc7
- echo > vc7.mf
-
-cw.mf: abld.bat symbian\\config.pl
- abld makefile cw_ide
- echo > cw.mf
-
-PM = lib\\Config.pm lib\\Cross.pm lib\\lib.pm ext\\DynaLoader\\DynaLoader.pm ext\\DynaLoader\\XSLoader.pm ext\\Errno\\Errno.pm
-POD = lib\\Config.pod
-
-pm: \$(PM)
-
-XLIB = -Ixlib\\symbian
-
-XSBOPT = --win=\$(WIN) --arm=\$(ARM)
-
-lib\\Config.pm:
- copy symbian\\config.sh config.sh
-__EOF__
- if (defined $S90SDK) {
- print MAKEFILE <<__EOF__;
- perl -pi.bak -e "s:x\\.y\\.z+:$R_V_SV:g; s!='(\\\\\\\\system)!='C:\\1!" config.sh
-__EOF__
- } else {
- print MAKEFILE <<__EOF__;
- perl -pi.bak -e "s:x\\.y\\.z+:$R_V_SV:g" config.sh
-__EOF__
- };
- print MAKEFILE <<__EOF__;
- perl \$(XLIB) configpm --cross=symbian
- copy xlib\\symbian\\Config.pm lib\\Config.pm
- perl -pi.bak -e "s:x\\.y\\.z:$R_V_SV:g" lib\\Config.pm
- perl -pi.bak -e "s:5\\.\\d+\\.\\d+:$R_V_SV:g" lib\\Config.pm
- -perl -pi.bak -e "s:x\\.y\\.z:$R_V_SV:g" xlib\\symbian\\Config_heavy.pl
-
-lib\\lib.pm:
- perl lib\\lib_pm.PL
-
-ext\\DynaLoader\\DynaLoader.pm:
- -del /f ext\\DynaLoader\\DynaLoader.pm
- perl -Ixlib\\symbian ext\\DynaLoader\\DynaLoader_pm.PL
- perl -pi.bak -e "s/__END__//" DynaLoader.pm
- copy /y DynaLoader.pm ext\\DynaLoader\\DynaLoader.pm
- -del /f DynaLoader.pm DynaLoader.pm.bak
-
-ext\\DynaLoader\\XSLoader.pm:
- perl \$(XLIB) symbian\\xsbuild.pl \$(XSBOPT) XSLoader
-
-ext\\Errno\\Errno.pm:
- perl \$(XLIB) symbian\\xsbuild.pl \$(XSBOPT) Errno
-
-miniperlexe.sis: miniperl_arm symbian\\makesis.pl
- perl \$(XLIB) symbian\\makesis.pl miniperl
-
-perlexe.sis: perl_arm symbian\\makesis.pl
- perl \$(XLIB) symbian\\makesis.pl perl
-
-
-allsis: all miniperlexe.sis perlexe.sis perldll.sis perllib.sis perlext.sis perlapp.sis
-
-perldll.sis perl$VERSION.sis: perldll_arm pm symbian\\makesis.pl
- perl \$(XLIB) symbian\\makesis.pl perl${VERSION}dll
-
-perl${VERSION}lib.sis perllib.sis: \$(PM)
- perl \$(XLIB) symbian\\makesis.pl perl${VERSION}lib
-
-perl${VERSION}ext.sis perlext.sis: perldll_arm buildext_sis
- perl symbian\\makesis.pl perl${VERSION}ext
-
-EXT = Compress::Raw::Zlib Cwd Data::Dumper Devel::Peek Digest::MD5 Errno Fcntl File::Glob Filter::Util::Call IO List::Util MIME::Base64 PerlIO::scalar PerlIO::via SDBM_File Socket Storable Time::HiRes XSLoader attributes
-
-buildext: perldll symbian\\xsbuild.pl lib\\Config.pm
- perl \$(XLIB) symbian\\xsbuild.pl \$(XSBOPT) \$(EXT)
-
-buildextcpp: perldll symbian\\xsbuild.pl lib\\Config.pm
- perl \$(XLIB) symbian\\xsbuild.pl --csuffix .cpp \$(XSBOPT) \$(EXT)
-
-buildext_sis: perldll.sis symbian\\xsbuild.pl lib\\Config.pm
- perl \$(XLIB) symbian\\xsbuild.pl \$(XSBOPT) --sis \$(EXT)
-
-buildextcpp_sis: perldll.sis symbian\\xsbuild.pl lib\\Config.pm
- perl \$(XLIB) symbian\\xsbuild.pl --csuffix .cpp \$(XSBOPT) --sis \$(EXT)
-
-cleanext: symbian\\xsbuild.pl
- perl \$(XLIB) symbian\\xsbuild.pl \$(XSBOPT) --clean \$(EXT)
-
-distcleanext: symbian\\xsbuild.pl
- perl \$(XLIB) symbian\\xsbuild.pl \$(XSBOPT) --distclean \$(EXT)
-
-sis makesis: miniperl perl perldll pm buildext perlapp.sis
- perl \$(XLIB) symbian\\makesis.pl
-
-APIDIR = \\Symbian\\perl\\$R_V_SV
-
-sdkinstall:
- -mkdir \\Symbian\\perl
- -mkdir \\Symbian\\perl\\$R_V_SV
- -mkdir \$(APIDIR)\\include
- -mkdir \$(APIDIR)\\include\\symbian
- -mkdir \$(APIDIR)\\lib
- -mkdir \$(APIDIR)\\lib\\ExtUtils
- -mkdir \$(APIDIR)\\pod
- -mkdir \$(APIDIR)\\bin
- -mkdir \$(BINDIR)
- copy /y *.h \$(APIDIR)\\include
- -copy /y *.inc \$(APIDIR)\\include
- copy /y lib\\ExtUtils\\xsubpp \$(APIDIR)\\lib\\ExtUtils
- copy /y lib\\ExtUtils\\typemap \$(APIDIR)\\lib\\ExtUtils
- copy /y lib\\ExtUtils\\ParseXS.pm \$(APIDIR)\\lib\\ExtUtils
- copy /y symbian\\xsbuild.pl \$(APIDIR)\\bin
- copy /y symbian\\sisify.pl \$(APIDIR)\\bin
- copy /y symbian\\PerlBase.h \$(APIDIR)\\include
- copy /y symbian\\PerlUi.h \$(APIDIR)\\include
- copy /y symbian\\PerlUtil.h \$(APIDIR)\\include
- copy /y symbian\\symbian*.h \$(APIDIR)\\include\\symbian
- copy /y symbian\\PerlBase.pod \$(APIDIR)\\pod
- copy /y symbian\\PerlUtil.pod \$(APIDIR)\\pod
-
-RELDIR = $SYMBIAN_ROOT\\epoc32\\release
-RELWIN = \$(RELDIR)\\\$(WIN)\\udeb
-RELARM = \$(RELDIR)\\\$(ARM)\\$UARM
-SDKZIP = perl${VERSION}sdk.zip
-
-
-\$(SDKZIP) perlsdk.zip: perldll sdkinstall
- -del /f perl${VERSION}sdk.zip
- zip -r perl${VERSION}sdk.zip \$(RELWIN)\\perl$VERSION.* \$(RELARM)\\perl$VERSION.* \$(APIDIR)
- \@echo perl${VERSION}sdk.zip created.
-
-PERLSIS = perl${VERSION}.SIS perl${VERSION}lib.SIS perl${VERSION}ext.SIS
-ALLSIS = \$(PERLSIS) perlapp.sis
-ETC = README.symbian symbian\\PerlBase.pod symbian\\PerlUtil.pod symbian\\sisify.pl symbian\\TODO
-
-perl${VERSION}dist.zip perldist.zip: \$(ALLSIS) \$(SDKZIP) \$(ETC)
- -del /f perl${VERSION}dist.zip
- zip -r perl${VERSION}dist.zip \$(ALLSIS) \$(SDKZIP) \$(ETC)
-
-perlapp: sdkinstall perlapp_${WIN} perlapp_arm
-
-perlapp_arm_minimal sisify_hex perlappmin.hex perlrscmin.hex: sdkinstall config.h
- cd symbian; make perlapp_arm USERDEFS=-DCreatePerlAppMinimal
- perl symbian\\hexdump.pl
-
-perlapp_win perlapp_${WIN}: config.h
- cd symbian; make perlapp_${WIN}
-
-perlapp_arm: config.h
- cd symbian; make perlapp_arm
-
-perlapp_arm_clean:
- cd symbian; make clean
-
-perlapp_demo_extract:
- cd symbian; make perlapp_demo_extract
-
-perlapp.sis: perlapp_arm
- cd symbian; make perlapp.sis
-
-perlapp.zip:
- cd symbian; zip perlapp.zip PerlApp.* PerlRecog.* PerlBase.* PerlUtil.* demo_pl
-
-zip: perlsdk.zip perlapp.zip
-
-freeze: freeze_${WIN} freeze_arm
-
-freeze_${WIN}:
- abld freeze ${WIN} perl$VERSION
-
-freeze_arm:
- abld freeze \$(ARM) perl$VERSION
-
-defrost: defrost_${WIN} defrost_arm
-
-defrost_${WIN}:
- -del /f $windef1
- -del /f $windef2
-
-defrost_arm:
- -del /f $armdef1
- -del /f $armdef2
-
-clean_${WIN}: abld.bat
- abld clean ${WIN}
-
-clean_arm: abld.bat
- abld clean \$(ARM)
-
-clean: clean_${WIN} clean_arm rerename_makedef
- -del /f \$(PM)
- -del /f \$(POD)
- -del /f lib\\Config.pm.bak
- -del /f xlib\\symbian\\Config_heavy.pl
- -rmdir /s /q xlib
- -del /f config.sh
- -del /f DynaLoader.pm ext\\DynaLoader\\DynaLoader.pm
- -del /f ext\\DynaLoader\\Makefile
- -del /f ext\\SDBM_File\\sdbm\\Makefile
- -del /f symbian\\*.lst
- -del /f abld.bat @unclean *.pkg *.sis *.zip
- -del /f symbian\\abld.bat symbian\\*.sis symbian\\*.zip
- -del /f symbian\\perl5*.pkg symbian\\miniperl.pkg
- -del arm_*.mf ${WIN}_*.mf vc*.mf cw*.mf
- -del symbian\\Makefile
- -del symbian\\PerlUi.rss symbian\\PerlApp.rss
- -del perlappmin.hex perlrscmin.hex
- -perl symbian\\xsbuild.pl \$(XSBOPT) --clean \$(EXT)
- -rmdir /s /q perl${VERSION}_Data
- -cd symbian; make clean
-
-reallyclean: abld.bat
- abld reallyclean
-
-distclean: defrost reallyclean clean
- -perl symbian\\xsbuild.pl \$(XSBOPT) --distclean \$(EXT)
- -del /f config.h config.sh.bak symbian\\symbian_port.h
- -del /f Makefile symbian\\PerlApp.mmp
- -del /f BMARM\\*.def
- -del /f *.cwlink *.resources *.pref
- -del /f perl${VERSION}.xml perl${VERSION}.mcp uid.cpp
- -rmdir /s /q BMARM
- cd symbian; make distclean
- -del /f symbian\\Makefile
-__EOF__
- close MAKEFILE;
-}
-else {
- warn "$0: failed to create Makefile: $!\n";
-}
-
-if ( open( MAKEFILE, ">symbian/Makefile")) {
- my $wrap = defined $S60SDK && $S60SDK eq '1.2' && $WIN ne '${WIN}cw';
- my $ABLD = $wrap ? 'perl b.pl': 'abld';
- print "\tsymbian/Makefile\n";
- my $MF = $WIN eq 'wins' ? 'vc6' : $WIN eq 'winscw' ? 'cw_ide' : "UNKNOWN";
- print MAKEFILE <<__EOF__;
-WIN = $WIN
-ARM = $ARM
-ABLD = $ABLD
-MF = $MF
-
-abld.bat:
- bldmake bldfiles
-
-perlapp_${WIN}: abld.bat ..\\config.h PerlApp.h PerlApp.cpp
- copy PerlUi$SDK_VARIANT.rss PerlApp.rss
- bldmake bldfiles
- \$(ABLD) build ${WIN} udeb
-
-perlapp_arm: ..\\config.h PerlApp.h PerlApp.cpp
- copy PerlUi$SDK_VARIANT.rss PerlApp.rss
- bldmake bldfiles
- \$(ABLD) build ${ARM} $UARM
-
-$MF:
- abld makefile $MF
-
-win.mf:
- bldmake bldfiles
- abld makefile $MF
-
-perlapp_demo_extract:
- perl demo_pl extract
-
-perlapp.sis: perlapp_arm perlapp_demo_extract
- -del /f perlapp.SIS
- makesis perlapp.pkg
- copy /y perlapp.SIS ..\\perlapp.SIS
-
-clean:
- -perl demo_pl cleanup
- -del /f perlapp.sis
- -del /f b.pl
- -del PerlApp.rss
- abld clean $WIN
- abld clean thumb
- -del Makefile
-
-distclean: clean
- -del /f *.cwlink *.resources *.pref
- -del /f PerlApp.xml PerlApp.mcp uid.cpp
- -rmdir /s /q PerlApp_Data
- -del /f abld.bat
-__EOF__
- close(MAKEFILE);
- if ($wrap) {
- if ( open( B_PL, ">symbian/b.pl")) {
- print B_PL <<'__EOF__';
-# abld.pl wrapper.
-
-# nmake doesn't like MFLAGS and MAKEFLAGS being set to -w and w.
-delete $ENV{MFLAGS};
-delete $ENV{MAKEFLAGS};
-
-system("abld @ARGV");
-__EOF__
- close(B_PL);
- } else {
- warn "$0: failed to create symbian/b.pl: $!\n";
- }
- }
-} else {
- warn "$0: failed to create symbian/Makefile: $!\n";
-}
-
-print "Deleting...\n";
-for my $config (
- # Do not delete config.h here.
- "config.sh",
- "lib\\Config.pm",
- "xlib\\symbian\\Config.pm",
- "xlib\\symbian\\Config_heavy.pl",
- "symbian\\PerlUi.rss",
- "symbian\\PerlApp.rss",
- ) {
- print "\t$config\n";
- unlink($config);
-}
-
-print <<__EOM__;
-Configuring done.
-Now you can run:
- make all
- make allsis
-__EOM__
-
-1; # Happy End.
+#!/usr/bin/perl -w
+
+# Copyright (c) 2004-2005 Nokia. All rights reserved.
+# This utility is licensed under the same terms as Perl itself.
+
+use strict;
+use lib "symbian";
+
+print "Configuring...\n";
+print "Configuring with: Perl version $] ($^X)\n";
+
+do "sanity.pl" or die $@;
+
+my %VERSION = %{ do "version.pl" or die $@ };
+
+printf "Configuring for: Perl version $VERSION{REVISION}.%03d%03d\n",
+ $VERSION{VERSION}, $VERSION{SUBVERSION};
+
+my $VERSION = "$VERSION{REVISION}$VERSION{VERSION}$VERSION{SUBVERSION}";
+my $R_V_SV = "$VERSION{REVISION}.$VERSION{VERSION}.$VERSION{SUBVERSION}";
+
+my ($SYMBIAN_ROOT, $SYMBIAN_VERSION, $SDK_NAME, $SDK_VARIANT, $SDK_VERSION) =
+ @{ do "sdk.pl" or die $@ };
+my %PORT = %{ do "port.pl" or die $@ };
+
+if ($SYMBIAN_ROOT eq 'C:\Symbian\Series60_1_2_CW') {
+ ( $SYMBIAN_VERSION, $SDK_VERSION ) = qw(6.1 1.2);
+}
+
+my $WIN = $ENV{WIN} ; # 'wins', 'winscw' (from sdk.pl)
+my $ARM = 'thumb'; # 'thumb', 'armv5'
+my $S60SDK = $ENV{S60SDK}; # qw(1.2 2.0 2.1 2.6) (from sdk.pl)
+my $S80SDK = $ENV{S80SDK}; # qw(2.0) (from sdk.pl)
+my $S90SDK = $ENV{S90SDK}; # qw(1.1) (from sdk.pl)
+my $UIQSDK = $ENV{UIQSDK}; # qw(2.0 2.1) (from sdk.pl)
+
+my $UREL = $ENV{UREL}; # from sdk.pl
+$UREL =~ s/-ARM-/$ARM/;
+my $UARM = $ENV{UARM}; # from sdk.pl
+
+die "$0: SDK not recognized\n"
+ if !defined($SYMBIAN_VERSION) ||
+ !defined($SDK_VERSION) ||
+ (!defined($S60SDK) && !defined($S80SDK) && !defined($S90SDK) && !defined($UIQSDK));
+
+die "$0: does not know which Windows compiler to use\n"
+ unless defined $WIN;
+
+print "Symbian $SYMBIAN_VERSION SDK $SDK_VARIANT $SDK_VERSION ($WIN) installed at $SYMBIAN_ROOT\n";
+
+my $CWD = do "cwd.pl" or die $@;
+print "Build directory $CWD\n";
+
+die "$0: '+' in cwd does not work with Series 60 SDK 1.2\n"
+ if defined $S60SDK && $S60SDK eq '1.2' && $CWD =~ /\+/;
+
+my @unclean;
+my @mmp;
+
+sub create_mmp {
+ my ( $target, $type, @x ) = @_;
+ my $miniperl = $target eq 'miniperl';
+ my $perl = $target eq 'perl';
+ my $mmp = "$target.mmp";
+ my $targetpath = $miniperl
+ || $perl ? "TARGETPATH\t\\System\\Apps\\Perl" : "";
+ if ( open( my $fh, ">$mmp" ) ) {
+ print "\t$mmp\n";
+ push @mmp, $mmp;
+ push @unclean, $mmp;
+ print $fh <<__EOF__;
+TARGET $target.$type
+TARGETTYPE $type
+$targetpath
+EPOCHEAPSIZE 1024 8388608
+EPOCSTACKSIZE 65536
+EXPORTUNFROZEN
+SRCDBG
+__EOF__
+ if ($SDK_VARIANT eq 'S60') {
+ print $fh "MACRO\t__SERIES60__\n";
+ print $fh "MACRO\t__SERIES60_1X__\n" if $S60SDK =~ /^1\./;
+ print $fh "MACRO\t__SERIES60_2X__\n" if $S60SDK =~ /^2\./;
+ }
+ if ($SDK_VARIANT eq 'S80') {
+ print $fh "MACRO\t__SERIES80__\n";
+ print $fh "MACRO\t__SERIES80_1X__\n" if $S80SDK =~ /^1\./;
+ print $fh "MACRO\t__SERIES80_2X__\n" if $S80SDK =~ /^2\./;
+ }
+ if ($SDK_VARIANT eq 'S90') {
+ print $fh "MACRO\t__SERIES90__\n";
+ }
+ if ($SDK_VARIANT eq 'UIQ') {
+ print $fh "MACRO\t__UIQ__\n";
+ print $fh "MACRO\t__UIQ_1X__\n" if $UIQSDK =~ /^1\./;
+ print $fh "MACRO\t__UIQ_2X__\n" if $UIQSDK =~ /^2\./;
+ }
+ my ( @c, %c );
+ @c = map { glob } qw(*.c); # Find the .c files.
+ @c = map { lc } @c; # Lowercase the names.
+ @c = grep { !/malloc\.c/ } @c; # Use the system malloc.
+ @c = grep { !/madly\.c/ } @c; # mad is undef.
+ @c = grep { !/main\.c/ } @c; # main.c must be explicit.
+ push @c, map { lc } @x;
+ @c = map { s:^\.\./::; $_ } @c; # Remove the leading ../
+ @c = map { $c{$_}++ } @c; # Uniquefy.
+ @c = sort keys %c; # Beautify.
+
+ for (@c) {
+ print $fh "SOURCE\t\t$_\n";
+ }
+ print $fh <<__EOF__;
+SOURCEPATH $CWD
+USERINCLUDE $CWD
+USERINCLUDE $CWD\\ext\\DynaLoader
+USERINCLUDE $CWD\\symbian
+SYSTEMINCLUDE \\epoc32\\include\\libc
+SYSTEMINCLUDE \\epoc32\\include
+LIBRARY euser.lib
+LIBRARY estlib.lib
+LIBRARY eikcore.lib
+LIBRARY cone.lib
+LIBRARY efsrv.lib
+__EOF__
+ if ( $miniperl || $perl || $type eq 'dll' ) {
+ print $fh <<__EOF__;
+LIBRARY charconv.lib
+LIBRARY hal.lib
+LIBRARY estor.lib
+__EOF__
+ }
+ if ($SDK_VARIANT =~ /^S[689]0$/) {
+ print $fh <<__EOF__;
+LIBRARY commonengine.lib
+__EOF__
+ }
+ if (defined $S60SDK) {
+ print $fh <<__EOF__;
+LIBRARY avkon.lib
+LIBRARY commondialogs.lib
+__EOF__
+ }
+ if ((defined $S80SDK) or (defined $S90SDK)) {
+ print $fh <<__EOF__;
+LIBRARY eikctl.lib
+LIBRARY eikcoctl.lib
+LIBRARY eikdlg.lib
+LIBRARY ckndlg.lib
+__EOF__
+ }
+ if (defined $UIQSDK) {
+ print $fh <<__EOF__;
+LIBRARY eikctl.lib
+LIBRARY eikcoctl.lib
+LIBRARY eikdlg.lib
+LIBRARY qikctl.lib
+__EOF__
+ }
+ if ( $type eq 'exe' ) {
+ print $fh <<__EOF__;
+STATICLIBRARY ecrt0.lib
+__EOF__
+ }
+ if ($miniperl) {
+ print $fh <<__EOF__;
+MACRO PERL_MINIPERL
+__EOF__
+ }
+ if ($perl) {
+ print $fh <<__EOF__;
+MACRO PERL_PERL
+__EOF__
+ }
+ print $fh <<__EOF__;
+MACRO PERL_CORE
+MACRO MULTIPLICITY
+MACRO PERL_IMPLICIT_CONTEXT
+__EOF__
+ unless ( $miniperl || $perl ) {
+ print $fh <<__EOF__;
+MACRO PERL_GLOBAL_STRUCT
+MACRO PERL_GLOBAL_STRUCT_PRIVATE
+RESOURCE symbian\\PerlUi.rss
+__EOF__
+ }
+ close $fh;
+ }
+ else {
+ warn "$0: failed to open $mmp for writing: $!\n";
+ }
+}
+
+sub create_bld_inf {
+ if ( open( BLD_INF, ">bld.inf" ) ) {
+ print "\tbld.inf\n";
+ push @unclean, "bld.inf";
+ print BLD_INF <<__EOF__;
+PRJ_PLATFORMS
+${WIN} ${ARM}
+PRJ_MMPFILES
+__EOF__
+ for (@mmp) { print BLD_INF $_, "\n" }
+ close BLD_INF;
+ }
+ else {
+ warn "$0: failed to open bld.inf for writing: $!\n";
+ }
+}
+
+my %config;
+
+sub load_config_sh {
+ if ( open( CONFIG_SH, "symbian/config.sh" ) ) {
+ while (<CONFIG_SH>) {
+ if (/^(\w+)=['"]?(.*?)["']?$/) {
+ my ( $var, $val ) = ( $1, $2 );
+ $val =~ s/x.y.z/$R_V_SV/gi;
+ $val =~ s/thumb/$ARM/gi;
+ $val = "C:$val" if (defined($S90SDK) and ($val =~ /^(\/|\\\\)system[\/\\]/i));
+ $val = "'$SYMBIAN_VERSION'" if $var eq 'osvers';
+ $val = "'$SDK_VERSION'" if $var eq 'sdkvers';
+ $config{$var} = $val;
+ }
+ }
+ close CONFIG_SH;
+ }
+ else {
+ warn "$0: failed to open symbian\\config.sh for reading: $!\n";
+ }
+}
+
+sub create_config_h {
+ load_config_sh();
+ if ( open( CONFIG_H, ">config.h" ) ) {
+ print "\tconfig.h\n";
+ push @unclean, "config.h";
+ if ( open( CONFIG_H_SH, "config_h.SH" ) ) {
+ while (<CONFIG_H_SH>) {
+ last if /\#ifndef _config_h_/;
+ }
+ print CONFIG_H <<__EOF__;
+/*
+ * Package name : perl
+ * Source directory : .
+ * Configuration time:
+ * Configured by :
+ * Target system : symbian
+ */
+
+#ifndef _config_h_
+__EOF__
+ while (<CONFIG_H_SH>) {
+ last if /!GROK!THIS/;
+ s/\$(\w+)/exists $config{$1} ? $config{$1} : (warn "$0: config.sh missing '$1'\n", "")/eg;
+ s/^#undef\s+(\S+).+/#undef $1/g;
+ s:\Q/**/::;
+ print CONFIG_H;
+ }
+ close CONFIG_H_SH;
+ }
+ else {
+ warn "$0: failed to open ../config_h.SH for reading: $!\n";
+ }
+ close CONFIG_H;
+ }
+ else {
+ warn "$0: failed to open config.h for writing: $!\n";
+ }
+}
+
+sub create_DynaLoader_cpp {
+ print "\text\\DynaLoader\\DynaLoader.cpp\n";
+ system(
+q[xsubpp ext\DynaLoader\dl_symbian.xs >ext\DynaLoader\DynaLoader.cpp]
+ ) == 0
+ or die "$0: creating DynaLoader.cpp failed: $!\n";
+ push @unclean, 'ext\DynaLoader\DynaLoader.cpp';
+
+}
+
+sub create_symbian_port_h {
+ print "\tsymbian\\symbian_port.h\n";
+ if ( open( SYMBIAN_PORT_H, ">symbian/symbian_port.h" ) ) {
+ my ($sdkmajor, $sdkminor);
+ if ($SDK_VARIANT eq 'S60') {
+ $S60SDK =~ /^(\d+)\.(\d+)$/;
+ ($sdkmajor, $sdkminor) = ($1, $2);
+ }
+ if ($SDK_VARIANT eq 'S80') {
+ $S80SDK =~ /^(\d+)\.(\d+)$/;
+ ($sdkmajor, $sdkminor) = ($1, $2);
+ }
+ if ($SDK_VARIANT eq 'S90') {
+ $S90SDK =~ /^(\d+)\.(\d+)$/;
+ ($sdkmajor, $sdkminor) = ($1, $2);
+ }
+ if ($SDK_VARIANT eq 'UIQ') {
+ $UIQSDK =~ /^(\d+)\.(\d+)$/;
+ ($sdkmajor, $sdkminor) = ($1, $2);
+ }
+ print SYMBIAN_PORT_H <<__EOF__;
+/* Copyright (c) 2004-2005, Nokia. All rights reserved. */
+
+#ifndef __symbian_port_h__
+#define __symbian_port_h__
+
+#define PERL_SYMBIANPORT_MAJOR $PORT{dll}->{MAJOR}
+#define PERL_SYMBIANPORT_MINOR $PORT{dll}->{MINOR}
+#define PERL_SYMBIANPORT_PATCH $PORT{dll}->{PATCH}
+
+#define PERL_SYMBIANSDK_FLAVOR L"$SDK_VARIANT"
+#define PERL_SYMBIANSDK_MAJOR $sdkmajor
+#define PERL_SYMBIANSDK_MINOR $sdkminor
+
+#endif /* #ifndef __symbian_port_h__ */
+__EOF__
+ close(SYMBIAN_PORT_H);
+ push @unclean, 'symbian\symbian_port.h';
+ }
+ else {
+ warn "$0: failed to open symbian/symbian_port.h for writing: $!\n";
+ }
+}
+
+sub create_perlmain_c {
+ print "\tperlmain.c\n";
+ system(
+q[perl -ne "print qq[ char *file = __FILE__;\n] if /dXSUB_SYS/;print unless /PERL_UNUSED_CONTEXT/;print qq[ newXS(\"DynaLoader::boot_DynaLoader\", boot_DynaLoader, file);\n] if /dXSUB_SYS/;print qq[EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);\n] if /Do not delete this line/" miniperlmain.c > perlmain.c]
+ ) == 0
+ or die "$0: Creating perlmain.c failed: $!\n";
+ push @unclean, 'perlmain.c';
+}
+
+sub create_PerlApp_pkg {
+ print "\tsymbian\\PerlApp.pkg\n";
+ if ( open( PERLAPP_PKG, ">symbian\\PerlApp.pkg" ) ) {
+ my $ProductId =
+ defined $S60SDK ?
+qq[;Supports Series 60 v0.9\n(0x101F6F88), 0, 0, 0, {"Series60ProductID"}\n] :
+ defined $S80SDK ?
+qq[;Supports Series 80 v2.0\n(0x101F8ED2), 0, 0, 0, {"Series80ProductID"}\n] :
+ defined $S90SDK ?
+qq[;Supports Series 90 v1.1\n(0x101FBE05), 0, 0, 0, {"Series90ProductID"}\n] :
+ defined $UIQSDK && $SDK_VERSION =~ /^(\d)\.(\d)$/ ?
+qq[;Supports UIQ v2.1\n(0x101F617B), $1, $2, 0, {"UIQ21ProductID"}\n] :
+ ";Supports Series NN";
+ my $APPS = $UREL;
+ if (($SDK_VARIANT eq 'S60' && $SDK_VERSION ne '1.2' || $WIN eq 'winscw') || defined $S80SDK || defined $S90SDK) { # Do only if not in S60 1.2 VC.
+ $APPS =~ s!\\epoc32\\release\\(.+)\\$UARM$!\\epoc32\\data\\z\\system\\apps\\PerlApp!i;
+ }
+ # TODO: in S60 3.0 there will be no more recognizers.
+ my $mdl = qq["$UREL\\PerlRecog.mdl"-"!:\\system\\recogs\\PerlRecog.mdl";];
+ my $AIF = $SDK_VARIANT =~ /^S[689]0/ ? qq["$APPS\\PerlApp.aif"-"!:\\system\\apps\\PerlApp\\PerlApp.aif"] : "";
+ print PERLAPP_PKG <<__EOF__;
+; !!!!!! DO NOT EDIT THIS FILE !!!!!!
+; This file is built by symbian\\config.pl.
+; Any changes made here will be lost!
+;
+; PerlApp.pkg
+;
+; Note that the demo_pl needs to be run to create the demo .pl scripts.
+;
+; Languages
+&EN;
+
+; Standard SIS file header
+#{"PerlApp"},(0x102015F6),0,2,0
+
+$ProductId
+
+; Files
+"$UREL\\PerlApp.APP"-"!:\\system\\apps\\PerlApp\\PerlApp.app"
+$mdl
+"$APPS\\PerlApp.rsc"-"!:\\system\\apps\\PerlApp\\PerlApp.rsc"
+$AIF
+__EOF__
+ if ( open( DEMOS, "perl symbian\\demo_pl list |" ) ) {
+ while (<DEMOS>) {
+ chomp;
+ if (defined $S90SDK) {
+ print PERLAPP_PKG qq["$_"-"!:\\Mydocs\\Perl\\$_"\n];
+ } else {
+ print PERLAPP_PKG qq["$_"-"!:\\Perl\\$_"\n];
+ }
+ }
+ close(DEMOS);
+ }
+ close(PERLAPP_PKG);
+ }
+ else {
+ die "$0: symbian\\PerlApp.pkg: $!\n";
+ }
+ push @unclean, 'symbian\PerlApp.pkg';
+}
+
+print "Creating...\n";
+create_mmp(
+ 'miniperl', 'exe',
+ 'miniperlmain.c', 'symbian\symbian_stubs.c',
+ 'symbian\PerlBase.cpp',
+ 'symbian\PerlUi.cpp',
+ 'symbian\PerlUtil.cpp',
+ 'symbian\symbian_utils.cpp',
+);
+create_mmp(
+ "perl", 'exe',
+ 'perlmain.c', 'symbian\symbian_stubs.c',
+ 'symbian\symbian_utils.cpp',
+ 'symbian\PerlBase.cpp',
+ 'symbian\PerlUi.cpp',
+ 'symbian\PerlUtil.cpp',
+ 'ext\DynaLoader\DynaLoader.cpp',
+);
+
+create_mmp(
+ "perl$VERSION", 'dll',
+ 'symbian\symbian_dll.cpp', 'symbian\symbian_stubs.c',
+ 'symbian\symbian_utils.cpp',
+ 'symbian\PerlBase.cpp',
+ 'symbian\PerlUi.cpp',
+ 'symbian\PerlUtil.cpp',
+ 'ext\DynaLoader\DynaLoader.cpp',
+);
+
+create_bld_inf();
+create_config_h();
+create_perlmain_c();
+create_symbian_port_h();
+create_DynaLoader_cpp();
+create_PerlApp_pkg();
+
+if ( open( PERLAPP_MMP, ">symbian/PerlApp.mmp" ) ) {
+ my @MACRO;
+ my @LIB;
+ push @MACRO, 'PERL_IMPLICIT_CONTEXT';
+ push @MACRO, 'MULTIPLICITY';
+ if (defined $S60SDK) {
+ push @MACRO, '__SERIES60__';
+ push @MACRO, '__SERIES60_1X__' if $S60SDK =~ /^1\./;
+ push @MACRO, '__SERIES60_2X__' if $S60SDK =~ /^2\./;
+ push @LIB, <<__EOF__;
+LIBRARY avkon.lib
+LIBRARY commondialogs.lib
+__EOF__
+ }
+ if (defined $S80SDK) {
+ push @MACRO, '__SERIES80__';
+ push @MACRO, '__SERIES80_1X__' if $S80SDK =~ /^1\./;
+ push @MACRO, '__SERIES80_2X__' if $S80SDK =~ /^2\./;
+ push @LIB, <<__EOF__;
+LIBRARY eikctl.lib
+LIBRARY eikcoctl.lib
+LIBRARY eikdlg.lib
+LIBRARY ckndlg.lib
+__EOF__
+ }
+ if (defined $S90SDK) {
+ push @MACRO, '__SERIES90__';
+ push @LIB, <<__EOF__;
+LIBRARY eikctl.lib
+LIBRARY eikcoctl.lib
+LIBRARY eikdlg.lib
+LIBRARY ckndlg.lib
+__EOF__
+ }
+ if (defined $UIQSDK) {
+ push @MACRO, '__UIQ__';
+ push @MACRO, '__UIQ_1X__' if $UIQSDK =~ /^1\./;
+ push @MACRO, '__UIQ_2X__' if $UIQSDK =~ /^2\./;
+ push @LIB, <<__EOF__;
+LIBRARY eikctl.lib
+LIBRARY eikcoctl.lib
+LIBRARY eikdlg.lib
+LIBRARY qikctl.lib
+__EOF__
+ }
+ print PERLAPP_MMP <<__EOF__;
+// !!!!!! DO NOT EDIT THIS FILE !!!!!!
+// This file is built by symbian\\config.pl.
+// Any changes made here will be lost!
+TARGET PerlApp.app
+TARGETTYPE app
+UID 0x100039CE 0x102015F6
+TARGETPATH \\system\\apps\\PerlApp
+SRCDBG
+EXPORTUNFROZEN
+SOURCEPATH .
+SOURCE PerlApp.cpp
+
+USERINCLUDE .
+USERINCLUDE ..
+USERINCLUDE \\symbian\\perl\\$R_V_SV\\include
+
+SYSTEMINCLUDE \\epoc32\\include
+SYSTEMINCLUDE \\epoc32\\include\\libc
+
+LIBRARY apparc.lib
+LIBRARY bafl.lib
+LIBRARY charconv.lib
+LIBRARY cone.lib
+LIBRARY efsrv.lib
+LIBRARY eikcore.lib
+LIBRARY estlib.lib
+LIBRARY euser.lib
+LIBRARY perl$VERSION.lib
+@LIB
+RESOURCE perlapp.rss
+__EOF__
+ if (@MACRO) {
+ for my $macro (@MACRO) {
+ print PERLAPP_MMP <<__EOF__;
+MACRO $macro
+__EOF__
+ }
+ }
+ if ($SDK_VARIANT =~ /^S[689]0$/) {
+ print PERLAPP_MMP <<__EOF__;
+AIF PerlApp.aif . PerlAppAif.rss
+__EOF__
+ }
+ close(PERLAPP_MMP);
+ push @unclean, 'symbian\PerlApp.mmp';
+}
+else {
+ warn "$0: failed to create symbian\\PerlApp.mmp";
+}
+
+if ( open( MAKEFILE, ">Makefile" ) ) {
+ my $perl = "perl$VERSION";
+ my $windef1 = "$SYMBIAN_ROOT\\Epoc32\\Build$CWD\\$perl\\$WIN\\$perl.def";
+ my $windef2 = "..\\BWINS\\${perl}u.def";
+ my $armdef1 = "$SYMBIAN_ROOT\\Epoc32\\Build$CWD\\$perl\\$ARM\\$perl.def";
+ my $armdef2 = "..\\BMARM\\${perl}u.def";
+ my $MF = $WIN eq 'wins' ? 'vc6' : $WIN eq 'winscw' ? 'cw_ide' : "UNKNOWN";
+ print "\tMakefile\n";
+ print MAKEFILE <<__EOF__;
+help:
+ \@echo === Perl for Symbian ===
+ \@echo Useful targets:
+ \@echo all win arm clean
+ \@echo perldll.sis perlext.sis perlsdk.zip
+
+WIN = ${WIN}
+ARM = ${ARM}
+
+all: build
+
+build: rename_makedef build_${WIN} build_arm
+
+@unclean: symbian\\config.pl
+ perl symbian\\config.pl
+
+build_${WIN}: abld.bat perldll_${WIN}
+
+build_vc6: abld.bat perldll_wins
+
+build_vc7: abld.bat perldll_wins
+
+build_cw: abld.bat perldll_winscw
+
+build_arm: abld.bat perl_arm miniperl_arm perldll_arm
+
+miniperl_win miniperl_${WIN}: miniperl.mmp abld.bat rename_makedef
+ abld build ${WIN} udeb miniperl
+
+miniperl_arm: miniperl.mmp abld.bat rename_makedef
+ abld build \$(ARM) $UARM miniperl
+
+miniperl: miniperl_${WIN} miniperl_arm
+
+perl: perl_${WIN} perl_arm
+
+perl_win perl_${WIN}: perl.mmp abld.bat rename_makedef
+ abld build ${WIN} perl
+
+perl_arm: perl.mmp abld.bat rename_makedef
+ abld build \$(ARM) $UARM perl
+
+perldll_win perldll_${WIN}: perl${VERSION}_${WIN} freeze_${WIN} perl${VERSION}_${WIN}
+
+perl${VERSION}_win perl${VERSION}_${WIN}: perl$VERSION.mmp abld.bat rename_makedef
+ abld build ${WIN} perl$VERSION
+
+perldll_arm: perl${VERSION}_arm freeze_arm perl${VERSION}_arm
+
+perl${VERSION}_arm: perl$VERSION.mmp abld.bat rename_makedef
+ abld build \$(ARM) $UARM perl$VERSION
+
+perldll perl$VERSION: perldll_${WIN} perldll_arm
+
+win ${WIN}: miniperl_${WIN} perl_${WIN} perldll_${WIN}
+
+thumb arm: miniperl_arm perl_arm perldll_arm
+
+rename_makedef:
+ -ren makedef.pl nomakedef.pl
+
+# Symbian SDK has a makedef.pl of its own,
+# and we don't need Perl's.
+rerename_makedef:
+ -ren nomakedef.pl makedef.pl
+
+symbian\\PerlUi.rss: symbian\\PerlUi$SDK_VARIANT.rss
+ copy symbian\\PerlUi$SDK_VARIANT.rss symbian\\PerlUi.rss
+
+abld.bat abld: bld.inf symbian\\PerlUi.rss
+ bldmake bldfiles
+
+vc6: win.mf vc6.mf build_vc6
+
+vc7: win.mf vc7.mf build_vc7
+
+cw: win.mf cw.mf build_cw
+
+${WIN}_miniperl.mf: abld.bat symbian\\config.pl
+ abld makefile ${MF} miniperl
+ echo > ${WIN}_miniperl.mf
+
+${WIN}_perl.mf: abld.bat symbian\\config.pl
+ abld makefile ${MF} perl
+ echo > ${WIN}_perl.mf
+
+${WIN}_${VERSION}.mf: abld.bat symbian\\config.pl
+ abld makefile ${MF} perl${VERSION}
+ echo > ${WIN}_${VERSION}.mf
+
+symbian\\${WIN}.mf:
+ cd symbian; make ${WIN}.mf
+
+${WIN}.mf: ${WIN}_miniperl.mf ${WIN}_perl.mf ${WIN}_${VERSION}.mf symbian\\${WIN}.mf
+
+arm_miniperl.mf: abld.bat symbian\\config.pl
+ echo > arm_miniperl.mf
+
+arm_perl.mf: abld.bat symbian\\config.pl
+ echo > arm_perl.mf
+
+arm_${VERSION}.mf: abld.bat symbian\\config.pl
+ echo > arm_${VERSION}.mf
+
+arm.mf: arm_miniperl.mf arm_perl.mf arm_${VERSION}.mf
+
+win.mf: vc6.mf cw.mf
+ echo > win.mf
+
+vc6.mf: abld.bat symbian\\config.pl
+ abld makefile vc6
+ echo > vc6.mf
+
+vc7.mf: abld.bat symbian\\config.pl
+ abld makefile vc7
+ echo > vc7.mf
+
+cw.mf: abld.bat symbian\\config.pl
+ abld makefile cw_ide
+ echo > cw.mf
+
+PM = lib\\Config.pm lib\\Cross.pm lib\\lib.pm ext\\DynaLoader\\DynaLoader.pm ext\\DynaLoader\\XSLoader.pm ext\\Errno\\Errno.pm
+POD = lib\\Config.pod
+
+pm: \$(PM)
+
+XLIB = -Ixlib\\symbian
+
+XSBOPT = --win=\$(WIN) --arm=\$(ARM)
+
+lib\\Config.pm:
+ copy symbian\\config.sh config.sh
+__EOF__
+ if (defined $S90SDK) {
+ print MAKEFILE <<__EOF__;
+ perl -pi.bak -e "s:x\\.y\\.z+:$R_V_SV:g; s!='(\\\\\\\\system)!='C:\\1!" config.sh
+__EOF__
+ } else {
+ print MAKEFILE <<__EOF__;
+ perl -pi.bak -e "s:x\\.y\\.z+:$R_V_SV:g" config.sh
+__EOF__
+ };
+ print MAKEFILE <<__EOF__;
+ perl \$(XLIB) configpm --cross=symbian
+ copy xlib\\symbian\\Config.pm lib\\Config.pm
+ perl -pi.bak -e "s:x\\.y\\.z:$R_V_SV:g" lib\\Config.pm
+ perl -pi.bak -e "s:5\\.\\d+\\.\\d+:$R_V_SV:g" lib\\Config.pm
+ -perl -pi.bak -e "s:x\\.y\\.z:$R_V_SV:g" xlib\\symbian\\Config_heavy.pl
+
+lib\\lib.pm:
+ perl lib\\lib_pm.PL
+
+ext\\DynaLoader\\DynaLoader.pm:
+ -del /f ext\\DynaLoader\\DynaLoader.pm
+ perl -Ixlib\\symbian ext\\DynaLoader\\DynaLoader_pm.PL
+ perl -pi.bak -e "s/__END__//" DynaLoader.pm
+ copy /y DynaLoader.pm ext\\DynaLoader\\DynaLoader.pm
+ -del /f DynaLoader.pm DynaLoader.pm.bak
+
+ext\\DynaLoader\\XSLoader.pm:
+ perl \$(XLIB) symbian\\xsbuild.pl \$(XSBOPT) XSLoader
+
+ext\\Errno\\Errno.pm:
+ perl \$(XLIB) symbian\\xsbuild.pl \$(XSBOPT) Errno
+
+miniperlexe.sis: miniperl_arm symbian\\makesis.pl
+ perl \$(XLIB) symbian\\makesis.pl miniperl
+
+perlexe.sis: perl_arm symbian\\makesis.pl
+ perl \$(XLIB) symbian\\makesis.pl perl
+
+
+allsis: all miniperlexe.sis perlexe.sis perldll.sis perllib.sis perlext.sis perlapp.sis
+
+perldll.sis perl$VERSION.sis: perldll_arm pm symbian\\makesis.pl
+ perl \$(XLIB) symbian\\makesis.pl perl${VERSION}dll
+
+perl${VERSION}lib.sis perllib.sis: \$(PM)
+ perl \$(XLIB) symbian\\makesis.pl perl${VERSION}lib
+
+perl${VERSION}ext.sis perlext.sis: perldll_arm buildext_sis
+ perl symbian\\makesis.pl perl${VERSION}ext
+
+EXT = Compress::Raw::Zlib Cwd Data::Dumper Devel::Peek Digest::MD5 Errno Fcntl File::Glob Filter::Util::Call IO List::Util MIME::Base64 PerlIO::scalar PerlIO::via SDBM_File Socket Storable Time::HiRes XSLoader attrs
+
+buildext: perldll symbian\\xsbuild.pl lib\\Config.pm
+ perl \$(XLIB) symbian\\xsbuild.pl \$(XSBOPT) \$(EXT)
+
+buildextcpp: perldll symbian\\xsbuild.pl lib\\Config.pm
+ perl \$(XLIB) symbian\\xsbuild.pl --csuffix .cpp \$(XSBOPT) \$(EXT)
+
+buildext_sis: perldll.sis symbian\\xsbuild.pl lib\\Config.pm
+ perl \$(XLIB) symbian\\xsbuild.pl \$(XSBOPT) --sis \$(EXT)
+
+buildextcpp_sis: perldll.sis symbian\\xsbuild.pl lib\\Config.pm
+ perl \$(XLIB) symbian\\xsbuild.pl --csuffix .cpp \$(XSBOPT) --sis \$(EXT)
+
+cleanext: symbian\\xsbuild.pl
+ perl \$(XLIB) symbian\\xsbuild.pl \$(XSBOPT) --clean \$(EXT)
+
+distcleanext: symbian\\xsbuild.pl
+ perl \$(XLIB) symbian\\xsbuild.pl \$(XSBOPT) --distclean \$(EXT)
+
+sis makesis: miniperl perl perldll pm buildext perlapp.sis
+ perl \$(XLIB) symbian\\makesis.pl
+
+APIDIR = \\Symbian\\perl\\$R_V_SV
+
+sdkinstall:
+ -mkdir \\Symbian\\perl
+ -mkdir \\Symbian\\perl\\$R_V_SV
+ -mkdir \$(APIDIR)\\include
+ -mkdir \$(APIDIR)\\include\\symbian
+ -mkdir \$(APIDIR)\\lib
+ -mkdir \$(APIDIR)\\lib\\ExtUtils
+ -mkdir \$(APIDIR)\\pod
+ -mkdir \$(APIDIR)\\bin
+ -mkdir \$(BINDIR)
+ copy /y *.h \$(APIDIR)\\include
+ -copy /y *.inc \$(APIDIR)\\include
+ copy /y lib\\ExtUtils\\xsubpp \$(APIDIR)\\lib\\ExtUtils
+ copy /y lib\\ExtUtils\\typemap \$(APIDIR)\\lib\\ExtUtils
+ copy /y lib\\ExtUtils\\ParseXS.pm \$(APIDIR)\\lib\\ExtUtils
+ copy /y symbian\\xsbuild.pl \$(APIDIR)\\bin
+ copy /y symbian\\sisify.pl \$(APIDIR)\\bin
+ copy /y symbian\\PerlBase.h \$(APIDIR)\\include
+ copy /y symbian\\PerlUi.h \$(APIDIR)\\include
+ copy /y symbian\\PerlUtil.h \$(APIDIR)\\include
+ copy /y symbian\\symbian*.h \$(APIDIR)\\include\\symbian
+ copy /y symbian\\PerlBase.pod \$(APIDIR)\\pod
+ copy /y symbian\\PerlUtil.pod \$(APIDIR)\\pod
+
+RELDIR = $SYMBIAN_ROOT\\epoc32\\release
+RELWIN = \$(RELDIR)\\\$(WIN)\\udeb
+RELARM = \$(RELDIR)\\\$(ARM)\\$UARM
+SDKZIP = perl${VERSION}sdk.zip
+
+
+\$(SDKZIP) perlsdk.zip: perldll sdkinstall
+ -del /f perl${VERSION}sdk.zip
+ zip -r perl${VERSION}sdk.zip \$(RELWIN)\\perl$VERSION.* \$(RELARM)\\perl$VERSION.* \$(APIDIR)
+ \@echo perl${VERSION}sdk.zip created.
+
+PERLSIS = perl${VERSION}.SIS perl${VERSION}lib.SIS perl${VERSION}ext.SIS
+ALLSIS = \$(PERLSIS) perlapp.sis
+ETC = README.symbian symbian\\PerlBase.pod symbian\\PerlUtil.pod symbian\\sisify.pl symbian\\TODO
+
+perl${VERSION}dist.zip perldist.zip: \$(ALLSIS) \$(SDKZIP) \$(ETC)
+ -del /f perl${VERSION}dist.zip
+ zip -r perl${VERSION}dist.zip \$(ALLSIS) \$(SDKZIP) \$(ETC)
+
+perlapp: sdkinstall perlapp_${WIN} perlapp_arm
+
+perlapp_arm_minimal sisify_hex perlappmin.hex perlrscmin.hex: sdkinstall config.h
+ cd symbian; make perlapp_arm USERDEFS=-DCreatePerlAppMinimal
+ perl symbian\\hexdump.pl
+
+perlapp_win perlapp_${WIN}: config.h
+ cd symbian; make perlapp_${WIN}
+
+perlapp_arm: config.h
+ cd symbian; make perlapp_arm
+
+perlapp_arm_clean:
+ cd symbian; make clean
+
+perlapp_demo_extract:
+ cd symbian; make perlapp_demo_extract
+
+perlapp.sis: perlapp_arm
+ cd symbian; make perlapp.sis
+
+perlapp.zip:
+ cd symbian; zip perlapp.zip PerlApp.* PerlRecog.* PerlBase.* PerlUtil.* demo_pl
+
+zip: perlsdk.zip perlapp.zip
+
+freeze: freeze_${WIN} freeze_arm
+
+freeze_${WIN}:
+ abld freeze ${WIN} perl$VERSION
+
+freeze_arm:
+ abld freeze \$(ARM) perl$VERSION
+
+defrost: defrost_${WIN} defrost_arm
+
+defrost_${WIN}:
+ -del /f $windef1
+ -del /f $windef2
+
+defrost_arm:
+ -del /f $armdef1
+ -del /f $armdef2
+
+clean_${WIN}: abld.bat
+ abld clean ${WIN}
+
+clean_arm: abld.bat
+ abld clean \$(ARM)
+
+clean: clean_${WIN} clean_arm rerename_makedef
+ -del /f \$(PM)
+ -del /f \$(POD)
+ -del /f lib\\Config.pm.bak
+ -del /f xlib\\symbian\\Config_heavy.pl
+ -rmdir /s /q xlib
+ -del /f config.sh
+ -del /f DynaLoader.pm ext\\DynaLoader\\DynaLoader.pm
+ -del /f ext\\DynaLoader\\Makefile
+ -del /f ext\\SDBM_File\\sdbm\\Makefile
+ -del /f symbian\\*.lst
+ -del /f abld.bat @unclean *.pkg *.sis *.zip
+ -del /f symbian\\abld.bat symbian\\*.sis symbian\\*.zip
+ -del /f symbian\\perl5*.pkg symbian\\miniperl.pkg
+ -del arm_*.mf ${WIN}_*.mf vc*.mf cw*.mf
+ -del symbian\\Makefile
+ -del symbian\\PerlUi.rss symbian\\PerlApp.rss
+ -del perlappmin.hex perlrscmin.hex
+ -perl symbian\\xsbuild.pl \$(XSBOPT) --clean \$(EXT)
+ -rmdir /s /q perl${VERSION}_Data
+ -cd symbian; make clean
+
+reallyclean: abld.bat
+ abld reallyclean
+
+distclean: defrost reallyclean clean
+ -perl symbian\\xsbuild.pl \$(XSBOPT) --distclean \$(EXT)
+ -del /f config.h config.sh.bak symbian\\symbian_port.h
+ -del /f Makefile symbian\\PerlApp.mmp
+ -del /f BMARM\\*.def
+ -del /f *.cwlink *.resources *.pref
+ -del /f perl${VERSION}.xml perl${VERSION}.mcp uid.cpp
+ -rmdir /s /q BMARM
+ cd symbian; make distclean
+ -del /f symbian\\Makefile
+__EOF__
+ close MAKEFILE;
+}
+else {
+ warn "$0: failed to create Makefile: $!\n";
+}
+
+if ( open( MAKEFILE, ">symbian/Makefile")) {
+ my $wrap = defined $S60SDK && $S60SDK eq '1.2' && $WIN ne '${WIN}cw';
+ my $ABLD = $wrap ? 'perl b.pl': 'abld';
+ print "\tsymbian/Makefile\n";
+ my $MF = $WIN eq 'wins' ? 'vc6' : $WIN eq 'winscw' ? 'cw_ide' : "UNKNOWN";
+ print MAKEFILE <<__EOF__;
+WIN = $WIN
+ARM = $ARM
+ABLD = $ABLD
+MF = $MF
+
+abld.bat:
+ bldmake bldfiles
+
+perlapp_${WIN}: abld.bat ..\\config.h PerlApp.h PerlApp.cpp
+ copy PerlUi$SDK_VARIANT.rss PerlApp.rss
+ bldmake bldfiles
+ \$(ABLD) build ${WIN} udeb
+
+perlapp_arm: ..\\config.h PerlApp.h PerlApp.cpp
+ copy PerlUi$SDK_VARIANT.rss PerlApp.rss
+ bldmake bldfiles
+ \$(ABLD) build ${ARM} $UARM
+
+$MF:
+ abld makefile $MF
+
+win.mf:
+ bldmake bldfiles
+ abld makefile $MF
+
+perlapp_demo_extract:
+ perl demo_pl extract
+
+perlapp.sis: perlapp_arm perlapp_demo_extract
+ -del /f perlapp.SIS
+ makesis perlapp.pkg
+ copy /y perlapp.SIS ..\\perlapp.SIS
+
+clean:
+ -perl demo_pl cleanup
+ -del /f perlapp.sis
+ -del /f b.pl
+ -del PerlApp.rss
+ abld clean $WIN
+ abld clean thumb
+ -del Makefile
+
+distclean: clean
+ -del /f *.cwlink *.resources *.pref
+ -del /f PerlApp.xml PerlApp.mcp uid.cpp
+ -rmdir /s /q PerlApp_Data
+ -del /f abld.bat
+__EOF__
+ close(MAKEFILE);
+ if ($wrap) {
+ if ( open( B_PL, ">symbian/b.pl")) {
+ print B_PL <<'__EOF__';
+# abld.pl wrapper.
+
+# nmake doesn't like MFLAGS and MAKEFLAGS being set to -w and w.
+delete $ENV{MFLAGS};
+delete $ENV{MAKEFLAGS};
+
+system("abld @ARGV");
+__EOF__
+ close(B_PL);
+ } else {
+ warn "$0: failed to create symbian/b.pl: $!\n";
+ }
+ }
+} else {
+ warn "$0: failed to create symbian/Makefile: $!\n";
+}
+
+print "Deleting...\n";
+for my $config (
+ # Do not delete config.h here.
+ "config.sh",
+ "lib\\Config.pm",
+ "xlib\\symbian\\Config.pm",
+ "xlib\\symbian\\Config_heavy.pl",
+ "symbian\\PerlUi.rss",
+ "symbian\\PerlApp.rss",
+ ) {
+ print "\t$config\n";
+ unlink($config);
+}
+
+print <<__EOM__;
+Configuring done.
+Now you can run:
+ make all
+ make allsis
+__EOM__
+
+1; # Happy End.
diff --git a/gnu/usr.bin/perl/t/comp/fold.t b/gnu/usr.bin/perl/t/comp/fold.t
index 844ee411423..92a4fbe3e49 100644
--- a/gnu/usr.bin/perl/t/comp/fold.t
+++ b/gnu/usr.bin/perl/t/comp/fold.t
@@ -1,11 +1,14 @@
-#!./perl -w
+#!./perl
-# Uncomment this for testing, but don't leave it in for "production", as
-# we've not yet verified that use works.
-# use strict;
+BEGIN {
+ chdir 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+use strict;
+use warnings;
-print "1..29\n";
-my $test = 0;
+plan (13);
# Historically constant folding was performed by evaluating the ops, and if
# they threw an exception compilation failed. This was seen as buggy, because
@@ -15,71 +18,24 @@ my $test = 0;
# optimisation rather than a behaviour change.
-sub failed {
- my ($got, $expected, $name) = @_;
-
- print "not ok $test - $name\n";
- my @caller = caller(1);
- print "# Failed test at $caller[1] line $caller[2]\n";
- if (defined $got) {
- print "# Got '$got'\n";
- } else {
- print "# Got undef\n";
- }
- print "# Expected $expected\n";
- return;
-}
-
-sub like {
- my ($got, $pattern, $name) = @_;
- $test = $test + 1;
- if (defined $got && $got =~ $pattern) {
- print "ok $test - $name\n";
- # Principle of least surprise - maintain the expected interface, even
- # though we aren't using it here (yet).
- return 1;
- }
- failed($got, $pattern, $name);
-}
-
-sub is {
- my ($got, $expect, $name) = @_;
- $test = $test + 1;
- if (defined $got && $got eq $expect) {
- print "ok $test - $name\n";
- return 1;
- }
- failed($got, "'$expect'", $name);
-}
-
-sub ok {
- my ($got, $name) = @_;
- $test = $test + 1;
- if ($got) {
- print "ok $test - $name\n";
- return 1;
- }
- failed($got, "a true value", $name);
-}
-
my $a;
$a = eval '$b = 0/0 if 0; 3';
-is ($a, 3, 'constants in conditionals don\'t affect constant folding');
-is ($@, '', 'no error');
+is ($a, 3);
+is ($@, "");
my $b = 0;
$a = eval 'if ($b) {return sqrt -3} 3';
-is ($a, 3, 'variables in conditionals don\'t affect constant folding');
-is ($@, '', 'no error');
+is ($a, 3);
+is ($@, "");
$a = eval q{
$b = eval q{if ($b) {return log 0} 4};
- is ($b, 4, 'inner eval folds constant');
- is ($@, '', 'no error');
+ is ($b, 4);
+ is ($@, "");
5;
};
-is ($a, 5, 'outer eval folds constant');
-is ($@, '', 'no error');
+is ($a, 5);
+is ($@, "");
# warn and die hooks should be disabled during constant folding
@@ -98,76 +54,3 @@ is ($@, '', 'no error');
like ($@, qr/division/, "eval caught division");
is($c, 2, "missing die hook");
}
-
-# [perl #20444] Constant folding should not change the meaning of match
-# operators.
-{
- local *_;
- $_="foo"; my $jing = 1;
- ok scalar $jing =~ (1 ? /foo/ : /bar/),
- 'lone m// is not bound via =~ after ? : folding';
- ok scalar $jing =~ (0 || /foo/),
- 'lone m// is not bound via =~ after || folding';
- ok scalar $jing =~ (1 ? s/foo/foo/ : /bar/),
- 'lone s/// is not bound via =~ after ? : folding';
- ok scalar $jing =~ (0 || s/foo/foo/),
- 'lone s/// is not bound via =~ after || folding';
- $jing = 3;
- ok scalar $jing =~ (1 ? y/fo// : /bar/),
- 'lone y/// is not bound via =~ after ? : folding';
- ok scalar $jing =~ (0 || y/fo//),
- 'lone y/// is not bound via =~ after || folding';
-}
-
-# [perl #78064] or print
-package other { # hide the "ok" sub
- BEGIN { $^W = 0 }
- print 0 ? not_ok : ok;
- print " ", ++$test, " - print followed by const ? BEAR : BEAR\n";
- print 1 ? ok : not_ok;
- print " ", ++$test, " - print followed by const ? BEAR : BEAR (again)\n";
- print 1 && ok;
- print " ", ++$test, " - print followed by const && BEAR\n";
- print 0 || ok;
- print " ", ++$test, " - print followed by const || URSINE\n";
- BEGIN { $^W = 1 }
-}
-
-# or stat
-print "not " unless stat(1 ? INSTALL : 0) eq stat("INSTALL");
-print "ok ", ++$test, " - stat(const ? word : ....)\n";
-# in case we are in t/
-print "not " unless stat(1 ? TEST : 0) eq stat("TEST");
-print "ok ", ++$test, " - stat(const ? word : ....)\n";
-
-# or truncate
-my $n = "for_fold_dot_t$$";
-open F, ">$n" or die "open: $!";
-print F "bralh blah blah \n";
-close F or die "close $!";
-eval "truncate 1 ? $n : 0, 0;";
-print "not " unless -z $n;
-print "ok ", ++$test, " - truncate(const ? word : ...)\n";
-unlink $n;
-
-# Constant folding should not change the mutability of returned values.
-for(1+2) {
- eval { $_++ };
- print "not " unless $_ eq 4;
- print "ok ", ++$test,
- " - 1+2 returns mutable value, just like \$a+\$b",
- "\n";
-}
-
-# [perl #119055]
-# We hide the implementation detail that qq "foo" is implemented using
-# constant folding.
-eval { ${\"hello\n"}++ };
-print "not " unless $@ =~ "Modification of a read-only value attempted at";
-print "ok ", ++$test, " - qq with no vars is a constant\n";
-
-# [perl #119501]
-my @values;
-for (1,2) { for (\(1+3)) { push @values, $$_; $$_++ } }
-is "@values", "4 4",
- '\1+3 folding making modification affect future retvals';
diff --git a/gnu/usr.bin/perl/t/comp/uproto.t b/gnu/usr.bin/perl/t/comp/uproto.t
index f81e31411c6..9b908eb54a7 100644
--- a/gnu/usr.bin/perl/t/comp/uproto.t
+++ b/gnu/usr.bin/perl/t/comp/uproto.t
@@ -1,52 +1,12 @@
#!perl
-print "1..43\n";
-my $test = 0;
-
-sub failed {
- my ($got, $expected, $name) = @_;
-
- print "not ok $test - $name\n";
- my @caller = caller(1);
- print "# Failed test at $caller[1] line $caller[2]\n";
- if (defined $got) {
- print "# Got '$got'\n";
- } else {
- print "# Got undef\n";
- }
- print "# Expected $expected\n";
- return;
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require "./test.pl";
}
-sub like {
- my ($got, $pattern, $name) = @_;
- $test = $test + 1;
- if (defined $got && $got =~ $pattern) {
- print "ok $test - $name\n";
- # Principle of least surprise - maintain the expected interface, even
- # though we aren't using it here (yet).
- return 1;
- }
- failed($got, $pattern, $name);
-}
-
-sub is {
- my ($got, $expect, $name) = @_;
- $test = $test + 1;
- if (defined $expect) {
- if (defined $got && $got eq $expect) {
- print "ok $test - $name\n";
- return 1;
- }
- failed($got, "'$expect'", $name);
- } else {
- if (!defined $got) {
- print "ok $test - $name\n";
- return 1;
- }
- failed($got, 'undef', $name);
- }
-}
+plan(tests => 39);
sub f($$_) { my $x = shift; is("@_", $x) }
@@ -72,11 +32,7 @@ eval q{ f(1,2,3,4) };
like( $@, qr/Too many arguments for main::f at/ );
{
- # We have not tested require/use/no yet, so we must avoid this:
- # no warnings 'deprecated';
- BEGIN { $SIG{__WARN__} = sub {} }
my $_ = "quarante-deux";
- BEGIN { $SIG{__WARN__} = undef }
$foo = "FOO";
$bar = "BAR";
f("FOO quarante-deux", $foo);
@@ -101,9 +57,7 @@ $_ = $expected;
g();
g;
undef $expected; &g; # $_ not passed
-BEGIN { $SIG{__WARN__} = sub {} }
{ $expected = my $_ = "bar"; g() }
-BEGIN { $SIG{__WARN__} = undef }
eval q{ sub wrong1 (_$); wrong1(1,2) };
like( $@, qr/Malformed prototype for main::wrong1/, 'wrong1' );
@@ -111,11 +65,7 @@ like( $@, qr/Malformed prototype for main::wrong1/, 'wrong1' );
eval q{ sub wrong2 ($__); wrong2(1,2) };
like( $@, qr/Malformed prototype for main::wrong2/, 'wrong2' );
-sub opt ($;_) {
- is($_[0], "seen");
- is($_[1], undef, "; has precedence over _");
-}
-
+sub opt ($;_) { is($_[0], "seen"); ok(!defined $_[1], "; has precedence over _") }
opt("seen");
sub unop (_) { is($_[0], 11, "unary op") }
@@ -126,21 +76,6 @@ $expected = $_ = "mydir"; mymkdir();
mymkdir($expected = "foo");
$expected = "foo 493"; mymkdir foo => 0755;
-sub mylist (_@) { is("@_", $expected, "mylist") }
-$expected = "foo";
-$_ = "foo";
-mylist();
-$expected = "10 11 12 13";
-mylist(10, 11 .. 13);
-
-sub mylist2 (_%) { is("@_", $expected, "mylist2") }
-$expected = "foo";
-$_ = "foo";
-mylist2();
-$expected = "10 a 1";
-my %hash = (a => 1);
-mylist2(10, %hash);
-
# $_ says modifiable, it's not passed by copy
sub double(_) { $_[0] *= 2 }
@@ -148,9 +83,7 @@ $_ = 21;
double();
is( $_, 42, '$_ is modifiable' );
{
- BEGIN { $SIG{__WARN__} = sub {} }
my $_ = 22;
- BEGIN { $SIG{__WARN__} = undef }
double();
is( $_, 44, 'my $_ is modifiable' );
}
diff --git a/gnu/usr.bin/perl/t/lib/Cname.pm b/gnu/usr.bin/perl/t/lib/Cname.pm
index 562f59ae600..d4b8a9ea4dd 100644
--- a/gnu/usr.bin/perl/t/lib/Cname.pm
+++ b/gnu/usr.bin/perl/t/lib/Cname.pm
@@ -4,7 +4,6 @@ our $Evil='A';
sub translator {
my $str = shift;
if ( $str eq 'EVIL' ) {
- # Returns A first time, AB second, ABC third ... A-ZA the 27th time.
(my $c=substr("A".$Evil,-1))++;
my $r=$Evil;
$Evil.=$c;
@@ -13,25 +12,6 @@ sub translator {
if ( $str eq 'EMPTY-STR') {
return "";
}
- if ( $str eq 'NULL') {
- return "\0";
- }
- if ( $str eq 'LONG-STR') {
- return 'A' x 255;
- }
- # Should exceed limit for regex \N bytes in a sequence. Anyway it will if
- # UCHAR_MAX is 255.
- if ( $str eq 'TOO-LONG-STR') {
- return 'A' x 256;
- }
- if ($str eq 'MALFORMED') {
- $str = "\xDF\xDFabc";
- utf8::upgrade($str);
-
- # Create a malformed in first and second characters.
- $str =~ s/^\C/A/;
- $str =~ s/^(\C\C)\C/$1A/;
- }
return $str;
}
diff --git a/gnu/usr.bin/perl/t/lib/common.pl b/gnu/usr.bin/perl/t/lib/common.pl
index 4ab00b1f503..36d45f3c99a 100644
--- a/gnu/usr.bin/perl/t/lib/common.pl
+++ b/gnu/usr.bin/perl/t/lib/common.pl
@@ -1,9 +1,4 @@
-# This code is used by lib/charnames.t, lib/croak.t, lib/feature.t,
-# lib/subs.t, lib/strict.t and lib/warnings.t
-#
-# On input, $::local_tests is the number of tests in the caller; or
-# 'no_plan' if unknown, in which case it is the caller's responsibility
-# to call cur_test() to find out how many this executed
+# This code is used by lib/warnings.t and lib/feature.t
BEGIN {
require './test.pl';
@@ -11,49 +6,221 @@ BEGIN {
use Config;
use File::Path;
-use File::Spec::Functions qw(catfile curdir rel2abs);
+use File::Spec::Functions;
use strict;
use warnings;
-my (undef, $file) = caller;
-my ($pragma_name) = $file =~ /([A-Za-z_0-9]+)\.t$/
- or die "Can't identify pragama to test from file name '$file'";
+our $pragma_name;
$| = 1;
-my @w_files;
+my $Is_MacOS = $^O eq 'MacOS';
+my $tmpfile = "tmp0000";
+1 while -e ++$tmpfile;
+END { 1 while unlink $tmpfile }
-if (@ARGV) {
- print "ARGV = [@ARGV]\n";
- @w_files = map { "./lib/$pragma_name/$_" } @ARGV;
-} else {
- @w_files = sort glob catfile(curdir(), "lib", $pragma_name, "*");
+my @prgs = () ;
+my @w_files = () ;
+
+if (@ARGV)
+ { print "ARGV = [@ARGV]\n" ;
+ if ($Is_MacOS) {
+ @w_files = map { s#^#:lib:$pragma_name:#; $_ } @ARGV
+ } else {
+ @w_files = map { s#^#./lib/$pragma_name/#; $_ } @ARGV
+ }
+ }
+else
+ { @w_files = sort glob(catfile(curdir(), "lib", $pragma_name, "*")) }
+
+my $files = 0;
+foreach my $file (@w_files) {
+
+ next if $file =~ /(~|\.orig|,v)$/;
+ next if $file =~ /perlio$/ && !(find PerlIO::Layer 'perlio');
+ next if -d $file;
+
+ open F, "<$file" or die "Cannot open $file: $!\n" ;
+ my $line = 0;
+ while (<F>) {
+ $line++;
+ last if /^__END__/ ;
+ }
+
+ {
+ local $/ = undef;
+ $files++;
+ @prgs = (@prgs, $file, split "\n########\n", <F>) ;
+ }
+ close F ;
}
-my ($tests, @prgs) = setup_multiple_progs(@w_files);
+undef $/;
-$^X = rel2abs($^X);
-@INC = map { rel2abs($_) } @INC;
-my $tempdir = tempfile;
+plan tests => (scalar(@prgs)-$files);
-mkdir $tempdir, 0700 or die "Can't mkdir '$tempdir': $!";
-chdir $tempdir or die die "Can't chdir '$tempdir': $!";
-my $cleanup = 1;
+for (@prgs){
+ unless (/\n/)
+ {
+ print "# From $_\n";
+ next;
+ }
+ my $switch = "";
+ my @temps = () ;
+ my @temp_path = () ;
+ if (s/^\s*-\w+//){
+ $switch = $&;
+ }
+ my($prog,$expected) = split(/\nEXPECT(?:\n|$)/, $_, 2);
+
+ my ($todo, $todo_reason);
+ $todo = $prog =~ s/^#\s*TODO\s*(.*)\n//m and $todo_reason = $1;
+ # If the TODO reason starts ? then it's taken as a code snippet to evaluate
+ # This provides the flexibility to have conditional TODOs
+ if ($todo_reason && $todo_reason =~ s/^\?//) {
+ my $temp = eval $todo_reason;
+ if ($@) {
+ die "# In TODO code reason:\n# $todo_reason\n$@";
+ }
+ $todo_reason = $temp;
+ }
+ if ( $prog =~ /--FILE--/) {
+ my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ;
+ shift @files ;
+ die "Internal error: test $_ didn't split into pairs, got " .
+ scalar(@files) . "[" . join("%%%%", @files) ."]\n"
+ if @files % 2 ;
+ while (@files > 2) {
+ my $filename = shift @files ;
+ my $code = shift @files ;
+ push @temps, $filename ;
+ if ($filename =~ m#(.*)/#) {
+ mkpath($1);
+ push(@temp_path, $1);
+ }
+ open F, ">$filename" or die "Cannot open $filename: $!\n" ;
+ print F $code ;
+ close F or die "Cannot close $filename: $!\n";
+ }
+ shift @files ;
+ $prog = shift @files ;
+ }
+
+ # fix up some paths
+ if ($Is_MacOS) {
+ $prog =~ s|require "./abc(d)?";|require ":abc$1";|g;
+ $prog =~ s|"\."|":"|g;
+ }
+
+ open TEST, ">$tmpfile" or die "Cannot open >$tmpfile: $!";
+ print TEST q{
+ BEGIN {
+ open(STDERR, ">&STDOUT")
+ or die "Can't dup STDOUT->STDERR: $!;";
+ }
+ };
+ print TEST "\n#line 1\n"; # So the line numbers don't get messed up.
+ print TEST $prog,"\n";
+ close TEST or die "Cannot close $tmpfile: $!";
+ my $results = runperl( switches => [$switch], stderr => 1, progfile => $tmpfile );
+ my $status = $?;
+ $results =~ s/\n+$//;
+ # allow expected output to be written as if $prog is on STDIN
+ $results =~ s/tmp\d+/-/g;
+ if ($^O eq 'VMS') {
+ # some tests will trigger VMS messages that won't be expected
+ $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//;
+
+ # pipes double these sometimes
+ $results =~ s/\n\n/\n/g;
+ }
+# bison says 'parse error' instead of 'syntax error',
+# various yaccs may or may not capitalize 'syntax'.
+ $results =~ s/^(syntax|parse) error/syntax error/mig;
+ # allow all tests to run when there are leaks
+ $results =~ s/Scalars leaked: \d+\n//g;
-END {
- if ($cleanup) {
- chdir '..' or die "Couldn't chdir .. for cleanup: $!";
- rmtree($tempdir);
+ # fix up some paths
+ if ($Is_MacOS) {
+ $results =~ s|:abc\.pm\b|abc.pm|g;
+ $results =~ s|:abc(d)?\b|./abc$1|g;
}
+
+ $expected =~ s/\n+$//;
+ my $prefix = ($results =~ s#^PREFIX(\n|$)##) ;
+ # any special options? (OPTIONS foo bar zap)
+ my $option_regex = 0;
+ my $option_random = 0;
+ if ($expected =~ s/^OPTIONS? (.+)\n//) {
+ foreach my $option (split(' ', $1)) {
+ if ($option eq 'regex') { # allow regular expressions
+ $option_regex = 1;
+ }
+ elsif ($option eq 'random') { # all lines match, but in any order
+ $option_random = 1;
+ }
+ else {
+ die "$0: Unknown OPTION '$option'\n";
+ }
+ }
+ }
+ die "$0: can't have OPTION regex and random\n"
+ if $option_regex + $option_random > 1;
+ my $ok = 0;
+ if ($results =~ s/^SKIPPED\n//) {
+ print "$results\n" ;
+ $ok = 1;
+ }
+ elsif ($option_random) {
+ $ok = randomMatch($results, $expected);
+ }
+ elsif ($option_regex) {
+ $ok = $results =~ /^$expected/;
+ }
+ elsif ($prefix) {
+ $ok = $results =~ /^\Q$expected/;
+ }
+ else {
+ $ok = $results eq $expected;
+ }
+
+ print_err_line( $switch, $prog, $expected, $results, $todo ) unless $ok;
+
+ our $TODO = $todo ? $todo_reason : 0;
+ ok($ok);
+
+ foreach (@temps)
+ { unlink $_ if $_ }
+ foreach (@temp_path)
+ { rmtree $_ if -d $_ }
}
-if ($::local_tests && $::local_tests =~ /\D/) {
- # If input is 'no_plan', pass it on unchanged
- plan $::local_tests;
-} else {
- plan $tests + ($::local_tests || 0);
+sub randomMatch
+{
+ my $got = shift ;
+ my $expected = shift;
+
+ my @got = sort split "\n", $got ;
+ my @expected = sort split "\n", $expected ;
+
+ return "@got" eq "@expected";
+
}
-run_multiple_progs('../..', @prgs);
+sub print_err_line {
+ my($switch, $prog, $expected, $results, $todo) = @_;
+ my $err_line = "PROG: $switch\n$prog\n" .
+ "EXPECTED:\n$expected\n" .
+ "GOT:\n$results\n";
+ if ($todo) {
+ $err_line =~ s/^/# /mg;
+ print $err_line; # Harness can't filter it out from STDERR.
+ }
+ else {
+ print STDERR $err_line;
+ }
+
+ return 1;
+}
1;
diff --git a/gnu/usr.bin/perl/t/lib/feature/implicit b/gnu/usr.bin/perl/t/lib/feature/implicit
index a741421e7d3..0632770401c 100644
--- a/gnu/usr.bin/perl/t/lib/feature/implicit
+++ b/gnu/usr.bin/perl/t/lib/feature/implicit
@@ -21,10 +21,16 @@ Helloworld
########
# VERSION requirement, decimal notation
use 5.009005;
-say "Helloworld";
+say defined $INC{"feature.pm"} ? "Helloworld" : "Good bye";
EXPECT
Helloworld
########
+# VERSION requirement, doesn't load anything for < 5.9.5
+use 5.8.8;
+print "<".$INC{"feature.pm"}.">\n";
+EXPECT
+<>
+########
# VERSION requirement, doesn't load anything with require
require 5.9.5;
print "<".$INC{"feature.pm"}.">\n";
@@ -54,71 +60,3 @@ BEGIN {
}
EXPECT
Helloworld
-########
-# no implicit features with 'no'
-eval "no " . ($]+1); print $@;
-EXPECT
-########
-# lower version after higher version
-sub evalbytes { print "evalbytes sub\n" }
-sub say { print "say sub\n" }
-use 5.015;
-evalbytes "say 'yes'";
-use 5.014;
-evalbytes;
-use 5;
-say "no"
-EXPECT
-yes
-evalbytes sub
-say sub
-########
-# No $[ under 5.15
-# SKIP ? not defined DynaLoader::boot_DynaLoader
-use v5.14;
-no warnings 'deprecated';
-$[ = 1;
-print qw[a b c][2], "\n";
-use v5.15;
-print qw[a b c][2], "\n";
-EXPECT
-b
-c
-########
-# $[ under < 5.10
-# SKIP ? not defined DynaLoader::boot_DynaLoader
-use feature 'say'; # make sure it is loaded and modifies %^H; we are test-
-use v5.8.8; # ing to make sure it does not disable $[
-no warnings 'deprecated';
-$[ = 1;
-print qw[a b c][2], "\n";
-EXPECT
-b
-########
-# $[ under < 5.10 after use v5.15
-# SKIP ? not defined DynaLoader::boot_DynaLoader
-use v5.15;
-use v5.8.8;
-no warnings 'deprecated';
-$[ = 1;
-print qw[a b c][2], "\n";
-EXPECT
-b
-########
-# Implicit unicode_string feature
-use v5.14;
-print 'ss' =~ /\xdf/i ? "ok\n" : "nok\n";
-use v5.8.8;
-print 'ss' =~ /\xdf/i ? "ok\n" : "nok\n";
-EXPECT
-ok
-nok
-########
-# Implicit unicode_eval feature
-use v5.15;
-print eval "use utf8; q|\xc5\xbf|" eq "\xc5\xbf" ? "ok\n" : "nok\n";
-use v5.8.8;
-print eval "use utf8; q|\xc5\xbf|" eq "\x{17f}" ? "ok\n" : "nok\n";
-EXPECT
-ok
-ok
diff --git a/gnu/usr.bin/perl/t/lib/mypragma.t b/gnu/usr.bin/perl/t/lib/mypragma.t
index 0464897ebc1..48e9865384a 100644
--- a/gnu/usr.bin/perl/t/lib/mypragma.t
+++ b/gnu/usr.bin/perl/t/lib/mypragma.t
@@ -1,14 +1,14 @@
#!./perl
-use strict;
-use warnings;
-
BEGIN {
- unshift @INC, 'lib';
- require './test.pl';
- plan(tests => 14);
+ chdir 't';
+ @INC = ('../lib', 'lib');
}
+use strict;
+use warnings;
+use Test::More tests => 13;
+
use mypragma (); # don't enable this pragma yet
BEGIN {
@@ -22,10 +22,7 @@ is(mypragma::in_effect(), undef, "pragma not in effect yet");
or die $@;
use mypragma;
- use Sans_mypragma;
is(mypragma::in_effect(), 42, "pragma is in effect within this block");
- is(Sans_mypragma::affected(), undef,
- "pragma not in effect outside this file");
eval qq{is(mypragma::in_effect(), 42,
"pragma is in effect within this eval"); 1} or die $@;
diff --git a/gnu/usr.bin/perl/t/lib/no_load.t b/gnu/usr.bin/perl/t/lib/no_load.t
index 39f0dc6816e..3f10200d5bf 100644
--- a/gnu/usr.bin/perl/t/lib/no_load.t
+++ b/gnu/usr.bin/perl/t/lib/no_load.t
@@ -16,9 +16,16 @@ require "test.pl";
#
# Format: [Module-that-should-not-be-loaded => modules to test]
#
+my @TESTS = (
+ [Carp => qw [warnings Exporter]],
+);
-foreach my $test ([Carp => qw(warnings Exporter)],
- ) {
+my $count = 0;
+$count += @$_ - 1 for @TESTS;
+
+print "1..$count\n";
+
+foreach my $test (@TESTS) {
my ($exclude, @modules) = @$test;
foreach my $module (@modules) {
@@ -26,8 +33,9 @@ foreach my $test ([Carp => qw(warnings Exporter)],
use $module;
print exists \$INC {'$exclude.pm'} ? "not ok" : "ok";
--
- fresh_perl_is ($prog, "ok", {}, "$module does not load $exclude");
+ fresh_perl_is ($prog, "ok", "", "$module does not load $exclude");
}
}
-done_testing();
+
+__END__
diff --git a/gnu/usr.bin/perl/t/lib/proxy_constant_subs.t b/gnu/usr.bin/perl/t/lib/proxy_constant_subs.t
index 9e73006fce5..4af73d38c42 100644
--- a/gnu/usr.bin/perl/t/lib/proxy_constant_subs.t
+++ b/gnu/usr.bin/perl/t/lib/proxy_constant_subs.t
@@ -1,17 +1,26 @@
my @symbols;
BEGIN {
- require './test.pl';
- skip_all_without_dynamic_extension($_) foreach qw(B Fcntl);
- # S_IFMT is a real subroutine, and acts as control
+ chdir 't';
+ @INC = '../lib';
+ require Config;
+ if (($Config::Config{'extensions'} !~ /\bB\b/) ){
+ print "1..0 # Skip -- Perl configured without B module\n";
+ exit 0;
+ }
+ if ($Config::Config{'extensions'} !~ /\bPOSIX\b/) {
+ print "1..0 # Skip -- Perl configured without POSIX\n";
+ exit 0;
+ }
+ # errno is a real subroutine, and acts as control
# SEEK_SET is a proxy constant subroutine.
- @symbols = qw(S_IFMT SEEK_SET);
+ @symbols = qw(errno SEEK_SET);
}
use strict;
use warnings;
-plan(4 * @symbols);
+use Test::More tests => 4 * @symbols;
use B qw(svref_2object GVf_IMPORTED_CV);
-use Fcntl @symbols;
+use POSIX @symbols;
# GVf_IMPORTED_CV should not be set on the original, but should be set on the
# imported GV.
@@ -20,13 +29,13 @@ foreach my $symbol (@symbols) {
my ($ps, $ms);
{
no strict 'refs';
- $ps = svref_2object(\*{"Fcntl::$symbol"});
+ $ps = svref_2object(\*{"POSIX::$symbol"});
$ms = svref_2object(\*{"::$symbol"});
}
- object_ok($ps, 'B::GV');
+ isa_ok($ps, 'B::GV');
is($ps->GvFLAGS() & GVf_IMPORTED_CV, 0,
"GVf_IMPORTED_CV not set on original");
- object_ok($ms, 'B::GV');
+ isa_ok($ms, 'B::GV');
is($ms->GvFLAGS() & GVf_IMPORTED_CV, GVf_IMPORTED_CV,
"GVf_IMPORTED_CV set on imported GV");
}
diff --git a/gnu/usr.bin/perl/t/lib/warnings/9uninit b/gnu/usr.bin/perl/t/lib/warnings/9uninit
index d9e5b9bed73..e2e6ef9fecd 100644
--- a/gnu/usr.bin/perl/t/lib/warnings/9uninit
+++ b/gnu/usr.bin/perl/t/lib/warnings/9uninit
@@ -33,19 +33,6 @@ Use of uninitialized value $m2 in addition (+) at - line 6.
Use of uninitialized value $m1 in addition (+) at - line 6.
########
use warnings 'uninitialized';
-use utf8;
-use open qw( :utf8 :std );
-
-$v = $à1 + 10;
-$v = 22 + $a2;
-$v = $à1 + $a2;
-EXPECT
-Use of uninitialized value $à1 in addition (+) at - line 5.
-Use of uninitialized value $a2 in addition (+) at - line 6.
-Use of uninitialized value $a2 in addition (+) at - line 7.
-Use of uninitialized value $à1 in addition (+) at - line 7.
-########
-use warnings 'uninitialized';
my ($m1, $v);
our ($g1, $g2);
@@ -295,13 +282,13 @@ print STDERR $ga[1000];
print STDERR $m1, $g1, $ga[1],$m2;
print STDERR "", $ga[1],"";
EXPECT
-Use of uninitialized value in print at - line 5.
-Use of uninitialized value in print at - line 6.
+Use of uninitialized value $ga[1000] in print at - line 5.
+Use of uninitialized value $ga[1000] in print at - line 6.
Use of uninitialized value $m1 in print at - line 7.
Use of uninitialized value $g1 in print at - line 7.
Use of uninitialized value in print at - line 7.
Use of uninitialized value $m2 in print at - line 7.
-Use of uninitialized value in print at - line 8.
+Use of uninitialized value $ga[1] in print at - line 8.
########
use warnings 'uninitialized';
my ($m1);
@@ -309,11 +296,9 @@ our ($g1);
close $m1; # exercises rv2gv
close $g1; # exercises rv2gv
-close undef; # exercises rv2gv
EXPECT
Use of uninitialized value $m1 in ref-to-glob cast at - line 5.
Use of uninitialized value $g1 in ref-to-glob cast at - line 6.
-Use of uninitialized value in ref-to-glob cast at - line 7.
########
use warnings 'uninitialized';
my ($m1, $m2, $v);
@@ -395,8 +380,8 @@ my ($s5,$s6); chop ($s5,$s6);
EXPECT
Use of uninitialized value $s1 in scalar chomp at - line 3.
Use of uninitialized value $s2 in scalar chop at - line 4.
-Use of uninitialized value $s3 in chomp at - line 5.
Use of uninitialized value $s4 in chomp at - line 5.
+Use of uninitialized value $s3 in chomp at - line 5.
Use of uninitialized value $s5 in chop at - line 6.
Use of uninitialized value $s6 in chop at - line 6.
########
@@ -409,9 +394,10 @@ chomp $x; chop $x;
my $y;
chomp ($x, $y); chop ($x, $y);
EXPECT
-Use of uninitialized value $m1 in scalar assignment at - line 4.
-Use of uninitialized value $m1 in scalar assignment at - line 4.
-Setting $/ to a reference to zero as a form of slurp is deprecated, treating as undef at - line 4.
+Use of uninitialized value ${$/} in scalar chomp at - line 6.
+Use of uninitialized value ${$/} in chomp at - line 8.
+Use of uninitialized value $y in chomp at - line 8.
+Use of uninitialized value ${$/} in chomp at - line 8.
Use of uninitialized value $y in chop at - line 8.
########
use warnings 'uninitialized';
@@ -460,83 +446,6 @@ Use of uninitialized value $m1 in exists at - line 7.
Use of uninitialized value $g1 in exists at - line 8.
########
use warnings 'uninitialized';
-my ($m1, $m2);
-my ($v, @a);
-my ($t, $u) = (1, 1);
-
-local $.;
-
-@ma = (1 .. 2);
-@ma = ($t .. 2);
-@ma = ($m1 .. 2);
-@ma = (1 .. $u);
-@ma = (1 .. $m2);
-
-@ma = (1 ... 2);
-@ma = ($t ... 2);
-@ma = ($m1 ... 2);
-@ma = (1 ... $u);
-@ma = (1 ... $m2);
-
-$v = (1 .. 2);
-$v = ($t .. 2);
-$v = ($m1 .. 2);
-$v = (1 .. $u);
-$v = (1 .. $m2);
-
-$v = (1 ... 2);
-$v = ($t ... 2);
-$v = ($m1 ... 2);
-$v = (1 ... $u);
-$v = (1 ... $m2);
-EXPECT
-Use of uninitialized value $m1 in range (or flop) at - line 10.
-Use of uninitialized value $m2 in range (or flop) at - line 12.
-Use of uninitialized value $m1 in range (or flop) at - line 16.
-Use of uninitialized value $m2 in range (or flop) at - line 18.
-Use of uninitialized value $. in range (or flip) at - line 20.
-Use of uninitialized value $. in range (or flop) at - line 21.
-Use of uninitialized value $. in range (or flip) at - line 23.
-Use of uninitialized value $. in range (or flip) at - line 24.
-Use of uninitialized value $. in range (or flip) at - line 26.
-Use of uninitialized value $. in range (or flip) at - line 29.
-Use of uninitialized value $. in range (or flip) at - line 30.
-########
-use warnings 'uninitialized';
-my ($m1, $m2);
-my ($v, @a);
-my ($t, $u) = (1, 1);
-
-@ma = ($t .. $u);
-@ma = ($m1 .. $u);
-@ma = ($t .. $m2);
-@ma = ($m1 .. $m2);
-
-@ma = ($t ... $u);
-@ma = ($m1 ... $u);
-@ma = ($t ... $m2);
-@ma = ($m1 ... $m2);
-
-$v = ($t .. $u);
-$v = ($m1 .. $u);
-$v = ($t .. $m2);
-$v = ($m1 .. $m2);
-
-$v = ($t ... $u);
-$v = ($m1 ... $u);
-$v = ($t ... $m2);
-$v = ($m1 ... $m2);
-EXPECT
-Use of uninitialized value $m1 in range (or flop) at - line 7.
-Use of uninitialized value $m2 in range (or flop) at - line 8.
-Use of uninitialized value $m1 in range (or flop) at - line 9.
-Use of uninitialized value $m2 in range (or flop) at - line 9.
-Use of uninitialized value $m1 in range (or flop) at - line 12.
-Use of uninitialized value $m2 in range (or flop) at - line 13.
-Use of uninitialized value $m1 in range (or flop) at - line 14.
-Use of uninitialized value $m2 in range (or flop) at - line 14.
-########
-use warnings 'uninitialized';
my ($m1, $v);
our ($g1);
@@ -631,19 +540,6 @@ my @sort;
@sort = sort {$a <=> $b} $m1, $g1;
sub sortf {$a-1 <=> $b-1};
@sort = sort &sortf, $m1, $g1;
-@sort = sort { undef } 1, 2;
-sub frobnicate($$) { undef }
-@sort = sort frobnicate 1, 2;
-@sort = sort pyfg 1, 2;
-@sort = sort pyfgc 1, 2;
-no warnings;
-sub pyfg { undef }
-sub pyfgc($$) { undef }
-use warnings;
-sub dog {}
-sub dogwood($$) {}
-@sort = sort dog 1,2;
-@sort = sort dogwood 1,2;
EXPECT
Use of uninitialized value $m1 in sort at - line 6.
Use of uninitialized value $g1 in sort at - line 6.
@@ -661,28 +557,6 @@ Use of uninitialized value $m1 in sort at - line 9.
Use of uninitialized value $m1 in sort at - line 9.
Use of uninitialized value $g1 in sort at - line 9.
Use of uninitialized value $g1 in sort at - line 9.
-Use of uninitialized value in sort at - line 10.
-Use of uninitialized value in sort at - line 12.
-Use of uninitialized value in sort at - line 13.
-Use of uninitialized value in sort at - line 14.
-Use of uninitialized value in sort at - line 21.
-Use of uninitialized value in sort at - line 22.
-########
-my $nan = sin 9**9**9;
-if ($nan == $nan) {
- print <<EOM ;
-SKIPPED
-# No nan support
-EOM
- exit ;
-}
-use warnings 'uninitialized';
-# The optimised {$a<=>$b} case should behave the same way as unoptimised.
-@sort = sort { ($a)[0] <=> $b } 1, $nan;
-@sort = sort { $a <=> $b } 1, $nan;
-EXPECT
-Use of uninitialized value in sort at - line 11.
-Use of uninitialized value in sort at - line 12.
########
use warnings 'uninitialized';
my ($m1, $m2, $v);
@@ -737,23 +611,6 @@ Use of uninitialized value $g1 in subtraction (-) at - line 20.
Use of uninitialized value $m1 in subtraction (-) at - line 20.
########
use warnings 'uninitialized';
-sub TIESCALAR{bless[]}
-sub FETCH { undef }
-
-tie my $m1, "";
-my $v;
-$v = $m1 + $m1;
-$v = $m1 - $m1;
-no warnings;
-$v = $m1 + $m1;
-$v = $m1 - $m1;
-EXPECT
-Use of uninitialized value $m1 in addition (+) at - line 7.
-Use of uninitialized value $m1 in addition (+) at - line 7.
-Use of uninitialized value $m1 in subtraction (-) at - line 8.
-Use of uninitialized value $m1 in subtraction (-) at - line 8.
-########
-use warnings 'uninitialized';
my ($m1, $v);
our ($g1);
@@ -784,7 +641,6 @@ s/$m1/z/; undef $_;
s//$g1/; undef $_;
s/$m1/$g1/; undef $_;
tr/x/y/; undef $_;
-tr/x/y/r; undef $_;
my $_;
/y/;
@@ -795,7 +651,6 @@ s/$m1/z/; undef $_;
s//$g1/; undef $_;
s/$m1/$g1/; undef $_;
tr/x/y/; undef $_;
-tr/x/y/r; undef $_;
$g2 =~ /y/;
$g2 =~ /$m1/;
@@ -805,7 +660,6 @@ $g2 =~ s/$m1/z/; undef $g2;
$g2 =~ s//$g1/; undef $g2;
$g2 =~ s/$m1/$g1/; undef $g2;
$g2 =~ tr/x/y/; undef $g2; # XXX can't extract var name yet
-$g2 =~ tr/x/y/r; undef $g2; # XXX can't extract var name yet
my $foo = "abc";
$foo =~ /$m1/;
@@ -815,11 +669,7 @@ $foo =~ s/$m1/z/;
$foo =~ s//$g1/;
$foo =~ s/$m1/$g1/;
$foo =~ s/./$m1/e;
-undef $g1;
-$m1 = '$g1';
-$foo =~ s//$m1/ee;
EXPECT
-Use of my $_ is experimental at - line 16.
Use of uninitialized value $_ in pattern match (m//) at - line 5.
Use of uninitialized value $m1 in regexp compilation at - line 6.
Use of uninitialized value $_ in pattern match (m//) at - line 6.
@@ -830,58 +680,57 @@ Use of uninitialized value $m1 in regexp compilation at - line 10.
Use of uninitialized value $_ in substitution (s///) at - line 10.
Use of uninitialized value $_ in substitution (s///) at - line 10.
Use of uninitialized value $_ in substitution (s///) at - line 11.
+Use of uninitialized value $g1 in substitution (s///) at - line 11.
Use of uninitialized value $_ in substitution (s///) at - line 11.
-Use of uninitialized value $g1 in substitution iterator at - line 11.
+Use of uninitialized value $g1 in substitution (s///) at - line 11.
Use of uninitialized value $m1 in regexp compilation at - line 12.
Use of uninitialized value $_ in substitution (s///) at - line 12.
Use of uninitialized value $_ in substitution (s///) at - line 12.
Use of uninitialized value $g1 in substitution iterator at - line 12.
Use of uninitialized value $_ in transliteration (tr///) at - line 13.
-Use of uninitialized value $_ in transliteration (tr///) at - line 14.
+Use of uninitialized value $_ in pattern match (m//) at - line 16.
+Use of uninitialized value $m1 in regexp compilation at - line 17.
Use of uninitialized value $_ in pattern match (m//) at - line 17.
-Use of uninitialized value $m1 in regexp compilation at - line 18.
+Use of uninitialized value $g1 in regexp compilation at - line 18.
Use of uninitialized value $_ in pattern match (m//) at - line 18.
-Use of uninitialized value $g1 in regexp compilation at - line 19.
-Use of uninitialized value $_ in pattern match (m//) at - line 19.
+Use of uninitialized value $_ in substitution (s///) at - line 19.
+Use of uninitialized value $m1 in regexp compilation at - line 20.
+Use of uninitialized value $_ in substitution (s///) at - line 20.
Use of uninitialized value $_ in substitution (s///) at - line 20.
-Use of uninitialized value $m1 in regexp compilation at - line 21.
Use of uninitialized value $_ in substitution (s///) at - line 21.
+Use of uninitialized value $g1 in substitution (s///) at - line 21.
Use of uninitialized value $_ in substitution (s///) at - line 21.
+Use of uninitialized value $g1 in substitution (s///) at - line 21.
+Use of uninitialized value $m1 in regexp compilation at - line 22.
Use of uninitialized value $_ in substitution (s///) at - line 22.
Use of uninitialized value $_ in substitution (s///) at - line 22.
Use of uninitialized value $g1 in substitution iterator at - line 22.
-Use of uninitialized value $m1 in regexp compilation at - line 23.
-Use of uninitialized value $_ in substitution (s///) at - line 23.
-Use of uninitialized value $_ in substitution (s///) at - line 23.
-Use of uninitialized value $g1 in substitution iterator at - line 23.
-Use of uninitialized value $_ in transliteration (tr///) at - line 24.
-Use of uninitialized value $_ in transliteration (tr///) at - line 25.
+Use of uninitialized value $_ in transliteration (tr///) at - line 23.
+Use of uninitialized value $g2 in pattern match (m//) at - line 25.
+Use of uninitialized value $m1 in regexp compilation at - line 26.
+Use of uninitialized value $g2 in pattern match (m//) at - line 26.
+Use of uninitialized value $g1 in regexp compilation at - line 27.
Use of uninitialized value $g2 in pattern match (m//) at - line 27.
-Use of uninitialized value $m1 in regexp compilation at - line 28.
-Use of uninitialized value $g2 in pattern match (m//) at - line 28.
-Use of uninitialized value $g1 in regexp compilation at - line 29.
-Use of uninitialized value $g2 in pattern match (m//) at - line 29.
+Use of uninitialized value $g2 in substitution (s///) at - line 28.
+Use of uninitialized value $m1 in regexp compilation at - line 29.
+Use of uninitialized value $g2 in substitution (s///) at - line 29.
+Use of uninitialized value $g2 in substitution (s///) at - line 29.
Use of uninitialized value $g2 in substitution (s///) at - line 30.
+Use of uninitialized value $g1 in substitution (s///) at - line 30.
+Use of uninitialized value $g2 in substitution (s///) at - line 30.
+Use of uninitialized value $g1 in substitution (s///) at - line 30.
Use of uninitialized value $m1 in regexp compilation at - line 31.
Use of uninitialized value $g2 in substitution (s///) at - line 31.
Use of uninitialized value $g2 in substitution (s///) at - line 31.
-Use of uninitialized value $g2 in substitution (s///) at - line 32.
-Use of uninitialized value $g2 in substitution (s///) at - line 32.
-Use of uninitialized value $g1 in substitution iterator at - line 32.
-Use of uninitialized value $m1 in regexp compilation at - line 33.
-Use of uninitialized value $g2 in substitution (s///) at - line 33.
-Use of uninitialized value $g2 in substitution (s///) at - line 33.
-Use of uninitialized value $g1 in substitution iterator at - line 33.
-Use of uninitialized value in transliteration (tr///) at - line 34.
-Use of uninitialized value in transliteration (tr///) at - line 35.
+Use of uninitialized value $g1 in substitution iterator at - line 31.
+Use of uninitialized value in transliteration (tr///) at - line 32.
+Use of uninitialized value $m1 in regexp compilation at - line 35.
+Use of uninitialized value $g1 in regexp compilation at - line 36.
Use of uninitialized value $m1 in regexp compilation at - line 38.
-Use of uninitialized value $g1 in regexp compilation at - line 39.
-Use of uninitialized value $m1 in regexp compilation at - line 41.
-Use of uninitialized value $g1 in substitution iterator at - line 42.
-Use of uninitialized value $m1 in regexp compilation at - line 43.
-Use of uninitialized value $g1 in substitution iterator at - line 43.
-Use of uninitialized value $m1 in substitution (s///) at - line 44.
-Use of uninitialized value in substitution iterator at - line 47.
+Use of uninitialized value $g1 in substitution (s///) at - line 39.
+Use of uninitialized value $m1 in regexp compilation at - line 40.
+Use of uninitialized value $g1 in substitution iterator at - line 40.
+Use of uninitialized value $m1 in substitution iterator at - line 41.
########
use warnings 'uninitialized';
my ($m1);
@@ -977,8 +826,8 @@ $v = eval {log $m1};
$v = sqrt $m1;
$v = hex $m1;
$v = oct $m1;
-$v = oct;
-$v = length; # does not warn
+$v = length $m1;
+$v = length;
EXPECT
Use of uninitialized value $g1 in atan2 at - line 5.
Use of uninitialized value $m1 in atan2 at - line 5.
@@ -991,7 +840,8 @@ Use of uninitialized value $m1 in log at - line 11.
Use of uninitialized value $m1 in sqrt at - line 12.
Use of uninitialized value $m1 in hex at - line 13.
Use of uninitialized value $m1 in oct at - line 14.
-Use of uninitialized value $_ in oct at - line 15.
+Use of uninitialized value $m1 in length at - line 15.
+Use of uninitialized value $_ in length at - line 16.
########
use warnings 'uninitialized';
my ($m1, $v);
@@ -1016,22 +866,24 @@ Use of uninitialized value $m1 in substr at - line 5.
Use of uninitialized value $m2 in substr at - line 6.
Use of uninitialized value $g1 in substr at - line 6.
Use of uninitialized value $m1 in substr at - line 6.
+Use of uninitialized value $g2 in substr at - line 7.
Use of uninitialized value $m2 in substr at - line 7.
Use of uninitialized value $g1 in substr at - line 7.
-Use of uninitialized value $g2 in substr at - line 7.
+Use of uninitialized value $m1 in substr at - line 7.
Use of uninitialized value $m1 in substr at - line 7.
Use of uninitialized value $g1 in substr at - line 8.
-Use of uninitialized value $g2 in substr at - line 8.
Use of uninitialized value $m1 in substr at - line 8.
+Use of uninitialized value in scalar assignment at - line 8.
Use of uninitialized value $m2 in substr at - line 9.
Use of uninitialized value $g1 in substr at - line 9.
-Use of uninitialized value $g2 in substr at - line 9.
Use of uninitialized value $m1 in substr at - line 9.
+Use of uninitialized value in scalar assignment at - line 9.
Use of uninitialized value $m2 in vec at - line 11.
Use of uninitialized value $g1 in vec at - line 11.
Use of uninitialized value $m1 in vec at - line 11.
Use of uninitialized value $m2 in vec at - line 12.
Use of uninitialized value $g1 in vec at - line 12.
+Use of uninitialized value $m1 in vec at - line 12.
Use of uninitialized value $m1 in index at - line 14.
Use of uninitialized value $m2 in index at - line 14.
Use of uninitialized value $g1 in index at - line 15.
@@ -1063,7 +915,6 @@ Use of uninitialized value $m2 in formline at - line 8.
Use of uninitialized value $g1 in formline at - line 8.
Use of uninitialized value $g2 in formline at - line 8.
########
-# SKIP ? !$Config{d_crypt}
use warnings 'uninitialized';
my ($m1, $v);
our ($g1);
@@ -1075,6 +926,7 @@ $v = ord $m1;
$v = chr;
$v = chr $m1;
+# XXX these functions don't warn!
$v = ucfirst;
$v = ucfirst $m1;
$v = lcfirst;
@@ -1093,16 +945,8 @@ Use of uninitialized value $_ in ord at - line 7.
Use of uninitialized value $m1 in ord at - line 8.
Use of uninitialized value $_ in chr at - line 9.
Use of uninitialized value $m1 in chr at - line 10.
-Use of uninitialized value $_ in ucfirst at - line 12.
-Use of uninitialized value $m1 in ucfirst at - line 13.
-Use of uninitialized value $_ in lcfirst at - line 14.
-Use of uninitialized value $m1 in lcfirst at - line 15.
-Use of uninitialized value $_ in uc at - line 16.
-Use of uninitialized value $m1 in uc at - line 17.
-Use of uninitialized value $_ in lc at - line 18.
-Use of uninitialized value $m1 in lc at - line 19.
-Use of uninitialized value $_ in quotemeta at - line 21.
-Use of uninitialized value $m1 in quotemeta at - line 22.
+Use of uninitialized value $_ in quotemeta at - line 22.
+Use of uninitialized value $m1 in quotemeta at - line 23.
########
use warnings 'uninitialized';
my ($m1, $v1, $v2, $v3, $v4);
@@ -1141,8 +985,8 @@ our @foo3=(1,undef); chop @foo3;
my @foo4=(1,undef); chop @foo4;
our @foo5=(1,undef); $v = sprintf "%s%s",@foo5;
my @foo6=(1,undef); $v = sprintf "%s%s",@foo6;
-our %foo7=('foo'=>'bar','baz'=>undef); $v = sprintf "%s%s%s%s",%foo7;
-my %foo8=('foo'=>'bar','baz'=>undef); $v = sprintf "%s%s%s%s",%foo8;
+our %foo7=('foo'=>'bar','baz'=>undef); $v = sprintf "%s%s",%foo7;
+my %foo8=('foo'=>'bar','baz'=>undef); $v = sprintf "%s%s",%foo8;
our @foo9 =(1,undef); $v = sprintf "%s%s%s%s",$m1,@foo9, $ma[2];
my @foo10=(1,undef); $v = sprintf "%s%s%s%s",$m2,@foo10,$ma[2];
our %foo11=('foo'=>'bar','baz'=>undef); $v = join '', %foo11;
@@ -1186,10 +1030,10 @@ use warnings 'uninitialized';
my ($v);
# check hash key is sanitised
-my %h = ("\0011\002\r\n\t\f\"\\\x{1234}abcdefghijklmnopqrstuvwxyz", undef);
+my %h = ("\0011\002\r\n\t\f\"\\abcdefghijklmnopqrstuvwxyz", undef);
$v = join '', %h;
EXPECT
-Use of uninitialized value $h{"\0011\2\r\n\t\f\"\\\x{1234}abcde"...} in join or string at - line 6.
+Use of uninitialized value $h{"\0011\2\r\n\t\f\"\\abcdefghijklm"...} in join or string at - line 6.
########
use warnings 'uninitialized';
my ($m1, $v);
@@ -1216,6 +1060,8 @@ reset $m1;
reset $g1;
EXPECT
Use of uninitialized value $m1 in subroutine dereference at - line 5.
+Use of uninitialized value $m1 in subroutine dereference at - line 5.
+Use of uninitialized value $g1 in subroutine dereference at - line 6.
Use of uninitialized value $g1 in subroutine dereference at - line 6.
Use of uninitialized value $m1 in splice at - line 9.
Use of uninitialized value $g1 in splice at - line 9.
@@ -1223,6 +1069,8 @@ Use of uninitialized value $m1 in splice at - line 10.
Use of uninitialized value $g1 in splice at - line 10.
Use of uninitialized value in addition (+) at - line 10.
Use of uninitialized value $m1 in method lookup at - line 13.
+Use of uninitialized value in subroutine entry at - line 15.
+Use of uninitialized value in subroutine entry at - line 16.
Use of uninitialized value $m1 in warn at - line 18.
Use of uninitialized value $g1 in warn at - line 18.
foo at - line 18.
@@ -1270,6 +1118,7 @@ Use of uninitialized value $m1 in sysopen at - line 16.
Use of uninitialized value $m1 in umask at - line 19.
Use of uninitialized value $g1 in umask at - line 20.
Use of uninitialized value $m1 in binmode at - line 23.
+Use of uninitialized value $m1 in binmode at - line 23.
########
use warnings 'uninitialized';
my ($m1);
@@ -1283,6 +1132,7 @@ eval { my $x; sysread $m1, $x, $g1 };
eval { my $x; sysread $m1, $x, $g1, $g2 };
EXPECT
Use of uninitialized value $m1 in tie at - line 5.
+Use of uninitialized value $m1 in tie at - line 5.
Use of uninitialized value $m1 in ref-to-glob cast at - line 7.
Use of uninitialized value $g1 in read at - line 7.
Use of uninitialized value $m1 in ref-to-glob cast at - line 8.
@@ -1311,15 +1161,15 @@ Use of uninitialized value $m2 in printf at - line 6.
Use of uninitialized value $g1 in printf at - line 6.
Use of uninitialized value $g2 in printf at - line 6.
0000
-Use of uninitialized value in printf at - line 7.
-Use of uninitialized value in printf at - line 8.
+Use of uninitialized value $ga[1000] in printf at - line 7.
+Use of uninitialized value $ga[1000] in printf at - line 8.
FOO1:
Use of uninitialized value $m1 in printf at - line 9.
Use of uninitialized value $g1 in printf at - line 9.
Use of uninitialized value in printf at - line 9.
Use of uninitialized value $m2 in printf at - line 9.
FOO2:
-Use of uninitialized value in printf at - line 10.
+Use of uninitialized value $ga[1] in printf at - line 10.
FOO3:XY
########
use warnings 'uninitialized';
@@ -1431,6 +1281,7 @@ Use of uninitialized value $m1 in -f at - line 27.
Use of uninitialized value $m1 in -d at - line 28.
Use of uninitialized value $m1 in -p at - line 29.
Use of uninitialized value $m1 in -l at - line 30.
+Use of uninitialized value $m1 in -l at - line 30.
Use of uninitialized value $m1 in -u at - line 31.
Use of uninitialized value $m1 in -g at - line 32.
Use of uninitialized value $m1 in -t at - line 34.
@@ -1448,15 +1299,13 @@ Use of uninitialized value $m1 in localtime at - line 5.
Use of uninitialized value $g1 in gmtime at - line 6.
########
use warnings 'uninitialized';
-my ($m1, $m2, $v);
+my ($m1, $v);
$v = eval;
$v = eval $m1;
-$m2 = q($m1); $v = 1 + eval $m2;
EXPECT
Use of uninitialized value $_ in eval "string" at - line 4.
Use of uninitialized value $m1 in eval "string" at - line 5.
-Use of uninitialized value in addition (+) at - line 6.
########
use warnings 'uninitialized';
my ($m1);
@@ -1464,626 +1313,3 @@ my ($m1);
exit $m1;
EXPECT
Use of uninitialized value $m1 in exit at - line 4.
-########
-use warnings 'uninitialized';
-my $undef;
-
-if ($undef == 3) {
-} elsif ($undef == 0) {
-}
-EXPECT
-Use of uninitialized value $undef in numeric eq (==) at - line 4.
-Use of uninitialized value $undef in numeric eq (==) at - line 5.
-########
-# TODO long standing bug - conditions of while loops
-use warnings;
-
-my $c;
-my $d = 1;
-while ($c == 0 && $d) {
- # a
- # few
- # blank
- # lines
- undef $d;
-}
-EXPECT
-Use of uninitialized value $c in numeric eq (==) at - line 5.
-Use of uninitialized value $c in numeric eq (==) at - line 5.
-########
-# TODO long standing bug - conditions of until loops
-use warnings;
-
-my $c;
-my $d;
-until ($c == 1) {
- # a
- # few
- # blank
- # lines
- $c = 1 if ++$d == 2;
-}
-EXPECT
-Use of uninitialized value $c in numeric eq (==) at - line 5.
-Use of uninitialized value $c in numeric eq (==) at - line 5.
-########
-# TODO long standing bug - conditions of for loops
-use warnings;
-
-my $c;
-my $d;
-for ($d = 1; $c == 0 && $d; ) {
- # a
- # few
- # blank
- # lines
- undef $d;
-}
-
-my $e;
-for ($d = 2; $d > 0; $e = !($c == 0)) {
- # a
- # few
- # blank
- # lines
- --$d;
-}
-EXPECT
-Use of uninitialized value $c in numeric eq (==) at - line 5.
-Use of uninitialized value $c in numeric eq (==) at - line 5.
-Use of uninitialized value $c in numeric eq (==) at - line 14.
-Use of uninitialized value $c in numeric eq (==) at - line 14.
-########
-# TODO long standing bug - more general variant of the above problem
-use warnings;
-my $undef;
-
-my $a = $undef + 1;
-my $b
- = $undef
- + 1;
-EXPECT
-Use of uninitialized value $undef in addition (+) at - line 4.
-Use of uninitialized value $undef in addition (+) at - line 7.
-########
-use warnings 'uninitialized';
-my ($r1, $r2);
-$_ = undef;
-$v = reverse;
-$v = reverse $r1;
-$v = reverse "abc", $r2, "def";
-EXPECT
-Use of uninitialized value in reverse at - line 4.
-Use of uninitialized value $r1 in reverse at - line 5.
-Use of uninitialized value $r2 in reverse at - line 6.
-########
-use warnings 'uninitialized';
-#
-# ops that can return undef for defined args
-# split into separate tests to diagnose the cause of daily build smoke
-#
-# *** `` not tested: Windows produces an error on STDERR
-# *** ditto qx()
-# *** pipe() not tested
-# *** ioctl not tested
-# *** socket not tested
-# *** socketpair not tested
-# *** bind not tested
-# *** connect not tested
-# *** listen not tested
-# *** shutdown not tested
-# *** setsockopt not tested
-# *** getpeername not tested
-# *** readdir not tested
-# *** telldir not tested
-# *** seekdir not tested
-# *** rewinddir not tested
-# *** closedir not tested
-# *** gmtime not tested
-# *** alarm not tested
-# *** semget not tested
-# *** getlogin not tested
-EXPECT
-########
-use warnings 'uninitialized';
-if ($^O eq 'MSWin32') {
- print <<'EOM';
-SKIPPED
-# `` produces an error on STDERR on Win32
-EOM
- exit;
-}
-my $nocmd = '/no/such/command';
-my $v;
-$v = 1 + `$nocmd`;
-EXPECT
-Use of uninitialized value in addition (+) at - line 11.
-########
-use warnings 'uninitialized';
-if ($^O eq 'MSWin32') {
- print <<'EOM';
-SKIPPED
-# qx produces an error on STDERR on Win32
-EOM
- exit;
-}
-my $nocmd = '/no/such/command';
-my $v;
-$v = 1 + qx($nocmd);
-EXPECT
-Use of uninitialized value in addition (+) at - line 11.
-########
-use warnings 'uninitialized';
-my $nan = "NaN";
-if ($nan == $nan) {
- print <<'EOM';
-SKIPPED
-# NaN not supported here.
-EOM
- exit;
-}
-my $v;
-$v = 1 + ($nan <=> 1);
-EXPECT
-Use of uninitialized value in addition (+) at - line 11.
-########
-use warnings 'uninitialized';
-if ($^O eq 'MSWin32') {
- print <<'EOM';
-SKIPPED
-# -k produces no warning on Win32
-EOM
- exit;
-}
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + -k $nofile;
-EXPECT
-Use of uninitialized value in addition (+) at - line 11.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-my $f = "";
-$v = 1 + open($f, $nofile);
-EXPECT
-Use of uninitialized value in addition (+) at - line 5.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + fileno($nofile);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + binmode($nofile);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + tied($nofile);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + getc($nofile);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + sysread($nofile, my $buf,1);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + eval { send($nofile, $buf,0) };
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-my $fh = "";
-$v = 1 + eval { accept($fh, $nofile) };
-EXPECT
-Use of uninitialized value in addition (+) at - line 5.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + (-r $nofile);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + (-w $nofile);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + (-x $nofile);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + (-o $nofile);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + (-R $nofile);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + (-W $nofile);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + (-X $nofile);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + (-O $nofile);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + (-e $nofile);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + (-z $nofile);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + (-s $nofile);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + (-f $nofile);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + (-d $nofile);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + (-l $nofile);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + (-p $nofile);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + (-S $nofile);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + (-b $nofile);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + (-c $nofile);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + (-t $nofile);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + (-u $nofile);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + (-g $nofile);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + (-T $nofile);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + (-B $nofile);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + (-M $nofile);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + (-A $nofile);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + (-C $nofile);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + eval { readlink $nofile };
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + opendir($f, $nofile);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + undef;
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-my $x = 1; $v = 1 + undef($x);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $v;
-my $emptys = "";
-$v = 1 + substr($emptys,2,1);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $v;
-my @emptya;
-$v = 1 + each @emptya;
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $v;
-my %emptyh;
-$v = 1 + each %emptyh;
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $v;
-my @emptya;
-$v = 1 + sort @emptya;
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $v;
-my $zero = 0; $v = 1 + caller($zero);
-EXPECT
-Use of uninitialized value in addition (+) at - line 3.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-$v = 1 + do $nofile;
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $v;
-my $fn = sub {};
-$v = 1 + prototype $fn;
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized'; no warnings 'experimental::smartmatch';
-my $v;
-my $fn = sub {};
-$v = 1 + (1 ~~ $fn);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $v;
-my $f = "";
-$v = 1 + (print STDIN $f); # print to STDIN returns undef
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $v;
-my $f = "";
-$v = 1 + (printf STDIN "%s", $f);
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $v;
-my $f = "";
-{ use feature 'say'; $v = 1 + (say STDIN "%s", $f); }
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $v;
-my $f = "";
-$v = 1 + (unpack("",$f));
-EXPECT
-Use of uninitialized value in addition (+) at - line 4.
-########
-use warnings 'uninitialized';
-my $nofile = '/no/such/file';
-my $v;
-my $f = "";
-$v = 1 + sysopen($f, $nofile, 0);
-EXPECT
-Use of uninitialized value in addition (+) at - line 5.
-########
-use warnings 'uninitialized';
-my $v;
-{ my $x = -1; $v = 1 + sysseek(DATA, $x, 0); }
-__END__
-EXPECT
-Use of uninitialized value in addition (+) at - line 3.
-########
-use warnings 'uninitialized';
-delete $::{'Foo::'};
-my $moo = $Foo::BAR + 42;
-__END__
-EXPECT
-Use of uninitialized value in addition (+) at - line 3.
-########
-use warnings 'uninitialized';
-use constant {u=>undef, v=>undef};
-sub foo () {u}
-sub foo () {v}
-EXPECT
-########
-# [perl #72090]
-use warnings 'uninitialized';
-$a = @$a > 0;
-EXPECT
-Use of uninitialized value $a in array dereference at - line 3.
-Use of uninitialized value in numeric gt (>) at - line 3.
-########
-# [perl #103766]
-use warnings 'uninitialized';
-"@{[ $x ]}";
-EXPECT
-Use of uninitialized value in join or string at - line 3.
-########
-# inside formats
-use warnings 'uninitialized';
-my $x;
-format =
-@
-"$x";
-.
-write;
-EXPECT
-Use of uninitialized value $x in string at - line 6.
-########
-# NAME off-by-one error in hash bucket walk in key detection logic
-use warnings 'uninitialized';
-
-for ( 0 .. 20 ) { # we assume that this means we test keys for every bucket
- my %h= ( $_ => undef );
- my $s= sprintf "%s", $h{$_};
-}
-EXPECT
-Use of uninitialized value $h{"0"} in sprintf at - line 5.
-Use of uninitialized value $h{"1"} in sprintf at - line 5.
-Use of uninitialized value $h{"2"} in sprintf at - line 5.
-Use of uninitialized value $h{"3"} in sprintf at - line 5.
-Use of uninitialized value $h{"4"} in sprintf at - line 5.
-Use of uninitialized value $h{"5"} in sprintf at - line 5.
-Use of uninitialized value $h{"6"} in sprintf at - line 5.
-Use of uninitialized value $h{"7"} in sprintf at - line 5.
-Use of uninitialized value $h{"8"} in sprintf at - line 5.
-Use of uninitialized value $h{"9"} in sprintf at - line 5.
-Use of uninitialized value $h{"10"} in sprintf at - line 5.
-Use of uninitialized value $h{"11"} in sprintf at - line 5.
-Use of uninitialized value $h{"12"} in sprintf at - line 5.
-Use of uninitialized value $h{"13"} in sprintf at - line 5.
-Use of uninitialized value $h{"14"} in sprintf at - line 5.
-Use of uninitialized value $h{"15"} in sprintf at - line 5.
-Use of uninitialized value $h{"16"} in sprintf at - line 5.
-Use of uninitialized value $h{"17"} in sprintf at - line 5.
-Use of uninitialized value $h{"18"} in sprintf at - line 5.
-Use of uninitialized value $h{"19"} in sprintf at - line 5.
-Use of uninitialized value $h{"20"} in sprintf at - line 5.
-########
-# NAME SvPOK && SvLEN==0 should not produce uninit warning
-use warnings 'uninitialized';
-
-$v = int(${qr||}); # sv_2iv on a regexp
-$v = 1.1 * ${qr||}; # sv_2nv on a regexp
-$v = ${qr||} << 2; # sv_2uv on a regexp
-
-sub TIESCALAR{bless[]}
-sub FETCH {${qr||}}
-tie $t, "";
-$v = 1.1 * $t; # sv_2nv on a tied regexp
-
-EXPECT
diff --git a/gnu/usr.bin/perl/t/mro/basic.t b/gnu/usr.bin/perl/t/mro/basic.t
index 5625b5190ee..1b186617dfe 100644
--- a/gnu/usr.bin/perl/t/mro/basic.t
+++ b/gnu/usr.bin/perl/t/mro/basic.t
@@ -3,14 +3,7 @@
use strict;
use warnings;
-BEGIN {
- chdir 't';
- @INC = '../lib';
- require q(./test.pl);
-}
-plan(tests => 61);
-
-require mro;
+require q(./test.pl); plan(tests => 38);
{
package MRO_A;
@@ -62,10 +55,10 @@ ok(!mro::is_universal('MRO_B'));
ok(mro::is_universal('MRO_B'));
@UNIVERSAL::ISA = ();
-ok(!mro::is_universal('MRO_B'));
+ok(mro::is_universal('MRO_B'));
# is_universal, get_mro, and get_linear_isa should
-# handle non-existent packages sanely
+# handle non-existant packages sanely
ok(!mro::is_universal('Does_Not_Exist'));
is(mro::get_mro('Also_Does_Not_Exist'), 'dfs');
ok(eq_array(
@@ -180,19 +173,6 @@ is(eval { MRO_N->testfunc() }, 123);
ok(eq_array(mro::get_linear_isa('ISACLEAR1'),[qw/ISACLEAR1/]));
ok(eq_array(mro::get_linear_isa('ISACLEAR2'),[qw/ISACLEAR2/]));
-
- # [perl #49564] This is a pretty obscure way of clearing @ISA but
- # it tests a regression that affects XS code calling av_clear too.
- {
- package ISACLEAR3;
- our @ISA = qw/WW XX/;
- }
- ok(eq_array(mro::get_linear_isa('ISACLEAR3'),[qw/ISACLEAR3 WW XX/]));
- {
- package ISACLEAR3;
- reset 'I';
- }
- ok(eq_array(mro::get_linear_isa('ISACLEAR3'),[qw/ISACLEAR3/]));
}
# Check that recursion bails out "cleanly" in a variety of cases
@@ -238,160 +218,3 @@ is(eval { MRO_N->testfunc() }, 123);
is($stk_obj->foo(3), 6);
}
-{
- {
- # assigning @ISA via arrayref to globref RT 60220
- package P1;
- sub new { bless {}, shift }
-
- package P2;
- }
- *{P2::ISA} = [ 'P1' ];
- my $foo = P2->new;
- ok(!eval { $foo->bark }, "no bark method");
- no warnings 'once'; # otherwise it'll bark about P1::bark used only once
- *{P1::bark} = sub { "[bark]" };
- is(scalar eval { $foo->bark }, "[bark]", "can bark now");
-}
-
-{
- # assigning @ISA via arrayref then modifying it RT 72866
- {
- package Q1;
- sub foo { }
-
- package Q2;
- sub bar { }
-
- package Q3;
- }
- push @Q3::ISA, "Q1";
- can_ok("Q3", "foo");
- *Q3::ISA = [];
- push @Q3::ISA, "Q1";
- can_ok("Q3", "foo");
- *Q3::ISA = [];
- push @Q3::ISA, "Q2";
- can_ok("Q3", "bar");
- ok(!Q3->can("foo"), "can't call foo method any longer");
-}
-
-{
- # test mro::method_changed_in
- my $count = mro::get_pkg_gen("MRO_A");
- mro::method_changed_in("MRO_A");
- my $count_new = mro::get_pkg_gen("MRO_A");
-
- is($count_new, $count + 1);
-}
-
-{
- # test if we can call mro::invalidate_all_method_caches;
- eval {
- mro::invalidate_all_method_caches();
- };
- is($@, "");
-}
-
-{
- # @main::ISA
- no warnings 'once';
- @main::ISA = 'parent';
- my $output = '';
- *parent::do = sub { $output .= 'parent' };
- *parent2::do = sub { $output .= 'parent2' };
- main->do;
- @main::ISA = 'parent2';
- main->do;
- is $output, 'parentparent2', '@main::ISA is magical';
-}
-
-{
- # Undefining *ISA, then modifying @ISA
- # This broke Class::Trait. See [perl #79024].
- {package Class::Trait::Base}
- no strict 'refs';
- undef *{"Extra::TSpouse::ISA"};
- 'Extra::TSpouse'->isa('Class::Trait::Base'); # cache the mro
- unshift @{"Extra::TSpouse::ISA"}, 'Class::Trait::Base';
- ok 'Extra::TSpouse'->isa('Class::Trait::Base'),
- 'a isa b after undef *a::ISA and @a::ISA modification';
-}
-
-{
- # Deleting $package::{ISA}
- # Broken in 5.10.0; fixed in 5.13.7
- @Blength::ISA = 'Bladd';
- delete $Blength::{ISA};
- ok !Blength->isa("Bladd"), 'delete $package::{ISA}';
-}
-
-{
- # Undefining stashes
- @Thrext::ISA = "Thwit";
- @Thwit::ISA = "Sile";
- undef %Thwit::;
- ok !Thrext->isa('Sile'), 'undef %package:: updates subclasses';
-}
-
-{
- # Obliterating @ISA via glob assignment
- # Broken in 5.14.0; fixed in 5.17.2
- @Gwythaint::ISA = "Fantastic::Creature";
- undef *This_glob_haD_better_not_exist; # paranoia; must have no array
- *Gwythaint::ISA = *This_glob_haD_better_not_exist;
- ok !Gwythaint->isa("Fantastic::Creature"),
- 'obliterating @ISA via glob assignment';
-}
-
-{
- # Autovivifying @ISA via @{*ISA}
- no warnings;
- undef *fednu::ISA;
- @{*fednu::ISA} = "pyfg";
- ok +fednu->isa("pyfg"), 'autovivifying @ISA via *{@ISA}';
-}
-
-{
- sub Detached::method;
- my $h = delete $::{"Detached::"};
- eval { local *Detached::method };
- is $@, "", 'localising gv-with-cv belonging to detached package';
-}
-
-{
- # *ISA localisation
- @il::ISA = "ilsuper";
- sub ilsuper::can { "puree" }
- sub il::tomatoes;
- {
- local *il::ISA;
- is +il->can("tomatoes"), \&il::tomatoes, 'local *ISA';
- }
- is "il"->can("tomatoes"), "puree", 'local *ISA unwinding';
- {
- local *il::ISA = [];
- is +il->can("tomatoes"), \&il::tomatoes, 'local *ISA = []';
- }
- is "il"->can("tomatoes"), "puree", 'local *ISA=[] unwinding';
-}
-
-# Changes to UNIVERSAL::DESTROY should not leave stale DESTROY caches
-# (part of #114864)
-our $destroy_output;
-sub UNIVERSAL::DESTROY { $destroy_output = "old" }
-my $x = bless[];
-undef $x; # cache the DESTROY method
-undef *UNIVERSAL::DESTROY;
-*UNIVERSAL::DESTROY = sub { $destroy_output = "new" };
-$x = bless[];
-undef $x; # should use the new DESTROY
-is $destroy_output, "new",
- 'Changes to UNIVERSAL::DESTROY invalidate DESTROY caches';
-undef *UNIVERSAL::DESTROY;
-
-{
- no warnings 'uninitialized';
- $#_119433::ISA++;
- pass "no crash when ISA contains nonexistent elements";
-}
diff --git a/gnu/usr.bin/perl/t/mro/inconsistent_c3.t b/gnu/usr.bin/perl/t/mro/inconsistent_c3.t
index ae01e9fdf27..14f652cc6d5 100644
--- a/gnu/usr.bin/perl/t/mro/inconsistent_c3.t
+++ b/gnu/usr.bin/perl/t/mro/inconsistent_c3.t
@@ -11,8 +11,6 @@ BEGIN {
require q(./test.pl); plan(tests => 1);
-require mro;
-
=pod
This example is take from: http://www.python.org/2.3/mro.html
@@ -46,5 +44,4 @@ except TypeError:
}
eval { mro::get_linear_isa('Z', 'c3') };
-like($@, qr/^Inconsistent hierarchy during C3 merge of class 'Z'/,
- '... got the right error with an inconsistent hierarchy');
+like($@, qr/^Inconsistent /, '... got the right error with an inconsistent hierarchy');
diff --git a/gnu/usr.bin/perl/t/mro/method_caching.t b/gnu/usr.bin/perl/t/mro/method_caching.t
index 3f21b1b6b34..733193ae1be 100644
--- a/gnu/usr.bin/perl/t/mro/method_caching.t
+++ b/gnu/usr.bin/perl/t/mro/method_caching.t
@@ -1,7 +1,6 @@
#!./perl
use strict;
-no strict 'refs'; # we do a lot of this
use warnings;
no warnings 'redefine'; # we do a lot of this
no warnings 'prototype'; # we do a lot of this
@@ -11,9 +10,10 @@ BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
- require './test.pl';
}
+require './test.pl';
+
{
package MCTest::Base;
sub foo { return $_[1]+1 };
@@ -35,15 +35,6 @@ my @testsubs = (
sub { is(MCTest::Derived->foo(0), 5); },
sub { sub FFF { $_[1]+7 }; local *MCTest::Base::foo = *FFF; is(MCTest::Derived->foo(0), 7); },
sub { is(MCTest::Derived->foo(0), 5); },
- sub { { local *MCTest::Base::can = sub { "tomatoes" };
- MCTest::Derived->can(0); }
- is(MCTest::Derived->can("isa"), \&UNIVERSAL::isa,
- 'removing method when unwinding local *method=sub{}'); },
- sub { sub peas { "peas" }
- { local *MCTest::Base::can = *peas;
- MCTest::Derived->can(0); }
- is(MCTest::Derived->can("isa"), \&UNIVERSAL::isa,
- 'removing method when unwinding local *method=*other'); },
sub { sub DDD { $_[1]+8 }; *MCTest::Base::foo = *DDD; is(MCTest::Derived->foo(0), 8); },
sub { *ASDF::asdf = sub { $_[1]+9 }; *MCTest::Base::foo = \&ASDF::asdf; is(MCTest::Derived->foo(0), 9); },
sub { undef *MCTest::Base::foo; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); },
@@ -66,39 +57,6 @@ my @testsubs = (
sub { *{MCTest::Base::} = *{Foo::}; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); },
sub { *MCTest::Derived::foo = \&MCTest::Base::foo; eval { MCTest::Derived::foo(0,0) }; ok(!$@); undef *MCTest::Derived::foo },
sub { eval 'package MCTest::Base; sub foo { $_[1]+18 }'; is(MCTest::Derived->foo(0), 18); },
-
- # Redefining through a glob alias
- sub { *A = *{'MCTest::Base::foo'}; eval 'sub A { $_[1]+19 }';
- is(MCTest::Derived->foo(0), 19,
- 'redefining sub through glob alias via decl'); },
- sub { SKIP: {
- skip_if_miniperl("no XS");
- eval { require XS::APItest; }
- or skip "XS::APItest not available", 1;
- *A = *{'MCTest::Base::foo'};
- XS::APItest::newCONSTSUB(\%main::, "A", 0, 20);
- is (MCTest::Derived->foo(0), 20,
- 'redefining sub through glob alias via newXS');
- } },
- sub { undef *{'MCTest::Base::foo'}; *A = *{'MCTest::Base::foo'};
- eval { no warnings 'once'; local *UNIVERSAL::foo = sub {96};
- MCTest::Derived->foo };
- ()=\&A;
- eval { MCTest::Derived->foo };
- like($@, qr/Undefined subroutine/,
- 'redefining sub through glob alias via stub vivification'); },
- sub { *A = *{'MCTest::Base::foo'};
- local *A = sub { 21 };
- is(MCTest::Derived->foo, 21,
- 'redef sub through glob alias via local cv-to-glob assign'); },
- sub { *A = *{'MCTest::Base::foo'};
- eval 'sub MCTest::Base::foo { 22 }';
- { local *A = sub { 23 }; MCTest::Derived->foo }
- is(MCTest::Derived->foo, 22,
- 'redef sub through glob alias via localisation unwinding'); },
- sub { *A = *{'MCTest::Base::foo'}; *A = sub { 24 };
- is(MCTest::Derived->foo(0), 24,
- 'redefining sub through glob alias via cv-to-glob assign'); },
);
plan(tests => scalar(@testsubs));
diff --git a/gnu/usr.bin/perl/t/mro/next_edgecases.t b/gnu/usr.bin/perl/t/mro/next_edgecases.t
index e177d7098fc..91c2c8581b6 100644
--- a/gnu/usr.bin/perl/t/mro/next_edgecases.t
+++ b/gnu/usr.bin/perl/t/mro/next_edgecases.t
@@ -3,9 +3,7 @@
use strict;
use warnings;
-BEGIN { chdir 't'; require q(./test.pl); @INC = qw "../lib lib" }
-
-plan(tests => 12);
+require q(./test.pl); plan(tests => 11);
{
@@ -21,7 +19,7 @@ plan(tests => 12);
# call the submethod in the direct instance
my $foo = Foo->new();
- object_ok($foo, 'Foo');
+ isa_ok($foo, 'Foo');
can_ok($foo, 'bar');
is($foo->bar(), 'Foo::bar', '... got the right return value');
@@ -37,8 +35,8 @@ plan(tests => 12);
}
my $bar = Bar->new();
- object_ok($bar, 'Bar');
- object_ok($bar, 'Foo');
+ isa_ok($bar, 'Bar');
+ isa_ok($bar, 'Foo');
# test it working with with Sub::Name
SKIP: {
@@ -54,7 +52,7 @@ plan(tests => 12);
can_ok($bar, 'bar');
my $value = eval { $bar->bar() };
- ok(!$@, '... calling bar() succeeded') || diag $@;
+ ok(!$@, '... calling bar() succedded') || diag $@;
is($value, 'Foo::bar', '... got the right return value too');
}
@@ -68,8 +66,8 @@ plan(tests => 12);
}
my $baz = Baz->new();
- object_ok($baz, 'Baz');
- object_ok($baz, 'Foo');
+ isa_ok($baz, 'Baz');
+ isa_ok($baz, 'Foo');
{
my $m = sub { (shift)->next::method() };
@@ -80,16 +78,5 @@ plan(tests => 12);
eval { $baz->bar() };
ok($@, '... calling bar() with next::method failed') || diag $@;
- }
-
- # Test with non-existing class (used to segfault)
- {
- package Qux;
- use mro;
- sub foo { No::Such::Class->next::can }
- }
-
- eval { Qux->foo() };
- is($@, '', "->next::can on non-existing package name");
-
+ }
}
diff --git a/gnu/usr.bin/perl/t/mro/recursion_c3.t b/gnu/usr.bin/perl/t/mro/recursion_c3.t
index cd1db3355a3..4030cfcd2c6 100644
--- a/gnu/usr.bin/perl/t/mro/recursion_c3.t
+++ b/gnu/usr.bin/perl/t/mro/recursion_c3.t
@@ -14,8 +14,6 @@ require './test.pl';
plan(skip_all => "Your system has no SIGALRM") if !exists $SIG{ALRM};
plan(tests => 8);
-require mro;
-
=pod
These are like the 010_complex_merge_classless test,
@@ -62,7 +60,7 @@ into an infinite loop
our @ISA = qw//;
}
-# A series of 8 aberations that would cause infinite loops,
+# A series of 8 abberations that would cause infinite loops,
# each one undoing the work of the previous
my @loopies = (
sub { @E::ISA = qw/F/ },
diff --git a/gnu/usr.bin/perl/t/mro/recursion_dfs.t b/gnu/usr.bin/perl/t/mro/recursion_dfs.t
index ddb4d31a08f..b7bf6d42cd1 100644
--- a/gnu/usr.bin/perl/t/mro/recursion_dfs.t
+++ b/gnu/usr.bin/perl/t/mro/recursion_dfs.t
@@ -49,7 +49,7 @@ into an infinite loop
our @ISA = qw//;
}
-# A series of 8 aberations that would cause infinite loops,
+# A series of 8 abberations that would cause infinite loops,
# each one undoing the work of the previous
my @loopies = (
sub { @E::ISA = qw/F/ },
diff --git a/gnu/usr.bin/perl/t/op/blocks.t b/gnu/usr.bin/perl/t/op/blocks.t
index fb15eeeda38..476d9ea9af7 100644
--- a/gnu/usr.bin/perl/t/op/blocks.t
+++ b/gnu/usr.bin/perl/t/op/blocks.t
@@ -6,20 +6,20 @@ BEGIN {
require './test.pl';
}
-plan tests => 7;
+plan tests => 3;
my @expect = qw(
b1
b2
b3
b4
-b6-c
+b6
+u5
b7
u6
-u5-c
u1
c3
-c2-c
+c2
c1
i1
i2
@@ -27,8 +27,6 @@ b5
u2
u3
u4
-b6-r
-u5-r
e2
e1
);
@@ -47,18 +45,9 @@ UNITCHECK {print ":u1"}
eval 'BEGIN {print ":b5"}';
eval 'UNITCHECK {print ":u2"}';
eval 'UNITCHECK {print ":u3"; UNITCHECK {print ":u4"}}';
-"a" =~ /(?{UNITCHECK {print ":u5-c"};
- CHECK {print ":c2-c"};
- BEGIN {print ":b6-c"}})/x;
-{
- use re 'eval';
- my $runtime = q{
- (?{UNITCHECK {print ":u5-r"};
- CHECK {print ":c2-r"};
- BEGIN {print ":b6-r"}})/
- };
- "a" =~ /$runtime/x;
-}
+"a" =~ /(?{UNITCHECK {print ":u5"};
+ CHECK {print ":c2"};
+ BEGIN {print ":b6"}})/x;
eval {BEGIN {print ":b7"}};
eval {UNITCHECK {print ":u6"}};
eval {INIT {print ":i2"}};
@@ -116,32 +105,3 @@ sub CHECK {print ":check"}
sub INIT {print ":init"}
sub END {print ":end"}
SCRIPT3
-
-fresh_perl_is(<<'SCRIPT70614', "still here",{switches => [''], stdin => '', stderr => 1 },'eval-UNITCHECK-eval (bug 70614)');
-eval "UNITCHECK { eval 0 }"; print "still here";
-SCRIPT70614
-
-# [perl #78634] Make sure block names can be used as constants.
-use constant INIT => 5;
-::is INIT, 5, 'constant named after a special block';
-
-# [perl #108794] context
-fresh_perl_is(<<'SCRIPT3', <<expEct,{stderr => 1 },'context');
-sub context {
- print qw[void scalar list][wantarray + defined wantarray], "\n"
-}
-BEGIN {context}
-UNITCHECK {context}
-CHECK {context}
-INIT {context}
-END {context}
-SCRIPT3
-void
-void
-void
-void
-void
-expEct
-
-fresh_perl_is('END { print "ok\n" } INIT { bless {} and exit }', "ok\n",
- {}, 'null PL_curcop in newGP');
diff --git a/gnu/usr.bin/perl/t/op/dor.t b/gnu/usr.bin/perl/t/op/dor.t
index a0b98f189eb..602a03c16d5 100644
--- a/gnu/usr.bin/perl/t/op/dor.t
+++ b/gnu/usr.bin/perl/t/op/dor.t
@@ -10,7 +10,7 @@ BEGIN {
package main;
require './test.pl';
-plan( tests => 34 );
+plan( tests => 31 );
my($x);
@@ -23,7 +23,7 @@ is($x // 1, 1, ' // : left-hand operand undef');
$x='';
is($x // 0, '', ' // : left-hand operand defined but empty');
-like([] // 0, qr/^ARRAY/, ' // : left-hand operand a reference');
+like([] // 0, qr/^ARRAY/, ' // : left-hand operand a referece');
$x=undef;
$x //= 1;
@@ -56,45 +56,18 @@ for (qw(getc pos readline readlink undef umask <> <FOO> <$foo> -f)) {
# Test for some ambiguous syntaxes
eval q# sub f ($) { } f $x / 2; #;
-is( $@, '', "'/' correctly parsed as arithmetic operator" );
+is( $@, '' );
eval q# sub f ($):lvalue { $y } f $x /= 2; #;
-is( $@, '', "'/=' correctly parsed as assigment operator" );
+is( $@, '' );
eval q# sub f ($) { } f $x /2; #;
-like( $@, qr/^Search pattern not terminated/,
- "Caught unterminated search pattern error message: empty subroutine" );
+like( $@, qr/^Search pattern not terminated/ );
eval q# sub { print $fh / 2 } #;
-is( $@, '',
- "'/' correctly parsed as arithmetic operator in sub with built-in function" );
+is( $@, '' );
eval q# sub { print $fh /2 } #;
-like( $@, qr/^Search pattern not terminated/,
- "Caught unterminated search pattern error message: sub with built-in function" );
+like( $@, qr/^Search pattern not terminated/ );
# [perl #28123] Perl optimizes // away incorrectly
is(0 // 2, 0, ' // : left-hand operand not optimized away');
is('' // 2, '', ' // : left-hand operand not optimized away');
is(undef // 2, 2, ' // : left-hand operand optimized away');
-
-# Test that OP_DORs other branch isn't run when arg is defined
-# // returns the value if its defined, and we must test its
-# truthness after
-my $x = 0;
-my $y = 0;
-
-$x // 1 and $y = 1;
-is($y, 0, 'y is still 0 after "$x // 1 and $y = 1"');
-
-$y = 0;
-# $x is defined, so its value 0 is returned to the if block
-# and the block is skipped
-if ($x // 1) {
- $y = 1;
-}
-is($y, 0, 'if ($x // 1) exited out early since $x is defined and 0');
-
-# This is actually (($x // $z) || 'cat'), so 0 from first dor
-# evaluates false, we should see 'cat'.
-$y = undef;
-
-$y = $x // $z || 'cat';
-is($y, 'cat', 'chained or/dor behaves correctly');
diff --git a/gnu/usr.bin/perl/t/op/incfilter.t b/gnu/usr.bin/perl/t/op/incfilter.t
index c344558f6ad..f796275f0bc 100644
--- a/gnu/usr.bin/perl/t/op/incfilter.t
+++ b/gnu/usr.bin/perl/t/op/incfilter.t
@@ -5,15 +5,21 @@
BEGIN {
chdir 't' if -d 't';
@INC = qw(. ../lib);
- require 'test.pl';
- skip_all_if_miniperl('no dynamic loading on miniperl, no Filter::Util::Call');
- skip_all_without_perlio();
+ if ($ENV{PERL_CORE_MINITEST}) {
+ print "1..0 # Skip: no dynamic loading on miniperl\n";
+ exit 0;
+ }
+ unless (find PerlIO::Layer 'perlio') {
+ print "1..0 # Skip: not perlio\n";
+ exit 0;
+ }
+ require "test.pl";
}
use strict;
use Config;
use Filter::Util::Call;
-plan(tests => 153);
+plan(tests => 141);
unshift @INC, sub {
no warnings 'uninitialized';
@@ -74,12 +80,7 @@ if ($^O eq 'VMS') {
$fail_arg = '"fail"';
}
else {
- if ($^O =~ /android/) {
- $echo_command = q{sh -c 'echo $@' -- };
- }
- else {
- $echo_command = 'echo';
- }
+ $echo_command = 'echo';
$pass_arg = 'pass';
$fail_arg = 'fail';
}
@@ -200,23 +201,7 @@ do [$fh, sub {$_ .= $_ . $_; return;}] or die;
do \"pass\n(\n'Scalar references are treated as initial file contents'\n)\n"
or die;
-use constant scalarreffee =>
- "pass\n(\n'Scalar references are treated as initial file contents'\n)\n";
-do \scalarreffee or die;
-is scalarreffee,
- "pass\n(\n'Scalar references are treated as initial file contents'\n)\n",
- 'and are not gobbled up when read-only';
-
-{
- local $SIG{__WARN__} = sub {}; # ignore deprecation warning from ?...?
- do qr/a?, 1/;
- pass "No crash (perhaps) when regexp ref is returned from inc filter";
- # Even if that outputs "ok", it may not have passed, as the crash
- # occurs during globular destruction. But the crash will result in
- # this script failing.
-}
-
-open $fh, "<", \"ss('The file is concatenated');";
+open $fh, "<", \"ss('The file is concatentated');";
do [\'pa', $fh] or die;
@@ -236,62 +221,3 @@ do [\'pa', \&generator_with_state,
["ss('And generators which take state');\n",
"pass('And return multiple lines');\n",
]] or die;
-
-@origlines = keys %{{ "1\n+\n2\n" => 1 }};
-@lines = @origlines;
-do \&generator or die;
-is $origlines[0], "1\n+\n2\n", 'ink filters do not mangle cow buffers';
-
-@lines = ('$::the_array = "', [], '"');
-do \&generator or die;
-like ${$::{the_array}}, qr/^ARRAY\(0x.*\)\z/,
- 'setting $_ to ref in inc filter';
-@lines = ('$::the_array = "', do { no warnings 'once'; *foo}, '"');
-do \&generator or die;
-is ${$::{the_array}}, "*main::foo", 'setting $_ to glob in inc filter';
-@lines = (
- '$::the_array = "',
- do { no strict; no warnings; *{"foo\nbar"}},
- '"');
-do \&generator or die;
-is ${$::{the_array}}, "*main::foo\nbar",
- 'setting $_ to multiline glob in inc filter';
-
-sub TIESCALAR { bless \(my $thing = pop), shift }
-sub FETCH {${$_[0]}}
-my $done;
-do sub {
- return 0 if $done;
- tie $_, "main", '$::the_scalar = 98732';
- return $done = 1;
-} or die;
-is ${$::{the_scalar}}, 98732, 'tying $_ in inc filter';
-@lines = ('$::the_scalar', '= "12345"');
-tie my $ret, "main", 1;
-do sub :lvalue {
- return 0 unless @lines;
- $_ = shift @lines;
- return $ret;
-} or die;
-is ${$::{the_scalar}}, 12345, 'returning tied val from inc filter';
-
-
-# d8723a6a74b2c12e wasn't perfect, as the char * returned by SvPV*() can be
-# a temporary, freed at the next FREETMPS. And there is a FREETMPS in
-# pp_require
-
-for (0 .. 1) {
- # Need both alternatives on the regexp, because currently the logic in
- # pp_require for what is written to %INC is somewhat confused
- open $fh, "<",
- \'like(__FILE__, qr/(?:GLOB|CODE)\(0x[0-9a-f]+\)/, "__FILE__ is valid");';
- do $fh or die;
-}
-
-# [perl #91880] $_ having the wrong refcount inside a
-{ # filter sub
- local @INC; local $|;
- unshift @INC, sub { sub { undef *_; --$| }};
- do "dah";
- pass '$_ has the right refcount inside a filter sub';
-}
diff --git a/gnu/usr.bin/perl/t/op/mydef.t b/gnu/usr.bin/perl/t/op/mydef.t
index b993f1b607c..f250ff6e367 100644
--- a/gnu/usr.bin/perl/t/op/mydef.t
+++ b/gnu/usr.bin/perl/t/op/mydef.t
@@ -1,89 +1,94 @@
-#!./perl -w
+#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
- require './test.pl';
}
-use strict;
-no warnings 'misc', 'experimental::lexical_topic';
+print "1..70\n";
+
+my $test = 0;
+sub ok ($$) {
+ my ($ok, $name) = @_;
+ ++$test;
+ print $ok ? "ok $test - $name\n" : "not ok $test - $name\n";
+}
$_ = 'global';
-is($_, 'global', '$_ initial value');
+ok( $_ eq 'global', '$_ initial value' );
s/oba/abo/;
-is($_, 'glabol', 's/// on global $_');
+ok( $_ eq 'glabol', 's/// on global $_' );
{
my $_ = 'local';
- is($_, 'local', 'my $_ initial value');
+ ok( $_ eq 'local', 'my $_ initial value' );
s/oca/aco/;
- is($_, 'lacol', 's/// on my $_');
+ ok( $_ eq 'lacol', 's/// on my $_' );
/(..)/;
- is($1, 'la', '// on my $_');
- cmp_ok(tr/c/d/, '==', 1, 'tr/// on my $_ counts correctly' );
- is($_, 'ladol', 'tr/// on my $_');
+ ok( $1 eq 'la', '// on my $_' );
+ ok( tr/c/d/ == 1, 'tr/// on my $_ counts correctly' );
+ ok( $_ eq 'ladol', 'tr/// on my $_' );
{
my $_ = 'nested';
- is($_, 'nested', 'my $_ nested');
+ ok( $_ eq 'nested', 'my $_ nested' );
chop;
- is($_, 'neste', 'chop on my $_');
+ ok( $_ eq 'neste', 'chop on my $_' );
}
{
our $_;
- is($_, 'glabol', 'gains access to our global $_');
+ ok( $_ eq 'glabol', 'gains access to our global $_' );
}
- is($_, 'ladol', 'my $_ restored');
+ ok( $_ eq 'ladol', 'my $_ restored' );
}
-is($_, 'glabol', 'global $_ restored');
+ok( $_ eq 'glabol', 'global $_ restored' );
s/abo/oba/;
-is($_, 'global', 's/// on global $_ again');
+ok( $_ eq 'global', 's/// on global $_ again' );
{
my $_ = 11;
our $_ = 22;
- is($_, 22, 'our $_ is seen explicitly');
+ ok( $_ eq 22, 'our $_ is seen explicitly' );
chop;
- is($_, 2, '...default chop chops our $_');
+ ok( $_ eq 2, '...default chop chops our $_' );
/(.)/;
- is($1, 2, '...default match sees our $_');
+ ok( $1 eq 2, '...default match sees our $_' );
}
$_ = "global";
{
my $_ = 'local';
for my $_ ("foo") {
- is($_, "foo", 'for my $_');
+ ok( $_ eq "foo", 'for my $_' );
/(.)/;
- is($1, "f", '...m// in for my $_');
- is(our $_, 'global', '...our $_ inside for my $_');
+ ok( $1 eq "f", '...m// in for my $_' );
+ ok( our $_ eq 'global', '...our $_ inside for my $_' );
}
- is($_, 'local', '...my $_ restored outside for my $_');
- is(our $_, 'global', '...our $_ restored outside for my $_');
+ ok( $_ eq 'local', '...my $_ restored outside for my $_' );
+ ok( our $_ eq 'global', '...our $_ restored outside for my $_' );
}
{
my $_ = 'local';
for ("implicit foo") { # implicit "my $_"
- is($_, "implicit foo", 'for implicit my $_');
+ ok( $_ eq "implicit foo", 'for implicit my $_' );
/(.)/;
- is($1, "i", '...m// in for implicit my $_');
- is(our $_, 'global', '...our $_ inside for implicit my $_');
+ ok( $1 eq "i", '...m// in for implicity my $_' );
+ ok( our $_ eq 'global', '...our $_ inside for implicit my $_' );
}
- is($_, 'local', '...my $_ restored outside for implicit my $_');
- is(our $_, 'global', '...our $_ restored outside for implicit my $_');
+ ok( $_ eq 'local', '...my $_ restored outside for implicit my $_' );
+ ok( our $_ eq 'global', '...our $_ restored outside for implicit my $_' );
}
{
my $_ = 'local';
- is($_, "postfix foo", 'postfix for' ) for 'postfix foo';
- is($_, 'local', '...my $_ restored outside postfix for');
- is(our $_, 'global', '...our $_ restored outside postfix for');
+ ok( $_ eq "postfix foo", 'postfix for' ) for 'postfix foo';
+ ok( $_ eq 'local', '...my $_ restored outside postfix for' );
+ ok( our $_ eq 'global', '...our $_ restored outside postfix for' );
}
{
for our $_ ("bar") {
- is($_, "bar", 'for our $_');
+ ok( $_ eq "bar", 'for our $_' );
/(.)/;
- is($1, "b", '...m// in for our $_');
+ ok( $1 eq "b", '...m// in for our $_' );
}
- is($_, 'global', '...our $_ restored outside for our $_');
+ ok( $_ eq 'global', '...our $_ restored outside for our $_' );
}
{
@@ -95,27 +100,27 @@ $_ = "global";
tmap1();
tmap2();
ok( /^[67]\z/, 'local lexical $_ is seen in map' );
- { is(our $_, 'global', 'our $_ still visible'); }
+ { ok( our $_ eq 'global', 'our $_ still visible' ); }
ok( $_ == 6 || $_ == 7, 'local lexical $_ is still seen in map' );
- { my $_ ; is($_, undef, 'nested my $_ is undefined'); }
+ { my $_ ; ok( !defined, 'nested my $_ is undefined' ); }
} 6, 7;
- is($buf, 'gxgx', q/...map doesn't modify outer lexical $_/);
- is($_, 'x', '...my $_ restored outside map');
- is(our $_, 'global', '...our $_ restored outside map');
- map { my $_; is($_, undef, 'redeclaring $_ in map block undefs it'); } 1;
+ ok( $buf eq 'gxgx', q/...map doesn't modify outer lexical $_/ );
+ ok( $_ eq 'x', '...my $_ restored outside map' );
+ ok( our $_ eq 'global', '...our $_ restored outside map' );
+ map { my $_; ok( !defined, 'redeclaring $_ in map block undefs it' ); } 1;
}
-{ map { my $_; is($_, undef, 'declaring $_ in map block undefs it'); } 1; }
+{ map { my $_; ok( !defined, 'declaring $_ in map block undefs it' ); } 1; }
{
sub tmap3 () { return $_ };
my $_ = 'local';
sub tmap4 () { return $_ };
my $x = join '-', map $_.tmap3.tmap4, 1 .. 2;
- is($x, '1globallocal-2globallocal', 'map without {}');
+ ok( $x eq '1globallocal-2globallocal', 'map without {}' );
}
{
for my $_ (1) {
my $x = map $_, qw(a b);
- is($x, 2, 'map in scalar context');
+ ok( $x == 2, 'map in scalar context' );
}
}
{
@@ -127,92 +132,69 @@ $_ = "global";
tgrep1();
tgrep2();
ok( /^[89]\z/, 'local lexical $_ is seen in grep' );
- { is(our $_, 'global', 'our $_ still visible'); }
+ { ok( our $_ eq 'global', 'our $_ still visible' ); }
ok( $_ == 8 || $_ == 9, 'local lexical $_ is still seen in grep' );
} 8, 9;
- is($buf, 'gygy', q/...grep doesn't modify outer lexical $_/);
- is($_, 'y', '...my $_ restored outside grep');
- is(our $_, 'global', '...our $_ restored outside grep');
+ ok( $buf eq 'gygy', q/...grep doesn't modify outer lexical $_/ );
+ ok( $_ eq 'y', '...my $_ restored outside grep' );
+ ok( our $_ eq 'global', '...our $_ restored outside grep' );
}
{
sub tgrep3 () { return $_ };
my $_ = 'local';
sub tgrep4 () { return $_ };
my $x = join '-', grep $_=$_.tgrep3.tgrep4, 1 .. 2;
- is($x, '1globallocal-2globallocal', 'grep without {} with side-effect');
- is($_, 'local', '...but without extraneous side-effects');
+ ok( $x eq '1globallocal-2globallocal', 'grep without {} with side-effect' );
+ ok( $_ eq 'local', '...but without extraneous side-effects' );
}
{
for my $_ (1) {
my $x = grep $_, qw(a b);
- is($x, 2, 'grep in scalar context');
+ ok( $x == 2, 'grep in scalar context' );
}
}
{
my $s = "toto";
my $_ = "titi";
- my $r;
- {
- local $::TODO = 'Marked as todo since test was added in 59f00321bbc2d046';
- $r = $s =~ /to(?{ is($_, 'toto', 'my $_ in code-match' ) })to/;
- }
- ok($r, "\$s=$s should match!");
- is(our $_, 'global', '...our $_ restored outside code-match');
+ $s =~ /to(?{ ok( $_ eq 'toto', 'my $_ in code-match # TODO' ) })to/
+ or ok( 0, "\$s=$s should match!" );
+ ok( our $_ eq 'global', '...our $_ restored outside code-match' );
}
{
my $_ = "abc";
my $x = reverse;
- is($x, "cba", 'reverse without arguments picks up $_');
+ ok( $x eq "cba", 'reverse without arguments picks up $_' );
}
{
package notmain;
our $_ = 'notmain';
- ::is($::_, 'notmain', 'our $_ forced into main::');
+ ::ok( $::_ eq 'notmain', 'our $_ forced into main::' );
/(.*)/;
- ::is($1, 'notmain', '...m// defaults to our $_ in main::');
+ ::ok( $1 eq 'notmain', '...m// defaults to our $_ in main::' );
}
-my $file = tempfile();
+my $file = 'dolbar1.tmp';
+END { unlink $file; }
{
open my $_, '>', $file or die "Can't open $file: $!";
print $_ "hello\n";
close $_;
- cmp_ok(-s $file, '>', 5, 'writing to filehandle $_ works');
+ ok( -s $file, 'writing to filehandle $_ works' );
}
{
open my $_, $file or die "Can't open $file: $!";
my $x = <$_>;
- is($x, "hello\n", 'reading from <$_> works');
+ ok( $x eq "hello\n", 'reading from <$_> works' );
close $_;
}
{
$fqdb::_ = 'fqdb';
- is($fqdb::_, 'fqdb', 'fully qualified $_ is not in main' );
- is(eval q/$fqdb::_/, 'fqdb', 'fully qualified, evaled $_ is not in main' );
+ ok( $fqdb::_ eq 'fqdb', 'fully qualified $_ is not in main' );
+ ok( eval q/$fqdb::_/ eq 'fqdb', 'fully qualified, evaled $_ is not in main' );
package fqdb;
- ::isnt($_, 'fqdb', 'unqualified $_ is in main' );
- ::isnt(eval q/$_/, 'fqdb', 'unqualified, evaled $_ is in main');
+ ::ok( $_ ne 'fqdb', 'unqualified $_ is in main' );
+ ::ok( q/$_/ ne 'fqdb', 'unqualified, evaled $_ is in main' );
}
-
-{
- $clank_est::qunckkk = 3;
- our $qunckkk;
- $qunckkk = 4;
- package clank_est;
- our $qunckkk;
- ::is($qunckkk, 3, 'regular variables are not forced to main');
-}
-
-{
- $whack::_ = 3;
- our $_;
- $_ = 4;
- package whack;
- our $_;
- ::is($_, 4, '$_ is "special", and always forced to main');
-}
-
-done_testing();
diff --git a/gnu/usr.bin/perl/t/op/qr.t b/gnu/usr.bin/perl/t/op/qr.t
index ac017eb2083..f8fc32f5e28 100644
--- a/gnu/usr.bin/perl/t/op/qr.t
+++ b/gnu/usr.bin/perl/t/op/qr.t
@@ -1,112 +1,20 @@
#!./perl -w
-use strict;
-
BEGIN {
- chdir 't';
+ chdir 't' if -d 't';
+ @INC = '../lib';
require './test.pl';
}
-plan(tests => 32);
-
-sub r {
- return qr/Good/;
-}
-
-my $a = r();
-object_ok($a, 'Regexp');
-my $b = r();
-object_ok($b, 'Regexp');
-
-my $b1 = $b;
-
-isnt($a + 0, $b + 0, 'Not the same object');
-
-bless $b, 'Pie';
-
-object_ok($b, 'Pie');
-object_ok($a, 'Regexp');
-object_ok($b1, 'Pie');
-
-my $c = r();
-like("$c", qr/Good/);
-my $d = r();
-like("$d", qr/Good/);
-
-my $d1 = $d;
-
-isnt($c + 0, $d + 0, 'Not the same object');
-
-$$d = 'Bad';
-
-like("$c", qr/Good/);
-is($$d, 'Bad');
-is($$d1, 'Bad');
+plan tests => 2;
-# Assignment to an implicitly blessed Regexp object retains the class
-# (No different from direct value assignment to any other blessed SV
+my $rx = qr//;
-object_ok($d, 'Regexp');
-like("$d", qr/\ARegexp=SCALAR\(0x[0-9a-f]+\)\z/);
+is(ref $rx, "Regexp", "qr// blessed into `Regexp' by default");
-# As does an explicitly blessed Regexp object.
-
-my $e = bless qr/Faux Pie/, 'Stew';
-
-object_ok($e, 'Stew');
-$$e = 'Fake!';
-
-is($$e, 'Fake!');
-object_ok($e, 'Stew');
-like("$e", qr/\Stew=SCALAR\(0x[0-9a-f]+\)\z/);
-
-# [perl #96230] qr// should not have the reuse-last-pattern magic
-"foo" =~ /foo/;
-like "bar",qr//,'[perl #96230] =~ qr// does not reuse last successful pat';
-"foo" =~ /foo/;
-$_ = "bar";
-$_ =~ s/${qr||}/baz/;
-is $_, "bazbar", '[perl #96230] s/$qr// does not reuse last pat';
-
-{
- my $x = 1.1; $x = ${qr//};
- pass 'no assertion failure when upgrading NV to regexp';
-}
-
-sub TIESCALAR{bless[]}
-sub STORE { is ref\pop, "REGEXP", "stored regexp" }
-tie my $t, "";
-$t = ${qr||};
-ok tied $t, 'tied var is still tied after regexp assignment';
-
-bless \my $t2;
-$t2 = ${qr||};
-is ref \$t2, 'main', 'regexp assignment is not maledictory';
-
-{
- my $w;
- local $SIG{__WARN__}=sub{$w=$_[0]};
- $_ = 1.1;
- $_ = ${qr//};
- is 0+$_, 0, 'double upgraded to regexp';
- like $w, 'numeric', 'produces non-numeric warning';
- undef $w;
- $_ = 1;
- $_ = ${qr//};
- is 0+$_, 0, 'int upgraded to regexp';
- like $w, 'numeric', 'likewise produces non-numeric warning';
-}
-
-sub {
- $_[0] = ${qr=crumpets=};
- is ref\$_[0], 'REGEXP', 'PVLVs';
- # Don’t use like() here, as we would no longer be testing a PVLV.
- ok " crumpets " =~ $_[0], 'using a regexpvlv as regexp';
- my $x = $_[0];
- is ref\$x, 'REGEXP', 'copying a regexpvlv';
- $_[0] = ${qr//};
- my $str = "".qr//;
- $_[0] .= " ";
- is $_[0], "$str ", 'stringifying regexpvlv in place';
-}
- ->((\my%hash)->{key});
+#
+# DESTROY doesn't do anything in the case of qr// except make sure
+# that lookups for it don't end up in AUTOLOAD lookups. But make sure
+# it's there anyway.
+#
+ok($rx->can("DESTROY"), "DESTROY method defined for Regexp");
diff --git a/gnu/usr.bin/perl/t/op/reset.t b/gnu/usr.bin/perl/t/op/reset.t
index e5924305af0..029161a0a4b 100644
--- a/gnu/usr.bin/perl/t/op/reset.t
+++ b/gnu/usr.bin/perl/t/op/reset.t
@@ -7,12 +7,13 @@ BEGIN {
}
use strict;
-plan tests => 39;
+# Currently only testing the reset of patterns.
+plan tests => 24;
package aiieee;
sub zlopp {
- (shift =~ m?zlopp?) ? 1 : 0;
+ (shift =~ ?zlopp?) ? 1 : 0;
}
sub reset_zlopp {
@@ -22,7 +23,7 @@ sub reset_zlopp {
package CLINK;
sub ZZIP {
- shift =~ m?ZZIP? ? 1 : 0;
+ shift =~ ?ZZIP? ? 1 : 0;
}
sub reset_ZZIP {
@@ -61,106 +62,6 @@ CLINK::reset_ZZIP();
is(CLINK::ZZIP("ZZIP"), 1, "match matches after reset");
is(CLINK::ZZIP(""), 0, "mismatch doesn't match");
-sub match_foo{
- "foo" =~ m?foo?;
-}
-match_foo();
-reset "";
-ok !match_foo(), 'reset "" leaves patterns alone [perl #97958]';
-
-$scratch::a = "foo";
-$scratch::a2 = "bar";
-$scratch::b = "baz";
-package scratch { reset "a" }
-is join("-", $scratch::a//'u', $scratch::a2//'u', $scratch::b//'u'),
- "u-u-baz",
- 'reset "char"';
-
-$scratch::a = "foo";
-$scratch::a2 = "bar";
-$scratch::b = "baz";
-$scratch::c = "sea";
-package scratch { reset "bc" }
-is join("-", $scratch::a//'u', $scratch::a2//'u', $scratch::b//'u',
- $scratch::c//'u'),
- "foo-bar-u-u",
- 'reset "chars"';
-
-$scratch::a = "foo";
-$scratch::a2 = "bar";
-$scratch::b = "baz";
-$scratch::c = "sea";
-package scratch { reset "a-b" }
-is join("-", $scratch::a//'u', $scratch::a2//'u', $scratch::b//'u',
- $scratch::c//'u'),
- "u-u-u-sea",
- 'reset "range"';
-
-{ no strict; ${"scratch::\0foo"} = "bar" }
-$scratch::a = "foo";
-package scratch { reset "\0a" }
-is join("-", $scratch::a//'u', do { no strict; ${"scratch::\0foo"} }//'u'),
- "u-u",
- 'reset "\0char"';
-
-$scratch::cow = __PACKAGE__;
-$scratch::qr = ${qr//};
-$scratch::v = v6;
-$scratch::glob = *is;
-*scratch::ro = \1;
-package scratch { reset 'cqgvr' }
-is join ("-", map $_//'u', $scratch::cow, $scratch::qr, $scratch::v,
- $scratch::glob,$scratch::ro), 'u-u-u-u-1',
- 'cow, qr, vstring, glob, ro test';
-
-@scratch::an_array = 1..3;
-%scratch::a_hash = 1..4;
-package scratch { reset 'a' }
-is @scratch::an_array, 0, 'resetting an array';
-is %scratch::a_hash, 0, 'resetting a hash';
-
-@scratch::an_array = 1..3;
-%scratch::an_array = 1..4;
-*scratch::an_array = \1;
-package scratch { reset 'a' }
-is @scratch::an_array, 0, 'resetting array in the same gv as a ro scalar';
-is @scratch::an_array, 0, 'resetting a hash in the same gv as a ro scalar';
-is $scratch::an_array, 1, 'reset skips ro scalars in the same gv as av/hv';
-
-for our $z (*_) {
- {
- local *_;
- reset "z";
- $z = 3;
- () = *_{SCALAR};
- no warnings;
- () = "$_"; # used to crash
- }
- is ref\$z, "GLOB", 'reset leaves real-globs-as-scalars as GLOBs';
- is $z, "*main::_", 'And the glob still has the right value';
-}
-
-# This used to crash under threaded builds, because pmops were remembering
-# their stashes by name, rather than by pointer.
-fresh_perl_is( # it crashes more reliably with a smaller script
- 'package bar;
- sub foo {
- m??;
- BEGIN { *baz:: = *bar::; *bar:: = *foo:: }
- # The name "bar" no langer refers to the same package
- }
- undef &foo; # so freeing the op does not remove it from the stash’s list
- $_ = "";
- push @_, ($_) x 10000; # and its memory is scribbled over
- reset; # so reset on the original package tries to reset an invalid op
- print "ok\n";',
- "ok\n", {},
- "no crash if package is effectively renamed before op is freed");
-
-sub _117941 { package _117941; reset }
-delete $::{"_117941::"};
-_117941();
-pass("no crash when current package is freed");
undef $/;
my $prog = <DATA>;
@@ -187,17 +88,17 @@ use strict;
# Note that there are no digits in this program, other than the placeholders
sub a {
-m8one8;
+8one8;
}
sub b {
-m9two9;
+9two9;
}
use threads;
use threads::shared;
sub wipe {
- eval 'no warnings; sub b {}; 1' or die $@;
+ eval 'no warnings; sub b {}';
}
sub lock_then_wipe {
diff --git a/gnu/usr.bin/perl/t/op/smartmatch.t b/gnu/usr.bin/perl/t/op/smartmatch.t
index ed4b3ec88dc..ed41aaa5999 100644
--- a/gnu/usr.bin/perl/t/op/smartmatch.t
+++ b/gnu/usr.bin/perl/t/op/smartmatch.t
@@ -6,20 +6,19 @@ BEGIN {
require './test.pl';
}
use strict;
-use warnings;
-no warnings 'uninitialized';
-no warnings 'experimental::smartmatch';
use Tie::Array;
use Tie::Hash;
+# The feature mechanism is tested in t/lib/feature/smartmatch:
+# This file tests the semantics of the operator, without worrying
+# about feature issues such as scoping etc.
+
# Predeclare vars used in the tests:
-my @empty;
-my %empty;
-my @sparse; $sparse[2] = 2;
+my $deep1 = []; push @$deep1, \$deep1;
+my $deep2 = []; push @$deep2, \$deep2;
-my $deep1 = []; push @$deep1, $deep1;
-my $deep2 = []; push @$deep2, $deep2;
+{my $const = "a constant"; sub a_const () {$const}}
my @nums = (1..10);
tie my @tied_nums, 'Tie::StdArray';
@@ -29,450 +28,147 @@ my %hash = (foo => 17, bar => 23);
tie my %tied_hash, 'Tie::StdHash';
%tied_hash = %hash;
-{
- package Test::Object::NoOverload;
- sub new { bless { key => 1 } }
-}
-
-{
- package Test::Object::StringOverload;
- use overload '""' => sub { "object" }, fallback => 1;
- sub new { bless { key => 1 } }
-}
-
-{
- package Test::Object::WithOverload;
- sub new { bless { key => ($_[1] // 'magic') } }
- use overload '~~' => sub {
- my %hash = %{ $_[0] };
- if ($_[2]) { # arguments reversed ?
- return $_[1] eq reverse $hash{key};
- }
- else {
- return $_[1] eq $hash{key};
- }
- };
- use overload '""' => sub { "stringified" };
- use overload 'eq' => sub {"$_[0]" eq "$_[1]"};
-}
+# Load and run the tests
+my @tests = map [chomp and split /\t+/, $_, 3], grep !/^#/ && /\S/, <DATA>;
+plan tests => 2 * @tests;
-our $ov_obj = Test::Object::WithOverload->new;
-our $ov_obj_2 = Test::Object::WithOverload->new("object");
-our $obj = Test::Object::NoOverload->new;
-our $str_obj = Test::Object::StringOverload->new;
+for my $test (@tests) {
+ my ($yn, $left, $right) = @$test;
-my %refh;
-unless (is_miniperl()) {
- require Tie::RefHash;
- tie %refh, 'Tie::RefHash';
- $refh{$ov_obj} = 1;
+ match_test($yn, $left, $right);
+ match_test($yn, $right, $left);
}
-my @keyandmore = qw(key and more);
-my @fooormore = qw(foo or more);
-my %keyandmore = map { $_ => 0 } @keyandmore;
-my %fooormore = map { $_ => 0 } @fooormore;
+sub match_test {
+ my ($yn, $left, $right) = @_;
-# Load and run the tests
-plan tests => 349;
+ die "Bad test spec: ($yn, $left, $right)"
+ unless $yn eq "" || $yn eq "!";
+
+ my $tstr = "$left ~~ $right";
+
+ my $res;
+ $res = eval $tstr // ""; #/ <- fix syntax colouring
-while (<DATA>) {
- SKIP: {
- next if /^#/ || !/\S/;
- chomp;
- my ($yn, $left, $right, $note) = split /\t+/;
+ die $@ if $@ ne "";
+ ok( ($yn =~ /!/ xor $res), "$tstr: $res");
+}
- local $::TODO = $note =~ /TODO/;
- die "Bad test spec: ($yn, $left, $right)" if $yn =~ /[^!@=]/;
- my $tstr = "$left ~~ $right";
+sub foo {}
+sub bar {2}
+sub fatal {die}
- test_again:
- my $res;
- if ($note =~ /NOWARNINGS/) {
- $res = eval "no warnings; $tstr";
- }
- else {
- skip_if_miniperl("Doesn't work with miniperl", $yn =~ /=/ ? 2 : 1)
- if $note =~ /MINISKIP/;
- $res = eval $tstr;
- }
-
- chomp $@;
-
- if ( $yn =~ /@/ ) {
- ok( $@ ne '', "$tstr dies" )
- and print "# \$\@ was: $@\n";
- } else {
- my $test_name = $tstr . ($yn =~ /!/ ? " does not match" : " matches");
- if ( $@ ne '' ) {
- fail($test_name);
- print "# \$\@ was: $@\n";
- } else {
- ok( ($yn =~ /!/ xor $res), $test_name );
- }
- }
-
- if ( $yn =~ s/=// ) {
- $tstr = "$right ~~ $left";
- goto test_again;
- }
- }
-}
+sub a_const() {die if @_; "a constant"}
+sub b_const() {die if @_; "a constant"}
-sub foo {}
-sub bar {42}
-sub gorch {42}
-sub fatal {die "fatal sub\n"}
-
-# to test constant folding
-sub FALSE() { 0 }
-sub TRUE() { 1 }
-sub NOT_DEF() { undef }
-
-# Prefix character :
-# - expected to match
-# ! - expected to not match
-# @ - expected to be a compilation failure
-# = - expected to match symmetrically (runs test twice)
-# Data types to test :
-# undef
-# Object-overloaded
-# Object
-# Coderef
-# Hash
-# Hashref
-# Array
-# Arrayref
-# Tied arrays and hashes
-# Arrays that reference themselves
-# Regex (// and qr//)
-# Range
-# Num
-# Str
-# Other syntactic items of interest:
-# Constants
-# Values returned by a sub call
__DATA__
-# Any ~~ undef
-! $ov_obj undef
-! $obj undef
-! sub {} undef
-! %hash undef
-! \%hash undef
-! {} undef
-! @nums undef
-! \@nums undef
-! [] undef
-! %tied_hash undef
-! @tied_nums undef
-! $deep1 undef
-! /foo/ undef
-! qr/foo/ undef
-! 21..30 undef
-! 189 undef
-! "foo" undef
-! "" undef
-! !1 undef
- undef undef
- (my $u) undef
- NOT_DEF undef
- &NOT_DEF undef
-
-# Any ~~ object overloaded
-! \&fatal $ov_obj
- 'cigam' $ov_obj
-! 'cigam on' $ov_obj
-! ['cigam'] $ov_obj
-! ['stringified'] $ov_obj
-! { cigam => 1 } $ov_obj
-! { stringified => 1 } $ov_obj
-! $obj $ov_obj
-! undef $ov_obj
-
-# regular object
-@ $obj $obj
-@ $ov_obj $obj
-=@ \&fatal $obj
-@ \&FALSE $obj
-@ \&foo $obj
-@ sub { 1 } $obj
-@ sub { 0 } $obj
-@ %keyandmore $obj
-@ {"key" => 1} $obj
-@ @fooormore $obj
-@ ["key" => 1] $obj
-@ /key/ $obj
-@ qr/key/ $obj
-@ "key" $obj
-@ FALSE $obj
-
-# regular object with "" overload
-@ $obj $str_obj
-=@ \&fatal $str_obj
-@ \&FALSE $str_obj
-@ \&foo $str_obj
-@ sub { 1 } $str_obj
-@ sub { 0 } $str_obj
-@ %keyandmore $str_obj
-@ {"object" => 1} $str_obj
-@ @fooormore $str_obj
-@ ["object" => 1] $str_obj
-@ /object/ $str_obj
-@ qr/object/ $str_obj
-@ "object" $str_obj
-@ FALSE $str_obj
-# Those will treat the $str_obj as a string because of fallback:
-
-# object (overloaded or not) ~~ Any
- $obj qr/NoOverload/
- $ov_obj qr/^stringified$/
-= "$ov_obj" "stringified"
-= "$str_obj" "object"
-!= $ov_obj "stringified"
- $str_obj "object"
- $ov_obj 'magic'
-! $ov_obj 'not magic'
-
-# ~~ Coderef
- sub{0} sub { ref $_[0] eq "CODE" }
- %fooormore sub { $_[0] =~ /^(foo|or|more)$/ }
-! %fooormore sub { $_[0] =~ /^(foo|or|less)$/ }
- \%fooormore sub { $_[0] =~ /^(foo|or|more)$/ }
-! \%fooormore sub { $_[0] =~ /^(foo|or|less)$/ }
- +{%fooormore} sub { $_[0] =~ /^(foo|or|more)$/ }
-! +{%fooormore} sub { $_[0] =~ /^(foo|or|less)$/ }
- @fooormore sub { $_[0] =~ /^(foo|or|more)$/ }
-! @fooormore sub { $_[0] =~ /^(foo|or|less)$/ }
- \@fooormore sub { $_[0] =~ /^(foo|or|more)$/ }
-! \@fooormore sub { $_[0] =~ /^(foo|or|less)$/ }
- [@fooormore] sub { $_[0] =~ /^(foo|or|more)$/ }
-! [@fooormore] sub { $_[0] =~ /^(foo|or|less)$/ }
- %fooormore sub{@_==1}
- @fooormore sub{@_==1}
- "foo" sub { $_[0] =~ /^(foo|or|more)$/ }
-! "more" sub { $_[0] =~ /^(foo|or|less)$/ }
- /fooormore/ sub{ref $_[0] eq 'Regexp'}
- qr/fooormore/ sub{ref $_[0] eq 'Regexp'}
+# CODE ref against argument
+# - arg is code ref
+ \&foo \&foo
+! \&foo sub {}
+! \&foo \&bar
+
+# - arg is not code ref
1 sub{shift}
! 0 sub{shift}
-! undef sub{shift}
- undef sub{not shift}
- NOT_DEF sub{not shift}
- &NOT_DEF sub{not shift}
- FALSE sub{not shift}
- [1] \&bar
- {a=>1} \&bar
+ 1 sub{scalar @_}
+ [] \&bar
+ {} \&bar
qr// \&bar
-! [1] \&foo
-! {a=>1} \&foo
- $obj sub { ref($_[0]) =~ /NoOverload/ }
- $ov_obj sub { ref($_[0]) =~ /WithOverload/ }
-# empty stuff matches, because the sub is never called:
- [] \&foo
- {} \&foo
- @empty \&foo
- %empty \&foo
-! qr// \&foo
-! undef \&foo
- undef \&bar
-@ undef \&fatal
-@ 1 \&fatal
-@ [1] \&fatal
-@ {a=>1} \&fatal
-@ "foo" \&fatal
-@ qr// \&fatal
-# sub is not called on empty hashes / arrays
- [] \&fatal
- +{} \&fatal
- @empty \&fatal
- %empty \&fatal
-# sub is not special on the left
- sub {0} qr/^CODE/
- sub {0} sub { ref shift eq "CODE" }
+
+# - null-prototyped subs
+ a_const "a constant"
+ a_const a_const
+ a_const b_const
# HASH ref against:
# - another hash ref
{} {}
-=! {} {1 => 2}
+! {} {1 => 2}
{1 => 2} {1 => 2}
{1 => 2} {1 => 3}
-=! {1 => 2} {2 => 3}
-= \%main:: {map {$_ => 'x'} keys %main::}
+! {1 => 2} {2 => 3}
+ \%main:: {map {$_ => 'x'} keys %main::}
# - tied hash ref
-= \%hash \%tied_hash
+ \%hash \%tied_hash
\%tied_hash \%tied_hash
-!= {"a"=>"b"} \%tied_hash
-= %hash %tied_hash
- %tied_hash %tied_hash
-!= {"a"=>"b"} %tied_hash
- $ov_obj %refh MINISKIP
-! "$ov_obj" %refh MINISKIP
- [$ov_obj] %refh MINISKIP
-! ["$ov_obj"] %refh MINISKIP
- %refh %refh MINISKIP
# - an array ref
-# (since this is symmetrical, tests as well hash~~array)
-= [keys %main::] \%::
-= [qw[STDIN STDOUT]] \%::
-=! [] \%::
-=! [""] {}
-=! [] {}
-=! @empty {}
-= [undef] {"" => 1}
-= [""] {"" => 1}
-= ["foo"] { foo => 1 }
-= ["foo", "bar"] { foo => 1 }
-= ["foo", "bar"] \%hash
-= ["foo"] \%hash
-=! ["quux"] \%hash
-= [qw(foo quux)] \%hash
-= @fooormore { foo => 1, or => 2, more => 3 }
-= @fooormore %fooormore
-= @fooormore \%fooormore
-= \@fooormore %fooormore
+ \%:: [keys %main::]
+! \%:: []
+ {"" => 1} [undef]
+ { foo => 1 } ["foo"]
+ { foo => 1 } ["foo", "bar"]
+ \%hash ["foo", "bar"]
+ \%hash ["foo"]
+! \%hash ["quux"]
+ \%hash [qw(foo quux)]
# - a regex
-= qr/^(fo[ox])$/ {foo => 1}
-= /^(fo[ox])$/ %fooormore
-=! qr/[13579]$/ +{0..99}
-=! qr/a*/ {}
-= qr/a*/ {b=>2}
-= qr/B/i {b=>2}
-= /B/i {b=>2}
-=! qr/a+/ {b=>2}
-= qr/^à/ {"à"=>2}
-
-# - a scalar
- "foo" +{foo => 1, bar => 2}
- "foo" %fooormore
-! "baz" +{foo => 1, bar => 2}
-! "boz" %fooormore
-! 1 +{foo => 1, bar => 2}
-! 1 %fooormore
- 1 { 1 => 3 }
- 1.0 { 1 => 3 }
-! "1.0" { 1 => 3 }
-! "1.0" { 1.0 => 3 }
- "1.0" { "1.0" => 3 }
- "à" { "à" => "À" }
-
-# - undef
-! undef { hop => 'zouu' }
-! undef %hash
-! undef +{"" => "empty key"}
-! undef {}
+ {foo => 1} qr/^(fo[ox])$/
+! +{0..100} qr/[13579]$/
+
+# - a string
+ +{foo => 1, bar => 2} "foo"
+! +{foo => 1, bar => 2} "baz"
+
# ARRAY ref against:
# - another array ref
- [] []
-=! [] [1]
+ [] []
+! [] [1]
[["foo"], ["bar"]] [qr/o/, qr/a/]
-! [["foo"], ["bar"]] [qr/ARRAY/, qr/ARRAY/]
["foo", "bar"] [qr/o/, qr/a/]
-! [qr/o/, qr/a/] ["foo", "bar"]
- ["foo", "bar"] [["foo"], ["bar"]]
! ["foo", "bar"] [qr/o/, "foo"]
- ["foo", undef, "bar"] [qr/o/, undef, "bar"]
-! ["foo", undef, "bar"] [qr/o/, "", "bar"]
-! ["foo", "", "bar"] [qr/o/, undef, "bar"]
- $deep1 $deep1
- @$deep1 @$deep1
-! $deep1 $deep2
-
-= \@nums \@tied_nums
-= @nums \@tied_nums
-= \@nums @tied_nums
-= @nums @tied_nums
-
-# - an object
-! $obj @fooormore
- $obj [sub{ref shift}]
+ $deep1 $deep1
+! $deep1 $deep2
+
+ \@nums \@tied_nums
# - a regex
-= qr/x/ [qw(foo bar baz quux)]
-=! qr/y/ [qw(foo bar baz quux)]
-= /x/ [qw(foo bar baz quux)]
-=! /y/ [qw(foo bar baz quux)]
-= /FOO/i @fooormore
-=! /bar/ @fooormore
+ [qw(foo bar baz quux)] qr/x/
+! [qw(foo bar baz quux)] qr/y/
# - a number
- 2 [qw(1.00 2.00)]
- 2 [qw(foo 2)]
- 2.0_0e+0 [qw(foo 2)]
-! 2 [qw(1foo bar2)]
+ [qw(1foo 2bar)] 2
# - a string
-! "2" [qw(1foo 2bar)]
- "2bar" [qw(1foo 2bar)]
-
-# - undef
- undef [1, 2, undef, 4]
-! undef [1, 2, [undef], 4]
-! undef @fooormore
- undef @sparse
- undef [undef]
-! 0 [undef]
-! "" [undef]
-! undef [0]
-! undef [""]
-
-# - nested arrays and ~~ distributivity
- 11 [[11]]
-! 11 [[12]]
- "foo" [{foo => "bar"}]
-! "bar" [{foo => "bar"}]
+! [qw(1foo 2bar)] "2"
# Number against number
2 2
- 20 2_0
! 2 3
- 0 FALSE
- 3-2 TRUE
-! undef 0
-! (my $u) 0
# Number against string
-= 2 "2"
-= 2 "2.0"
+ 2 "2"
+ 2 "2.0"
! 2 "2bananas"
-!= 2_3 "2_3" NOWARNINGS
- FALSE "0"
-! undef "0"
-! undef ""
+! 2_3 "2_3"
# Regex against string
- "x" qr/x/
-! "x" qr/y/
+ qr/x/ "x"
+! qr/y/ "x"
# Regex against number
12345 qr/3/
-! 12345 qr/7/
-# array/hash against string
- @fooormore "".\@fooormore
-! @keyandmore "".\@fooormore
- %fooormore "".\%fooormore
-! %keyandmore "".\%fooormore
# Test the implicit referencing
- 7 @nums
+ @nums 7
@nums \@nums
! @nums \\@nums
@nums [1..10]
! @nums [0..9]
- "foo" %hash
- /bar/ %hash
- [qw(bar)] %hash
-! [qw(a b c)] %hash
+ %hash "foo"
+ %hash /bar/
+ %hash [qw(bar)]
+! %hash [qw(a b c)]
%hash %hash
- %hash +{%hash}
- %hash \%hash
+ %hash {%hash}
%hash %tied_hash
%tied_hash %tied_hash
%hash { foo => 5, bar => 10 }
@@ -481,42 +177,3 @@ __DATA__
@nums { 1, '', 2, '' }
@nums { 1, '', 12, '' }
! @nums { 11, '', 12, '' }
-
-# array slices
- @nums[0..-1] []
- @nums[0..0] [1]
-! @nums[0..1] [0..2]
- @nums[0..4] [1..5]
-
-! undef @nums[0..-1]
- 1 @nums[0..0]
- 2 @nums[0..1]
-! @nums[0..1] 2
-
- @nums[0..1] @nums[0..1]
-
-# hash slices
- @keyandmore{qw(not)} [undef]
- @keyandmore{qw(key)} [0]
-
- undef @keyandmore{qw(not)}
- 0 @keyandmore{qw(key and more)}
-! 2 @keyandmore{qw(key and)}
-
- @fooormore{qw(foo)} @keyandmore{qw(key)}
- @fooormore{qw(foo or more)} @keyandmore{qw(key and more)}
-
-# UNDEF
-! 3 undef
-! 1 undef
-! [] undef
-! {} undef
-! \%::main undef
-! [1,2] undef
-! %hash undef
-! @nums undef
-! "foo" undef
-! "" undef
-! !1 undef
-! \&foo undef
-! sub { } undef
diff --git a/gnu/usr.bin/perl/t/op/state.t b/gnu/usr.bin/perl/t/op/state.t
index 81e5486867a..411ffaa30ee 100644
--- a/gnu/usr.bin/perl/t/op/state.t
+++ b/gnu/usr.bin/perl/t/op/state.t
@@ -8,15 +8,9 @@ BEGIN {
}
use strict;
-
-plan tests => 137;
-
-# Before loading feature.pm, test it with CORE::
-ok eval 'CORE::state $x = 1;', 'CORE::state outside of feature.pm scope';
-
-
use feature ":5.10";
+plan tests => 123;
ok( ! defined state $uninit, q(state vars are undef by default) );
@@ -211,7 +205,6 @@ my $first = $stones [0];
my $First = ucfirst $first;
$_ = "bambam";
foreach my $flint (@stones) {
- no warnings 'experimental::lexical_topic';
state $_ = $flint;
is $_, $first, 'state $_';
ok /$first/, '/.../ binds to $_';
@@ -229,9 +222,9 @@ again:
is $simpson, 'Homer', 'goto 1';
goto again if @simpsons;
+goto Elvis;
my $vi;
{
- goto Elvis unless $vi;
state $calvin = ++ $vi;
Elvis: state $vile = ++ $vi;
redo unless defined $calvin;
@@ -312,7 +305,6 @@ foreach my $x (0 .. 4) {
#
my @spam = qw [spam ham bacon beans];
foreach my $spam (@spam) {
- no warnings 'experimental::smartmatch';
given (state $spam = $spam) {
when ($spam [0]) {ok 1, "given"}
default {ok 0, "given"}
@@ -362,99 +354,6 @@ foreach my $forbidden (<DATA>) {
eval $forbidden;
like $@, qr/Initialization of state variables in list context currently forbidden/, "Currently forbidden: $forbidden";
}
-
-# [perl #49522] state variable not available
-
-{
- my @warnings;
- local $SIG{__WARN__} = sub { push @warnings, $_[0] };
-
- eval q{
- use warnings;
-
- sub f_49522 {
- state $s = 88;
- sub g_49522 { $s }
- sub { $s };
- }
-
- sub h_49522 {
- state $t = 99;
- sub i_49522 {
- sub { $t };
- }
- }
- };
- is $@, '', "eval f_49522";
- # shouldn't be any 'not available' or 'not stay shared' warnings
- ok !@warnings, "suppress warnings part 1 [@warnings]";
-
- @warnings = ();
- my $f = f_49522();
- is $f->(), 88, "state var closure 1";
- is g_49522(), 88, "state var closure 2";
- ok !@warnings, "suppress warnings part 2 [@warnings]";
-
-
- @warnings = ();
- $f = i_49522();
- h_49522(); # initialise $t
- is $f->(), 99, "state var closure 3";
- ok !@warnings, "suppress warnings part 3 [@warnings]";
-
-
-}
-
-
-# [perl #117095] state var initialisation getting skipped
-# the 'if 0' code below causes a call to op_free at compile-time,
-# which used to inadvertently mark the state var as initialised.
-
-{
- state $f = 1;
- foo($f) if 0; # this calls op_free on padmy($f)
- ok(defined $f, 'state init not skipped');
-}
-
-# [perl #121134] Make sure padrange doesn't mess with these
-{
- sub thing {
- my $expect = shift;
- my ($x, $y);
- state $z;
-
- is($z, $expect, "State variable is correct");
-
- $z = 5;
- }
-
- thing(undef);
- thing(5);
-
- sub thing2 {
- my $expect = shift;
- my $x;
- my $y;
- state $z;
-
- is($z, $expect, "State variable is correct");
-
- $z = 6;
- }
-
- thing2(undef);
- thing2(6);
-}
-
-# [perl #123029] regression in "state" under PERL_NO_COW
-sub rt_123029 {
- state $s;
- $s = 'foo'x500;
- my $c = $s;
- return defined $s;
-}
-ok(rt_123029(), "state variables don't surprisingly disappear when accessed");
-
__DATA__
state ($a) = 1;
(state $a) = 1;
diff --git a/gnu/usr.bin/perl/t/op/switch.t b/gnu/usr.bin/perl/t/op/switch.t
index 204a57a999e..d897157946a 100644
--- a/gnu/usr.bin/perl/t/op/switch.t
+++ b/gnu/usr.bin/perl/t/op/switch.t
@@ -3,28 +3,20 @@
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
- require './test.pl';
}
use strict;
use warnings;
-no warnings 'experimental::smartmatch';
-plan tests => 201;
+use Test::More tests => 108;
-# The behaviour of the feature pragma should be tested by lib/feature.t
-# using the tests in t/lib/feature/*. This file tests the behaviour of
+# The behaviour of the feature pragma should be tested by lib/switch.t
+# using the tests in t/lib/switch/*. This file tests the behaviour of
# the switch ops themselves.
-
-
-# Before loading feature, test the switch ops with CORE::
-CORE::given(3) {
- CORE::when(3) { pass "CORE::given and CORE::when"; continue }
- CORE::default { pass "continue (without feature) and CORE::default" }
-}
-
+
use feature 'switch';
+no warnings "numeric";
eval { continue };
like($@, qr/^Can't "continue" outside/, "continue outside");
@@ -53,10 +45,9 @@ given(my $x = "foo") {
$_ = "outside";
given("inside") { check_outside1() }
-sub check_outside1 { is($_, "inside", "\$_ is not lexically scoped") }
+sub check_outside1 { is($_, "outside", "\$_ lexically scoped") }
{
- no warnings 'experimental::lexical_topic';
my $_ = "outside";
given("inside") { check_outside2() }
sub check_outside2 {
@@ -142,13 +133,11 @@ sub check_outside1 { is($_, "inside", "\$_ is not lexically scoped") }
is($ok, 1, "Given(0) when($undef++)");
}
{
- no warnings "uninitialized";
my $ok = 1;
given (undef) { when(0) {$ok = 0} }
is($ok, 1, "Given(undef) when(0)");
}
{
- no warnings "uninitialized";
my $undef;
my $ok = 1;
given ($undef) { when(0) {$ok = 0} }
@@ -167,13 +156,11 @@ sub check_outside1 { is($_, "inside", "\$_ is not lexically scoped") }
is($ok, 1, 'Given("") when($undef)');
}
{
- no warnings "uninitialized";
my $ok = 1;
given (undef) { when("") {$ok = 0} }
is($ok, 1, 'Given(undef) when("")');
}
{
- no warnings "uninitialized";
my $undef;
my $ok = 1;
given ($undef) { when("") {$ok = 0} }
@@ -399,7 +386,6 @@ sub check_outside1 { is($_, "inside", "\$_ is not lexically scoped") }
# Make sure it still works with a lexical $_:
{
- no warnings 'experimental::lexical_topic';
my $_;
my $test = "explicit comparison with lexical \$_";
my $twenty_five = 25;
@@ -424,15 +410,6 @@ sub check_outside1 { is($_, "inside", "\$_ is not lexically scoped") }
is($ok, 'y', "Optimized-away comparison");
}
-{
- my $ok;
- given(23) {
- when (scalar 24) { $ok = 'n'; continue }
- default { $ok = 'y' }
- }
- is($ok,'y','scalar()');
-}
-
# File tests
# (How to be both thorough and portable? Pinch a few ideas
# from t/op/filetest.t. We err on the side of portability for
@@ -451,11 +428,11 @@ sub check_outside1 { is($_, "inside", "\$_ is not lexically scoped") }
}
# Sub and method calls
-sub notfoo {"bar"}
+sub bar {"bar"}
{
my $ok = 0;
given("foo") {
- when(notfoo()) {$ok = 1}
+ when(bar()) {$ok = 1}
}
ok($ok, "Sub call acts as boolean")
}
@@ -463,7 +440,7 @@ sub notfoo {"bar"}
{
my $ok = 0;
given("foo") {
- when(main->notfoo()) {$ok = 1}
+ when(main->bar()) {$ok = 1}
}
ok($ok, "Class-method call acts as boolean")
}
@@ -472,7 +449,7 @@ sub notfoo {"bar"}
my $ok = 0;
my $obj = bless [];
given("foo") {
- when($obj->notfoo()) {$ok = 1}
+ when($obj->bar()) {$ok = 1}
}
ok($ok, "Object-method call acts as boolean")
}
@@ -533,28 +510,6 @@ sub notfoo {"bar"}
}
{
- my $n = 0;
- for my $l (qw(a b c d)) {
- given ($l) {
- when ($_ eq "b" .. $_ eq "c") { $n = 1 }
- default { $n = 0 }
- }
- ok(($n xor $l =~ /[ad]/), 'when(E1..E2) evaluates in boolean context');
- }
-}
-
-{
- my $n = 0;
- for my $l (qw(a b c d)) {
- given ($l) {
- when ($_ eq "b" ... $_ eq "c") { $n = 1 }
- default { $n = 0 }
- }
- ok(($n xor $l =~ /[ad]/), 'when(E1...E2) evaluates in boolean context');
- }
-}
-
-{
my $ok = 0;
given("foo") {
when((1 == $ok) || "foo") {
@@ -564,15 +519,6 @@ sub notfoo {"bar"}
ok($ok, '((1 == $ok) || "foo") smartmatched');
}
-{
- my $ok = 0;
- given("foo") {
- when((1 == $ok || undef) // "foo") {
- $ok = 1;
- }
- }
- ok($ok, '((1 == $ok || undef) // "foo") smartmatched');
-}
# Make sure we aren't invoking the get-magic more than once
@@ -601,7 +547,7 @@ sub notfoo {"bar"}
my $f = tie my $v, "FetchCounter";
-{ my $test_name = "Multiple FETCHes in given, due to aliasing";
+{ my $test_name = "Only one FETCH (in given)";
my $ok;
given($v = 23) {
when(undef) {}
@@ -612,7 +558,7 @@ my $f = tie my $v, "FetchCounter";
when(/24/) {$ok = 0}
}
is($ok, 1, "precheck: $test_name");
- is($f->count(), 4, $test_name);
+ is($f->count(), 1, $test_name);
}
{ my $test_name = "Only one FETCH (numeric when)";
@@ -651,7 +597,6 @@ my $f = tie my $v, "FetchCounter";
my $ok;
$v = undef;
is($f->count(), 0, "Sanity check: $test_name");
- no warnings "uninitialized";
given(my $undef) {
when(sub{0}->()) {}
when("21") {}
@@ -700,7 +645,6 @@ my $f = tie my $v, "FetchCounter";
{
my $first = 1;
- no warnings 'experimental::lexical_topic';
my $_;
for (1, "two") {
when ("two") {
@@ -719,7 +663,6 @@ my $f = tie my $v, "FetchCounter";
{
my $first = 1;
- no warnings 'experimental::lexical_topic';
my $_;
for $_ (1, "two") {
when ("two") {
@@ -738,7 +681,6 @@ my $f = tie my $v, "FetchCounter";
{
my $first = 1;
- no warnings 'experimental::lexical_topic';
for my $_ (1, "two") {
when ("two") {
is($first, 0, "Lexical loop: second");
@@ -747,7 +689,7 @@ my $f = tie my $v, "FetchCounter";
q{Can't "break" in a loop topicalizer});
}
when (1) {
- is($first, 1, "Lexical loop: first");
+ is($first, 1, "Lecical loop: first");
$first = 0;
# Implicit break is okay
}
@@ -757,19 +699,20 @@ my $f = tie my $v, "FetchCounter";
# Code references
{
+ no warnings "redefine";
my $called_foo = 0;
- sub foo {$called_foo = 1; "@_" eq "foo"}
+ sub foo {$called_foo = 1}
my $called_bar = 0;
- sub bar {$called_bar = 1; "@_" eq "bar"}
+ sub bar {$called_bar = 1}
my ($matched_foo, $matched_bar) = (0, 0);
- given("foo") {
+ given(\&foo) {
when(\&bar) {$matched_bar = 1}
when(\&foo) {$matched_foo = 1}
}
- is($called_foo, 1, "foo() was called");
- is($called_bar, 1, "bar() was called");
- is($matched_bar, 0, "bar didn't match");
- is($matched_foo, 1, "foo did match");
+ is($called_foo, 0, "Code ref comparison: foo not called");
+ is($called_bar, 0, "Code ref comparison: bar not called");
+ is($matched_bar, 0, "Code ref didn't match different one");
+ is($matched_foo, 1, "Code ref did match itself");
}
sub contains_x {
@@ -797,609 +740,98 @@ sub contains_x {
is($ok2, 1, "Calling sub indirectly (false)");
}
-SKIP: {
- skip_if_miniperl("no dynamic loading on miniperl, no Scalar::Util", 14);
- # Test overloading
- { package OverloadTest;
-
- use overload '""' => sub{"string value of obj"};
- use overload 'eq' => sub{"$_[0]" eq "$_[1]"};
-
- use overload "~~" => sub {
- my ($self, $other, $reversed) = @_;
- if ($reversed) {
- $self->{left} = $other;
- $self->{right} = $self;
- $self->{reversed} = 1;
- } else {
- $self->{left} = $self;
- $self->{right} = $other;
- $self->{reversed} = 0;
- }
- $self->{called} = 1;
- return $self->{retval};
- };
-
- sub new {
- my ($pkg, $retval) = @_;
- bless {
- called => 0,
- retval => $retval,
- }, $pkg;
- }
- }
-
- {
- my $test = "Overloaded obj in given (true)";
- my $obj = OverloadTest->new(1);
- my $matched;
- given($obj) {
- when ("other arg") {$matched = 1}
- default {$matched = 0}
- }
-
- is($obj->{called}, 1, "$test: called");
- ok($matched, "$test: matched");
- }
-
- {
- my $test = "Overloaded obj in given (false)";
- my $obj = OverloadTest->new(0);
- my $matched;
- given($obj) {
- when ("other arg") {$matched = 1}
- }
-
- is($obj->{called}, 1, "$test: called");
- ok(!$matched, "$test: not matched");
- }
+# Test overloading
+{ package OverloadTest;
- {
- my $test = "Overloaded obj in when (true)";
- my $obj = OverloadTest->new(1);
- my $matched;
- given("topic") {
- when ($obj) {$matched = 1}
- default {$matched = 0}
- }
-
- is($obj->{called}, 1, "$test: called");
- ok($matched, "$test: matched");
- is($obj->{left}, "topic", "$test: left");
- is($obj->{right}, "string value of obj", "$test: right");
- ok($obj->{reversed}, "$test: reversed");
- }
+ use overload '""' => sub{"string value of obj"};
- {
- my $test = "Overloaded obj in when (false)";
- my $obj = OverloadTest->new(0);
- my $matched;
- given("topic") {
- when ($obj) {$matched = 1}
- default {$matched = 0}
- }
+ use overload "~~" => sub {
+ my ($self, $other, $reversed) = @_;
+ if ($reversed) {
+ $self->{left} = $other;
+ $self->{right} = $self;
+ $self->{reversed} = 1;
+ } else {
+ $self->{left} = $self;
+ $self->{right} = $other;
+ $self->{reversed} = 0;
+ }
+ $self->{called} = 1;
+ return $self->{retval};
+ };
- is($obj->{called}, 1, "$test: called");
- ok(!$matched, "$test: not matched");
- is($obj->{left}, "topic", "$test: left");
- is($obj->{right}, "string value of obj", "$test: right");
- ok($obj->{reversed}, "$test: reversed");
- }
-}
-
-# Postfix when
-{
- my $ok;
- given (undef) {
- $ok = 1 when undef;
- }
- is($ok, 1, "postfix undef");
-}
-{
- my $ok;
- given (2) {
- $ok += 1 when 7;
- $ok += 2 when 9.1685;
- $ok += 4 when $_ > 4;
- $ok += 8 when $_ < 2.5;
- }
- is($ok, 8, "postfix numeric");
-}
-{
- my $ok;
- given ("apple") {
- $ok = 1, continue when $_ eq "apple";
- $ok += 2;
- $ok = 0 when "banana";
- }
- is($ok, 3, "postfix string");
-}
-{
- my $ok;
- given ("pear") {
- do { $ok = 1; continue } when /pea/;
- $ok += 2;
- $ok = 0 when /pie/;
- default { $ok += 4 }
- $ok = 0;
- }
- is($ok, 7, "postfix regex");
-}
-# be_true is defined at the beginning of the file
-{
- my $x = "what";
- given(my $x = "foo") {
- do {
- is($x, "foo", "scope inside ... when my \$x = ...");
- continue;
- } when be_true(my $x = "bar");
- is($x, "bar", "scope after ... when my \$x = ...");
- }
-}
-{
- my $x = 0;
- given(my $x = 1) {
- my $x = 2, continue when be_true();
- is($x, undef, "scope after my \$x = ... when ...");
+ sub new {
+ my ($pkg, $retval) = @_;
+ bless {
+ called => 0,
+ retval => $retval,
+ }, $pkg;
}
}
-# Tests for last and next in when clauses
-my $letter;
-
-$letter = '';
-for ("a".."e") {
- given ($_) {
- $letter = $_;
- when ("b") { last }
- }
- $letter = "z";
-}
-is($letter, "b", "last in when");
-
-$letter = '';
-LETTER1: for ("a".."e") {
- given ($_) {
- $letter = $_;
- when ("b") { last LETTER1 }
- }
- $letter = "z";
-}
-is($letter, "b", "last LABEL in when");
-
-$letter = '';
-for ("a".."e") {
- given ($_) {
- when (/b|d/) { next }
- $letter .= $_;
- }
- $letter .= ',';
-}
-is($letter, "a,c,e,", "next in when");
-
-$letter = '';
-LETTER2: for ("a".."e") {
- given ($_) {
- when (/b|d/) { next LETTER2 }
- $letter .= $_;
- }
- $letter .= ',';
-}
-is($letter, "a,c,e,", "next LABEL in when");
-
-# Test goto with given/when
-{
- my $flag = 0;
- goto GIVEN1;
- $flag = 1;
- GIVEN1: given ($flag) {
- when (0) { break; }
- $flag = 2;
- }
- is($flag, 0, "goto GIVEN1");
-}
-{
- my $flag = 0;
- given ($flag) {
- when (0) { $flag = 1; }
- goto GIVEN2;
- $flag = 2;
- }
-GIVEN2:
- is($flag, 1, "goto inside given");
-}
-{
- my $flag = 0;
- given ($flag) {
- when (0) { $flag = 1; goto GIVEN3; $flag = 2; }
- $flag = 3;
- }
-GIVEN3:
- is($flag, 1, "goto inside given and when");
-}
{
- my $flag = 0;
- for ($flag) {
- when (0) { $flag = 1; goto GIVEN4; $flag = 2; }
- $flag = 3;
- }
-GIVEN4:
- is($flag, 1, "goto inside for and when");
-}
-{
- my $flag = 0;
-GIVEN5:
- given ($flag) {
- when (0) { $flag = 1; goto GIVEN5; $flag = 2; }
- when (1) { break; }
- $flag = 3;
- }
- is($flag, 1, "goto inside given and when to the given stmt");
-}
-
-# test with unreified @_ in smart match [perl #71078]
-sub unreified_check { ok([@_] ~~ \@_) } # should always match
-unreified_check(1,2,"lala");
-unreified_check(1,2,undef);
-unreified_check(undef);
-unreified_check(undef,"");
-
-# Test do { given } as a rvalue
-
-{
- # Simple scalar
- my $lexical = 5;
- my @things = (11 .. 26); # 16 elements
- my @exp = (5, 16, 9);
- no warnings 'void';
- for (0, 1, 2) {
- my $scalar = do { given ($_) {
- when (0) { $lexical }
- when (2) { 'void'; 8, 9 }
- @things;
- } };
- is($scalar, shift(@exp), "rvalue given - simple scalar [$_]");
- }
-}
-{
- # Postfix scalar
- my $lexical = 5;
- my @exp = (5, 7, 9);
- for (0, 1, 2) {
- no warnings 'void';
- my $scalar = do { given ($_) {
- $lexical when 0;
- 8, 9 when 2;
- 6, 7;
- } };
- is($scalar, shift(@exp), "rvalue given - postfix scalar [$_]");
- }
-}
-{
- # Default scalar
- my @exp = (5, 9, 9);
- for (0, 1, 2) {
- my $scalar = do { given ($_) {
- no warnings 'void';
- when (0) { 5 }
- default { 8, 9 }
- 6, 7;
- } };
- is($scalar, shift(@exp), "rvalue given - default scalar [$_]");
- }
-}
-{
- # Simple list
- my @things = (11 .. 13);
- my @exp = ('3 4 5', '11 12 13', '8 9');
- for (0, 1, 2) {
- my @list = do { given ($_) {
- when (0) { 3 .. 5 }
- when (2) { my $fake = 'void'; 8, 9 }
- @things;
- } };
- is("@list", shift(@exp), "rvalue given - simple list [$_]");
- }
-}
-{
- # Postfix list
- my @things = (12);
- my @exp = ('3 4 5', '6 7', '12');
- for (0, 1, 2) {
- my @list = do { given ($_) {
- 3 .. 5 when 0;
- @things when 2;
- 6, 7;
- } };
- is("@list", shift(@exp), "rvalue given - postfix list [$_]");
- }
-}
-{
- # Default list
- my @things = (11 .. 20); # 10 elements
- my @exp = ('m o o', '8 10', '8 10');
- for (0, 1, 2) {
- my @list = do { given ($_) {
- when (0) { "moo" =~ /(.)/g }
- default { 8, scalar(@things) }
- 6, 7;
- } };
- is("@list", shift(@exp), "rvalue given - default list [$_]");
- }
-}
-{
- # Switch control
- my @exp = ('6 7', '', '6 7');
- for (0, 1, 2, 3) {
- my @list = do { given ($_) {
- continue when $_ <= 1;
- break when 1;
- next when 2;
- 6, 7;
- } };
- is("@list", shift(@exp), "rvalue given - default list [$_]");
- }
-}
-{
- # Context propagation
- my $smart_hash = sub {
- do { given ($_[0]) {
- 'undef' when undef;
- when ([ 1 .. 3 ]) { 1 .. 3 }
- when (4) { my $fake; do { 4, 5 } }
- } };
- };
-
- my $scalar;
-
- $scalar = $smart_hash->();
- is($scalar, 'undef', "rvalue given - scalar context propagation [undef]");
-
- $scalar = $smart_hash->(4);
- is($scalar, 5, "rvalue given - scalar context propagation [4]");
-
- $scalar = $smart_hash->(999);
- is($scalar, undef, "rvalue given - scalar context propagation [999]");
-
- my @list;
-
- @list = $smart_hash->();
- is("@list", 'undef', "rvalue given - list context propagation [undef]");
-
- @list = $smart_hash->(2);
- is("@list", '1 2 3', "rvalue given - list context propagation [2]");
-
- @list = $smart_hash->(4);
- is("@list", '4 5', "rvalue given - list context propagation [4]");
-
- @list = $smart_hash->(999);
- is("@list", '', "rvalue given - list context propagation [999]");
-}
-{
- # Array slices
- my @list = 10 .. 15;
- my @in_list;
- my @in_slice;
- for (5, 10, 15) {
- given ($_) {
- when (@list) {
- push @in_list, $_;
- continue;
- }
- when (@list[0..2]) {
- push @in_slice, $_;
- }
- }
- }
- is("@in_list", "10 15", "when(array)");
- is("@in_slice", "10", "when(array slice)");
-}
-{
- # Hash slices
- my %list = map { $_ => $_ } "a" .. "f";
- my @in_list;
- my @in_slice;
- for ("a", "e", "i") {
- given ($_) {
- when (%list) {
- push @in_list, $_;
- continue;
- }
- when (@list{"a".."c"}) {
- push @in_slice, $_;
- }
- }
- }
- is("@in_list", "a e", "when(hash)");
- is("@in_slice", "a", "when(hash slice)");
-}
-
-{ # RT#84526 - Handle magical TARG
- my $x = my $y = "aaa";
- for ($x, $y) {
- given ($_) {
- is(pos, undef, "handle magical TARG");
- pos = 1;
- }
+ my $test = "Overloaded obj in given (true)";
+ my $obj = OverloadTest->new(1);
+ my $matched;
+ given($obj) {
+ when ("other arg") {$matched = 1}
+ default {$matched = 0}
}
+
+ is($obj->{called}, 1, "$test: called");
+ ok($matched, "$test: matched");
+ is($obj->{left}, "string value of obj", "$test: left");
+ is($obj->{right}, "other arg", "$test: right");
+ ok(!$obj->{reversed}, "$test: not reversed");
}
-# Test that returned values are correctly propagated through several context
-# levels (see RT #93548).
{
- my $tester = sub {
- my $id = shift;
-
- package fmurrr;
-
- our ($when_loc, $given_loc, $ext_loc);
-
- my $ext_lex = 7;
- our $ext_glob = 8;
- local $ext_loc = 9;
-
- given ($id) {
- my $given_lex = 4;
- our $given_glob = 5;
- local $given_loc = 6;
-
- when (0) { 0 }
-
- when (1) { my $when_lex = 1 }
- when (2) { our $when_glob = 2 }
- when (3) { local $when_loc = 3 }
-
- when (4) { $given_lex }
- when (5) { $given_glob }
- when (6) { $given_loc }
-
- when (7) { $ext_lex }
- when (8) { $ext_glob }
- when (9) { $ext_loc }
-
- 'fallback';
- }
- };
-
- my @descriptions = qw<
- constant
-
- when-lexical
- when-global
- when-local
-
- given-lexical
- given-global
- given-local
-
- extern-lexical
- extern-global
- extern-local
- >;
-
- for my $id (0 .. 9) {
- my $desc = $descriptions[$id];
-
- my $res = $tester->($id);
- is $res, $id, "plain call - $desc";
-
- $res = do {
- my $id_plus_1 = $id + 1;
- given ($id_plus_1) {
- do {
- when (/\d/) {
- --$id_plus_1;
- continue;
- 456;
- }
- };
- default {
- $tester->($id_plus_1);
- }
- 'XXX';
- }
- };
- is $res, $id, "across continue and default - $desc";
+ my $test = "Overloaded obj in given (false)";
+ my $obj = OverloadTest->new(0);
+ my $matched;
+ given($obj) {
+ when ("other arg") {$matched = 1}
}
+
+ is($obj->{called}, 1, "$test: called");
+ ok(!$matched, "$test: not matched");
+ is($obj->{left}, "string value of obj", "$test: left");
+ is($obj->{right}, "other arg", "$test: right");
+ ok(!$obj->{reversed}, "$test: not reversed");
}
-# Check that values returned from given/when are destroyed at the right time.
{
- {
- package Fmurrr;
-
- sub new {
- bless {
- flag => \($_[1]),
- id => $_[2],
- }, $_[0]
- }
-
- sub DESTROY {
- ${$_[0]->{flag}}++;
- }
+ my $test = "Overloaded obj in when (true)";
+ my $obj = OverloadTest->new(1);
+ my $matched;
+ given("topic") {
+ when ($obj) {$matched = 1}
+ default {$matched = 0}
}
-
- my @descriptions = qw<
- when
- break
- continue
- default
- >;
-
- for my $id (0 .. 3) {
- my $desc = $descriptions[$id];
-
- my $destroyed = 0;
- my $res_id;
-
- {
- my $res = do {
- given ($id) {
- my $x;
- when (0) { Fmurrr->new($destroyed, 0) }
- when (1) { my $y = Fmurrr->new($destroyed, 1); break }
- when (2) { $x = Fmurrr->new($destroyed, 2); continue }
- when (2) { $x }
- default { Fmurrr->new($destroyed, 3) }
- }
- };
- $res_id = $res->{id};
- }
- $res_id = $id if $id == 1; # break doesn't return anything
-
- is $res_id, $id, "given/when returns the right object - $desc";
- is $destroyed, 1, "given/when does not leak - $desc";
- };
+
+ is($obj->{called}, 1, "$test: called");
+ ok($matched, "$test: matched");
+ is($obj->{left}, "topic", "$test: left");
+ is($obj->{right}, "string value of obj", "$test: right");
+ ok($obj->{reversed}, "$test: reversed");
}
-# break() must reset the stack
{
- my @res = (1, do {
- given ("x") {
- 2, 3, do {
- when (/[a-z]/) {
- 4, 5, 6, break
- }
- }
- }
- });
- is "@res", "1", "break resets the stack";
-}
-
-# RT #94682:
-# must ensure $_ is initialised and cleared at start/end of given block
-
-{
- sub f1 {
- no warnings 'experimental::lexical_topic';
- my $_;
- given(3) {
- return sub { $_ } # close over lexical $_
- }
- }
- is(f1()->(), 3, 'closed over $_');
-
- package RT94682;
-
- my $d = 0;
- sub DESTROY { $d++ };
-
- sub f2 {
- no warnings 'experimental::lexical_topic';
- my $_ = 5;
- given(bless [7]) {
- ::is($_->[0], 7, "is [7]");
- }
- ::is($_, 5, "is 5");
- ::is($d, 1, "DESTROY called once");
+ my $test = "Overloaded obj in when (false)";
+ my $obj = OverloadTest->new(0);
+ my $matched;
+ given("topic") {
+ when ($obj) {$matched = 1}
+ default {$matched = 0}
}
- f2();
+
+ is($obj->{called}, 1, "$test: called");
+ ok(!$matched, "$test: not matched");
+ is($obj->{left}, "topic", "$test: left");
+ is($obj->{right}, "string value of obj", "$test: right");
+ ok($obj->{reversed}, "$test: reversed");
}
-
-
# Okay, that'll do for now. The intricacies of the smartmatch
-# semantics are tested in t/op/smartmatch.t. Taintedness of
-# returned values is checked in t/op/taint.t.
+# semantics are tested in t/op/smartmatch.t
__END__
diff --git a/gnu/usr.bin/perl/t/run/cloexec.t b/gnu/usr.bin/perl/t/run/cloexec.t
index 52003771652..cfbe702a081 100644
--- a/gnu/usr.bin/perl/t/run/cloexec.t
+++ b/gnu/usr.bin/perl/t/run/cloexec.t
@@ -35,17 +35,26 @@
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
+ use Config;
+ if (!$Config{'d_fcntl'}) {
+ print("1..0 # Skip: fcntl() is not available\n");
+ exit(0);
+ }
require './test.pl';
- skip_all_without_config('d_fcntl');
}
use strict;
$|=1;
+my $Is_VMS = $^O eq 'VMS';
+my $Is_MacOS = $^O eq 'MacOS';
+my $Is_Win32 = $^O eq 'MSWin32';
+
# When in doubt, skip.
-skip_all($^O)
- if $^O eq 'VMS' or $^O eq 'MSWin32';
+skip_all("MacOS") if $Is_MacOS;
+skip_all("VMS") if $Is_VMS;
+skip_all("Win32") if $Is_Win32;
sub make_tmp_file {
my ($fname, $fcontents) = @_;
@@ -56,11 +65,11 @@ sub make_tmp_file {
}
my $Perl = which_perl();
-my $quote = "'";
+my $quote = $Is_VMS || $Is_Win32 ? '"' : "'";
-my $tmperr = tempfile();
-my $tmpfile1 = tempfile();
-my $tmpfile2 = tempfile();
+my $tmperr = 'cloexece.tmp';
+my $tmpfile1 = 'cloexec1.tmp';
+my $tmpfile2 = 'cloexec2.tmp';
my $tmpfile1_contents = "tmpfile1 line 1\ntmpfile1 line 2\n";
my $tmpfile2_contents = "tmpfile2 line 1\ntmpfile2 line 2\n";
make_tmp_file($tmpfile1, $tmpfile1_contents);
@@ -155,3 +164,9 @@ cmp_ok( $parentfd1, '<=', $^F, "parent open fd=$parentfd1 (\$^F=$^F)" );
test_inherited($parentfd1);
close FHPARENT1 or die "close '$tmpfile1': $!";
close FHPARENT2 or die "close '$tmpfile2': $!";
+
+END {
+ defined $tmperr and unlink($tmperr);
+ defined $tmpfile1 and unlink($tmpfile1);
+ defined $tmpfile2 and unlink($tmpfile2);
+}
diff --git a/gnu/usr.bin/perl/t/uni/cache.t b/gnu/usr.bin/perl/t/uni/cache.t
index 7b6e31e08aa..c3f7634fcda 100644
--- a/gnu/usr.bin/perl/t/uni/cache.t
+++ b/gnu/usr.bin/perl/t/uni/cache.t
@@ -6,28 +6,16 @@ BEGIN {
plan tests => 1;
-# Looks to see if a "do 'unicore/lib/Sc/Hira.pl'" is called more than once, by
-# putting a compile sub first on the libary path;
-# XXX Kludge: requires exact path, which might change, and has deep knowledge
-# of how utf8_heavy.pl works, which might also change.
-
-BEGIN { # Make sure catches compile time references
- $::count = 0;
- unshift @INC, sub {
- $::count++ if $_[1] eq 'unicore/lib/Sc/Hira.pl';
- };
-}
+my $count = 0;
+unshift @INC, sub {
+ $count++ if $_[1] eq 'unicore/lib/gc_sc/Hira.pl';
+};
my $s = 'foo';
-# The second value is to prevent an optimization that exists at the time this
-# is written to re-use a property without trying to look it up if it is the
-# only thing in a character class. They differ in order to make sure that any
-# future optimizations that don't re-use identical character classes don't come
-# into play
-$s =~ m/[\p{Hiragana}\x{101}]/;
-$s =~ m/[\p{Hiragana}\x{102}]/;
-$s =~ m/[\p{Hiragana}\x{103}]/;
-$s =~ m/[\p{Hiragana}\x{104}]/;
+$s =~ m/[\p{Hiragana}]/;
+$s =~ m/[\p{Hiragana}]/;
+$s =~ m/[\p{Hiragana}]/;
+$s =~ m/[\p{Hiragana}]/;
-is($::count, 1, "Swatch hash caching kept us from reloading swatch hash.");
+is($count, 1, "Swatch hash caching kept us from reloading swatch hash.");
diff --git a/gnu/usr.bin/perl/t/uni/chr.t b/gnu/usr.bin/perl/t/uni/chr.t
index 9445d32a7ba..ab710d9e352 100644
--- a/gnu/usr.bin/perl/t/uni/chr.t
+++ b/gnu/usr.bin/perl/t/uni/chr.t
@@ -1,15 +1,33 @@
-#!./perl -w
BEGIN {
- require './test.pl';
- skip_all_without_dynamic_extension('Encode');
- skip_all("EBCDIC") if $::IS_EBCDIC;
- skip_all_without_perlio();
+ if ($ENV{'PERL_CORE'}){
+ chdir 't';
+ @INC = '../lib';
+ }
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bEncode\b/) {
+ print "1..0 # Skip: Encode was not built\n";
+ exit 0;
+ }
+ if (ord("A") == 193) {
+ print "1..0 # Skip: EBCDIC\n";
+ exit 0;
+ }
+ unless (PerlIO::Layer->find('perlio')){
+ print "1..0 # Skip: PerlIO required\n";
+ exit 0;
+ }
+ if ($ENV{PERL_CORE_MINITEST}) {
+ print "1..0 # Skip: no dynamic loading on miniperl, no Encode\n";
+ exit 0;
+ }
+ $| = 1;
}
use strict;
-plan (tests => 8);
-no warnings 'deprecated';
+use Test::More tests => 6;
+use Encode;
+
use encoding 'johab';
ok(chr(0x7f) eq "\x7f");
@@ -20,13 +38,4 @@ for my $i (127, 128, 255) {
ok(chr($i) eq pack('C', $i));
}
-# [perl #83048]
-{
- my $w;
- local $SIG{__WARN__} = sub { $w .= $_[0] };
- my $chr = chr(-1);
- is($chr, "\x{fffd}", "invalid values become REPLACEMENT CHARACTER");
- like($w, qr/^Invalid negative number \(-1\) in chr at /, "with a warning");
-}
-
__END__
diff --git a/gnu/usr.bin/perl/t/uni/greek.t b/gnu/usr.bin/perl/t/uni/greek.t
index 5326ab94ad7..a8102f3880e 100644
--- a/gnu/usr.bin/perl/t/uni/greek.t
+++ b/gnu/usr.bin/perl/t/uni/greek.t
@@ -1,15 +1,31 @@
-#!./perl -w
-
BEGIN {
+ if ($ENV{'PERL_CORE'}){
+ chdir 't';
+ @INC = '../lib';
+ }
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bEncode\b/) {
+ print "1..0 # Skip: Encode was not built\n";
+ exit 0;
+ }
+ if (ord("A") == 193) {
+ print "1..0 # Skip: EBCDIC\n";
+ exit 0;
+ }
+ unless (PerlIO::Layer->find('perlio')){
+ print "1..0 # Skip: PerlIO required\n";
+ exit 0;
+ }
+ if ($ENV{PERL_CORE_MINITEST}) {
+ print "1..0 # Skip: no dynamic loading on miniperl, no Encode\n";
+ exit 0;
+ }
+ $| = 1;
require './test.pl';
- skip_all_without_dynamic_extension('Encode');
- skip_all("EBCDIC") if $::IS_EBCDIC;
- skip_all_without_perlio();
}
plan tests => 72;
-no warnings 'deprecated';
use encoding "greek"; # iso 8859-7
# U+0391, \xC1, \301, GREEK CAPITAL LETTER ALPHA
diff --git a/gnu/usr.bin/perl/t/uni/latin2.t b/gnu/usr.bin/perl/t/uni/latin2.t
index 6e7d980aec3..08928b60398 100644
--- a/gnu/usr.bin/perl/t/uni/latin2.t
+++ b/gnu/usr.bin/perl/t/uni/latin2.t
@@ -1,15 +1,31 @@
-#!./perl -w
-
BEGIN {
+ if ($ENV{'PERL_CORE'}){
+ chdir 't';
+ @INC = '../lib';
+ }
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bEncode\b/) {
+ print "1..0 # Skip: Encode was not built\n";
+ exit 0;
+ }
+ if (ord("A") == 193) {
+ print "1..0 # Skip: EBCDIC\n";
+ exit 0;
+ }
+ unless (PerlIO::Layer->find('perlio')){
+ print "1..0 # Skip: PerlIO required\n";
+ exit 0;
+ }
+ if ($ENV{PERL_CORE_MINITEST}) {
+ print "1..0 # Skip: no dynamic loading on miniperl, no Encode\n";
+ exit 0;
+ }
+ $| = 1;
require './test.pl';
- skip_all_without_dynamic_extension('Encode');
- skip_all("EBCDIC") if $::IS_EBCDIC;
- skip_all_without_perlio();
}
plan tests => 94;
-no warnings 'deprecated';
use encoding "latin2"; # iso 8859-2
# U+00C1, \xC1, \301, LATIN CAPITAL LETTER A WITH ACUTE
diff --git a/gnu/usr.bin/perl/utils/config_data.PL b/gnu/usr.bin/perl/utils/config_data.PL
index a167de896b7..e1de813b526 100644
--- a/gnu/usr.bin/perl/utils/config_data.PL
+++ b/gnu/usr.bin/perl/utils/config_data.PL
@@ -35,7 +35,7 @@ use File::Spec;
my $script = File::Spec->catfile(
File::Spec->catdir(
- File::Spec->updir, qw[cpan Module-Build bin]
+ File::Spec->updir, qw[lib Module Build scripts]
), "config_data");
if (open(IN, $script)) {
diff --git a/gnu/usr.bin/perl/win32/Makefile.ce b/gnu/usr.bin/perl/win32/Makefile.ce
index 840cee63bb6..d773f994abb 100644
--- a/gnu/usr.bin/perl/win32/Makefile.ce
+++ b/gnu/usr.bin/perl/win32/Makefile.ce
@@ -1,1071 +1,950 @@
-#
-# perl makefile for wince
-# During the cross-compilation, it first uses Makefile file to build
-# miniperl on HOST and then build required platform
-#
-
-SRCDIR = ..
-PV = 520
-
-# INSTALL_ROOT specifies a path where this perl will be installed on CE device
-INSTALL_ROOT=/netzwerk/sprache/perl
-INST_TOP=$(INSTALL_ROOT)
-INST_VER=
-
-# PERLCEDIR shoud be set to current directory
-PERLCEDIR = $(MAKEDIR)
-
-# WCEROOT is a directory where Windows CE Tools was installed
-WCEROOT = D:\Windows CE Tools
-
-# HPERL stands for host perl, which is perl on local desktop machine
-# which is usually ..\miniperl.exe
-#HPERL = N:\Programme\perl\bin\perl.exe
-HPERL = $(MAKEDIR)\..\miniperl.exe
-
-CEPATH = D:\Programme\Microsoft eMbedded Tools\EVC\WCE211\BIN
-CELIBDLLDIR = h:\src\wince\celib-palm-3.0
-CECONSOLEDIR = h:\src\wince\w32console
-
-# specify following options to build perl on local machine, by MSVC
-MSVCDIR = D:\MSVStudio\VC98
-CCHOME = $(MSVCDIR)
-CCINCDIR = $(CCHOME)\include
-CCLIBDIR = $(CCHOME)\lib
-
-# cecopy program. Make shure it is in your path, as well as cemkdir, cedel
-CECOPY = cecopy
-
-#
-# Comment out next assign to disable perl's I/O subsystem and use compiler's
-# stdio for IO - depending on your compiler vendor and run time library you may
-# then get a number of fails from make test i.e. bugs - complain to them not us ;-).
-# You will also be unable to take full advantage of perl5.8's support for multiple
-# encodings and may see lower IO performance. You have been warned.
-USE_PERLIO = define
-
-#
-# set this if you wish to use perl's malloc
-# This will make perl run few times faster
-# WARNING: Turning this on/off WILL break binary compatibility with extensions
-# you may have compiled with/without it.
-#
-PERL_MALLOC = define
-
-
-NOOP = @echo
-# keep this untouched!
-NULL =
-
-#
-# uncomment exactly one of the following
-#
-# Embedded Visual C++ 4 and older
-CCTYPE = MSVC60
-# Smart Devices for Visual C++ 2005 (aka Visual C++ 8.x) (full version)
-#CCTYPE = MSVC80
-# Smart Devices for Visual C++ 2008 (aka Visual C++ 9.x) (full version)
-#CCTYPE = MSVC90
-
-#CFG=DEBUG
-CFG=RELEASE
-
-!if "$(MACHINE)" == ""
-MACHINE=wince-arm-hpc-wce300
-#MACHINE=wince-arm-hpc-wce211
-#MACHINE=wince-sh3-hpc-wce211
-#MACHINE=wince-mips-hpc-wce211
-#MACHINE=wince-sh3-hpc-wce200
-#MACHINE=wince-mips-hpc-wce200
-#MACHINE=wince-arm-pocket-wce300
-#MACHINE=wince-mips-pocket-wce300
-#MACHINE=wince-sh3-pocket-wce300
-#MACHINE=wince-x86em-pocket-wce300
-#MACHINE=wince-mips-palm-wce211
-#MACHINE=wince-sh3-palm-wce211
-#MACHINE=wince-x86em-palm-wce211
-#MACHINE=wince-x86-hpc-wce300
-#MACHINE=wince-arm-pocket-wce400
-!endif
-
-# set this to your email address
-#
-#EMAIL =
-
-##################### CHANGE THESE ONLY IF YOU MUST #####################
-
-######################################################################
-# machines
-
-!if "$(MACHINE)" == "wince-sh3-hpc-wce211"
-CC = shcl.exe
-ARCH = SH3
-CPU = SH3
-TARGETCPU = SH3
-CEVersion = 211
-OSVERSION = WCE211
-PLATFORM = MS HPC Pro
-MCFLAGS = -MDd -DSH3 -D_SH3_ -DSHx -DPROCESSOR_SH3 -DPALM_SIZE \
- -I $(CELIBDLLDIR)\inc
-SUBSYS = -subsystem:windowsce,2.11
-CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release
-LDLIBPATH = -libpath:$(CELIBPATH)
-STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \
- $(CECONSOLEDIR)/$(MACHINE)/w32console.obj
-!endif
-
-!if "$(MACHINE)" == "wince-mips-hpc-wce211"
-CC = clmips.exe
-ARCH = MIPS
-CPU = MIPS
-TARGETCPU = MIPS
-CEVersion = 211
-OSVERSION = WCE211
-PLATFORM = MS HPC Pro
-MCFLAGS = -D _MT -D _DLL \
- -D MIPS -D mips -D _MIPS_ -D _mips_ -DPROCESSOR_MIPS \
- -D PALM_SIZE \
- -I $(CELIBDLLDIR)\inc
-SUBSYS = -subsystem:windowsce,2.11
-CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release
-LDLIBPATH = -libpath:$(CELIBPATH)
-STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \
- $(CECONSOLEDIR)/$(MACHINE)/w32console.obj
-!endif
-
-!if "$(MACHINE)" == "wince-mips-hpc-wce200"
-CC = clmips.exe
-ARCH = MIPS
-CPU = MIPS
-TARGETCPU = MIPS
-CEVersion = 200
-OSVERSION = WCE200
-PLATFORM = MS HPC
-# MUST USE -MD to get the right FPE stuff...
-MCFLAGS = -D _MT -D _DLL -MD \
- -D MIPS -D mips -D _MIPS_ -D _mips_ -DPROCESSOR_MIPS \
- -D PALM_SIZE \
- -I $(CELIBDLLDIR)\inc
-SUBSYS = -subsystem:windowsce,2.00
-CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release
-LDLIBPATH = -libpath:$(CELIBPATH)
-STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \
- $(CECONSOLEDIR)/$(MACHINE)/w32console.obj
-!endif
-
-!if "$(MACHINE)" == "wince-sh3-hpc-wce200"
-CC = shcl.exe
-ARCH = SH3
-CPU = SH3
-TARGETCPU = SH3
-CEVersion = 200
-OSVERSION = WCE200
-PLATFORM = MS HPC
-# MUST USE -MD to get the right FPE stuff...
-MCFLAGS = -D _MT -D _DLL -MD \
- -D SH3 -D sh3 -D _SH3_ -D _sh3_ -D SHx -DPROCESSOR_SH3 \
- -D PALM_SIZE \
- -I $(CELIBDLLDIR)\inc
-SUBSYS = -subsystem:windowsce,2.00
-CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release
-LDLIBPATH = -libpath:$(CELIBPATH)
-STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \
- $(CECONSOLEDIR)/$(MACHINE)/w32console.obj
-!endif
-
-!if "$(MACHINE)" == "wince-arm-hpc-wce211"
-CC = clarm.exe
-ARCH = ARM
-CPU = ARM
-TARGETCPU = ARM
-CEVersion = 211
-OSVERSION = WCE211
-PLATFORM = MS HPC Pro
-MCFLAGS = -D _MT -D _DLL -D ARM -D arm -D _arm_ -D _ARM_ \
- -DPROCESSOR_ARM -DPALM_SIZE \
- -I $(CELIBDLLDIR)\inc
-SUBSYS = -subsystem:windowsce,2.11
-CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release
-LDLIBPATH = -libpath:$(CELIBPATH)
-STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \
- $(CECONSOLEDIR)/$(MACHINE)/w32console.obj
-!endif
-
-!if "$(MACHINE)" == "wince-arm-hpc-wce300"
-CC = clarm.exe
-ARCH = ARM
-CPU = ARM
-TARGETCPU = ARM
-CEVersion = 300
-OSVERSION = WCE300
-#PLATFORM = HPC2000
-MCFLAGS = -D _MT -D _DLL -D ARM -D arm -D _arm_ -D _ARM_ \
- -DPROCESSOR_ARM -DPALM_SIZE \
- -I $(CELIBDLLDIR)\inc
-SUBSYS = -subsystem:windowsce,3.00
-CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release
-LDLIBPATH = -libpath:$(CELIBPATH)
-STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \
- $(CECONSOLEDIR)/$(MACHINE)/w32console.obj
-!endif
-
-!if "$(MACHINE)" == "wince-mips-palm-wce211"
-CC = clmips.exe
-ARCH = MIPS
-CPU = MIPS
-TARGETCPU = MIPS
-CEVersion = 211
-OSVERSION = WCE211
-PLATFORM = MS Palm Size PC
-MCFLAGS = -DMIPS -D_MIPS_ -DPROCESSOR_MIPS -D PALM_SIZE -D _DLL -D _MT \
- -I $(CELIBDLLDIR)\inc
-SUBSYS = -subsystem:windowsce,2.11
-CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release
-LDLIBPATH = -libpath:$(CELIBPATH)
-STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \
- $(CECONSOLEDIR)/$(MACHINE)/w32console.obj
-!endif
-
-!if "$(MACHINE)" == "wince-sh3-palm-wce211"
-CC = shcl.exe
-ARCH = SH3
-CPU = SH3
-TARGETCPU = SH3
-CEVersion = 211
-OSVERSION = WCE211
-PLATFORM = MS Palm Size PC
-MCFLAGS = -D _MT -D _DLL -DSH3 -D_SH3_ -DSHx -DPROCESSOR_SH3 -DPALM_SIZE \
- -I $(CELIBDLLDIR)\inc
-SUBSYS = -subsystem:windowsce,2.11
-CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release
-LDLIBPATH = -libpath:$(CELIBPATH)
-STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \
- $(CECONSOLEDIR)/$(MACHINE)/w32console.obj
-!endif
-
-!if "$(MACHINE)" == "wince-x86em-palm-wce211"
-CC = cl.exe
-ARCH = X86EM
-CPU = X86
-TARGETCPU = X86
-CEVersion = 211
-OSVERSION = WCE211
-PLATFORM = MS Palm Size PC
-MCFLAGS = -MDd -DX86 -D_X86_ -DPROCESSOR_X86 \
- -D_WIN32_WCE_EMULATION -DPALM_SIZE \
- -I $(CELIBDLLDIR)\inc
-MACH = -machine:x86
-SUBSYS = -subsystem:windows
-CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release
-LDLIBPATH = -libpath:$(CELIBPATH)
-STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \
- $(CECONSOLEDIR)/$(MACHINE)/w32console.obj
-!endif
-
-!if "$(MACHINE)" == "wince-x86em-pocket-wce300"
-CC = cl.exe
-ARCH = X86EM
-CPU = X86
-TARGETCPU = X86
-CEVersion = 300
-OSVERSION = WCE300
-PLATFORM = MS Pocket PC
-MCFLAGS = -DX86 -D_X86_ -DPROCESSOR_X86 -D _MT -D _DLL \
- -D_WIN32_WCE_EMULATION -DPALM_SIZE -DPOCKET_SIZE \
- -I $(CELIBDLLDIR)\inc
-MACH = -machine:x86
-SUBSYS = -subsystem:windows
-CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release
-LDLIBPATH = -libpath:$(CELIBPATH)
-STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \
- $(CECONSOLEDIR)/$(MACHINE)/w32console.obj
-!endif
-
-!if "$(MACHINE)" == "wince-mips-pocket-wce300"
-CC = clmips.exe
-ARCH = MIPS
-CPU = MIPS
-TARGETCPU = MIPS
-CEVersion = 300
-OSVERSION = WCE300
-PLATFORM = MS Pocket PC
-MCFLAGS = -D MIPS -D mips -D _MIPS_ -D _mips_ -DPROCESSOR_MIPS \
- -D _MT -D _DLL -DPALM_SIZE -DPOCKET_SIZE \
- -I $(CELIBDLLDIR)\inc
-MACH = -machine:mips
-SUBSYS = -subsystem:windowsce,3.00
-CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release
-#STDLIBPATH = $(WCEROOT)\$(OSVERSION)\$(PLATFORM)\lib\$(CPU)
-LDLIBPATH = -libpath:$(CELIBPATH)
-#"-libpath:$(STDLIBPATH)"
-STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \
- $(CECONSOLEDIR)/$(MACHINE)/w32console.obj
-!endif
-
-!if "$(MACHINE)" == "wince-sh3-pocket-wce300"
-CC = shcl.exe
-ARCH = SH3
-CPU = SH3
-TARGETCPU = SH3
-CEVersion = 300
-OSVERSION = WCE300
-PLATFORM = MS Pocket PC
-MCFLAGS = -D _MT -D _DLL -DSH3 -D_SH3_ -DSHx -DPROCESSOR_SH3 \
- -DPALM_SIZE -DPOCKET_SIZE \
- -I $(CELIBDLLDIR)\inc
-MACH = -machine:sh3
-SUBSYS = -subsystem:windowsce,3.00
-CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release
-LDLIBPATH = -libpath:$(CELIBPATH)
-STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \
- $(CECONSOLEDIR)/$(MACHINE)/w32console.obj
-!endif
-
-!if "$(MACHINE)" == "wince-arm-pocket-wce300"
-CC = clarm.exe
-ARCH = ARM
-CPU = ARM
-TARGETCPU = ARM
-CEVersion = 300
-OSVERSION = WCE300
-PLATFORM = MS Pocket PC
-MCFLAGS = -D ARM -D arm -D _ARM_ -D _arm_ -DPROCESSOR_ARM \
- -D _MT -D _DLL -DPALM_SIZE -DPOCKET_SIZE \
- -I $(CELIBDLLDIR)\inc
-MACH = -machine:arm
-SUBSYS = -subsystem:windowsce,3.00
-CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release
-LDLIBPATH = -libpath:$(CELIBPATH)
-STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \
- $(CECONSOLEDIR)/$(MACHINE)/w32console.obj
-!endif
-
-!if "$(MACHINE)" == "wince-x86-hpc-wce300"
-CC = cl.exe
-ARCH = X86EM
-CPU = X86
-TARGETCPU = X86
-CEVersion = 400
-OSVERSION = WCE400
-PLATFORM = MS Pocket PC
-MCFLAGS = -DX86 -D_X86_ -Dx86 -DPROCESSOR_X86 -D _MT -D _DLL \
- -DPALM_SIZE -DPOCKET_SIZE -I $(CELIBDLLDIR)\inc
-MACH = -machine:IX86
-SUBSYS = -subsystem:windowsce,2.0
-CELIBPATH = $(CELIBDLLDIR)\wince-x86-hpc-wce300-release
-LDLIBPATH = -libpath:$(CELIBPATH)
-STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \
- $(CECONSOLEDIR)/$(MACHINE)/w32console.obj
-!endif
-
-!if "$(MACHINE)" == "wince-arm-pocket-wce400"
-#CC = clarm.exe #set in WCEARMV4.BAT
-ARCH = ARM
-CPU = ARM
-TARGETCPU = ARM
-CEVersion = 400
-#OSVERSION = WCE300 #set in WCEARMV4.BAT
-PLATFORM = MS Pocket PC
-MCFLAGS = -D ARM -D arm -D _ARM_ -D _arm_ -DPROCESSOR_ARM \
- -D _MT -D _DLL -DPALM_SIZE -DPOCKET_SIZE \
- -I $(CELIBDLLDIR)\inc
-MACH = -machine:arm
-SUBSYS = -subsystem:windowsce,4.00
-CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release
-LDLIBPATH = -libpath:$(CELIBPATH)
-STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \
- $(CECONSOLEDIR)/$(MACHINE)/w32console.obj
-!endif
-
-
-######################################################################
-# common section
-
-CEDEFS = -D_WINDOWS -D_WIN32_WCE=$(CEVersion) -DUNDER_CE=$(CEVersion) \
- $(MCFLAGS) -D PERL
-
-CECFLAGS = $(CEDEFS) -Zi
-
-!if "$(CFG)" == "DEBUG"
-CECFLAGS = $(CECFLAGS) -Od
-!endif
-
-!if "$(CFG)" == "RELEASE"
-# -O2 and -Ot give internal compiler error in perl.c and lexer.
-# Also the dll cannot be loaded by perl.exe...
-!if "$(CPU)" == "SH3"
-!else
-CECFLAGS = $(CECFLAGS) -O1
-!endif
-! IF "$(CCTYPE)" != "MSVC60"
-#turn on LTCG optimization for CCs that have it
-CECFLAGS = $(CECFLAGS) -GL
-! ENDIF
-! IF "$(CCTYPE)" == "MSVC80" || "$(CCTYPE)" == "MSVC90"
-#no stack security cookie for CCs where its on by default
-CECFLAGS = $(CECFLAGS) -GS-
-! ENDIF
-!endif
-
-RCDEFS = /l 0x407 /r /d "UNICODE" /d UNDER_CE=$(CEVersion) \
- /d _WIN32_WCE=$(CEVersion)
-
-#PATH=$(CEPATH);$(PATH)
-
-# attention, for eVC 4, these paths are not generated correctly since the
-# WinCE SDK is organized differently from eVC 3, replace the next 2 macros
-# with absolute paths to the correct directories on your system
-#INCLUDE=$(WCEROOT)\$(OSVERSION)\$(PLATFORM)\include
-#LIB=$(WCEROOT)\$(OSVERSION)\$(PLATFORM)\lib\$(ARCH)
-
-######################################################################
-
-!message
-!message Compiling for $(MACHINE)
-!message LIB=$(LIB)
-!message INCLUDE=$(INCLUDE)
-!message PATH=$(CEPATH)
-!message
-
-######################################################################
-#
-# Additional compiler flags can be specified here.
-#
-
-BUILDOPT = $(BUILDOPT) $(CECFLAGS) -DUSE_CROSS_COMPILE
-
-
-!IF "$(CRYPT_SRC)$(CRYPT_LIB)" == ""
-D_CRYPT = undef
-!ELSE
-D_CRYPT = define
-CRYPT_FLAG = -DHAVE_DES_FCRYPT
-!ENDIF
-
-!IF "$(PERL_MALLOC)" == ""
-PERL_MALLOC = undef
-!ENDIF
-
-!IF "$(USE_MULTI)" == ""
-USE_MULTI = undef
-!ENDIF
-
-!IF "$(USE_ITHREADS)" == ""
-USE_ITHREADS = undef
-!ENDIF
-
-!IF "$(USE_IMP_SYS)" == ""
-USE_IMP_SYS = undef
-!ENDIF
-
-!IF "$(USE_PERLIO)" == ""
-USE_PERLIO = undef
-!ENDIF
-
-!IF "$(USE_PERLCRT)" == ""
-USE_PERLCRT = undef
-!ENDIF
-
-!IF "$(USE_IMP_SYS)$(USE_MULTI)" == "defineundef"
-USE_MULTI = define
-!ENDIF
-
-!IF "$(USE_ITHREADS)$(USE_MULTI)" == "defineundef"
-USE_MULTI = define
-!ENDIF
-
-!IF "$(USE_MULTI)" != "undef"
-BUILDOPT = $(BUILDOPT) -DPERL_IMPLICIT_CONTEXT
-!ENDIF
-
-!IF "$(USE_IMP_SYS)" != "undef"
-BUILDOPT = $(BUILDOPT) -DPERL_IMPLICIT_SYS
-!ENDIF
-
-!IF "$(USE_PERLIO)" == "define"
-BUILDOPT = $(BUILDOPT) -DUSE_PERLIO
-!ENDIF
-
-!IF "$(CROSS_NAME)" == ""
-CROSS_NAME = $(MACHINE)
-!ENDIF
-
-# new option - automatically defined in perl.h...
-#BUILDOPT = $(BUILDOPT) -DUSE_ENVIRON_ARRAY
-
-PROCESSOR_ARCHITECTURE = $(TARGETCPU)
-ARCHNAME = $(PLATFORM)-$(OSVERSION)-$(PROCESSOR_ARCHITECTURE)
-ARCHDIR = ..\lib\$(ARCHNAME)
-COREDIR = ..\lib\CORE
-AUTODIR = ..\lib\auto
-LIBDIR = ..\lib
-EXTDIR = ..\ext
-DISTDIR = ..\dist
-CPANDIR = ..\cpan
-PODDIR = ..\pod
-EXTUTILSDIR = $(LIBDIR)\ExtUtils
-
-LINK32 = link
-LIB32 = $(LINK32) -lib
-RSC = rc
-
-INCLUDES = -I.\include -I. -I..
-DEFINES = -DWIN32 -D_CONSOLE -DNO_STRICT $(CRYPT_FLAG) $(CECFLAGS)
-LOCDEFS = -DPERLDLL -DPERL_CORE
-CXX_FLAG = -TP
-
-PERLEXE_RES = perl.res
-PERLDLL_RES =
-
-!if "$(CFG)" == "RELEASE"
-CELIB = celib.lib
-!endif
-
-!if "$(CFG)" == "DEBUG"
-CELIB = celib.lib
-!endif
-
-#use ws2.lib instead of winsock.lib for WSAGetLastError
-CELIBS = -nodefaultlib \
- ws2.lib $(CELIB) coredll.lib
-
-#this libc's purpose is WinCE entrypoint to main wrapper, not a real C std lib
-!if $(CEVersion) > 200
-LIBC = corelibc.lib
-!else
-LIBC = msvcrt.lib
-!endif
-
-LIBBASEFILES = $(CRYPT_LIB) $(CELIBS)
-
-LIBFILES = $(LIBBASEFILES) $(LIBC)
-
-CFLAGS = -nologo -GF -W3 $(INCLUDES) $(DEFINES) $(LOCDEFS) \
- $(PCHFLAGS) $(OPTIMIZE)
-
-LINK_FLAGS = -nologo -debug -opt:ref,icf -machine:$(PROCESSOR_ARCHITECTURE)
-
-!if "$(CFG)" == "RELEASE" && "$(CCTYPE)" != "MSVC60"
-#see matching flag in CECFLAGS
-LINK_FLAGS = $(LINK_FLAGS) -ltcg
-!endif
-
-OBJOUT_FLAG = -Fo
-EXEOUT_FLAG = -Fe
-
-CFLAGS_O = $(CFLAGS) $(BUILDOPT)
-
-o = .obj
-
-#
-# Rules
-#
-
-.SUFFIXES : .c $(o) .dll .lib .exe .rc .res
-
-.c$(o):
- $(CC) -c -I$(<D) $(CFLAGS_O) $(OBJOUT_FLAG)$@ $<
-
-.c.i:
- $(CC) -c -I$(<D) $(CFLAGS_O) -P $(OBJOUT_FLAG)$@ $<
-
-.y.c:
- $(NOOP)
-
-$(o).dll:
- $(LINK32) -dll $(SUBSYS) $(LDLIBPATH) \
- -implib:$(*B).lib -def:$(*B).def \
- -out:$@ $(LINK_FLAGS) $(LIBFILES) $< $(LIBPERL)
-
-.rc.res:
- $(RSC) -i.. $<
-
-# This must be relative to ../lib/CORE, else the ext dll build fails...
-PERLIMPLIB_EXP = perl$(PV).lib
-PERLIMPLIB = $(PERLCEDIR)\$(MACHINE)\perl$(PV).lib
-PERLDLL = $(MACHINE)\perl$(PV).dll
-
-DLLDIR = $(MACHINE)\dll
-PERLEXE = $(MACHINE)\perl.exe
-
-CONFIGPM = ..\lib\Config.pm ..\lib\Config_heavy.pl
-GENUUDMAP = ..\generate_uudmap.exe
-
-UUDMAP_H = ..\uudmap.h
-BITCOUNT_H = ..\bitcount.h
-MG_DATA_H = ..\mg_data.h
-GENERATED_HEADERS = $(UUDMAP_H) $(BITCOUNT_H) $(MG_DATA_H)
-
-# Unicode data files generated by mktables
-FIRSTUNIFILE = ..\lib\unicore\Decomposition.pl
-UNIDATAFILES = ..\lib\unicore\Decomposition.pl \
- ..\lib\unicore\CombiningClass.pl ..\lib\unicore\Name.pl \
- ..\lib\unicore\Heavy.pl ..\lib\unicore\mktables.lst \
- ..\lib\unicore\UCD.pl ..\lib\unicore\Name.pm \
- ..\lib\unicore\TestProp.pl
-
-PERLEXE_MANIFEST= .\perlexe.manifest
-PERLEXE_ICO = .\perlexe.ico
-PERLEXE_RES = .\perlexe.res
-PERLDLL_RES =
-
-# Directories of Unicode data files generated by mktables
-UNIDATADIR1 = ..\lib\unicore\To
-UNIDATADIR2 = ..\lib\unicore\lib
-
-# Nominate a target which causes extensions to be re-built
-# This used to be $(PERLEXE), but at worst it is the .dll that they depend
-# on and really only the interface - i.e. the .def file used to export symbols
-# from the .dll
-PERLDEP = perldll.def
-
-MAKE = nmake -nologo
-MAKE_BARE = nmake
-
-CFGSH_TMPL = config.ce
-CFGH_TMPL = config_H.ce
-
-XCOPY = xcopy /f /r /i /d /y
-RCOPY = xcopy /f /r /i /e /d /y
-NOOP = @rem
-NULL =
-
-DEL = del
-
-MICROCORE_SRC = \
- ..\av.c \
- ..\caretx.c \
- ..\deb.c \
- ..\doio.c \
- ..\doop.c \
- ..\dump.c \
- ..\globals.c \
- ..\gv.c \
- ..\mro.c \
- ..\hv.c \
- ..\locale.c \
- ..\keywords.c \
- ..\mathoms.c \
- ..\mg.c \
- ..\numeric.c \
- ..\op.c \
- ..\pad.c \
- ..\perl.c \
- ..\perlapi.c \
- ..\perly.c \
- ..\pp.c \
- ..\pp_ctl.c \
- ..\pp_hot.c \
- ..\pp_pack.c \
- ..\pp_sort.c \
- ..\pp_sys.c \
- ..\reentr.c \
- ..\regcomp.c \
- ..\regexec.c \
- ..\run.c \
- ..\scope.c \
- ..\sv.c \
- ..\taint.c \
- ..\toke.c \
- ..\universal.c \
- ..\utf8.c \
- ..\util.c
-
-EXTRACORE_SRC = $(EXTRACORE_SRC) perllib.c
-
-!IF "$(PERL_MALLOC)" == "define"
-EXTRACORE_SRC = $(EXTRACORE_SRC) ..\malloc.c
-!ENDIF
-
-EXTRACORE_SRC = $(EXTRACORE_SRC) ..\perlio.c .\win32io.c
-
-WIN32_SRC = \
- .\wince.c \
- .\wincesck.c \
- .\win32thread.c
-
-!IF "$(CRYPT_SRC)" != ""
-WIN32_SRC = $(WIN32_SRC) .\$(CRYPT_SRC)
-!ENDIF
-
-CORE_NOCFG_H = \
- ..\av.h \
- ..\cop.h \
- ..\cv.h \
- ..\dosish.h \
- ..\embed.h \
- ..\form.h \
- ..\gv.h \
- ..\handy.h \
- ..\hv.h \
- ..\hv_func.h \
- ..\iperlsys.h \
- ..\mg.h \
- ..\nostdio.h \
- ..\op.h \
- ..\opcode.h \
- ..\perl.h \
- ..\perlapi.h \
- ..\perlsdio.h \
- ..\perly.h \
- ..\pp.h \
- ..\proto.h \
- ..\regexp.h \
- ..\scope.h \
- ..\sv.h \
- ..\thread.h \
- ..\unixish.h \
- ..\utf8.h \
- ..\util.h \
- ..\warnings.h \
- ..\XSUB.h \
- ..\EXTERN.h \
- ..\perlvars.h \
- ..\intrpvar.h \
- .\include\dirent.h \
- .\include\netdb.h \
- .\include\sys\errno2.h \
- .\include\sys\socket.h \
- .\win32.h
-
-DYNAMIC_EXT = Socket IO Fcntl Opcode SDBM_File POSIX attributes B re \
- Data/Dumper Devel/Peek ByteLoader Devel/DProf File/Glob \
- Sys/Hostname
-
-STATIC_EXT = DynaLoader
-
-DYNALOADER = $(EXTDIR)\DynaLoader\DynaLoader
-
-ERRNO_PM = $(LIBDIR)\Errno.pm
-
-
-EXTENSION_PM = \
- $(ERRNO_PM)
-
-CFG_VARS = \
- "INST_TOP=$(INST_TOP)" \
- "INST_VER=$(INST_VER)" \
- "INST_ARCH=$(INST_ARCH)" \
- "archname=$(ARCHNAME)" \
- "cc=$(CC)" \
- "ld=$(LINK32)" \
- "ccflags=$(OPTIMIZE) $(DEFINES) $(BUILDOPT)" \
- "cppflags=$(OPTIMIZE) $(DEFINES) $(BUILDOPT)" \
- "cf_by=vkon" \
- "cf_email=$(EMAIL)" \
-#9cef8306
- "d_mymalloc=$(PERL_MALLOC)" \
- "libs=$(LIBFILES)" \
- "incpath=$(CCINCDIR)" \
- "libperl=$(PERLIMPLIB_EXP)" \
- "libpth=$(LIBPATH)" \
- "libc=$(LIBC)" \
- "make=$(MAKE_BARE)" \
- "static_ext=$(STATIC_EXT)" \
- "dynamic_ext=$(DYNAMIC_EXT)" \
- "usethreads=$(USE_ITHREADS)" \
- "useithreads=$(USE_ITHREADS)" \
- "usemultiplicity=$(USE_MULTI)" \
- "useperlio=$(USE_PERLIO)" \
- "use64bitint=undef" \
- "uselargefiles=undef" \
- "LINK_FLAGS=$(LDLIBPATH) $(LINK_FLAGS) $(SUBSYS)" \
- "optimize=$(OPTIMIZE)" \
- "WIN64=$(WIN64)"
-
-#
-# filenames given to xsubpp must have forward slashes (since it puts
-# full pathnames in #line strings)
-XSUBPP = $(HPERL) -I..\..\lib ..\$(EXTUTILSDIR)\xsubpp \
- -C++ -prototypes
-
-
-#
-# Top targets
-#
-
-all: hostminiperl force_config_h ..\lib\buildcustomize.pl .\config.h ..\git_version.h $(CONFIGPM) $(UNIDATAFILES) $(PERLEXE) MakePPPort Extensions
-
-$(DYNALOADER)$(o) : $(DYNALOADER).c config.h $(EXTDIR)\DynaLoader\dlutils.c
-
-#convenience target
-configpm_targ : $(CONFIGPM)
-
-force_config_h:
- -@$(DEL) /f config.h
- -@$(DEL) /f config.sh
- -@$(DEL) /f ..\config.h
- -@$(DEL) /f ..\config.sh
- -@$(DEL) $(PERLEXE_RES)
- -@mkdir ..\host
- -@copy $(HPERL) ..\host\miniperl.exe
- -@copy $(GENUUDMAP) ..\host\generate_uudmap.exe
- -@$(MAKE) -f Makefile distclean
- -@copy ..\host\miniperl.exe $(HPERL)
- -@copy ..\host\generate_uudmap.exe $(GENUUDMAP)
- $(GENUUDMAP) $(GENERATED_HEADERS)
- type NUL > force_config_h
-
-$(UUDMAP_H) $(MG_DATA_H) : $(BITCOUNT_H)
-
-$(BITCOUNT_H) :
- $(GENUUDMAP) $(GENERATED_HEADERS)
-
-$(CONFIGPM) : $(HPERL) ..\config.sh config_h.PL ..\git_version.h
- cd .. && $(HPERL) -Ilib configpm --no-glossary
- if exist lib\* $(RCOPY) lib\*.* ..\lib\$(NULL)
- $(XCOPY) ..\*.h $(COREDIR)\*.*
- $(XCOPY) *.h $(COREDIR)\*.*
- $(RCOPY) include $(COREDIR)\*.*
- if errorlevel 1 $(MAKE) /$(MAKEFLAGS) $(CONFIGPM)
-
-.\config.h: $(CONFIGPM) ..\config.sh
- -@$(DEL) /f config.h
- -$(HPERL) -I..\lib config_h.PL "INST_VER=$(INST_VER)" "CORE_DIR=$(COREDIR)" "CONFIG_H=config.h"
- copy config.h ..\config.h
-
-..\config.sh : config.ce config_sh.PL FindExt.pm
- -@$(DEL) /f config.sh
- $(HPERL) -I..\lib -I. config_sh.PL $(CFG_VARS) config.ce > ..\config.sh
-
-..\git_version.h : ..\make_patchnum.pl
- cd .. && $(HPERL) -Ilib make_patchnum.pl && cd win32
-
-# make sure that we recompile perl.c if the git version changes
-$(DLLDIR)\perl.obj : ..\git_version.h
-
-MakePPPort: $(HPERL) $(CONFIGPM) Extensions_nonxs
- $(HPERL) -I..\lib ..\mkppport
-
-MakePPPort_clean:
- -if exist $(HPERL) $(HPERL) -I..\lib ..\mkppport --clean
-
-#----------------------------------------------------------------------------------
-NOT_COMPILE_EXT =
-!if "$(MACHINE)" == "wince-sh3-palm-wce211"
-NOT_COMPILE_EXT = $(NOT_COMPILE_EXT) !XS/Typemap
-!endif
-!if "$(MACHINE)" == "wince-mips-palm-wce211"
-NOT_COMPILE_EXT = $(NOT_COMPILE_EXT) !XS/Typemap
-!endif
-
-Extensions: ..\make_ext.pl $(CONFIGPM)
- $(HPERL) -I..\lib -I. ..\make_ext.pl "MAKE=$(MAKE)" --dir=$(CPANDIR) --dir=$(DISTDIR) --dir=$(EXTDIR) --all \
- !POSIX !Win32 !Win32API/File !Time/HiRes !Time/Piece !re !SDBM_File $(NOT_COMPILE_EXT)
-
-
-Extensions_nonxs: ..\make_ext.pl ..\lib\buildcustomize.pl $(CONFIGPM) ..\pod\perlfunc.pod
- $(XCOPY) ..\*.h $(COREDIR)\*.*
- $(HPERL) -I..\lib ..\make_ext.pl "MAKE=$(MAKE)" --dir=$(CPANDIR) --dir=$(DISTDIR) --dir=$(EXTDIR) --nonxs
-
-Extensions_clean:
- -if exist $(HPERL) $(HPERL) -I..\lib ..\make_ext.pl "MAKE=$(MAKE)" --dir=$(CPANDIR) --dir=$(DISTDIR) --dir=$(EXTDIR) --all --target=clean
-
-#----------------------------------------------------------------------------------
-
-$(PERLEXE_RES): perlexe.rc perl.rc $(PERLEXE_MANIFEST) $(PERLEXE_ICO)
- rc $(RCDEFS) perlexe.rc
-
-clean: Extensions_clean
- -if exist .\$(MACHINE)\dll rmdir /s /q .\$(MACHINE)\dll
- -@$(DEL) .\$(MACHINE)\*.obj
- -@$(DEL) .\$(MACHINE)\*.exe
- -@$(DEL) .\$(MACHINE)\*.dll
- -@$(DEL) .\$(MACHINE)\*.lib
- -@$(DEL) .\$(MACHINE)\*.exp
- -@$(DEL) .\$(MACHINE)\*.pdb
- -@$(DEL) ..\git_version.h
- -@$(DEL) config.h perl.res
- -@$(DEL) ..\t\test_state
-
-XDLLOBJS = \
-$(DLLDIR)\av.obj \
-$(DLLDIR)\caretx.obj \
-$(DLLDIR)\deb.obj \
-$(DLLDIR)\doio.obj \
-$(DLLDIR)\doop.obj \
-$(DLLDIR)\dump.obj \
-$(DLLDIR)\globals.obj \
-$(DLLDIR)\gv.obj \
-$(DLLDIR)\mro.obj \
-$(DLLDIR)\hv.obj \
-$(DLLDIR)\locale.obj \
-$(DLLDIR)\keywords.obj \
-$(DLLDIR)\mathoms.obj \
-$(DLLDIR)\mg.obj \
-$(DLLDIR)\numeric.obj \
-$(DLLDIR)\op.obj \
-$(DLLDIR)\pad.obj \
-$(DLLDIR)\perl.obj \
-$(DLLDIR)\perlapi.obj \
-$(DLLDIR)\perlio.obj \
-$(DLLDIR)\perly.obj \
-$(DLLDIR)\pp.obj \
-$(DLLDIR)\pp_ctl.obj \
-$(DLLDIR)\pp_hot.obj \
-$(DLLDIR)\pp_pack.obj \
-$(DLLDIR)\pp_sort.obj \
-$(DLLDIR)\pp_sys.obj \
-$(DLLDIR)\reentr.obj \
-$(DLLDIR)\regcomp.obj \
-$(DLLDIR)\regexec.obj \
-$(DLLDIR)\run.obj \
-$(DLLDIR)\scope.obj \
-$(DLLDIR)\sv.obj \
-$(DLLDIR)\taint.obj \
-$(DLLDIR)\toke.obj \
-$(DLLDIR)\universal.obj \
-$(DLLDIR)\utf8.obj \
-$(DLLDIR)\util.obj \
-$(DLLDIR)\win32thread.obj \
-$(DLLDIR)\wince.obj \
-$(DLLDIR)\win32io.obj \
-$(DLLDIR)\wincesck.obj \
-$(DLLDIR)\perllib.obj \
-$(DLLDIR)\DynaLoader.obj
-!IF "$(PERL_MALLOC)" == "define"
-XDLLOBJS = $(XDLLOBJS) $(DLLDIR)\malloc.obj
-!ENDIF
-!IF "$(CRYPT_SRC)" != ""
-XDLLOBJS = $(XDLLOBJS) $(DLLDIR)\fcrypt.obj
-!ENDIF
-
-#sanity checks to make sure all our external files (celib, w32console, and
-#MS CE SDK) are locatable
-lib_check :
- @if not exist $(CECONSOLEDIR)\$(MACHINE)\w32console.obj cmd /k \
- "echo w32console.obj doesn't seem to exist, check your w32console directory \
- & exit 1"
- @if not exist $(CELIBDLLDIR)\$(MACHINE)-release\celib.lib cmd /k \
- "echo celib.lib doesn't seem to exist, check your celib directory \
- & exit 1"
- @for %X in ( $(LIBC) ) do @if exist %~^$LIB:X ( exit 0 ) \
- else ( echo $(LIBC) doesn't seem to exist, check your build enviroment & exit 1 )
-
-#specific header files to check picked at random
-header_check :
- @if not exist $(CELIBDLLDIR)\inc\cewin32.h cmd /k \
- "echo cewin32.h doesn't seem to exist, check your celib directory \
- & exit 1"
- @for %X in (ceconfig.h) do @if exist %~^$INCLUDE:X ( exit 0 ) \
- else ( echo ceconfig.h doesn't seem to exist, check your build enviroment & exit 1 )
-
-{$(SRCDIR)}.c{$(DLLDIR)}.obj:
- $(CC) -c $(CFLAGS_O) -DPERL_EXTERNAL_GLOB -Fo$(DLLDIR)\ $<
-
-# compiler explains that it will optimize toke.c if we'll give it an
-# option -QMOb<num> with num>=4178
-$(DLLDIR)\toke.obj:
- $(CC) -c $(CFLAGS_O) -QMOb9000 -DPERL_EXTERNAL_GLOB -Fo$(DLLDIR)\ ..\toke.c
-
-{$(SRCDIR)/win32}.c{$(DLLDIR)}.obj:
- $(CC) -c $(CFLAGS_O) -DPERL_EXTERNAL_GLOB -Fo$(DLLDIR)\ $<
-
-# -DPERL_IMPLICIT_SYS needs C++ for perllib.c
-# This is the only file that depends on perlhost.h, vmem.h, and vdir.h
-!IF "$(USE_IMP_SYS)" == "define"
-$(DLLDIR)\perllib$(o) : perllib.c .\perlhost.h .\vdir.h .\vmem.h
- $(CC) -c -I. $(CFLAGS_O) $(CXX_FLAG) $(OBJOUT_FLAG)$@ perllib.c
- rem (frustrated) mv perllib.obj $(DLLDIR)
-!ENDIF
-
-perldll.def : $(HPERL) $(CONFIGPM) ..\embed.fnc ..\makedef.pl create_perllibst_h.pl .\config.h
- $(HPERL) -I..\lib create_perllibst_h.pl
- $(HPERL) -I..\lib -w ..\makedef.pl PLATFORM=wince $(OPTIMIZE) $(DEFINES) $(BUILDOPT) \
- CCTYPE=$(CCTYPE) -DPERL_DLL=$(PERLDLL) TARG_DIR=..\ > perldll.def
-
-$(PERLDLL) : header_check lib_check $(DLLDIR) perldll.def $(XDLLOBJS) $(PERLDLL_RES)
- $(LINK32) -dll -def:perldll.def -base:0x28000000 -out:$@ \
- $(SUBSYS) $(LDLIBPATH) \
- $(LINK_FLAGS) $(LIBFILES) \
- $(XDLLOBJS) $(PERLDLL_RES)
-
-$(DLLDIR) :
- if not exist "$(DLLDIR)" mkdir "$(DLLDIR)"
-
-$(EXTDIR)\DynaLoader\DynaLoader.c :
- $(HPERL) -I..\lib -I. ..\make_ext.pl "MAKE=$(MAKE)" --dir=$(EXTDIR) --dynaloader
-
-$(DLLDIR)\DynaLoader.obj: $(EXTDIR)\DynaLoader\DynaLoader.c
- $(CC) -c $(CFLAGS_O) -DPERL_EXTERNAL_GLOB -Fo$(DLLDIR)\ \
- $(EXTDIR)\DynaLoader\DynaLoader.c
-
-XPERLEXEOBJS = \
-$(MACHINE)\perlmaince.obj
-
-..\lib\buildcustomize.pl :
- $(HPERL) -I..\lib -f ..\write_buildcustomize.pl ..
-
-$(PERLEXE) : $(PERLDLL) $(CONFIGPM) $(XPERLEXEOBJS) $(PERLEXE_RES) $(STARTOBJS)
- $(XCOPY) $(MACHINE)\*.lib $(COREDIR)
- $(LINK32) $(SUBSYS) $(LDLIBPATH) \
- -entry:wWinMainCRTStartup \
- -out:$(MACHINE)\perl.exe \
- -stack:0x100000 $(LINK_FLAGS) $(STARTOBJS) $(XPERLEXEOBJS) \
- $(PERLIMPLIB) $(PERLEXE_RES) $(LIBFILES)
-
-$(MACHINE)\perlmaince.obj : perlmaince.c
- $(CC) $(CFLAGS_O) -UPERLDLL -Fo$(MACHINE)\ -c perlmaince.c
-
-iodll: $(IO_DLL)
-socketdll: $(SOCKET_DLL)
-dumperdll: $(DUMPER_DLL)
-
-dlls: socketdll iodll dumperdll
- -xmkdir -p $(MACHINE)/lib/auto/IO
- copy ../lib/auto/IO/IO.bs $(MACHINE)/lib/auto/IO
- copy ../lib/auto/IO/IO.dll $(MACHINE)/lib/auto/IO
- -xmkdir $(MACHINE)/lib/auto/Socket
- copy ../lib/auto/Socket/Socket.bs $(MACHINE)/lib/auto/Socket
- copy ../lib/auto/Socket/Socket.dll $(MACHINE)/lib/auto/Socket
- -xmkdir -p $(MACHINE)/lib/auto/Data/Dumper
- copy ../lib/auto/Data/Dumper/Dumper.bs $(MACHINE)/lib/auto/Data/Dumper
- copy ../lib/auto/Data/Dumper/Dumper.dll $(MACHINE)/lib/auto/Data/Dumper
-
-makedist: all dlls
- $(COPY) $(CELIBPATH)\celib.dll $(MACHINE)
- copy perl.txt $(MACHINE)
- copy registry.bat $(MACHINE)
- copy ../lib/Config.pm $(MACHINE)/lib
- cd $(MACHINE)
- -@$(DEL) perl-$(MACHINE).tar.gz
- sh -c "tar cf perl-$(MACHINE).tar *.exe *.dll *.txt *.bat lib"
- gzip -9 perl-$(MACHINE).tar
- mv perl-$(MACHINE).tar.gz h:/freenet/new
- cd ..
-
-install: all
- -cemkdir "$(INSTALL_ROOT)"
- -cemkdir "$(INSTALL_ROOT)\bin"
- -cemkdir "$(INSTALL_ROOT)\lib"
- $(CECOPY) "pc:$(MACHINE)/perl.exe" "ce:$(INSTALL_ROOT)/bin"
- $(CECOPY) "pc:$(MACHINE)/perl$(PV).dll" "ce:$(INSTALL_ROOT)/bin"
- $(CECOPY) "pc:../lib/Config.pm" "ce:$(INSTALL_ROOT)/lib"
-
-$(UNIDATAFILES) : $(HPERL) $(CONFIGPM) ..\lib\unicore\mktables MakePPPort
- cd ..\lib\unicore && \
- $(HPERL) -I.. -I..\..\lib mktables -P ..\..\pod -maketest -makelist -p -check $@ $(FIRSTUNIFILE)
-
-dist: all
- $(HPERL) -I..\lib ce-helpers\makedist.pl --distdir=dist-$(CROSS_NAME) --cross-name=$(CROSS_NAME)
-
-zipdist: all
- $(HPERL) -I..\lib ce-helpers\makedist.pl --distdir=dist-$(CROSS_NAME) --cross-name=$(CROSS_NAME)
- $(HPERL) -I..\lib ce-helpers\makedist.pl --distdir=dist-$(CROSS_NAME) --cross-name=$(CROSS_NAME) --zip
-
-zip:
- $(HPERL) -I..\lib ce-helpers\makedist.pl --distdir=dist-$(CROSS_NAME) --cross-name=$(CROSS_NAME) --zip
-
-hostminiperl: ..\miniperl.exe
-
-..\miniperl.exe:
- set PATH=$(CCHOME)\bin;$(PATH)
- $(MAKE) -f Makefile "CCHOME=$(MSVCDIR)" "CCINCDIR=$(CCHOME)\include" "CCLIBDIR=$(CCHOME)\lib" "INCLUDE=$(CCHOME)\include" "LIB=$(CCHOME)\lib" "LINK_FLAGS=" .\config.h ..\miniperl.exe
-
-host-install:
- perl -MConfig -MExtUtils::Install -we "install({'../lib/CORE', qq#$$Config{installprefixexp}/lib/CORE#},1)"
- perl -MConfig -MExtUtils::Install -we "install({'../lib', qq#$$Config{installprefixexp}/lib#},1)"
- perl -MConfig -MFile::Copy -we "copy qq#./$(MACHINE)/perl$(PV).lib#, qq#$$Config{installprefixexp}/lib/CORE#"
- perl -MConfig -we "system qq#perl -pi.bak -we \"s{((arch^|priv)libexp)='.*'}{\$$1='# . \
- quotemeta($$Config{installprefixexp}) . \
- qq#/lib'}\" $$Config{installprefixexp}/lib/Config.pm#"
+#
+# perl makefile for wince
+# During the cross-compilation, it first uses Makefile file to build
+# miniperl on HOST and then build required platform
+#
+
+SRCDIR = ..
+PV = 59
+INST_VER = 5.10.0
+
+# INSTALL_ROOT specifies a path where this perl will be installed on CE device
+INSTALL_ROOT=/netzwerk/sprache/perl
+INST_TOP=$(INSTALL_ROOT)
+INST_VER=
+
+# PERLCEDIR shoud be set to current directory
+PERLCEDIR = H:\src\wince\perl\win32
+
+# WCEROOT is a directory where Windows CE Tools was installed
+WCEROOT = D:\Windows CE Tools
+
+# HPERL stands for host perl, which is perl on local desktop machine
+# which is usually ..\miniperl.exe
+#HPERL = N:\Programme\perl\bin\perl.exe
+HPERL = $(MAKEDIR)\..\miniperl.exe
+
+CEPATH = D:\Programme\Microsoft eMbedded Tools\EVC\WCE211\BIN
+CELIBDLLDIR = h:\src\wince\celib-palm-3.0
+CECONSOLEDIR = h:\src\wince\w32console
+
+# specify following options to build perl on local machine, by MSVC
+MSVCDIR = D:\MSVStudio\VC98
+CCHOME = $(MSVCDIR)
+CCINCDIR = $(CCHOME)\include
+CCLIBDIR = $(CCHOME)\lib
+
+# Only for WIN2000
+#YES = /y
+COPY = copy $(YES)
+XCOPY = xcopy $(YES) /f /r /i /d
+RCOPY = xcopy $(YES) /f /r /i /e /d
+
+# cecopy program. Make shure it is in your path, as well as cemkdir, cedel
+CECOPY = cecopy
+
+#
+# Comment out next assign to disable perl's I/O subsystem and use compiler's
+# stdio for IO - depending on your compiler vendor and run time library you may
+# then get a number of fails from make test i.e. bugs - complain to them not us ;-).
+# You will also be unable to take full advantage of perl5.8's support for multiple
+# encodings and may see lower IO performance. You have been warned.
+USE_PERLIO = define
+
+#
+# set this if you wish to use perl's malloc
+# This will make perl run few times faster
+# WARNING: Turning this on/off WILL break binary compatibility with extensions
+# you may have compiled with/without it.
+#
+PERL_MALLOC = define
+
+
+NOOP = @echo
+# keep this untouched!
+NULL =
+
+
+#CFG=DEBUG
+CFG=RELEASE
+
+!if "$(MACHINE)" == ""
+MACHINE=wince-arm-hpc-wce300
+#MACHINE=wince-arm-hpc-wce211
+#MACHINE=wince-sh3-hpc-wce211
+#MACHINE=wince-mips-hpc-wce211
+#MACHINE=wince-sh3-hpc-wce200
+#MACHINE=wince-mips-hpc-wce200
+#MACHINE=wince-arm-pocket-wce300
+#MACHINE=wince-mips-pocket-wce300
+#MACHINE=wince-sh3-pocket-wce300
+#MACHINE=wince-x86em-pocket-wce300
+#MACHINE=wince-mips-palm-wce211
+#MACHINE=wince-sh3-palm-wce211
+#MACHINE=wince-x86em-palm-wce211
+!endif
+
+# set this to your email address
+#
+#EMAIL =
+
+##################### CHANGE THESE ONLY IF YOU MUST #####################
+
+######################################################################
+# machines
+
+!if "$(MACHINE)" == "wince-sh3-hpc-wce211"
+CC = shcl.exe
+ARCH = SH3
+CPU = SH3
+TARGETCPU = SH3
+CEVersion = 211
+OSVERSION = WCE211
+PLATFORM = MS HPC Pro
+MCFLAGS = -MDd -DSH3 -D_SH3_ -DSHx -DPROCESSOR_SH3 -DPALM_SIZE \
+ -I $(CELIBDLLDIR)\inc
+SUBSYS = -subsystem:windowsce,2.11
+CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release
+LDLIBPATH = -libpath:$(CELIBPATH)
+STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \
+ $(CECONSOLEDIR)/$(MACHINE)/w32console.obj
+!endif
+
+!if "$(MACHINE)" == "wince-mips-hpc-wce211"
+CC = clmips.exe
+ARCH = MIPS
+CPU = MIPS
+TARGETCPU = MIPS
+CEVersion = 211
+OSVERSION = WCE211
+PLATFORM = MS HPC Pro
+MCFLAGS = -D _MT -D _DLL \
+ -D MIPS -D mips -D _MIPS_ -D _mips_ -DPROCESSOR_MIPS \
+ -D PALM_SIZE \
+ -I $(CELIBDLLDIR)\inc
+SUBSYS = -subsystem:windowsce,2.11
+CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release
+LDLIBPATH = -libpath:$(CELIBPATH)
+STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \
+ $(CECONSOLEDIR)/$(MACHINE)/w32console.obj
+!endif
+
+!if "$(MACHINE)" == "wince-mips-hpc-wce200"
+CC = clmips.exe
+ARCH = MIPS
+CPU = MIPS
+TARGETCPU = MIPS
+CEVersion = 200
+OSVERSION = WCE200
+PLATFORM = MS HPC
+# MUST USE -MD to get the right FPE stuff...
+MCFLAGS = -D _MT -D _DLL -MD \
+ -D MIPS -D mips -D _MIPS_ -D _mips_ -DPROCESSOR_MIPS \
+ -D PALM_SIZE \
+ -I $(CELIBDLLDIR)\inc
+SUBSYS = -subsystem:windowsce,2.00
+CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release
+LDLIBPATH = -libpath:$(CELIBPATH)
+STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \
+ $(CECONSOLEDIR)/$(MACHINE)/w32console.obj
+!endif
+
+!if "$(MACHINE)" == "wince-sh3-hpc-wce200"
+CC = shcl.exe
+ARCH = SH3
+CPU = SH3
+TARGETCPU = SH3
+CEVersion = 200
+OSVERSION = WCE200
+PLATFORM = MS HPC
+# MUST USE -MD to get the right FPE stuff...
+MCFLAGS = -D _MT -D _DLL -MD \
+ -D SH3 -D sh3 -D _SH3_ -D _sh3_ -D SHx -DPROCESSOR_SH3 \
+ -D PALM_SIZE \
+ -I $(CELIBDLLDIR)\inc
+SUBSYS = -subsystem:windowsce,2.00
+CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release
+LDLIBPATH = -libpath:$(CELIBPATH)
+STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \
+ $(CECONSOLEDIR)/$(MACHINE)/w32console.obj
+!endif
+
+!if "$(MACHINE)" == "wince-arm-hpc-wce211"
+CC = clarm.exe
+ARCH = ARM
+CPU = ARM
+TARGETCPU = ARM
+CEVersion = 211
+OSVERSION = WCE211
+PLATFORM = MS HPC Pro
+MCFLAGS = -D _MT -D _DLL -D ARM -D arm -D _arm_ -D _ARM_ \
+ -DPROCESSOR_ARM -DPALM_SIZE \
+ -I $(CELIBDLLDIR)\inc
+SUBSYS = -subsystem:windowsce,2.11
+CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release
+LDLIBPATH = -libpath:$(CELIBPATH)
+STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \
+ $(CECONSOLEDIR)/$(MACHINE)/w32console.obj
+!endif
+
+!if "$(MACHINE)" == "wince-arm-hpc-wce300"
+CC = clarm.exe
+ARCH = ARM
+CPU = ARM
+TARGETCPU = ARM
+CEVersion = 300
+OSVERSION = WCE300
+#PLATFORM = HPC2000
+MCFLAGS = -D _MT -D _DLL -D ARM -D arm -D _arm_ -D _ARM_ \
+ -DPROCESSOR_ARM -DPALM_SIZE \
+ -I $(CELIBDLLDIR)\inc
+SUBSYS = -subsystem:windowsce,3.00
+CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release
+LDLIBPATH = -libpath:$(CELIBPATH)
+STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \
+ $(CECONSOLEDIR)/$(MACHINE)/w32console.obj
+!endif
+
+!if "$(MACHINE)" == "wince-mips-palm-wce211"
+CC = clmips.exe
+ARCH = MIPS
+CPU = MIPS
+TARGETCPU = MIPS
+CEVersion = 211
+OSVERSION = WCE211
+PLATFORM = MS Palm Size PC
+MCFLAGS = -DMIPS -D_MIPS_ -DPROCESSOR_MIPS -D PALM_SIZE -D _DLL -D _MT \
+ -I $(CELIBDLLDIR)\inc
+SUBSYS = -subsystem:windowsce,2.11
+CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release
+LDLIBPATH = -libpath:$(CELIBPATH)
+STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \
+ $(CECONSOLEDIR)/$(MACHINE)/w32console.obj
+!endif
+
+!if "$(MACHINE)" == "wince-sh3-palm-wce211"
+CC = shcl.exe
+ARCH = SH3
+CPU = SH3
+TARGETCPU = SH3
+CEVersion = 211
+OSVERSION = WCE211
+PLATFORM = MS Palm Size PC
+MCFLAGS = -D _MT -D _DLL -DSH3 -D_SH3_ -DSHx -DPROCESSOR_SH3 -DPALM_SIZE \
+ -I $(CELIBDLLDIR)\inc
+SUBSYS = -subsystem:windowsce,2.11
+CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release
+LDLIBPATH = -libpath:$(CELIBPATH)
+STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \
+ $(CECONSOLEDIR)/$(MACHINE)/w32console.obj
+!endif
+
+!if "$(MACHINE)" == "wince-x86em-palm-wce211"
+CC = cl.exe
+ARCH = X86EM
+CPU = X86
+TARGETCPU = X86
+CEVersion = 211
+OSVERSION = WCE211
+PLATFORM = MS Palm Size PC
+MCFLAGS = -MDd -DX86 -D_X86_ -DPROCESSOR_X86 \
+ -D_WIN32_WCE_EMULATION -DPALM_SIZE \
+ -I $(CELIBDLLDIR)\inc
+MACH = -machine:x86
+SUBSYS = -subsystem:windows
+CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release
+LDLIBPATH = -libpath:$(CELIBPATH)
+STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \
+ $(CECONSOLEDIR)/$(MACHINE)/w32console.obj
+!endif
+
+!if "$(MACHINE)" == "wince-x86em-pocket-wce300"
+CC = cl.exe
+ARCH = X86EM
+CPU = X86
+TARGETCPU = X86
+CEVersion = 300
+OSVERSION = WCE300
+PLATFORM = MS Pocket PC
+MCFLAGS = -DX86 -D_X86_ -DPROCESSOR_X86 -D _MT -D _DLL \
+ -D_WIN32_WCE_EMULATION -DPALM_SIZE -DPOCKET_SIZE \
+ -I $(CELIBDLLDIR)\inc
+MACH = -machine:x86
+SUBSYS = -subsystem:windows
+CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release
+LDLIBPATH = -libpath:$(CELIBPATH)
+STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \
+ $(CECONSOLEDIR)/$(MACHINE)/w32console.obj
+!endif
+
+!if "$(MACHINE)" == "wince-mips-pocket-wce300"
+CC = clmips.exe
+ARCH = MIPS
+CPU = MIPS
+TARGETCPU = MIPS
+CEVersion = 300
+OSVERSION = WCE300
+PLATFORM = MS Pocket PC
+MCFLAGS = -D MIPS -D mips -D _MIPS_ -D _mips_ -DPROCESSOR_MIPS \
+ -D _MT -D _DLL -DPALM_SIZE -DPOCKET_SIZE \
+ -I $(CELIBDLLDIR)\inc
+MACH = -machine:mips
+SUBSYS = -subsystem:windowsce,3.00
+CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release
+#STDLIBPATH = $(WCEROOT)\$(OSVERSION)\$(PLATFORM)\lib\$(CPU)
+LDLIBPATH = -libpath:$(CELIBPATH)
+#"-libpath:$(STDLIBPATH)"
+STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \
+ $(CECONSOLEDIR)/$(MACHINE)/w32console.obj
+!endif
+
+!if "$(MACHINE)" == "wince-sh3-pocket-wce300"
+CC = shcl.exe
+ARCH = SH3
+CPU = SH3
+TARGETCPU = SH3
+CEVersion = 300
+OSVERSION = WCE300
+PLATFORM = MS Pocket PC
+MCFLAGS = -D _MT -D _DLL -DSH3 -D_SH3_ -DSHx -DPROCESSOR_SH3 \
+ -DPALM_SIZE -DPOCKET_SIZE \
+ -I $(CELIBDLLDIR)\inc
+MACH = -machine:sh3
+SUBSYS = -subsystem:windowsce,3.00
+CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release
+LDLIBPATH = -libpath:$(CELIBPATH)
+STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \
+ $(CECONSOLEDIR)/$(MACHINE)/w32console.obj
+!endif
+
+!if "$(MACHINE)" == "wince-arm-pocket-wce300"
+CC = clarm.exe
+ARCH = ARM
+CPU = ARM
+TARGETCPU = ARM
+CEVersion = 300
+OSVERSION = WCE300
+PLATFORM = MS Pocket PC
+MCFLAGS = -D ARM -D arm -D _ARM_ -D _arm_ -DPROCESSOR_ARM \
+ -D _MT -D _DLL -DPALM_SIZE -DPOCKET_SIZE \
+ -I $(CELIBDLLDIR)\inc
+MACH = -machine:arm
+SUBSYS = -subsystem:windowsce,3.00
+CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release
+LDLIBPATH = -libpath:$(CELIBPATH)
+STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \
+ $(CECONSOLEDIR)/$(MACHINE)/w32console.obj
+!endif
+
+######################################################################
+# common section
+
+CEDEFS = -D_WINDOWS -D_WIN32_WCE=$(CEVersion) -DUNDER_CE=$(CEVersion) \
+ $(MCFLAGS) -D PERL
+
+CECFLAGS = $(CEDEFS)
+
+!if "$(CFG)" == "DEBUG"
+CECFLAGS = $(CECFLAGS) -Zi -Od
+!endif
+
+!if "$(CFG)" == "RELEASE"
+# -O2 and -Ot give internal compiler error in perl.c and lexer.
+# Also the dll cannot be loaded by perl.exe...
+!if "$(CPU)" == "SH3"
+!else
+CECFLAGS = $(CECFLAGS) -O2 -Ot
+!endif
+
+!endif
+
+RCDEFS = /l 0x407 /r /d "UNICODE" /d UNDER_CE=$(CEVersion) \
+ /d _WIN32_WCE=$(CEVersion)
+
+PATH=$(CEPATH);$(PATH)
+
+INCLUDE=$(WCEROOT)\$(OSVERSION)\$(PLATFORM)\include
+LIB=$(WCEROOT)\$(OSVERSION)\$(PLATFORM)\lib\$(ARCH)
+
+######################################################################
+
+!message
+!message Compiling for $(MACHINE)
+!message LIB=$(LIB)
+!message INCLUDE=$(INCLUDE)
+!message PATH=$(CEPATH)
+!message
+
+######################################################################
+#
+# Additional compiler flags can be specified here.
+#
+
+BUILDOPT = $(BUILDOPT) $(CECFLAGS) -DUSE_CROSS_COMPILE
+
+
+!IF "$(CRYPT_SRC)$(CRYPT_LIB)" == ""
+D_CRYPT = undef
+!ELSE
+D_CRYPT = define
+CRYPT_FLAG = -DHAVE_DES_FCRYPT
+!ENDIF
+
+!IF "$(PERL_MALLOC)" == ""
+PERL_MALLOC = undef
+!ENDIF
+
+!IF "$(USE_MULTI)" == ""
+USE_MULTI = undef
+!ENDIF
+
+!IF "$(USE_ITHREADS)" == ""
+USE_ITHREADS = undef
+!ENDIF
+
+!IF "$(USE_IMP_SYS)" == ""
+USE_IMP_SYS = undef
+!ENDIF
+
+!IF "$(USE_PERLIO)" == ""
+USE_PERLIO = undef
+!ENDIF
+
+!IF "$(USE_PERLCRT)" == ""
+USE_PERLCRT = undef
+!ENDIF
+
+!IF "$(USE_IMP_SYS)$(USE_MULTI)" == "defineundef"
+USE_MULTI = define
+!ENDIF
+
+!IF "$(USE_ITHREADS)$(USE_MULTI)" == "defineundef"
+USE_MULTI = define
+!ENDIF
+
+!IF "$(USE_MULTI)" != "undef"
+BUILDOPT = $(BUILDOPT) -DPERL_IMPLICIT_CONTEXT
+!ENDIF
+
+!IF "$(USE_IMP_SYS)" != "undef"
+BUILDOPT = $(BUILDOPT) -DPERL_IMPLICIT_SYS
+!ENDIF
+
+!IF "$(USE_PERLIO)" == "define"
+BUILDOPT = $(BUILDOPT) -DUSE_PERLIO
+!ENDIF
+
+!IF "$(CROSS_NAME)" == ""
+CROSS_NAME = $(MACHINE)
+!ENDIF
+
+# new option - automatically defined in perl.h...
+#BUILDOPT = $(BUILDOPT) -DUSE_ENVIRON_ARRAY
+
+PROCESSOR_ARCHITECTURE = $(TARGETCPU)
+ARCHNAME = $(PLATFORM)-$(OSVERSION)-$(PROCESSOR_ARCHITECTURE)
+ARCHDIR = ..\lib\$(ARCHNAME)
+COREDIR = ..\lib\CORE
+XCOREDIR = ..\xlib\$(CROSS_NAME)\CORE
+AUTODIR = ..\lib\auto
+LIBDIR = ..\lib
+EXTDIR = ..\ext
+PODDIR = ..\pod
+EXTUTILSDIR = $(LIBDIR)\ExtUtils
+
+LINK32 = link
+LIB32 = $(LINK32) -lib
+RSC = rc
+
+INCLUDES = -I.\include -I. -I..
+DEFINES = -DWIN32 -D_CONSOLE -DNO_STRICT $(CRYPT_FLAG) $(CECFLAGS)
+LOCDEFS = -DPERLDLL -DPERL_CORE
+CXX_FLAG = -TP
+
+PERLEXE_RES = perl.res
+PERLDLL_RES =
+
+!if "$(CFG)" == "RELEASE"
+CELIB = celib.lib
+!endif
+
+!if "$(CFG)" == "DEBUG"
+CELIB = celib.lib
+!endif
+
+CELIBS = -nodefaultlib \
+ winsock.lib $(CELIB) coredll.lib
+
+!if $(CEVersion) > 200
+CELIBS = $(CELIBS) corelibc.lib
+!else
+CELIBS = $(CELIBS) msvcrt.lib
+!endif
+
+LIBBASEFILES = $(CRYPT_LIB) $(CELIBS)
+
+LIBFILES = $(LIBBASEFILES) $(LIBC)
+
+CFLAGS = -nologo -Gf -W3 $(INCLUDES) $(DEFINES) $(LOCDEFS) \
+ $(PCHFLAGS) $(OPTIMIZE)
+
+LINK_FLAGS = -nologo -machine:$(PROCESSOR_ARCHITECTURE)
+
+!if "$(CFG)" == "DEBUG"
+LINK_FLAGS = $(LINK_FLAGS) -debug:full -pdb:none
+!else
+LINK_FLAGS = $(LINK_FLAGS) -release
+!endif
+
+OBJOUT_FLAG = -Fo
+EXEOUT_FLAG = -Fe
+
+CFLAGS_O = $(CFLAGS) $(BUILDOPT)
+
+o = .obj
+
+#
+# Rules
+#
+
+.SUFFIXES : .c $(o) .dll .lib .exe .rc .res
+
+.c$(o):
+ $(CC) -c -I$(<D) $(CFLAGS_O) $(OBJOUT_FLAG)$@ $<
+
+.y.c:
+ $(NOOP)
+
+$(o).dll:
+ $(LINK32) -dll $(SUBSYS) $(LDLIBPATH) \
+ -implib:$(*B).lib -def:$(*B).def \
+ -out:$@ $(LINK_FLAGS) $(LIBFILES) $< $(LIBPERL)
+
+.rc.res:
+ $(RSC) -i.. $<
+
+# This must be relative to ../lib/CORE, else the ext dll build fails...
+PERLIMPLIB_EXP = ..\..\..\xlib\$(CROSS_NAME)\CORE\perl$(PV).lib
+PERLIMPLIB = $(PERLCEDIR)\$(MACHINE)\perl$(PV).lib
+PERLDLL = $(MACHINE)\perl$(PV).dll
+
+DLLDIR = $(MACHINE)\dll
+PERLEXE = $(MACHINE)\perl.exe
+
+CONFIGPM = ..\xlib\$(CROSS_NAME)\Config.pm
+MINIMOD = ..\lib\ExtUtils\Miniperl.pm
+
+# Unicode data files generated by mktables
+UNIDATAFILES = ..\lib\unicore\Canonical.pl ..\lib\unicore\Exact.pl \
+ ..\lib\unicore\Properties ..\lib\unicore\Decomposition.pl \
+ ..\lib\unicore\CombiningClass.pl ..\lib\unicore\Name.pl \
+ ..\lib\unicore\PVA.pl
+
+# Directories of Unicode data files generated by mktables
+UNIDATADIR1 = ..\lib\unicore\To
+UNIDATADIR2 = ..\lib\unicore\lib
+
+# Nominate a target which causes extensions to be re-built
+# This used to be $(PERLEXE), but at worst it is the .dll that they depend
+# on and really only the interface - i.e. the .def file used to export symbols
+# from the .dll
+PERLDEP = perldll.def
+
+MAKE = nmake -nologo
+
+CFGSH_TMPL = config.ce
+CFGH_TMPL = config_H.ce
+
+#
+# filenames given to xsubpp must have forward slashes (since it puts
+# full pathnames in #line strings)
+XSUBPP = $(HPERL) -I..\..\lib -MCross=$(CROSS_NAME) ..\$(EXTUTILSDIR)\xsubpp \
+ -C++ -prototypes
+
+MICROCORE_SRC = \
+ ..\av.c \
+ ..\deb.c \
+ ..\doio.c \
+ ..\doop.c \
+ ..\dump.c \
+ ..\globals.c \
+ ..\gv.c \
+ ..\mro.c \
+ ..\hv.c \
+ ..\mg.c \
+ ..\op.c \
+ ..\pad.c \
+ ..\perl.c \
+ ..\perlapi.c \
+ ..\perly.c \
+ ..\pp.c \
+ ..\pp_ctl.c \
+ ..\pp_hot.c \
+ ..\pp_pack.c \
+ ..\pp_sort.c \
+ ..\pp_sys.c \
+ ..\reentr.c \
+ ..\regcomp.c \
+ ..\regexec.c \
+ ..\run.c \
+ ..\scope.c \
+ ..\sv.c \
+ ..\taint.c \
+ ..\toke.c \
+ ..\universal.c \
+ ..\utf8.c \
+ ..\util.c \
+ ..\xsutils.c
+
+EXTRACORE_SRC = $(EXTRACORE_SRC) perllib.c
+
+!IF "$(PERL_MALLOC)" == "define"
+EXTRACORE_SRC = $(EXTRACORE_SRC) ..\malloc.c
+!ENDIF
+
+EXTRACORE_SRC = $(EXTRACORE_SRC) ..\perlio.c .\win32io.c
+
+WIN32_SRC = \
+ .\wince.c \
+ .\wincesck.c \
+ .\win32thread.c
+
+!IF "$(CRYPT_SRC)" != ""
+WIN32_SRC = $(WIN32_SRC) .\$(CRYPT_SRC)
+!ENDIF
+
+DLL_SRC = $(DYNALOADER).c
+
+CORE_NOCFG_H = \
+ ..\av.h \
+ ..\cop.h \
+ ..\cv.h \
+ ..\dosish.h \
+ ..\embed.h \
+ ..\form.h \
+ ..\gv.h \
+ ..\handy.h \
+ ..\hv.h \
+ ..\iperlsys.h \
+ ..\mg.h \
+ ..\nostdio.h \
+ ..\op.h \
+ ..\opcode.h \
+ ..\perl.h \
+ ..\perlapi.h \
+ ..\perlsdio.h \
+ ..\perlsfio.h \
+ ..\perly.h \
+ ..\pp.h \
+ ..\proto.h \
+ ..\regexp.h \
+ ..\scope.h \
+ ..\sv.h \
+ ..\thread.h \
+ ..\unixish.h \
+ ..\utf8.h \
+ ..\util.h \
+ ..\warnings.h \
+ ..\XSUB.h \
+ ..\EXTERN.h \
+ ..\perlvars.h \
+ ..\intrpvar.h \
+ .\include\dirent.h \
+ .\include\netdb.h \
+ .\include\sys\socket.h \
+ .\win32.h
+
+DYNAMIC_EXT = Socket IO Fcntl Opcode SDBM_File POSIX attrs B re \
+ Data/Dumper Devel/Peek ByteLoader Devel/DProf File/Glob \
+ Sys/Hostname
+
+STATIC_EXT = DynaLoader
+
+DYNALOADER = $(EXTDIR)\DynaLoader\DynaLoader
+
+ERRNO_PM = $(LIBDIR)\Errno.pm
+
+
+EXTENSION_PM = \
+ $(ERRNO_PM)
+
+POD2HTML = $(PODDIR)\pod2html
+POD2MAN = $(PODDIR)\pod2man
+POD2LATEX = $(PODDIR)\pod2latex
+POD2TEXT = $(PODDIR)\pod2text
+
+CFG_VARS = \
+ "INST_DRV=$(INST_DRV)" \
+ "INST_TOP=$(INST_TOP)" \
+ "INST_VER=$(INST_VER)" \
+ "INST_ARCH=$(INST_ARCH)" \
+ "archname=$(ARCHNAME)" \
+ "CC=$(CC)" \
+ "ccflags=$(OPTIMIZE) $(DEFINES) $(BUILDOPT)" \
+ "cppflags=$(OPTIMIZE) $(DEFINES) $(BUILDOPT)" \
+ "cf_by=vkon" \
+ "cf_email=$(EMAIL)" \
+ "d_crypt=$(D_CRYPT)" \
+ "d_mymalloc=$(PERL_MALLOC)" \
+ "libs=$(LIBFILES)" \
+ "incpath=$(CCINCDIR)" \
+ "libperl=$(PERLIMPLIB_EXP)" \
+ "libpth=$(LIBPATH)" \
+ "libc=$(LIBC)" \
+ "make=nmake" \
+ "static_ext=$(STATIC_EXT)" \
+ "dynamic_ext=$(DYNAMIC_EXT)" \
+ "useithreads=$(USE_ITHREADS)" \
+ "usemultiplicity=$(USE_MULTI)" \
+ "useperlio=$(USE_PERLIO)" \
+ "LINK_FLAGS=$(LDLIBPATH) $(LINK_FLAGS) $(SUBSYS)" \
+ "optimize=$(OPTIMIZE)"
+
+#
+# Top targets
+#
+
+all: hostminiperl $(MINIMOD) $(CONFIGPM) $(UNIDATAFILES) $(PERLEXE) MakePPPort Extensions
+
+$(DYNALOADER)$(o) : $(DYNALOADER).c xconfig.h $(EXTDIR)\DynaLoader\dlutils.c
+
+$(CONFIGPM) : $(HPERL) ..\config.sh .\xconfig.h config_h.PL ..\minimod.pl
+ cd .. && $(HPERL) configpm --cross=$(CROSS_NAME) --no-glossary
+ -mkdir $(XCOREDIR)
+ $(XCOPY) ..\*.h $(XCOREDIR)\*.*
+ $(XCOPY) ..\*.inc $(XCOREDIR)\*.*
+ $(XCOPY) *.h $(XCOREDIR)\*.*
+ $(XCOPY) ..\ext\re\re.pm $(LIBDIR)\*.*
+ $(RCOPY) include $(XCOREDIR)\*.*
+
+.\xconfig.h:
+ -del /f xconfig.h
+ -mkdir $(XCOREDIR)
+ -$(HPERL) -I..\lib -MCross=$(CROSS_NAME) config_h.PL "INST_VER=$(INST_VER)" "CORE_DIR=$(XCOREDIR)" "CONFIG_H=xconfig.h"
+ $(XCOPY) xconfig.h $(XCOREDIR)\config.h
+
+..\config.sh: config.ce config_sh.PL
+ $(HPERL) -I..\lib -I. config_sh.PL $(CFG_VARS) config.ce > ..\config.sh
+
+$(MINIMOD) : ..\minimod.pl
+ cd .. && $(HPERL) minimod.pl > lib\ExtUtils\Miniperl.pm
+
+$(DYNALOADER).c: $(EXTDIR)\DynaLoader\dl_win32.xs $(CONFIGPM)
+ if not exist $(AUTODIR) mkdir $(AUTODIR)
+ cd $(EXTDIR)\$(*B)
+ $(HPERL) -I..\..\lib -MCross=$(CROSS_NAME) $(*B)_pm.PL
+ $(HPERL) -I..\..\lib -MCross=$(CROSS_NAME) XSLoader_pm.PL
+ cd ..\..\win32
+ $(XCOPY) $(EXTDIR)\$(*B)\$(*B).pm $(LIBDIR)\$(NULL)
+ $(XCOPY) $(EXTDIR)\$(*B)\XSLoader.pm $(LIBDIR)\$(NULL)
+ cd $(EXTDIR)\$(*B)
+ $(XSUBPP) dl_win32.xs > $(*B).c
+ cd ..\..\win32
+
+$(EXTDIR)\DynaLoader\dl_win32.xs: dl_win32.xs
+ $(COPY) dl_win32.xs $(EXTDIR)\DynaLoader\dl_win32.xs
+
+MakePPPort: $(MINIPERL) $(CONFIGPM)
+ $(HPERL) -I..\lib -MCross=$(CROSS_NAME) ..\mkppport
+
+MakePPPort_clean:
+ -if exist $(HPERL) $(HPERL) -I..\lib ..\mkppport --clean
+
+#----------------------------------------------------------------------------------
+NOT_COMPILE_EXT =
+!if "$(MACHINE)" == "wince-sh3-palm-wce211"
+NOT_COMPILE_EXT = $(NOT_COMPILE_EXT) !XS/Typemap
+!endif
+!if "$(MACHINE)" == "wince-mips-palm-wce211"
+NOT_COMPILE_EXT = $(NOT_COMPILE_EXT) !XS/Typemap
+!endif
+
+Extensions: .\buildext.pl $(PERLDEP) $(CONFIGPM)
+ $(HPERL) -I..\lib -I. -MCross=$(CROSS_NAME) .\buildext.pl $(MAKE) $(PERLDEP) $(EXTDIR) \
+ !POSIX $(NOT_COMPILE_EXT)
+
+Extensions_clean:
+ -if exist $(MINIPERL) $(MINIPERL) -I..\lib buildext.pl $(MAKE) $(PERLDEP) $(EXTDIR) clean
+
+#----------------------------------------------------------------------------------
+
+$(PERLEXE_RES): perl.rc perl.ico
+ rc $(RCDEFS) perl.rc
+
+clean:
+ -rm -f $(MACHINE)/dll/*
+ -rm -f $(MACHINE)/*.obj
+ -rm -f $(MACHINE)/*.exe
+ -rm -f $(MACHINE)/*.dll
+ -rm -f $(MACHINE)/*.lib
+ -rm -f ../config.sh ../lib/Config.pm
+ -rm -f config.h xconfig.h perl.res
+
+XDLLOBJS = \
+$(DLLDIR)\av.obj \
+$(DLLDIR)\deb.obj \
+$(DLLDIR)\doio.obj \
+$(DLLDIR)\doop.obj \
+$(DLLDIR)\dump.obj \
+$(DLLDIR)\globals.obj \
+$(DLLDIR)\gv.obj \
+$(DLLDIR)\mro.obj \
+$(DLLDIR)\hv.obj \
+$(DLLDIR)\locale.obj \
+$(DLLDIR)\mathoms.obj \
+$(DLLDIR)\mg.obj \
+$(DLLDIR)\numeric.obj \
+$(DLLDIR)\op.obj \
+$(DLLDIR)\pad.obj \
+$(DLLDIR)\perl.obj \
+$(DLLDIR)\perlapi.obj \
+$(DLLDIR)\perlio.obj \
+$(DLLDIR)\perly.obj \
+$(DLLDIR)\pp.obj \
+$(DLLDIR)\pp_ctl.obj \
+$(DLLDIR)\pp_hot.obj \
+$(DLLDIR)\pp_pack.obj \
+$(DLLDIR)\pp_sort.obj \
+$(DLLDIR)\pp_sys.obj \
+$(DLLDIR)\reentr.obj \
+$(DLLDIR)\regcomp.obj \
+$(DLLDIR)\regexec.obj \
+$(DLLDIR)\run.obj \
+$(DLLDIR)\scope.obj \
+$(DLLDIR)\sv.obj \
+$(DLLDIR)\taint.obj \
+$(DLLDIR)\toke.obj \
+$(DLLDIR)\universal.obj \
+$(DLLDIR)\utf8.obj \
+$(DLLDIR)\util.obj \
+$(DLLDIR)\win32thread.obj \
+$(DLLDIR)\wince.obj \
+$(DLLDIR)\win32io.obj \
+$(DLLDIR)\wincesck.obj \
+$(DLLDIR)\xsutils.obj \
+$(DLLDIR)\perllib.obj \
+$(DLLDIR)\DynaLoader.obj
+!IF "$(PERL_MALLOC)" == "define"
+XDLLOBJS = $(XDLLOBJS) $(DLLDIR)\malloc.obj
+!ENDIF
+!IF "$(CRYPT_SRC)" != ""
+XDLLOBJS = $(XDLLOBJS) $(DLLDIR)\fcrypt.obj
+!ENDIF
+
+{$(SRCDIR)}.c{$(DLLDIR)}.obj:
+ $(CC) -c $(CFLAGS_O) -DPERL_EXTERNAL_GLOB -Fo$(DLLDIR)\ $<
+
+# compiler explains that it will optimize toke.c if we'll give it an
+# option -QMOb<num> with num>=4178
+$(DLLDIR)\toke.obj:
+ $(CC) -c $(CFLAGS_O) -QMOb9000 -DPERL_EXTERNAL_GLOB -Fo$(DLLDIR)\ ..\toke.c
+
+{$(SRCDIR)/win32}.c{$(DLLDIR)}.obj:
+ $(CC) -c $(CFLAGS_O) -DPERL_EXTERNAL_GLOB -Fo$(DLLDIR)\ $<
+
+# -DPERL_IMPLICIT_SYS needs C++ for perllib.c
+# This is the only file that depends on perlhost.h, vmem.h, and vdir.h
+!IF "$(USE_IMP_SYS)" == "define"
+$(DLLDIR)\perllib$(o) : perllib.c .\perlhost.h .\vdir.h .\vmem.h
+ $(CC) -c -I. $(CFLAGS_O) $(CXX_FLAG) $(OBJOUT_FLAG)$@ perllib.c
+ rem (frustrated) mv perllib.obj $(DLLDIR)
+!ENDIF
+
+perldll.def : $(HPERL) $(CONFIGPM) ..\global.sym ..\pp.sym ..\makedef.pl
+ $(HPERL) -MCross -I..\lib buildext.pl --create-perllibst-h
+ $(HPERL) -w ..\makedef.pl PLATFORM=wince $(OPTIMIZE) $(DEFINES) $(BUILDOPT) \
+ CCTYPE=$(CCTYPE) -DPERL_DLL=$(PERLDLL) > perldll.def
+
+$(PERLDLL) : $(DLLDIR) perldll.def $(XDLLOBJS) $(PERLDLL_RES)
+ $(LINK32) -dll -def:perldll.def -out:$@ \
+ $(SUBSYS) $(LDLIBPATH) \
+ $(LINK_FLAGS) $(LIBFILES) \
+ $(XDLLOBJS) $(PERLDLL_RES)
+
+$(DLLDIR) :
+ if not exist "$(DLLDIR)" mkdir "$(DLLDIR)"
+
+$(DLLDIR)\DynaLoader.obj: $(EXTDIR)\DynaLoader\DynaLoader.c
+ $(CC) -c $(CFLAGS_O) -DPERL_EXTERNAL_GLOB -Fo$(DLLDIR)\ \
+ $(EXTDIR)\DynaLoader\DynaLoader.c
+
+XPERLEXEOBJS = \
+$(MACHINE)\perlmaince.obj
+
+$(PERLEXE) : $(PERLDLL) $(CONFIGPM) $(XPERLEXEOBJS) $(PERLEXE_RES) $(STARTOBJS)
+ $(XCOPY) $(MACHINE)\*.lib $(XCOREDIR)
+ $(LINK32) $(SUBSYS) $(LDLIBPATH) \
+ -entry:wWinMainCRTStartup \
+ -out:$(MACHINE)\perl.exe \
+ -stack:0x100000 $(LINK_FLAGS) $(STARTOBJS) $(XPERLEXEOBJS) \
+ $(PERLIMPLIB) $(PERLEXE_RES) $(LIBFILES)
+
+$(MACHINE)\perlmaince.obj : perlmaince.c
+ $(CC) $(CFLAGS_O) -UPERLDLL -Fo$(MACHINE)\ -c perlmaince.c
+
+iodll: $(IO_DLL)
+socketdll: $(SOCKET_DLL)
+dumperdll: $(DUMPER_DLL)
+
+dlls: socketdll iodll dumperdll
+ -xmkdir -p $(MACHINE)/lib/auto/IO
+ cp ../lib/auto/IO/IO.bs $(MACHINE)/lib/auto/IO
+ cp ../lib/auto/IO/IO.dll $(MACHINE)/lib/auto/IO
+ -xmkdir $(MACHINE)/lib/auto/Socket
+ cp ../lib/auto/Socket/Socket.bs $(MACHINE)/lib/auto/Socket
+ cp ../lib/auto/Socket/Socket.dll $(MACHINE)/lib/auto/Socket
+ -xmkdir -p $(MACHINE)/lib/auto/Data/Dumper
+ cp ../lib/auto/Data/Dumper/Dumper.bs $(MACHINE)/lib/auto/Data/Dumper
+ cp ../lib/auto/Data/Dumper/Dumper.dll $(MACHINE)/lib/auto/Data/Dumper
+
+makedist: all dlls
+ $(COPY) $(CELIBPATH)\celib.dll $(MACHINE)
+ cp perl.txt $(MACHINE)
+ cp registry.bat $(MACHINE)
+ cp ../lib/Config.pm $(MACHINE)/lib
+ cd $(MACHINE)
+ rm -f perl-$(MACHINE).tar.gz
+ sh -c "tar cf perl-$(MACHINE).tar *.exe *.dll *.txt *.bat lib"
+ gzip -9 perl-$(MACHINE).tar
+ mv perl-$(MACHINE).tar.gz h:/freenet/new
+ cd ..
+
+install: all
+ -cemkdir "$(INSTALL_ROOT)"
+ -cemkdir "$(INSTALL_ROOT)\bin"
+ -cemkdir "$(INSTALL_ROOT)\lib"
+ $(CECOPY) "pc:$(MACHINE)/perl.exe" "ce:$(INSTALL_ROOT)/bin"
+ $(CECOPY) "pc:$(MACHINE)/perl$(PV).dll" "ce:$(INSTALL_ROOT)/bin"
+ $(CECOPY) "pc:../xlib/$(CROSS_NAME)/Config.pm" "ce:$(INSTALL_ROOT)/lib"
+
+$(UNIDATAFILES) : $(HPERL) $(CONFIGPM) ..\lib\unicore\mktables
+ cd ..\lib\unicore && \
+ $(HPERL) -I.. mktables
+
+dist: all
+ $(HPERL) -I..\lib -MCross=$(CROSS_NAME) ce-helpers\makedist.pl --distdir=dist-$(CROSS_NAME) --cross-name=$(CROSS_NAME)
+
+zipdist: all
+ $(HPERL) -I..\lib -MCross=$(CROSS_NAME) ce-helpers\makedist.pl --distdir=dist-$(CROSS_NAME) --cross-name=$(CROSS_NAME)
+ $(HPERL) -I..\lib -MCross=$(CROSS_NAME) ce-helpers\makedist.pl --distdir=dist-$(CROSS_NAME) --cross-name=$(CROSS_NAME) --zip
+
+zip:
+ $(HPERL) -I..\lib -MCross=$(CROSS_NAME) ce-helpers\makedist.pl --distdir=dist-$(CROSS_NAME) --cross-name=$(CROSS_NAME) --zip
+
+perl.ico:
+ $(HPERL) -I..\lib ..\uupacktool.pl -u perlexe.ico.packd perl.ico
+
+hostminiperl: ..\miniperl.exe
+
+..\miniperl.exe:
+ set PATH=$(CCHOME)\bin;$(PATH)
+ $(MAKE) -f Makefile "CCHOME=$(MSVCDIR)" "CCINCDIR=$(CCHOME)\include" "CCLIBDIR=$(CCHOME)\lib" "INCLUDE=$(CCHOME)\include" "LIB=$(CCHOME)\lib" "LINK_FLAGS=" .\config.h ..\miniperl.exe
+
+host-install:
+ perl -MConfig -MExtUtils::Install -we "install({'../lib/CORE', qq#$$Config{installprefixexp}/xlib/$(CROSS_NAME)/CORE#},1)"
+ perl -MConfig -MExtUtils::Install -we "install({'../xlib/$(CROSS_NAME)', qq#$$Config{installprefixexp}/xlib/$(CROSS_NAME)#},1)"
+ perl -MConfig -MFile::Copy -we "copy qq#./$(MACHINE)/perl$(PV).lib#, qq#$$Config{installprefixexp}/xlib/$(CROSS_NAME)/CORE#"
+ perl -MConfig -MFile::Copy -we "copy qq#../lib/Cross.pm#, qq#$$Config{installprefixexp}/lib#"
+ perl -MConfig -we "system qq#perl -pi.bak -we \"s{((arch^|priv)libexp)='.*'}{\$$1='# . \
+ quotemeta($$Config{installprefixexp}) . \
+ qq#/xlib/$(CROSS_NAME)'}\" $$Config{installprefixexp}/xlib/$(CROSS_NAME)/Config.pm#"
diff --git a/gnu/usr.bin/perl/win32/ce-helpers/cecopy-lib.pl b/gnu/usr.bin/perl/win32/ce-helpers/cecopy-lib.pl
index 23f9f03aff0..35bba3b2d78 100644
--- a/gnu/usr.bin/perl/win32/ce-helpers/cecopy-lib.pl
+++ b/gnu/usr.bin/perl/win32/ce-helpers/cecopy-lib.pl
@@ -40,7 +40,6 @@ sub BEGIN {
bytes.pm
Carp.pm
charnames.pm
- _charnames.pm
Config.pm
constant.pm
Cwd.pm
diff --git a/gnu/usr.bin/perl/win32/config_H.ce b/gnu/usr.bin/perl/win32/config_H.ce
index 196f419ab7f..ce98d7d922a 100644
--- a/gnu/usr.bin/perl/win32/config_H.ce
+++ b/gnu/usr.bin/perl/win32/config_H.ce
@@ -227,7 +227,7 @@
* This symbol, if defined, indicates that the localeconv routine is
* available for numeric and monetary formatting conventions.
*/
-/*#define HAS_LOCALECONV /**/
+#define HAS_LOCALECONV /**/
/* HAS_LOCKF:
* This symbol, if defined, indicates that the lockf routine is
@@ -636,12 +636,6 @@
*/
#define I_ARPA_INET /**/
-/* I_ASSERT:
- * This symbol, if defined, indicates to the C program that it could
- * include <assert.h> to get the assert() macro.
- */
-#define I_ASSERT /**/
-
/* I_DBM:
* This symbol, if defined, indicates that <dbm.h> exists and should
* be included.
@@ -651,7 +645,7 @@
* should be included.
*/
/*#define I_DBM /**/
-/*#define I_RPCSVC_DBM / **/
+#define I_RPCSVC_DBM /**/
/* I_DIRENT:
* This symbol, if defined, indicates to the C program that it should
@@ -728,6 +722,12 @@
*/
/*#define I_NETINET_IN /**/
+/* I_SFIO:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sfio.h>.
+ */
+/*#define I_SFIO /**/
+
/* I_STDDEF:
* This symbol, if defined, indicates that <stddef.h> exists and should
* be included.
@@ -932,7 +932,7 @@
* double, or a long double when applicable. Usual values are 2,
* 4 and 8. The default is eight, for safety.
*/
-#if defined(MULTIARCH)
+#if defined(USE_CROSS_COMPILE) || defined(MULTIARCH)
# define MEM_ALIGNBYTES 8
#else
#define MEM_ALIGNBYTES 8
@@ -1017,7 +1017,7 @@
* so the default case (for NeXT) is big endian to catch them.
* This might matter for NeXT 3.0.
*/
-#if defined(MULTIARCH)
+#if defined(USE_CROSS_COMPILE) || defined(MULTIARCH)
# ifdef __LITTLE_ENDIAN__
# if LONGSIZE == 4
# define BYTEORDER 0x1234
@@ -1044,12 +1044,6 @@
#define BYTEORDER 0x1234 /* large digits for MSB */
#endif /* NeXT */
-/* CHARBITS:
- * This symbol contains the size of a char, so that the C preprocessor
- * can make decisions based on it.
- */
-#define CHARBITS 8 /**/
-
/* CAT2:
* This macro concatenates 2 tokens together.
*/
@@ -1889,16 +1883,9 @@
/* LOCALTIME_R_NEEDS_TZSET:
* Many libc's localtime_r implementations do not call tzset,
* making them differ from localtime(), and making timezone
- * changes using \undef{TZ} without explicitly calling tzset
+ * changes using $ENV{TZ} without explicitly calling tzset
* impossible. This symbol makes us call tzset before localtime_r
*/
-/*#define LOCALTIME_R_NEEDS_TZSET /**/
-#ifdef LOCALTIME_R_NEEDS_TZSET
-#define L_R_TZSET tzset(),
-#else
-#define L_R_TZSET
-#endif
-
/* LOCALTIME_R_PROTO:
* This symbol encodes the prototype of localtime_r.
* It is zero if d_localtime_r is undef, and one of the
@@ -1906,6 +1893,7 @@
* is defined.
*/
/*#define HAS_LOCALTIME_R /**/
+/*#define LOCALTIME_R_NEEDS_TZSET /**/
#define LOCALTIME_R_PROTO 0 /**/
/* HAS_LONG_DOUBLE:
@@ -2261,6 +2249,12 @@
*/
/*#define HAS_SETVBUF /**/
+/* USE_SFIO:
+ * This symbol, if defined, indicates that sfio should
+ * be used.
+ */
+/*#define USE_SFIO /**/
+
/* HAS_SHM:
* This symbol, if defined, indicates that the entire shm*(2) library is
* supported.
@@ -2304,27 +2298,6 @@
#define Siglongjmp(buf,retval) longjmp((buf),(retval))
#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_SITECUSTOMIZE:
* This symbol, if defined, indicates that sitecustomize should
* be used.
@@ -3269,13 +3242,7 @@
* This symbol contains the number of bits a variable of type NVTYPE
* can preserve of a variable of type UVTYPE.
*/
-/* NV_OVERFLOWS_INTEGERS_AT
- * This symbol gives the largest integer value that NVs can hold. This
- * value + 1.0 cannot be stored accurately. It is expressed as constant
- * floating point expression to reduce the chance of decimale/binary
- * conversion issues. If it can not be determined, the value 0 is given.
- */
-/* NV_ZERO_IS_ALLBITS_ZERO
+/* NV_ZERO_IS_ALLBITS_ZERO:
* This symbol, if defined, indicates that a variable of type NVTYPE
* stores 0.0 in memory as all bits zero.
*/
@@ -3307,7 +3274,6 @@
#define NVSIZE 8 /**/
#define NV_PRESERVES_UV
#define NV_PRESERVES_UV_BITS undef
-#define NV_OVERFLOWS_INTEGERS_AT 256.0*256.0*256.0*256.0*256.0*256.0*2.0*2.0*2.0*2.0*2.0
#undef NV_ZERO_IS_ALLBITS_ZERO
#if UVSIZE == 8
# ifdef BYTEORDER
@@ -3382,7 +3348,7 @@
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
#define PRIVLIB "\\Storage Card\\perl58m\\lib" /**/
-#define PRIVLIB_EXP (win32_get_privlib(PERL_VERSION_STRING, NULL)) /**/
+#define PRIVLIB_EXP (win32_get_privlib("5.10.0")) /**/
/* PTRSIZE:
* This symbol contains the size of a pointer, so that the C preprocessor
@@ -3513,7 +3479,7 @@
* be tacked onto this variable to generate a list of directories to search.
*/
#define SITELIB "\\Storage Card\\perl58m\\site\\lib" /**/
-#define SITELIB_EXP (win32_get_sitelib(PERL_VERSION_STRING, NULL)) /**/
+#define SITELIB_EXP (win32_get_sitelib("5.10.0")) /**/
#define SITELIB_STEM "" /**/
/* Size_t_size:
@@ -3692,12 +3658,6 @@
/*#define OLD_PTHREADS_API /**/
/*#define USE_REENTRANT_API /**/
-/* USE_DTRACE
- * This symbol, if defined, indicates that Perl should
- * be built with support for DTrace.
- */
-/*#define USE_DTRACE / **/
-
/* 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
@@ -3728,6 +3688,31 @@
/*#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:
+ *
+ * 1 = supports declaration of void
+ * 2 = supports arrays of pointers to functions returning void
+ * 4 = supports comparisons between pointers to void functions and
+ * addresses of void functions
+ * 8 = suports declaration of generic void pointers
+ *
+ * The package designer should define VOIDUSED to indicate the requirements
+ * of the package. This can be done either by #defining VOIDUSED before
+ * including config.h, or by defining defvoidused in Myinit.U. If the
+ * latter approach is taken, only those flags will be tested. If the
+ * level of void support necessary is not present, defines void to int.
+ */
+#ifndef VOIDUSED
+#define VOIDUSED 15
+#endif
+#define VOIDFLAGS 15
+#if (VOIDFLAGS & VOIDUSED) != VOIDUSED
+#define void int /* is void to be avoided? */
+#define M_VOID /* Xenix strikes again */
+#endif
+
/* HASATTRIBUTE_FORMAT:
* Can we handle GCC attribute for checking printf-style formats
*/
@@ -4395,25 +4380,5 @@
*/
/*#define HAS_TTYNAME_R /**/
#define TTYNAME_R_PROTO 0 /**/
-/* GMTIME_MAX:
- * This symbol contains the maximum value for the time_t offset that
- * the system function gmtime () accepts, and defaults to 0
- */
-/* GMTIME_MIN:
- * This symbol contains the minimum value for the time_t offset that
- * the system function gmtime () accepts, and defaults to 0
- */
-/* LOCALTIME_MAX:
- * This symbol contains the maximum value for the time_t offset that
- * the system function localtime () accepts, and defaults to 0
- */
-/* LOCALTIME_MIN:
- * This symbol contains the minimum value for the time_t offset that
- * the system function localtime () accepts, and defaults to 0
- */
-#define GMTIME_MAX 2147483647 /**/
-#define GMTIME_MIN 0 /**/
-#define LOCALTIME_MAX 2147483647 /**/
-#define LOCALTIME_MIN 0 /**/
#endif
diff --git a/gnu/usr.bin/perl/win32/wince.c b/gnu/usr.bin/perl/win32/wince.c
index 63147cce3f7..2926803bb90 100644
--- a/gnu/usr.bin/perl/win32/wince.c
+++ b/gnu/usr.bin/perl/win32/wince.c
@@ -13,7 +13,7 @@
#define PERLIO_NOT_STDIO 0
-#if !defined(PERLIO_IS_STDIO)
+#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
#define PerlIO FILE
#endif
@@ -70,17 +70,16 @@ static int do_spawn2(pTHX_ char *cmd, int exectype);
static BOOL has_shell_metachars(char *ptr);
static long filetime_to_clock(PFILETIME ft);
static BOOL filetime_from_time(PFILETIME ft, time_t t);
-static char * get_emd_part(SV **leading, STRLEN *const len,
- char *trailing, ...);
+static char * get_emd_part(SV **leading, char *trailing, ...);
static void remove_dead_process(long deceased);
-static long find_pid(pTHX_ int pid);
+static long find_pid(int pid);
static char * qualified_path(const char *cmd);
static char * win32_get_xlib(const char *pl, const char *xlib,
- const char *libname, STRLEN *const len);
+ const char *libname);
#ifdef USE_ITHREADS
static void remove_dead_pseudo_process(long child);
-static long find_pseudo_pid(pTHX_ int pid);
+static long find_pseudo_pid(int pid);
#endif
int _fmode = O_TEXT; /* celib do not provide _fmode, so we define it here */
@@ -136,7 +135,7 @@ get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
HKEY handle;
DWORD type;
const char *subkey = "Software\\Perl";
- char *str = NULL;
+ char *str = Nullch;
long retval;
retval = XCERegOpenKeyExA(hkey, subkey, 0, KEY_READ, &handle);
@@ -172,7 +171,7 @@ get_regstr(const char *valuename, SV **svp)
/* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
static char *
-get_emd_part(SV **prev_pathp, STRLEN *const len, char *trailing_path, ...)
+get_emd_part(SV **prev_pathp, char *trailing_path, ...)
{
char base[10];
va_list ap;
@@ -229,21 +228,19 @@ get_emd_part(SV **prev_pathp, STRLEN *const len, char *trailing_path, ...)
*prev_pathp = sv_2mortal(newSVpvn("",0));
sv_catpvn(*prev_pathp, ";", 1);
sv_catpv(*prev_pathp, mod_name);
- if(len)
- *len = SvCUR(*prev_pathp);
return SvPVX(*prev_pathp);
}
- return NULL;
+ return Nullch;
}
char *
-win32_get_privlib(const char *pl, STRLEN *const len)
+win32_get_privlib(const char *pl)
{
dTHX;
char *stdlib = "lib";
char buffer[MAX_PATH+1];
- SV *sv = NULL;
+ SV *sv = Nullsv;
/* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
sprintf(buffer, "%s-%s", stdlib, pl);
@@ -251,18 +248,19 @@ win32_get_privlib(const char *pl, STRLEN *const len)
(void)get_regstr(stdlib, &sv);
/* $stdlib .= ";$EMD/../../lib" */
- return get_emd_part(&sv, len, stdlib, ARCHNAME, "bin", NULL);
+ return get_emd_part(&sv, stdlib, ARCHNAME, "bin", Nullch);
}
static char *
-win32_get_xlib(const char *pl, const char *xlib, const char *libname,
- STRLEN *const len)
+win32_get_xlib(const char *pl, const char *xlib, const char *libname)
{
dTHX;
char regstr[40];
char pathstr[MAX_PATH+1];
- SV *sv1 = NULL;
- SV *sv2 = NULL;
+ DWORD datalen;
+ int len, newsize;
+ SV *sv1 = Nullsv;
+ SV *sv2 = Nullsv;
/* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
sprintf(regstr, "%s-%s", xlib, pl);
@@ -271,7 +269,7 @@ win32_get_xlib(const char *pl, const char *xlib, const char *libname,
/* $xlib .=
* ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
sprintf(pathstr, "%s/%s/lib", libname, pl);
- (void)get_emd_part(&sv1, NULL, pathstr, ARCHNAME, "bin", pl, NULL);
+ (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, Nullch);
/* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
(void)get_regstr(xlib, &sv2);
@@ -279,26 +277,25 @@ win32_get_xlib(const char *pl, const char *xlib, const char *libname,
/* $xlib .=
* ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
sprintf(pathstr, "%s/lib", libname);
- (void)get_emd_part(&sv2, NULL, pathstr, ARCHNAME, "bin", pl, NULL);
+ (void)get_emd_part(&sv2, pathstr, ARCHNAME, "bin", pl, Nullch);
if (!sv1 && !sv2)
- return NULL;
- if (!sv1) {
- sv1 = sv2;
- } else if (sv2) {
- sv_catpvn(sv1, ";", 1);
- sv_catsv(sv1, sv2);
- }
+ return Nullch;
+ if (!sv1)
+ return SvPVX(sv2);
+ if (!sv2)
+ return SvPVX(sv1);
+
+ sv_catpvn(sv1, ";", 1);
+ sv_catsv(sv1, sv2);
- if (len)
- *len = SvCUR(sv1);
return SvPVX(sv1);
}
char *
-win32_get_sitelib(const char *pl, STRLEN *const len)
+win32_get_sitelib(const char *pl)
{
- return win32_get_xlib(pl, "sitelib", "site", len);
+ return win32_get_xlib(pl, "sitelib", "site");
}
#ifndef PERL_VENDORLIB_NAME
@@ -306,9 +303,9 @@ win32_get_sitelib(const char *pl, STRLEN *const len)
#endif
char *
-win32_get_vendorlib(const char *pl, STRLEN *const len)
+win32_get_vendorlib(const char *pl)
{
- return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME, len);
+ return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME);
}
static BOOL
@@ -409,14 +406,14 @@ win32_getpid(void)
static long
tokenize(const char *str, char **dest, char ***destv)
{
- char *retstart = NULL;
+ char *retstart = Nullch;
char **retvstart = 0;
int items = -1;
if (str) {
dTHX;
int slen = strlen(str);
- char *ret;
- char **retv;
+ register char *ret;
+ register char **retv;
Newx(ret, slen+2, char);
Newx(retv, (slen+3)/2, char*);
@@ -444,7 +441,7 @@ tokenize(const char *str, char **dest, char ***destv)
++items;
ret++;
}
- retvstart[items] = NULL;
+ retvstart[items] = Nullch;
*ret++ = '\0';
*ret = '\0';
}
@@ -499,8 +496,6 @@ get_shell(void)
int
Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
{
- PERL_ARGS_ASSERT_DO_ASPAWN;
-
Perl_croak(aTHX_ PL_no_func, "aspawn");
return -1;
}
@@ -556,7 +551,7 @@ do_spawn2(pTHX_ char *cmd, int exectype)
if (*s)
*s++ = '\0';
}
- *a = NULL;
+ *a = Nullch;
if (argv[0]) {
switch (exectype) {
case EXECF_SPAWN:
@@ -585,7 +580,7 @@ do_spawn2(pTHX_ char *cmd, int exectype)
while (++i < w32_perlshell_items)
argv[i] = w32_perlshell_vec[i];
argv[i++] = cmd;
- argv[i] = NULL;
+ argv[i] = Nullch;
switch (exectype) {
case EXECF_SPAWN:
status = win32_spawnvp(P_WAIT, argv[0],
@@ -624,24 +619,18 @@ do_spawn2(pTHX_ char *cmd, int exectype)
int
Perl_do_spawn(pTHX_ char *cmd)
{
- PERL_ARGS_ASSERT_DO_SPAWN;
-
return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
}
int
Perl_do_spawn_nowait(pTHX_ char *cmd)
{
- PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
-
return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
}
bool
Perl_do_exec(pTHX_ const char *cmd)
{
- PERL_ARGS_ASSERT_DO_EXEC;
-
do_spawn2(aTHX_ cmd, EXECF_EXEC);
return FALSE;
}
@@ -891,51 +880,7 @@ win32_longpath(char *path)
return path;
}
-static void
-out_of_memory(void)
-{
- if (PL_curinterp) {
- dTHX;
- /* 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);
- }
- exit(1);
-}
-
-/* The win32_ansipath() function takes a Unicode filename and converts it
- * into the current Windows codepage. If some characters cannot be mapped,
- * then it will convert the short name instead.
- *
- * The buffer to the ansi pathname must be freed with win32_free() when it
- * it no longer needed.
- *
- * The argument to win32_ansipath() must exist before this function is
- * called; otherwise there is no way to determine the short path name.
- *
- * Ideas for future refinement:
- * - Only convert those segments of the path that are not in the current
- * codepage, but leave the other segments in their long form.
- * - If the resulting name is longer than MAX_PATH, start converting
- * additional path segments into short names until the full name
- * is shorter than MAX_PATH. Shorten the filename part last!
- */
-DllExport char *
-win32_ansipath(const WCHAR *widename)
-{
- char *name;
- size_t widelen = wcslen(widename)+1;
- int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
- NULL, 0, NULL, NULL);
- name = win32_malloc(len);
- if (!name)
- out_of_memory();
-
- WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
- name, len, NULL, NULL);
- return name;
-}
+#ifndef USE_WIN32_RTL_ENV
DllExport char *
win32_getenv(const char *name)
@@ -949,6 +894,8 @@ win32_putenv(const char *name)
return xceputenv(name);
}
+#endif
+
static long
filetime_to_clock(PFILETIME ft)
{
@@ -1301,7 +1248,7 @@ win32_crypt(const char *txt, const char *salt)
return des_fcrypt(txt, salt, w32_crypt_buffer);
#else
Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
- return NULL;
+ return Nullch;
#endif
}
@@ -1542,6 +1489,9 @@ win32_tmpfd(void)
if (fh != INVALID_HANDLE_VALUE) {
int fd = win32_open_osfhandle((intptr_t)fh, 0);
if (fd >= 0) {
+#if defined(__BORLANDC__)
+ setmode(fd,O_BINARY);
+#endif
DEBUG_p(PerlIO_printf(Perl_debug_log,
"Created tmpfile=%s\n",filename));
return fd;
@@ -1864,7 +1814,7 @@ qualified_path(const char *cmd)
int has_slash = 0;
if (!cmd)
- return NULL;
+ return Nullch;
fullcmd = (char*)cmd;
while (*fullcmd) {
if (*fullcmd == '/' || *fullcmd == '\\')
@@ -1939,7 +1889,7 @@ qualified_path(const char *cmd)
}
Safefree(fullcmd);
- return NULL;
+ return Nullch;
}
/* The following are just place holders.
@@ -2025,7 +1975,7 @@ win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
PROCESS_INFORMATION ProcessInformation;
DWORD create = 0;
char *cmd;
- char *fullcmd = NULL;
+ char *fullcmd = Nullch;
char *cname = (char *)cmdname;
STRLEN clen = 0;
@@ -2449,7 +2399,9 @@ XS(w32_GetCwd)
EXTEND(SP,1);
SvPOK_on(sv);
ST(0) = sv;
+#ifndef INCOMPLETE_TAINTS
SvTAINTED_on(ST(0));
+#endif
XSRETURN(1);
}
@@ -2488,12 +2440,12 @@ XS(w32_GetOSVersion)
if (!XCEGetVersionExA(&osver)) {
XSRETURN_EMPTY;
}
- mXPUSHp(osver.szCSDVersion, strlen(osver.szCSDVersion));
- mXPUSHi(osver.dwMajorVersion);
- mXPUSHi(osver.dwMinorVersion);
- mXPUSHi(osver.dwBuildNumber);
+ XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion)));
+ XPUSHs(newSViv(osver.dwMajorVersion));
+ XPUSHs(newSViv(osver.dwMinorVersion));
+ XPUSHs(newSViv(osver.dwBuildNumber));
/* WINCE = 3 */
- mXPUSHi(osver.dwPlatformId);
+ XPUSHs(newSViv(osver.dwPlatformId));
PUTBACK;
}
@@ -2602,15 +2554,15 @@ XS(w32_GetPowerStatus)
XSRETURN_EMPTY;
}
- mXPUSHi(sps.ACLineStatus);
- mXPUSHi(sps.BatteryFlag);
- mXPUSHi(sps.BatteryLifePercent);
- mXPUSHi(sps.BatteryLifeTime);
- mXPUSHi(sps.BatteryFullLifeTime);
- mXPUSHi(sps.BackupBatteryFlag);
- mXPUSHi(sps.BackupBatteryLifePercent);
- mXPUSHi(sps.BackupBatteryLifeTime);
- mXPUSHi(sps.BackupBatteryFullLifeTime);
+ XPUSHs(newSViv(sps.ACLineStatus));
+ XPUSHs(newSViv(sps.BatteryFlag));
+ XPUSHs(newSViv(sps.BatteryLifePercent));
+ XPUSHs(newSViv(sps.BatteryLifeTime));
+ XPUSHs(newSViv(sps.BatteryFullLifeTime));
+ XPUSHs(newSViv(sps.BackupBatteryFlag));
+ XPUSHs(newSViv(sps.BackupBatteryLifePercent));
+ XPUSHs(newSViv(sps.BackupBatteryLifeTime));
+ XPUSHs(newSViv(sps.BackupBatteryFullLifeTime));
PUTBACK;
}
@@ -2660,7 +2612,7 @@ Perl_init_os_extras(void)
char *file = __FILE__;
dXSUB_SYS;
- w32_perlshell_tokens = NULL;
+ w32_perlshell_tokens = Nullch;
w32_perlshell_items = -1;
w32_fdpid = newAV(); /* XX needs to be in Perl_win32_init()? */
Newx(w32_children, 1, child_tab);
@@ -2776,6 +2728,12 @@ getcwd(char *buf, size_t size)
return xcegetcwd(buf, size);
}
+int
+isnan(double d)
+{
+ return _isnan(d);
+}
+
DllExport PerlIO*
win32_popenlist(const char *mode, IV narg, SV **args)
@@ -2824,7 +2782,7 @@ void
Perl_sys_intern_init(pTHX)
{
int i;
- w32_perlshell_tokens = NULL;
+ w32_perlshell_tokens = Nullch;
w32_perlshell_vec = (char**)NULL;
w32_perlshell_items = 0;
w32_fdpid = newAV();
@@ -2861,7 +2819,7 @@ Perl_sys_intern_clear(pTHX)
void
Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
{
- dst->perlshell_tokens = NULL;
+ dst->perlshell_tokens = Nullch;
dst->perlshell_vec = (char**)NULL;
dst->perlshell_items = 0;
dst->fdpid = newAV();