Steve Vinoski
Stevan Little <stevan@cpan.org>
Steven Hirsch <hirschs@btv.ibm.com>
+Steven Humphrey <catchperl@33k.co.uk>
Steven Knight <knight@theopera.baldmt.citilink.com>
Steven Morlock <newspost@morlock.net>
Steven N. Hirsch <hirschs@stargate.btv.ibm.com>
printf("9\n");
exit(0);
}
+ if (b[0] == 0xC0 && b[3] == 0x9A) {
+ /* IBM single 32-bit */
+ printf("12\n");
+ exit(0);
+ }
#endif
#if DOUBLESIZE == 8
if (b[0] == 0x9A && b[7] == 0xBF) {
printf("11\n");
exit(0);
}
+ if (b[0] == 0xC0 && b[7] == 0x9A) {
+ /* IBM double 64-bit */
+ printf("13\n");
+ exit(0);
+ }
+ if (b[0] == 0xBF && b[7] == 0xCD) {
+ /* CRAY single 64-bit */
+ printf("14\n");
+ exit(0);
+ }
#endif
#if DOUBLESIZE == 16
if (b[0] == 0x9A && b[15] == 0xBF) {
9) echo "You have VAX format F 32-bit PDP-style mixed endian doubles." >&4 ;;
10) echo "You have VAX format D 64-bit PDP-style mixed endian doubles." >&4 ;;
11) echo "You have VAX format G 64-bit PDP-style mixed endian doubles." >&4 ;;
-*) echo "Cannot figure out your double. You CRAY, or something?" >&4 ;;
+12) echo "You have IBM short 32-bit doubles." >&4 ;;
+13) echo "You have IBM long 64-bit doubles." >&4 ;;
+14) echo "You have Cray single 64-bit doubles." >&4 ;;
+*) echo "Cannot figure out your double. You Cyber, or something?" >&4 ;;
esac
$rm_try
ansi2knr=''
aphostname='/bin/hostname'
api_revision='5'
-api_subversion='5'
+api_subversion='6'
api_version='25'
-api_versionstring='5.25.5'
+api_versionstring='5.25.6'
ar='ar'
-archlib='/usr/lib/perl5/5.25.5/armv4l-linux'
-archlibexp='/usr/lib/perl5/5.25.5/armv4l-linux'
+archlib='/usr/lib/perl5/5.25.6/armv4l-linux'
+archlibexp='/usr/lib/perl5/5.25.6/armv4l-linux'
archname64=''
archname='armv4l-linux'
archobjs=''
cat='cat'
cc='cc'
cccdlflags='-fpic'
-ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.25.5/armv4l-linux/CORE'
+ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.25.6/armv4l-linux/CORE'
ccflags='-fno-strict-aliasing -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64'
ccflags_uselargefiles='-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64'
ccname='arm-linux-gcc'
inc_version_list_init='0'
incpath=''
inews=''
-installarchlib='./install_me_here/usr/lib/perl5/5.25.5/armv4l-linux'
+installarchlib='./install_me_here/usr/lib/perl5/5.25.6/armv4l-linux'
installbin='./install_me_here/usr/bin'
installhtml1dir=''
installhtml3dir=''
installman3dir='./install_me_here/usr/share/man/man3'
installprefix='./install_me_here/usr'
installprefixexp='./install_me_here/usr'
-installprivlib='./install_me_here/usr/lib/perl5/5.25.5'
+installprivlib='./install_me_here/usr/lib/perl5/5.25.6'
installscript='./install_me_here/usr/bin'
-installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.25.5/armv4l-linux'
+installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.25.6/armv4l-linux'
installsitebin='./install_me_here/usr/bin'
installsitehtml1dir=''
installsitehtml3dir=''
-installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.25.5'
+installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.25.6'
installsiteman1dir='./install_me_here/usr/share/man/man1'
installsiteman3dir='./install_me_here/usr/share/man/man3'
installsitescript='./install_me_here/usr/bin'
pr=''
prefix='/usr'
prefixexp='/usr'
-privlib='/usr/lib/perl5/5.25.5'
-privlibexp='/usr/lib/perl5/5.25.5'
+privlib='/usr/lib/perl5/5.25.6'
+privlibexp='/usr/lib/perl5/5.25.6'
procselfexe='"/proc/self/exe"'
prototype='define'
ptrsize='4'
sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 6, 17, 29, 31, 0'
sig_size='68'
signal_t='void'
-sitearch='/usr/lib/perl5/site_perl/5.25.5/armv4l-linux'
-sitearchexp='/usr/lib/perl5/site_perl/5.25.5/armv4l-linux'
+sitearch='/usr/lib/perl5/site_perl/5.25.6/armv4l-linux'
+sitearchexp='/usr/lib/perl5/site_perl/5.25.6/armv4l-linux'
sitebin='/usr/bin'
sitebinexp='/usr/bin'
sitehtml1dir=''
sitehtml1direxp=''
sitehtml3dir=''
sitehtml3direxp=''
-sitelib='/usr/lib/perl5/site_perl/5.25.5'
+sitelib='/usr/lib/perl5/site_perl/5.25.6'
sitelib_stem='/usr/lib/perl5/site_perl'
-sitelibexp='/usr/lib/perl5/site_perl/5.25.5'
+sitelibexp='/usr/lib/perl5/site_perl/5.25.6'
siteman1dir='/usr/share/man/man1'
siteman1direxp='/usr/share/man/man1'
siteman3dir='/usr/share/man/man3'
strerror_r_proto='0'
strings='/usr/include/string.h'
submit=''
-subversion='5'
+subversion='6'
sysman='/usr/share/man/man1'
tail=''
tar=''
vendorprefixexp=''
vendorscript=''
vendorscriptexp=''
-version='5.25.5'
-version_patchlevel_string='version 25 subversion 5'
+version='5.25.6'
+version_patchlevel_string='version 25 subversion 6'
versiononly='undef'
vi=''
xlibpth='/usr/lib/386 /lib/386'
config_argc=0
PERL_REVISION=5
PERL_VERSION=25
-PERL_SUBVERSION=5
+PERL_SUBVERSION=6
PERL_API_REVISION=5
PERL_API_VERSION=25
-PERL_API_SUBVERSION=5
+PERL_API_SUBVERSION=6
PERL_PATCHLEVEL=
PERL_CONFIG_SH=true
ansi2knr=''
aphostname='/bin/hostname'
api_revision='5'
-api_subversion='5'
+api_subversion='6'
api_version='25'
-api_versionstring='5.25.5'
+api_versionstring='5.25.6'
ar='ar'
-archlib='/usr/lib/perl5/5.25.5/armv4l-linux'
-archlibexp='/usr/lib/perl5/5.25.5/armv4l-linux'
+archlib='/usr/lib/perl5/5.25.6/armv4l-linux'
+archlibexp='/usr/lib/perl5/5.25.6/armv4l-linux'
archname64=''
archname='armv4l-linux'
archobjs=''
cat='cat'
cc='arm-none-linux-gnueabi-gcc'
cccdlflags='-fpic'
-ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.25.5/armv4l-linux/CORE'
+ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.25.6/armv4l-linux/CORE'
ccflags='-fno-strict-aliasing -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64'
ccflags_uselargefiles='-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64'
ccname='arm-linux-gcc'
inc_version_list_init='0'
incpath=''
inews=''
-installarchlib='./install_me_here/usr/lib/perl5/5.25.5/armv4l-linux'
+installarchlib='./install_me_here/usr/lib/perl5/5.25.6/armv4l-linux'
installbin='./install_me_here/usr/bin'
installhtml1dir=''
installhtml3dir=''
installman3dir='./install_me_here/usr/share/man/man3'
installprefix='./install_me_here/usr'
installprefixexp='./install_me_here/usr'
-installprivlib='./install_me_here/usr/lib/perl5/5.25.5'
+installprivlib='./install_me_here/usr/lib/perl5/5.25.6'
installscript='./install_me_here/usr/bin'
-installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.25.5/armv4l-linux'
+installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.25.6/armv4l-linux'
installsitebin='./install_me_here/usr/bin'
installsitehtml1dir=''
installsitehtml3dir=''
-installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.25.5'
+installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.25.6'
installsiteman1dir='./install_me_here/usr/share/man/man1'
installsiteman3dir='./install_me_here/usr/share/man/man3'
installsitescript='./install_me_here/usr/bin'
pr=''
prefix='/usr'
prefixexp='/usr'
-privlib='/usr/lib/perl5/5.25.5'
-privlibexp='/usr/lib/perl5/5.25.5'
+privlib='/usr/lib/perl5/5.25.6'
+privlibexp='/usr/lib/perl5/5.25.6'
procselfexe='"/proc/self/exe"'
prototype='define'
ptrsize='4'
sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 6, 17, 29, 31, 0'
sig_size='68'
signal_t='void'
-sitearch='/usr/lib/perl5/site_perl/5.25.5/armv4l-linux'
-sitearchexp='/usr/lib/perl5/site_perl/5.25.5/armv4l-linux'
+sitearch='/usr/lib/perl5/site_perl/5.25.6/armv4l-linux'
+sitearchexp='/usr/lib/perl5/site_perl/5.25.6/armv4l-linux'
sitebin='/usr/bin'
sitebinexp='/usr/bin'
sitehtml1dir=''
sitehtml1direxp=''
sitehtml3dir=''
sitehtml3direxp=''
-sitelib='/usr/lib/perl5/site_perl/5.25.5'
+sitelib='/usr/lib/perl5/site_perl/5.25.6'
sitelib_stem='/usr/lib/perl5/site_perl'
-sitelibexp='/usr/lib/perl5/site_perl/5.25.5'
+sitelibexp='/usr/lib/perl5/site_perl/5.25.6'
siteman1dir='/usr/share/man/man1'
siteman1direxp='/usr/share/man/man1'
siteman3dir='/usr/share/man/man3'
strerror_r_proto='0'
strings='/usr/include/string.h'
submit=''
-subversion='5'
+subversion='6'
sysman='/usr/share/man/man1'
tail=''
tar=''
vendorprefixexp=''
vendorscript=''
vendorscriptexp=''
-version='5.25.5'
-version_patchlevel_string='version 25 subversion 5'
+version='5.25.6'
+version_patchlevel_string='version 25 subversion 6'
versiononly='undef'
vi=''
xlibpth='/usr/lib/386 /lib/386'
config_argc=0
PERL_REVISION=5
PERL_VERSION=25
-PERL_SUBVERSION=5
+PERL_SUBVERSION=6
PERL_API_REVISION=5
PERL_API_VERSION=25
-PERL_API_SUBVERSION=5
+PERL_API_SUBVERSION=6
PERL_PATCHLEVEL=
PERL_CONFIG_SH=true
=item Directories for the perl distribution
-By default, Configure will use the following directories for 5.25.5.
+By default, Configure will use the following directories for 5.25.6.
$version is the full perl version number, including subversion, e.g.
5.12.3, and $archname is a string like sun4-sunos,
determined by Configure. The full definitions of all Configure
=head1 Coexistence with earlier versions of perl 5
-Perl 5.25.5 is not binary compatible with earlier versions of Perl.
+Perl 5.25.6 is not binary compatible with earlier versions of Perl.
In other words, you will have to recompile your XS modules.
In general, you can usually safely upgrade from one version of Perl
libraries after 5.6.0, but not for executables. TODO?) One convenient
way to do this is by using a separate prefix for each version, such as
- sh Configure -Dprefix=/opt/perl5.25.5
+ sh Configure -Dprefix=/opt/perl5.25.6
-and adding /opt/perl5.25.5/bin to the shell PATH variable. Such users
+and adding /opt/perl5.25.6/bin to the shell PATH variable. Such users
may also wish to add a symbolic link /usr/local/bin/perl so that
scripts can still start with #!/usr/local/bin/perl.
=head2 Upgrading from 5.25.2 or earlier
-B<Perl 5.25.5 may not be binary compatible with Perl 5.25.3 or
+B<Perl 5.25.6 may not be binary compatible with Perl 5.25.3 or
earlier Perl releases.> Perl modules having binary parts
(meaning that a C compiler is used) will have to be recompiled to be
-used with 5.25.5. If you find you do need to rebuild an extension with
-5.25.5, you may safely do so without disturbing the older
+used with 5.25.6. If you find you do need to rebuild an extension with
+5.25.6, you may safely do so without disturbing the older
installations. (See L<"Coexistence with earlier versions of perl 5">
above.)
print("$f\n");
}
-in Linux with perl-5.25.5 is as follows (under $Config{prefix}):
+in Linux with perl-5.25.6 is as follows (under $Config{prefix}):
./bin/perl
- ./lib/perl5/5.25.5/strict.pm
- ./lib/perl5/5.25.5/warnings.pm
- ./lib/perl5/5.25.5/i686-linux/File/Glob.pm
- ./lib/perl5/5.25.5/feature.pm
- ./lib/perl5/5.25.5/XSLoader.pm
- ./lib/perl5/5.25.5/i686-linux/auto/File/Glob/Glob.so
+ ./lib/perl5/5.25.6/strict.pm
+ ./lib/perl5/5.25.6/warnings.pm
+ ./lib/perl5/5.25.6/i686-linux/File/Glob.pm
+ ./lib/perl5/5.25.6/feature.pm
+ ./lib/perl5/5.25.6/XSLoader.pm
+ ./lib/perl5/5.25.6/i686-linux/auto/File/Glob/Glob.so
Secondly, for perl-5.10.1, the Debian perl-base package contains 591
files, (of which 510 are for lib/unicore) totaling about 3.5MB in its
cpan/parent/t/parent-classfromfile.t tests for parent.pm
cpan/parent/t/parent-pmc.t tests for parent.pm
cpan/parent/t/parent-returns-false.t tests for parent.pm
+cpan/parent/t/rt62341.t.disabled test files for parent.pm
cpan/Perl-OSType/lib/Perl/OSType.pm Perl::OSType
cpan/Perl-OSType/t/OSType.t Perl::OSType
cpan/perlfaq/lib/perlfaq.pm Perl frequently asked questions
cpan/podlators/t/data/basic.pod podlators test
cpan/podlators/t/data/basic.txt podlators test
cpan/podlators/t/data/perl.conf podlators test
+cpan/podlators/t/data/snippets/man/bullet-after-nonbullet
cpan/podlators/t/data/snippets/man/cpp podlators test
+cpan/podlators/t/data/snippets/man/error-die
+cpan/podlators/t/data/snippets/man/error-none
+cpan/podlators/t/data/snippets/man/error-normal
+cpan/podlators/t/data/snippets/man/error-pod
+cpan/podlators/t/data/snippets/man/error-stderr
+cpan/podlators/t/data/snippets/man/error-stderr-opt
+cpan/podlators/t/data/snippets/man/fixed-font
+cpan/podlators/t/data/snippets/man/long-quote
+cpan/podlators/t/data/snippets/man/lquote-and-quote
+cpan/podlators/t/data/snippets/man/lquote-rquote
+cpan/podlators/t/data/snippets/man/nourls
+cpan/podlators/t/data/snippets/man/rquote-none
cpan/podlators/t/data/snippets/man/utf8-nonbreaking podlators test
cpan/podlators/t/data/snippets/man/utf8-verbatim podlators test
cpan/podlators/t/data/snippets/README podlators test
cpan/Test-Simple/t/regression/684-nested_todo_diag.t
cpan/Test-Simple/t/regression/694_note_diag_return_values.t
cpan/Test-Simple/t/regression/696-intercept_skip_all.t
+cpan/Test-Simple/t/regression/721-nested-streamed-subtest.t
cpan/Test-Simple/t/regression/no_name_in_subtest.t
cpan/Test-Simple/t/Test2/acceptance/try_it_done_testing.t
cpan/Test-Simple/t/Test2/acceptance/try_it_fork.t
dist/Module-CoreList/t/utils.t Module::CoreList tests
dist/Net-Ping/Changes Net::Ping
dist/Net-Ping/lib/Net/Ping.pm Hello, anybody home?
-dist/Net-Ping/t/100_load.t Ping Net::Ping
+dist/Net-Ping/t/000_load.t
+dist/Net-Ping/t/001_new.t
+dist/Net-Ping/t/010_pingecho.t
dist/Net-Ping/t/110_icmp_inst.t Ping Net::Ping
dist/Net-Ping/t/120_udp_inst.t Ping Net::Ping
dist/Net-Ping/t/130_tcp_inst.t Ping Net::Ping
pod/perl5252delta.pod Perl changes in version 5.25.2
pod/perl5253delta.pod Perl changes in version 5.25.3
pod/perl5254delta.pod Perl changes in version 5.25.4
+pod/perl5255delta.pod Perl changes in version 5.25.5
pod/perl561delta.pod Perl changes in version 5.6.1
pod/perl56delta.pod Perl changes in version 5.6
pod/perl581delta.pod Perl changes in version 5.8.1
Porting/git-make-p4-refs Output git refs for each p4 change number, suitable for appending to .git/packed-refs
Porting/GitUtils.pm Generate the contents of a .patch file
Porting/Glossary Glossary of config.sh variables
+Porting/harness-timer-report.pl Analyze the timings from the test harness
Porting/how_to_write_a_perldelta.pod Bluffer's guide to writing a perldelta.
Porting/leakfinder.pl Hacky script for finding memory leaks
Porting/Maintainers Program to pretty print info in Maintainers.pl
t/re/subst_amp.t See if $&-related substitution works
t/re/subst_wamp.t See if substitution works with $& present
t/re/substT.t See if substitution works with -T
-t/re/uniprops.t Test unicode \p{} regex constructs
+t/re/uniprops01.t Test unicode \p{} regex constructs
+t/re/uniprops02.t Test unicode \p{} regex constructs
+t/re/uniprops03.t Test unicode \p{} regex constructs
+t/re/uniprops04.t Test unicode \p{} regex constructs
+t/re/uniprops05.t Test unicode \p{} regex constructs
+t/re/uniprops06.t Test unicode \p{} regex constructs
+t/re/uniprops07.t Test unicode \p{} regex constructs
+t/re/uniprops08.t Test unicode \p{} regex constructs
+t/re/uniprops09.t Test unicode \p{} regex constructs
+t/re/uniprops10.t Test unicode \p{} regex constructs
t/README Instructions for regression tests
t/run/cloexec.t Test close-on-exec.
t/run/dtrace.pl For dtrace.t
"url" : "http://perl5.git.perl.org/"
}
},
- "version" : "5.025005",
+ "version" : "5.025006",
"x_serialization_backend" : "JSON::PP version 2.27400_01"
}
homepage: http://www.perl.org/
license: http://dev.perl.org/licenses/
repository: http://perl5.git.perl.org/
-version: '5.025005'
+version: '5.025006'
x_serialization_backend: 'CPAN::Meta::YAML version 0.018'
perllib_objs = $(perllib_objs_nodt) $(DTRACE_PERLLIB_O)
perlmain_objs = perlmain$(OBJ_EXT) $(DTRACE_MAIN_O)
-perltoc_pod_prereqs = extra.pods pod/perl5255delta.pod pod/perlapi.pod pod/perlintern.pod pod/perlmodlib.pod pod/perluniprops.pod
+perltoc_pod_prereqs = extra.pods pod/perl5256delta.pod pod/perlapi.pod pod/perlintern.pod pod/perlmodlib.pod pod/perluniprops.pod
generated_pods = pod/perltoc.pod $(perltoc_pod_prereqs)
generated_headers = uudmap.h bitcount.h mg_data.h
pod/perlmodlib.pod: $(MINIPERL_EXE) pod/perlmodlib.PL MANIFEST
$(MINIPERL) pod/perlmodlib.PL -q
-pod/perl5255delta.pod: pod/perldelta.pod
- $(RMS) pod/perl5255delta.pod
- $(LNS) perldelta.pod pod/perl5255delta.pod
+pod/perl5256delta.pod: pod/perldelta.pod
+ $(RMS) pod/perl5256delta.pod
+ $(LNS) perldelta.pod pod/perl5256delta.pod
extra.pods: $(MINIPERL_EXE)
-@test ! -f extra.pods || rm -f `cat extra.pods`
# Here comes the CW tools - TO BE FILLED TO BUILD WITH CW -
-MODULE_DESC = "Perl 5.25.5 for NetWare"
+MODULE_DESC = "Perl 5.25.6 for NetWare"
CCTYPE = CodeWarrior
C_COMPILER = mwccnlm -c
CPP_COMPILER = mwccnlm
# versioned installation can be obtained by setting INST_TOP above to a
# path that includes an arbitrary version string.
#
-INST_VER = \5.25.5
+INST_VER = \5.25.6
#
# Comment this out if you DON'T want your perl installation to have
* This symbol contains the ~name expanded version of ARCHLIB, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
-#define ARCHLIB "c:\\perl\\5.25.5\\lib\\NetWare-x86-multi-thread" /**/
+#define ARCHLIB "c:\\perl\\5.25.6\\lib\\NetWare-x86-multi-thread" /**/
/*#define ARCHLIB_EXP "" /**/
/* ARCHNAME:
* This symbol is the filename expanded version of the BIN symbol, for
* programs that do not want to deal with that at run-time.
*/
-#define BIN "c:\\perl\\5.25.5\\bin\\NetWare-x86-multi-thread" /**/
-#define BIN_EXP "c:\\perl\\5.25.5\\bin\\NetWare-x86-multi-thread" /**/
+#define BIN "c:\\perl\\5.25.6\\bin\\NetWare-x86-multi-thread" /**/
+#define BIN_EXP "c:\\perl\\5.25.6\\bin\\NetWare-x86-multi-thread" /**/
/* BYTEORDER:
* This symbol holds the hexadecimal constant defined in byteorder,
* This symbol contains the ~name expanded version of SITEARCH, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
-#define SITEARCH "c:\\perl\\site\\5.25.5\\lib\\NetWare-x86-multi-thread" /**/
+#define SITEARCH "c:\\perl\\site\\5.25.6\\lib\\NetWare-x86-multi-thread" /**/
/*#define SITEARCH_EXP "" /**/
/* SITELIB:
* removed. The elements in inc_version_list (inc_version_list.U) can
* be tacked onto this variable to generate a list of directories to search.
*/
-#define SITELIB "c:\\perl\\site\\5.25.5\\lib" /**/
+#define SITELIB "c:\\perl\\site\\5.25.6\\lib" /**/
/*#define SITELIB_EXP "" /**/
#define SITELIB_STEM "" /**/
9 = VAX 32bit little endian F float format
10 = VAX 64bit little endian D float format
11 = VAX 64bit little endian G float format
+ 12 = IBM 32bit format
+ 13 = IBM 64bit format
+ 14 = Cray 64bit format
-1 = unknown format.
doublemantbits (mantbits.U):
%Modules = (
'Archive::Tar' => {
- 'DISTRIBUTION' => 'BINGOS/Archive-Tar-2.10.tar.gz',
+ 'DISTRIBUTION' => 'BINGOS/Archive-Tar-2.14.tar.gz',
'FILES' => q[cpan/Archive-Tar],
'BUGS' => 'bug-archive-tar@rt.cpan.org',
'EXCLUDED' => [
},
'HTTP::Tiny' => {
- 'DISTRIBUTION' => 'DAGOLDEN/HTTP-Tiny-0.064.tar.gz',
+ 'DISTRIBUTION' => 'DAGOLDEN/HTTP-Tiny-0.070.tar.gz',
'FILES' => q[cpan/HTTP-Tiny],
'EXCLUDED' => [
't/00-report-prereqs.t',
},
'Module::CoreList' => {
- 'DISTRIBUTION' => 'BINGOS/Module-CoreList-5.20160820.tar.gz',
+ 'DISTRIBUTION' => 'BINGOS/Module-CoreList-5.20160920.tar.gz',
'FILES' => q[dist/Module-CoreList],
},
},
'Net::Ping' => {
- 'DISTRIBUTION' => 'SMPETERS/Net-Ping-2.41.tar.gz',
+ 'DISTRIBUTION' => 'RURBAN/Net-Ping-2.51.tar.gz',
'FILES' => q[dist/Net-Ping],
+ 'EXCLUDED' => [
+ qw(t/020_external.t),
+ qw(t/600_pod.t),
+ qw(t/601_pod-coverage.t),
+ ],
+
},
'NEXT' => {
},
'parent' => {
- 'DISTRIBUTION' => 'CORION/parent-0.234.tar.gz',
+ 'DISTRIBUTION' => 'CORION/parent-0.236.tar.gz',
'FILES' => q[cpan/parent],
+ 'EXCLUDED' => [
+ qr{^xt}
+ ],
},
'PathTools' => {
},
'podlators' => {
- 'DISTRIBUTION' => 'RRA/podlators-4.07.tar.gz',
+ 'DISTRIBUTION' => 'RRA/podlators-4.08.tar.gz',
'FILES' => q[cpan/podlators pod/perlpodstyle.pod],
'MAP' => {
},
'Scalar-List-Utils' => {
- 'DISTRIBUTION' => 'PEVANS/Scalar-List-Utils-1.45.tar.gz',
+ 'DISTRIBUTION' => 'PEVANS/Scalar-List-Utils-1.46.tar.gz',
'FILES' => q[cpan/Scalar-List-Utils],
- # Waiting to be merged upstream
- # https://github.com/Scalar-List-Utils/Scalar-List-Utils/pull/42
- 'CUSTOMIZED' => [
- qw( ListUtil.xs
- lib/List/Util.pm
- lib/List/Util/XS.pm
- lib/Scalar/Util.pm
- lib/Sub/Util.pm
- )
- ],
},
'Search::Dict' => {
},
'Test::Simple' => {
- 'DISTRIBUTION' => 'EXODIST/Test-Simple-1.302056.tar.gz',
+ 'DISTRIBUTION' => 'EXODIST/Test-Simple-1.302059.tar.gz',
'FILES' => q[cpan/Test-Simple],
'EXCLUDED' => [
qr{^examples/},
},
'Time::HiRes' => {
- 'DISTRIBUTION' => 'JHI/Time-HiRes-1.9739.tar.gz',
+ 'DISTRIBUTION' => 'JHI/Time-HiRes-1.9740.tar.gz',
'FILES' => q[dist/Time-HiRes],
},
the shell variables whose value is determined by the Configure script.
It later gets incorporated into the pod for F<Config.pm>.
+=head2 F<harness-timer-report.pl>
+
+For analyzing the output of "env HARNESS_TIMER=1 make test", to find
+outliers of test execution times.
+
=head2 F<how_to_write_a_perldelta.pod>
This file contains a specification as to how to write a perldelta pod.
# Validate the list of perl=label (+ cmdline options) on the command line.
-# Return a list of [ exe, label, cmdline-options ] tuples, ie PUTs
+# Return a list of [ exe, label, cmdline-options ] tuples, i.e.
+# 'perl-under-test's (PUTs)
sub process_puts {
my @res_puts; # returned, each item is [ perlexe, label, @putargs ]
my ($perl, $label, $env) = split /[=:,]/, $p, 3;
$label //= $perl;
$label = $perl.$label if $label =~ /^\+/;
- die "$label cannot be used on 2 different PUTs\n" if $seen{$label}++;
+ die "$label cannot be used on 2 different perls under test\n" if $seen{$label}++;
my %env;
if ($env) {
warn "Added Perl-Under-Test: [ @{[@{$res_puts[-1]}]} ]\n"
if $OPTS{verbose};
} else {
- warn "PUT-args: @putargs + a not-perl: $p $r\n"
+ warn "perl-under-test args: @putargs + a not-perl: $p $r\n"
if $OPTS{verbose};
push @putargs, $p; # not-perl
}
ansi2knr=''
aphostname='/bin/hostname'
api_revision='5'
-api_subversion='5'
+api_subversion='6'
api_version='25'
-api_versionstring='5.25.5'
+api_versionstring='5.25.6'
ar='ar'
-archlib='/tmp/mblead/lib/perl5/5.25.5/darwin-2level'
-archlibexp='/tmp/mblead/lib/perl5/5.25.5/darwin-2level'
+archlib='/tmp/mblead/lib/perl5/5.25.6/darwin-2level'
+archlibexp='/tmp/mblead/lib/perl5/5.25.6/darwin-2level'
archname64=''
archname='darwin-2level'
archobjs=''
incpth='/usr/local/include /Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/bin/../lib/clang/6.0/include /Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/include /usr/include /usr/local/include /Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/bin/../lib/clang/6.0/include /Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/include /usr/include /usr/local/include /Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/bin/../lib/clang/6.0/include /Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/include /usr/include'
inews=''
initialinstalllocation='/tmp/mblead/bin'
-installarchlib='/tmp/mblead/lib/perl5/5.25.5/darwin-2level'
+installarchlib='/tmp/mblead/lib/perl5/5.25.6/darwin-2level'
installbin='/tmp/mblead/bin'
installhtml1dir=''
installhtml3dir=''
installman3dir='/tmp/mblead/man/man3'
installprefix='/tmp/mblead'
installprefixexp='/tmp/mblead'
-installprivlib='/tmp/mblead/lib/perl5/5.25.5'
+installprivlib='/tmp/mblead/lib/perl5/5.25.6'
installscript='/tmp/mblead/bin'
-installsitearch='/tmp/mblead/lib/perl5/site_perl/5.25.5/darwin-2level'
+installsitearch='/tmp/mblead/lib/perl5/site_perl/5.25.6/darwin-2level'
installsitebin='/tmp/mblead/bin'
installsitehtml1dir=''
installsitehtml3dir=''
-installsitelib='/tmp/mblead/lib/perl5/site_perl/5.25.5'
+installsitelib='/tmp/mblead/lib/perl5/site_perl/5.25.6'
installsiteman1dir='/tmp/mblead/man/man1'
installsiteman3dir='/tmp/mblead/man/man3'
installsitescript='/tmp/mblead/bin'
perl_static_inline='static __inline__'
perladmin='aaron@daybreak.nonet'
perllibs='-lpthread -ldl -lm -lutil -lc'
-perlpath='/tmp/mblead/bin/perl5.25.5'
+perlpath='/tmp/mblead/bin/perl5.25.6'
pg='pg'
phostname='hostname'
pidtype='pid_t'
pr=''
prefix='/tmp/mblead'
prefixexp='/tmp/mblead'
-privlib='/tmp/mblead/lib/perl5/5.25.5'
-privlibexp='/tmp/mblead/lib/perl5/5.25.5'
+privlib='/tmp/mblead/lib/perl5/5.25.6'
+privlibexp='/tmp/mblead/lib/perl5/5.25.6'
procselfexe=''
prototype='define'
ptrsize='8'
sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 6, 0'
sig_size='33'
signal_t='void'
-sitearch='/tmp/mblead/lib/perl5/site_perl/5.25.5/darwin-2level'
-sitearchexp='/tmp/mblead/lib/perl5/site_perl/5.25.5/darwin-2level'
+sitearch='/tmp/mblead/lib/perl5/site_perl/5.25.6/darwin-2level'
+sitearchexp='/tmp/mblead/lib/perl5/site_perl/5.25.6/darwin-2level'
sitebin='/tmp/mblead/bin'
sitebinexp='/tmp/mblead/bin'
sitehtml1dir=''
sitehtml1direxp=''
sitehtml3dir=''
sitehtml3direxp=''
-sitelib='/tmp/mblead/lib/perl5/site_perl/5.25.5'
+sitelib='/tmp/mblead/lib/perl5/site_perl/5.25.6'
sitelib_stem='/tmp/mblead/lib/perl5/site_perl'
-sitelibexp='/tmp/mblead/lib/perl5/site_perl/5.25.5'
+sitelibexp='/tmp/mblead/lib/perl5/site_perl/5.25.6'
siteman1dir='/tmp/mblead/man/man1'
siteman1direxp='/tmp/mblead/man/man1'
siteman3dir='/tmp/mblead/man/man3'
ssizetype='ssize_t'
st_ino_sign='1'
st_ino_size='8'
-startperl='#!/tmp/mblead/bin/perl5.25.5'
+startperl='#!/tmp/mblead/bin/perl5.25.6'
startsh='#!/bin/sh'
static_ext=' '
stdchar='char'
strerror_r_proto='0'
strings='/usr/include/string.h'
submit=''
-subversion='5'
+subversion='6'
sysman='/usr/share/man/man1'
sysroot=''
tail=''
vendorprefixexp=''
vendorscript=''
vendorscriptexp=''
-version='5.25.5'
-version_patchlevel_string='version 25 subversion 5'
+version='5.25.6'
+version_patchlevel_string='version 25 subversion 6'
versiononly='define'
vi=''
xlibpth='/usr/lib/386 /lib/386'
zip='zip'
PERL_REVISION=5
PERL_VERSION=25
-PERL_SUBVERSION=5
+PERL_SUBVERSION=6
PERL_API_REVISION=5
PERL_API_VERSION=25
-PERL_API_SUBVERSION=5
+PERL_API_SUBVERSION=6
PERL_PATCHLEVEL=''
PERL_CONFIG_SH=true
* This symbol contains the ~name expanded version of ARCHLIB, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
-#define ARCHLIB "/pro/lib/perl5/5.25.5/i686-linux-64int-ld" /**/
-#define ARCHLIB_EXP "/pro/lib/perl5/5.25.5/i686-linux-64int-ld" /**/
+#define ARCHLIB "/pro/lib/perl5/5.25.6/i686-linux-64int-ld" /**/
+#define ARCHLIB_EXP "/pro/lib/perl5/5.25.6/i686-linux-64int-ld" /**/
/* ARCHNAME:
* This symbol holds a string representing the architecture name.
* This symbol contains the ~name expanded version of PRIVLIB, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
-#define PRIVLIB "/pro/lib/perl5/5.25.5" /**/
-#define PRIVLIB_EXP "/pro/lib/perl5/5.25.5" /**/
+#define PRIVLIB "/pro/lib/perl5/5.25.6" /**/
+#define PRIVLIB_EXP "/pro/lib/perl5/5.25.6" /**/
/* PTRSIZE:
* This symbol contains the size of a pointer, so that the C preprocessor
* This symbol contains the ~name expanded version of SITEARCH, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
-#define SITEARCH "/pro/lib/perl5/site_perl/5.25.5/i686-linux-64int-ld" /**/
-#define SITEARCH_EXP "/pro/lib/perl5/site_perl/5.25.5/i686-linux-64int-ld" /**/
+#define SITEARCH "/pro/lib/perl5/site_perl/5.25.6/i686-linux-64int-ld" /**/
+#define SITEARCH_EXP "/pro/lib/perl5/site_perl/5.25.6/i686-linux-64int-ld" /**/
/* SITELIB:
* This symbol contains the name of the private library for this package.
* removed. The elements in inc_version_list (inc_version_list.U) can
* be tacked onto this variable to generate a list of directories to search.
*/
-#define SITELIB "/pro/lib/perl5/site_perl/5.25.5" /**/
-#define SITELIB_EXP "/pro/lib/perl5/site_perl/5.25.5" /**/
+#define SITELIB "/pro/lib/perl5/site_perl/5.25.6" /**/
+#define SITELIB_EXP "/pro/lib/perl5/site_perl/5.25.6" /**/
#define SITELIB_STEM "/pro/lib/perl5/site_perl" /**/
/* SSize_t:
* script to make sure (one hopes) that it runs with perl and not
* some shell.
*/
-#define STARTPERL "#!/pro/bin/perl5.25.5" /**/
+#define STARTPERL "#!/pro/bin/perl5.25.6" /**/
/* HAS_STDIO_STREAM_ARRAY:
* This symbol, if defined, tells that there is an array
op/postfixderef.t
op/range.t
op/readline.t
-op/split.t
op/srand.t
op/sub.t
op/sub_lval.t
=head1 EPIGRAPHS
+=head2 v5.25.5 - Philip K. Dick, VALIS
+
+L<Announced on 2016-09-20 by Stevan Little|http://www.nntp.perl.org/group/perl.perl5.porters/2016/09/msg239887.html>
+
+ We hypostatize information into objects. Rearrangement of objects is
+ change in the content of the information; the message has changed.
+ This is a language which we have lost the ability to read. We ourselves
+ are a part of this language; changes in us are changes in the content
+ of the information. We ourselves are information-rich; information
+ enters us, is processed and is then projected outward once more, now
+ in an altered form. We are not aware that we are doing this, that in
+ fact this is all we are doing
+
=head2 v5.25.4 - Terry Pratchett, "Truckers"
L<Announced on 2016-08-20 by Chris 'BinGOs' Williams|http://www.nntp.perl.org/group/perl.perl5.porters/2016/08/msg239191.html>
To find that the utmost reward
Of daring should be still to dare.
+=head2 v5.24.1-RC4 - John Milton, ed. Gordon Campbell, "Paradise Lost", Book II
+
+L<Announced on 2016-10-12 by Steve Hay|http://www.nntp.perl.org/group/perl.perl5.porters/2016/10/msg240224.html>
+
+ Before the gates there sat
+ On either side a formidable shape;
+ The one seemed woman to the waste, and fair,
+ But ended foul in many a scaly fold,
+ Voluminous and vast -- a serpent armed
+ With mortal sting; about her middle round
+ A cry of hell hounds never ceasing barked
+ With wide Cerberean mouths full loud, and rung
+ A hideous peal; yet, when they list, would creep,
+ If aught disturbed their noise, into her womb,
+ And kennel there; yet there still barked and howled
+ Within unseen. Far less abhorred than these
+ Vexed Scylla, bathing in the sea that parts
+ Calabria from the hoarse Trinacrian shore;
+ Nor uglier follow the night-hag, when, called
+ In secret, riding through the air she comes,
+ Lured with the smell of infant blood, to dance
+ With Lapland witches, while the labouring moon
+ Eclipses at their charms. The other shape --
+ If shape it might be called that shape had none
+ Distinguishable in member, joint, or limb;
+ Or substance might be called that shadow seemed,
+ For each seemed either -- black it stood as night,
+ Fierce as ten Furies, terrible as hell,
+ And shook a dreadful dart: what seemed his head
+ The likeness of a kingly crown had on.
+ Satan was now at hand, and from his seat
+ The monster moving onward came as fast
+ With horrid strides; hell trembled as he strode.
+
=head2 v5.24.1-RC3 - Dante Alighieri, trans. Dorothy L. Sayers and Barbara Reynolds, "The Divine Comedy", Cantica III: Paradise, Canto XXIII
L<Announced on 2016-08-11 by Steve Hay|http://www.nntp.perl.org/group/perl.perl5.porters/2016/08/msg238909.html>
They sing while you slave and I just get bored
I ain't gonna work on Maggie's farm no more
+=head2 v5.22.3-RC4 - John Milton, ed. Gordon Campbell, "Paradise Lost", Book II
+
+L<Announced on 2016-10-12 by Steve Hay|http://www.nntp.perl.org/group/perl.perl5.porters/2016/10/msg240223.html>
+
+ Far off from these, a slow and silent stream,
+ Lethe, the river of oblivion, rolls
+ Her watery labyrinth, whereof who drinks
+ Forthwith his former state and being forgets --
+ Forgets both joy and grief, pleasure and pain.
+ Beyond this flood a frozen continent
+ Lies dark and wild, beat with perpetual storms
+ Of Whirlwind and dire hail, which on firm land
+ Thaws not, but gathers heap, and ruin seems
+ Of ancient pile; all else deep snow and ice,
+ A gulf profound as that Serbonian bog
+ Betwixt Damiata and Mount Casius old,
+ Where armies whole have sunk: the parching air
+ Burns frore, and cold performs the effect of fire.
+ Thither, by harpy-footed Furies haled,
+ At certain revolutions all the damned
+ Are brought; and feel by turns the bitter change
+ Of fierce extremes, extremes by change more fierce,
+ From beds of raging fire to starve in ice
+ Their soft ethereal warmth, and there to pine
+ Immovable, infixed, and frozen round
+ Periods of time -- thence hurried back to fire.
+ They ferry over this Lethean sound
+ Both to and fro, their sorrow to augment,
+ And wish and struggle, as they pass, to reach
+ The tempting stream, with one small drop to lose
+ In sweet forgetfulness all pain and woe,
+ All in one moment, and so near the brink;
+ But fate withstands, and, to oppose the attempt,
+ Medusa with Gorgonian terror guards
+ The ford, and of itself the water flies
+ All taste of living wight, as once it fled
+ The lip of Tantalus.
+
=head2 v5.22.3-RC3 - Dante Alighieri, trans. Dorothy L. Sayers and Barbara Reynolds, "The Divine Comedy", Cantica III: Paradise, Canto IV
L<Announced on 2016-08-11 by Steve Hay|http://www.nntp.perl.org/group/perl.perl5.porters/2016/08/msg238908.html>
Porting/corelist-perldelta.pl
Porting/corelist.pl
Porting/expand-macro.pl
+Porting/harness-timer-report.pl
Porting/findrfuncs
Porting/makerel
Porting/make_dot_patch.pl
--- /dev/null
+#!perl -w
+#
+# harness-timer-report.pl
+#
+# - read in the HARNESS_TIMER=1 output of "make test"
+# - convert the milliseconds to seconds
+# - compute a couple of derived values
+# - cpu: the sum of 'self' and 'kids'
+# - ratio of the wallclock and the cpu
+# - optionally show header, the sum, or the max of each colum
+# - sort the rows in various ways
+# - default ordering by 'cpu' seconds
+# - optionally scale the column values by either the sum or the max
+# - optionally display only rows that have rows of at least / at most a limit
+#
+# The --sort option has a few canned sorting rules. If those are
+# not to your liking, there is always sort(1).
+#
+# Example usages:
+#
+# perl harness-timer-report.pl log
+# perl harness-timer-report.pl --sort=wall log
+# perl harness-timer-report.pl --scale=sum log
+# perl harness-timer-report.pl --scale=sum --min=0.01 log
+# perl harness-timer-report.pl --show=header,max,sum log
+# perl harness-timer-report.pl --min=wall=10 log
+
+use strict;
+use warnings;
+
+use File::Basename qw[basename];
+
+our $ME = basename($0);
+
+use Getopt::Long;
+
+sub usage {
+ die <<__EOF__;
+$ME: Usage:
+$ME [--scale=[sum|max]]
+ [--sort=[cpu|wall|ratio|self|kids|test|name]]
+ [--show=header,sum,max]
+ [--min=[[cpu|wall|ratio|self|kids]=value,...]]
+ [--max=[[cpu|wall|ratio|self|kids]=value,...]]
+ [--order]
+ logfile
+
+The --order includes the original test order as the last column.
+__EOF__
+}
+
+my %Opt;
+usage()
+ unless
+ GetOptions(
+ 'scale=s' => \$Opt{scale},
+ 'sort=s' => \$Opt{sort},
+ 'show=s' => \$Opt{show},
+ 'min=s' => \$Opt{min},
+ 'max=s' => \$Opt{max},
+ 'order' => \$Opt{order},
+ );
+
+my %SHOW;
+if (defined $Opt{show}) {
+ for my $s (split(/,/, $Opt{show})) {
+ if ($s =~ /^(header|sum|max)$/) {
+ $SHOW{$s}++;
+ } else {
+ die "$ME: Unexpected --show='$s'\n";
+ }
+ }
+}
+my %MIN;
+if (defined $Opt{min}) {
+ for my $s (split(/,/, $Opt{min})) {
+ if ($s =~ /^(wall|cpu|kids|self|ratio)=(\d+(?:\.\d+)?)$/) {
+ $MIN{$1} = $2;
+ } else {
+ die "$ME: Unexpected --min='$s'\n";
+ }
+ }
+}
+my %MAX;
+if (defined $Opt{max}) {
+ for my $s (split(/,/, $Opt{max})) {
+ if ($s =~ /^(wall|cpu|kids|self|ratio)=(\d+(?:\.\d+)?)$/) {
+ $MAX{$1} = $2;
+ } else {
+ die "$ME: Unexpected --max='$s'\n";
+ }
+ }
+}
+
+use List::Util qw[max];
+
+my ($sa, $sb, $sc, $sd, $se);
+my ($ma, $mb, $mc, $md, $me);
+
+my $order = 0;
+my @t;
+while (<>) {
+ # t/re/pat ....................................................... ok 2876 ms 2660 ms 210 ms
+ if (m{(.+)\s+\.+\s+ok\s+(\d+)\s+ms\s+(\d+)\s+ms\s+(\d+)\s+ms$}) {
+ my ($test, $wall, $self, $kids) = ($1, $2, $3, $4);
+ next unless $wall > 0;
+ # Milliseconds to seconds.
+ $wall /= 1000;
+ $self /= 1000;
+ $kids /= 1000;
+ my $cpu = $self + $kids;
+ my $ratio = $cpu / $wall;
+ push @t, [ $test, $wall, $self, $kids, $cpu, $ratio, $order++ ];
+ $sa += $wall;
+ $sb += $self;
+ $sc += $kids;
+ $sd += $cpu;
+ $ma = max($wall, $ma // $wall);
+ $mb = max($self, $mb // $self);
+ $mc = max($kids, $mc // $kids);
+ $md = max($cpu, $md // $cpu);
+ $me = max($ratio, $md // $ratio);
+ }
+}
+
+die "$ME: No input found\n" unless @t;
+
+# Compute the sum for the ratio only after the loop.
+$se = $sd / $sa;
+
+my %SORTER =
+ (
+ 'cpu' =>
+ sub { $b->[4] <=> $a->[4] ||
+ $b->[1] <=> $a->[1] ||
+ $a->[0] cmp $b->[0] },
+ 'wall' =>
+ sub { $b->[1] <=> $a->[1] ||
+ $b->[4] <=> $a->[4] ||
+ $a->[0] cmp $b->[0] },
+ 'ratio' =>
+ sub { $b->[5] <=> $a->[5] ||
+ $b->[4] <=> $a->[4] ||
+ $b->[1] <=> $a->[1] ||
+ $a->[0] cmp $b->[0] },
+ 'self' =>
+ sub { $b->[2] <=> $a->[2] ||
+ $b->[3] <=> $a->[3] ||
+ $a->[0] cmp $b->[0] },
+ 'kids' =>
+ sub { $b->[3] <=> $a->[3] ||
+ $b->[2] <=> $a->[2] ||
+ $a->[0] cmp $b->[0] },
+ 'test' =>
+ sub { $a->[6] <=> $b->[6] },
+ 'name' =>
+ sub { $a->[0] cmp $b->[0] },
+ );
+my $sorter;
+
+$Opt{sort} //= 'cpu';
+
+die "$ME: Unexpected --sort='$Opt{sort}'\n"
+ unless defined $SORTER{$Opt{sort}};
+
+@t = sort { $SORTER{$Opt{sort}}->() } @t;
+
+if (defined $Opt{scale}) {
+ my ($ta, $tb, $tc, $td, $te) =
+ $Opt{scale} eq 'sum' ?
+ ($sa, $sb, $sc, $sd, $se) :
+ $Opt{scale} eq 'max' ?
+ ($ma, $mb, $mc, $md, $me) :
+ die "$ME: Unexpected --scale='$Opt{scale}'";
+
+ my @u;
+ for my $t (@t) {
+ push @u, [ $t->[0],
+ $t->[1] / $ta, $t->[2] / $tb,
+ $t->[3] / $tc, $t->[4] / $td,
+ $t->[5] / $te, $t->[6] ];
+ }
+ @t = @u;
+}
+
+if ($SHOW{header}) {
+ my @header = qw[TEST WALL SELF KIDS CPU RATIO];
+ if ($Opt{order}) {
+ push @header, 'ORDER';
+ }
+ print join(" ", @header), "\n";
+}
+if ($SHOW{sum}) {
+ print join(" ", "SUM",
+ map { sprintf("%.6f", $_) } $sa, $sb, $sc, $sd, $se),
+ "\n";
+}
+if ($SHOW{max}) {
+ print join(" ", "MAX",
+ map { sprintf("%.6f", $_) } $ma, $mb, $mc, $md, $me),
+ "\n";
+}
+
+my %N2I = (wall => 1,
+ self => 2,
+ kids => 3,
+ cpu => 4,
+ ratio => 5);
+
+sub row_is_skippable {
+ my ($t) = @_;
+ if (scalar keys %MIN) {
+ for my $k (grep { exists $MIN{$_} } keys %N2I) {
+ if ($t->[$N2I{$k}] < $MIN{$k}) {
+ return 1;
+ }
+ }
+ }
+ if (scalar keys %MAX) {
+ for my $k (grep { exists $MAX{$_} } keys %N2I) {
+ if ($t->[$N2I{$k}] > $MAX{$k}) {
+ return 1;
+ }
+ }
+ }
+ return 0;
+}
+
+for my $t (@t) {
+ next if row_is_skippable($t);
+ my $out = sprintf("%s %.6f %.6f %.6f %.6f %.6f",
+ $t->[0], $t->[1], $t->[2], $t->[3], $t->[4], $t->[5]);
+ if ($Opt{order}) {
+ $out .= " $t->[6]";
+ }
+ print $out, "\n";
+}
+
+exit(0);
2016-06-20 5.25.2 ✓ Matthew Horsfall
2016-07-20 5.25.3 ✓ Steve Hay
2016-08-20 5.25.4 ✓ BinGOs
- 2016-09-20 5.25.5 Stevan Little
+ 2016-09-20 5.25.5 ✓ Stevan Little
2016-10-20 5.25.6 Aaron Crane
2016-11-20 5.25.7 Chad Granum
2016-12-20 5.25.8 Sawyer X
On these systems, it might be the default compilation mode, and there
is currently no guarantee that passing no use64bitall option to the
Configure process will build a 32bit perl. Implementing -Duse32bit*
-options would be nice for perl 5.25.5.
+options would be nice for perl 5.25.6.
=head2 Profile Perl - am I hot or not?
=head1 Big projects
Tasks that will get your name mentioned in the description of the "Highlights
-of 5.25.5"
+of 5.25.6"
=head2 make ithreads more robust
Make perl executable and create a symlink for libperl:
chmod a+x /boot/common/bin/perl
- cd /boot/common/lib; ln -s perl5/5.25.5/BePC-haiku/CORE/libperl.so .
+ cd /boot/common/lib; ln -s perl5/5.25.6/BePC-haiku/CORE/libperl.so .
-Replace C<5.25.5> with your respective version of Perl.
+Replace C<5.25.6> with your respective version of Perl.
=head1 KNOWN PROBLEMS
This document briefly describes Perl under Mac OS X.
- curl -O http://www.cpan.org/src/perl-5.25.5.tar.gz
- tar -xzf perl-5.25.5.tar.gz
- cd perl-5.25.5
+ curl -O http://www.cpan.org/src/perl-5.25.6.tar.gz
+ tar -xzf perl-5.25.6.tar.gz
+ cd perl-5.25.6
./Configure -des -Dprefix=/usr/local/
make
make test
=head1 DESCRIPTION
-The latest Perl release (5.25.5 as of this writing) builds without changes
+The latest Perl release (5.25.6 as of this writing) builds without changes
under all versions of Mac OS X from 10.3 "Panther" onwards.
In order to build your own version of Perl you will need 'make',
=item Additional Perl modules
- unzip perl_ste.zip -d f:/perllib/lib/site_perl/5.25.5/
+ unzip perl_ste.zip -d f:/perllib/lib/site_perl/5.25.6/
Same remark as above applies. Additionally, if this directory is not
one of directories on @INC (and @INC is influenced by C<PERLLIB_PREFIX>), you
choice. Once you have done so, use a command like the following to
unpack the archive:
- vmstar -xvf perl-5^.25^.5.tar
+ vmstar -xvf perl-5^.25^.6.tar
Then set default to the top-level source directory like so:
- set default [.perl-5^.25^.5]
+ set default [.perl-5^.25^.6]
and proceed with configuration as described in the next section.
if (*cmd == '.' && isSPACE(cmd[1]))
goto doshell;
- if (strnEQ(cmd, "exec", 4) && isSPACE(cmd[4]))
+ if (strEQs(cmd, "exec") && isSPACE(cmd[4]))
goto doshell;
s = cmd;
my $docs = "";
DOC:
while (defined($doc = $get_next_line->())) {
- last DOC if $doc =~ /^=\w+/;
+
+ # Other pod commands are considered part of the current
+ # function's docs, so can have lists, etc.
+ last DOC if $doc =~ /^=(cut|for\s+apidoc|head)/;
if ($doc =~ m:^\*/$:) {
warn "=cut missing? $file:$line:$doc";;
last DOC;
- }
+ }
$docs .= $doc;
}
$docs = "\n$docs" if $docs and $docs !~ /^\n/;
See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
more information on how to use this function on tied arrays.
-The rough perl equivalent is C<$myarray[$idx]>.
+The rough perl equivalent is C<$myarray[$key]>.
=cut
*/
count of C<val> before the call, and decrementing it if the function
returned C<NULL>.
-Approximate Perl equivalent: C<$myarray[$key] = $val;>.
+Approximate Perl equivalent: C<splice(@myarray, $key, 1, $val)>.
See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
more information on how to use this function on tied arrays.
Pushes an SV (transferring control of one reference count) onto the end of the
array. The array will grow automatically to accommodate the addition.
-Perl equivalent: C<push @myarray, $elem;>.
+Perl equivalent: C<push @myarray, $val;>.
=cut
*/
=for apidoc av_unshift
Unshift the given number of C<undef> values onto the beginning of the
-array. The array will grow automatically to accommodate the addition. You
-must then use C<av_store> to assign values to these new elements.
+array. The array will grow automatically to accommodate the addition.
-Perl equivalent: S<C<unshift @myarray, ( (undef) x $n );>>
+Perl equivalent: S<C<unshift @myarray, ((undef) x $num);>>
=cut
*/
/*
=for apidoc av_delete
-Deletes the element indexed by C<key> from the array, makes the element mortal,
-and returns it. If C<flags> equals C<G_DISCARD>, the element is freed and null
-is returned. Perl equivalent: S<C<my $elem = delete($myarray[$idx]);>> for the
-non-C<G_DISCARD> version and a void-context S<C<delete($myarray[$idx]);>> for the
-C<G_DISCARD> version.
+Deletes the element indexed by C<key> from the array, makes the element
+mortal, and returns it. If C<flags> equals C<G_DISCARD>, the element is
+freed and NULL is returned. NULL is also returned if C<key> is out of
+range.
+
+Perl equivalent: S<C<splice(@myarray, $key, 1, undef)>> (with the
+C<splice> in void context if C<G_DISCARD> is present).
=cut
*/
* 37f6186253da9824bdb27f4ad867bfe8c25d4dc6bdb2f05585e40a034675a348 lib/unicore/extracted/DLineBreak.txt
* ef24061b5a5dc93d7e90c2e34530ec757180ee75d872cba65ffc946e52624ae8 lib/unicore/extracted/DNumType.txt
* a197371fec9a1b517058b440841f60f9378d81682084eef8db22a88cb2f96e90 lib/unicore/extracted/DNumValues.txt
- * 5c7eb94310e2aaa15702fd6bed24ff0e7ab5448f9a8231d8c49ca96c9e941089 lib/unicore/mktables
+ * 421444fcd83fcdfecffa743c8888c3a1a8e88bcde472a80fca57d199ec5db10a lib/unicore/mktables
* cdecb300baad839a6f62791229f551a4fa33f3cbdca08e378dc976466354e778 lib/unicore/version
* 913d2f93f3cb6cdf1664db888bf840bc4eb074eef824e082fceda24a9445e60c regen/charset_translations.pl
* 11011bc761487f5a63c8135e67248394d4cdff6f8f204a41cdfbdc8131e79406 regen/mk_invlists.pl
* DOUBLE_IS_VAX_F_FLOAT
* DOUBLE_IS_VAX_D_FLOAT
* DOUBLE_IS_VAX_G_FLOAT
+ * DOUBLE_IS_IBM_SINGLE_32_BIT
+ * DOUBLE_IS_IBM_DOUBLE_64_BIT
+ * DOUBLE_IS_CRAY_SINGLE_64_BIT
* DOUBLE_IS_UNKNOWN_FORMAT
*/
#define DOUBLEKIND $doublekind /**/
#define DOUBLE_IS_VAX_F_FLOAT 9
#define DOUBLE_IS_VAX_D_FLOAT 10
#define DOUBLE_IS_VAX_G_FLOAT 11
+#define DOUBLE_IS_IBM_SINGLE_32_BIT 12
+#define DOUBLE_IS_IBM_DOUBLE_64_BIT 13
+#define DOUBLE_IS_CRAY_SINGLE_64_BIT 14
#define DOUBLE_IS_UNKNOWN_FORMAT -1
#$d_PRIfldbl PERL_PRIfldbl $sPRIfldbl /**/
#$d_PRIgldbl PERL_PRIgldbl $sPRIgldbl /**/
=head1 NAME
- ptar - a tar-like program written in perl
+ptar - a tar-like program written in perl
=head1 DESCRIPTION
- ptar is a small, tar look-alike program that uses the perl module
- Archive::Tar to extract, create and list tar archives.
+ptar is a small, tar look-alike program that uses the perl module
+Archive::Tar to extract, create and list tar archives.
=head1 SYNOPSIS
=head1 SEE ALSO
-
tar(1), L<Archive::Tar>.
+
L<tar(1)>, L<Archive::Tar>.
=cut
$DEBUG = 0;
$WARN = 1;
$FOLLOW_SYMLINK = 0;
-$VERSION = "2.10";
+$VERSION = "2.14";
$CHOWN = 1;
$CHMOD = 1;
$SAME_PERMISSIONS = $> == 0 ? 1 : 0;
BEGIN {
require Exporter;
- $VERSION = '2.10';
+ $VERSION = '2.14';
@ISA = qw[Exporter];
require Time::Local if $^O eq "MacOS";
use vars qw[@ISA $VERSION];
#@ISA = qw[Archive::Tar];
-$VERSION = '2.10';
+$VERSION = '2.14';
### set value to 1 to oct() it during the unpack ###
use Archive::Tar;
-# tarballs available for testing
-my @archives = (
+BEGIN {
+ eval { require IPC::Cmd; };
+ unless ( $@ ) {
+ diag('Using IPC::Cmd');
+ *can_run = \&IPC::Cmd::can_run;
+ }
+ else {
+ diag('Using fallback');
+ *can_run = sub {
+ require ExtUtils::MakeMaker;
+ my $cmd = shift;
+ my $_cmd = $cmd;
+ return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
+ require Config;
+ for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
+ next if $dir eq '';
+ require File::Spec;
+ my $abs = File::Spec->catfile($dir, $cmd);
+ return $abs if (-x $abs or $abs = MM->maybe_command($abs));
+ }
+ return;
+ };
+ }
+}
+
+# Identify tarballs available for testing
+# Some contain only files
+# Others contain both files and directories
+
+my @file_only_archives = (
[qw( src short bar.tar )],
- [qw( src long bar.tar )],
- [qw( src linktest linktest_with_dir.tar )],
);
-push @archives,
- [qw( src short foo.tgz )],
- [qw( src long foo.tgz )]
+push @file_only_archives, [qw( src short foo.tgz )]
+ if Archive::Tar->has_zlib_support;
+push @file_only_archives, [qw( src short foo.tbz )]
+ if Archive::Tar->has_bzip2_support;
+
+@file_only_archives = map File::Spec->catfile(@$_), @file_only_archives;
+
+
+my @file_and_directory_archives = (
+ [qw( src long bar.tar )],
+ [qw( src linktest linktest_with_dir.tar )],
+);
+push @file_and_directory_archives, [qw( src long foo.tgz )]
if Archive::Tar->has_zlib_support;
-push @archives,
- [qw( src short foo.tbz )],
- [qw( src long foo.tbz )]
+push @file_and_directory_archives, [qw( src long foo.tbz )]
if Archive::Tar->has_bzip2_support;
-@archives = map File::Spec->catfile(@$_), @archives;
+@file_and_directory_archives = map File::Spec->catfile(@$_), @file_and_directory_archives;
+my @archives = (@file_only_archives, @file_and_directory_archives);
plan tests => scalar @archives;
# roundtrip test
-for my $archive (@archives) {
+for my $archive_name (@file_only_archives) {
# create a new tarball with the same content as the old one
- my $old = Archive::Tar->new($archive);
+ my $old = Archive::Tar->new($archive_name);
my $new = Archive::Tar->new();
$new->add_files( $old->get_files );
# save differently if compressed
- my $ext = ( split /\./, $archive )[-1];
+ my $ext = ( split /\./, $archive_name )[-1];
my @compress =
$ext =~ /t?gz$/ ? (COMPRESS_GZIP)
: $ext =~ /(tbz|bz2?)$/ ? (COMPRESS_BZIP)
# read the archive again from disk
$new = Archive::Tar->new($filename);
- TODO: {
- local $TODO = 'Need to work out why no trailing slash';
-
# compare list of files
is_deeply(
[ $new->list_files ],
[ $old->list_files ],
- "$archive roundtrip on file names"
+ "$archive_name roundtrip on file names"
);
- };
+}
+
+# rt.cpan.org #115160
+# t/09_roundtrip.t was added with all 7 then existent tests marked TODO even
+# though 3 of them were passing. So what was really TODO was to figure out
+# why the other 4 were not passing.
+#
+# It turns out that the tests are expecting behavior which, though on the face
+# of it plausible and desirable, is not Archive::Tar::write()'s current
+# behavior. write() -- which is used in the unit tests in this file -- relies
+# on Archive::Tar::File::_prefix_and_file(). Since at least 2006 this helper
+# method has had the effect of removing a trailing slash from archive entries
+# which are in fact directories. So we have to adjust our expectations for
+# what we'll get when round-tripping on an archive which contains one or more
+# entries for directories.
+
+SKIP: {
+ skip 'No tar command found', scalar @file_and_directory_archives unless can_run('tar');
+
+ for my $archive_name (@file_and_directory_archives) {
+ my @contents;
+ if ($archive_name =~ m/\.tar$/) {
+ @contents = qx{tar tvf $archive_name};
+ }
+ elsif ($archive_name =~ m/\.tgz$/) {
+ @contents = qx{tar tzvf $archive_name};
+ }
+ elsif ($archive_name =~ m/\.tbz$/) {
+ @contents = qx{tar tjvf $archive_name};
+ }
+ chomp(@contents);
+ my @directory_or_not;
+ for my $entry (@contents) {
+ my $perms = (split(/\s+/ => $entry))[0];
+ my @chars = split('' => $perms);
+ push @directory_or_not,
+ ($chars[0] eq 'd' ? 1 : 0);
+ }
+
+ # create a new tarball with the same content as the old one
+ my $old = Archive::Tar->new($archive_name);
+ my $new = Archive::Tar->new();
+ $new->add_files( $old->get_files );
+
+ # save differently if compressed
+ my $ext = ( split /\./, $archive_name )[-1];
+ my @compress =
+ $ext =~ /t?gz$/ ? (COMPRESS_GZIP)
+ : $ext =~ /(tbz|bz2?)$/ ? (COMPRESS_BZIP)
+ : ();
+
+ my ( $fh, $filename ) = tempfile( UNLINK => 1 );
+ $new->write( $filename, @compress );
+
+ # read the archive again from disk
+ $new = Archive::Tar->new($filename);
+
+ # Adjust our expectations of
+ my @oldfiles = $old->list_files;
+ for (my $i = 0; $i <= $#oldfiles; $i++) {
+ chop $oldfiles[$i] if $directory_or_not[$i];
+ }
+
+ # compare list of files
+ is_deeply(
+ [ $new->list_files ],
+ [ @oldfiles ],
+ "$archive_name roundtrip on file names"
+ );
+ }
}
if ($is_thread) {
$b=<<EOF;
leave enter nextstate label leaveloop enterloop null and defined null
-threadsv readline gv lineseq nextstate aassign null pushmark split pushre
+threadsv readline gv lineseq nextstate aassign null pushmark split
threadsv const null pushmark rvav gv nextstate subst const unstack
EOF
} elsif ($] >= 5.021005) {
$b=<<EOF;
leave enter nextstate label leaveloop enterloop null and defined null null
-gvsv readline gv lineseq nextstate split pushre null
+gvsv readline gv lineseq nextstate split null
gvsv const nextstate subst const unstack
EOF
} else {
$b=<<EOF;
leave enter nextstate label leaveloop enterloop null and defined null null
-gvsv readline gv lineseq nextstate aassign null pushmark split pushre null
+gvsv readline gv lineseq nextstate aassign null pushmark split null
gvsv const null pushmark rvav gv nextstate subst const unstack
EOF
}
use warnings;
# ABSTRACT: A small, simple, correct HTTP/1.1 client
-our $VERSION = '0.064';
+our $VERSION = '0.070';
-use Carp ();
+sub _croak { require Carp; Carp::croak(@_) }
#pod =method new
#pod
sub $sub_name {
my (\$self, \$url, \$args) = \@_;
\@_ == 2 || (\@_ == 3 && ref \$args eq 'HASH')
- or Carp::croak(q/Usage: \$http->$sub_name(URL, [HASHREF])/ . "\n");
+ or _croak(q/Usage: \$http->$sub_name(URL, [HASHREF])/ . "\n");
return \$self->request('$req_method', \$url, \$args || {});
}
HERE
sub post_form {
my ($self, $url, $data, $args) = @_;
(@_ == 3 || @_ == 4 && ref $args eq 'HASH')
- or Carp::croak(q/Usage: $http->post_form(URL, DATAREF, [HASHREF])/ . "\n");
+ or _croak(q/Usage: $http->post_form(URL, DATAREF, [HASHREF])/ . "\n");
my $headers = {};
while ( my ($key, $value) = each %{$args->{headers} || {}} ) {
sub mirror {
my ($self, $url, $file, $args) = @_;
@_ == 3 || (@_ == 4 && ref $args eq 'HASH')
- or Carp::croak(q/Usage: $http->mirror(URL, FILE, [HASHREF])/ . "\n");
+ or _croak(q/Usage: $http->mirror(URL, FILE, [HASHREF])/ . "\n");
if ( exists $args->{headers} ) {
my $headers = {};
require Fcntl;
sysopen my $fh, $tempfile, Fcntl::O_CREAT()|Fcntl::O_EXCL()|Fcntl::O_WRONLY()
- or Carp::croak(qq/Error: Could not create temporary file $tempfile for downloading: $!\n/);
+ or _croak(qq/Error: Could not create temporary file $tempfile for downloading: $!\n/);
binmode $fh;
$args->{data_callback} = sub { print {$fh} $_[0] };
my $response = $self->request('GET', $url, $args);
close $fh
- or Carp::croak(qq/Error: Caught error closing temporary file $tempfile: $!\n/);
+ or _croak(qq/Error: Caught error closing temporary file $tempfile: $!\n/);
if ( $response->{success} ) {
rename $tempfile, $file
- or Carp::croak(qq/Error replacing $file with $tempfile: $!\n/);
+ or _croak(qq/Error replacing $file with $tempfile: $!\n/);
my $lm = $response->{headers}{'last-modified'};
if ( $lm and my $mtime = $self->_parse_http_date($lm) ) {
utime $mtime, $mtime, $file;
sub request {
my ($self, $method, $url, $args) = @_;
@_ == 3 || (@_ == 4 && ref $args eq 'HASH')
- or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/ . "\n");
+ or _croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/ . "\n");
$args ||= {}; # we keep some state in this during _request
# RFC 2616 Section 8.1.4 mandates a single retry on broken socket
if (my $e = $@) {
# maybe we got a response hash thrown from somewhere deep
if ( ref $e eq 'HASH' && exists $e->{status} ) {
+ $e->{redirects} = delete $args->{_redirects} if @{ $args->{_redirects} || []};
return $e;
}
headers => {
'content-type' => 'text/plain',
'content-length' => length $e,
- }
+ },
+ ( @{$args->{_redirects} || []} ? (redirects => delete $args->{_redirects}) : () ),
};
}
return $response;
sub www_form_urlencode {
my ($self, $data) = @_;
(@_ == 2 && ref $data)
- or Carp::croak(q/Usage: $http->www_form_urlencode(DATAREF)/ . "\n");
+ or _croak(q/Usage: $http->www_form_urlencode(DATAREF)/ . "\n");
(ref $data eq 'HASH' || ref $data eq 'ARRAY')
- or Carp::croak("form data must be a hash or array reference\n");
+ or _croak("form data must be a hash or array reference\n");
my @params = ref $data eq 'HASH' ? %$data : @$data;
@params % 2 == 0
- or Carp::croak("form data reference must have an even number of terms\n");
+ or _croak("form data reference must have an even number of terms\n");
my @terms;
while( @params ) {
my @proxy_vars;
if ( $request->{scheme} eq 'https' ) {
- Carp::croak(qq{No https_proxy defined}) unless $self->{https_proxy};
+ _croak(qq{No https_proxy defined}) unless $self->{https_proxy};
@proxy_vars = $self->_split_proxy( https_proxy => $self->{https_proxy} );
if ( $proxy_vars[0] eq 'https' ) {
- Carp::croak(qq{Can't proxy https over https: $request->{uri} via $self->{https_proxy}});
+ _croak(qq{Can't proxy https over https: $request->{uri} via $self->{https_proxy}});
}
}
else {
- Carp::croak(qq{No http_proxy defined}) unless $self->{http_proxy};
+ _croak(qq{No http_proxy defined}) unless $self->{http_proxy};
@proxy_vars = $self->_split_proxy( http_proxy => $self->{http_proxy} );
}
defined($scheme) && length($scheme) && length($host) && length($port)
&& $path_query eq '/'
) {
-
Carp::croak(qq{$type URL must be in format http[s]://[auth@]<host>:<port>/\n});
+
_croak(qq{$type URL must be in format http[s]://[auth@]<host>:<port>/\n});
}
return ($scheme, $host, $port, $auth);
# duck typing
for my $method ( qw/add cookie_header/ ) {
- Carp::croak(qq/Cookie jar must provide the '$method' method\n/)
+ _croak(qq/Cookie jar must provide the '$method' method\n/)
unless ref($jar) && ref($jar)->can($method);
}
=head1 VERSION
-version 0.064
+version 0.070
=head1 SYNOPSIS
=head1 CONTRIBUTORS
-=for stopwords Alan Gardner Alessandro Ghedini A. Sinan Unur Brad Gilbert brian m. carlson Chris Nehren Weyl Claes Jakobsson Clinton Gormley David Golden Dean Pearce Edward Zborowski James Raspass Jeremy Mates Jess Robinson Karen Etheridge Lukas Eklund Martin J. Evans Martin-Louis Bright Mike Doherty Olaf Alders Olivier Mengué Petr PÃsaÅ™ SkyMarshal Sören Kornetzki Steve Grazzini Syohei YOSHIDA Tatsuhiko Miyagawa Tom Hukins Tony Cook
+=for stopwords Alan Gardner Alessandro Ghedini A. Sinan Unur Brad Gilbert brian m. carlson Chris Nehren Weyl Claes Jakobsson Clinton Gormley Craig Berry David Golden Dean Pearce Edward Zborowski James Raspass Jeremy Mates Jess Robinson Karen Etheridge Lukas Eklund Martin J. Evans Martin-Louis Bright Mike Doherty Nicolas Rochelemagne Olaf Alders Olivier Mengué Petr PÃsaÅ™ SkyMarshal Sören Kornetzki Steve Grazzini Syohei YOSHIDA Tatsuhiko Miyagawa Tom Hukins Tony Cook
=over 4
=item *
+Craig A. Berry <craigberry@mac.com>
+
+=item *
+
David Golden <xdg@xdg.me>
=item *
=item *
+Nicolas Rochelemagne <rochelemagne@cpanel.net>
+
+=item *
+
Olaf Alders <olaf@wundersolutions.com>
=item *
XSRETURN_UNDEF;
retsv = ST(0);
+ SvGETMAGIC(retsv);
magic = SvAMAGIC(retsv);
if(!magic)
retval = slu_sv_value(retsv);
for(index = 1 ; index < items ; index++) {
SV *stacksv = ST(index);
SV *tmpsv;
+ SvGETMAGIC(stacksv);
if((magic || SvAMAGIC(stacksv)) && (tmpsv = amagic_call(retsv, stacksv, gt_amg, 0))) {
if(SvTRUE(tmpsv) ? !ix : ix) {
retsv = stacksv;
}
sv = ST(0);
+ SvGETMAGIC(sv);
switch((accum = accum_type(sv))) {
case ACC_SV:
retsv = TARG;
for(index = 1 ; index < items ; index++) {
sv = ST(index);
+ SvGETMAGIC(sv);
if(accum < ACC_SV && SvAMAGIC(sv)){
if(!retsv)
retsv = TARG;
GvSV(agv) = ret;
SvSetMagicSV(ret, args[1]);
#ifdef dMULTICALL
+ assert(cv);
if(!CvISXSUB(cv)) {
dMULTICALL;
I32 gimme = G_SCALAR;
SAVESPTR(GvSV(PL_defgv));
#ifdef dMULTICALL
+ assert(cv);
if(!CvISXSUB(cv)) {
dMULTICALL;
I32 gimme = G_SCALAR;
SAVESPTR(GvSV(PL_defgv));
#ifdef dMULTICALL
+ assert(cv);
if(!CvISXSUB(cv)) {
dMULTICALL;
I32 gimme = G_SCALAR;
SAVESPTR(GvSV(agv));
SAVESPTR(GvSV(bgv));
#ifdef dMULTICALL
+ assert(cv);
if(!CvISXSUB(cv)) {
/* Since MULTICALL is about to move it */
SV **stack = PL_stack_base + ax;
SAVESPTR(GvSV(agv));
SAVESPTR(GvSV(bgv));
#ifdef dMULTICALL
+ assert(cv);
if(!CvISXSUB(cv)) {
/* Since MULTICALL is about to move it */
SV **stack = PL_stack_base + ax;
* Skip it on those versions (RT#87857)
*/
#if defined(dMULTICALL) && (PERL_BCDVERSION > 0x5010000 || PERL_BCDVERSION < 0x5008009)
+ assert(cv);
if(!CvISXSUB(cv)) {
/* Since MULTICALL is about to move it */
SV **stack = PL_stack_base + ax;
all any first min max minstr maxstr none notall product reduce sum sum0 shuffle uniq uniqnum uniqstr
pairs unpairs pairkeys pairvalues pairmap pairgrep pairfirst
);
-our $VERSION = "1.45_01";
+our $VERSION = "1.46";
our $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
max maxstr min minstr product sum sum0
- pairs pairkeys pairvalues pairfirst pairgrep pairmap
+ pairs unpairs pairkeys pairvalues pairfirst pairgrep pairmap
- shuffle uniqnum uniqstr
+ shuffle uniq uniqnum uniqstr
);
=head1 DESCRIPTION
the returned list is coerced into a numerical zero, so that the entire list of
values returned by C<uniqnum> are well-behaved as numbers.
+Note also that multiple IEEE C<NaN> values are treated as duplicates of
+each other, regardless of any differences in their payloads, and despite
+the fact that C<< 0+'NaN' == 0+'NaN' >> yields false.
+
=head2 uniqstr
my @subset = uniqstr @values
use warnings;
use List::Util;
-our $VERSION = "1.45_01"; # FIXUP
+our $VERSION = "1.46"; # FIXUP
$VERSION = eval $VERSION; # FIXUP
1;
dualvar isdual isvstring looks_like_number openhandle readonly set_prototype
tainted
);
-our $VERSION = "1.45_01";
+our $VERSION = "1.46";
$VERSION = eval $VERSION;
require List::Util; # List::Util loads the XS
subname set_subname
);
-our $VERSION = "1.45_01";
+our $VERSION = "1.46";
$VERSION = eval $VERSION;
require List::Util; # as it has the XS
use Scalar::Util ();
use List::Util ();
use List::Util::XS ();
-use Test::More tests => 2;
+use Sub::Util ();
+use Test::More tests => 4;
-is( $Scalar::Util::VERSION, $List::Util::VERSION, "VERSION mismatch");
+is( $Scalar::Util::VERSION, $List::Util::VERSION, "VERSION mismatch between Scalar/List");
my $has_xs = eval { Scalar::Util->import('dualvar'); 1 };
my $xs_version = $has_xs ? $List::Util::VERSION : undef;
-is( $List::Util::XS::VERSION, $xs_version, "XS VERSION");
+is( $List::Util::XS::VERSION, $xs_version, "VERSION mismatch between LU::XS and LU");
+is( $Sub::Util::VERSION, $Scalar::Util::VERSION, "VERSION mistmatch between Sub/Scalar");
+is( $Sub::Util::VERSION, $List::Util::VERSION, "VERSION mistmatch between Sub/List");
use strict;
use warnings;
-use Test::More tests => 10;
+use Test::More tests => 22;
use List::Util qw(min);
my $v;
$v = min(1, 2, $v1, 3);
is($v, 1, 'bigint and normal int');
+{
+ # test that min/max and sum call GETMAGIC properly
+ # note, in my tests how this fails depends on exactly
+ # which List::Util subs are called and in what order.
+ my @list;
+ for my $size (10, 20, 10, 30) {
+ @list = ( 1 ) x $size;
+
+ my $sum= List::Util::sum( 0, $#list );
+ ok( $sum == $size-1, "sum(\$#list, 0) == $size-1");
+
+ my $min= List::Util::min( 15, $#list );
+ ok( $min <= 15, "min(15,$size)" );
+
+ my $max= List::Util::max( 0, $#list );
+ ok( $max == $size-1, "max(\$#list, 0) == $size-1");
+ }
+}
use strict;
use warnings;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
BEGIN {
if( $] < 5.008 ) {
$meta->{Test_Results} = [];
$meta->{subevents} = $subevents;
$meta->{subtest_id} = $hub->id;
+ $meta->{subtest_buffered} = $parent->format ? 0 : 1;
$self->_add_ts_hooks;
else {
$parent->{subevents} = $meta->{subevents};
$parent->{subtest_id} = $meta->{subtest_id};
+ $parent->{subtest_buffered} = $meta->{subtest_buffered};
$parent->ok( $chub->is_passing, $meta->{Name} );
}
}
my @attrs;
my $subevents = delete $self->{subevents};
my $subtest_id = delete $self->{subtest_id};
+ my $subtest_buffered = delete $self->{subtest_buffered};
my $epkg = 'Test2::Event::Ok';
if ($subevents) {
$epkg = 'Test2::Event::Subtest';
- push @attrs => (subevents => $subevents, subtest_id => $subtest_id);
+ push @attrs => (subevents => $subevents, subtest_id => $subtest_id, buffered => $subtest_buffered);
}
my $e = bless {
use strict;
use warnings;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
BEGIN { require Test2::Formatter::TAP; our @ISA = qw(Test2::Formatter::TAP) }
require Exporter;
our @ISA = qw(Exporter);
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
=head1 NAME
package Test::Builder::Tester;
use strict;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
use Test::Builder;
use Symbol;
had that we were testing for as real failures.
The color function doesn't work unless L<Term::ANSIColor> is
-compatible with your terminal.
+compatible with your terminal. Additionally, L<Win32::Console::ANSI>
+must be installed on windows platforms for color output.
Bugs (and requests for new features) can be reported to the author
-though the CPAN RT system:
-L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Builder-Tester>
+though GitHub:
+L<https://github.com/Test-More/test-more/issues>
=head1 AUTHOR
# get color
eval { require Term::ANSIColor };
unless($@) {
+ eval { require Win32::Console::ANSI } if 'MSWin32' eq $^O; # support color on windows platforms
+
# colours
my $green = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_green");
package Test::Builder::Tester::Color;
use strict;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
require Test::Builder::Tester;
use strict;
use warnings;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
BEGIN { require Test2::Event::Diag; our @ISA = qw(Test2::Event::Diag) }
return warn @_, " at $file line $line\n";
}
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
use Test::Builder::Module;
our @ISA = qw(Test::Builder::Module);
return '' if !ref $thing;
- for my $type (qw(Regexp ARRAY HASH REF SCALAR GLOB CODE)) {
+ for my $type (qw(Regexp ARRAY HASH REF SCALAR GLOB CODE VSTRING)) {
return $type if UNIVERSAL::isa( $thing, $type );
}
=head1 BUGS
-See F<http://rt.cpan.org> to report and view bugs.
+See F<https://github.com/Test-More/test-more/issues> to report and view bugs.
=head1 SOURCE
use strict;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
use Test::Builder::Module;
our @ISA = qw(Test::Builder::Module);
use vars qw( @ISA @EXPORT );
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
@EXPORT = qw( run_tests check_tests check_test cmp_results show_space );
@ISA = qw( Exporter );
if (my $want_colour = $ENV{TESTTESTERCOLOUR} || $ENV{TESTTESTERCOLOR})
{
- if (eval "require Term::ANSIColor")
+ if (eval { require Term::ANSIColor; 1 })
{
+ eval { require Win32::Console::ANSI } if 'MSWin32' eq $^O; # support color on windows platforms
my ($f, $b) = split(",", $want_colour);
$colour = Term::ANSIColor::color($f).Term::ANSIColor::color("on_$b");
$reset = Term::ANSIColor::color("reset");
package Test::Tester::Capture;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
use Test::Builder;
package Test::Tester::CaptureRunner;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
use Test::Tester::Capture;
package Test::Tester::Delegate;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
use vars '$AUTOLOAD';
package Test::use::ok;
use 5.005;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
__END__
use strict;
use warnings;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
1;
use strict;
use warnings;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
my $INST;
$hub->format(undef) if $hide;
}
}
+ elsif (! $parent->format) {
+ # If our parent has no format that means we're in a buffered subtest
+ # and now we're trying to run a streaming subtest. There's really no
+ # way for that to work, so we need to force the use of a buffered
+ # subtest here as
+ # well. https://github.com/Test-More/test-more/issues/721
+ $buffered = 1;
+ }
if ($inherit_trace) {
my $orig = $code;
use strict;
use warnings;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
use Test2::Util qw/pkg_to_file/;
use strict;
use warnings;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
use Carp qw/confess croak longmess/;
# Do not show the warning if it looks like an exception has been thrown, or
# if the context is not local to this process or thread.
- if($self->{+EVAL_ERROR} eq $@ && $hub->is_local) {
- my $frame = $self->{+_IS_SPAWN} || $self->{+TRACE}->frame;
- warn <<" EOT";
+ {
+ # Sometimes $@ is uninitialized, not a problem in this case so do not
+ # show the warning about using eq.
+ no warnings 'uninitialized';
+ if($self->{+EVAL_ERROR} eq $@ && $hub->is_local) {
+ my $frame = $self->{+_IS_SPAWN} || $self->{+TRACE}->frame;
+ warn <<" EOT";
A context appears to have been destroyed without first calling release().
Based on \$@ it does not look like an exception was thrown (this is not always
a reliable test)
Tool: $frame->[3]
Cleaning up the CONTEXT stack...
- EOT
+ EOT
+ }
}
return if $self->{+_IS_SPAWN};
use strict;
use warnings;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
our @CARP_NOT = qw/Test2::API Test2::API::Instance Test2::IPC::Driver Test2::Formatter/;
use strict;
use warnings;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
use Test2::Hub();
use strict;
use warnings;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
use Test2::Util::HashBase qw/trace nested in_subtest subtest_id/;
use strict;
use warnings;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use strict;
use warnings;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use strict;
use warnings;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use Carp qw/croak/;
use Scalar::Util qw/reftype/;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use Test2::Util::HashBase;
use Scalar::Util qw/blessed/;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use Test2::Util::HashBase qw/diagnostics renderer/;
use strict;
use warnings;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use strict;
use warnings;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use strict;
use warnings;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use strict;
use warnings;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) }
use strict;
use warnings;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) }
use strict;
use warnings;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use strict;
use warnings;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
my %ADDED;
use warnings;
require PerlIO;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
use Test2::Util::HashBase qw{
use strict;
use warnings;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
use Carp qw/carp croak confess/;
use strict;
use warnings;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
use Test2::Hub::Interceptor::Terminator();
use strict;
use warnings;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
1;
use strict;
use warnings;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) }
use strict;
use warnings;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
use Test2::API::Instance;
use strict;
use warnings;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
use Carp qw/confess longmess/;
use strict;
use warnings;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
BEGIN { require Test2::IPC::Driver; our @ISA = qw(Test2::IPC::Driver) }
use strict;
use warnings;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
use Config qw/%Config/;
use strict;
use warnings;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
use Carp qw/croak/;
use strict;
use warnings;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
require Carp;
use strict;
use warnings;
-our $VERSION = '1.302056';
+our $VERSION = '1.302059';
use Test2::Util qw/get_tid/;
package ok;
-$ok::VERSION = '1.302056';
+$ok::VERSION = '1.302059';
use strict;
use Test::More ();
my $TB = Test::Builder->create;
-$TB->plan(tests => 100);
+$TB->plan(tests => 102);
# Utility testing functions.
sub ok ($;$) {
ok !is_deeply( {x => ''}, {x => undef}, "{x => ''} != {x => undef}" );
is( $out, "not ok 41 - {x => ''} != {x => undef}\n" );
}
+
+# this will also happily fail before 5.10, even though there's no VSTRING ref type
+{
+ my $version1 = v1.2.3;
+ my $version2 = v1.2.4;
+ ok !is_deeply( [\\$version1], [\\$version2], "version objects");
+ is( $out, "not ok 42 - version objects\n" );
+}
use Test2::API qw/test2_stack/;
-sub capture(&) {
- my $code = shift;
-
- my ($err, $out) = ("", "");
-
- my $handles = test2_stack->top->format->handles;
- my ($ok, $e);
- {
- my ($out_fh, $err_fh);
-
- ($ok, $e) = try {
- open($out_fh, '>', \$out) or die "Failed to open a temporary STDOUT: $!";
- open($err_fh, '>', \$err) or die "Failed to open a temporary STDERR: $!";
-
- test2_stack->top->format->set_handles([$out_fh, $err_fh, $out_fh]);
-
- $code->();
- };
- }
- test2_stack->top->format->set_handles($handles);
-
- die $e unless $ok;
-
- $err =~ s/ $/_/mg;
- $out =~ s/ $/_/mg;
-
- return {
- STDOUT => $out,
- STDERR => $err,
- };
-}
-
# Ensure the top hub is generated
test2_stack->top;
use Test2::API qw/test2_stack/;
use Test::Builder::Formatter;
-sub capture(&) {
- my $code = shift;
-
- my ($err, $out) = ("", "");
-
- my $handles = test2_stack->top->format->handles;
- my ($ok, $e);
- {
- my ($out_fh, $err_fh);
-
- ($ok, $e) = try {
- open($out_fh, '>', \$out) or die "Failed to open a temporary STDOUT: $!";
- open($err_fh, '>', \$err) or die "Failed to open a temporary STDERR: $!";
-
- test2_stack->top->format->set_handles([$out_fh, $err_fh, $out_fh]);
-
- $code->();
- };
- }
- test2_stack->top->format->set_handles($handles);
-
- die $e unless $ok;
-
- $err =~ s/ $/_/mg;
- $out =~ s/ $/_/mg;
-
- return {
- STDOUT => $out,
- STDERR => $err,
- };
-}
-
# The tools in tools.pl have some intentional differences from the Test::More
# versions, these behave more like Test::More which is important for
# back-compat.
use strict;
use warnings;
-sub capture(&) {
+sub simple_capture(&) {
my $code = shift;
my ($err, $out) = ("", "");
my @lines;
my $file = __FILE__;
- my $out = capture {
+ my $out = simple_capture {
local $ENV{T2_KEEP_TEMPDIR} = 1;
my $ipc = Test2::IPC::Driver::Files->new();
like($out->{STDERR}, qr/^IPC Fatal Error: File for hub '12345-1-1' already exists/m, "Got message for duplicate hub");
like($out->{STDERR}, qr/^IPC Fatal Error: File for hub '12345-1-1' does not exist/m, "Cannot remove hub twice");
- $out = capture {
+ $out = simple_capture {
my $ipc = Test2::IPC::Driver::Files->new();
$ipc->add_hub($hid);
my $trace = Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'foo']);
like($out->{STDERR}, qr/Origin PID:\s+$$/, "Got pid");
like($out->{STDERR}, qr/Error: Can't store GLOB items/, "Got cause");
- $out = capture {
+ $out = simple_capture {
my $ipc = Test2::IPC::Driver::Files->new();
local $@;
eval { $ipc->send($hid, bless({ foo => 1 }, 'Foo')) };
};
like($out->{STDERR}, qr/IPC Fatal Error: hub '12345-1-1' is not available, failed to send event!/, "Cannot send to missing hub");
- $out = capture {
+ $out = simple_capture {
my $ipc = Test2::IPC::Driver::Files->new();
$tmpdir = $ipc->tempdir;
$ipc->add_hub($hid);
like($out->{STDERR}, qr/IPC Fatal Error: Not all files from hub '12345-1-1' have been collected/, "Leftover files");
like($out->{STDERR}, qr/IPC Fatal Error: Leftover files in the directory \(.*\.ready\)/, "What file");
- $out = capture {
+ $out = simple_capture {
my $ipc = Test2::IPC::Driver::Files->new();
$ipc->add_hub($hid);
close($fh);
Storable::store({}, $fn);
- $out = capture { eval { $ipc->read_event_file($fn) } };
+ $out = simple_capture { eval { $ipc->read_event_file($fn) } };
like(
$out->{STDERR},
qr/IPC Fatal Error: Got an unblessed object: 'HASH\(.*\)'/,
);
Storable::store(bless({}, 'Test2::Event::FakeEvent'), $fn);
- $out = capture { eval { $ipc->read_event_file($fn) } };
+ $out = simple_capture { eval { $ipc->read_event_file($fn) } };
like(
$out->{STDERR},
qr{IPC Fatal Error: Event has unknown type \(Test2::Event::FakeEvent\), tried to load 'Test2/Event/FakeEvent\.pm' but failed: Can't locate Test2/Event/FakeEvent\.pm},
);
Storable::store(bless({}, 'Test2::API'), $fn);
- $out = capture { eval { $ipc->read_event_file($fn) } };
+ $out = simple_capture { eval { $ipc->read_event_file($fn) } };
like(
$out->{STDERR},
qr{'Test2::API=HASH\(.*\)' is not a 'Test2::Event' object},
);
Storable::store(bless({}, 'Foo'), $fn);
- $out = capture {
+ $out = simple_capture {
local @INC;
push @INC => ('t/lib', 'lib');
eval { $ipc->read_event_file($fn) };
--- /dev/null
+use strict;
+use warnings;
+
+BEGIN { require "t/tools.pl" }
+
+# This module's exports interfere with the ones in t/tools.pl
+use Test::More ();
+use Test2::API qw/run_subtest test2_stack/;
+
+{
+ test2_stack->top;
+ my $temp_hub = test2_stack->new_hub();
+
+ my $output = capture {
+ run_subtest(
+ 'parent',
+ sub {
+ run_subtest(
+ 'buffered',
+ sub {
+ ok(1, 'b1');
+ ok(1, 'b2');
+ },
+ {buffered => 1},
+ );
+ run_subtest(
+ 'streamed',
+ sub {
+ ok(1, 's1');
+ ok(1, 's2');
+ },
+ {buffered => 0},
+ );
+ },
+ {buffered => 1},
+ );
+ };
+
+ test2_stack->pop($temp_hub);
+
+ Test::More::subtest(
+ 'Test2::API::run_subtest',
+ sub {
+ is($output->{STDERR}, q{}, 'no output on stderr');
+ like($output->{STDOUT}, qr/ +ok 1 - b1/, 'got ok output for tests in buffered subtest');
+ like($output->{STDOUT}, qr/ +ok 2 - b2/, 'got ok output for tests in buffered subtest');
+ like($output->{STDOUT}, qr/ +ok 1 - s1/, 'got ok output for tests in streamed subtest');
+ like($output->{STDOUT}, qr/ +ok 2 - s2/, 'got ok output for tests in streamed subtest');
+ }
+ );
+}
+
+{
+ test2_stack->top;
+ my $temp_hub = test2_stack->new_hub();
+
+ my $output = capture {
+ run_subtest(
+ 'parent',
+ sub {
+ run_subtest(
+ 'buffered',
+ sub {
+ ok(1, 'b1');
+ ok(1, 'b2');
+ },
+ {buffered => 1},
+ );
+ Test::More::subtest(
+ 'streamed',
+ sub {
+ ok(1, 's1');
+ ok(1, 's2');
+ },
+ {buffered => 0},
+ );
+ },
+ {buffered => 1},
+ );
+ };
+
+ test2_stack->pop($temp_hub);
+
+ Test::More::subtest(
+ 'Test::More::subtest and Test2::API::run_subtest',
+ sub {
+ is($output->{STDERR}, q{}, 'no output on stderr');
+ like($output->{STDOUT}, qr/ +ok 1 - b1/, 'got ok output for tests in buffered subtest');
+ like($output->{STDOUT}, qr/ +ok 2 - b2/, 'got ok output for tests in buffered subtest');
+ like($output->{STDOUT}, qr/ +ok 1 - s1/, 'got ok output for tests in streamed subtest');
+ like($output->{STDOUT}, qr/ +ok 2 - s2/, 'got ok output for tests in streamed subtest');
+ }
+ );
+}
+
+done_testing;
use Scalar::Util qw/blessed/;
use Test2::Util qw/try/;
-use Test2::API qw/context run_subtest/;
+use Test2::API qw/context run_subtest test2_stack/;
use Test2::Hub::Interceptor();
use Test2::Hub::Interceptor::Terminator();
return $bool;
}
+sub capture(&) {
+ my $code = shift;
+
+ my ($err, $out) = ("", "");
+
+ my $handles = test2_stack->top->format->handles;
+ my ($ok, $e);
+ {
+ my ($out_fh, $err_fh);
+
+ ($ok, $e) = try {
+ open($out_fh, '>', \$out) or die "Failed to open a temporary STDOUT: $!";
+ open($err_fh, '>', \$err) or die "Failed to open a temporary STDERR: $!";
+
+ test2_stack->top->format->set_handles([$out_fh, $err_fh, $out_fh]);
+
+ $code->();
+ };
+ }
+ test2_stack->top->format->set_handles($handles);
+
+ die $e unless $ok;
+
+ $err =~ s/ $/_/mg;
+ $out =~ s/ $/_/mg;
+
+ return {
+ STDOUT => $out,
+ STDERR => $err,
+ };
+}
+
1;
package parent;
use strict;
use vars qw($VERSION);
-$VERSION = '0.234';
+$VERSION = '0.236';
sub import {
my $class = shift;
{
no strict 'refs';
- push @{"$inheritor\::ISA"}, @_;
+ push @{"$inheritor\::ISA"}, @_; # dies if a loop is detected
};
};
-"All your base are belong to us"
+1;
__END__
plan skip_all => ".pmc are only available with 5.6 and later" if $] < 5.006;
-my $no_pmc = defined &Config::non_bincompat_options
- ? (grep $_ eq 'PERL_DISABLE_PMC', Config::non_bincompat_options())
- : ($Config::Config{ccflags} =~ /-DPERL_DISABLE_PMC\b/);
-plan skip_all => ".pmc are disabled in this perl"
- if $no_pmc;
+# Skip this test if perl is compiled with PERL_DISABLE_PMC
+#
+my $pmc = 1;
+if (Config->can('non_bincompat_options')) { # $] ge '5.014'
+ $pmc = 0
+ if grep { $_ eq 'PERL_DISABLE_PMC' } Config::non_bincompat_options();
+} elsif (eval {
+ require Config::Perl::V;
+ Config::Perl::V->VERSION('0.10');
+}) {
+ $pmc = 0
+ if Config::Perl::V::myconfig()->{options}{PERL_DISABLE_PMC};
+} else {
+ $pmc = 0
+ if $Config::Config{ccflags} =~ /(?:^|\s)-DPERL_DISABLE_PMC\b/;
+}
+
+plan skip_all => 'Perl is built with PERL_DISABLE_PMC' unless $pmc;
+
plan tests => 3;
use vars qw($got_here);
--- /dev/null
+#!perl -w\r
+use strict;\r
+use Benchmark qw/cmpthese/;\r
+use Test::More tests => 1;\r
+\r
+{\r
+ package Bench::Base;\r
+ sub foo { 1 };\r
+}\r
+\r
+my $c;\r
+my $sub_iter = 100;\r
+\r
+cmpthese (-1 => {\r
+ recompute_existing_ISA => sub {\r
+ $c++;\r
+ for (1..$sub_iter) {\r
+ my $class = "Bench::Par::Sub_${c}";\r
+ no strict 'refs';\r
+ @{ "$class\::ISA"} = (@{ "$class\::ISA"},'Bench::Base');\r
+ die unless $class->foo;\r
+ }\r
+ },\r
+ recompute_new_ISA => sub {\r
+ $c++;\r
+ for (1..$sub_iter) {\r
+ my $class = "Bench::Par::Sub_${c}::SubSub${_}";\r
+ no strict 'refs';\r
+ @{ "$class\::ISA"} = (@{ "$class\::ISA"},'Bench::Base');\r
+ die unless $class->foo;\r
+ }\r
+ },\r
+ push_existing_ISA => sub {\r
+ $c++;\r
+ for (1..$sub_iter) {\r
+ my $class = "Bench::Par::Sub_${c}";\r
+ no strict 'refs';\r
+ push @{ "$class\::ISA"}, 'Bench::Base';\r
+ die unless $class->foo;\r
+ }\r
+ },\r
+ push_new_ISA => sub {\r
+ $c++;\r
+ for (1..$sub_iter) {\r
+ my $class = "Bench::Par::Sub_${c}::SubSub${_}";\r
+ no strict 'refs';\r
+ push @{ "$class\::ISA"}, 'Bench::Base';\r
+ die unless $class->foo;\r
+ }\r
+ },\r
+ push_new_FOO => sub {\r
+ $c++;\r
+ for (1..$sub_iter) {\r
+ my $class = "Bench::Par::Sub_${c}::SubSub${_}";\r
+ no strict 'refs';\r
+ push @{ "$class\::FOO"}, 'Bench::Base';\r
+ #die unless $class->foo;\r
+ }\r
+ },\r
+ push_existing_FOO => sub {\r
+ $c++;\r
+ for (1..$sub_iter) {\r
+ my $class = "Bench::Par::Sub_${c}";\r
+ no strict 'refs';\r
+ push @{ "$class\::FOO"}, 'Bench::Base';\r
+ #die unless $class->foo;\r
+ }\r
+ },\r
+ recompute_existing_FOO => sub {\r
+ $c++;\r
+ for (1..$sub_iter) {\r
+ my $class = "Bench::Par::Sub_${c}";\r
+ no strict 'refs';\r
+ @{ "$class\::FOO"} = (@{ "$class\::FOO"}, 'Bench::Base');\r
+ #die unless $class->foo;\r
+ }\r
+ },\r
+ \r
+ # Take a reference and manipulate that, in case string references are slow\r
+ refcompute_existing_FOO => sub {\r
+ $c++;\r
+ for (1..$sub_iter) {\r
+ my $class = "Bench::Par::Sub_${c}";\r
+ no strict 'refs';\r
+ my $aref = \@{ "$class\::FOO"};\r
+ @{ $aref } = (@{ $aref }, 'Bench::Base');\r
+ #die unless $class->foo;\r
+ }\r
+ },\r
+ recompute_new_FOO => sub {\r
+ $c++;\r
+ for (1..$sub_iter) {\r
+ my $class = "Bench::Par::Sub_${c}::SubSub${_}";\r
+ no strict 'refs';\r
+ @{ "$class\::FOO"} = (@{ "$class\::FOO"}, 'Bench::Base');\r
+ #die unless $class->foo;\r
+ }\r
+ },\r
+});\r
+\r
+pass "Benchmarks run";\r
@ISA = qw(Pod::Simple);
-$VERSION = '4.07';
+$VERSION = '4.08';
# Set the debugging level. If someone has inserted a debug function into this
# class already, use that. Otherwise, use any Pod::Simple debug function
}
# Initialize the quotes that we'll be using for C<> text. This requires some
-# special handling, both to parse the user parameter if given and to make sure
-# that the quotes will be safe against *roff. Sets the internal hash keys
-# LQUOTE and RQUOTE.
+# special handling, both to parse the user parameters if given and to make
+# sure that the quotes will be safe against *roff. Sets the internal hash
+# keys LQUOTE and RQUOTE.
sub init_quotes {
my ($self) = (@_);
+ # Handle the quotes option first, which sets both quotes at once.
$$self{quotes} ||= '"';
if ($$self{quotes} eq 'none') {
$$self{LQUOTE} = $$self{RQUOTE} = '';
croak(qq(Invalid quote specification "$$self{quotes}"))
}
+ # Now handle the lquote and rquote options.
+ if (defined $$self{lquote}) {
+ $$self{LQUOTE} = $$self{lquote} eq 'none' ? q{} : $$self{lquote};
+ }
+ if (defined $$self{rquote}) {
+ $$self{RQUOTE} = $$self{rquote} eq 'none' ? q{} : $$self{rquote};
+ }
+
# Double the first quote; note that this should not be s///g as two double
# quotes is represented in *roff as three double quotes, not four. Weird,
# I know.
# entire warranty disclaimers in man page output into small caps.
if ($$self{MAGIC_SMALLCAPS}) {
s{
- ( ^ | [\s\(\"\'\`\[\{<>] | \\[ ] ) # (1)
- ( [A-Z] [A-Z] (?: [/A-Z+:\d_\$&] | \\- | [.,\"\s] )* ) # (2)
- (?= [\s>\}\]\(\)\'\".?!,;] | \\*\(-- | \\[ ] | $ ) # (3)
+ ( ^ | [\s\(\"\'\`\[\{<>] | \\[ ] ) # (1)
+ ( [A-Z] [A-Z] (?: \s? [/A-Z+:\d_\$&] | \\- | \s? [.,\"] )* ) # (2)
+ (?= [\s>\}\]\(\)\'\".?!,;] | \\*\(-- | \\[ ] | $ ) # (3)
} {
$1 . '\s-1' . $2 . '\s0'
}egx;
if ($$self{MAGIC_MANREF}) {
s{
( \b | \\s-1 )
+ (?<! \\ ) # rule out \s0(1)
( [A-Za-z_] (?:[.:\w] | \\- | \\s-?[01])+ )
( \( \d [a-z]* \) )
} {
# If Pod::Parser gave us an IO::File reference as the source file name,
# convert that to the empty string as well. Then, if we don't have a
- # valid name, emit a warning and convert it to STDIN.
+ # valid name, convert it to STDIN.
+ #
+ # In podlators 4.00 through 4.07, this also produced a warning, but that
+ # was surprising to a lot of programs that had expected to be able to pipe
+ # POD through pod2man without specifying the name. In the name of
+ # backward compatibility, just quietly set STDIN as the page title.
if ($name =~ /^IO::File(?:=\w+)\(0x[\da-f]+\)$/i) {
$name = '';
}
if ($name eq '') {
- $self->whine (1, 'No name given for document');
$name = 'STDIN';
}
=for stopwords
en em ALLCAPS teeny fixedbold fixeditalic fixedbolditalic stderr utf8
UTF-8 Allbery Sean Burke Ossanna Solaris formatters troff uppercased
-Christiansen nourls parsers Kernighan
+Christiansen nourls parsers Kernighan lquote rquote
=head1 NAME
systems (such as Solaris) have this font available as C<CX>. Only matters
for B<troff> output.
+=item lquote
+
+=item rquote
+
+Sets the quote marks used to surround CE<lt>> text. C<lquote> sets the
+left quote mark and C<rquote> sets the right quote mark. Either may also
+be set to the special value C<none>, in which case no quote mark is added
+on that side of CE<lt>> text (but the font is still changed for troff
+output).
+
+Also see the C<quotes> option, which can be used to set both quotes at once.
+If both C<quotes> and one of the other options is set, C<lquote> or C<rquote>
+overrides C<quotes>.
+
=item name
Set the name of the manual page for the C<.TH> macro. Without this
C<.../lib/Pod/Man.pm> is converted into a name like C<Pod::Man>. This
option, if given, overrides any automatic determination of the name.
-If generating a manual page from standard input, this option is required,
-since there's otherwise no way for Pod::Man to know what to use for the
-manual page name.
+If generating a manual page from standard input, the name will be set to
+C<STDIN> if this option is not provided. Providing this option is strongly
+recommended to set a meaningful manual page name.
=item nourls
marks are added around CE<lt>> text (but the font is still changed for troff
output).
+Also see the C<lquote> and C<rquote> options, which can be used to set the
+left and right quotes independently. If both C<quotes> and one of the other
+options is set, C<lquote> or C<rquote> overrides C<quotes>.
+
=item release
Set the centered footer for the C<.TH> macro. By default, this is set to
@ISA = qw(Exporter);
@EXPORT = qw(parselink);
-$VERSION = '4.07';
+$VERSION = '4.08';
##############################################################################
# Implementation
# We have to export pod2text for backward compatibility.
@EXPORT = qw(pod2text);
-$VERSION = '4.07';
+$VERSION = '4.08';
##############################################################################
# Initialization
@ISA = qw(Pod::Text);
-$VERSION = '4.07';
+$VERSION = '4.08';
##############################################################################
# Overrides
@ISA = qw(Pod::Text);
-$VERSION = '4.07';
+$VERSION = '4.08';
##############################################################################
# Overrides
@ISA = qw(Pod::Text);
-$VERSION = '4.07';
+$VERSION = '4.08';
##############################################################################
# Overrides
Getopt::Long::config ('bundling_override');
GetOptions (\%options, 'center|c=s', 'date|d=s', 'errors=s', 'fixed=s',
'fixedbold=s', 'fixeditalic=s', 'fixedbolditalic=s', 'help|h',
- 'lax|l', 'name|n=s', 'nourls', 'official|o', 'quotes|q=s',
- 'release|r=s', 'section|s=s', 'stderr', 'verbose|v', 'utf8|u')
+ 'lax|l', 'lquote=s', 'name|n=s', 'nourls', 'official|o',
+ 'quotes|q=s', 'release|r=s', 'rquote=s', 'section|s=s', 'stderr',
+ 'verbose|v', 'utf8|u')
or exit 1;
pod2usage (0) if $options{help};
=for stopwords
en em --stderr stderr --utf8 UTF-8 overdo markup MT-LEVEL Allbery Solaris
URL troff troff-specific formatters uppercased Christiansen --nourls UTC
-prepend
+prepend lquote rquote
=head1 NAME
pod2man [B<--center>=I<string>] [B<--date>=I<string>] [B<--errors>=I<style>]
[B<--fixed>=I<font>] [B<--fixedbold>=I<font>] [B<--fixeditalic>=I<font>]
[B<--fixedbolditalic>=I<font>] [B<--name>=I<name>] [B<--nourls>]
- [B<--official>] [B<--quotes>=I<quotes>] [B<--release>=I<version>]
- [B<--section>=I<manext>] [B<--stderr>] [B<--utf8>] [B<--verbose>]
- [I<input> [I<output>] ...]
+ [B<--official>] [B<--release>=I<version>] [B<--section>=I<manext>]
+ [B<--quotes>=I<quotes>] [B<--lquote>=I<quote>] [B<--rquote>=I<quote>]
+ [B<--stderr>] [B<--utf8>] [B<--verbose>] [I<input> [I<output>] ...]
pod2man B<--help>
manual page, but this should now be done by L<podchecker(1)> instead.
Accepted for backward compatibility; this option no longer does anything.
+=item B<--lquote>=I<quote>
+
+=item B<--rquote>=I<quote>
+
+Sets the quote marks used to surround CE<lt>> text. B<--lquote> sets the
+left quote mark and B<--rquote> sets the right quote mark. Either may also
+be set to the special value C<none>, in which case no quote mark is added
+on that side of CE<lt>> text (but the font is still changed for troff
+output).
+
+Also see the B<--quotes> option, which can be used to set both quotes at once.
+If both B<--quotes> and one of the other options is set, B<--lquote> or
+B<--rquote> overrides B<--quotes>.
+
=item B<-n> I<name>, B<--name>=I<name>
Set the name of the manual page for the C<.TH> macro to I<name>. Without
This option is probably not useful when converting multiple POD files at
once.
-When converting POD source from standard input, this option is required,
-since there's otherwise no way to know what to use as the name of the
-manual page.
+When converting POD source from standard input, the name will be set to
+C<STDIN> if this option is not provided. Providing this option is strongly
+recommended to set a meaningful manual page name.
=item B<--nourls>
quote marks are added around CE<lt>> text (but the font is still changed for
troff output).
+Also see the B<--lquote> and B<--rquote> options, which can be used to set the
+left and right quotes independently. If both B<--quotes> and one of the other
+options is set, B<--lquote> or B<--rquote> overrides B<--quotes>.
+
=item B<-r> I<version>, B<--release>=I<version>
Set the centered footer for the C<.TH> macro to I<version>. By default,
"Section "with" \e[4m\e[1mother\e[m markup\e[m" in foo|bar
- Nested <http://www.perl.org/>
-
\e[1mOVER AND ITEMS\e[m
Taken from Pod::Parser tests, this is a test to ensure that multiline
=item paragraphs get indented appropriately.
"Section "with" \e[33m\e[1mother\e[0m markup\e[0m" in foo|bar
- Nested <http://www.perl.org/>
-
\e[1mOVER AND ITEMS\e[0m
Taken from Pod::Parser tests, this is a test to ensure that multiline
=item paragraphs get indented appropriately.
"\fIItalic\fR text" in foo
.PP
"Section \f(CW\*(C`with\*(C'\fR \fI\f(BIother\fI markup\fR" in foo|bar
-.PP
-Nested <http://www.perl.org/>
.SH "OVER AND ITEMS"
.IX Header "OVER AND ITEMS"
Taken from Pod::Parser tests, this is a test to ensure that multiline
"Section "with" _\bo_\bt_\bh_\be_\br_\b _\bm_\ba_\br_\bk_\bu_\bp" in foo|bar
- Nested <http://www.perl.org/>
-
O\bOV\bVE\bER\bR \b A\bAN\bND\bD \b I\bIT\bTE\bEM\bMS\bS
Taken from Pod::Parser tests, this is a test to ensure that multiline
=item paragraphs get indented appropriately.
L<fooE<verbar>barZ<>/Section C<with> I<B<other> markup>>
-L<Nested L<http://www.perl.org/>|fooE<sol>bar>
-
=head1 OVER AND ITEMS
Taken from Pod::Parser tests, this is a test to ensure that multiline
"Section "with" *other markup*" in foo|bar
- Nested <http://www.perl.org/>
-
OVER AND ITEMS
Taken from Pod::Parser tests, this is a test to ensure that multiline
=item paragraphs get indented appropriately.
--- /dev/null
+[name]
+Handling of bullet after non-bullet
+
+[options]
+errors none
+
+[input]
+=over 4
+
+=item foo
+
+Not a bullet.
+
+=item *
+
+Also not a bullet.
+
+=back
+
+[output]
+.IP "foo" 4
+.IX Item "foo"
+Not a bullet.
+.IP "*" 4
+Also not a bullet.
--- /dev/null
+[name]
+Errors throw exceptions
+
+[options]
+errors die
+
+[input]
+=over 4
+
+=item Foo
+
+Bar.
+
+=head1 NEXT
+
+[output]
+.IP "Foo" 4
+.IX Item "Foo"
+Bar.
+.SH "NEXT"
+.IX Header "NEXT"
+
+[errors]
+Pod input around line 7: You forgot a '=back' before '=head1'
+
+[exception]
+POD document had syntax errors
--- /dev/null
+[name]
+Suppress errors
+
+[options]
+errors none
+
+[input]
+=over 4
+
+=item Foo
+
+Bar.
+
+=head1 NEXT
+
+[output]
+.IP "Foo" 4
+.IX Item "Foo"
+Bar.
+.SH "NEXT"
+.IX Header "NEXT"
--- /dev/null
+[name]
+Normal error handling
+
+[input]
+=over 4
+
+=item Foo
+
+Bar.
+
+=head1 NEXT
+
+[output]
+.IP "Foo" 4
+.IX Item "Foo"
+Bar.
+.SH "NEXT"
+.IX Header "NEXT"
+.SH "POD ERRORS"
+.IX Header "POD ERRORS"
+Hey! \fBThe above document had some coding errors, which are explained below:\fR
+.IP "Around line 7:" 4
+.IX Item "Around line 7:"
+You forgot a '=back' before '=head1'
--- /dev/null
+[name]
+Errors to POD source
+
+[options]
+errors pod
+
+[input]
+=over 4
+
+=item Foo
+
+Bar.
+
+=head1 NEXT
+
+[output]
+.IP "Foo" 4
+.IX Item "Foo"
+Bar.
+.SH "NEXT"
+.IX Header "NEXT"
+.SH "POD ERRORS"
+.IX Header "POD ERRORS"
+Hey! \fBThe above document had some coding errors, which are explained below:\fR
+.IP "Around line 7:" 4
+.IX Item "Around line 7:"
+You forgot a '=back' before '=head1'
--- /dev/null
+[name]
+Errors to stadard error
+
+[options]
+errors stderr
+
+[input]
+=over 4
+
+=item Foo
+
+Bar.
+
+=head1 NEXT
+
+[output]
+.IP "Foo" 4
+.IX Item "Foo"
+Bar.
+.SH "NEXT"
+.IX Header "NEXT"
+
+[errors]
+Pod input around line 7: You forgot a '=back' before '=head1'
--- /dev/null
+[name]
+Errors to standard error with stderr option
+
+[options]
+stderr 1
+
+[input]
+=over 4
+
+=item Foo
+
+Bar.
+
+=head1 NEXT
+
+[output]
+.IP "Foo" 4
+.IX Item "Foo"
+Bar.
+.SH "NEXT"
+.IX Header "NEXT"
+
+[errors]
+Pod input around line 7: You forgot a '=back' before '=head1'
--- /dev/null
+[name]
+Options to set fixed fonts
+
+[options]
+fixed CR
+fixedbold CY
+fixeditalic CW
+fixedbolditalic CX
+
+[input]
+=head1 FIXED FONTS
+
+C<foo B<bar I<baz>> I<bay>>
+
+[output]
+.SH "FIXED FONTS"
+.IX Header "FIXED FONTS"
+\&\f(CR\*(C`foo \f(CYbar \f(CXbaz\f(CY\f(CR \f(CWbay\f(CR\*(C'\fR
--- /dev/null
+[name]
+Long quotes option
+
+[options]
+quotes \(lq"\(rq"
+
+[input]
+=head1 FOO C<BAR> BAZ
+
+Foo C<bar> baz.
+
+[output]
+.ie n .SH "FOO \(lq""BAR\(rq"" BAZ"
+.el .SH "FOO \f(CWBAR\fP BAZ"
+.IX Header "FOO BAR BAZ"
+Foo \f(CW\*(C`bar\*(C'\fR baz.
--- /dev/null
+[name]
+lquote and quotes both used
+
+[options]
+lquote ``
+quotes "
+
+[input]
+=head1 FOO C<BAR> BAZ
+
+Foo C<bar> baz.
+
+[output]
+.ie n .SH "FOO ``BAR"" BAZ"
+.el .SH "FOO \f(CWBAR\fP BAZ"
+.IX Header "FOO BAR BAZ"
+Foo \f(CW\*(C`bar\*(C'\fR baz.
--- /dev/null
+[name]
+Set separate left and right quotes
+
+[options]
+lquote ``
+rquote "
+
+[input]
+=head1 FOO C<BAR> BAZ
+
+Foo C<bar> baz.
+
+[output]
+.ie n .SH "FOO ``BAR"" BAZ"
+.el .SH "FOO \f(CWBAR\fP BAZ"
+.IX Header "FOO BAR BAZ"
+Foo \f(CW\*(C`bar\*(C'\fR baz.
--- /dev/null
+[name]
+nourls option
+
+[options]
+nourls 1
+
+[input]
+=head1 URL suppression
+
+L<anchor|http://www.example.com/>
+
+[output]
+.SH "URL suppression"
+.IX Header "URL suppression"
+anchor
--- /dev/null
+[name]
+rquote set to none
+
+[options]
+rquote none
+
+[input]
+=head1 FOO C<BAR> BAZ
+
+Foo C<bar> baz.
+
+[output]
+.ie n .SH "FOO ""BAR BAZ"
+.el .SH "FOO \f(CWBAR\fP BAZ"
+.IX Header "FOO BAR BAZ"
+Foo \f(CW\*(C`bar\*(C'\fR baz.
}
if ($data_ref->{exception} || $exception) {
if ($exception) {
- $exception =~ s{ [ ] at [ ] .* }{}xms;
+ $exception =~ s{ [ ] at [ ] .* }{\n}xms;
}
is($exception, $data_ref->{exception}, "$data_ref->{name}: exception");
}
# This version should match the corresponding rra-c-util release, but with
# two digits for the minor version, including a leading zero if necessary,
# so that it will sort properly.
- $VERSION = '5.09';
+ $VERSION = '6.01';
}
# Skip this test unless author tests are requested. Takes a short description
# This version should match the corresponding rra-c-util release, but with
# two digits for the minor version, including a leading zero if necessary,
# so that it will sort properly.
- $VERSION = '5.09';
+ $VERSION = '6.01';
}
-# If BUILD or SOURCE are set in the environment, look for data/perl.conf under
-# those paths for a C Automake package. Otherwise, look in t/data/perl.conf
-# for a standalone Perl module or tests/data/perl.conf for Perl tests embedded
-# in a larger distribution. Don't use Test::RRA::Automake since it may not
-# exist.
+# If C_TAP_BUILD or C_TAP_SOURCE are set in the environment, look for
+# data/perl.conf under those paths for a C Automake package. Otherwise, look
+# in t/data/perl.conf for a standalone Perl module or tests/data/perl.conf for
+# Perl tests embedded in a larger distribution. Don't use Test::RRA::Automake
+# since it may not exist.
our $PATH;
-for my $base ($ENV{BUILD}, $ENV{SOURCE}, 't', 'tests') {
+for my $base ($ENV{C_TAP_BUILD}, $ENV{C_TAP_SOURCE}, './t', './tests') {
next if !defined($base);
my $path = "$base/data/perl.conf";
if (-r $path) {
# Load the configuration.
if (!do($PATH)) {
my $error = $@ || $! || 'loading file did not return true';
- BAIL_OUT("cannot load data/perl.conf: $error");
+ BAIL_OUT("cannot load $PATH: $error");
}
1;
Test::RRA::Config looks for a file named F<data/perl.conf> relative to the
root of the test directory. That root is taken from the environment variables
-BUILD or SOURCE (in that order) if set, which will be the case for C Automake
-packages using C TAP Harness. If neither is set, it expects the root of the
-test directory to be a directory named F<t> relative to the current directory,
-which will be the case for stand-alone Perl modules.
+C_TAP_BUILD or C_TAP_SOURCE (in that order) if set, which will be the case for
+C Automake packages using C TAP Harness. If neither is set, it expects the
+root of the test directory to be a directory named F<t> relative to the
+current directory, which will be the case for stand-alone Perl modules.
The following variables are supported:
=head1 COPYRIGHT AND LICENSE
+Copyright 2015, 2016 Russ Allbery <eagle@eyrie.org>
+
Copyright 2013, 2014 The Board of Trustees of the Leland Stanford Junior
University
# This version should match the corresponding rra-c-util release, but with
# two digits for the minor version, including a leading zero if necessary,
# so that it will sort properly.
- $VERSION = '5.09';
+ $VERSION = '6.01';
}
# A regular expression matching the version string for a module using the
use strict;
-use Test::More tests => 35;
+use Test::More tests => 37;
BEGIN { use_ok ('Pod::Man') }
# Test whether we can use binmode to set encoding.
.el .IP "\f(CWtar \f(CIletter\f(CW... [\f(CIargument\f(CW]... [\f(CIoption\f(CW]... [\f(CIname\f(CW]...\fR" 2
.IX Item "tar letter... [argument]... [option]... [name]..."
###
+
+###
+=head1 TRUE (1)
+
+podlators prior to 4.08 misrendered TRUE (1) and FALSE (0) with escaped nroff
+in the output because it tried to apply both small caps and man page reference
+code and got it wrong.
+###
+.SH "TRUE (1)"
+.IX Header "TRUE (1)"
+podlators prior to 4.08 misrendered \s-1TRUE\s0 (1) and \s-1FALSE\s0 (0) with escaped nroff
+in the output because it tried to apply both small caps and man page reference
+code and got it wrong.
+###
+
+###
+=pod
+
+Not a man page reference: \s0(1)
+###
+.PP
+Not a man page reference: \es0(1)
+###
$parser->output_string(\$output);
$parser->parse_file($handle);
-# Check the results of devise_title for this. We should get back STDIN, and
-# we should have reported an error.
+# Check the results of devise_title for this. We should get back STDIN and
+# not report an error.
my ($name, $section) = $parser->devise_title;
is($name, 'STDIN', 'devise_title uses STDIN for file handle input');
-ok($parser->errors_seen, '...and errors were seen');
+ok(!$parser->errors_seen, '...and no errors were seen');
# Now check handling of a simple file name with no parent directory, which
# simulates a POD file at the top of a distribution. In podlators 4.06, this
-#!/usr/bin/perl -w
+#!/usr/bin/perl
#
-# Additional tests for Pod::Man options.
+# Test Pod::Man behavior with various options
#
-# Copyright 2002, 2004, 2006, 2008, 2009, 2012, 2013, 2015
+# Copyright 2002, 2004, 2006, 2008, 2009, 2012, 2013, 2015, 2016
# Russ Allbery <rra@cpan.org>
#
# This program is free software; you may redistribute it and/or modify it
use lib 't/lib';
use Test::More tests => 31;
-use Test::Podlators qw(read_test_data slurp);
+use Test::Podlators qw(test_snippet);
+# Load the module.
BEGIN {
- use_ok ('Pod::Man');
+ use_ok('Pod::Man');
}
-# Redirect stderr to a file. Return the name of the file that stores standard
-# error.
-sub stderr_save {
- open(OLDERR, '>&STDERR') or die "Can't dup STDERR: $!\n";
- open(STDERR, "> out$$.err") or die "Can't redirect STDERR: $!\n";
- return "out$$.err";
-}
-
-# Restore stderr.
-sub stderr_restore {
- close(STDERR);
- open(STDERR, '>&OLDERR') or die "Can't dup STDERR: $!\n";
- close(OLDERR);
-}
-
-# Loop through all the test data, generate output, and compare it to the
-# desired output data.
-my %options = (options => 1, errors => 1);
-my $n = 1;
-while (defined(my $data_ref = read_test_data(\*DATA, \%options))) {
- my $parser = Pod::Man->new(%{ $data_ref->{options} }, name => 'TEST');
- isa_ok($parser, 'Pod::Man', 'Parser object');
-
- # Save stderr to a temporary file and then run the parser, storing the
- # output into a Perl variable.
- my $errors = stderr_save();
- my $got;
- $parser->output_string(\$got);
- eval { $parser->parse_string_document($data_ref->{input}) };
- my $exception = $@;
- stderr_restore();
-
- # Strip off everything prior to .nh from the output so that we aren't
- # testing the generated header, and then check the output.
- $got =~ s{ \A .* \n [.]nh \n }{}xms;
- is($got, $data_ref->{output}, "Output for test $n");
+# List of snippets run by this test.
+my @snippets = qw(
+ bullet-after-nonbullet error-die error-none error-normal
+ error-pod error-stderr error-stderr-opt fixed-font long-quote
+ lquote-and-quote lquote-rquote nourls rquote-none
+);
- # Collect the errors and add any exception, marking it with EXCEPTION.
- # Then, compare that to the expected errors. The "1 while" construct is
- # for VMS, in case there are multiple versions of the file.
- my $got_errors = slurp($errors);
- 1 while unlink($errors);
- if ($exception) {
- $exception =~ s{ [ ] at [ ] .* }{}xms;
- $got_errors .= "EXCEPTION: $exception\n";
- }
- is($got_errors, $data_ref->{errors}, "Errors for test $n");
- $n++;
+# Run all the tests.
+for my $snippet (@snippets) {
+ test_snippet('Pod::Man', "man/$snippet");
}
-
-# Below the marker are bits of POD and corresponding expected text output and
-# error output. The options, input, output, and errors are separated by lines
-# containing only ###.
-
-__DATA__
-
-###
-fixed CR
-fixedbold CY
-fixeditalic CW
-fixedbolditalic CX
-###
-=head1 FIXED FONTS
-
-C<foo B<bar I<baz>> I<bay>>
-###
-.SH "FIXED FONTS"
-.IX Header "FIXED FONTS"
-\&\f(CR\*(C`foo \f(CYbar \f(CXbaz\f(CY\f(CR \f(CWbay\f(CR\*(C'\fR
-###
-###
-
-###
-###
-=over 4
-
-=item Foo
-
-Bar.
-
-=head1 NEXT
-###
-.IP "Foo" 4
-.IX Item "Foo"
-Bar.
-.SH "NEXT"
-.IX Header "NEXT"
-.SH "POD ERRORS"
-.IX Header "POD ERRORS"
-Hey! \fBThe above document had some coding errors, which are explained below:\fR
-.IP "Around line 7:" 4
-.IX Item "Around line 7:"
-You forgot a '=back' before '=head1'
-###
-###
-
-###
-stderr 1
-###
-=over 4
-
-=item Foo
-
-Bar.
-
-=head1 NEXT
-###
-.IP "Foo" 4
-.IX Item "Foo"
-Bar.
-.SH "NEXT"
-.IX Header "NEXT"
-###
-Pod input around line 7: You forgot a '=back' before '=head1'
-###
-
-###
-nourls 1
-###
-=head1 URL suppression
-
-L<anchor|http://www.example.com/>
-###
-.SH "URL suppression"
-.IX Header "URL suppression"
-anchor
-###
-###
-
-###
-errors stderr
-###
-=over 4
-
-=item Foo
-
-Bar.
-
-=head1 NEXT
-###
-.IP "Foo" 4
-.IX Item "Foo"
-Bar.
-.SH "NEXT"
-.IX Header "NEXT"
-###
-Pod input around line 7: You forgot a '=back' before '=head1'
-###
-
-###
-errors die
-###
-=over 4
-
-=item Foo
-
-Bar.
-
-=head1 NEXT
-###
-.IP "Foo" 4
-.IX Item "Foo"
-Bar.
-.SH "NEXT"
-.IX Header "NEXT"
-###
-Pod input around line 7: You forgot a '=back' before '=head1'
-EXCEPTION: POD document had syntax errors
-###
-
-###
-errors pod
-###
-=over 4
-
-=item Foo
-
-Bar.
-
-=head1 NEXT
-###
-.IP "Foo" 4
-.IX Item "Foo"
-Bar.
-.SH "NEXT"
-.IX Header "NEXT"
-.SH "POD ERRORS"
-.IX Header "POD ERRORS"
-Hey! \fBThe above document had some coding errors, which are explained below:\fR
-.IP "Around line 7:" 4
-.IX Item "Around line 7:"
-You forgot a '=back' before '=head1'
-###
-###
-
-###
-errors none
-###
-=over 4
-
-=item Foo
-
-Bar.
-
-=head1 NEXT
-###
-.IP "Foo" 4
-.IX Item "Foo"
-Bar.
-.SH "NEXT"
-.IX Header "NEXT"
-###
-###
-
-###
-errors none
-###
-=over 4
-
-=item foo
-
-Not a bullet.
-
-=item *
-
-Also not a bullet.
-
-=back
-###
-.IP "foo" 4
-.IX Item "foo"
-Not a bullet.
-.IP "*" 4
-Also not a bullet.
-###
-###
-
-###
-quotes \(lq"\(rq"
-###
-=head1 FOO C<BAR> BAZ
-
-Foo C<bar> baz.
-###
-.ie n .SH "FOO \(lq""BAR\(rq"" BAZ"
-.el .SH "FOO \f(CWBAR\fP BAZ"
-.IX Header "FOO BAR BAZ"
-Foo \f(CW\*(C`bar\*(C'\fR baz.
-###
-###
package Data::Dumper;
BEGIN {
- $VERSION = '2.161'; # Don't forget to set version and release
+ $VERSION = '2.162'; # Don't forget to set version and release
} # date in POD below!
#$| = 1;
=head1 VERSION
-Version 2.161 (July 11 2016)
+Version 2.162 (September 21 2016)
=head1 SEE ALSO
}
else {
STRLEN nchars;
- sv_setpvn(name, "$", 1);
+ sv_setpvs(name, "$");
sv_catsv(name, varname);
nchars = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"IVdf, (IV)(i+1));
sv_catpvn(name, tmpbuf, nchars);
sv_catpvs(retval, ";");
sv_catsv(retval, style.sep);
}
- sv_setpvn(valstr, "", 0);
+ SvPVCLEAR(valstr);
if (gimme == G_ARRAY) {
XPUSHs(sv_2mortal(retval));
if (i < imax) /* not the last time thro ? */
+5.20161020
+ - Updated for v5.25.6
+
5.20160920
- Updated for v5.25.5
print $msg,"\n";
if( defined $ret and exists $Opts{u} ) {
- my $upsream = $Module::CoreList::upstream{$mod};
- $upsream = 'undef' unless $upsream;
- print "upstream: $upsream\n";
- if ( $upsream ne 'blead' ) {
+ my $upstream = $Module::CoreList::upstream{$mod};
+ $upstream = 'undef' unless $upstream;
+ print "upstream: $upstream\n";
+ if ( $upstream ne 'blead' ) {
my $bugtracker = $Module::CoreList::bug_tracker{$mod};
$bugtracker = 'unknown' unless $bugtracker;
print "bug tracker: $bugtracker\n";
use vars qw/$VERSION %released %version %families %upstream
%bug_tracker %deprecated %delta/;
use version;
-$VERSION = '5.20160920';
+$VERSION = '5.20161020';
sub _undelta {
my ($delta) = @_;
5.025003 => '2016-07-20',
5.025004 => '2016-08-20',
5.025005 => '2016-09-20',
+ 5.025006 => '2016-10-20',
);
for my $version ( sort { $a <=> $b } keys %released ) {
removed => {
}
},
+ 5.025006 => {
+ delta_from => 5.025005,
+ changed => {
+ 'Archive::Tar' => '2.14',
+ 'Archive::Tar::Constant'=> '2.14',
+ 'Archive::Tar::File' => '2.14',
+ 'B' => '1.64',
+ 'B::Concise' => '0.999',
+ 'B::Deparse' => '1.39',
+ 'B::Op_private' => '5.025006',
+ 'Config' => '5.025006',
+ 'Data::Dumper' => '2.162',
+ 'Devel::Peek' => '1.25',
+ 'HTTP::Tiny' => '0.070',
+ 'List::Util' => '1.46',
+ 'List::Util::XS' => '1.46',
+ 'Module::CoreList' => '5.20161020',
+ 'Module::CoreList::TieHashDelta'=> '5.20161020',
+ 'Module::CoreList::Utils'=> '5.20161020',
+ 'Net::Ping' => '2.51',
+ 'OS2::DLL' => '1.07',
+ 'Opcode' => '1.38',
+ 'POSIX' => '1.73',
+ 'PerlIO::encoding' => '0.25',
+ 'Pod::Man' => '4.08',
+ 'Pod::ParseLink' => '4.08',
+ 'Pod::Text' => '4.08',
+ 'Pod::Text::Color' => '4.08',
+ 'Pod::Text::Overstrike' => '4.08',
+ 'Pod::Text::Termcap' => '4.08',
+ 'Scalar::Util' => '1.46',
+ 'Storable' => '2.58',
+ 'Sub::Util' => '1.46',
+ 'Test2' => '1.302059',
+ 'Test2::API' => '1.302059',
+ 'Test2::API::Breakage' => '1.302059',
+ 'Test2::API::Context' => '1.302059',
+ 'Test2::API::Instance' => '1.302059',
+ 'Test2::API::Stack' => '1.302059',
+ 'Test2::Event' => '1.302059',
+ 'Test2::Event::Bail' => '1.302059',
+ 'Test2::Event::Diag' => '1.302059',
+ 'Test2::Event::Exception'=> '1.302059',
+ 'Test2::Event::Generic' => '1.302059',
+ 'Test2::Event::Info' => '1.302059',
+ 'Test2::Event::Note' => '1.302059',
+ 'Test2::Event::Ok' => '1.302059',
+ 'Test2::Event::Plan' => '1.302059',
+ 'Test2::Event::Skip' => '1.302059',
+ 'Test2::Event::Subtest' => '1.302059',
+ 'Test2::Event::Waiting' => '1.302059',
+ 'Test2::Formatter' => '1.302059',
+ 'Test2::Formatter::TAP' => '1.302059',
+ 'Test2::Hub' => '1.302059',
+ 'Test2::Hub::Interceptor'=> '1.302059',
+ 'Test2::Hub::Interceptor::Terminator'=> '1.302059',
+ 'Test2::Hub::Subtest' => '1.302059',
+ 'Test2::IPC' => '1.302059',
+ 'Test2::IPC::Driver' => '1.302059',
+ 'Test2::IPC::Driver::Files'=> '1.302059',
+ 'Test2::Util' => '1.302059',
+ 'Test2::Util::ExternalMeta'=> '1.302059',
+ 'Test2::Util::HashBase' => '1.302059',
+ 'Test2::Util::Trace' => '1.302059',
+ 'Test::Builder' => '1.302059',
+ 'Test::Builder::Formatter'=> '1.302059',
+ 'Test::Builder::Module' => '1.302059',
+ 'Test::Builder::Tester' => '1.302059',
+ 'Test::Builder::Tester::Color'=> '1.302059',
+ 'Test::Builder::TodoDiag'=> '1.302059',
+ 'Test::More' => '1.302059',
+ 'Test::Simple' => '1.302059',
+ 'Test::Tester' => '1.302059',
+ 'Test::Tester::Capture' => '1.302059',
+ 'Test::Tester::CaptureRunner'=> '1.302059',
+ 'Test::Tester::Delegate'=> '1.302059',
+ 'Test::use::ok' => '1.302059',
+ 'Time::HiRes' => '1.9740_01',
+ 'VMS::Stdio' => '2.42',
+ 'XS::APItest' => '0.86',
+ 'attributes' => '0.28',
+ 'mro' => '1.19',
+ 'ok' => '1.302059',
+ 'overload' => '1.27',
+ 'parent' => '0.236',
+ },
+ removed => {
+ }
+ },
);
sub is_core
removed => {
}
},
+ 5.025006 => {
+ delta_from => 5.025005,
+ changed => {
+ },
+ removed => {
+ }
+ },
);
%deprecated = _undelta(\%deprecated);
use strict;
use vars qw($VERSION);
-$VERSION = '5.20160920';
+$VERSION = '5.20161020';
sub TIEHASH {
my ($class, $changed, $removed, $parent) = @_;
use vars qw[$VERSION %utilities];
use Module::CoreList;
-$VERSION = '5.20160920';
+$VERSION = '5.20161020';
sub utilities {
my $perl = shift;
removed => {
}
},
+ 5.025006 => {
+ delta_from => 5.025005,
+ changed => {
+ },
+ removed => {
+ }
+ },
);
%utilities = Module::CoreList::_undelta(\%delta);
CHANGES
-------
+2.51 Mon Oct 17 16:11:03 2016 +0200 (rurban)
+ version in cperl since 5.25.2c
+
+ Bugfixes
+ - Fixed missing _unpack_sockaddr_in family, which took AF_INET6 for
+ a AF_INET addr in t/500_ping_icmp.t and t/500_ping_icmp_ttl.t.
+ Use now a proper default.
+
+2.50 Sat Apr 16 11:50:20 2016 +0200 (rurban)
+ version in cperl since 5.22.2c
+
+ Features
+ - Handle IPv6 addresses and the AF_INET6 family.
+ - Added the optional family argument to most methods.
+ valid values: 6, "v6", "ip6", "ipv6", AF_INET6
+ - new can take now named arguments, a hashref.
+ - Added the following named arguments to new:
+ gateway host port bind retrans pingstring source_verify econnrefused
+ IPV6_USE_MIN_MTU IPV6_RECVPATHMTU IPV6_HOPLIMIT
+ - Added a dontfrag option, setting IP_DONTFRAG and on linux
+ also IP_MTU_DISCOVER to IP_PMTUDISC_DO. Note that is ignored if
+ Socket does not export IP_DONTFRAG.
+ - Added the wakeonlan method
+ - Improve argument default handling
+ - Added missing documentation
+
+ Bugfixes
+ - Reapply tos with ping_udp, when the address is changed.
+ RT #6706 (Torgny.Hofstedt@sevenlevels.se)
+ ditto re-bind to a device.
+
+ Internals
+ - $ip is now a hash with {addr, addr_in, family} not the addr_in packed IP.
+ - added _resolv replacing inet_aton,
+ _pack_sockaddr_in and _unpack_sockaddr_in replacing sockaddr_in,
+ _inet_ntoa replacing inet_ntoa
+ - Use _isroot helper, with Win32 _IsAdminUser helper.
+ - added several new tests (Steve Peters)
+
+2.43 Mon Apr 29 00:23:56 2013 -0300
+ version in perl core since 5.19.9
+ Bugfixes
+ - Handle getprotobyn{ame,umber} not being available
+2.42 Sun May 26 19:08:46 2013 -0700
+ version in perl core since 5.19.1
+ Bugfixes
+ - Stabilize tests
+ Internals
+ - wrap long pod lines
2.41 Mar 17 09:35 2013
Bugfixes
- Windows Vista does not appear to support inet_ntop(). It seems to
and passing in the NI_NUMERICHOST to get an IP address.
Features
- Change Net::Ping to use Time::HiRes::time() instead of CORE::time()
- by default. For most successful cases, CORE::time() returned zero.
+ by default. For most successful cases, CORE::time() returned zero.
2.40 Mar 15 11:20 2013
Bugfixes
- - several fixes to tests to stop the black smoke on Win32's
+ - several fixes to tests to stop the black smoke on Win32's
and Cygwin since the core updated the module to Test::More.
I had planned a later release, but all the black smoke is
forcing a release.
- - fixes to some skips in tests that were still using the
+ - fixes to some skips in tests that were still using the
Test style skip's.
- Documentation fix for https://rt.cpan.org/Ticket/Display.html?id=48014.
Thanks to Keith Taylor <keith@supanet.net.uk>
- - Instead of using a hard-coded TOS value, import IP_TOS from
- Socket. This fixes an outstanding bug on Solaris which uses a
+ - Instead of using a hard-coded TOS value, import IP_TOS from
+ Socket. This fixes an outstanding bug on Solaris which uses a
different value for IP_TOS in it headers than Linux. I'm assuming
other OS's were fixed with this change as well.
Features
- - added TTL handling for icmp pings to allow traceroute like
- applications to be built with Net::Ping. Thanks to
+ - added TTL handling for icmp pings to allow traceroute like
+ applications to be built with Net::Ping. Thanks to
<rolek@bokxing.nl> for the patch and tests!
Internals
- - replaced SOL_IP with IPPROTO_IP. SOL_IP is not portable and was
+ - replaced SOL_IP with IPPROTO_IP. SOL_IP is not portable and was
hard-coded anyway.
- - added IPPROTO_IP, IP_TOS, IP_TTL, and AF_INET to the list of Socket
+ - added IPPROTO_IP, IP_TOS, IP_TTL, and AF_INET to the list of Socket
constants imported.
- removed some hard-coded constants.
- converted all calls to inet_ntoa() to inet_ntop() in preparation
- release to include a few fixes from the Perl core
2.35 Feb 08 14:42 2008
- - Patch in Perl change #33242 by Nicholas Clark
+ - Patch in Perl change #33242 by Nicholas Clark
<http://perl5.git.perl.org/perl.git/commit/5d6b07c5a4c042580b85248d570ee299fd102a79>
2.34 Dec 19 08:51 2007
require Exporter;
use strict;
-use vars qw(@ISA @EXPORT $VERSION
- $def_timeout $def_proto $def_factor
+use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION
+ $def_timeout $def_proto $def_factor $def_family
$max_datasize $pingstring $hires $source_verify $syn_forking);
use Fcntl qw( F_GETFL F_SETFL O_NONBLOCK );
-use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET SOL_SOCKET SO_ERROR IPPROTO_IP IP_TOS IP_TTL
- inet_aton getnameinfo NI_NUMERICHOST sockaddr_in );
-use POSIX qw( ENOTCONN ECONNREFUSED ECONNRESET EINPROGRESS EWOULDBLOCK EAGAIN WNOHANG );
+use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW AF_INET PF_INET IPPROTO_TCP
+ SOL_SOCKET SO_ERROR SO_BROADCAST
+ IPPROTO_IP IP_TOS IP_TTL
+ inet_ntoa inet_aton getnameinfo NI_NUMERICHOST sockaddr_in );
+use POSIX qw( ENOTCONN ECONNREFUSED ECONNRESET EINPROGRESS EWOULDBLOCK EAGAIN
+ WNOHANG );
use FileHandle;
use Carp;
use Time::HiRes;
@ISA = qw(Exporter);
@EXPORT = qw(pingecho);
-$VERSION = "2.44";
+@EXPORT_OK = qw(wakeonlan);
+$VERSION = "2.51";
-# Constants
+# Globals
$def_timeout = 5; # Default timeout to wait for a reply
$def_proto = "tcp"; # Default protocol to use for pinging
$def_factor = 1.2; # Default exponential backoff rate.
+$def_family = AF_INET; # Default family.
$max_datasize = 1024; # Maximum data bytes in a packet
# The data we exchange with the server for the stream protocol
$pingstring = "pingschwingping!\n";
$source_verify = 1; # Default is to verify source endpoint
$syn_forking = 0;
+# Constants
+
+my $AF_INET6 = eval { Socket::AF_INET6() };
+my $AF_UNSPEC = eval { Socket::AF_UNSPEC() };
+my $AI_NUMERICHOST = eval { Socket::AI_NUMERICHOST() };
+my $NI_NUMERICHOST = eval { Socket::NI_NUMERICHOST() };
+my $IPPROTO_IPV6 = eval { Socket::IPPROTO_IPV6() };
+#my $IPV6_HOPLIMIT = eval { Socket::IPV6_HOPLIMIT() }; # ping6 -h 0-255
+my $qr_family = qr/^(?:(?:(:?ip)?v?(?:4|6))|${\AF_INET}|$AF_INET6)$/;
+my $qr_family4 = qr/^(?:(?:(:?ip)?v?4)|${\AF_INET})$/;
+
if ($^O =~ /Win32/i) {
# Hack to avoid this Win32 spewage:
# Your vendor has not defined POSIX macro ECONNREFUSED
# $syn_forking = 1; # XXX possibly useful in < Win2K ?
};
-# h2ph "asm/socket.h"
-# require "asm/socket.ph";
-sub SO_BINDTODEVICE {25;}
-
# Description: The pingecho() subroutine is provided for backward
# compatibility with the original Net::Ping. It accepts a host
# name/IP and an optional timeout in seconds. Create a tcp ping
$device, # Optional device to use
$tos, # Optional ToS to set
$ttl, # Optional TTL to set
+ $family, # Optional address family (AF_INET)
) = @_;
my $class = ref($this) || $this;
my $self = {};
);
bless($self, $class);
+ if (ref $proto eq 'HASH') { # support named args
+ for my $k (qw(proto timeout data_size device tos ttl family
+ gateway host port bind retrans pingstring source_verify
+ econnrefused dontfrag
+ IPV6_USE_MIN_MTU IPV6_RECVPATHMTU IPV6_HOPLIMIT))
+ {
+ if (exists $proto->{$k}) {
+ $self->{$k} = $proto->{$k};
+ # some are still globals
+ if ($k eq 'pingstring') { $pingstring = $proto->{$k} }
+ if ($k eq 'source_verify') { $source_verify = $proto->{$k} }
+ delete $proto->{$k};
+ }
+ }
+ if (%$proto) {
+ croak("Invalid named argument: ",join(" ",keys (%$proto)));
+ }
+ $proto = $self->{'proto'};
+ }
$proto = $def_proto unless $proto; # Determine the protocol
- croak('Protocol for ping must be "icmp", "udp", "tcp", "syn", "stream", or "external"')
- unless $proto =~ m/^(icmp|udp|tcp|syn|stream|external)$/;
+ croak('Protocol for ping must be "icmp", "icmpv6", "udp", "tcp", "syn", "stream" or "external"')
+ unless $proto =~ m/^(icmp|icmpv6|udp|tcp|syn|stream|external)$/;
$self->{"proto"} = $proto;
$timeout = $def_timeout unless $timeout; # Determine the timeout
$self->{"tos"} = $tos;
- if ($self->{"proto"} eq 'icmp') {
+ if ($self->{'host'}) {
+ my $host = $self->{'host'};
+ my $ip = _resolv($host)
+ or croak("could not resolve host $host");
+ $self->{host} = $ip;
+ $self->{family} = $ip->{family};
+ }
+
+ if ($self->{bind}) {
+ my $addr = $self->{bind};
+ my $ip = _resolv($addr)
+ or croak("could not resolve local addr $addr");
+ $self->{local_addr} = $ip;
+ } else {
+ $self->{local_addr} = undef; # Don't bind by default
+ }
+
+ if ($self->{proto} eq 'icmp') {
croak('TTL must be from 0 to 255')
if ($ttl && ($ttl < 0 || $ttl > 255));
- $self->{"ttl"} = $ttl;
+ $self->{ttl} = $ttl;
+ }
+
+ if ($family) {
+ if ($family =~ $qr_family) {
+ if ($family =~ $qr_family4) {
+ $self->{"family"} = AF_INET;
+ } else {
+ $self->{"family"} = $AF_INET6;
+ }
+ } else {
+ croak('Family must be "ipv4" or "ipv6"')
+ }
+ } else {
+ $self->{"family"} = $def_family;
}
$min_datasize = ($proto eq "udp") ? 1 : 0; # Determine data size
$self->{"data"} .= chr($cnt % 256);
}
- $self->{"local_addr"} = undef; # Don't bind by default
- $self->{"retrans"} = $def_factor; # Default exponential backoff rate
- $self->{"econnrefused"} = undef; # Default Connection refused behavior
+ # Default exponential backoff rate
+ $self->{"retrans"} = $def_factor unless exists $self->{"retrans"};
+ # Default Connection refused behavior
+ $self->{"econnrefused"} = undef unless exists $self->{"econnrefused"};
$self->{"seq"} = 0; # For counting packets
if ($self->{"proto"} eq "udp") # Open a socket
{
$self->{"proto_num"} = eval { (getprotobyname('udp'))[2] } ||
croak("Can't udp protocol by name");
- $self->{"port_num"} = (getservbyname('echo', 'udp'))[2] ||
- croak("Can't get udp echo port by name");
+ $self->{"port_num"} = $self->{"port"}
+ || (getservbyname('echo', 'udp'))[2]
+ || croak("Can't get udp echo port by name");
$self->{"fh"} = FileHandle->new();
socket($self->{"fh"}, PF_INET, SOCK_DGRAM,
$self->{"proto_num"}) ||
croak("udp socket error - $!");
- if ($self->{'device'}) {
- setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
- or croak "error binding to device $self->{'device'} $!";
- }
- if ($self->{'tos'}) {
- setsockopt($self->{"fh"}, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'}))
- or croak "error configuring tos to $self->{'tos'} $!";
- }
+ $self->_setopts();
}
elsif ($self->{"proto"} eq "icmp")
{
- croak("icmp ping requires root privilege") if ($> and $^O ne 'VMS' and $^O ne 'cygwin');
+ croak("icmp ping requires root privilege") if !_isroot();
$self->{"proto_num"} = eval { (getprotobyname('icmp'))[2] } ||
croak("Can't get icmp protocol by name");
$self->{"pid"} = $$ & 0xffff; # Save lower 16 bits of pid
$self->{"fh"} = FileHandle->new();
socket($self->{"fh"}, PF_INET, SOCK_RAW, $self->{"proto_num"}) ||
croak("icmp socket error - $!");
- if ($self->{'device'}) {
- setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
- or croak "error binding to device $self->{'device'} $!";
+ $self->_setopts();
+ if ($self->{'ttl'}) {
+ setsockopt($self->{"fh"}, IPPROTO_IP, IP_TTL, pack("I*", $self->{'ttl'}))
+ or croak "error configuring ttl to $self->{'ttl'} $!";
+ }
+ }
+ elsif ($self->{"proto"} eq "icmpv6")
+ {
+ croak("icmpv6 ping requires root privilege") if !_isroot();
+ croak("Wrong family $self->{family} for icmpv6 protocol")
+ if $self->{"family"} and $self->{"family"} != $AF_INET6;
+ $self->{"family"} = $AF_INET6;
+ $self->{"proto_num"} = eval { (getprotobyname('ipv6-icmp'))[2] } ||
+ croak("Can't get ipv6-icmp protocol by name"); # 58
+ $self->{"pid"} = $$ & 0xffff; # Save lower 16 bits of pid
+ $self->{"fh"} = FileHandle->new();
+ socket($self->{"fh"}, $AF_INET6, SOCK_RAW, $self->{"proto_num"}) ||
+ croak("icmp socket error - $!");
+ $self->_setopts();
+ if ($self->{'gateway'}) {
+ my $g = $self->{gateway};
+ my $ip = _resolv($g)
+ or croak("nonexistent gateway $g");
+ $self->{family} eq $AF_INET6
+ or croak("gateway requires the AF_INET6 family");
+ $ip->{family} eq $AF_INET6
+ or croak("gateway address needs to be IPv6");
+ my $IPV6_NEXTHOP = eval { Socket::IPV6_NEXTHOP() } || 48; # IPV6_3542NEXTHOP, or 21
+ setsockopt($self->{"fh"}, $IPPROTO_IPV6, $IPV6_NEXTHOP, _pack_sockaddr_in($ip))
+ or croak "error configuring gateway to $g NEXTHOP $!";
+ }
+ if (exists $self->{IPV6_USE_MIN_MTU}) {
+ my $IPV6_USE_MIN_MTU = eval { Socket::IPV6_USE_MIN_MTU() } || 42;
+ setsockopt($self->{"fh"}, $IPPROTO_IPV6, $IPV6_USE_MIN_MTU,
+ pack("I*", $self->{'IPV6_USE_MIN_MT'}))
+ or croak "error configuring IPV6_USE_MIN_MT} $!";
+ }
+ if (exists $self->{IPV6_RECVPATHMTU}) {
+ my $IPV6_RECVPATHMTU = eval { Socket::IPV6_RECVPATHMTU() } || 43;
+ setsockopt($self->{"fh"}, $IPPROTO_IPV6, $IPV6_RECVPATHMTU,
+ pack("I*", $self->{'RECVPATHMTU'}))
+ or croak "error configuring IPV6_RECVPATHMTU $!";
}
if ($self->{'tos'}) {
- setsockopt($self->{"fh"}, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'}))
+ my $proto = $self->{family} == AF_INET ? IPPROTO_IP : $IPPROTO_IPV6;
+ setsockopt($self->{"fh"}, $proto, IP_TOS, pack("I*", $self->{'tos'}))
or croak "error configuring tos to $self->{'tos'} $!";
}
if ($self->{'ttl'}) {
- setsockopt($self->{"fh"}, IPPROTO_IP, IP_TTL, pack("I*", $self->{'ttl'}))
+ my $proto = $self->{family} == AF_INET ? IPPROTO_IP : $IPPROTO_IPV6;
+ setsockopt($self->{"fh"}, $proto, IP_TTL, pack("I*", $self->{'ttl'}))
or croak "error configuring ttl to $self->{'ttl'} $!";
}
}
{
$self->{"proto_num"} = eval { (getprotobyname('tcp'))[2] } ||
croak("Can't get tcp protocol by name");
- $self->{"port_num"} = (getservbyname('echo', 'tcp'))[2] ||
- croak("Can't get tcp echo port by name");
+ $self->{"port_num"} = $self->{"port"}
+ || (getservbyname('echo', 'tcp'))[2]
+ || croak("Can't get tcp echo port by name");
$self->{"fh"} = FileHandle->new();
}
elsif ($self->{"proto"} eq "syn")
$self->{"syn"} = {};
$self->{"stop_time"} = 0;
}
- elsif ($self->{"proto"} eq "external")
- {
- # No preliminary work needs to be done.
- }
return($self);
}
# Description: Set the local IP address from which pings will be sent.
-# For ICMP and UDP pings, this calls bind() on the already-opened socket;
-# for TCP pings, just saves the address to be used when the socket is
-# opened. Returns non-zero if successful; croaks on error.
+# For ICMP, UDP and TCP pings, just saves the address to be used when
+# the socket is opened. Returns non-zero if successful; croaks on error.
sub bind
{
my ($self,
$local_addr # Name or IP number of local interface
) = @_;
- my ($ip # Packed IP number of $local_addr
+ my ($ip, # Hash of addr (string), addr_in (packed), family
+ $h # resolved hash
);
croak("Usage: \$p->bind(\$local_addr)") unless @_ == 2;
croak("already bound") if defined($self->{"local_addr"}) &&
($self->{"proto"} eq "udp" || $self->{"proto"} eq "icmp");
- $ip = inet_aton($local_addr);
+ $ip = $self->_resolv($local_addr);
croak("nonexistent local address $local_addr") unless defined($ip);
- $self->{"local_addr"} = $ip; # Only used if proto is tcp
+ $self->{"local_addr"} = $ip;
- if ($self->{"proto"} eq "udp" || $self->{"proto"} eq "icmp")
- {
- CORE::bind($self->{"fh"}, sockaddr_in(0, $ip)) ||
- croak("$self->{'proto'} bind error - $!");
- }
- elsif (($self->{"proto"} ne "tcp") && ($self->{"proto"} ne "syn"))
+ if (($self->{"proto"} ne "udp") &&
+ ($self->{"proto"} ne "icmp") &&
+ ($self->{"proto"} ne "tcp") &&
+ ($self->{"proto"} ne "syn"))
{
croak("Unknown protocol \"$self->{proto}\" in bind()");
}
$self->{"retrans"} = shift;
}
+sub _IsAdminUser {
+ return unless $^O eq 'MSWin32' or $^O eq "cygwin";
+ return unless eval { require Win32 };
+ return unless defined &Win32::IsAdminUser;
+ return Win32::IsAdminUser();
+}
+
+sub _isroot {
+ if (($> and $^O ne 'VMS' and $^O ne 'cygwin')
+ or (($^O eq 'MSWin32' or $^O eq 'cygwin')
+ and !_IsAdminUser())
+ or ($^O eq 'VMS'
+ and (`write sys\$output f\$privilege("SYSPRV")` =~ m/FALSE/))) {
+ return 0;
+ }
+ else {
+ return 1;
+ }
+}
+
+# Description: Sets ipv6 reachability
+# REACHCONF was removed in RFC3542, ping6 -R supports it. requires root.
+
+sub IPV6_REACHCONF
+{
+ my $self = shift;
+ my $on = shift;
+ if ($on) {
+ my $reachconf = eval { Socket::IPV6_REACHCONF() };
+ if (!$reachconf) {
+ carp "IPV6_REACHCONF not supported on this platform";
+ return 0;
+ }
+ if (!_isroot()) {
+ carp "IPV6_REACHCONF requires root permissions";
+ return 0;
+ }
+ $self->{"IPV6_REACHCONF"} = 1;
+ }
+ else {
+ return $self->{"IPV6_REACHCONF"};
+ }
+}
+
+# Description: set it on or off.
+
+sub IPV6_USE_MIN_MTU
+{
+ my $self = shift;
+ my $on = shift;
+ if (defined $on) {
+ my $IPV6_USE_MIN_MTU = eval { Socket::IPV6_USE_MIN_MTU() } || 43;
+ #if (!$IPV6_USE_MIN_MTU) {
+ # carp "IPV6_USE_MIN_MTU not supported on this platform";
+ # return 0;
+ #}
+ $self->{"IPV6_USE_MIN_MTU"} = $on ? 1 : 0;
+ setsockopt($self->{"fh"}, $IPPROTO_IPV6, $IPV6_USE_MIN_MTU,
+ pack("I*", $self->{'IPV6_USE_MIN_MT'}))
+ or croak "error configuring IPV6_USE_MIN_MT} $!";
+ }
+ else {
+ return $self->{"IPV6_USE_MIN_MTU"};
+ }
+}
+
+# Description: notify an according MTU
+
+sub IPV6_RECVPATHMTU
+{
+ my $self = shift;
+ my $on = shift;
+ if ($on) {
+ my $IPV6_RECVPATHMTU = eval { Socket::IPV6_RECVPATHMTU() } || 43;
+ #if (!$RECVPATHMTU) {
+ # carp "IPV6_RECVPATHMTU not supported on this platform";
+ # return 0;
+ #}
+ $self->{"IPV6_RECVPATHMTU"} = 1;
+ setsockopt($self->{"fh"}, $IPPROTO_IPV6, $IPV6_RECVPATHMTU,
+ pack("I*", $self->{'IPV6_RECVPATHMTU'}))
+ or croak "error configuring IPV6_RECVPATHMTU} $!";
+ }
+ else {
+ return $self->{"IPV6_RECVPATHMTU"};
+ }
+}
+
# Description: allows the module to use milliseconds as returned by
# the Time::HiRes module
my ($self,
$host, # Name or IP number of host to ping
$timeout, # Seconds after which ping times out
+ $family, # Address family
) = @_;
- my ($ip, # Packed IP number of $host
+ my ($ip, # Hash of addr (string), addr_in (packed), family
$ret, # The return value
$ping_time, # When ping began
);
- croak("Usage: \$p->ping(\$host [, \$timeout])") unless @_ == 2 || @_ == 3;
+ $host = $self->{host} if !defined $host and $self->{host};
+ croak("Usage: \$p->ping([ \$host [, \$timeout [, \$family]]])") if @_ > 4 or !$host;
$timeout = $self->{"timeout"} unless $timeout;
croak("Timeout must be greater than 0 seconds") if $timeout <= 0;
- $ip = inet_aton($host);
+ if ($family) {
+ if ($family =~ $qr_family) {
+ if ($family =~ $qr_family4) {
+ $self->{"family_local"} = AF_INET;
+ } else {
+ $self->{"family_local"} = $AF_INET6;
+ }
+ } else {
+ croak('Family must be "ipv4" or "ipv6"')
+ }
+ } else {
+ $self->{"family_local"} = $self->{"family"};
+ }
+
+ $ip = $self->_resolv($host);
return () unless defined($ip); # Does host exist?
# Dispatch to the appropriate routine.
elsif ($self->{"proto"} eq "icmp") {
$ret = $self->ping_icmp($ip, $timeout);
}
+ elsif ($self->{"proto"} eq "icmpv6") {
+ $ret = $self->ping_icmpv6($ip, $timeout);
+ }
elsif ($self->{"proto"} eq "tcp") {
$ret = $self->ping_tcp($ip, $timeout);
}
# Uses Net::Ping::External to do an external ping.
sub ping_external {
my ($self,
- $ip, # Packed IP number of the host
- $timeout # Seconds after which ping times out
+ $ip, # Hash of addr (string), addr_in (packed), family
+ $timeout, # Seconds after which ping times out
+ $family
) = @_;
- eval {
- local @INC = @INC;
- pop @INC if $INC[-1] eq '.';
- require Net::Ping::External;
- }
+ $ip = $self->{host} if !defined $ip and $self->{host};
+ $timeout = $self->{timeout} if !defined $timeout and $self->{timeout};
+
+ eval { require Net::Ping::External; }
or croak('Protocol "external" not supported on your system: Net::Ping::External not found');
- return Net::Ping::External::ping(ip => $ip, timeout => $timeout);
+ return Net::Ping::External::ping(ip => $ip->{host}, timeout => $timeout,
+ family => $family);
}
+# h2ph "asm/socket.h"
+# require "asm/socket.ph";
+use constant SO_BINDTODEVICE => 25;
use constant ICMP_ECHOREPLY => 0; # ICMP packet types
+use constant ICMPv6_ECHOREPLY => 129; # ICMP packet types
use constant ICMP_UNREACHABLE => 3; # ICMP packet types
+use constant ICMPv6_UNREACHABLE => 1; # ICMP packet types
use constant ICMP_ECHO => 8;
+use constant ICMPv6_ECHO => 128;
use constant ICMP_TIME_EXCEEDED => 11; # ICMP packet types
use constant ICMP_PARAMETER_PROBLEM => 12; # ICMP packet types
use constant ICMP_STRUCT => "C2 n3 A"; # Structure of a minimal ICMP packet
use constant SUBCODE => 0; # No ICMP subcode for ECHO and ECHOREPLY
use constant ICMP_FLAGS => 0; # No special flags for send or recv
use constant ICMP_PORT => 0; # No port with ICMP
+use constant IP_MTU_DISCOVER => 10; # linux only
sub ping_icmp
{
my ($self,
- $ip, # Packed IP number of the host
+ $ip, # Hash of addr (string), addr_in (packed), family
$timeout # Seconds after which ping times out
) = @_;
$from_msg # ICMP message
);
+ $ip = $self->{host} if !defined $ip and $self->{host};
+ $timeout = $self->{timeout} if !defined $timeout and $self->{timeout};
+
+ socket($self->{"fh"}, $ip->{"family"}, SOCK_RAW, $self->{"proto_num"}) ||
+ croak("icmp socket error - $!");
+
+ if (defined $self->{"local_addr"} &&
+ !CORE::bind($self->{"fh"}, _pack_sockaddr_in(0, $self->{"local_addr"}))) {
+ croak("icmp bind error - $!");
+ }
+ $self->_setopts();
+
$self->{"seq"} = ($self->{"seq"} + 1) % 65536; # Increment sequence
$checksum = 0; # No checksum for starters
- $msg = pack(ICMP_STRUCT . $self->{"data_size"}, ICMP_ECHO, SUBCODE,
- $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"});
+ if ($ip->{"family"} == AF_INET) {
+ $msg = pack(ICMP_STRUCT . $self->{"data_size"}, ICMP_ECHO, SUBCODE,
+ $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"});
+ } else {
+ # how to get SRC
+ my $pseudo_header = pack('a16a16Nnn', $ip->{"addr_in"}, $ip->{"addr_in"}, 8+length($self->{"data"}), "\0", 0x003a);
+ $msg = pack(ICMP_STRUCT . $self->{"data_size"}, ICMPv6_ECHO, SUBCODE,
+ $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"});
+ $msg = $pseudo_header.$msg
+ }
$checksum = Net::Ping->checksum($msg);
- $msg = pack(ICMP_STRUCT . $self->{"data_size"}, ICMP_ECHO, SUBCODE,
- $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"});
+ if ($ip->{"family"} == AF_INET) {
+ $msg = pack(ICMP_STRUCT . $self->{"data_size"}, ICMP_ECHO, SUBCODE,
+ $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"});
+ } else {
+ $msg = pack(ICMP_STRUCT . $self->{"data_size"}, ICMPv6_ECHO, SUBCODE,
+ $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"});
+ }
$len_msg = length($msg);
- $saddr = sockaddr_in(ICMP_PORT, $ip);
+ $saddr = _pack_sockaddr_in(ICMP_PORT, $ip);
$self->{"from_ip"} = undef;
$self->{"from_type"} = undef;
$self->{"from_subcode"} = undef;
$from_pid = -1;
$from_seq = -1;
$from_saddr = recv($self->{"fh"}, $recv_msg, 1500, ICMP_FLAGS);
- ($from_port, $from_ip) = sockaddr_in($from_saddr);
+ ($from_port, $from_ip) = _unpack_sockaddr_in($from_saddr, $ip->{"family"});
($from_type, $from_subcode) = unpack("C2", substr($recv_msg, 20, 2));
if ($from_type == ICMP_ECHOREPLY) {
($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 24, 4))
if length $recv_msg >= 28;
+ } elsif ($from_type == ICMPv6_ECHOREPLY) {
+ ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 24, 4))
+ if length $recv_msg >= 28;
} else {
($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 52, 4))
if length $recv_msg >= 56;
next if ($from_pid != $self->{"pid"});
next if ($from_seq != $self->{"seq"});
if (! $source_verify || ($self->ntop($from_ip) eq $self->ntop($ip))) { # Does the packet check out?
- if ($from_type == ICMP_ECHOREPLY) {
+ if (($from_type == ICMP_ECHOREPLY) || ($from_type == ICMPv6_ECHOREPLY)) {
$ret = 1;
- $done = 1;
- } elsif ($from_type == ICMP_UNREACHABLE) {
+ $done = 1;
+ } elsif (($from_type == ICMP_UNREACHABLE) || ($from_type == ICMPv6_UNREACHABLE)) {
$done = 1;
} elsif ($from_type == ICMP_TIME_EXCEEDED) {
$ret = 0;
return $ret;
}
+sub ping_icmpv6
+{
+ shift->ping_icmp(@_);
+}
+
sub icmp_result {
my ($self) = @_;
- my $ip = $self->{"from_ip"} || "";
- $ip = "\0\0\0\0" unless 4 == length $ip;
- return ($self->ntop($ip),($self->{"from_type"} || 0), ($self->{"from_subcode"} || 0));
+ my $addr = $self->{"from_ip"} || "";
+ $addr = "\0\0\0\0" unless 4 == length $addr;
+ return ($self->ntop($addr),($self->{"from_type"} || 0), ($self->{"from_subcode"} || 0));
}
# Description: Do a checksum on the message. Basically sum all of
sub ping_tcp
{
my ($self,
- $ip, # Packed IP number of the host
+ $ip, # Hash of addr (string), addr_in (packed), family
$timeout # Seconds after which ping times out
) = @_;
my ($ret # The return value
);
+ $ip = $self->{host} if !defined $ip and $self->{host};
+ $timeout = $self->{timeout} if !defined $timeout and $self->{timeout};
+
$! = 0;
$ret = $self -> tcp_connect( $ip, $timeout);
if (!$self->{"econnrefused"} &&
sub tcp_connect
{
my ($self,
- $ip, # Packed IP number of the host
+ $ip, # Hash of addr (string), addr_in (packed), family
$timeout # Seconds after which connect times out
) = @_;
my ($saddr); # Packed IP and Port
- $saddr = sockaddr_in($self->{"port_num"}, $ip);
+ $ip = $self->{host} if !defined $ip and $self->{host};
+ $timeout = $self->{timeout} if !defined $timeout and $self->{timeout};
+
+ $saddr = _pack_sockaddr_in($self->{"port_num"}, $ip);
my $ret = 0; # Default to unreachable
my $do_socket = sub {
- socket($self->{"fh"}, PF_INET, SOCK_STREAM, $self->{"proto_num"}) ||
+ socket($self->{"fh"}, $ip->{"family"}, SOCK_STREAM, $self->{"proto_num"}) ||
croak("tcp socket error - $!");
if (defined $self->{"local_addr"} &&
- !CORE::bind($self->{"fh"}, sockaddr_in(0, $self->{"local_addr"}))) {
+ !CORE::bind($self->{"fh"}, _pack_sockaddr_in(0, $self->{"local_addr"}))) {
croak("tcp bind error - $!");
}
- if ($self->{'device'}) {
- setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
- or croak("error binding to device $self->{'device'} $!");
- }
- if ($self->{'tos'}) {
- setsockopt($self->{"fh"}, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'}))
- or croak "error configuring tos to $self->{'tos'} $!";
- }
+ $self->_setopts();
};
my $do_connect = sub {
- $self->{"ip"} = $ip;
+ $self->{"ip"} = $ip->{"addr_in"};
# ECONNREFUSED is 10061 on MSWin32. If we pass it as child error through $?,
# we'll get (10061 & 255) = 77, so we cannot check it in the parent process.
return ($ret = connect($self->{"fh"}, $saddr) || ($! == ECONNREFUSED && !$self->{"econnrefused"}));
# Unset O_NONBLOCK property on filehandle
$self->socket_blocking_mode($self->{"fh"}, 1);
- $self->{"ip"} = $ip;
+ $self->{"ip"} = $ip->{"addr_in"};
return $ret;
};
# back. It returns 1 on success, 0 on failure.
sub tcp_echo
{
- my $self = shift;
- my $timeout = shift;
- my $pingstring = shift;
+ my ($self, $timeout, $pingstring) = @_;
+
+ $timeout = $self->{timeout} if !defined $timeout and $self->{timeout};
+ $pingstring = $self->{pingstring} if !defined $pingstring and $self->{pingstring};
my $ret = undef;
my $time = &time();
return $ret;
}
-
-
-
# Description: Perform a stream ping. If the tcp connection isn't
# already open, it opens it. It then sends some data and waits for
# a reply. It leaves the stream open on exit.
sub ping_stream
{
my ($self,
- $ip, # Packed IP number of the host
+ $ip, # Hash of addr (string), addr_in (packed), family
$timeout # Seconds after which ping times out
) = @_;
}
croak "tried to switch servers while stream pinging"
- if $self->{"ip"} ne $ip;
+ if $self->{"ip"} ne $ip->{"addr_in"};
return $self->tcp_echo($timeout, $pingstring);
}
{
my ($self,
$host, # Host or IP address
- $timeout # Seconds after which open times out
+ $timeout, # Seconds after which open times out
+ $family
) = @_;
+ my $ip; # Hash of addr (string), addr_in (packed), family
+ $host = $self->{host} unless defined $host;
+
+ if ($family) {
+ if ($family =~ $qr_family) {
+ if ($family =~ $qr_family4) {
+ $self->{"family_local"} = AF_INET;
+ } else {
+ $self->{"family_local"} = $AF_INET6;
+ }
+ } else {
+ croak('Family must be "ipv4" or "ipv6"')
+ }
+ } else {
+ $self->{"family_local"} = $self->{"family"};
+ }
- my ($ip); # Packed IP number of the host
- $ip = inet_aton($host);
+ $ip = $self->_resolv($host);
$timeout = $self->{"timeout"} unless $timeout;
if($self->{"proto"} eq "stream") {
}
}
+sub _dontfrag {
+ my $self = shift;
+ # bsd solaris
+ my $IP_DONTFRAG = eval { Socket::IP_DONTFRAG() };
+ if ($IP_DONTFRAG) {
+ my $i = 1;
+ setsockopt($self->{"fh"}, IPPROTO_IP, $IP_DONTFRAG, pack("I*", $i))
+ or croak "error configuring IP_DONTFRAG $!";
+ # Linux needs more: Path MTU Discovery as defined in RFC 1191
+ # For non SOCK_STREAM sockets it is the user's responsibility to packetize
+ # the data in MTU sized chunks and to do the retransmits if necessary.
+ # The kernel will reject packets that are bigger than the known path
+ # MTU if this flag is set (with EMSGSIZE).
+ if ($^O eq 'linux') {
+ my $i = 2; # IP_PMTUDISC_DO
+ setsockopt($self->{"fh"}, IPPROTO_IP, IP_MTU_DISCOVER, pack("I*", $i))
+ or croak "error configuring IP_MTU_DISCOVER $!";
+ }
+ }
+}
+
+# SO_BINDTODEVICE + IP_TOS
+sub _setopts {
+ my $self = shift;
+ if ($self->{'device'}) {
+ setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE, pack("Z*", $self->{'device'}))
+ or croak "error binding to device $self->{'device'} $!";
+ }
+ if ($self->{'tos'}) { # need to re-apply ToS (RT #6706)
+ setsockopt($self->{"fh"}, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'}))
+ or croak "error applying tos to $self->{'tos'} $!";
+ }
+ if ($self->{'dontfrag'}) {
+ $self->_dontfrag;
+ }
+}
+
# Description: Perform a udp echo ping. Construct a message of
# at least the one-byte sequence number and any additional data bytes.
sub ping_udp
{
my ($self,
- $ip, # Packed IP number of the host
+ $ip, # Hash of addr (string), addr_in (packed), family
$timeout # Seconds after which ping times out
) = @_;
$from_ip # Packed IP number of sender
);
- $saddr = sockaddr_in($self->{"port_num"}, $ip);
+ $saddr = _pack_sockaddr_in($self->{"port_num"}, $ip);
$self->{"seq"} = ($self->{"seq"} + 1) % 256; # Increment sequence
$msg = chr($self->{"seq"}) . $self->{"data"}; # Add data if any
+ socket($self->{"fh"}, $ip->{"family"}, SOCK_DGRAM,
+ $self->{"proto_num"}) ||
+ croak("udp socket error - $!");
+
+ if (defined $self->{"local_addr"} &&
+ !CORE::bind($self->{"fh"}, _pack_sockaddr_in(0, $self->{"local_addr"}))) {
+ croak("udp bind error - $!");
+ }
+
+ $self->_setopts();
+
if ($self->{"connected"}) {
if ($self->{"connected"} ne $saddr) {
# Still connected to wrong destination.
if ($flush) {
# Need to socket() again to flush the descriptor
# This will disconnect from the old saddr.
- socket($self->{"fh"}, PF_INET, SOCK_DGRAM,
+ socket($self->{"fh"}, $ip->{"family"}, SOCK_DGRAM,
$self->{"proto_num"});
+ $self->_setopts();
}
# Connect the socket if it isn't already connected
# to the right destination.
}
$done = 1;
} else {
- ($from_port, $from_ip) = sockaddr_in($from_saddr);
+ ($from_port, $from_ip) = _unpack_sockaddr_in($from_saddr, $ip->{"family"});
if (!$source_verify ||
(($from_ip eq $ip) && # Does the packet check out?
($from_port == $self->{"port_num"}) &&
}
my $fh = FileHandle->new();
- my $saddr = sockaddr_in($self->{"port_num"}, $ip);
+ my $saddr = _pack_sockaddr_in($self->{"port_num"}, $ip);
# Create TCP socket
- if (!socket ($fh, PF_INET, SOCK_STREAM, $self->{"proto_num"})) {
+ if (!socket ($fh, $ip->{"family"}, SOCK_STREAM, $self->{"proto_num"})) {
croak("tcp socket error - $!");
}
if (defined $self->{"local_addr"} &&
- !CORE::bind($fh, sockaddr_in(0, $self->{"local_addr"}))) {
+ !CORE::bind($fh, _pack_sockaddr_in(0, $self->{"local_addr"}))) {
croak("tcp bind error - $!");
}
- if ($self->{'device'}) {
- setsockopt($fh, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
- or croak("error binding to device $self->{'device'} $!");
- }
- if ($self->{'tos'}) {
- setsockopt($fh, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'}))
- or croak "error configuring tos to $self->{'tos'} $!";
- }
+ $self->_setopts();
# Set O_NONBLOCK property on filehandle
$self->socket_blocking_mode($fh, 0);
}
} else {
# Child process
- my $saddr = sockaddr_in($self->{"port_num"}, $ip);
+ my $saddr = _pack_sockaddr_in($self->{"port_num"}, $ip);
# Create TCP socket
- if (!socket ($self->{"fh"}, PF_INET, SOCK_STREAM, $self->{"proto_num"})) {
+ if (!socket ($self->{"fh"}, $ip->{"family"}, SOCK_STREAM, $self->{"proto_num"})) {
croak("tcp socket error - $!");
}
if (defined $self->{"local_addr"} &&
- !CORE::bind($self->{"fh"}, sockaddr_in(0, $self->{"local_addr"}))) {
+ !CORE::bind($self->{"fh"}, _pack_sockaddr_in(0, $self->{"local_addr"}))) {
croak("tcp bind error - $!");
}
- if ($self->{'device'}) {
- setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
- or croak("error binding to device $self->{'device'} $!");
- }
- if ($self->{'tos'}) {
- setsockopt($self->{"fh"}, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'}))
- or croak "error configuring tos to $self->{'tos'} $!";
- }
+ $self->_setopts();
$!=0;
# Try to connect (could take a long time)
}
my $wbits = "";
my $stop_time = 0;
- if (my $host = shift) {
- # Host passed as arg
+ if (my $host = shift or $self->{host}) {
+ # Host passed as arg or as option to new
+ $host = $self->{host} unless defined $host;
if (exists $self->{"bad"}->{$host}) {
if (!$self->{"econnrefused"} &&
$self->{"bad"}->{ $host } &&
# Any port will work, even undef, but this will work for now.
# Socket warns when undef is passed in, but it still works.
my $port = getservbyname('echo', 'udp');
- my $sockaddr = sockaddr_in $port, $ip;
+ my $sockaddr = _pack_sockaddr_in($port, $ip);
my ($error, $address) = getnameinfo($sockaddr, NI_NUMERICHOST);
if($error) {
croak $error;
return $address;
}
+sub wakeonlan {
+ my ($mac_addr, $host, $port) = @_;
+
+ # use the discard service if $port not passed in
+ if (! defined $host) { $host = '255.255.255.255' }
+ if (! defined $port || $port !~ /^\d+$/ ) { $port = 9 }
+
+ require IO::Socket::INET;
+ my $sock = IO::Socket::INET->new(Proto=>'udp') || return undef;
+
+ my $ip_addr = inet_aton($host);
+ my $sock_addr = sockaddr_in($port, $ip_addr);
+ $mac_addr =~ s/://g;
+ my $packet = pack('C6H*', 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, $mac_addr x 16);
+
+ setsockopt($sock, SOL_SOCKET, SO_BROADCAST, 1);
+ send($sock, $packet, 0, $sock_addr);
+ $sock->close;
+
+ return 1;
+}
+
+########################################################
+# DNS hostname resolution
+# return:
+# $h->{name} = host - as passed in
+# $h->{host} = host - as passed in without :port
+# $h->{port} = OPTIONAL - if :port, then value of port
+# $h->{addr} = resolved numeric address
+# $h->{addr_in} = aton/pton result
+# $h->{family} = AF_INET/6
+############################
+sub _resolv {
+ my ($self,
+ $name,
+ ) = @_;
+
+ my %h;
+ $h{name} = $name;
+ my $family = $self->{"family"};
+
+ if (defined($self->{"family_local"})) {
+ $family = $self->{"family_local"}
+ }
+
+# START - host:port
+ my $cnt = 0;
+
+ # Count ":"
+ $cnt++ while ($name =~ m/:/g);
+
+ # 0 = hostname or IPv4 address
+ if ($cnt == 0) {
+ $h{host} = $name
+ # 1 = IPv4 address with port
+ } elsif ($cnt == 1) {
+ ($h{host}, $h{port}) = split /:/, $name
+ # >=2 = IPv6 address
+ } elsif ($cnt >= 2) {
+ #IPv6 with port - [2001::1]:port
+ if ($name =~ /^\[.*\]:\d{1,5}$/) {
+ ($h{host}, $h{port}) = split /:([^:]+)$/, $name # split after last :
+ # IPv6 without port
+ } else {
+ $h{host} = $name
+ }
+ }
+
+ # Clean up host
+ $h{host} =~ s/\[//g;
+ $h{host} =~ s/\]//g;
+ # Clean up port
+ if (defined($h{port}) && (($h{port} !~ /^\d{1,5}$/) || ($h{port} < 1) || ($h{port} > 65535))) {
+ croak("Invalid port `$h{port}' in `$name'");
+ }
+# END - host:port
+
+ # address check
+ # new way
+ if ($Socket::VERSION >= 1.94) {
+ my %hints = (
+ family => $AF_UNSPEC,
+ protocol => IPPROTO_TCP,
+ flags => $AI_NUMERICHOST
+ );
+
+ # numeric address, return
+ my ($err, @getaddr) = Socket::getaddrinfo($h{host}, undef, \%hints);
+ if (defined($getaddr[0])) {
+ $h{addr} = $h{host};
+ $h{family} = $getaddr[0]->{family};
+ if ($h{family} == AF_INET) {
+ (undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in $getaddr[0]->{addr};
+ } else {
+ (undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in6 $getaddr[0]->{addr};
+ }
+ return \%h
+ }
+ # old way
+ } else {
+ # numeric address, return
+ my $ret = gethostbyname($h{host});
+ if (defined($ret) && (_inet_ntoa($ret) eq $h{host})) {
+ $h{addr} = $h{host};
+ $h{addr_in} = $ret;
+ $h{family} = AF_INET;
+ return \%h
+ }
+ }
+
+ # resolve
+ # new way
+ if ($Socket::VERSION >= 1.94) {
+ my %hints = (
+ family => $family,
+ protocol => IPPROTO_TCP
+ );
+
+ my ($err, @getaddr) = Socket::getaddrinfo($h{host}, undef, \%hints);
+ if (defined($getaddr[0])) {
+ my ($err, $address) = Socket::getnameinfo($getaddr[0]->{addr}, $NI_NUMERICHOST);
+ if (defined($address)) {
+ $h{addr} = $address;
+ $h{addr} =~ s/\%(.)*$//; # remove %ifID if IPv6
+ $h{family} = $getaddr[0]->{family};
+ if ($h{family} == AF_INET) {
+ (undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in $getaddr[0]->{addr};
+ } else {
+ (undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in6 $getaddr[0]->{addr};
+ }
+ return \%h
+ } else {
+ croak("getnameinfo($getaddr[0]->{addr}) failed - $err");
+ }
+ } else {
+ my $error = sprintf "getaddrinfo($h{host},,%s) failed - $err",
+ ($family == AF_INET) ? "AF_INET" : "AF_INET6";
+ croak("$error");
+ }
+ # old way
+ } else {
+ if ($family == $AF_INET6) {
+ croak("Socket >= 1.94 required for IPv6 - found Socket $Socket::VERSION");
+ }
+
+ my @gethost = gethostbyname($h{host});
+ if (defined($gethost[4])) {
+ $h{addr} = inet_ntoa($gethost[4]);
+ $h{addr_in} = $gethost[4];
+ $h{family} = AF_INET;
+ return \%h
+ } else {
+ croak("gethostbyname($h{host}) failed - $^E");
+ }
+ }
+}
+
+sub _pack_sockaddr_in($$) {
+ my ($port,
+ $addr,
+ ) = @_;
+
+ if ($addr->{"family"} == AF_INET) {
+ return Socket::pack_sockaddr_in($port, $addr->{"addr_in"});
+ } else {
+ return Socket::pack_sockaddr_in6($port, $addr->{"addr_in"});
+ }
+}
+
+sub _unpack_sockaddr_in($;$) {
+ my ($addr,
+ $family,
+ ) = @_;
+
+ my ($port, $host);
+ if ($family == AF_INET || (!defined($family) and length($addr) <= 16 )) {
+ ($port, $host) = Socket::unpack_sockaddr_in($addr);
+ } else {
+ ($port, $host) = Socket::unpack_sockaddr_in6($addr);
+ }
+ return $port, $host
+}
+
+sub _inet_ntoa {
+ my ($addr
+ ) = @_;
+
+ my $ret;
+ if ($Socket::VERSION >= 1.94) {
+ my ($err, $address) = Socket::getnameinfo($addr, $NI_NUMERICHOST);
+ if (defined($address)) {
+ $ret = $address;
+ } else {
+ croak("getnameinfo($addr) failed - $err");
+ }
+ } else {
+ $ret = inet_ntoa($addr)
+ }
+
+ return $ret
+}
+
1;
__END__
=over 4
-=item Net::Ping->new([$proto [, $def_timeout [, $bytes [, $device [, $tos [, $ttl ]]]]]]);
+=item Net::Ping->new([proto, timeout, bytes, device, tos, ttl, family,
+ host, port, bind, gateway, retrans, pingstring,
+ source_verify econnrefused dontfrag
+ IPV6_USE_MIN_MTU IPV6_RECVPATHMTU])
-Create a new ping object. All of the parameters are optional. $proto
-specifies the protocol to use when doing a ping. The current choices
-are "tcp", "udp", "icmp", "stream", "syn", or "external".
-The default is "tcp".
+Create a new ping object. All of the parameters are optional and can
+be passed as hash ref. All options besides the first 7 must be passed
+as hash ref.
-If a default timeout ($def_timeout) in seconds is provided, it is used
+C<proto> specifies the protocol to use when doing a ping. The current
+choices are "tcp", "udp", "icmp", "icmpv6", "stream", "syn", or
+"external". The default is "tcp".
+
+If a C<timeout> in seconds is provided, it is used
when a timeout is not given to the ping() method (below). The timeout
must be greater than 0 and the default, if not specified, is 5 seconds.
-If the number of data bytes ($bytes) is given, that many data bytes
+If the number of data bytes (C<bytes>) is given, that many data bytes
are included in the ping packet sent to the remote host. The number of
data bytes is ignored if the protocol is "tcp". The minimum (and
default) number of data bytes is 1 if the protocol is "udp" and 0
otherwise. The maximum number of data bytes that can be specified is
1024.
-If $device is given, this device is used to bind the source endpoint
+If C<device> is given, this device is used to bind the source endpoint
before sending the ping packet. I believe this only works with
superuser privileges and with udp and icmp protocols at this time.
-If $tos is given, this ToS is configured into the socket.
+If <tos> is given, this ToS is configured into the socket.
+
+For icmp, C<ttl> can be specified to set the TTL of the outgoing packet.
+
+Valid C<family> values for IPv4:
+
+ 4, v4, ip4, ipv4, AF_INET (constant)
+
+Valid C<family> values for IPv6:
+
+ 6, v6, ip6, ipv6, AF_INET6 (constant)
+
+The C<host> argument implicitly specifies the family if the family
+argument is not given.
+
+The C<port> argument is only valid for a udp, tcp or stream ping, and will not
+do what you think it does. ping returns true when we get a "Connection refused"!
+The default is the echo port.
+
+The C<bind> argument specifies the local_addr to bind to.
+By specifying a bind argument you don't need the bind method.
+
+The C<gateway> argument is only valid for IPv6, and requires a IPv6
+address.
-For icmp, $ttl can be specified to set the TTL of the outgoing packet.
+The C<retrans> argument the exponential backoff rate, default 1.2.
+It matches the $def_factor global.
-=item $p->ping($host [, $timeout]);
+The C<dontfrag> argument sets the IP_DONTFRAG bit, but note that
+IP_DONTFRAG is not yet defined by Socket, and not available on many
+systems. Then it is ignored. On linux it also sets IP_MTU_DISCOVER to
+IP_PMTUDISC_DO but need we don't chunk oversized packets. You need to
+set $data_size manually.
+
+=item $p->ping($host [, $timeout [, $family]]);
Ping the remote host and wait for a response. $host can be either the
hostname or the IP number of the remote host. The optional timeout
=item $p->hires( { 0 | 1 } );
-Causes this module to use Time::HiRes module, allowing milliseconds
+With 1 causes this module to use Time::HiRes module, allowing milliseconds
to be returned by subsequent calls to ping().
-This is disabled by default.
+=item $p->time
+
+The current time, hires or not.
+
+=item $p->socket_blocking_mode( $fh, $mode );
+
+Sets or clears the O_NONBLOCK flag on a file handle.
+
+=item $p->IPV6_USE_MIN_MTU
+
+With argument sets the option.
+Without returns the option value.
+
+=item $p->IPV6_RECVPATHMTU
+
+Notify an according IPv6 MTU.
+
+With argument sets the option.
+Without returns the option value.
+
+=item $p->IPV6_HOPLIMIT
+
+With argument sets the option.
+Without returns the option value.
+
+=item $p->IPV6_REACHCONF I<NYI>
+
+Sets ipv6 reachability
+IPV6_REACHCONF was removed in RFC3542. ping6 -R supports it.
+IPV6_REACHCONF requires root/admin permissions.
+
+With argument sets the option.
+Without returns the option value.
+
+Not yet implemented.
=item $p->bind($local_addr);
called at all) must be called before the first call to ping() for that
object.
+The bind() call can be omitted when specifying the C<bind> option to
+new().
+
=item $p->open($host);
When you are using the "stream" protocol, this call pre-opens the
This call simply does nothing if you are using any protocol other
than stream.
+The $host argument can be omitted when specifying the C<host> option to
+new().
+
=item $p->ack( [ $host ] );
When using the "syn" protocol, use this method to determine
This call simply does nothing if you are using any protocol
other than syn.
+When new() had a host option, this host will be used.
+Without host argument, all hosts are scanned.
+
=item $p->nack( $failed_ack_host );
The reason that host $failed_ack_host did not receive a
valid ACK. Useful to find out why when ack( $fail_ack_host )
returns a false value.
+=item $p->ack_unfork($host)
+
+The variant called by ack() with the syn protocol and $syn_forking
+enabled.
+
+=item $p->ping_icmp([$host, $timeout, $family])
+
+The ping() method used with the icmp protocol.
+
+=item $p->ping_icmpv6([$host, $timeout, $family]) I<NYI>
+
+The ping() method used with the icmpv6 protocol.
+
+=item $p->ping_stream([$host, $timeout, $family])
+
+The ping() method used with the stream protocol.
+
+Perform a stream ping. If the tcp connection isn't
+already open, it opens it. It then sends some data and waits for
+a reply. It leaves the stream open on exit.
+
+=item $p->ping_syn([$host, $ip, $start_time, $stop_time])
+
+The ping() method used with the syn protocol.
+Sends a TCP SYN packet to host specified.
+
+=item $p->ping_syn_fork([$host, $timeout, $family])
+
+The ping() method used with the forking syn protocol.
+
+=item $p->ping_tcp([$host, $timeout, $family])
+
+The ping() method used with the tcp protocol.
+
+=item $p->ping_udp([$host, $timeout, $family])
+
+The ping() method used with the udp protocol.
+
+Perform a udp echo ping. Construct a message of
+at least the one-byte sequence number and any additional data bytes.
+Send the message out and wait for a message to come back. If we
+get a message, make sure all of its parts match. If they do, we are
+done. Otherwise go back and wait for the message until we run out
+of time. Return the result of our efforts.
+
+=item $p->ping_external([$host, $timeout, $family])
+
+The ping() method used with the external protocol.
+Uses Net::Ping::External to do an external ping.
+
+=item $p->tcp_connect([$ip, $timeout])
+
+Initiates a TCP connection, for a tcp ping.
+
+=item $p->tcp_echo([$ip, $timeout, $pingstring])
+
+Performs a TCP echo.
+It writes the given string to the socket and then reads it
+back. It returns 1 on success, 0 on failure.
+
=item $p->close();
Close the network connection for this ping object. The network
response only if that specific port is accessible. This function returns
the value of the port that C<ping()> will connect to.
+=item $p->mselect
+
+A select() wrapper that compensates for platform
+peculiarities.
+
+=item $p->ntop
+
+Platform abstraction over inet_ntop()
+
+=item $p->checksum($msg)
+
+Do a checksum on the message. Basically sum all of
+the short words and fold the high order bits into the low order bits.
+
+=item $p->icmp_result
+
+Returns a list of addr, type, subcode.
+
=item pingecho($host [, $timeout]);
To provide backward compatibility with the previous version of
method. This subroutine is obsolete and may be removed in a future
version of Net::Ping.
+=item wakeonlan($mac, [$host, [$port]])
+
+Emit the popular wake-on-lan magic udp packet to wake up a local
+device. See also L<Net::Wake>, but this has the mac address as 1st arg.
+$host should be the local gateway. Without it will broadcast.
+
+Default host: '255.255.255.255'
+Default port: 9
+
+ perl -MNet::Ping=wakeonlan -e'wakeonlan "e0:69:95:35:68:d2"'
+
=back
=head1 NOTES
to implement a small wait (e.g. 25ms or more) between each ping to
avoid flooding your network with packets.
-The icmp protocol requires that the program be run as root or that it
-be setuid to root. The other protocols do not require special
-privileges, but not all network devices implement tcp or udp echo.
+The icmp and icmpv6 protocols requires that the program be run as root
+or that it be setuid to root. The other protocols do not require
+special privileges, but not all network devices implement tcp or udp
+echo.
Local hosts should normally respond to pings within milliseconds.
However, on a very congested network it may take up to 3 seconds or
=head1 INSTALL
-The latest source tree is available via cvs:
+The latest source tree is available via git:
- cvs -z3 -q -d \
- :pserver:anonymous@cvs.roobik.com.:/usr/local/cvsroot/freeware \
- checkout Net-Ping
+ git clone https://github.com/rurban/net-ping.git Net-Ping
cd Net-Ping
The tarball can be created as follows:
perl Makefile.PL ; make ; make dist
-The latest Net::Ping release can be found at CPAN:
-
- $CPAN/modules/by-module/Net/
-
-1) Extract the tarball
-
- gtar -zxvf Net-Ping-xxxx.tar.gz
- cd Net-Ping-xxxx
-
-2) Build:
+The latest Net::Ping releases are included in cperl and perl5.
- make realclean
- perl Makefile.PL
- make
- make test
-
-3) Install
-
- make install
+=head1 BUGS
-Or install it RPM Style:
+For a list of known issues, visit:
- rpm -ta SOURCES/Net-Ping-xxxx.tar.gz
+L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-Ping>
- rpm -ih RPMS/noarch/perl-Net-Ping-xxxx.rpm
+To report a new bug, visit:
-=head1 BUGS
+L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-Ping> (stale)
-For a list of known issues, visit:
+or call:
-https://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-Ping
+ perlbug
-To report a new bug, visit:
+resp.:
-https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-Ping
+ cperlbug
=head1 AUTHORS
- Current maintainer:
+ Current maintainers:
+ perl11 (for cperl, with IPv6 support and more)
+ p5p (for perl5)
+
+ Previous maintainers:
bbb@cpan.org (Rob Brown)
+ Steve Peters
External protocol:
colinm@cpan.org (Colin McMillen)
Stream protocol:
bronson@trestle.com (Scott Bronson)
+ Wake-on-lan:
+ 1999-2003 Clinton Wong
+
Original pingecho():
karrer@bernina.ethz.ch (Andreas Karrer)
pmarquess@bfsec.bt.co.uk (Paul Marquess)
=head1 COPYRIGHT
+Copyright (c) 2016, cPanel Inc. All rights reserved.
+
+Copyright (c) 2012, Steve Peters. All rights reserved.
+
Copyright (c) 2002-2003, Rob Brown. All rights reserved.
Copyright (c) 2001, Colin McMillen. All rights reserved.
--- /dev/null
+#!perl -T
+use 5.006;
+use strict;
+use warnings FATAL => 'all';
+use Test::More;
+
+plan tests => 3;
+
+BEGIN {
+ use_ok( 'Socket' ) || print "No Socket!\n";
+ use_ok( 'Time::HiRes' ) || print "No Time::HiRes!\n";
+ use_ok( 'Net::Ping' ) || print "No Net::Ping!\n";
+}
+
+diag( "Testing Net::Ping $Net::Ping::VERSION, Perl $], $^X" );
+
--- /dev/null
+use warnings;
+use strict;
+
+use Test::More qw(no_plan);
+BEGIN {use_ok('Net::Ping')};
+
+# plain ol' constuctor call
+my $p = Net::Ping->new();
+isa_ok($p, "Net::Ping");
+
+# call new from an instantiated object
+my $p2 = $p->new();
+isa_ok($p2, "Net::Ping");
+
+# named args
+my $p3 = Net::Ping->new({proto => 'tcp', ttl => 5});
+isa_ok($p3, "Net::Ping");
+
+# check for invalid proto
+eval {
+ $p = Net::Ping->new("thwackkk");
+};
+like($@, qr/Protocol for ping must be "icmp", "icmpv6", "udp", "tcp", "syn", "stream" or "external"/, "new() errors for invalid protocol");
+
+# check for invalid timeout
+eval {
+ $p = Net::Ping->new("tcp", -1);
+};
+like($@, qr/Default timeout for ping must be greater than 0 seconds/, "new() errors for invalid timeout");
+
+# check for invalid data sizes
+eval {
+ $p = Net::Ping->new("udp", 10, -1);
+};
+like($@, qr/Data for ping must be from/, "new() errors for invalid data size");
+
+eval {
+ $p = Net::Ping->new("udp", 10, 1025);
+};
+like($@, qr/Data for ping must be from/, "new() errors for invalid data size");
+
+# force failures for udp
+
+
+# force failures for tcp
+SKIP: {
+ diag "Checking icmp";
+ eval { $p = Net::Ping->new('icmp'); };
+ if($> and $^O ne 'VMS' and $^O ne 'cygwin') {
+ like($@, qr/icmp ping requires root privilege/, "Need root for icmp");
+ skip "icmp tests require root", 2;
+ } else {
+ isa_ok($p, "Net::Ping");
+ }
+
+ # set IP TOS to "Minimum Delay"
+ $p = Net::Ping->new("icmp", undef, undef, undef, 8);
+ isa_ok($p, "Net::Ping");
+
+ # This really shouldn't work. Not sure who to blame.
+ $p = Net::Ping->new("icmp", undef, undef, undef, "does this fail");
+ isa_ok($p, "Net::Ping");
+}
+
--- /dev/null
+use warnings;
+use strict;
+
+use Test::More tests => 2;
+BEGIN {use_ok('Net::Ping')};
+
+my $result = pingecho("127.0.0.1");
+is($result, 1, "pingecho works");
+++ /dev/null
-use strict;
-
-BEGIN {
- unless (eval "require Socket") {
- print "1..0 \# Skip: no Socket\n";
- exit;
- }
-}
-
-use Test::More tests => 1;
-# Just make sure everything compiles
-BEGIN {use_ok 'Net::Ping'};
SKIP: {
skip "icmp ping requires root privileges.", 1
- if ($> and $^O ne 'VMS' and $^O ne 'cygwin')
- or (($^O eq 'MSWin32' or $^O eq 'cygwin')
- and !IsAdminUser())
- or ($^O eq 'VMS'
- and (`write sys\$output f\$privilege("SYSPRV")` =~ m/FALSE/));
+ unless &Net::Ping::_isroot;
my $p = new Net::Ping "icmp";
isa_ok($p, 'Net::Ping', 'object can be instantiated for icmp protocol');
}
-
-sub IsAdminUser {
- return unless $^O eq 'MSWin32' or $^O eq 'cygwin';
- return unless eval { require Win32 };
- return unless defined &Win32::IsAdminUser;
- return Win32::IsAdminUser();
-}
SKIP: {
skip "icmp ping requires root privileges.", 1
- if ($> and $^O ne 'VMS' and $^O ne 'cygwin')
- or (($^O eq 'MSWin32' or $^O eq 'cygwin')
- and !IsAdminUser())
- or ($^O eq 'VMS'
- and (`write sys\$output f\$privilege("SYSPRV")` =~ m/FALSE/));
+ if !Net::Ping::_isroot() or $^O eq 'MSWin32';
my $p = new Net::Ping "icmp";
is($p->ping("127.0.0.1"), 1, "icmp ping 127.0.0.1");
}
-sub IsAdminUser {
- return unless $^O eq 'MSWin32' or $^O eq "cygwin";
- return unless eval { require Win32 };
- return unless defined &Win32::IsAdminUser;
- return Win32::IsAdminUser();
-}
SKIP: {
skip "icmp ping requires root privileges.", 1
- if ($> and $^O ne 'VMS' and $^O ne 'cygwin')
- or (($^O eq 'MSWin32' or $^O eq 'cygwin')
- and !IsAdminUser())
- or ($^O eq 'VMS'
- and (`write sys\$output f\$privilege("SYSPRV")` =~ m/FALSE/));
+ if !Net::Ping::_isroot() or $^O eq 'MSWin32';
my $p = new Net::Ping ("icmp",undef,undef,undef,undef,undef);
isa_ok($p, 'Net::Ping');
ok $p->ping("127.0.0.1");
ok $p->ping("127.0.0.1");
$p->close();
}
-
-sub IsAdminUser {
- return unless $^O eq 'MSWin32' or $^O eq "cygwin";
- return unless eval { require Win32 };
- return unless defined &Win32::IsAdminUser;
- return Win32::IsAdminUser();
-}
-BEGIN { @INC = grep {!/blib/} @INC }
+# See https://rt.cpan.org/Public/Bug/Display.html?id=4681
+# and https://rt.perl.org/Ticket/Display.html?id=125603
+# When installing a newer Cwd on a system with an existing Cwd,
+# under some circumstances the old Cwd.pm and the new Cwd.xs could
+# get mixed up and SEGVs ensue.
+
+BEGIN { @INC = grep { $_ ne "blib/arch" and $_ ne "blib/lib" } @INC }
require 5.005;
use ExtUtils::MakeMaker;
padav SKIP my @x
padhv SKIP my %x
padany SKIP (not implemented)
-pushre SKIP split /foo/
rv2gv *x
rv2sv $x
av2arylen $#x
use vars qw($canonical $forgive_me $VERSION);
-$VERSION = '2.57';
+$VERSION = '2.58';
BEGIN {
if (eval {
SEEN_NN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */
if (len == 0) {
- sv_setpvn(sv, "", 0);
+ SvPVCLEAR(sv);
return sv;
}
SAVETMPS;
errsv = get_sv("@", GV_ADD);
- sv_setpvn(errsv, "", 0); /* clear $@ */
+ SvPVCLEAR(errsv); /* clear $@ */
if (SvROK(cxt->eval) && SvTYPE(SvRV(cxt->eval)) == SVt_PVCV) {
PUSHMARK(sp);
XPUSHs(sv_2mortal(newSVsv(sub)));
print "# Timeout\n";
print "not ok $N\n"; $N++;
print "not ok $N\n"; $N++;
+ if (defined $len) {
+ # Fail the tests in the recursive call as well
+ print "not ok $N\n"; $N++;
+ print "not ok $N\n"; $N++;
+ }
return;
} else {
$@ = $err;
Revision history for the Perl extension Time::HiRes.
+1.9740_01 [2016-10-01]
+ - explicit cast to clockid_t needed for C++11 (gcc 6, clang 3.9)
+
+1.9740 [2016-09-25]
+ - the ext3/ext2 filesystems do not have subsecond resolution,
+ therefore skip the t/utime.t test
+ [rt.cpan.org #116127]
+
1.9739 [2016-06-28]
- the upcoming macOS 10.12 (Sierra, the operating system formerly
known as OS X, or Darwin) has implemented the clock_gettime()
stat lstat utime
);
-our $VERSION = '1.9739';
+our $VERSION = '1.9740_01';
our $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
# undef ITIMER_REALPROF
#endif
+#ifndef TIME_HIRES_CLOCKID_T
+typedef int clockid_t;
+#endif
+
#if defined(TIME_HIRES_CLOCK_GETTIME) && defined(_STRUCT_ITIMERSPEC)
/* HP-UX has CLOCK_XXX values but as enums, not as defines.
}
#ifdef TIME_HIRES_CLOCK_GETTIME_EMULATION
-static int clock_gettime(int clock_id, struct timespec *ts) {
+static int clock_gettime(clockid_t clock_id, struct timespec *ts) {
if (darwin_time_init() && timebase_info.denom) {
switch (clock_id) {
case CLOCK_REALTIME:
#endif /* TIME_HIRES_CLOCK_GETTIME_EMULATION */
#ifdef TIME_HIRES_CLOCK_GETRES_EMULATION
-static int clock_getres(int clock_id, struct timespec *ts) {
+static int clock_getres(clockid_t clock_id, struct timespec *ts) {
if (darwin_time_init() && timebase_info.denom) {
switch (clock_id) {
case CLOCK_REALTIME:
#endif /* TIME_HIRES_CLOCK_GETRES_EMULATION */
#ifdef TIME_HIRES_CLOCK_NANOSLEEP_EMULATION
-static int clock_nanosleep(int clock_id, int flags,
+static int clock_nanosleep(clockid_t clock_id, int flags,
const struct timespec *rqtp,
struct timespec *rmtp) {
if (darwin_time_init()) {
#ifdef TIME_HIRES_CLOCK_GETTIME_SYSCALL
status = syscall(SYS_clock_gettime, clock_id, &ts);
#else
- status = clock_gettime(clock_id, &ts);
+ status = clock_gettime((clockid_t)clock_id, &ts);
#endif
RETVAL = status == 0 ? ts.tv_sec + (NV) ts.tv_nsec / NV_1E9 : -1;
#ifdef TIME_HIRES_CLOCK_GETRES_SYSCALL
status = syscall(SYS_clock_getres, clock_id, &ts);
#else
- status = clock_getres(clock_id, &ts);
+ status = clock_getres((clockid_t)clock_id, &ts);
#endif
RETVAL = status == 0 ? ts.tv_sec + (NV) ts.tv_nsec / NV_1E9 : -1;
EOM
}
+sub has_clockid_t{
+ return 1 if
+ try_compile_and_link(<<EOM);
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include <sys/time.h>
+#include <fcntl.h>
+int main(int argc, char** argv)
+{
+ clockid_t id = CLOCK_REALTIME;
+ exit(id == CLOCK_REALTIME ? 1 : 0);
+}
+EOM
+}
+
sub DEFINE {
my ($def, $val) = @_;
my $define = defined $val ? "$def=$val" : $def ;
print "(It would not be portable anyway.)\n";
}
+ print "Looking for clockid_t... ";
+ my $has_clockid_t;
+ if (has_clockid_t()) {
+ print "found.\n";
+ $has_clockid_t++;
+ $DEFINE .= ' -DTIME_HIRES_CLOCKID_T';
+ } else {
+ print "NOT found, will use int.\n";
+ }
+
print "Looking for clock_gettime()... ";
my $has_clock_gettime;
my $has_clock_gettime_emulation;
BEGIN {
require Time::HiRes;
require Test::More;
+ require File::Temp;
unless(&Time::HiRes::d_hires_utime) {
Test::More::plan(skip_all => "no hires_utime");
}
if ($^O eq 'gnukfreebsd') {
Test::More::plan(skip_all => "futimens() and utimensat() not working in $^O");
}
+ if ($^O eq 'linux' && -e '/proc/mounts') {
+ # The linux might be wrong when ext3
+ # is available in other operating systems,
+ # but then we need other methods for detecting
+ # the filesystem type of the tempfiles.
+ my ($fh, $fn) = File::Temp::tempfile( "Time-HiRes-utime-XXXXXXXXX", UNLINK => 1);
+ sub getfstype {
+ my ($fn) = @_;
+ my $cmd = "df $fn";
+ open(my $df, "$cmd |") or die "$cmd: $!";
+ my @df = <$df>; # Assume $df[0] is header line.
+ my $dev = +(split(" ", $df[1]))[0];
+ open(my $mounts, "/proc/mounts") or die "/proc/mounts: $!";
+ while (<$mounts>) {
+ my @m = split(" ");
+ if ($m[0] eq $dev) { return $m[2] }
+ }
+ return;
+ }
+ my $fstype = getfstype($fn);
+ unless (defined $fstype) {
+ warn "Unknown fstype for $fn\n";
+ } else {
+ print "# fstype = $fstype\n";
+ if ($fstype eq 'ext3' || $fstype eq 'ext2') {
+ Test::More::plan(skip_all => "fstype $fstype has no subsecond timestamps in $^O");
+ }
+ }
+ }
}
use Test::More tests => 18;
use Config;
-# Cygwin timestamps have less precision.
-my $atime = $^O eq 'cygwin' ? 1.1111111 : 1.111111111;
-my $mtime = $^O eq 'cygwin' ? 2.2222222 : 2.222222222;
+# Hope initially for nanosecond accuracy.
+my $atime = 1.111111111;
+my $mtime = 2.222222222;
+
+if ($^O eq 'cygwin') {
+ # Cygwin timestamps have less precision.
+ $atime = 1.1111111;
+ $mtime = 2.2222222;
+}
+print "# \$^O = $^O, atime = $atime, mtime = $mtime\n";
print "# utime \$fh\n";
{
const char *star = strchr(PL_inplace, '*');
if (star) {
const char *begin = PL_inplace;
- sv_setpvs(sv, "");
+ SvPVCLEAR(sv);
do {
sv_catpvn(sv, begin, star - begin);
sv_catpvn(sv, PL_oldname, oldlen);
do_fstat_have_io:
PL_laststype = OP_STAT;
PL_statgv = gv ? gv : (GV *)io;
- sv_setpvs(PL_statname, "");
+ SvPVCLEAR(PL_statname);
if (io) {
if (IoIFP(io)) {
int fd = PerlIO_fileno(IoIFP(io));
{
char flags[PERL_FLAGS_MAX];
if (strnEQ(cmd,PL_cshname,PL_cshlen) &&
- strnEQ(cmd+PL_cshlen," -c",3)) {
+ strEQs(cmd+PL_cshlen," -c")) {
my_strlcpy(flags, "-c", PERL_FLAGS_MAX);
s = cmd+PL_cshlen+3;
if (*s == 'f') {
if (*cmd == '.' && isSPACE(cmd[1]))
goto doshell;
- if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
+ if (strEQs(cmd,"exec") && isSPACE(cmd[4]))
goto doshell;
s = cmd;
/* suppress warning when reading into undef var --jhi */
if (! SvOK(mstr))
- sv_setpvs(mstr, "");
+ SvPVCLEAR(mstr);
msize = SvIVx(*++mark);
mtype = (long)SvIVx(*++mark);
flags = SvIVx(*++mark);
SvGETMAGIC(mstr);
SvUPGRADE(mstr, SVt_PV);
if (! SvOK(mstr))
- sv_setpvs(mstr, "");
+ SvPVCLEAR(mstr);
SvPOK_only(mstr);
mbuf = SvGROW(mstr, (STRLEN)msize+1);
++mark;
}
- sv_setpvs(sv, "");
+ SvPVCLEAR(sv);
/* sv_setpv retains old UTF8ness [perl #24846] */
SvUTF8_off(sv);
PERL_ARGS_ASSERT_DO_VOP;
if (sv != left || (optype != OP_BIT_AND && !SvOK(sv)))
- sv_setpvn(sv, "", 0); /* avoid undef warning on |= and ^= */
+ SvPVCLEAR(sv); /* avoid undef warning on |= and ^= */
if (sv == left) {
lsave = lc = SvPV_force_nomg(left, leftlen);
}
if (dsv && !(flags & PERL_PV_ESCAPE_NOCLEAR)) {
/* This won't alter the UTF-8 flag */
- sv_setpvs(dsv, "");
+ SvPVCLEAR(dsv);
}
if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
/* This won't alter the UTF-8 flag */
- sv_setpvs(dsv, "");
+ SvPVCLEAR(dsv);
}
orig_cur= SvCUR(dsv);
int unref = 0;
U32 type;
- sv_setpvs(t, "");
+ SvPVCLEAR(t);
retry:
if (!sv) {
sv_catpv(t, "VOID");
(pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
else
Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
- if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
- Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
- op_dump(pm->op_pmreplrootu.op_pmreplroot);
+
+ if (pm->op_type == OP_SPLIT)
+ Perl_dump_indent(aTHX_ level, file, "TARGOFF/GV = 0x%"UVxf"\n",
+ PTR2UV(pm->op_pmreplrootu.op_pmtargetgv));
+ else {
+ if (pm->op_pmreplrootu.op_pmreplroot) {
+ Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
+ op_dump(pm->op_pmreplrootu.op_pmreplroot);
+ }
}
+
if (pm->op_code_list) {
if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
Perl_dump_indent(aTHX_ level, file, "CODE_LIST =\n");
else
PerlIO_printf(file, "DONE\n");
break;
- case OP_PUSHRE:
+ case OP_SPLIT:
case OP_MATCH:
case OP_QR:
case OP_SUBST:
Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n",
SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
- sv_setpvs(d, "");
+ SvPVCLEAR(d);
if (AvREAL(sv)) sv_catpv(d, ",REAL");
if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
:
: (currently no effect)
:
+: W Add a _pDEPTH argument to function prototypes, and an _aDEPTH
+: argument to the function calls. This means that under DEBUGGING
+: a depth argument is added to the functions, which is used for
+: example by the regex engine for debugging and trace output.
+: A non DEBUGGING build will not pass the unused argument.
+: Currently restricted to functions with at least one argument.
+:
: X Explicitly exported:
:
: add entry to the list of exported symbols, unless x or m
AnpdD |STRLEN |is_utf8_char |NN const U8 *s
Abmnpd |STRLEN |is_utf8_char_buf|NN const U8 *buf|NN const U8 *buf_end
AnipdP |bool |is_utf8_string |NN const U8 *s|const STRLEN len
-Anpdmb |bool |is_utf8_string_loc|NN const U8 *s|const STRLEN len|NN const U8 **ep
-Anipd |bool |is_utf8_string_loclen|NN const U8 *s|const STRLEN len|NULLOK const U8 **ep|NULLOK STRLEN *el
+AnidP |bool |is_utf8_string_flags \
+ |NN const U8 *s|const STRLEN len|const U32 flags
+AnidP |bool |is_strict_utf8_string|NN const U8 *s|const STRLEN len
+AnidP |bool |is_c9strict_utf8_string|NN const U8 *s|const STRLEN len
+Anpdmb |bool |is_utf8_string_loc \
+ |NN const U8 *s|const STRLEN len|NN const U8 **ep
+Andm |bool |is_utf8_string_loc_flags \
+ |NN const U8 *s|const STRLEN len|NN const U8 **ep \
+ |const U32 flags
+Andm |bool |is_strict_utf8_string_loc \
+ |NN const U8 *s|const STRLEN len|NN const U8 **ep
+Andm |bool |is_c9strict_utf8_string_loc \
+ |NN const U8 *s|const STRLEN len|NN const U8 **ep
+Anipd |bool |is_utf8_string_loclen \
+ |NN const U8 *s|const STRLEN len|NULLOK const U8 **ep \
+ |NULLOK STRLEN *el
+Anid |bool |is_utf8_string_loclen_flags \
+ |NN const U8 *s|const STRLEN len|NULLOK const U8 **ep \
+ |NULLOK STRLEN *el|const U32 flags
+Anid |bool |is_strict_utf8_string_loclen \
+ |NN const U8 *s|const STRLEN len|NULLOK const U8 **ep \
+ |NULLOK STRLEN *el
+Anid |bool |is_c9strict_utf8_string_loclen \
+ |NN const U8 *s|const STRLEN len|NULLOK const U8 **ep \
+ |NULLOK STRLEN *el
+Amnd |bool |is_utf8_fixed_width_buf_flags \
+ |NN const U8 * const s|const STRLEN len|const U32 flags
+Amnd |bool |is_utf8_fixed_width_buf_loc_flags \
+ |NN const U8 * const s|const STRLEN len \
+ |NULLOK const U8 **ep|const U32 flags
+Anid |bool |is_utf8_fixed_width_buf_loclen_flags \
+ |NN const U8 * const s|const STRLEN len \
+ |NULLOK const U8 **ep|NULLOK STRLEN *el|const U32 flags
AmndP |bool |is_utf8_valid_partial_char \
|NN const U8 * const s|NN const U8 * const e
AnidP |bool |is_utf8_valid_partial_char_flags \
#endif
: Used in perly.y
p |OP* |pmruntime |NN OP *o|NN OP *expr|NULLOK OP *repl \
- |bool isreg|I32 floor
+ |UV flags|I32 floor
#if defined(PERL_IN_OP_C)
s |OP* |pmtrans |NN OP* o|NN OP* expr|NN OP* repl
#endif
|NN const char *const pv|const STRLEN n
Apd |void |sv_setpv |NN SV *const sv|NULLOK const char *const ptr
Apd |void |sv_setpvn |NN SV *const sv|NULLOK const char *const ptr|const STRLEN len
+Apd |char *|sv_setpv_bufsize|NN SV *const sv|const STRLEN cur|const STRLEN len
Xp |void |sv_sethek |NN SV *const sv|NULLOK const HEK *const hek
Apmdb |void |sv_setsv |NN SV *dstr|NULLOK SV *sstr
Apmdb |void |sv_taint |NN SV* sv
|NN const char *normal| \
NULLOK const char *special
#if defined(PERL_IN_UTF8_C)
+inRP |bool |does_utf8_overflow|NN const U8 * const s|NN const U8 * e
+inRP |bool |is_utf8_overlong_given_start_byte_ok|NN const U8 * const s|const STRLEN len
+sMR |char * |unexpected_non_continuation_text \
+ |NN const U8 * const s \
+ |STRLEN print_len \
+ |const STRLEN non_cont_byte_pos \
+ |const STRLEN expect_len
+sM |char * |_byte_dump_string|NN const U8 * s|const STRLEN len
s |UV |_to_utf8_case |const UV uv1 \
|NN const U8 *p \
|NN U8* ustrp \
ApdD |UV |utf8_to_uvuni_buf |NN const U8 *s|NN const U8 *send|NULLOK STRLEN *retlen
pM |bool |check_utf8_print |NN const U8 *s|const STRLEN len
-Adp |UV |utf8n_to_uvchr |NN const U8 *s|STRLEN curlen|NULLOK STRLEN *retlen|U32 flags
+Adop |UV |utf8n_to_uvchr |NN const U8 *s \
+ |STRLEN curlen \
+ |NULLOK STRLEN *retlen \
+ |const U32 flags
+Adp |UV |utf8n_to_uvchr_error|NN const U8 *s \
+ |STRLEN curlen \
+ |NULLOK STRLEN *retlen \
+ |const U32 flags \
+ |NULLOK U32 * errors
AipnR |UV |valid_utf8_to_uvchr |NN const U8 *s|NULLOK STRLEN *retlen
Ap |UV |utf8n_to_uvuni|NN const U8 *s|STRLEN curlen|NULLOK STRLEN *retlen|U32 flags
|NULLOK SV ** return_invlist \
|NN I32 *flagp|U32 depth \
|NN char * const oregcomp_parse
+#if defined(DEBUGGING) && defined(ENABLE_REGEX_SETS_DEBUGGING)
+Es |void |dump_regex_sets_structures \
+ |NN RExC_state_t *pRExC_state \
+ |NN AV * stack \
+ |const IV fence|NN AV * fence_stack
+#endif
Es |void|parse_lparen_question_flags|NN RExC_state_t *pRExC_state
Es |regnode*|reg_node |NN RExC_state_t *pRExC_state|U8 op
Es |regnode*|regpiece |NN RExC_state_t *pRExC_state \
ERs |bool |isFOO_lc |const U8 classnum|const U8 character
ERs |bool |isFOO_utf8_lc |const U8 classnum|NN const U8* character
ERs |SSize_t|regmatch |NN regmatch_info *reginfo|NN char *startpos|NN regnode *prog
-ERs |I32 |regrepeat |NN regexp *prog|NN char **startposp \
+WERs |I32 |regrepeat |NN regexp *prog|NN char **startposp \
|NN const regnode *p \
|NN regmatch_info *const reginfo \
- |I32 max \
- |int depth
+ |I32 max
ERs |bool |regtry |NN regmatch_info *reginfo|NN char **startposp
ERs |bool |reginclass |NULLOK regexp * const prog \
|NN const regnode * const n \
|NN const U8 * const p \
|NN const U8 * const p_end \
|bool const utf8_target
-Es |CHECKPOINT|regcppush |NN const regexp *rex|I32 parenfloor\
+WEs |CHECKPOINT|regcppush |NN const regexp *rex|I32 parenfloor\
|U32 maxopenparen
-Es |void |regcppop |NN regexp *rex\
- |NN U32 *maxopenparen_p
+WEs |void |regcppop |NN regexp *rex|NN U32 *maxopenparen_p
+WEs |void |regcp_restore |NN regexp *rex|I32 ix|NN U32 *maxopenparen_p
ERsn |U8* |reghop3 |NN U8 *s|SSize_t off|NN const U8 *lim
ERsn |U8* |reghop4 |NN U8 *s|SSize_t off|NN const U8 *llim \
|NN const U8 *rlim
#define intro_my() Perl_intro_my(aTHX)
#define isALNUM_lazy(a) Perl_isALNUM_lazy(aTHX_ a)
#define isIDFIRST_lazy(a) Perl_isIDFIRST_lazy(aTHX_ a)
+#define is_c9strict_utf8_string S_is_c9strict_utf8_string
+#define is_c9strict_utf8_string_loclen S_is_c9strict_utf8_string_loclen
#define is_lvalue_sub() Perl_is_lvalue_sub(aTHX)
+#define is_strict_utf8_string S_is_strict_utf8_string
+#define is_strict_utf8_string_loclen S_is_strict_utf8_string_loclen
#define is_uni_alnum(a) Perl_is_uni_alnum(aTHX_ a)
#define is_uni_alnum_lc(a) Perl_is_uni_alnum_lc(aTHX_ a)
#define is_uni_alnumc(a) Perl_is_uni_alnumc(aTHX_ a)
#define is_utf8_char Perl_is_utf8_char
#define is_utf8_cntrl(a) Perl_is_utf8_cntrl(aTHX_ a)
#define is_utf8_digit(a) Perl_is_utf8_digit(aTHX_ a)
+#define is_utf8_fixed_width_buf_loclen_flags S_is_utf8_fixed_width_buf_loclen_flags
#define is_utf8_graph(a) Perl_is_utf8_graph(aTHX_ a)
#define is_utf8_idcont(a) Perl_is_utf8_idcont(aTHX_ a)
#define is_utf8_idfirst(a) Perl_is_utf8_idfirst(aTHX_ a)
#define is_utf8_punct(a) Perl_is_utf8_punct(aTHX_ a)
#define is_utf8_space(a) Perl_is_utf8_space(aTHX_ a)
#define is_utf8_string Perl_is_utf8_string
+#define is_utf8_string_flags S_is_utf8_string_flags
#define is_utf8_string_loclen Perl_is_utf8_string_loclen
+#define is_utf8_string_loclen_flags S_is_utf8_string_loclen_flags
#define is_utf8_upper(a) Perl_is_utf8_upper(aTHX_ a)
#define is_utf8_valid_partial_char_flags S_is_utf8_valid_partial_char_flags
#define is_utf8_xdigit(a) Perl_is_utf8_xdigit(aTHX_ a)
#define sv_setnv(a,b) Perl_sv_setnv(aTHX_ a,b)
#define sv_setnv_mg(a,b) Perl_sv_setnv_mg(aTHX_ a,b)
#define sv_setpv(a,b) Perl_sv_setpv(aTHX_ a,b)
+#define sv_setpv_bufsize(a,b,c) Perl_sv_setpv_bufsize(aTHX_ a,b,c)
#define sv_setpv_mg(a,b) Perl_sv_setpv_mg(aTHX_ a,b)
#ifndef PERL_IMPLICIT_CONTEXT
#define sv_setpvf Perl_sv_setpvf
#define utf8_to_uvchr(a,b) Perl_utf8_to_uvchr(aTHX_ a,b)
#define utf8_to_uvuni(a,b) Perl_utf8_to_uvuni(aTHX_ a,b)
#define utf8_to_uvuni_buf(a,b,c) Perl_utf8_to_uvuni_buf(aTHX_ a,b,c)
-#define utf8n_to_uvchr(a,b,c,d) Perl_utf8n_to_uvchr(aTHX_ a,b,c,d)
+#define utf8n_to_uvchr_error(a,b,c,d,e) Perl_utf8n_to_uvchr_error(aTHX_ a,b,c,d,e)
#define utf8n_to_uvuni(a,b,c,d) Perl_utf8n_to_uvuni(aTHX_ a,b,c,d)
#define uvoffuni_to_utf8_flags(a,b,c) Perl_uvoffuni_to_utf8_flags(aTHX_ a,b,c)
#define uvuni_to_utf8(a,b) Perl_uvuni_to_utf8(aTHX_ a,b)
#endif
# endif
# endif
+# if defined(DEBUGGING) && defined(ENABLE_REGEX_SETS_DEBUGGING)
+# if defined(PERL_IN_REGCOMP_C)
+#define dump_regex_sets_structures(a,b,c,d) S_dump_regex_sets_structures(aTHX_ a,b,c,d)
+# endif
+# endif
# if defined(PERL_ANY_COW)
#define sv_setsv_cow(a,b) Perl_sv_setsv_cow(aTHX_ a,b)
# endif
#define isSB(a,b,c,d,e,f) S_isSB(aTHX_ a,b,c,d,e,f)
#define isWB(a,b,c,d,e,f,g) S_isWB(aTHX_ a,b,c,d,e,f,g)
#define reg_check_named_buff_matched S_reg_check_named_buff_matched
-#define regcppop(a,b) S_regcppop(aTHX_ a,b)
-#define regcppush(a,b,c) S_regcppush(aTHX_ a,b,c)
+#define regcp_restore(a,b,c) S_regcp_restore(aTHX_ a,b,c _aDEPTH)
+#define regcppop(a,b) S_regcppop(aTHX_ a,b _aDEPTH)
+#define regcppush(a,b,c) S_regcppush(aTHX_ a,b,c _aDEPTH)
#define reghop3 S_reghop3
#define reghop4 S_reghop4
#define reghopmaybe3 S_reghopmaybe3
#define reginclass(a,b,c,d,e) S_reginclass(aTHX_ a,b,c,d,e)
#define regmatch(a,b,c) S_regmatch(aTHX_ a,b,c)
-#define regrepeat(a,b,c,d,e,f) S_regrepeat(aTHX_ a,b,c,d,e,f)
+#define regrepeat(a,b,c,d,e) S_regrepeat(aTHX_ a,b,c,d,e _aDEPTH)
#define regtry(a,b) S_regtry(aTHX_ a,b)
#define to_byte_substr(a) S_to_byte_substr(aTHX_ a)
#define to_utf8_substr(a) S_to_utf8_substr(aTHX_ a)
#define isa_lookup(a,b,c,d) S_isa_lookup(aTHX_ a,b,c,d)
# endif
# if defined(PERL_IN_UTF8_C)
+#define _byte_dump_string(a,b) S__byte_dump_string(aTHX_ a,b)
#define _to_utf8_case(a,b,c,d,e,f,g) S__to_utf8_case(aTHX_ a,b,c,d,e,f,g)
#define check_locale_boundary_crossing(a,b,c,d) S_check_locale_boundary_crossing(aTHX_ a,b,c,d)
+#define does_utf8_overflow S_does_utf8_overflow
#define is_utf8_common(a,b,c,d) S_is_utf8_common(aTHX_ a,b,c,d)
#define is_utf8_cp_above_31_bits S_is_utf8_cp_above_31_bits
+#define is_utf8_overlong_given_start_byte_ok S_is_utf8_overlong_given_start_byte_ok
#define swash_scan_list_line(a,b,c,d,e,f,g) S_swash_scan_list_line(aTHX_ a,b,c,d,e,f,g)
#define swatch_get(a,b,c) S_swatch_get(aTHX_ a,b,c)
#define to_lower_latin1 S_to_lower_latin1
+#define unexpected_non_continuation_text(a,b,c,d) S_unexpected_non_continuation_text(aTHX_ a,b,c,d)
# endif
# if defined(PERL_IN_UTF8_C) || defined(PERL_IN_PP_C)
#define _to_upper_title_latin1(a,b,c,d) Perl__to_upper_title_latin1(aTHX_ a,b,c,d)
# walkoptree comes from B.xs
BEGIN {
- $B::VERSION = '1.63';
+ $B::VERSION = '1.64';
@B::EXPORT_OK = ();
# Our BOOT code needs $VERSION set, and will append to @EXPORT_OK.
ref = walkoptree(aTHX_ kid, method, ref);
}
}
- if (o && (cc_opclass(aTHX_ o) == OPc_PMOP) && o->op_type != OP_PUSHRE
+ if (o && (cc_opclass(aTHX_ o) == OPc_PMOP) && o->op_type != OP_SPLIT
&& (kid = PMOP_pmreplroot(cPMOPo)))
{
ref = walkoptree(aTHX_ kid, method, ref);
int i;
IV result = -1;
ST(0) = sv_newmortal();
- if (strncmp(name,"pp_",3) == 0)
+ if (strEQs(name,"pp_"))
name += 3;
for (i = 0; i < PL_maxo; i++)
{
- if (strcmp(name, PL_op_name[i]) == 0)
+ if (strEQ(name, PL_op_name[i]))
{
result = i;
break;
}
break;
case 34: /* B::PMOP::pmreplroot */
- if (cPMOPo->op_type == OP_PUSHRE) {
-#ifdef USE_ITHREADS
- ret = sv_newmortal();
- sv_setiv(ret, cPMOPo->op_pmreplrootu.op_pmtargetoff);
-#else
- GV *const target = cPMOPo->op_pmreplrootu.op_pmtargetgv;
+ if (cPMOPo->op_type == OP_SPLIT) {
ret = sv_newmortal();
- sv_setiv(newSVrv(ret, target ?
- svclassnames[SvTYPE((SV*)target)] : "B::SV"),
- PTR2IV(target));
+#ifndef USE_ITHREADS
+ if (o->op_private & OPpSPLIT_LEX)
+#endif
+ sv_setiv(ret, cPMOPo->op_pmreplrootu.op_pmtargetoff);
+#ifndef USE_ITHREADS
+ else {
+ GV *const target = cPMOPo->op_pmreplrootu.op_pmtargetgv;
+ sv_setiv(newSVrv(ret, target ?
+ svclassnames[SvTYPE((SV*)target)] : "B::SV"),
+ PTR2IV(target));
+ }
#endif
}
else {
use Exporter (); # use #5
-our $VERSION = "0.998";
+our $VERSION = "0.999";
our @ISA = qw(Exporter);
our @EXPORT_OK = qw( set_style set_style_standard add_callback
concise_subref concise_cv concise_main
# use #6
use B qw(class ppname main_start main_root main_cv cstring svref_2object
SVf_IOK SVf_NOK SVf_POK SVf_IVisUV SVf_FAKE OPf_KIDS OPf_SPECIAL
+ OPf_STACKED
+ OPpSPLIT_ASSIGN OPpSPLIT_LEX
CVf_ANON PAD_FAKELEX_ANON PAD_FAKELEX_MULTI SVf_ROK);
my %style =
$srclines{$fullnm} = \@l;
}
+# Given a pad target, return the pad var's name and cop range /
+# fakeness, or failing that, its target number.
+# e.g.
+# ('$i', '$i:5,7')
+# or
+# ('$i', '$i:fake:a')
+# or
+# ('t5', 't5')
+
+sub padname {
+ my ($targ) = @_;
+
+ my ($targarg, $targarglife);
+ my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$targ];
+ if (defined $padname and class($padname) ne "SPECIAL" and
+ $padname->LEN)
+ {
+ $targarg = $padname->PVX;
+ if ($padname->FLAGS & SVf_FAKE) {
+ # These changes relate to the jumbo closure fix.
+ # See changes 19939 and 20005
+ my $fake = '';
+ $fake .= 'a'
+ if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_ANON;
+ $fake .= 'm'
+ if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_MULTI;
+ $fake .= ':' . $padname->PARENT_PAD_INDEX
+ if $curcv->CvFLAGS & CVf_ANON;
+ $targarglife = "$targarg:FAKE:$fake";
+ }
+ else {
+ my $intro = $padname->COP_SEQ_RANGE_LOW - $cop_seq_base;
+ my $finish = int($padname->COP_SEQ_RANGE_HIGH) - $cop_seq_base;
+ $finish = "end" if $finish == 999999999 - $cop_seq_base;
+ $targarglife = "$targarg:$intro,$finish";
+ }
+ } else {
+ $targarglife = $targarg = "t" . $targ;
+ }
+ return $targarg, $targarglife;
+}
+
+
+
sub concise_op {
my ($op, $level, $format) = @_;
my %h;
: 1;
my (@targarg, @targarglife);
for my $i (0..$count-1) {
- my ($targarg, $targarglife);
- my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$h{targ}+$i];
- if (defined $padname and class($padname) ne "SPECIAL" and
- $padname->LEN)
- {
- $targarg = $padname->PVX;
- if ($padname->FLAGS & SVf_FAKE) {
- # These changes relate to the jumbo closure fix.
- # See changes 19939 and 20005
- my $fake = '';
- $fake .= 'a'
- if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_ANON;
- $fake .= 'm'
- if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_MULTI;
- $fake .= ':' . $padname->PARENT_PAD_INDEX
- if $curcv->CvFLAGS & CVf_ANON;
- $targarglife = "$targarg:FAKE:$fake";
- }
- else {
- my $intro = $padname->COP_SEQ_RANGE_LOW - $cop_seq_base;
- my $finish = int($padname->COP_SEQ_RANGE_HIGH) - $cop_seq_base;
- $finish = "end" if $finish == 999999999 - $cop_seq_base;
- $targarglife = "$targarg:$intro,$finish";
- }
- } else {
- $targarglife = $targarg = "t" . ($h{targ}+$i);
- }
+ my ($targarg, $targarglife) = padname($h{targ} + $i);
push @targarg, $targarg;
push @targarglife, $targarglife;
}
$extra = " replstart->" . seq($op->pmreplstart);
}
}
- elsif ($op->name eq 'pushre') {
- # with C<@stash_array = split(/pat/, str);>,
- # *stash_array is stored in /pat/'s pmreplroot.
- my $gv = $op->pmreplroot;
- if (!ref($gv)) {
- # threaded: the value is actually a pad offset for where
- # the GV is kept (op_pmtargetoff)
- if ($gv) {
- $gv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$gv]->NAME;
- }
- }
- else {
- # unthreaded: its a GV (if it exists)
- $gv = (ref($gv) eq "B::GV") ? $gv->NAME : undef;
- }
- $extra = " => \@$gv" if $gv;
+ elsif ($op->name eq 'split') {
+ if ( ($op->private & OPpSPLIT_ASSIGN) # @array = split
+ && (not $op->flags & OPf_STACKED)) # @{expr} = split
+ {
+ # with C<@array = split(/pat/, str);>,
+ # array is stored in /pat/'s pmreplroot; either
+ # as an integer index into the pad (for a lexical array)
+ # or as GV for a package array (which will be a pad index
+ # on threaded builds)
+
+ if ($op->private & $B::Op_private::defines{'OPpSPLIT_LEX'}) {
+ my $off = $op->pmreplroot; # union with op_pmtargetoff
+ my ($name, $full) = padname($off);
+ $extra = " => $full";
+ }
+ else {
+ # union with op_pmtargetoff, op_pmtargetgv
+ my $gv = $op->pmreplroot;
+ if (!ref($gv)) {
+ # the value is actually a pad offset
+ $gv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$gv]->NAME;
+ }
+ else {
+ # unthreaded: its a GV
+ $gv = $gv->NAME;
+ }
+ $extra = " => \@$gv";
+ }
+ }
}
$h{arg} = "($precomp$extra)";
} elsif ($h{class} eq "PVOP" and $h{name} !~ '^transr?\z') {
is(B::class(bless {}, "Wibble::Bibble"), "Bibble", "Testing B::class()");
is(B::cast_I32(3.14), 3, "Testing B::cast_I32()");
-is(B::opnumber("chop"), $] >= 5.015 ? 39 : 38,
- "Testing opnumber with opname (chop)");
+is(B::opnumber("chop"), 38, "Testing opnumber with opname (chop)");
{
no warnings 'once';
UNOP (0x82b0918) leavesub [1]
LISTOP (0x82b08d8) lineseq
COP (0x82b0880) nextstate
- UNOP (0x82b0860) null [15]
+ UNOP (0x82b0860) null [14]
PADOP (0x82b0840) gvsv GV (0x82a818c) *a
EOT_EOT
# UNOP (0x8282310) leavesub [1]
# LISTOP (0x82822f0) lineseq
# COP (0x82822b8) nextstate
-# UNOP (0x812fc20) null [15]
+# UNOP (0x812fc20) null [14]
# SVOP (0x812fc00) gvsv GV (0x814692c) *a
EONT_EONT
# 3 <;> nextstate(main 636 optree_misc.t:25) v:>,<,%,{ ->4
# 6 <2> add[t6] sK/2 ->7
# - <1> ex-aelem sK/2 ->5
-# 4 <0> aelemfast_lex[@x:634,636] sR/127 ->5
+# 4 <0> aelemfast_lex[@x:634,636] sR/key=127 ->5
# - <0> ex-const s ->-
# - <1> ex-aelem sK/2 ->6
# - <1> ex-rv2av sKR/1 ->-
-# 5 <#> aelemfast[*y] s/128 ->6
+# 5 <#> aelemfast[*y] s/key=128 ->6
# - <0> ex-const s/FOLD ->-
EOT_EOT
# 7 <1> leavesub[1 ref] K/REFC,1 ->(end)
# 3 <;> nextstate(main 636 optree_misc.t:27) v:>,<,%,{ ->4
# 6 <2> add[t4] sK/2 ->7
# - <1> ex-aelem sK/2 ->5
-# 4 <0> aelemfast_lex[@x:634,636] sR/127 ->5
+# 4 <0> aelemfast_lex[@x:634,636] sR/key=127 ->5
# - <0> ex-const s ->-
# - <1> ex-aelem sK/2 ->6
# - <1> ex-rv2av sKR/1 ->-
-# 5 <$> aelemfast(*y) s/128 ->6
+# 5 <$> aelemfast(*y) s/key=128 ->6
# - <0> ex-const s/FOLD ->-
EONT_EONT
# - <@> 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
+# 2 <0> padrange[$x:1,2; $y:1,2] vM/LVINTRO,range=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/COM_AGG ->9
# - <1> ex-list lKP ->5
-# 4 <0> padrange[$x:1,2; $y:1,2] /2 ->5
+# 4 <0> padrange[$x:1,2; $y:1,2] /range=2 ->5
# - <0> padsv[$x:1,2] s ->-
# - <0> padsv[$y:1,2] s ->-
# - <1> ex-list lK ->8
# 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] RM/2 ->e
+# d <0> padrange[$x:1,2; $y:1,2] RM/range=2 ->e
# - <0> padsv[$x:1,2] sRM* ->-
# - <0> padsv[$y:1,2] sRM* ->-
EOT_EOT
# - <@> 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
+# 2 <0> padrange[$x:1,2; $y:1,2] vM/LVINTRO,range=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/COM_AGG ->9
# - <1> ex-list lKP ->5
-# 4 <0> padrange[$x:1,2; $y:1,2] /2 ->5
+# 4 <0> padrange[$x:1,2; $y:1,2] /range=2 ->5
# - <0> padsv[$x:1,2] s ->-
# - <0> padsv[$y:1,2] s ->-
# - <1> ex-list lK ->8
# 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] RM/2 ->e
+# d <0> padrange[$x:1,2; $y:1,2] RM/range=2 ->e
# - <0> padsv[$x:1,2] sRM* ->-
# - <0> padsv[$y:1,2] sRM* ->-
EONT_EONT
# 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] */LVINTRO,2 ->3
+# 2 <0> padrange[$a:1,4; $b:1,4] */LVINTRO,range=2 ->3
# - <1> rv2av[t4] lK/1 ->-
# - <#> gv[*_] s ->-
# - <1> ex-list lKPRM* ->3
# 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] RM/LVINTRO,2 ->9
+# 8 <0> padrange[$c:2,4; $d:2,4] RM/LVINTRO,range=2 ->9
# - <0> padsv[$c:2,4] sRM*/LVINTRO ->-
# - <0> padsv[$d:2,4] sRM*/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] */LVINTRO,2 ->c
+# b <0> padrange[$e:3,4; $f:3,4] */LVINTRO,range=2 ->c
# - <1> rv2av[t14] lK/1 ->-
# - <#> gv[*_] s ->-
# - <1> ex-list lKPRM* ->c
# 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] */LVINTRO,2 ->3
+# 2 <0> padrange[$a:1,4; $b:1,4] */LVINTRO,range=2 ->3
# - <1> rv2av[t4] lK/1 ->-
# - <$> gv(*_) s ->-
# - <1> ex-list lKPRM* ->3
# 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] RM/LVINTRO,2 ->9
+# 8 <0> padrange[$c:2,4; $d:2,4] RM/LVINTRO,range=2 ->9
# - <0> padsv[$c:2,4] sRM*/LVINTRO ->-
# - <0> padsv[$d:2,4] sRM*/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] */LVINTRO,2 ->c
+# b <0> padrange[$e:3,4; $f:3,4] */LVINTRO,range=2 ->c
# - <1> rv2av[t14] lK/1 ->-
# - <$> gv(*_) s ->-
# - <1> ex-list lKPRM* ->c
# - <@> 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
+# 2 <0> padrange[$a:900,902; $b:900,902; $c:901,902; $d:901,902] vM/LVINTRO,range=4 ->3
# - <0> padsv[$a:900,902] vM/LVINTRO ->-
# - <0> padsv[$b:900,902] vM/LVINTRO ->-
# - <;> nextstate(main 901 optree_misc.t:334) v:>,<,% ->-
# - <@> 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
+# 2 <0> padrange[$a:900,902; $b:900,902; $c:901,902; $d:901,902] vM/LVINTRO,range=4 ->3
# - <0> padsv[$a:900,902] vM/LVINTRO ->-
# - <0> padsv[$b:900,902] vM/LVINTRO ->-
# - <;> nextstate(main 901 optree_misc.t:334) v:>,<,% ->-
# - <@> 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
+# 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,range=10 ->3
# - <0> padsv[$a:903,910] vM/LVINTRO ->-
# - <0> padsv[$b:903,910] vM/LVINTRO ->-
# - <;> nextstate(main 904 optree_misc.t:371) v:>,<,% ->-
# - <@> 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
+# 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,range=10 ->3
# - <0> padsv[$a:903,910] vM/LVINTRO ->-
# - <0> padsv[$b:903,910] vM/LVINTRO ->-
# - <;> nextstate(main 904 optree_misc.t:371) v:>,<,% ->-
bcopts => '-exec',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1 <;> nextstate(main 991 (eval 17):1) v
-# 2 <0> padrange[$a:991,994; @b:992,994; %c:993,994] vM/LVINTRO,3
+# 2 <0> padrange[$a:991,994; @b:992,994; %c:993,994] vM/LVINTRO,range=3
# 3 <;> nextstate(main 994 (eval 17):1) v:{
# 4 <$> const[IV 1] s
# 5 <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 991 (eval 17):1) v
-# 2 <0> padrange[$a:991,994; @b:992,994; %c:993,994] vM/LVINTRO,3
+# 2 <0> padrange[$a:991,994; @b:992,994; %c:993,994] vM/LVINTRO,range=3
# 3 <;> nextstate(main 994 (eval 17):1) v:{
# 4 <$> const(IV 1) s
# 5 <1> leavesub[1 ref] K/REFC,1
# 1 <0> enter
# 2 <;> nextstate(main 1 -e:1) v:>,<,%,{
# 3 <0> pushmark s
-# 4 <0> padrange[$a:1,2; $b:1,2] RM/LVINTRO,2
+# 4 <0> padrange[$a:1,2; $b:1,2] RM/LVINTRO,range=2
# 5 <2> aassign[t3] vKS
# 6 <@> leave[1 ref] vKP/REFC
EOT_EOT
# 1 <0> enter
# 2 <;> nextstate(main 1 -e:1) v:>,<,%,{
# 3 <0> pushmark s
-# 4 <0> padrange[$a:1,2; $b:1,2] RM/LVINTRO,2
+# 4 <0> padrange[$a:1,2; $b:1,2] RM/LVINTRO,range=2
# 5 <2> aassign[t3] vKS
# 6 <@> leave[1 ref] vKP/REFC
EONT_EONT
$_[0] =~ s/(a)/ $1/;
# PMOP_pmreplroot(cPMOPo) is NULL for this
$_[0] =~ s/(b)//;
- # This gives an OP_PUSHRE
+ # This gives an OP_SPLIT
split /c/;
};
is (B::walkoptree_debug, 0, 'walkoptree_debug() is 0');
B::walkoptree(B::svref_2object($victim)->ROOT, "pie");
-foreach (qw(substcont pushre split leavesub)) {
+foreach (qw(substcont split split leavesub)) {
is ($seen{$_}, 1, "Our victim had a $_ OP");
}
is_deeply ([keys %debug], [], 'walkoptree_debug was not called');
%seen = ();
B::walkoptree(B::svref_2object($victim)->ROOT, "pie");
-foreach (qw(substcont pushre split leavesub)) {
+foreach (qw(substcont split split leavesub)) {
is ($seen{$_}, 1, "Our victim had a $_ OP");
}
is_deeply (\%debug, \%seen, 'walkoptree_debug was called correctly');
package Devel::Peek;
-$VERSION = '1.24';
+$VERSION = '1.25';
$XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
SV **svp;
int type;
- svp = hv_fetch(hv, "topbucket", 9, 1);
+ svp = hv_fetchs(hv, "topbucket", 1);
sv_setiv(*svp, b->buffer.topbucket);
- svp = hv_fetch(hv, "topbucket_ev", 12, 1);
+ svp = hv_fetchs(hv, "topbucket_ev", 1);
sv_setiv(*svp, b->buffer.topbucket_ev);
- svp = hv_fetch(hv, "topbucket_odd", 13, 1);
+ svp = hv_fetchs(hv, "topbucket_odd", 1);
sv_setiv(*svp, b->buffer.topbucket_odd);
- svp = hv_fetch(hv, "totfree", 7, 1);
+ svp = hv_fetchs(hv, "totfree", 1);
sv_setiv(*svp, b->buffer.totfree);
- svp = hv_fetch(hv, "total", 5, 1);
+ svp = hv_fetchs(hv, "total", 1);
sv_setiv(*svp, b->buffer.total);
- svp = hv_fetch(hv, "total_chain", 11, 1);
+ svp = hv_fetchs(hv, "total_chain", 1);
sv_setiv(*svp, b->buffer.total_chain);
- svp = hv_fetch(hv, "total_sbrk", 10, 1);
+ svp = hv_fetchs(hv, "total_sbrk", 1);
sv_setiv(*svp, b->buffer.total_sbrk);
- svp = hv_fetch(hv, "sbrks", 5, 1);
+ svp = hv_fetchs(hv, "sbrks", 1);
sv_setiv(*svp, b->buffer.sbrks);
- svp = hv_fetch(hv, "sbrk_good", 9, 1);
+ svp = hv_fetchs(hv, "sbrk_good", 1);
sv_setiv(*svp, b->buffer.sbrk_good);
- svp = hv_fetch(hv, "sbrk_slack", 10, 1);
+ svp = hv_fetchs(hv, "sbrk_slack", 1);
sv_setiv(*svp, b->buffer.sbrk_slack);
- svp = hv_fetch(hv, "start_slack", 11, 1);
+ svp = hv_fetchs(hv, "start_slack", 1);
sv_setiv(*svp, b->buffer.start_slack);
- svp = hv_fetch(hv, "sbrked_remains", 14, 1);
+ svp = hv_fetchs(hv, "sbrked_remains", 1);
sv_setiv(*svp, b->buffer.sbrked_remains);
- svp = hv_fetch(hv, "minbucket", 9, 1);
+ svp = hv_fetchs(hv, "minbucket", 1);
sv_setiv(*svp, b->buffer.minbucket);
- svp = hv_fetch(hv, "nbuckets", 8, 1);
+ svp = hv_fetchs(hv, "nbuckets", 1);
sv_setiv(*svp, b->buffer.nbuckets);
if (_NBUCKETS < b->buffer.nbuckets)
our($VERSION, @ISA, @EXPORT_OK);
-$VERSION = "1.37";
+$VERSION = "1.38";
use Carp;
use Exporter ();
bless -- could be used to change ownership of objects
(reblessing)
- pushre regcmaybe regcreset regcomp subst substcont
+ regcmaybe regcreset regcomp subst substcont
sprintf prtf -- can core dump
#endif
'});
-push @names,
- {name=>"INFINITY", type=>"NV", value=>"NV_INF", not_constant=>1},
- {name=>"NAN", type=>"NV", value=>"NV_NAN", not_constant=>1},
- {name=>"Inf", type=>"NV", value=>"NV_INF", not_constant=>1},
- {name=>"NaN", type=>"NV", value=>"NV_NAN", not_constant=>1};
+unless ($Config{doublekind} == 9 ||
+ $Config{doublekind} == 10 ||
+ $Config{doublekind} == 11) {
+ push @names,
+ {name=>"INFINITY", type=>"NV", value=>"NV_INF", not_constant=>1},
+ {name=>"NAN", type=>"NV", value=>"NV_NAN", not_constant=>1},
+ {name=>"Inf", type=>"NV", value=>"NV_INF", not_constant=>1},
+ {name=>"NaN", type=>"NV", value=>"NV_NAN", not_constant=>1};
+}
push @names, {name=>$_, type=>"UV"}
foreach (qw(SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK SA_RESETHAND
#define PERLIO_NOT_STDIO 1
#include "perl.h"
#include "XSUB.h"
+
+static int not_here(const char *s);
+
#if defined(PERL_IMPLICIT_SYS)
# undef signal
# undef open
#include <float.h>
#endif
#ifdef I_FENV
+#if !(defined(__vax__) && defined(__NetBSD__))
#include <fenv.h>
#endif
+#endif
#ifdef I_LIMITS
#include <limits.h>
#endif
#ifndef c99_fdim
static NV my_fdim(NV x, NV y)
{
+#ifdef NV_NAN
return (Perl_isnan(x) || Perl_isnan(y)) ? NV_NAN : (x > y ? x - y : 0);
+#else
+ return (x > y ? x - y : 0);
+#endif
}
# define c99_fdim my_fdim
#endif
#ifndef c99_fmax
static NV my_fmax(NV x, NV y)
{
+#ifdef NV_NAN
if (Perl_isnan(x)) {
return Perl_isnan(y) ? NV_NAN : y;
} else if (Perl_isnan(y)) {
return x;
}
+#endif
return x > y ? x : y;
}
# define c99_fmax my_fmax
#ifndef c99_fmin
static NV my_fmin(NV x, NV y)
{
+#ifdef NV_NAN
if (Perl_isnan(x)) {
return Perl_isnan(y) ? NV_NAN : y;
} else if (Perl_isnan(y)) {
return x;
}
+#endif
return x < y ? x : y;
}
# define c99_fmin my_fmin
x = PERL_ABS(x); /* Take absolute values. */
if (y == 0)
return x;
+#ifdef NV_INF
if (Perl_isnan(y))
return NV_INF;
+#endif
y = PERL_ABS(y);
if (x < y) { /* Swap so that y is less. */
t = x;
static NV my_tgamma(NV x)
{
const NV gamma = 0.577215664901532860606512090; /* Euler's gamma constant. */
+#ifdef NV_NAN
if (Perl_isnan(x) || x < 0.0)
return NV_NAN;
+#endif
+#ifdef NV_INF
if (x == 0.0 || x == NV_INF)
return x == -0.0 ? -NV_INF : NV_INF;
+#endif
/* The function domain is split into three intervals:
* (0, 0.001), [0.001, 12), and (12, infinity) */
return result;
}
+#ifdef NV_INF
/* Third interval: [12, +Inf) */
#if LDBL_MANT_DIG == 113 /* IEEE quad prec */
if (x > 1755.548) {
return NV_INF;
}
#endif
+#endif
return Perl_exp(c99_lgamma(x));
}
#ifdef USE_MY_LGAMMA
static NV my_lgamma(NV x)
{
+#ifdef NV_NAN
if (Perl_isnan(x))
return NV_NAN;
+#endif
+#ifdef NV_INF
if (x <= 0 || x == NV_INF)
return NV_INF;
+#endif
if (x == 1.0 || x == 2.0)
return 0;
if (x < 12.0)
{
/* http://www.johndcook.com/cpp_log_one_plus_x.html -- public domain.
* Taylor series, the first four terms (the last term quartic). */
+#ifdef NV_NAN
if (x < -1.0)
return NV_NAN;
+#endif
+#ifdef NV_INF
if (x == -1.0)
return -NV_INF;
+#endif
if (PERL_ABS(x) > 1e-4)
return Perl_log(1.0 + x);
else
case FE_TOWARDZERO: return MY_ROUND_TRUNC(x);
case FE_DOWNWARD: return MY_ROUND_DOWN(x);
case FE_UPWARD: return MY_ROUND_UP(x);
- default: return NV_NAN;
+ default: break;
}
#elif defined(HAS_FPGETROUND)
switch (fpgetround()) {
case FP_RZ: return MY_ROUND_TRUNC(x);
case FP_RM: return MY_ROUND_DOWN(x);
case FE_RP: return MY_ROUND_UP(x);
- default: return NV_NAN;
+ default: break;
}
-#else
- return NV_NAN;
#endif
+ not_here("rint");
}
#endif
# define c99_trunc my_trunc
#endif
+#ifdef NV_NAN
+
#undef NV_PAYLOAD_DEBUG
/* NOTE: the NaN payload API implementation is hand-rolled, since the
return payload;
}
+#endif /* #ifdef NV_NAN */
+
/* XXX This comment is just to make I_TERMIO and I_SGTTY visible to
metaconfig for future extension writers. We don't use them in POSIX.
(This is really sneaky :-) --AD
y1 = 30
CODE:
PERL_UNUSED_VAR(x);
+#ifdef NV_NAN
RETVAL = NV_NAN;
+#else
+ RETVAL = 0;
+#endif
switch (ix) {
case 0:
RETVAL = Perl_acos(x); /* C89 math */
getpayload(nv)
NV nv
CODE:
+#ifdef DOUBLE_HAS_NAN
RETVAL = S_getpayload(nv);
+#else
+ PERL_UNUSED_VAR(nv);
+ not_here("getpayload");
+#endif
OUTPUT:
RETVAL
NV nv
NV payload
CODE:
+#ifdef DOUBLE_HAS_NAN
S_setpayload(&nv, payload, FALSE);
+#else
+ PERL_UNUSED_VAR(nv);
+ PERL_UNUSED_VAR(payload);
+ not_here("setpayload");
+#endif
OUTPUT:
nv
NV nv
NV payload
CODE:
+#ifdef DOUBLE_HAS_NAN
nv = NV_NAN;
S_setpayload(&nv, payload, TRUE);
+#else
+ PERL_UNUSED_VAR(nv);
+ PERL_UNUSED_VAR(payload);
+ not_here("setpayloadsig");
+#endif
OUTPUT:
nv
issignaling(nv)
NV nv
CODE:
+#ifdef DOUBLE_HAS_NAN
RETVAL = Perl_isnan(nv) && NV_NAN_IS_SIGNALING(&nv);
+#else
+ PERL_UNUSED_VAR(nv);
+ not_here("issignaling");
+#endif
OUTPUT:
RETVAL
CODE:
PERL_UNUSED_VAR(x);
PERL_UNUSED_VAR(y);
+#ifdef NV_NAN
RETVAL = NV_NAN;
+#else
+ RETVAL = 0;
+#endif
switch (ix) {
case 0:
#ifdef c99_copysign
}
#elif defined(c99_nan)
{
- STRLEN elen = my_snprintf(PL_efloatbuf, PL_efloatsize, "%g", nv);
+ STRLEN elen = my_snprintf(PL_efloatbuf, PL_efloatsize, "%g", payload);
if ((IV)elen == -1) {
+#ifdef NV_NAN
RETVAL = NV_NAN;
+#else
+ not_here("nan");
+#endif
} else {
RETVAL = c99_nan(PL_efloatbuf);
}
ALIAS:
yn = 1
CODE:
+#ifdef NV_NAN
RETVAL = NV_NAN;
+#else
+ RETVAL = 0;
+#endif
switch (ix) {
case 0:
#ifdef bessel_jn
const char *s = SvPVX_const(ST(0));
int i = whichsig(s);
- if (i < 0 && memEQ(s, "SIG", 3))
+ if (i < 0 && _memEQs(s, "SIG"))
i = whichsig(s + 3);
if (i < 0) {
if (ckWARN(WARN_SIGNAL))
if (result == (time_t)-1)
SvOK_off(TARG);
else if (result == 0)
- sv_setpvn(TARG, "0 but true", 10);
+ sv_setpvs(TARG, "0 but true");
else
sv_setiv(TARG, (IV)result);
} else {
our ($AUTOLOAD, %SIGRT);
-our $VERSION = '1.72';
+our $VERSION = '1.73';
require XSLoader;
skip "no fpclassify", 4 unless $Config{d_fpclassify};
is(fpclassify(1), FP_NORMAL, "fpclassify 1");
is(fpclassify(0), FP_ZERO, "fpclassify 0");
+ skip("no inf/nan", 2) if ($Config{doublekind} == 9 ||
+ $Config{doublekind} == 10 ||
+ $Config{doublekind} == 11);
is(fpclassify(INFINITY), FP_INFINITE, "fpclassify INFINITY");
is(fpclassify(NAN), FP_NAN, "fpclassify NAN");
}
is(ilogb(255), 7, "ilogb 255");
is(ilogb(256), 8, "ilogb 256");
ok(isfinite(1), "isfinite 1");
- ok(!isfinite(Inf), "isfinite Inf");
- ok(!isfinite(NaN), "isfinite NaN");
- ok(isinf(INFINITY), "isinf INFINITY");
- ok(isinf(Inf), "isinf Inf");
- ok(!isinf(NaN), "isinf NaN");
ok(!isinf(42), "isinf 42");
- ok(isnan(NAN), "isnan NAN");
- ok(isnan(NaN), "isnan NaN");
- ok(!isnan(Inf), "isnan Inf");
ok(!isnan(42), "isnan Inf");
- cmp_ok(nan(), '!=', nan(), 'nan');
+ SKIP: {
+ skip("no inf/nan", 9) if ($Config{doublekind} == 9 ||
+ $Config{doublekind} == 10 ||
+ $Config{doublekind} == 11);
+ ok(!isfinite(Inf), "isfinite Inf");
+ ok(!isfinite(NaN), "isfinite NaN");
+ ok(isinf(INFINITY), "isinf INFINITY");
+ ok(isinf(Inf), "isinf Inf");
+ ok(!isinf(NaN), "isinf NaN");
+ ok(isnan(NAN), "isnan NAN");
+ ok(isnan(NaN), "isnan NaN");
+ ok(!isnan(Inf), "isnan Inf");
+ cmp_ok(nan(), '!=', nan(), 'nan');
+ }
near(log1p(2), 1.09861228866811, "log1p", 1e-9);
near(log1p(1e-6), 9.99999500000333e-07, "log1p", 1e-9);
near(log2(8), 3, "log2", 1e-9);
ok(isless(1, 2), "isless 1 2");
ok(!isless(2, 1), "isless 2 1");
ok(!isless(1, 1), "isless 1 1");
- ok(!isless(1, NaN), "isless 1 NaN");
ok(isgreater(2, 1), "isgreater 2 1");
ok(islessequal(1, 1), "islessequal 1 1");
- ok(isunordered(1, NaN), "isunordered 1 NaN");
+
+ SKIP: {
+ skip("no inf/nan", 2) if ($Config{doublekind} == 9 ||
+ $Config{doublekind} == 10 ||
+ $Config{doublekind} == 11);
+ ok(!isless(1, NaN), "isless 1 NaN");
+ ok(isunordered(1, NaN), "isunordered 1 NaN");
+ }
near(erf(0.5), 0.520499877813047, "erf 0.5", 1.5e-7);
near(erf(1), 0.842700792949715, "erf 1", 1.5e-7);
near(lgamma(5.5), 3.95781396761872, "lgamma 5.5", 1.5e-7);
near(lgamma(9), 10.6046029027452, "lgamma 9", 1.5e-7);
- # These don't work on old mips/hppa platforms because == Inf (or == -Inf).
- # ok(isnan(setpayload(0)), "setpayload zero");
- # is(getpayload(setpayload(0)), 0, "setpayload + getpayload (zero)");
- #
- # These don't work on most platforms because == Inf (or == -Inf).
- # ok(isnan(setpayloadsig(0)), "setpayload zero");
- # is(getpayload(setpayloadsig(0)), 0, "setpayload + getpayload (zero)");
-
- # Verify that the payload set be setpayload()
- # (1) still is a nan
- # (2) but the payload can be retrieved
- # (3) but is not signaling
- my $x = 0;
- setpayload($x, 0x12345);
- ok(isnan($x), "setpayload + isnan");
- is(getpayload($x), 0x12345, "setpayload + getpayload");
- ok(!issignaling($x), "setpayload + issignaling");
-
- # Verify that the signaling payload set be setpayloadsig()
- # (1) still is a nan
- # (2) but the payload can be retrieved
- # (3) and is signaling
- setpayloadsig($x, 0x12345);
- ok(isnan($x), "setpayloadsig + isnan");
- is(getpayload($x), 0x12345, "setpayloadsig + getpayload");
SKIP: {
- # https://rt.perl.org/Ticket/Display.html?id=125710
- # In the 32-bit x86 ABI cannot preserve the signaling bit
- # (the x87 simply does not preserve that). But using the
- # 80-bit extended format aka long double, the bit is preserved.
- # https://gcc.gnu.org/bugzilla/show_bug.cgi?id=57484
- my $could_be_x86_32 =
- # This is a really weak test: there are other 32-bit
- # little-endian platforms than just Intel (some embedded
- # processors, for example), but we use this just for not
- # bothering with the test if things look iffy.
- # We could, say, $Config{ccsymbols} =~ /\b__[xi][3-7]86=1\b/,
- # but that feels quite shaky.
- $Config{byteorder} =~ /1234/ &&
- $Config{longdblkind} == 3 &&
- $Config{ptrsize} == 4;
- skip($^O, 1) if $could_be_x86_32 && !$Config{uselongdouble};
- ok(issignaling($x), "setpayloadsig + issignaling");
- }
+ skip("no inf/nan", 19) if ($Config{doublekind} == 9 ||
+ $Config{doublekind} == 10 ||
+ $Config{doublekind} == 11);
+ # These don't work on old mips/hppa platforms
+ # because nan with payload zero == Inf (or == -Inf).
+ # ok(isnan(setpayload(0)), "setpayload zero");
+ # is(getpayload(setpayload(0)), 0, "setpayload + getpayload (zero)");
+ #
+ # These don't work on most platforms because == Inf (or == -Inf).
+ # ok(isnan(setpayloadsig(0)), "setpayload zero");
+ # is(getpayload(setpayloadsig(0)), 0, "setpayload + getpayload (zero)");
- # Try a payload more than one byte.
- is(getpayload(nan(0x12345)), 0x12345, "nan + getpayload");
+ # Verify that the payload set be setpayload()
+ # (1) still is a nan
+ # (2) but the payload can be retrieved
+ # (3) but is not signaling
+ my $x = 0;
+ setpayload($x, 0x12345);
+ ok(isnan($x), "setpayload + isnan");
+ is(getpayload($x), 0x12345, "setpayload + getpayload");
+ ok(!issignaling($x), "setpayload + issignaling");
- # Try payloads of 2^k, most importantly at and beyond 2^32. These
- # tests will fail if NV is just 32-bit float, but that Should Not
- # Happen (tm).
- is(getpayload(nan(2**31)), 2**31, "nan + getpayload 2**31");
- is(getpayload(nan(2**32)), 2**32, "nan + getpayload 2**32");
- is(getpayload(nan(2**33)), 2**33, "nan + getpayload 2**33");
+ # Verify that the signaling payload set be setpayloadsig()
+ # (1) still is a nan
+ # (2) but the payload can be retrieved
+ # (3) and is signaling
+ setpayloadsig($x, 0x12345);
+ ok(isnan($x), "setpayloadsig + isnan");
+ is(getpayload($x), 0x12345, "setpayloadsig + getpayload");
+ SKIP: {
+ # https://rt.perl.org/Ticket/Display.html?id=125710
+ # In the 32-bit x86 ABI cannot preserve the signaling bit
+ # (the x87 simply does not preserve that). But using the
+ # 80-bit extended format aka long double, the bit is preserved.
+ # https://gcc.gnu.org/bugzilla/show_bug.cgi?id=57484
+ my $could_be_x86_32 =
+ # This is a really weak test: there are other 32-bit
+ # little-endian platforms than just Intel (some embedded
+ # processors, for example), but we use this just for not
+ # bothering with the test if things look iffy.
+ # We could, say, $Config{ccsymbols} =~ /\b__[xi][3-7]86=1\b/,
+ # but that feels quite shaky.
+ $Config{byteorder} =~ /1234/ &&
+ $Config{longdblkind} == 3 &&
+ $Config{ptrsize} == 4;
+ skip($^O, 1) if $could_be_x86_32 && !$Config{uselongdouble};
+ ok(issignaling($x), "setpayloadsig + issignaling");
+ }
+
+ # Try a payload more than one byte.
+ is(getpayload(nan(0x12345)), 0x12345, "nan + getpayload");
+
+ # Try payloads of 2^k, most importantly at and beyond 2^32. These
+ # tests will fail if NV is just 32-bit float, but that Should Not
+ # Happen (tm).
+ is(getpayload(nan(2**31)), 2**31, "nan + getpayload 2**31");
+ is(getpayload(nan(2**32)), 2**32, "nan + getpayload 2**32");
+ is(getpayload(nan(2**33)), 2**33, "nan + getpayload 2**33");
- # Payloads just lower than 2^k.
- is(getpayload(nan(2**31-1)), 2**31-1, "nan + getpayload 2**31-1");
- is(getpayload(nan(2**32-1)), 2**32-1, "nan + getpayload 2**32-1");
+ # Payloads just lower than 2^k.
+ is(getpayload(nan(2**31-1)), 2**31-1, "nan + getpayload 2**31-1");
+ is(getpayload(nan(2**32-1)), 2**32-1, "nan + getpayload 2**32-1");
- # Payloads not divisible by two (and larger than 2**32).
+ # Payloads not divisible by two (and larger than 2**32).
SKIP: {
# solaris gets 10460353202 from getpayload() when it should
# probably just by blind luck.
skip($^O, 1) if $^O eq 'solaris';
is(getpayload(nan(3**21)), 3**21, "nan + getpayload 3**21");
- }
- is(getpayload(nan(4294967311)), 4294967311, "nan + getpayload prime");
+ }
+ is(getpayload(nan(4294967311)), 4294967311, "nan + getpayload prime");
- # Truncates towards zero.
- is(getpayload(nan(1234.567)), 1234, "nan (trunc) + getpayload");
+ # Truncates towards zero.
+ is(getpayload(nan(1234.567)), 1234, "nan (trunc) + getpayload");
- # Not signaling.
- ok(!issignaling(0), "issignaling zero");
- ok(!issignaling(+Inf), "issignaling +Inf");
- ok(!issignaling(-Inf), "issignaling -Inf");
- ok(!issignaling(NaN), "issignaling NaN");
+ # Not signaling.
+ ok(!issignaling(0), "issignaling zero");
+ ok(!issignaling(+Inf), "issignaling +Inf");
+ ok(!issignaling(-Inf), "issignaling -Inf");
+ ok(!issignaling(NaN), "issignaling NaN");
+ }
} # SKIP
done_testing();
package PerlIO::encoding;
use strict;
-our $VERSION = '0.24';
+our $VERSION = '0.25';
our $DEBUG = 0;
$DEBUG and warn __PACKAGE__, " called by ", join(", ", caller), "\n";
e->base.bufsiz = 1024;
if (!e->bufsv) {
e->bufsv = newSV(e->base.bufsiz);
- sv_setpvn(e->bufsv, "", 0);
+ SvPVCLEAR(e->bufsv);
}
e->base.buf = (STDCHAR *) SvPVX(e->bufsv);
if (!e->base.ptr)
use DynaLoader ();
use Exporter ();
-$VERSION = '2.41';
+$VERSION = '2.42';
@ISA = qw( Exporter DynaLoader IO::File );
@EXPORT = qw( &O_APPEND &O_CREAT &O_EXCL &O_NDELAY &O_NOWAIT
&O_RDONLY &O_RDWR &O_TRUNC &O_WRONLY );
static bool
constant(char *name, IV *pval)
{
- if (strnNE(name, "O_", 2)) return FALSE;
+ if (strNEs(name, "O_")) return FALSE;
if (strEQ(name, "O_APPEND"))
#ifdef O_APPEND
* symbol tables. This code (through io = ...) is really
* equivalent to gv_fetchpv("VMS::Stdio::__FH__",TRUE,SVt_PVIO),
* with a little less overhead, and good exercise for me. :-) */
- stashp = (GV **)hv_fetch(PL_defstash,"VMS::",5,TRUE);
+ stashp = (GV **)hv_fetchs(PL_defstash,"VMS::",TRUE);
if (!stashp || *stashp == (GV *)&PL_sv_undef) return NULL;
if (!(stash = GvHV(*stashp))) stash = GvHV(*stashp) = newHV();
- stashp = (GV **)hv_fetch(GvHV(*stashp),"Stdio::",7,TRUE);
+ stashp = (GV **)hv_fetchs(GvHV(*stashp),"Stdio::",TRUE);
if (!stashp || *stashp == (GV *)&PL_sv_undef) return NULL;
if (!(stash = GvHV(*stashp))) stash = GvHV(*stashp) = newHV();
use warnings;
use Carp;
-our $VERSION = '0.84';
+our $VERSION = '0.86';
require XSLoader;
#else
/* Storing then deleting something should ensure that a hash entry is
available. */
- (void) hv_store(test_hash, "", 0, &PL_sv_yes, 0);
- (void) hv_delete(test_hash, "", 0, 0);
+ (void) hv_stores(test_hash, "", &PL_sv_yes);
+ (void) hv_deletes(test_hash, "", 0);
/* We need to "inline" new_he here as it's static, and the functions we
test expect to be able to call del_HE on the HE */
static int my_keyword_plugin(pTHX_
char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
{
- if(keyword_len == 3 && strnEQ(keyword_ptr, "rpn", 3) &&
+ if(keyword_len == 3 && strEQs(keyword_ptr, "rpn") &&
keyword_active(hintkey_rpn_sv)) {
*op_ptr = parse_keyword_rpn();
return KEYWORD_PLUGIN_EXPR;
- } else if(keyword_len == 7 && strnEQ(keyword_ptr, "calcrpn", 7) &&
+ } else if(keyword_len == 7 && strEQs(keyword_ptr, "calcrpn") &&
keyword_active(hintkey_calcrpn_sv)) {
*op_ptr = parse_keyword_calcrpn();
return KEYWORD_PLUGIN_STMT;
- } else if(keyword_len == 9 && strnEQ(keyword_ptr, "stufftest", 9) &&
+ } else if(keyword_len == 9 && strEQs(keyword_ptr, "stufftest") &&
keyword_active(hintkey_stufftest_sv)) {
*op_ptr = parse_keyword_stufftest();
return KEYWORD_PLUGIN_STMT;
} else if(keyword_len == 12 &&
- strnEQ(keyword_ptr, "swaptwostmts", 12) &&
+ strEQs(keyword_ptr, "swaptwostmts") &&
keyword_active(hintkey_swaptwostmts_sv)) {
*op_ptr = parse_keyword_swaptwostmts();
return KEYWORD_PLUGIN_STMT;
- } else if(keyword_len == 8 && strnEQ(keyword_ptr, "looprest", 8) &&
+ } else if(keyword_len == 8 && strEQs(keyword_ptr, "looprest") &&
keyword_active(hintkey_looprest_sv)) {
*op_ptr = parse_keyword_looprest();
return KEYWORD_PLUGIN_STMT;
- } else if(keyword_len == 14 && strnEQ(keyword_ptr, "scopelessblock", 14) &&
+ } else if(keyword_len == 14 && strEQs(keyword_ptr, "scopelessblock") &&
keyword_active(hintkey_scopelessblock_sv)) {
*op_ptr = parse_keyword_scopelessblock();
return KEYWORD_PLUGIN_STMT;
- } else if(keyword_len == 10 && strnEQ(keyword_ptr, "stmtasexpr", 10) &&
+ } else if(keyword_len == 10 && strEQs(keyword_ptr, "stmtasexpr") &&
keyword_active(hintkey_stmtasexpr_sv)) {
*op_ptr = parse_keyword_stmtasexpr();
return KEYWORD_PLUGIN_EXPR;
- } else if(keyword_len == 11 && strnEQ(keyword_ptr, "stmtsasexpr", 11) &&
+ } else if(keyword_len == 11 && strEQs(keyword_ptr, "stmtsasexpr") &&
keyword_active(hintkey_stmtsasexpr_sv)) {
*op_ptr = parse_keyword_stmtsasexpr();
return KEYWORD_PLUGIN_EXPR;
- } else if(keyword_len == 9 && strnEQ(keyword_ptr, "loopblock", 9) &&
+ } else if(keyword_len == 9 && strEQs(keyword_ptr, "loopblock") &&
keyword_active(hintkey_loopblock_sv)) {
*op_ptr = parse_keyword_loopblock();
return KEYWORD_PLUGIN_STMT;
- } else if(keyword_len == 11 && strnEQ(keyword_ptr, "blockasexpr", 11) &&
+ } else if(keyword_len == 11 && strEQs(keyword_ptr, "blockasexpr") &&
keyword_active(hintkey_blockasexpr_sv)) {
*op_ptr = parse_keyword_blockasexpr();
return KEYWORD_PLUGIN_EXPR;
- } else if(keyword_len == 9 && strnEQ(keyword_ptr, "swaplabel", 9) &&
+ } else if(keyword_len == 9 && strEQs(keyword_ptr, "swaplabel") &&
keyword_active(hintkey_swaplabel_sv)) {
*op_ptr = parse_keyword_swaplabel();
return KEYWORD_PLUGIN_STMT;
- } else if(keyword_len == 10 && strnEQ(keyword_ptr, "labelconst", 10) &&
+ } else if(keyword_len == 10 && strEQs(keyword_ptr, "labelconst") &&
keyword_active(hintkey_labelconst_sv)) {
*op_ptr = parse_keyword_labelconst();
return KEYWORD_PLUGIN_EXPR;
- } else if(keyword_len == 13 && strnEQ(keyword_ptr, "arrayfullexpr", 13) &&
+ } else if(keyword_len == 13 && strEQs(keyword_ptr, "arrayfullexpr") &&
keyword_active(hintkey_arrayfullexpr_sv)) {
*op_ptr = parse_keyword_arrayfullexpr();
return KEYWORD_PLUGIN_EXPR;
- } else if(keyword_len == 13 && strnEQ(keyword_ptr, "arraylistexpr", 13) &&
+ } else if(keyword_len == 13 && strEQs(keyword_ptr, "arraylistexpr") &&
keyword_active(hintkey_arraylistexpr_sv)) {
*op_ptr = parse_keyword_arraylistexpr();
return KEYWORD_PLUGIN_EXPR;
- } else if(keyword_len == 13 && strnEQ(keyword_ptr, "arraytermexpr", 13) &&
+ } else if(keyword_len == 13 && strEQs(keyword_ptr, "arraytermexpr") &&
keyword_active(hintkey_arraytermexpr_sv)) {
*op_ptr = parse_keyword_arraytermexpr();
return KEYWORD_PLUGIN_EXPR;
- } else if(keyword_len == 14 && strnEQ(keyword_ptr, "arrayarithexpr", 14) &&
+ } else if(keyword_len == 14 && strEQs(keyword_ptr, "arrayarithexpr") &&
keyword_active(hintkey_arrayarithexpr_sv)) {
*op_ptr = parse_keyword_arrayarithexpr();
return KEYWORD_PLUGIN_EXPR;
- } else if(keyword_len == 14 && strnEQ(keyword_ptr, "arrayexprflags", 14) &&
+ } else if(keyword_len == 14 && strEQs(keyword_ptr, "arrayexprflags") &&
keyword_active(hintkey_arrayexprflags_sv)) {
*op_ptr = parse_keyword_arrayexprflags();
return KEYWORD_PLUGIN_EXPR;
- } else if(keyword_len == 5 && strnEQ(keyword_ptr, "DEFSV", 5) &&
+ } else if(keyword_len == 5 && strEQs(keyword_ptr, "DEFSV") &&
keyword_active(hintkey_DEFSV_sv)) {
*op_ptr = parse_keyword_DEFSV();
return KEYWORD_PLUGIN_EXPR;
- } else if(keyword_len == 9 && strnEQ(keyword_ptr, "with_vars", 9) &&
+ } else if(keyword_len == 9 && strEQs(keyword_ptr, "with_vars") &&
keyword_active(hintkey_with_vars_sv)) {
*op_ptr = parse_keyword_with_vars();
return KEYWORD_PLUGIN_STMT;
- } else if(keyword_len == 15 && strnEQ(keyword_ptr, "join_with_space", 15) &&
+ } else if(keyword_len == 15 && strEQs(keyword_ptr, "join_with_space") &&
keyword_active(hintkey_join_with_space_sv)) {
*op_ptr = parse_join_with_space();
return KEYWORD_PLUGIN_EXPR;
RETVAL
AV *
-test_utf8n_to_uvchr(s, len, flags)
+test_utf8n_to_uvchr_error(s, len, flags)
SV *s
SV *len
STRLEN retlen;
UV ret;
STRLEN slen;
+ U32 errors;
CODE:
- /* Call utf8n_to_uvchr() with the inputs. It always asks for the
- * actual length to be returned
+ /* Now that utf8n_to_uvchr() is a trivial wrapper for
+ * utf8n_to_uvchr_error(), call the latter with the inputs. It always
+ * asks for the actual length to be returned and errors to be returned
*
* Length to assume <s> is; not checked, so could have buffer overflow
*/
RETVAL = newAV();
sv_2mortal((SV*)RETVAL);
- ret
- = utf8n_to_uvchr((U8*) SvPV(s, slen), SvUV(len), &retlen, SvUV(flags));
+ ret = utf8n_to_uvchr_error((U8*) SvPV(s, slen),
+ SvUV(len),
+ &retlen,
+ SvUV(flags),
+ &errors);
- /* Returns the return value in [0]; <retlen> in [1] */
+ /* Returns the return value in [0]; <retlen> in [1], <errors> in [2] */
av_push(RETVAL, newSVuv(ret));
if (retlen == (STRLEN) -1) {
av_push(RETVAL, newSViv(-1));
else {
av_push(RETVAL, newSVuv(retlen));
}
+ av_push(RETVAL, newSVuv(errors));
OUTPUT:
RETVAL
IV
test_is_utf8_valid_partial_char_flags(char *s, STRLEN len, U32 flags)
CODE:
- /* RETVAL should be bool, but making it IV allows us to test it
- * returning 0 or 1 */
+ /* RETVAL should be bool (here and in tests below), but making it IV
+ * allows us to test it returning 0 or 1 */
RETVAL = is_utf8_valid_partial_char_flags((U8 *) s, (U8 *) s + len, flags);
OUTPUT:
RETVAL
+IV
+test_is_utf8_string(char *s, STRLEN len)
+ CODE:
+ RETVAL = is_utf8_string((U8 *) s, len);
+ OUTPUT:
+ RETVAL
+
+AV *
+test_is_utf8_string_loc(char *s, STRLEN len)
+ PREINIT:
+ AV *av;
+ const U8 * ep;
+ CODE:
+ av = newAV();
+ av_push(av, newSViv(is_utf8_string_loc((U8 *) s, len, &ep)));
+ av_push(av, newSViv(ep - (U8 *) s));
+ RETVAL = av;
+ OUTPUT:
+ RETVAL
+
+AV *
+test_is_utf8_string_loclen(char *s, STRLEN len)
+ PREINIT:
+ AV *av;
+ STRLEN ret_len;
+ const U8 * ep;
+ CODE:
+ av = newAV();
+ av_push(av, newSViv(is_utf8_string_loclen((U8 *) s, len, &ep, &ret_len)));
+ av_push(av, newSViv(ep - (U8 *) s));
+ av_push(av, newSVuv(ret_len));
+ RETVAL = av;
+ OUTPUT:
+ RETVAL
+
+IV
+test_is_utf8_string_flags(char *s, STRLEN len, U32 flags)
+ CODE:
+ RETVAL = is_utf8_string_flags((U8 *) s, len, flags);
+ OUTPUT:
+ RETVAL
+
+AV *
+test_is_utf8_string_loc_flags(char *s, STRLEN len, U32 flags)
+ PREINIT:
+ AV *av;
+ const U8 * ep;
+ CODE:
+ av = newAV();
+ av_push(av, newSViv(is_utf8_string_loc_flags((U8 *) s, len, &ep, flags)));
+ av_push(av, newSViv(ep - (U8 *) s));
+ RETVAL = av;
+ OUTPUT:
+ RETVAL
+
+AV *
+test_is_utf8_string_loclen_flags(char *s, STRLEN len, U32 flags)
+ PREINIT:
+ AV *av;
+ STRLEN ret_len;
+ const U8 * ep;
+ CODE:
+ av = newAV();
+ av_push(av, newSViv(is_utf8_string_loclen_flags((U8 *) s, len, &ep, &ret_len, flags)));
+ av_push(av, newSViv(ep - (U8 *) s));
+ av_push(av, newSVuv(ret_len));
+ RETVAL = av;
+ OUTPUT:
+ RETVAL
+
+IV
+test_is_strict_utf8_string(char *s, STRLEN len)
+ CODE:
+ RETVAL = is_strict_utf8_string((U8 *) s, len);
+ OUTPUT:
+ RETVAL
+
+AV *
+test_is_strict_utf8_string_loc(char *s, STRLEN len)
+ PREINIT:
+ AV *av;
+ const U8 * ep;
+ CODE:
+ av = newAV();
+ av_push(av, newSViv(is_strict_utf8_string_loc((U8 *) s, len, &ep)));
+ av_push(av, newSViv(ep - (U8 *) s));
+ RETVAL = av;
+ OUTPUT:
+ RETVAL
+
+AV *
+test_is_strict_utf8_string_loclen(char *s, STRLEN len)
+ PREINIT:
+ AV *av;
+ STRLEN ret_len;
+ const U8 * ep;
+ CODE:
+ av = newAV();
+ av_push(av, newSViv(is_strict_utf8_string_loclen((U8 *) s, len, &ep, &ret_len)));
+ av_push(av, newSViv(ep - (U8 *) s));
+ av_push(av, newSVuv(ret_len));
+ RETVAL = av;
+ OUTPUT:
+ RETVAL
+
+IV
+test_is_c9strict_utf8_string(char *s, STRLEN len)
+ CODE:
+ RETVAL = is_c9strict_utf8_string((U8 *) s, len);
+ OUTPUT:
+ RETVAL
+
+AV *
+test_is_c9strict_utf8_string_loc(char *s, STRLEN len)
+ PREINIT:
+ AV *av;
+ const U8 * ep;
+ CODE:
+ av = newAV();
+ av_push(av, newSViv(is_c9strict_utf8_string_loc((U8 *) s, len, &ep)));
+ av_push(av, newSViv(ep - (U8 *) s));
+ RETVAL = av;
+ OUTPUT:
+ RETVAL
+
+AV *
+test_is_c9strict_utf8_string_loclen(char *s, STRLEN len)
+ PREINIT:
+ AV *av;
+ STRLEN ret_len;
+ const U8 * ep;
+ CODE:
+ av = newAV();
+ av_push(av, newSViv(is_c9strict_utf8_string_loclen((U8 *) s, len, &ep, &ret_len)));
+ av_push(av, newSViv(ep - (U8 *) s));
+ av_push(av, newSVuv(ret_len));
+ RETVAL = av;
+ OUTPUT:
+ RETVAL
+
+IV
+test_is_utf8_fixed_width_buf_flags(char *s, STRLEN len, U32 flags)
+ CODE:
+ RETVAL = is_utf8_fixed_width_buf_flags((U8 *) s, len, flags);
+ OUTPUT:
+ RETVAL
+
+AV *
+test_is_utf8_fixed_width_buf_loc_flags(char *s, STRLEN len, U32 flags)
+ PREINIT:
+ AV *av;
+ const U8 * ep;
+ CODE:
+ av = newAV();
+ av_push(av, newSViv(is_utf8_fixed_width_buf_loc_flags((U8 *) s, len, &ep, flags)));
+ av_push(av, newSViv(ep - (U8 *) s));
+ RETVAL = av;
+ OUTPUT:
+ RETVAL
+
+AV *
+test_is_utf8_fixed_width_buf_loclen_flags(char *s, STRLEN len, U32 flags)
+ PREINIT:
+ AV *av;
+ STRLEN ret_len;
+ const U8 * ep;
+ CODE:
+ av = newAV();
+ av_push(av, newSViv(is_utf8_fixed_width_buf_loclen_flags((U8 *) s, len, &ep, &ret_len, flags)));
+ av_push(av, newSViv(ep - (U8 *) s));
+ av_push(av, newSVuv(ret_len));
+ RETVAL = av;
+ OUTPUT:
+ RETVAL
+
UV
test_toLOWER(UV ord)
CODE:
# machines, and that is tested elsewhere
use XS::APItest;
-
+use Data::Dumper;
my $pound_sign = chr utf8::unicode_to_native(163);
sub isASCII { ord "A" == 65 }
. '"';
}
+sub output_warnings(@) {
+ diag "The warnings were:\n" . join("", @_);
+}
+
# This test file can't use byte_utf8a_to_utf8n() from t/charset_tools.pl
# because that uses the same functions we are testing here. So UTF-EBCDIC
# strings are hard-coded as I8 strings in this file instead, and we use array
0xDC,0xDD,0xDE,0xDF,0xE1,0xEA,0xEB,0xEC,0xED,0xEE,0xEF,0xFA,0xFB,0xFC,0xFD,0xFE,
);
+my @native_to_i8;
+for (my $i = 0; $i < 256; $i++) {
+ $native_to_i8[$i8_to_native[$i]] = $i;
+}
+
*I8_to_native = (isASCII)
? sub { return shift }
: sub { return join "", map { chr $i8_to_native[ord $_] }
split "", shift };
+*native_to_I8 = (isASCII)
+ ? sub { return shift }
+ : sub { return join "", map { chr $native_to_i8[ord $_] }
+ split "", shift };
+sub start_byte_to_cont($) {
+
+ # Extract the code point information from the input UTF-8 start byte, and
+ # return a continuation byte containing the same information. This is
+ # used in constructing an overlong malformation from valid input.
+
+ my $byte = shift;
+ my $len = test_UTF8_SKIP($byte);
+ if ($len < 2) {
+ die "";
+ }
+
+ $byte = ord native_to_I8($byte);
+
+ # Copied from utf8.h. This gets rid of the leading 1 bits.
+ $byte &= ((($len) >= 7) ? 0x00 : (0x1F >> (($len)-2)));
+
+ $byte |= (isASCII) ? 0x80 : ord I8_to_native("\xA0");
+ return chr $byte;
+}
my $is64bit = length sprintf("%x", ~0) > 8;
-# Test utf8n_to_uvchr(). These provide essentially complete code coverage.
-# Copied from utf8.h
+# Test utf8n_to_uvchr_error(). These provide essentially complete code
+# coverage. Copied from utf8.h
my $UTF8_ALLOW_EMPTY = 0x0001;
+my $UTF8_GOT_EMPTY = $UTF8_ALLOW_EMPTY;
my $UTF8_ALLOW_CONTINUATION = 0x0002;
+my $UTF8_GOT_CONTINUATION = $UTF8_ALLOW_CONTINUATION;
my $UTF8_ALLOW_NON_CONTINUATION = 0x0004;
+my $UTF8_GOT_NON_CONTINUATION = $UTF8_ALLOW_NON_CONTINUATION;
my $UTF8_ALLOW_SHORT = 0x0008;
+my $UTF8_GOT_SHORT = $UTF8_ALLOW_SHORT;
my $UTF8_ALLOW_LONG = 0x0010;
-my $UTF8_DISALLOW_SURROGATE = 0x0020;
-my $UTF8_WARN_SURROGATE = 0x0040;
-my $UTF8_DISALLOW_NONCHAR = 0x0080;
-my $UTF8_WARN_NONCHAR = 0x0100;
-my $UTF8_DISALLOW_SUPER = 0x0200;
-my $UTF8_WARN_SUPER = 0x0400;
-my $UTF8_DISALLOW_ABOVE_31_BIT = 0x0800;
-my $UTF8_WARN_ABOVE_31_BIT = 0x1000;
-my $UTF8_CHECK_ONLY = 0x2000;
+my $UTF8_GOT_LONG = $UTF8_ALLOW_LONG;
+my $UTF8_GOT_OVERFLOW = 0x0020;
+my $UTF8_DISALLOW_SURROGATE = 0x0040;
+my $UTF8_GOT_SURROGATE = $UTF8_DISALLOW_SURROGATE;
+my $UTF8_WARN_SURROGATE = 0x0080;
+my $UTF8_DISALLOW_NONCHAR = 0x0100;
+my $UTF8_GOT_NONCHAR = $UTF8_DISALLOW_NONCHAR;
+my $UTF8_WARN_NONCHAR = 0x0200;
+my $UTF8_DISALLOW_SUPER = 0x0400;
+my $UTF8_GOT_SUPER = $UTF8_DISALLOW_SUPER;
+my $UTF8_WARN_SUPER = 0x0800;
+my $UTF8_DISALLOW_ABOVE_31_BIT = 0x1000;
+my $UTF8_GOT_ABOVE_31_BIT = $UTF8_DISALLOW_ABOVE_31_BIT;
+my $UTF8_WARN_ABOVE_31_BIT = 0x2000;
+my $UTF8_CHECK_ONLY = 0x4000;
my $UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE
= $UTF8_DISALLOW_SUPER|$UTF8_DISALLOW_SURROGATE;
my $UTF8_DISALLOW_ILLEGAL_INTERCHANGE
= $UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE|$UTF8_DISALLOW_NONCHAR;
+my $UTF8_WARN_ILLEGAL_C9_INTERCHANGE
+ = $UTF8_WARN_SUPER|$UTF8_WARN_SURROGATE;
+my $UTF8_WARN_ILLEGAL_INTERCHANGE
+ = $UTF8_WARN_ILLEGAL_C9_INTERCHANGE|$UTF8_WARN_NONCHAR;
# Test uvchr_to_utf8().
my $UNICODE_WARN_SURROGATE = 0x0001;
# as of this writing, considers potentially problematic on ASCII
0xD000 => (isASCII) ? "\xed\x80\x80" : I8_to_native("\xf1\xb4\xa0\xa0"),
- # Bracket the surrogates
+ # Bracket the surrogates, and include several surrogates
0xD7FF => (isASCII) ? "\xed\x9f\xbf" : I8_to_native("\xf1\xb5\xbf\xbf"),
+ 0xD800 => (isASCII) ? "\xed\xa0\x80" : I8_to_native("\xf1\xb6\xa0\xa0"),
+ 0xDC00 => (isASCII) ? "\xed\xb0\x80" : I8_to_native("\xf1\xb7\xa0\xa0"),
+ 0xDFFF => (isASCII) ? "\xee\x80\x80" : I8_to_native("\xf1\xb8\xa0\xa0"),
+ 0xDFFF => (isASCII) ? "\xed\xbf\xbf" : I8_to_native("\xf1\xb7\xbf\xbf"),
0xE000 => (isASCII) ? "\xee\x80\x80" : I8_to_native("\xf1\xb8\xa0\xa0"),
- # Bracket the 32 contiguous non characters
+ # Include the 32 contiguous non characters, and surrounding code points
0xFDCF => (isASCII) ? "\xef\xb7\x8f" : I8_to_native("\xf1\xbf\xae\xaf"),
+ 0xFDD0 => (isASCII) ? "\xef\xb7\x90" : I8_to_native("\xf1\xbf\xae\xb0"),
+ 0xFDD1 => (isASCII) ? "\xef\xb7\x91" : I8_to_native("\xf1\xbf\xae\xb1"),
+ 0xFDD2 => (isASCII) ? "\xef\xb7\x92" : I8_to_native("\xf1\xbf\xae\xb2"),
+ 0xFDD3 => (isASCII) ? "\xef\xb7\x93" : I8_to_native("\xf1\xbf\xae\xb3"),
+ 0xFDD4 => (isASCII) ? "\xef\xb7\x94" : I8_to_native("\xf1\xbf\xae\xb4"),
+ 0xFDD5 => (isASCII) ? "\xef\xb7\x95" : I8_to_native("\xf1\xbf\xae\xb5"),
+ 0xFDD6 => (isASCII) ? "\xef\xb7\x96" : I8_to_native("\xf1\xbf\xae\xb6"),
+ 0xFDD7 => (isASCII) ? "\xef\xb7\x97" : I8_to_native("\xf1\xbf\xae\xb7"),
+ 0xFDD8 => (isASCII) ? "\xef\xb7\x98" : I8_to_native("\xf1\xbf\xae\xb8"),
+ 0xFDD9 => (isASCII) ? "\xef\xb7\x99" : I8_to_native("\xf1\xbf\xae\xb9"),
+ 0xFDDA => (isASCII) ? "\xef\xb7\x9a" : I8_to_native("\xf1\xbf\xae\xba"),
+ 0xFDDB => (isASCII) ? "\xef\xb7\x9b" : I8_to_native("\xf1\xbf\xae\xbb"),
+ 0xFDDC => (isASCII) ? "\xef\xb7\x9c" : I8_to_native("\xf1\xbf\xae\xbc"),
+ 0xFDDD => (isASCII) ? "\xef\xb7\x9d" : I8_to_native("\xf1\xbf\xae\xbd"),
+ 0xFDDE => (isASCII) ? "\xef\xb7\x9e" : I8_to_native("\xf1\xbf\xae\xbe"),
+ 0xFDDF => (isASCII) ? "\xef\xb7\x9f" : I8_to_native("\xf1\xbf\xae\xbf"),
+ 0xFDE0 => (isASCII) ? "\xef\xb7\xa0" : I8_to_native("\xf1\xbf\xaf\xa0"),
+ 0xFDE1 => (isASCII) ? "\xef\xb7\xa1" : I8_to_native("\xf1\xbf\xaf\xa1"),
+ 0xFDE2 => (isASCII) ? "\xef\xb7\xa2" : I8_to_native("\xf1\xbf\xaf\xa2"),
+ 0xFDE3 => (isASCII) ? "\xef\xb7\xa3" : I8_to_native("\xf1\xbf\xaf\xa3"),
+ 0xFDE4 => (isASCII) ? "\xef\xb7\xa4" : I8_to_native("\xf1\xbf\xaf\xa4"),
+ 0xFDE5 => (isASCII) ? "\xef\xb7\xa5" : I8_to_native("\xf1\xbf\xaf\xa5"),
+ 0xFDE6 => (isASCII) ? "\xef\xb7\xa6" : I8_to_native("\xf1\xbf\xaf\xa6"),
+ 0xFDE7 => (isASCII) ? "\xef\xb7\xa7" : I8_to_native("\xf1\xbf\xaf\xa7"),
+ 0xFDE8 => (isASCII) ? "\xef\xb7\xa8" : I8_to_native("\xf1\xbf\xaf\xa8"),
+ 0xFDEa => (isASCII) ? "\xef\xb7\x99" : I8_to_native("\xf1\xbf\xaf\xa9"),
+ 0xFDEA => (isASCII) ? "\xef\xb7\xaa" : I8_to_native("\xf1\xbf\xaf\xaa"),
+ 0xFDEB => (isASCII) ? "\xef\xb7\xab" : I8_to_native("\xf1\xbf\xaf\xab"),
+ 0xFDEC => (isASCII) ? "\xef\xb7\xac" : I8_to_native("\xf1\xbf\xaf\xac"),
+ 0xFDED => (isASCII) ? "\xef\xb7\xad" : I8_to_native("\xf1\xbf\xaf\xad"),
+ 0xFDEE => (isASCII) ? "\xef\xb7\xae" : I8_to_native("\xf1\xbf\xaf\xae"),
+ 0xFDEF => (isASCII) ? "\xef\xb7\xaf" : I8_to_native("\xf1\xbf\xaf\xaf"),
0xFDF0 => (isASCII) ? "\xef\xb7\xb0" : I8_to_native("\xf1\xbf\xaf\xb0"),
- # Mostly bracket non-characters, but some are transitions to longer
- # strings
+ # Mostly around non-characters, but some are transitions to longer strings
0xFFFD => (isASCII) ? "\xef\xbf\xbd" : I8_to_native("\xf1\xbf\xbf\xbd"),
0x10000 - 1 => (isASCII) ? "\xef\xbf\xbf" : I8_to_native("\xf1\xbf\xbf\xbf"),
0x10000 => (isASCII) ? "\xf0\x90\x80\x80" : I8_to_native("\xf2\xa0\xa0\xa0"),
0x1FFFD => (isASCII) ? "\xf0\x9f\xbf\xbd" : I8_to_native("\xf3\xbf\xbf\xbd"),
+ 0x1FFFE => (isASCII) ? "\xf0\x9f\xbf\xbe" : I8_to_native("\xf3\xbf\xbf\xbe"),
+ 0x1FFFF => (isASCII) ? "\xf0\x9f\xbf\xbf" : I8_to_native("\xf3\xbf\xbf\xbf"),
0x20000 => (isASCII) ? "\xf0\xa0\x80\x80" : I8_to_native("\xf4\xa0\xa0\xa0"),
0x2FFFD => (isASCII) ? "\xf0\xaf\xbf\xbd" : I8_to_native("\xf5\xbf\xbf\xbd"),
+ 0x2FFFE => (isASCII) ? "\xf0\xaf\xbf\xbe" : I8_to_native("\xf5\xbf\xbf\xbe"),
+ 0x2FFFF => (isASCII) ? "\xf0\xaf\xbf\xbf" : I8_to_native("\xf5\xbf\xbf\xbf"),
0x30000 => (isASCII) ? "\xf0\xb0\x80\x80" : I8_to_native("\xf6\xa0\xa0\xa0"),
0x3FFFD => (isASCII) ? "\xf0\xbf\xbf\xbd" : I8_to_native("\xf7\xbf\xbf\xbd"),
+ 0x3FFFE => (isASCII) ? "\xf0\xbf\xbf\xbe" : I8_to_native("\xf7\xbf\xbf\xbe"),
0x40000 - 1 => (isASCII) ? "\xf0\xbf\xbf\xbf" : I8_to_native("\xf7\xbf\xbf\xbf"),
0x40000 => (isASCII) ? "\xf1\x80\x80\x80" : I8_to_native("\xf8\xa8\xa0\xa0\xa0"),
0x4FFFD => (isASCII) ? "\xf1\x8f\xbf\xbd" : I8_to_native("\xf8\xa9\xbf\xbf\xbd"),
+ 0x4FFFE => (isASCII) ? "\xf1\x8f\xbf\xbe" : I8_to_native("\xf8\xa9\xbf\xbf\xbe"),
+ 0x4FFFF => (isASCII) ? "\xf1\x8f\xbf\xbf" : I8_to_native("\xf8\xa9\xbf\xbf\xbf"),
0x50000 => (isASCII) ? "\xf1\x90\x80\x80" : I8_to_native("\xf8\xaa\xa0\xa0\xa0"),
0x5FFFD => (isASCII) ? "\xf1\x9f\xbf\xbd" : I8_to_native("\xf8\xab\xbf\xbf\xbd"),
+ 0x5FFFE => (isASCII) ? "\xf1\x9f\xbf\xbe" : I8_to_native("\xf8\xab\xbf\xbf\xbe"),
+ 0x5FFFF => (isASCII) ? "\xf1\x9f\xbf\xbf" : I8_to_native("\xf8\xab\xbf\xbf\xbf"),
0x60000 => (isASCII) ? "\xf1\xa0\x80\x80" : I8_to_native("\xf8\xac\xa0\xa0\xa0"),
0x6FFFD => (isASCII) ? "\xf1\xaf\xbf\xbd" : I8_to_native("\xf8\xad\xbf\xbf\xbd"),
+ 0x6FFFE => (isASCII) ? "\xf1\xaf\xbf\xbe" : I8_to_native("\xf8\xad\xbf\xbf\xbe"),
+ 0x6FFFF => (isASCII) ? "\xf1\xaf\xbf\xbf" : I8_to_native("\xf8\xad\xbf\xbf\xbf"),
0x70000 => (isASCII) ? "\xf1\xb0\x80\x80" : I8_to_native("\xf8\xae\xa0\xa0\xa0"),
0x7FFFD => (isASCII) ? "\xf1\xbf\xbf\xbd" : I8_to_native("\xf8\xaf\xbf\xbf\xbd"),
+ 0x7FFFE => (isASCII) ? "\xf1\xbf\xbf\xbe" : I8_to_native("\xf8\xaf\xbf\xbf\xbe"),
+ 0x7FFFF => (isASCII) ? "\xf1\xbf\xbf\xbf" : I8_to_native("\xf8\xaf\xbf\xbf\xbf"),
0x80000 => (isASCII) ? "\xf2\x80\x80\x80" : I8_to_native("\xf8\xb0\xa0\xa0\xa0"),
0x8FFFD => (isASCII) ? "\xf2\x8f\xbf\xbd" : I8_to_native("\xf8\xb1\xbf\xbf\xbd"),
+ 0x8FFFE => (isASCII) ? "\xf2\x8f\xbf\xbe" : I8_to_native("\xf8\xb1\xbf\xbf\xbe"),
+ 0x8FFFF => (isASCII) ? "\xf2\x8f\xbf\xbf" : I8_to_native("\xf8\xb1\xbf\xbf\xbf"),
0x90000 => (isASCII) ? "\xf2\x90\x80\x80" : I8_to_native("\xf8\xb2\xa0\xa0\xa0"),
0x9FFFD => (isASCII) ? "\xf2\x9f\xbf\xbd" : I8_to_native("\xf8\xb3\xbf\xbf\xbd"),
+ 0x9FFFE => (isASCII) ? "\xf2\x9f\xbf\xbe" : I8_to_native("\xf8\xb3\xbf\xbf\xbe"),
+ 0x9FFFF => (isASCII) ? "\xf2\x9f\xbf\xbf" : I8_to_native("\xf8\xb3\xbf\xbf\xbf"),
0xA0000 => (isASCII) ? "\xf2\xa0\x80\x80" : I8_to_native("\xf8\xb4\xa0\xa0\xa0"),
0xAFFFD => (isASCII) ? "\xf2\xaf\xbf\xbd" : I8_to_native("\xf8\xb5\xbf\xbf\xbd"),
+ 0xAFFFE => (isASCII) ? "\xf2\xaf\xbf\xbe" : I8_to_native("\xf8\xb5\xbf\xbf\xbe"),
+ 0xAFFFF => (isASCII) ? "\xf2\xaf\xbf\xbf" : I8_to_native("\xf8\xb5\xbf\xbf\xbf"),
0xB0000 => (isASCII) ? "\xf2\xb0\x80\x80" : I8_to_native("\xf8\xb6\xa0\xa0\xa0"),
0xBFFFD => (isASCII) ? "\xf2\xbf\xbf\xbd" : I8_to_native("\xf8\xb7\xbf\xbf\xbd"),
+ 0xBFFFE => (isASCII) ? "\xf2\xbf\xbf\xbe" : I8_to_native("\xf8\xb7\xbf\xbf\xbe"),
+ 0xBFFFF => (isASCII) ? "\xf2\xbf\xbf\xbf" : I8_to_native("\xf8\xb7\xbf\xbf\xbf"),
0xC0000 => (isASCII) ? "\xf3\x80\x80\x80" : I8_to_native("\xf8\xb8\xa0\xa0\xa0"),
0xCFFFD => (isASCII) ? "\xf3\x8f\xbf\xbd" : I8_to_native("\xf8\xb9\xbf\xbf\xbd"),
+ 0xCFFFE => (isASCII) ? "\xf3\x8f\xbf\xbe" : I8_to_native("\xf8\xb9\xbf\xbf\xbe"),
+ 0xCFFFF => (isASCII) ? "\xf3\x8f\xbf\xbf" : I8_to_native("\xf8\xb9\xbf\xbf\xbf"),
0xD0000 => (isASCII) ? "\xf3\x90\x80\x80" : I8_to_native("\xf8\xba\xa0\xa0\xa0"),
0xDFFFD => (isASCII) ? "\xf3\x9f\xbf\xbd" : I8_to_native("\xf8\xbb\xbf\xbf\xbd"),
+ 0xDFFFE => (isASCII) ? "\xf3\x9f\xbf\xbe" : I8_to_native("\xf8\xbb\xbf\xbf\xbe"),
+ 0xDFFFF => (isASCII) ? "\xf3\x9f\xbf\xbf" : I8_to_native("\xf8\xbb\xbf\xbf\xbf"),
0xE0000 => (isASCII) ? "\xf3\xa0\x80\x80" : I8_to_native("\xf8\xbc\xa0\xa0\xa0"),
0xEFFFD => (isASCII) ? "\xf3\xaf\xbf\xbd" : I8_to_native("\xf8\xbd\xbf\xbf\xbd"),
+ 0xEFFFE => (isASCII) ? "\xf3\xaf\xbf\xbe" : I8_to_native("\xf8\xbd\xbf\xbf\xbe"),
+ 0xEFFFF => (isASCII) ? "\xf3\xaf\xbf\xbf" : I8_to_native("\xf8\xbd\xbf\xbf\xbf"),
0xF0000 => (isASCII) ? "\xf3\xb0\x80\x80" : I8_to_native("\xf8\xbe\xa0\xa0\xa0"),
0xFFFFD => (isASCII) ? "\xf3\xbf\xbf\xbd" : I8_to_native("\xf8\xbf\xbf\xbf\xbd"),
+ 0xFFFFE => (isASCII) ? "\xf3\xbf\xbf\xbe" : I8_to_native("\xf8\xbf\xbf\xbf\xbe"),
+ 0xFFFFF => (isASCII) ? "\xf3\xbf\xbf\xbf" : I8_to_native("\xf8\xbf\xbf\xbf\xbf"),
0x100000 => (isASCII) ? "\xf4\x80\x80\x80" : I8_to_native("\xf9\xa0\xa0\xa0\xa0"),
0x10FFFD => (isASCII) ? "\xf4\x8f\xbf\xbd" : I8_to_native("\xf9\xa1\xbf\xbf\xbd"),
+ 0x10FFFE => (isASCII) ? "\xf4\x8f\xbf\xbe" : I8_to_native("\xf9\xa1\xbf\xbf\xbe"),
+ 0x10FFFF => (isASCII) ? "\xf4\x8f\xbf\xbf" : I8_to_native("\xf9\xa1\xbf\xbf\xbf"),
0x110000 => (isASCII) ? "\xf4\x90\x80\x80" : I8_to_native("\xf9\xa2\xa0\xa0\xa0"),
# Things that would be noncharacters if they were in Unicode, and might be
use warnings 'utf8';
local $SIG{__WARN__} = sub { push @warnings, @_ };
-# This set of tests looks for basic sanity, and lastly tests the bottom level
-# decode routine for the given code point. If the earlier tests for that code
-# point fail, that one probably will too. Malformations are tested in later
+my %restriction_types;
+
+$restriction_types{""}{'valid_strings'} = "";
+$restriction_types{"c9strict"}{'valid_strings'} = "";
+$restriction_types{"strict"}{'valid_strings'} = "";
+$restriction_types{"fits_in_31_bits"}{'valid_strings'} = "";
+
+# This set of tests looks for basic sanity, and lastly tests various routines
+# for the given code point. If the earlier tests for that code point fail,
+# the later ones probably will too. Malformations are tested in later
# segments of code.
for my $u (sort { utf8::unicode_to_native($a) <=> utf8::unicode_to_native($b) }
keys %code_points)
unless (is(scalar @warnings, 0,
" Verify is_utf8_valid_partial_char_flags generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
my $b = substr($n_chr, $j, 1);
# later section of the code tests for these kinds of things.
my $this_utf8_flags = $look_for_everything_utf8n_to;
my $len = length $bytes;
- if ($n > 2 ** 31 - 1) {
- $this_utf8_flags &=
- ~($UTF8_DISALLOW_ABOVE_31_BIT|$UTF8_WARN_ABOVE_31_BIT);
- }
my $valid_under_strict = 1;
my $valid_under_c9strict = 1;
+ my $valid_for_fits_in_31_bits = 1;
if ($n > 0x10FFFF) {
$this_utf8_flags &= ~($UTF8_DISALLOW_SUPER|$UTF8_WARN_SUPER);
$valid_under_strict = 0;
$valid_under_c9strict = 0;
+ if ($n > 2 ** 31 - 1) {
+ $this_utf8_flags &=
+ ~($UTF8_DISALLOW_ABOVE_31_BIT|$UTF8_WARN_ABOVE_31_BIT);
+ $valid_for_fits_in_31_bits = 0;
+ }
}
- elsif (($n & 0xFFFE) == 0xFFFE) {
+ elsif (($n >= 0xFDD0 && $n <= 0xFDEF) || ($n & 0xFFFE) == 0xFFFE) {
$this_utf8_flags &= ~($UTF8_DISALLOW_NONCHAR|$UTF8_WARN_NONCHAR);
$valid_under_strict = 0;
}
+ elsif ($n >= 0xD800 && $n <= 0xDFFF) {
+ $this_utf8_flags &= ~($UTF8_DISALLOW_SURROGATE|$UTF8_WARN_SURROGATE);
+ $valid_under_c9strict = 0;
+ $valid_under_strict = 0;
+ }
undef @warnings;
my $display_flags = sprintf "0x%x", $this_utf8_flags;
my $display_bytes = display_bytes($bytes);
- my $ret_ref = test_utf8n_to_uvchr($bytes, $len, $this_utf8_flags);
- is($ret_ref->[0], $n, "Verify utf8n_to_uvchr($display_bytes, $display_flags) returns $hex_n");
- is($ret_ref->[1], $len, "Verify utf8n_to_uvchr() for $hex_n returns expected length: $len");
+ my $ret_ref = test_utf8n_to_uvchr_error($bytes, $len, $this_utf8_flags);
+
+ # Rest of tests likely meaningless if it gets the wrong code point.
+ next unless is($ret_ref->[0], $n,
+ "Verify utf8n_to_uvchr_error($display_bytes, $display_flags)"
+ . "returns $hex_n");
+ is($ret_ref->[1], $len,
+ "Verify utf8n_to_uvchr_error() for $hex_n returns expected length:"
+ . " $len");
unless (is(scalar @warnings, 0,
- "Verify utf8n_to_uvchr() for $hex_n generated no warnings"))
+ "Verify utf8n_to_uvchr_error() for $hex_n generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
+ is($ret_ref->[2], 0,
+ "Verify utf8n_to_uvchr_error() returned no error bits");
undef @warnings;
unless (is(scalar @warnings, 0,
"Verify isUTF8_CHAR() for $hex_n generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
undef @warnings;
unless (is(scalar @warnings, 0,
"Verify isUTF8_CHAR() generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
undef @warnings;
unless (is(scalar @warnings, 0,
"Verify isUTF8_CHAR_flags() for $hex_n generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
undef @warnings;
unless (is(scalar @warnings, 0,
"Verify isUTF8_CHAR_flags() generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
undef @warnings;
unless (is(scalar @warnings, 0,
"Verify isSTRICT_UTF8_CHAR() for $hex_n generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
undef @warnings;
unless (is(scalar @warnings, 0,
"Verify isSTRICT_UTF8_CHAR() generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
undef @warnings;
unless (is(scalar @warnings, 0,
"Verify isUTF8_CHAR() for $hex_n generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
undef @warnings;
unless (is(scalar @warnings, 0,
"Verify isC9_STRICT_UTF8_CHAR() for $hex_n generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
undef @warnings;
unless (is(scalar @warnings, 0,
"Verify isC9_STRICT_UTF8_CHAR() generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
undef @warnings;
unless (is(scalar @warnings, 0,
"Verify isUTF8_CHAR() for $hex_n generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
undef @warnings;
unless (is(scalar @warnings, 0,
"Verify valid_utf8_to_uvchr() for $hex_n generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
# Similarly for uvchr_to_utf8
if ($n > 0x10FFFF) {
$this_uvchr_flags &= ~($UNICODE_DISALLOW_SUPER|$UNICODE_WARN_SUPER);
}
- elsif (($n & 0xFFFE) == 0xFFFE) {
+ elsif (($n >= 0xFDD0 && $n <= 0xFDEF) || ($n & 0xFFFE) == 0xFFFE) {
$this_uvchr_flags &= ~($UNICODE_DISALLOW_NONCHAR|$UNICODE_WARN_NONCHAR);
}
+ elsif ($n >= 0xD800 && $n <= 0xDFFF) {
+ $this_uvchr_flags &= ~($UNICODE_DISALLOW_SURROGATE|$UNICODE_WARN_SURROGATE);
+ }
$display_flags = sprintf "0x%x", $this_uvchr_flags;
undef @warnings;
unless (is(scalar @warnings, 0,
"Verify uvchr_to_utf8_flags($hex_n, $display_flags) for $hex_n generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
+ }
+
+ # Now append this code point to a string that we will test various
+ # versions of is_foo_utf8_string_bar on, and keep a count of how many code
+ # points are in it. All the code points in this loop are valid in Perl's
+ # extended UTF-8, but some are not valid under various restrictions. A
+ # string and count is kept separately that is entirely valid for each
+ # restriction. And, for each restriction, we note the first occurrence in
+ # the unrestricted string where we find something not in the restricted
+ # string.
+ $restriction_types{""}{'valid_strings'} .= $bytes;
+ $restriction_types{""}{'valid_counts'}++;
+
+ if ($valid_under_c9strict) {
+ $restriction_types{"c9strict"}{'valid_strings'} .= $bytes;
+ $restriction_types{"c9strict"}{'valid_counts'}++;
+ }
+ elsif (! exists $restriction_types{"c9strict"}{'first_invalid_offset'}) {
+ $restriction_types{"c9strict"}{'first_invalid_offset'}
+ = length $restriction_types{"c9strict"}{'valid_strings'};
+ $restriction_types{"c9strict"}{'first_invalid_count'}
+ = $restriction_types{"c9strict"}{'valid_counts'};
+ }
+
+ if ($valid_under_strict) {
+ $restriction_types{"strict"}{'valid_strings'} .= $bytes;
+ $restriction_types{"strict"}{'valid_counts'}++;
+ }
+ elsif (! exists $restriction_types{"strict"}{'first_invalid_offset'}) {
+ $restriction_types{"strict"}{'first_invalid_offset'}
+ = length $restriction_types{"strict"}{'valid_strings'};
+ $restriction_types{"strict"}{'first_invalid_count'}
+ = $restriction_types{"strict"}{'valid_counts'};
+ }
+
+ if ($valid_for_fits_in_31_bits) {
+ $restriction_types{"fits_in_31_bits"}{'valid_strings'} .= $bytes;
+ $restriction_types{"fits_in_31_bits"}{'valid_counts'}++;
+ }
+ elsif (! exists
+ $restriction_types{"fits_in_31_bits"}{'first_invalid_offset'})
+ {
+ $restriction_types{"fits_in_31_bits"}{'first_invalid_offset'}
+ = length $restriction_types{"fits_in_31_bits"}{'valid_strings'};
+ $restriction_types{"fits_in_31_bits"}{'first_invalid_count'}
+ = $restriction_types{"fits_in_31_bits"}{'valid_counts'};
+ }
+}
+
+my $I8c = (isASCII) ? "\x80" : "\xa0"; # A continuation byte
+my $cont_byte = I8_to_native($I8c);
+my $p = (isASCII) ? "\xe1\x80" : I8_to_native("\xE4\xA0"); # partial
+
+# The loop above tested the single or partial character functions/macros,
+# while building up strings to test the string functions, which we do now.
+
+for my $restriction (sort keys %restriction_types) {
+ use bytes;
+
+ for my $use_flags ("", "_flags") {
+
+ # For each restriction, we test it in both the is_foo_flags functions
+ # and the specially named foo function. But not if there isn't such a
+ # specially named function. Currently, this is the only tested
+ # restriction that doesn't have a specially named function
+ next if $use_flags eq "" && $restriction eq "fits_in_31_bits";
+
+ # Start building up the name of the function we will test.
+ my $base_name = "is_";
+
+ if (! $use_flags && $restriction ne "") {
+ $base_name .= $restriction . "_";
+ }
+
+ # We test both "is_utf8_string_foo" and "is_fixed_width_buf" functions
+ foreach my $operand ('string', 'fixed_width_buf') {
+
+ # Currently, the only fixed_width_buf functions have the '_flags'
+ # suffix.
+ next if $operand eq 'fixed_width_buf' && $use_flags eq "";
+
+ my $name = "${base_name}utf8_$operand";
+
+ # We test each version of the function
+ for my $function ("_loclen", "_loc", "") {
+
+ # We test each function against
+ # a) valid input
+ # b) invalid input created by appending an out-of-place
+ # continuation character to the valid string
+ # c) input created by appending a partial character. This
+ # is valid in the 'fixed_width' functions, but invalid in
+ # the 'string' ones
+ # d) invalid input created by calling a function that is
+ # expecting a restricted form of the input using the string
+ # that's valid when unrestricted
+ for my $error_type (0, $cont_byte, $p, $restriction) {
+ #diag "restriction=$restriction, use_flags=$use_flags, function=$function, error_type=" . display_bytes($error_type);
+
+ # If there is no restriction, the error type will be "",
+ # which is redundant with 0.
+ next if $error_type eq "";
+
+ my $this_name = "$name$function$use_flags";
+ my $bytes
+ = $restriction_types{$restriction}{'valid_strings'};
+ my $expected_offset = length $bytes;
+ my $expected_count
+ = $restriction_types{$restriction}{'valid_counts'};
+ my $test_name_suffix = "";
+
+ my $this_error_type = $error_type;
+ if ($this_error_type) {
+
+ # Appending a bare continuation byte or a partial
+ # character doesn't change the character count or
+ # offset. But in the other cases, we have saved where
+ # the failures should occur, so use those. Appending
+ # a continuation byte makes it invalid; appending a
+ # partial character makes the 'string' form invalid,
+ # but not the 'fixed_width_buf' form.
+ if ($this_error_type eq $cont_byte || $this_error_type eq $p) {
+ $bytes .= $this_error_type;
+ if ($this_error_type eq $cont_byte) {
+ $test_name_suffix
+ = " for an unexpected continuation";
+ }
+ else {
+ $test_name_suffix
+ = " if ends with a partial character";
+ $this_error_type
+ = 0 if $operand eq "fixed_width_buf";
+ }
+ }
+ else {
+ $test_name_suffix
+ = " if contains forbidden code points";
+ if ($this_error_type eq "c9strict") {
+ $bytes = $restriction_types{""}{'valid_strings'};
+ $expected_offset
+ = $restriction_types{"c9strict"}
+ {'first_invalid_offset'};
+ $expected_count
+ = $restriction_types{"c9strict"}
+ {'first_invalid_count'};
+ }
+ elsif ($this_error_type eq "strict") {
+ $bytes = $restriction_types{""}{'valid_strings'};
+ $expected_offset
+ = $restriction_types{"strict"}
+ {'first_invalid_offset'};
+ $expected_count
+ = $restriction_types{"strict"}
+ {'first_invalid_count'};
+
+ }
+ elsif ($this_error_type eq "fits_in_31_bits") {
+ $bytes = $restriction_types{""}{'valid_strings'};
+ $expected_offset
+ = $restriction_types{"fits_in_31_bits"}
+ {'first_invalid_offset'};
+ $expected_count
+ = $restriction_types{"fits_in_31_bits"}
+ {'first_invalid_count'};
+ }
+ else {
+ fail("Internal test error: Unknown error type "
+ . "'$this_error_type'");
+ next;
+ }
+ }
+ }
+
+ my $length = length $bytes;
+ my $ret_ref;
+
+ my $test = "\$ret_ref = test_$this_name(\$bytes, $length";
+
+ # If using the _flags functions, we have to figure out what
+ # flags to pass. This is done to match the restriction.
+ if ($use_flags eq "_flags") {
+ if (! $restriction) {
+ $test .= ", 0"; # The flag
+
+ # Indicate the kind of flag in the test name.
+ $this_name .= "(0)";
+ }
+ else {
+ $this_name .= "($restriction)";
+ if ($restriction eq "c9strict") {
+ $test
+ .= ", $UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE";
+ }
+ elsif ($restriction eq "strict") {
+ $test .= ", $UTF8_DISALLOW_ILLEGAL_INTERCHANGE";
+ }
+ elsif ($restriction eq "fits_in_31_bits") {
+ $test .= ", $UTF8_DISALLOW_ABOVE_31_BIT";
+ }
+ else {
+ fail("Internal test error: Unknown restriction "
+ . "'$restriction'");
+ next;
+ }
+ }
+ }
+ $test .= ")";
+
+ # Actually run the test
+ eval $test;
+ if ($@) {
+ fail($test);
+ diag $@;
+ next;
+ }
+
+ my $ret;
+ my $error_offset;
+ my $cp_count;
+
+ if ($function eq "") {
+ $ret = $ret_ref; # For plain function, there's only a
+ # single return value
+ }
+ else { # Otherwise, the multiple values come in an array.
+ $ret = shift @$ret_ref ;
+ $error_offset = shift @$ret_ref;
+ $cp_count = shift@$ret_ref if $function eq "_loclen";
+ }
+
+ if ($this_error_type) {
+ is($ret, 0,
+ "Verify $this_name is FALSE$test_name_suffix");
+ }
+ else {
+ unless(is($ret, 1,
+ "Verify $this_name is TRUE for valid input"
+ . "$test_name_suffix"))
+ {
+ diag("The bytes starting at offset"
+ . " $error_offset are"
+ . display_bytes(substr(
+ $restriction_types{$restriction}
+ {'valid_strings'},
+ $error_offset)));
+ next;
+ }
+ }
+
+ if ($function ne "") {
+ unless (is($error_offset, $expected_offset,
+ "\tAnd returns the correct offset"))
+ {
+ my $min = ($error_offset < $expected_offset)
+ ? $error_offset
+ : $expected_offset;
+ diag display_bytes(substr($bytes, $min));
+ }
+
+ if ($function eq '_loclen') {
+ is($cp_count, $expected_count,
+ "\tAnd returns the correct character count");
+ }
+ }
+ }
+ }
+ }
}
}
my $REPLACEMENT = 0xFFFD;
# Now test the malformations. All these raise category utf8 warnings.
-my $c = (isASCII) ? "\x80" : "\xa0"; # A continuation byte
my @malformations = (
[ "zero length string malformation", "", 0,
- $UTF8_ALLOW_EMPTY, 0, 0,
+ $UTF8_ALLOW_EMPTY, $UTF8_GOT_EMPTY, 0, 0,
qr/empty string/
],
- [ "orphan continuation byte malformation", I8_to_native("${c}a"),
+ [ "orphan continuation byte malformation", I8_to_native("${I8c}a"),
2,
- $UTF8_ALLOW_CONTINUATION, $REPLACEMENT, 1,
+ $UTF8_ALLOW_CONTINUATION, $UTF8_GOT_CONTINUATION, $REPLACEMENT, 1,
qr/unexpected continuation byte/
],
[ "premature next character malformation (immediate)",
(isASCII) ? "\xc2\xc2\x80" : I8_to_native("\xc5\xc5\xa0"),
3,
- $UTF8_ALLOW_NON_CONTINUATION, $REPLACEMENT, 1,
+ $UTF8_ALLOW_NON_CONTINUATION, $UTF8_GOT_NON_CONTINUATION, $REPLACEMENT, 1,
qr/unexpected non-continuation byte.*immediately after start byte/
],
[ "premature next character malformation (non-immediate)",
- I8_to_native("\xf0${c}a"),
+ I8_to_native("\xf1${I8c}a"),
3,
- $UTF8_ALLOW_NON_CONTINUATION, $REPLACEMENT, 2,
+ $UTF8_ALLOW_NON_CONTINUATION, $UTF8_GOT_NON_CONTINUATION, $REPLACEMENT, 2,
qr/unexpected non-continuation byte .* 2 bytes after start byte/
],
- [ "too short malformation", I8_to_native("\xf0${c}a"), 2,
+ [ "too short malformation", I8_to_native("\xf1${I8c}a"), 2,
# Having the 'a' after this, but saying there are only 2 bytes also
# tests that we pay attention to the passed in length
- $UTF8_ALLOW_SHORT, $REPLACEMENT, 2,
+ $UTF8_ALLOW_SHORT, $UTF8_GOT_SHORT, $REPLACEMENT, 2,
qr/2 bytes, need 4/
],
[ "overlong malformation, lowest 2-byte",
(isASCII) ? "\xc0\x80" : I8_to_native("\xc0\xa0"),
2,
- $UTF8_ALLOW_LONG,
+ $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
0, # NUL
2,
- qr/2 bytes, need 1/
+ qr/overlong/
],
[ "overlong malformation, highest 2-byte",
(isASCII) ? "\xc1\xbf" : I8_to_native("\xc4\xbf"),
2,
- $UTF8_ALLOW_LONG,
+ $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
(isASCII) ? 0x7F : utf8::unicode_to_native(0xBF),
2,
- qr/2 bytes, need 1/
+ qr/overlong/
],
[ "overlong malformation, lowest 3-byte",
(isASCII) ? "\xe0\x80\x80" : I8_to_native("\xe0\xa0\xa0"),
3,
- $UTF8_ALLOW_LONG,
+ $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
0, # NUL
3,
- qr/3 bytes, need 1/
+ qr/overlong/
],
[ "overlong malformation, highest 3-byte",
(isASCII) ? "\xe0\x9f\xbf" : I8_to_native("\xe0\xbf\xbf"),
3,
- $UTF8_ALLOW_LONG,
+ $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
(isASCII) ? 0x7FF : 0x3FF,
3,
- qr/3 bytes, need 2/
+ qr/overlong/
],
[ "overlong malformation, lowest 4-byte",
(isASCII) ? "\xf0\x80\x80\x80" : I8_to_native("\xf0\xa0\xa0\xa0"),
4,
- $UTF8_ALLOW_LONG,
+ $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
0, # NUL
4,
- qr/4 bytes, need 1/
+ qr/overlong/
],
[ "overlong malformation, highest 4-byte",
(isASCII) ? "\xf0\x8F\xbf\xbf" : I8_to_native("\xf0\xaf\xbf\xbf"),
4,
- $UTF8_ALLOW_LONG,
+ $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
(isASCII) ? 0xFFFF : 0x3FFF,
4,
- qr/4 bytes, need 3/
+ qr/overlong/
],
[ "overlong malformation, lowest 5-byte",
(isASCII)
? "\xf8\x80\x80\x80\x80"
: I8_to_native("\xf8\xa0\xa0\xa0\xa0"),
5,
- $UTF8_ALLOW_LONG,
+ $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
0, # NUL
5,
- qr/5 bytes, need 1/
+ qr/overlong/
],
[ "overlong malformation, highest 5-byte",
(isASCII)
? "\xf8\x87\xbf\xbf\xbf"
: I8_to_native("\xf8\xa7\xbf\xbf\xbf"),
5,
- $UTF8_ALLOW_LONG,
+ $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
(isASCII) ? 0x1FFFFF : 0x3FFFF,
5,
- qr/5 bytes, need 4/
+ qr/overlong/
],
[ "overlong malformation, lowest 6-byte",
(isASCII)
? "\xfc\x80\x80\x80\x80\x80"
: I8_to_native("\xfc\xa0\xa0\xa0\xa0\xa0"),
6,
- $UTF8_ALLOW_LONG,
+ $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
0, # NUL
6,
- qr/6 bytes, need 1/
+ qr/overlong/
],
[ "overlong malformation, highest 6-byte",
(isASCII)
? "\xfc\x83\xbf\xbf\xbf\xbf"
: I8_to_native("\xfc\xa3\xbf\xbf\xbf\xbf"),
6,
- $UTF8_ALLOW_LONG,
+ $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
(isASCII) ? 0x3FFFFFF : 0x3FFFFF,
6,
- qr/6 bytes, need 5/
+ qr/overlong/
],
[ "overlong malformation, lowest 7-byte",
(isASCII)
? "\xfe\x80\x80\x80\x80\x80\x80"
: I8_to_native("\xfe\xa0\xa0\xa0\xa0\xa0\xa0"),
7,
- $UTF8_ALLOW_LONG,
+ $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
0, # NUL
7,
- qr/7 bytes, need 1/
+ qr/overlong/
],
[ "overlong malformation, highest 7-byte",
(isASCII)
? "\xfe\x81\xbf\xbf\xbf\xbf\xbf"
: I8_to_native("\xfe\xa1\xbf\xbf\xbf\xbf\xbf"),
7,
- $UTF8_ALLOW_LONG,
+ $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
(isASCII) ? 0x7FFFFFFF : 0x3FFFFFF,
7,
- qr/7 bytes, need 6/
+ qr/overlong/
],
);
"\xfe\x84\x80\x80\x80\x80\x80", # Represents 2**32
7,
0, # There is no way to allow this malformation
+ $UTF8_GOT_OVERFLOW,
$REPLACEMENT,
7,
- qr/overflow/
+ qr/overflows/
],
[ "overflow malformation, can tell on first byte",
"\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80",
13,
0, # There is no way to allow this malformation
+ $UTF8_GOT_OVERFLOW,
$REPLACEMENT,
13,
- qr/overflow/
+ qr/overflows/
];
}
else {
? "\xff\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80"
: I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
(isASCII) ? 13 : 14,
- $UTF8_ALLOW_LONG,
+ $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
0, # NUL
(isASCII) ? 13 : 14,
- qr/1[34] bytes, need 1/, # 1[34] to work on either ASCII or EBCDIC
+ qr/overlong/,
],
[ "overlong malformation, highest max-byte",
(isASCII) # 2**36-1 on ASCII; 2**30-1 on EBCDIC
? "\xff\x80\x80\x80\x80\x80\x80\xbf\xbf\xbf\xbf\xbf\xbf"
: I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xbf\xbf\xbf\xbf\xbf\xbf"),
(isASCII) ? 13 : 14,
- $UTF8_ALLOW_LONG,
+ $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
(isASCII) ? 0xFFFFFFFFF : 0x3FFFFFFF,
(isASCII) ? 13 : 14,
- qr/1[34] bytes, need 7/,
+ qr/overlong/,
];
if (! $is64bit) { # 32-bit EBCDIC
I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa4\xa0\xa0\xa0\xa0\xa0\xa0"),
14,
0, # There is no way to allow this malformation
+ $UTF8_GOT_OVERFLOW,
$REPLACEMENT,
14,
- qr/overflow/
+ qr/overflows/
];
}
else { # 64-bit
: I8_to_native("\xff\xb0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
(isASCII) ? 13 : 14,
0, # There is no way to allow this malformation
+ $UTF8_GOT_OVERFLOW,
$REPLACEMENT,
(isASCII) ? 13 : 14,
- qr/overflow/
+ qr/overflows/
];
}
}
foreach my $test (@malformations) {
- my ($testname, $bytes, $length, $allow_flags, $allowed_uv, $expected_len, $message ) = @$test;
-
- next if ! ok(length($bytes) >= $length, "$testname: Make sure won't read beyond buffer: " . length($bytes) . " >= $length");
+ my ($testname, $bytes, $length, $allow_flags, $expected_error_flags,
+ $allowed_uv, $expected_len, $message ) = @$test;
+
+ if (length($bytes) < $length) {
+ fail("Internal test error: actual buffer length (" . length($bytes)
+ . ") must be at least as high as how far we are allowed to read"
+ . " into it ($length)");
+ diag($testname);
+ next;
+ }
undef @warnings;
unless (is(scalar @warnings, 0,
"$testname: isUTF8_CHAR() generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
undef @warnings;
unless (is(scalar @warnings, 0,
"$testname: isUTF8_CHAR() generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
$ret = test_isSTRICT_UTF8_CHAR($bytes, $length);
unless (is(scalar @warnings, 0,
"$testname: isSTRICT_UTF8_CHAR() generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
$ret = test_isC9_STRICT_UTF8_CHAR($bytes, $length);
unless (is(scalar @warnings, 0,
"$testname: isC9_STRICT_UTF8_CHAR() generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
for my $j (1 .. $length - 1) {
$ret = test_is_utf8_valid_partial_char_flags($bytes, $j, 0);
my $ret_should_be = 0;
my $comment = "";
- if ($testname =~ /premature|short/ && $j < 2) {
- $ret_should_be = 1;
- $comment = ", but need 2 bytes to discern:";
+ if ($testname =~ /premature|short/ && $j < 3) {
+
+ # The tests are hard-coded so these relationships hold
+ my $cut_off = 2;
+ $cut_off = 3 if $testname =~ /non-immediate/;
+ if ($j < $cut_off) {
+ $ret_should_be = 1;
+ $comment = ", but need $cut_off bytes to discern:";
+ }
+ }
+ elsif ($testname =~ /overlong/ && ! isASCII && $length == 3) {
+ # 3-byte overlongs on EBCDIC are determinable on the first byte
}
elsif ($testname =~ /overlong/ && $length > 2) {
if ($length <= 7 && $j < 2) {
unless (is(scalar @warnings, 0,
"$testname: is_utf8_valid_partial_char_flags() generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
}
# Test what happens when this malformation is not allowed
undef @warnings;
- my $ret_ref = test_utf8n_to_uvchr($bytes, $length, 0);
+ my $ret_ref = test_utf8n_to_uvchr_error($bytes, $length, 0);
is($ret_ref->[0], 0, "$testname: disallowed: Returns 0");
- is($ret_ref->[1], $expected_len, "$testname: utf8n_to_uvchr(), disallowed: Returns expected length: $expected_len");
- if (is(scalar @warnings, 1, "$testname: disallowed: Got a single warning ")) {
- like($warnings[0], $message, "$testname: disallowed: Got expected warning");
+ is($ret_ref->[1], $expected_len,
+ "$testname: utf8n_to_uvchr_error(), disallowed: Returns expected"
+ . " length: $expected_len");
+ if (is(scalar @warnings, 1,
+ "$testname: disallowed: Got a single warning "))
+ {
+ like($warnings[0], $message,
+ "$testname: disallowed: Got expected warning");
}
else {
if (scalar @warnings) {
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
}
+ is($ret_ref->[2], $expected_error_flags,
+ "$testname: utf8n_to_uvchr_error(), disallowed:"
+ . " Returns expected error");
{ # Next test when disallowed, and warnings are off.
undef @warnings;
no warnings 'utf8';
- my $ret_ref = test_utf8n_to_uvchr($bytes, $length, 0);
- is($ret_ref->[0], 0, "$testname: utf8n_to_uvchr(), disallowed: no warnings 'utf8': Returns 0");
- is($ret_ref->[1], $expected_len, "$testname: utf8n_to_uvchr(), disallowed: no warnings 'utf8': Returns expected length: $expected_len");
- if (!is(scalar @warnings, 0, "$testname: utf8n_to_uvchr(), disallowed: no warnings 'utf8': no warnings generated")) {
- diag "The warnings were: " . join(", ", @warnings);
+ my $ret_ref = test_utf8n_to_uvchr_error($bytes, $length, 0);
+ is($ret_ref->[0], 0,
+ "$testname: utf8n_to_uvchr_error(), disallowed: no warnings 'utf8':"
+ . " Returns 0");
+ is($ret_ref->[1], $expected_len,
+ "$testname: utf8n_to_uvchr_error(), disallowed: no warnings 'utf8':"
+ . " Returns expected length: $expected_len");
+ if (!is(scalar @warnings, 0,
+ "$testname: utf8n_to_uvchr_error(), disallowed: no warnings 'utf8':"
+ . " no warnings generated"))
+ {
+ output_warnings(@warnings);
}
+ is($ret_ref->[2], $expected_error_flags,
+ "$testname: utf8n_to_uvchr_error(), disallowed: Returns"
+ . " expected error");
}
# Test with CHECK_ONLY
undef @warnings;
- $ret_ref = test_utf8n_to_uvchr($bytes, $length, $UTF8_CHECK_ONLY);
+ $ret_ref = test_utf8n_to_uvchr_error($bytes, $length, $UTF8_CHECK_ONLY);
is($ret_ref->[0], 0, "$testname: CHECK_ONLY: Returns 0");
is($ret_ref->[1], -1, "$testname: CHECK_ONLY: returns -1 for length");
if (! is(scalar @warnings, 0, "$testname: CHECK_ONLY: no warnings generated")) {
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
+ is($ret_ref->[2], $expected_error_flags,
+ "$testname: utf8n_to_uvchr_error(), disallowed: Returns expected"
+ . " error");
next if $allow_flags == 0; # Skip if can't allow this malformation
# Test when the malformation is allowed
undef @warnings;
- $ret_ref = test_utf8n_to_uvchr($bytes, $length, $allow_flags);
- is($ret_ref->[0], $allowed_uv, "$testname: utf8n_to_uvchr(), allowed: Returns expected uv: " . sprintf("0x%04X", $allowed_uv));
- is($ret_ref->[1], $expected_len, "$testname: utf8n_to_uvchr(), allowed: Returns expected length: $expected_len");
- if (!is(scalar @warnings, 0, "$testname: utf8n_to_uvchr(), allowed: no warnings generated"))
+ $ret_ref = test_utf8n_to_uvchr_error($bytes, $length, $allow_flags);
+ is($ret_ref->[0], $allowed_uv,
+ "$testname: utf8n_to_uvchr_error(), allowed: Returns expected uv: "
+ . sprintf("0x%04X", $allowed_uv));
+ is($ret_ref->[1], $expected_len,
+ "$testname: utf8n_to_uvchr_error(), allowed: Returns expected length:"
+ . " $expected_len");
+ if (!is(scalar @warnings, 0,
+ "$testname: utf8n_to_uvchr_error(), allowed: no warnings"
+ . " generated"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
+ is($ret_ref->[2], $expected_error_flags,
+ "$testname: utf8n_to_uvchr_error(), disallowed: Returns"
+ . " expected error");
+}
+
+sub nonportable_regex ($) {
+
+ # Returns a pattern that matches the non-portable message raised either
+ # for the specific input code point, or the one generated when there
+ # is some malformation that precludes the message containing the specific
+ # code point
+
+ my $code_point = shift;
+
+ my $string = sprintf '(Code point 0x%x is not Unicode, and'
+ . '|Any UTF-8 sequence that starts with'
+ . ' "(\\\x[[:xdigit:]]{2})+" is for a'
+ . ' non-Unicode code point, and is) not portable',
+ $code_point;
+ return qr/$string/;
}
# Now test the cases where a legal code point is generated, but may or may not
my @tests = (
[ "lowest surrogate",
(isASCII) ? "\xed\xa0\x80" : I8_to_native("\xf1\xb6\xa0\xa0"),
- $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE,
+ $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE, $UTF8_GOT_SURROGATE,
'surrogate', 0xD800,
(isASCII) ? 3 : 4,
qr/surrogate/
],
[ "a middle surrogate",
(isASCII) ? "\xed\xa4\x8d" : I8_to_native("\xf1\xb6\xa8\xad"),
- $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE,
+ $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE, $UTF8_GOT_SURROGATE,
'surrogate', 0xD90D,
(isASCII) ? 3 : 4,
qr/surrogate/
],
[ "highest surrogate",
(isASCII) ? "\xed\xbf\xbf" : I8_to_native("\xf1\xb7\xbf\xbf"),
- $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE,
+ $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE, $UTF8_GOT_SURROGATE,
'surrogate', 0xDFFF,
(isASCII) ? 3 : 4,
qr/surrogate/
],
[ "first non_unicode",
(isASCII) ? "\xf4\x90\x80\x80" : I8_to_native("\xf9\xa2\xa0\xa0\xa0"),
- $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER,
+ $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER, $UTF8_GOT_SUPER,
'non_unicode', 0x110000,
(isASCII) ? 4 : 5,
- qr/not Unicode.* may not be portable/
+ qr/(not Unicode|for a non-Unicode code point).* may not be portable/
],
[ "non_unicode whose first byte tells that",
(isASCII) ? "\xf5\x80\x80\x80" : I8_to_native("\xfa\xa0\xa0\xa0\xa0"),
- $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER,
+ $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER, $UTF8_GOT_SUPER,
'non_unicode',
(isASCII) ? 0x140000 : 0x200000,
(isASCII) ? 4 : 5,
- qr/not Unicode.* may not be portable/
+ qr/(not Unicode|for a non-Unicode code point).* may not be portable/
],
[ "first of 32 consecutive non-character code points",
(isASCII) ? "\xef\xb7\x90" : I8_to_native("\xf1\xbf\xae\xb0"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xFDD0,
(isASCII) ? 3 : 4,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "a mid non-character code point of the 32 consecutive ones",
(isASCII) ? "\xef\xb7\xa0" : I8_to_native("\xf1\xbf\xaf\xa0"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xFDE0,
(isASCII) ? 3 : 4,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "final of 32 consecutive non-character code points",
(isASCII) ? "\xef\xb7\xaf" : I8_to_native("\xf1\xbf\xaf\xaf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xFDEF,
(isASCII) ? 3 : 4,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+FFFE",
(isASCII) ? "\xef\xbf\xbe" : I8_to_native("\xf1\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xFFFE,
(isASCII) ? 3 : 4,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+FFFF",
(isASCII) ? "\xef\xbf\xbf" : I8_to_native("\xf1\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xFFFF,
(isASCII) ? 3 : 4,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+1FFFE",
(isASCII) ? "\xf0\x9f\xbf\xbe" : I8_to_native("\xf3\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x1FFFE, 4,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+1FFFF",
(isASCII) ? "\xf0\x9f\xbf\xbf" : I8_to_native("\xf3\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x1FFFF, 4,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+2FFFE",
(isASCII) ? "\xf0\xaf\xbf\xbe" : I8_to_native("\xf5\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x2FFFE, 4,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+2FFFF",
(isASCII) ? "\xf0\xaf\xbf\xbf" : I8_to_native("\xf5\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x2FFFF, 4,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+3FFFE",
(isASCII) ? "\xf0\xbf\xbf\xbe" : I8_to_native("\xf7\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x3FFFE, 4,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+3FFFF",
(isASCII) ? "\xf0\xbf\xbf\xbf" : I8_to_native("\xf7\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x3FFFF, 4,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+4FFFE",
(isASCII) ? "\xf1\x8f\xbf\xbe" : I8_to_native("\xf8\xa9\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x4FFFE,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+4FFFF",
(isASCII) ? "\xf1\x8f\xbf\xbf" : I8_to_native("\xf8\xa9\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x4FFFF,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+5FFFE",
(isASCII) ? "\xf1\x9f\xbf\xbe" : I8_to_native("\xf8\xab\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x5FFFE,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+5FFFF",
(isASCII) ? "\xf1\x9f\xbf\xbf" : I8_to_native("\xf8\xab\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x5FFFF,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+6FFFE",
(isASCII) ? "\xf1\xaf\xbf\xbe" : I8_to_native("\xf8\xad\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x6FFFE,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+6FFFF",
(isASCII) ? "\xf1\xaf\xbf\xbf" : I8_to_native("\xf8\xad\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x6FFFF,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+7FFFE",
(isASCII) ? "\xf1\xbf\xbf\xbe" : I8_to_native("\xf8\xaf\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x7FFFE,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+7FFFF",
(isASCII) ? "\xf1\xbf\xbf\xbf" : I8_to_native("\xf8\xaf\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x7FFFF,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+8FFFE",
(isASCII) ? "\xf2\x8f\xbf\xbe" : I8_to_native("\xf8\xb1\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x8FFFE,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+8FFFF",
(isASCII) ? "\xf2\x8f\xbf\xbf" : I8_to_native("\xf8\xb1\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x8FFFF,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+9FFFE",
(isASCII) ? "\xf2\x9f\xbf\xbe" : I8_to_native("\xf8\xb3\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x9FFFE,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+9FFFF",
(isASCII) ? "\xf2\x9f\xbf\xbf" : I8_to_native("\xf8\xb3\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x9FFFF,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+AFFFE",
(isASCII) ? "\xf2\xaf\xbf\xbe" : I8_to_native("\xf8\xb5\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xAFFFE,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+AFFFF",
(isASCII) ? "\xf2\xaf\xbf\xbf" : I8_to_native("\xf8\xb5\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xAFFFF,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+BFFFE",
(isASCII) ? "\xf2\xbf\xbf\xbe" : I8_to_native("\xf8\xb7\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xBFFFE,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+BFFFF",
(isASCII) ? "\xf2\xbf\xbf\xbf" : I8_to_native("\xf8\xb7\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xBFFFF,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+CFFFE",
(isASCII) ? "\xf3\x8f\xbf\xbe" : I8_to_native("\xf8\xb9\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xCFFFE,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+CFFFF",
(isASCII) ? "\xf3\x8f\xbf\xbf" : I8_to_native("\xf8\xb9\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xCFFFF,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+DFFFE",
(isASCII) ? "\xf3\x9f\xbf\xbe" : I8_to_native("\xf8\xbb\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xDFFFE,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+DFFFF",
(isASCII) ? "\xf3\x9f\xbf\xbf" : I8_to_native("\xf8\xbb\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xDFFFF,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+EFFFE",
(isASCII) ? "\xf3\xaf\xbf\xbe" : I8_to_native("\xf8\xbd\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xEFFFE,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+EFFFF",
(isASCII) ? "\xf3\xaf\xbf\xbf" : I8_to_native("\xf8\xbd\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xEFFFF,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+FFFFE",
(isASCII) ? "\xf3\xbf\xbf\xbe" : I8_to_native("\xf8\xbf\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xFFFFE,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+FFFFF",
(isASCII) ? "\xf3\xbf\xbf\xbf" : I8_to_native("\xf8\xbf\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xFFFFF,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+10FFFE",
(isASCII) ? "\xf4\x8f\xbf\xbe" : I8_to_native("\xf9\xa1\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x10FFFE,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+10FFFF",
(isASCII) ? "\xf4\x8f\xbf\xbf" : I8_to_native("\xf9\xa1\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x10FFFF,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
# This code point is chosen so that it is representable in a UV on
# 32-bit machines
$UTF8_WARN_ABOVE_31_BIT, $UTF8_DISALLOW_ABOVE_31_BIT,
+ $UTF8_GOT_ABOVE_31_BIT,
'utf8', 0x80000000, (isASCII) ? 7 :14,
- qr/Code point 0x80000000 is not Unicode, and not portable/
+ nonportable_regex(0x80000000)
],
[ "requires at least 32 bits, and use SUPER-type flags, instead of ABOVE_31_BIT",
(isASCII)
? "\xfe\x82\x80\x80\x80\x80\x80"
: I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"),
- $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER,
+ $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER, $UTF8_GOT_SUPER,
'utf8', 0x80000000, (isASCII) ? 7 :14,
- qr/Code point 0x80000000 is not Unicode, and not portable/
+ nonportable_regex(0x80000000)
],
[ "overflow with warnings/disallow for more than 31 bits",
# This tests the interaction of WARN_ABOVE_31_BIT/DISALLOW_ABOVE_31_BIT
: ((isASCII)
? "\xfe\x86\x80\x80\x80\x80\x80"
: I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa4\xa0\xa0\xa0\xa0\xa0\xa0"))),
-
- # We include both warning categories to make sure the ABOVE_31_BIT one
- # has precedence
- "$UTF8_WARN_ABOVE_31_BIT|$UTF8_WARN_SUPER",
- "$UTF8_DISALLOW_ABOVE_31_BIT",
+ $UTF8_WARN_ABOVE_31_BIT,
+ $UTF8_DISALLOW_ABOVE_31_BIT,
+ $UTF8_GOT_ABOVE_31_BIT,
'utf8', 0,
(! isASCII) ? 14 : ($is64bit) ? 13 : 7,
- qr/overflow at byte .*, after start byte 0xf/
+ qr/overflows/
],
);
? "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80"
: I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
$UTF8_WARN_ABOVE_31_BIT, $UTF8_DISALLOW_ABOVE_31_BIT,
+ $UTF8_GOT_ABOVE_31_BIT,
'utf8', 0x1000000000, (isASCII) ? 13 : 14,
- qr/Code point 0x.* is not Unicode, and not portable/
+ qr/and( is)? not portable/
];
if (! isASCII) {
push @tests, # These could falsely show wrongly in a naive implementation
[ "requires at least 32 bits",
I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
$UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
+ $UTF8_GOT_ABOVE_31_BIT,
'utf8', 0x800000000, 14,
- qr/Code point 0x800000000 is not Unicode, and not portable/
+ nonportable_regex(0x80000000)
],
[ "requires at least 32 bits",
I8_to_native("\xff\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
$UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
+ $UTF8_GOT_ABOVE_31_BIT,
'utf8', 0x10000000000, 14,
- qr/Code point 0x10000000000 is not Unicode, and not portable/
+ nonportable_regex(0x10000000000)
],
[ "requires at least 32 bits",
I8_to_native("\xff\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
$UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
+ $UTF8_GOT_ABOVE_31_BIT,
'utf8', 0x200000000000, 14,
- qr/Code point 0x200000000000 is not Unicode, and not portable/
+ nonportable_regex(0x20000000000)
],
[ "requires at least 32 bits",
I8_to_native("\xff\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
$UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
+ $UTF8_GOT_ABOVE_31_BIT,
'utf8', 0x4000000000000, 14,
- qr/Code point 0x4000000000000 is not Unicode, and not portable/
+ nonportable_regex(0x4000000000000)
],
[ "requires at least 32 bits",
I8_to_native("\xff\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
$UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
+ $UTF8_GOT_ABOVE_31_BIT,
'utf8', 0x80000000000000, 14,
- qr/Code point 0x80000000000000 is not Unicode, and not portable/
+ nonportable_regex(0x80000000000000)
],
[ "requires at least 32 bits",
I8_to_native("\xff\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
+ #IBM-1047 \xFE\x41\x41\x41\x41\x41\x41\x43\x41\x41\x41\x41\x41\x41
$UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
+ $UTF8_GOT_ABOVE_31_BIT,
'utf8', 0x1000000000000000, 14,
- qr/Code point 0x1000000000000000 is not Unicode, and not portable/
+ nonportable_regex(0x1000000000000000)
];
}
}
foreach my $test (@tests) {
- my ($testname, $bytes, $warn_flags, $disallow_flags, $category, $allowed_uv, $expected_len, $message ) = @$test;
+ my ($testname, $bytes, $warn_flags, $disallow_flags, $expected_error_flags,
+ $category, $allowed_uv, $expected_len, $message ) = @$test;
my $length = length $bytes;
- my $will_overflow = $testname =~ /overflow/;
+ my $will_overflow = $testname =~ /overflow/ ? 'overflow' : "";
{
use warnings;
unless (is(scalar @warnings, 0,
"isUTF8_CHAR() and isUTF8_CHAR()_flags $testname: generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
undef @warnings;
unless (is(scalar @warnings, 0,
"isSTRICT_UTF8_CHAR() and isUTF8_CHAR_flags $testname: generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
undef @warnings;
unless (is(scalar @warnings, 0,
"isC9_STRICT_UTF8_CHAR() and isUTF8_CHAR_flags $testname: generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
# Test partial character handling, for each byte not a full character
$comment .= ", but need 2 bytes to discern";
}
}
- elsif ($testname =~ /first non_unicode/ && $j < 2) {
+ elsif ( ($disallow_flags & $UTF8_DISALLOW_SUPER)
+ && $j < 2
+ && ord(native_to_I8(substr($bytes, 0, 1)))
+ lt ((isASCII) ? 0xF5 : 0xFA))
+ {
$ret_should_be = 1;
$comment .= ", but need 2 bytes to discern";
}
+ elsif ( ! isASCII
+ && $testname =~ /requires at least 32 bits/)
+ {
+ # On EBCDIC, the boundary between 31 and 32 bits is
+ # more complicated.
+ $ret_should_be = 1 if native_to_I8($partial) le
+ "\xFF\xA0\xA0\xA0\xA0\xA0\xA0\xA1\xBF\xBF\xBF\xBF\xBF\xBF";
+ }
}
undef @warnings;
unless (is(scalar @warnings, 0,
"$testname: is_utf8_valid_partial_char_flags() generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
}
}
foreach my $disallow_flag (0, $disallow_flags) {
foreach my $do_warning (0, 1) {
- my $eval_warn = $do_warning
- ? "use warnings '$warning'"
- : $warning eq "utf8"
- ? "no warnings 'utf8'"
- : "use warnings 'utf8'; no warnings '$warning'";
-
- # is effectively disallowed if will overflow, even if the
- # flag indicates it is allowed, fix up test name to
- # indicate this as well
- my $disallowed = $disallow_flag || $will_overflow;
-
- my $this_name = "utf8n_to_uvchr() $testname: " . (($disallow_flag)
- ? 'disallowed'
- : ($disallowed)
- ? 'ABOVE_31_BIT allowed'
- : 'allowed');
- $this_name .= ", $eval_warn";
- $this_name .= ", " . (($warn_flag)
- ? 'with warning flag'
- : 'no warning flag');
-
- undef @warnings;
- my $ret_ref;
- my $display_bytes = display_bytes($bytes);
- my $call = "Call was: $eval_warn; \$ret_ref = test_utf8n_to_uvchr('$display_bytes', $length, $warn_flag|$disallow_flag)";
- my $eval_text = "$eval_warn; \$ret_ref = test_utf8n_to_uvchr('$bytes', $length, $warn_flag|$disallow_flag)";
- eval "$eval_text";
- if (! ok ("$@ eq ''", "$this_name: eval succeeded")) {
- diag "\$!='$!'; eval'd=\"$call\"";
- next;
- }
- if ($disallowed) {
- unless (is($ret_ref->[0], 0, "$this_name: Returns 0"))
- {
- diag $call;
- }
- }
- else {
- unless (is($ret_ref->[0], $allowed_uv,
- "$this_name: Returns expected uv: "
- . sprintf("0x%04X", $allowed_uv)))
- {
- diag $call;
- }
- }
- unless (is($ret_ref->[1], $expected_len,
- "$this_name: Returns expected length: $expected_len"))
+ # We try each of the above with various combinations of
+ # malformations that can occur on the same input sequence.
+ foreach my $short ("",
+ "short",
+ "unexpected non-continuation")
{
- diag $call;
- }
+ # The non-characters can't be discerned with a short
+ # malformation
+ next if $short && $testname =~ /non-character/;
+
+ foreach my $overlong ("", "overlong") {
+
+ # Our hard-coded overlong starts with \xFE, so
+ # can't handle anything larger.
+ next if $overlong
+ && ord native_to_I8(substr($bytes, 0, 1)) >= 0xFE;
+
+ my @malformations;
+ my @expected_errors;
+ push @malformations, $short if $short;
+ push @malformations, $overlong if $overlong;
+
+ # The overflow malformation test in the input
+ # array is coerced into being treated like one of
+ # the others.
+ if ($will_overflow) {
+ push @malformations, 'overflow';
+ push @expected_errors, $UTF8_GOT_OVERFLOW;
+ }
- if (! $do_warning
- && ($warning eq 'utf8' || $warning eq $category))
- {
- if (!is(scalar @warnings, 0,
- "$this_name: No warnings generated"))
- {
- diag $call;
- diag "The warnings were: " . join(", ", @warnings);
- }
- }
- elsif ($will_overflow
- && ! $disallow_flag
- && $warning eq 'utf8')
- {
+ my $malformations_name = join "/", @malformations;
+ $malformations_name .= " malformation"
+ if $malformations_name;
+ $malformations_name .= "s" if @malformations > 1;
+ my $this_bytes = $bytes;
+ my $this_length = $length;
+ my $expected_uv = $allowed_uv;
+ my $this_expected_len = $expected_len;
+ if ($malformations_name) {
+ $expected_uv = 0;
+
+ # Coerce the input into the desired
+ # malformation
+ if ($malformations_name =~ /overlong/) {
+
+ # For an overlong, we convert the original
+ # start byte into a continuation byte with
+ # the same data bits as originally. ...
+ substr($this_bytes, 0, 1)
+ = start_byte_to_cont(substr($this_bytes,
+ 0, 1));
+
+ # ... Then we prepend it with a known
+ # overlong sequence. This should evaluate
+ # to the exact same code point as the
+ # original.
+ $this_bytes = "\xfe"
+ . ("\x80"
+ x ( 6 - length($this_bytes)))
+ . $this_bytes;
+ $this_length = length($this_bytes);
+ $this_expected_len = 7;
+ push @expected_errors, $UTF8_GOT_LONG;
+ }
+ if ($malformations_name =~ /short/) {
+
+ # Just tell the test to not look far
+ # enough into the input.
+ $this_length--;
+ $this_expected_len--;
+ push @expected_errors, $UTF8_GOT_SHORT;
+ }
+ elsif ($malformations_name
+ =~ /non-continuation/)
+ {
+ # Change the final continuation byte into
+ # a non one.
+ substr($this_bytes, -1, 1) = '?';
+ $this_expected_len--;
+ push @expected_errors,
+ $UTF8_GOT_NON_CONTINUATION;
+ }
+ }
- # Will get the overflow message instead of the expected
- # message under these circumstances, as they would
- # otherwise accept an overflowed value, which the code
- # should not allow, so falls back to overflow.
- if (is(scalar @warnings, 1,
- "$this_name: Got a single warning "))
- {
- unless (like($warnings[0], qr/overflow/,
- "$this_name: Got overflow warning"))
+ my $eval_warn = $do_warning
+ ? "use warnings '$warning'"
+ : $warning eq "utf8"
+ ? "no warnings 'utf8'"
+ : ( "use warnings 'utf8';"
+ . " no warnings '$warning'");
+
+ # Is effectively disallowed if we've set up a
+ # malformation, even if the flag indicates it is
+ # allowed. Fix up test name to indicate this as
+ # well
+ my $disallowed = $disallow_flag
+ || $malformations_name;
+ my $this_name = "utf8n_to_uvchr_error() $testname: "
+ . (($disallow_flag)
+ ? 'disallowed'
+ : $disallowed
+ ? $disallowed
+ : 'allowed');
+ $this_name .= ", $eval_warn";
+ $this_name .= ", " . (($warn_flag)
+ ? 'with warning flag'
+ : 'no warning flag');
+
+ undef @warnings;
+ my $ret_ref;
+ my $display_bytes = display_bytes($this_bytes);
+ my $call = "Call was: $eval_warn; \$ret_ref"
+ . " = test_utf8n_to_uvchr_error("
+ . "'$display_bytes', $this_length,"
+ . "$warn_flag"
+ . "|$disallow_flag)";
+ my $eval_text = "$eval_warn; \$ret_ref"
+ . " = test_utf8n_to_uvchr_error("
+ . "'$this_bytes',"
+ . " $this_length, $warn_flag"
+ . "|$disallow_flag)";
+ eval "$eval_text";
+ if (! ok ("$@ eq ''",
+ "$this_name: eval succeeded"))
{
- diag $call;
+ diag "\$!='$!'; eval'd=\"$call\"";
+ next;
}
- }
- else {
- diag $call;
- if (scalar @warnings) {
- diag "The warnings were: "
- . join(", ", @warnings);
+ if ($disallowed) {
+ unless (is($ret_ref->[0], 0,
+ "$this_name: Returns 0"))
+ {
+ diag $call;
+ }
}
- }
- }
- elsif ($warn_flag
- && ($warning eq 'utf8' || $warning eq $category))
- {
- if (is(scalar @warnings, 1,
- "$this_name: Got a single warning "))
- {
- unless (like($warnings[0], $message,
- "$this_name: Got expected warning"))
+ else {
+ unless (is($ret_ref->[0], $expected_uv,
+ "$this_name: Returns expected uv: "
+ . sprintf("0x%04X", $expected_uv)))
+ {
+ diag $call;
+ }
+ }
+ unless (is($ret_ref->[1], $this_expected_len,
+ "$this_name: Returns expected length:"
+ . " $this_expected_len"))
{
diag $call;
}
- }
- else {
- diag $call;
- if (scalar @warnings) {
- diag "The warnings were: "
- . join(", ", @warnings);
- }
- }
- }
- # Check CHECK_ONLY results when the input is disallowed. Do
- # this when actually disallowed, not just when the
- # $disallow_flag is set
- if ($disallowed) {
- undef @warnings;
- $ret_ref = test_utf8n_to_uvchr($bytes, $length,
- $disallow_flag|$UTF8_CHECK_ONLY);
- unless (is($ret_ref->[0], 0, "$this_name, CHECK_ONLY: Returns 0")) {
- diag $call;
- }
- unless (is($ret_ref->[1], -1,
- "$this_name: CHECK_ONLY: returns -1 for length"))
- {
- diag $call;
- }
- if (! is(scalar @warnings, 0,
- "$this_name, CHECK_ONLY: no warnings generated"))
- {
- diag $call;
- diag "The warnings were: " . join(", ", @warnings);
- }
- }
+ my $errors = $ret_ref->[2];
- # Now repeat some of the above, but for
- # uvchr_to_utf8_flags(). Since this comes from an
- # existing code point, it hasn't overflowed.
- next if $will_overflow;
-
- # The warning and disallow flags passed in are for
- # utf8n_to_uvchr(). Convert them for
- # uvchr_to_utf8_flags().
- my $uvchr_warn_flag = 0;
- my $uvchr_disallow_flag = 0;
- if ($warn_flag) {
- if ($warn_flag == $UTF8_WARN_SURROGATE) {
- $uvchr_warn_flag = $UNICODE_WARN_SURROGATE
- }
- elsif ($warn_flag == $UTF8_WARN_NONCHAR) {
- $uvchr_warn_flag = $UNICODE_WARN_NONCHAR
- }
- elsif ($warn_flag == $UTF8_WARN_SUPER) {
- $uvchr_warn_flag = $UNICODE_WARN_SUPER
- }
- elsif ($warn_flag == $UTF8_WARN_ABOVE_31_BIT) {
- $uvchr_warn_flag = $UNICODE_WARN_ABOVE_31_BIT;
- }
- else {
- fail(sprintf "Unexpected warn flag: %x",
- $warn_flag);
- next;
- }
- }
- if ($disallow_flag) {
- if ($disallow_flag == $UTF8_DISALLOW_SURROGATE) {
- $uvchr_disallow_flag = $UNICODE_DISALLOW_SURROGATE
- }
- elsif ($disallow_flag == $UTF8_DISALLOW_NONCHAR) {
- $uvchr_disallow_flag = $UNICODE_DISALLOW_NONCHAR
- }
- elsif ($disallow_flag == $UTF8_DISALLOW_SUPER) {
- $uvchr_disallow_flag = $UNICODE_DISALLOW_SUPER
- }
- elsif ($disallow_flag == $UTF8_DISALLOW_ABOVE_31_BIT) {
- $uvchr_disallow_flag =
- $UNICODE_DISALLOW_ABOVE_31_BIT;
- }
- else {
- fail(sprintf "Unexpected disallow flag: %x",
- $disallow_flag);
- next;
- }
- }
+ for (my $i = @expected_errors - 1; $i >= 0; $i--) {
+ if (ok($expected_errors[$i] & $errors,
+ "Expected and got error bit return"
+ . " for $malformations[$i] malformation"))
+ {
+ $errors &= ~$expected_errors[$i];
+ }
+ splice @expected_errors, $i, 1;
+ }
+ unless (is(scalar @expected_errors, 0,
+ "Got all the expected malformation errors"))
+ {
+ diag Dumper \@expected_errors;
+ }
- $disallowed = $uvchr_disallow_flag;
+ if ($warn_flag || $disallow_flag) {
+ is($errors, $expected_error_flags,
+ "Got the correct error flag");
+ }
+ else {
+ is($errors, 0, "Got no other error flag");
+ }
- $this_name = "uvchr_to_utf8_flags() $testname: "
- . (($uvchr_disallow_flag)
- ? 'disallowed'
- : ($disallowed)
- ? 'ABOVE_31_BIT allowed'
- : 'allowed');
- $this_name .= ", $eval_warn";
- $this_name .= ", " . (($uvchr_warn_flag)
- ? 'with warning flag'
- : 'no warning flag');
+ if (@malformations) {
+ if (! $do_warning && $warning eq 'utf8') {
+ goto no_warnings_expected;
+ }
+
+ # Check that each malformation generates a
+ # warning, removing that warning if found
+ MALFORMATION:
+ foreach my $malformation (@malformations) {
+ foreach (my $i = 0; $i < @warnings; $i++) {
+ if ($warnings[$i] =~ /$malformation/) {
+ pass("Expected and got"
+ . "'$malformation' warning");
+ splice @warnings, $i, 1;
+ next MALFORMATION;
+ }
+ }
+ fail("Expected '$malformation' warning"
+ . "but didn't get it");
+
+ }
+ }
- undef @warnings;
- my $ret;
- my $warn_flag = sprintf "0x%x", $uvchr_warn_flag;
- my $disallow_flag = sprintf "0x%x", $uvchr_disallow_flag;
- $call = sprintf "call was: $eval_warn; \$ret = test_uvchr_to_utf8_flags(0x%x, $warn_flag|$disallow_flag)", $allowed_uv;
- $eval_text = "$eval_warn; \$ret = test_uvchr_to_utf8_flags($allowed_uv, $warn_flag|$disallow_flag)";
- eval "$eval_text";
- if (! ok ("$@ eq ''", "$this_name: eval succeeded")) {
- diag "\$!='$!'; eval'd=\"$eval_text\"";
- next;
- }
- if ($disallowed) {
- unless (is($ret, undef, "$this_name: Returns undef")) {
- diag $call;
- }
- }
- else {
- unless (is($ret, $bytes, "$this_name: Returns expected string")) {
- diag $call;
- }
- }
- if (! $do_warning
- && ($warning eq 'utf8' || $warning eq $category))
- {
- if (!is(scalar @warnings, 0,
- "$this_name: No warnings generated"))
- {
- diag $call;
- diag "The warnings were: " . join(", ", @warnings);
- }
- }
- elsif ($uvchr_warn_flag
- && ($warning eq 'utf8' || $warning eq $category))
- {
- if (is(scalar @warnings, 1,
- "$this_name: Got a single warning "))
- {
- unless (like($warnings[0], $message,
+ # Any overflow will override any super or above-31
+ # warnings.
+ goto no_warnings_expected if $will_overflow;
+
+ if ( ! $do_warning
+ && ( $warning eq 'utf8'
+ || $warning eq $category))
+ {
+ goto no_warnings_expected;
+ }
+ elsif ($warn_flag) {
+ if (is(scalar @warnings, 1,
+ "$this_name: Got a single warning "))
+ {
+ unless (like($warnings[0], $message,
"$this_name: Got expected warning"))
+ {
+ diag $call;
+ }
+ }
+ else {
+ diag $call;
+ if (scalar @warnings) {
+ output_warnings(@warnings);
+ }
+ }
+ }
+ else {
+ no_warnings_expected:
+ unless (is(scalar @warnings, 0,
+ "$this_name: Got no warnings"))
+ {
+ diag $call;
+ output_warnings(@warnings);
+ }
+ }
+
+ # Check CHECK_ONLY results when the input is
+ # disallowed. Do this when actually disallowed,
+ # not just when the $disallow_flag is set
+ if ($disallowed) {
+ undef @warnings;
+ $ret_ref = test_utf8n_to_uvchr_error(
+ $this_bytes, $this_length,
+ $disallow_flag|$UTF8_CHECK_ONLY);
+ unless (is($ret_ref->[0], 0,
+ "$this_name, CHECK_ONLY: Returns 0"))
+ {
+ diag $call;
+ }
+ unless (is($ret_ref->[1], -1,
+ "$this_name: CHECK_ONLY: returns -1 for"
+ . " length"))
+ {
+ diag $call;
+ }
+ if (! is(scalar @warnings, 0,
+ "$this_name, CHECK_ONLY: no warnings"
+ . " generated"))
+ {
+ diag $call;
+ output_warnings(@warnings);
+ }
+ }
+
+ # Now repeat some of the above, but for
+ # uvchr_to_utf8_flags(). Since this comes from an
+ # existing code point, it hasn't overflowed, and
+ # isn't malformed.
+ next if @malformations;
+
+ # The warning and disallow flags passed in are for
+ # utf8n_to_uvchr_error(). Convert them for
+ # uvchr_to_utf8_flags().
+ my $uvchr_warn_flag = 0;
+ my $uvchr_disallow_flag = 0;
+ if ($warn_flag) {
+ if ($warn_flag == $UTF8_WARN_SURROGATE) {
+ $uvchr_warn_flag = $UNICODE_WARN_SURROGATE
+ }
+ elsif ($warn_flag == $UTF8_WARN_NONCHAR) {
+ $uvchr_warn_flag = $UNICODE_WARN_NONCHAR
+ }
+ elsif ($warn_flag == $UTF8_WARN_SUPER) {
+ $uvchr_warn_flag = $UNICODE_WARN_SUPER
+ }
+ elsif ($warn_flag == $UTF8_WARN_ABOVE_31_BIT) {
+ $uvchr_warn_flag
+ = $UNICODE_WARN_ABOVE_31_BIT;
+ }
+ else {
+ fail(sprintf "Unexpected warn flag: %x",
+ $warn_flag);
+ next;
+ }
+ }
+ if ($disallow_flag) {
+ if ($disallow_flag == $UTF8_DISALLOW_SURROGATE)
+ {
+ $uvchr_disallow_flag
+ = $UNICODE_DISALLOW_SURROGATE;
+ }
+ elsif ($disallow_flag == $UTF8_DISALLOW_NONCHAR)
+ {
+ $uvchr_disallow_flag
+ = $UNICODE_DISALLOW_NONCHAR;
+ }
+ elsif ($disallow_flag == $UTF8_DISALLOW_SUPER) {
+ $uvchr_disallow_flag
+ = $UNICODE_DISALLOW_SUPER;
+ }
+ elsif ($disallow_flag
+ == $UTF8_DISALLOW_ABOVE_31_BIT)
+ {
+ $uvchr_disallow_flag =
+ $UNICODE_DISALLOW_ABOVE_31_BIT;
+ }
+ else {
+ fail(sprintf "Unexpected disallow flag: %x",
+ $disallow_flag);
+ next;
+ }
+ }
+
+ $disallowed = $uvchr_disallow_flag;
+
+ $this_name = "uvchr_to_utf8_flags() $testname: "
+ . (($uvchr_disallow_flag)
+ ? 'disallowed'
+ : ($disallowed)
+ ? 'ABOVE_31_BIT allowed'
+ : 'allowed');
+ $this_name .= ", $eval_warn";
+ $this_name .= ", " . (($uvchr_warn_flag)
+ ? 'with warning flag'
+ : 'no warning flag');
+
+ undef @warnings;
+ my $ret;
+ my $warn_flag = sprintf "0x%x", $uvchr_warn_flag;
+ my $disallow_flag = sprintf "0x%x",
+ $uvchr_disallow_flag;
+ $call = sprintf("call was: $eval_warn; \$ret"
+ . " = test_uvchr_to_utf8_flags("
+ . " 0x%x, $warn_flag|$disallow_flag)",
+ $allowed_uv);
+ $eval_text = "$eval_warn; \$ret ="
+ . " test_uvchr_to_utf8_flags("
+ . "$allowed_uv, $warn_flag|"
+ . "$disallow_flag)";
+ eval "$eval_text";
+ if (! ok ("$@ eq ''", "$this_name: eval succeeded"))
{
- diag $call;
+ diag "\$!='$!'; eval'd=\"$eval_text\"";
+ next;
}
- }
- else {
- diag $call;
- if (scalar @warnings) {
- diag "The warnings were: "
- . join(", ", @warnings);
+ if ($disallowed) {
+ unless (is($ret, undef,
+ "$this_name: Returns undef"))
+ {
+ diag $call;
+ }
+ }
+ else {
+ unless (is($ret, $bytes,
+ "$this_name: Returns expected string"))
+ {
+ diag $call;
+ }
+ }
+ if (! $do_warning
+ && ($warning eq 'utf8' || $warning eq $category))
+ {
+ if (!is(scalar @warnings, 0,
+ "$this_name: No warnings generated"))
+ {
+ diag $call;
+ output_warnings(@warnings);
+ }
+ }
+ elsif ( $uvchr_warn_flag
+ && ( $warning eq 'utf8'
+ || $warning eq $category))
+ {
+ if (is(scalar @warnings, 1,
+ "$this_name: Got a single warning "))
+ {
+ unless (like($warnings[0], $message,
+ "$this_name: Got expected warning"))
+ {
+ diag $call;
+ }
+ }
+ else {
+ diag $call;
+ output_warnings(@warnings)
+ if scalar @warnings;
+ }
}
}
}
package attributes;
-our $VERSION = 0.27;
+our $VERSION = 0.28;
@EXPORT_OK = qw(get reftype);
@EXPORT = ();
case SVt_PVCV:
switch ((int)len) {
case 5:
- if (memEQ(name, "const", 5)) {
+ if (_memEQs(name, "const")) {
if (negated)
CvANONCONST_off(sv);
else {
case 6:
switch (name[3]) {
case 'l':
- if (memEQ(name, "lvalue", 6)) {
+ if (_memEQs(name, "lvalue")) {
bool warn =
!CvISXSUB(MUTABLE_CV(sv))
&& CvROOT(MUTABLE_CV(sv))
}
break;
case 'h':
- if (memEQ(name, "method", 6)) {
+ if (_memEQs(name, "method")) {
if (negated)
CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_METHOD;
else
}
break;
default:
- if (len > 10 && memEQ(name, "prototype(", 10)) {
+ if (len > 10 && _memEQs(name, "prototype(")) {
SV * proto = newSVpvn(name+10,len-11);
HEK *const hek = CvNAME_HEK((CV *)sv);
SV *subname;
# mro.pm versions < 1.00 reserved for MRO::Compat
# for partial back-compat to 5.[68].x
-our $VERSION = '1.18';
+our $VERSION = '1.19';
sub import {
mro::set_mro(scalar(caller), $_[1]) if $_[1];
he = hv_fetch_ent(PL_isarev, classname, 0, 0);
isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
- if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
- || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
+ if((memEQs(classname_pv, classname_len, "UNIVERSAL"))
+ || (isarev && hv_existss(isarev, "UNIVERSAL")))
XSRETURN_YES;
else
XSRETURN_NO;
subname++;
subname_len = fq_subname_len - (subname - fq_subname);
- if(subname_len == 8 && strEQ(subname, "__ANON__")) {
+ if(memEQs(subname, subname_len, "__ANON__")) {
cxix = __dopoptosub_at(ccstack, cxix - 1);
continue;
}
plan( @tests + 2 + ( @strs - grep { !$_ or /^---/ } @strs ));
is( scalar @tests, $NUM_SECTS,
- "Expecting output for $NUM_SECTS patterns" );
+ "Expecting output for $NUM_SECTS patterns, got ". scalar(@tests) );
ok( defined $out, 'regop.pl returned something defined' );
$out ||= "";
{
*where = newSV_type(type);
if (type == SVt_PVAV && GvNAMELEN(gv) == 3
- && strnEQ(GvNAME(gv), "ISA", 3))
+ && strEQs(GvNAME(gv), "ISA"))
sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0);
}
return gv;
}
else if (stash == cachestash
&& len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4
- && strnEQ(hvname, "CORE", 4)
+ && strEQs(hvname, "CORE")
&& S_maybe_add_coresub(aTHX_ NULL,topgv,name,len))
goto have_gv;
}
if (!gvp) {
if (len > 1 && HvNAMELEN_get(cstash) == 4) {
const char *hvname = HvNAME(cstash); assert(hvname);
- if (strnEQ(hvname, "CORE", 4)
+ if (strEQs(hvname, "CORE")
&& (candidate =
S_maybe_add_coresub(aTHX_ cstash,NULL,name,len)
))
/* did we find a separator? */
if (last_separator) {
- if ((last_separator - origname) == 5 && memEQ(origname, "SUPER", 5)) {
+ STRLEN sep_len= last_separator - origname;
+ if ( memEQs(origname, sep_len, "SUPER")) {
/* ->SUPER::method should really be looked up in original stash */
stash = CopSTASH(PL_curcop);
flags |= GV_SUPER;
DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
origname, HvENAME_get(stash), name) );
}
- else if ((last_separator - origname) >= 7 &&
- strnEQ(last_separator - 7, "::SUPER", 7)) {
+ else if ( sep_len >= 7 &&
+ strEQs(last_separator - 7, "::SUPER")) {
/* don't autovifify if ->NoSuchStash::SUPER::method */
- stash = gv_stashpvn(origname, last_separator - origname - 7, is_utf8);
+ stash = gv_stashpvn(origname, sep_len - 7, is_utf8);
if (stash) flags |= GV_SUPER;
}
else {
/* don't autovifify if ->NoSuchStash::method */
- stash = gv_stashpvn(origname, last_separator - origname, is_utf8);
+ stash = gv_stashpvn(origname, sep_len, is_utf8);
}
ostash = stash;
}
ENTER;
-#define HV_FETCH_TIE_FUNC (GV **)hv_fetch(stash, "_tie_it", 7, 0)
+#define HV_FETCH_TIE_FUNC (GV **)hv_fetchs(stash, "_tie_it", 0)
/* Load the module if it is not loaded. */
if (!(stash = gv_stashpvn(name, len, 0))
}
}
+/* add a require_tie_mod_s - the _s suffix is similar to pvs type suffixes,
+ * IOW it means we do STR_WITH_LEN() ourselves and the user should pass in
+ * a true string WITHOUT a len.
+ */
+#define require_tie_mod_s(gv, varname, name, flags) \
+ S_require_tie_mod(aTHX_ gv, varname, STR_WITH_LEN(name), flags)
+
/*
=for apidoc gv_stashpv
*stash = GvHV(*gv) = newHV();
if (!HvNAME_get(*stash)) {
if (GvSTASH(*gv) == PL_defstash && *len == 6
- && strnEQ(*name, "CORE", 4))
- hv_name_set(*stash, "CORE", 4, 0);
+ && strEQs(*name, "CORE"))
+ hv_name_sets(*stash, "CORE", 0);
else
hv_name_set(
*stash, nambeg, name_cursor-nambeg, is_utf8
and VERSION. All the others apply only to the main stash or to
CORE (which is checked right after this). */
if (len) {
- const char * const name2 = name + 1;
switch (*name) {
case 'E':
- if (strnEQ(name2, "XPORT", 5))
+ if (memEQs(name, len, "EXPORT")
+ ||memEQs(name, len, "EXPORT_OK")
+ ||memEQs(name, len, "EXPORT_FAIL")
+ )
GvMULTI_on(gv);
break;
case 'I':
- if (strEQ(name2, "SA"))
+ if (memEQs(name, len, "ISA"))
gv_magicalize_isa(gv);
break;
case 'V':
- if (strEQ(name2, "ERSION"))
+ if (memEQs(name, len, "VERSION"))
GvMULTI_on(gv);
break;
case 'a':
- if (stash == PL_debstash && len==4 && strEQ(name2,"rgs")) {
+ if (stash == PL_debstash && memEQs(name, len, "args")) {
GvMULTI_on(gv_AVadd(gv));
break;
- }
+ }
+ /* FALLTHROUGH */
case 'b':
if (len == 1 && sv_type == SVt_PV)
GvMULTI_on(gv);
if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
/* Avoid null warning: */
const char * const stashname = HvNAME(stash); assert(stashname);
- if (strnEQ(stashname, "CORE", 4))
+ if (strEQs(stashname, "CORE"))
S_maybe_add_coresub(aTHX_ 0, gv, name, len);
}
}
} else
#endif
{
- const char * name2 = name + 1;
switch (*name) {
case 'A':
- if (strEQ(name2, "RGV")) {
+ if (memEQs(name, len, "ARGV")) {
IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
}
- else if (strEQ(name2, "RGVOUT")) {
+ else if (memEQs(name, len, "ARGVOUT")) {
GvMULTI_on(gv);
}
break;
case 'E':
- if (strnEQ(name2, "XPORT", 5))
+ if (memEQs(name, len, "EXPORT"))
GvMULTI_on(gv);
break;
case 'I':
- if (strEQ(name2, "SA")) {
+ if (memEQs(name, len, "ISA")) {
gv_magicalize_isa(gv);
}
break;
case 'S':
- if (strEQ(name2, "IG")) {
+ if (memEQs(name, len, "SIG")) {
HV *hv;
I32 i;
if (!PL_psig_name) {
}
break;
case 'V':
- if (strEQ(name2, "ERSION"))
+ if (memEQs(name, len, "VERSION"))
GvMULTI_on(gv);
break;
case '\003': /* $^CHILD_ERROR_NATIVE */
- if (strEQ(name2, "HILD_ERROR_NATIVE"))
+ if (memEQs(name, len, "\003HILD_ERROR_NATIVE"))
goto magicalize;
break;
case '\005': /* $^ENCODING */
- if (strEQ(name2, "NCODING"))
+ if (memEQs(name, len, "\005NCODING"))
goto magicalize;
break;
case '\007': /* $^GLOBAL_PHASE */
- if (strEQ(name2, "LOBAL_PHASE"))
+ if (memEQs(name, len, "\007LOBAL_PHASE"))
goto ro_magicalize;
break;
case '\014': /* $^LAST_FH */
- if (strEQ(name2, "AST_FH"))
+ if (memEQs(name, len, "\014AST_FH"))
goto ro_magicalize;
break;
case '\015': /* $^MATCH */
- if (strEQ(name2, "ATCH")) {
+ if (memEQs(name, len, "\015ATCH")) {
paren = RX_BUFF_IDX_CARET_FULLMATCH;
goto storeparen;
}
break;
case '\017': /* $^OPEN */
- if (strEQ(name2, "PEN"))
+ if (memEQs(name, len, "\017PEN"))
goto magicalize;
break;
case '\020': /* $^PREMATCH $^POSTMATCH */
- if (strEQ(name2, "REMATCH")) {
+ if (memEQs(name, len, "\020REMATCH")) {
paren = RX_BUFF_IDX_CARET_PREMATCH;
goto storeparen;
}
- if (strEQ(name2, "OSTMATCH")) {
+ if (memEQs(name, len, "\020OSTMATCH")) {
paren = RX_BUFF_IDX_CARET_POSTMATCH;
goto storeparen;
}
break;
case '\024': /* ${^TAINT} */
- if (strEQ(name2, "AINT"))
+ if (memEQs(name, len, "\024AINT"))
goto ro_magicalize;
break;
case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
- if (strEQ(name2, "NICODE"))
+ if (memEQs(name, len, "\025NICODE"))
goto ro_magicalize;
- if (strEQ(name2, "TF8LOCALE"))
+ if (memEQs(name, len, "\025TF8LOCALE"))
goto ro_magicalize;
- if (strEQ(name2, "TF8CACHE"))
+ if (memEQs(name, len, "\025TF8CACHE"))
goto magicalize;
break;
case '\027': /* $^WARNING_BITS */
- if (strEQ(name2, "ARNING_BITS"))
+ if (memEQs(name, len, "\027ARNING_BITS"))
goto magicalize;
#ifdef WIN32
- else if (strEQ(name2, "IN32_SLOPPY_STAT"))
+ else if (memEQs(name, len, "\027IN32_SLOPPY_STAT"))
goto magicalize;
#endif
break;
sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
- /* magicalization must be done before require_tie_mod is called */
+ /* magicalization must be done before require_tie_mod_s is called */
if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
- require_tie_mod(gv, '!', "Errno", 5, 1);
+ require_tie_mod_s(gv, '!', "Errno", 1);
break;
- case '-': /* $- */
- case '+': /* $+ */
+ case '-': /* $-, %-, @- */
+ case '+': /* $+, %+, @+ */
GvMULTI_on(gv); /* no used once warnings here */
{
AV* const av = GvAVn(gv);
SvREADONLY_on(av);
if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
- require_tie_mod(gv, *name, "Tie::Hash::NamedCapture",23,0);
+ require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture",0);
break;
}
case '[': /* $[ */
if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
&& FEATURE_ARYBASE_IS_ENABLED) {
- require_tie_mod(gv,'[',"arybase",7,0);
+ require_tie_mod_s(gv,'[',"arybase",0);
}
else goto magicalize;
break;
if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
if (*name == '!')
- require_tie_mod(gv, '!', "Errno", 5, 1);
+ require_tie_mod_s(gv, '!', "Errno", 1);
else if (*name == '-' || *name == '+')
- require_tie_mod(gv, *name, "Tie::Hash::NamedCapture", 23, 0);
+ require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture", 0);
} else if (sv_type == SVt_PV) {
if (*name == '*' || *name == '#') {
/* diag_listed_as: $* is no longer supported */
if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
switch (*name) {
case '[':
- require_tie_mod(gv,'[',"arybase",7,0);
+ require_tie_mod_s(gv,'[',"arybase",0);
break;
#ifdef PERL_SAWAMPERSAND
case '`':
maybe_multimagic_gv(gv, name, sv_type);
}
else if (len == 3 && sv_type == SVt_PVAV
- && strnEQ(name, "ISA", 3)
+ && strEQs(name, "ISA")
&& (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
gv_magicalize_isa(gv);
}
/* Unused by core; should be deprecated */
#define Ctl(ch) ((ch) & 037)
+#if defined(PERL_CORE) || defined(PERL_EXT)
+# ifndef MIN
+# define MIN(a,b) ((a) < (b) ? (a) : (b))
+# endif
+# ifndef MAX
+# define MAX(a,b) ((a) > (b) ? (a) : (b))
+# endif
+#endif
+
/* This is a helper macro to avoid preprocessor issues, replaced by nothing
* unless under DEBUGGING, where it expands to an assert of its argument,
* followed by a comma (hence the comma operator). If we just used a straight
Perl_gv_fetchpvn_flags(aTHX_ namebeg, len, add, sv_type)
#define sv_catxmlpvs(dsv, str, utf8) \
Perl_sv_catxmlpvn(aTHX_ dsv, STR_WITH_LEN(str), utf8)
-#define hv_fetchs(hv,key,lval) \
- ((SV **)Perl_hv_common(aTHX_ (hv), NULL, STR_WITH_LEN(key), 0, \
- (lval) ? (HV_FETCH_JUST_SV | HV_FETCH_LVALUE) \
- : HV_FETCH_JUST_SV, NULL, 0))
-#define hv_stores(hv,key,val) \
- ((SV **)Perl_hv_common(aTHX_ (hv), NULL, STR_WITH_LEN(key), 0, \
- (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), (val), 0))
#define lex_stuff_pvs(pv,flags) Perl_lex_stuff_pvn(aTHX_ STR_WITH_LEN(pv), flags)
=cut
*/
+
#define strNE(s1,s2) (strcmp(s1,s2))
#define strEQ(s1,s2) (!strcmp(s1,s2))
#define strLT(s1,s2) (strcmp(s1,s2) < 0)
#define strLE(s1,s2) (strcmp(s1,s2) <= 0)
#define strGT(s1,s2) (strcmp(s1,s2) > 0)
#define strGE(s1,s2) (strcmp(s1,s2) >= 0)
+
#define strnNE(s1,s2,l) (strncmp(s1,s2,l))
#define strnEQ(s1,s2,l) (!strncmp(s1,s2,l))
+#define strNEs(s1,s2) (strncmp(s1,"" s2 "", sizeof(s2)-1))
+#define strEQs(s1,s2) (!strncmp(s1,"" s2 "", sizeof(s2)-1))
+
#ifdef HAS_MEMCMP
# define memNE(s1,s2,l) (memcmp(s1,s2,l))
# define memEQ(s1,s2,l) (!memcmp(s1,s2,l))
/* memEQ and memNE where second comparand is a string constant */
#define memEQs(s1, l, s2) \
- (sizeof(s2)-1 == l && memEQ(s1, ("" s2 ""), (sizeof(s2)-1)))
+ (((sizeof(s2)-1) == (l)) && memEQ((s1), ("" s2 ""), (sizeof(s2)-1)))
#define memNEs(s1, l, s2) !memEQs(s1, l, s2)
+/* memEQ and memNE where second comparand is a string constant
+ * and we can assume the length of s1 is at least that of the string */
+#define _memEQs(s1, s2) \
+ (memEQ((s1), ("" s2 ""), (sizeof(s2)-1)))
+#define _memNEs(s1, s2) (memNE((s1),("" s2 ""),(sizeof(s2)-1)))
+
#define memLT(s1,s2,l) (memcmp(s1,s2,l) < 0)
#define memLE(s1,s2,l) (memcmp(s1,s2,l) <= 0)
#define memGT(s1,s2,l) (memcmp(s1,s2,l) > 0)
# mkdir -p /opt/perl-catamount
# mkdir -p /opt/perl-catamount/include
# mkdir -p /opt/perl-catamount/lib
-# mkdir -p /opt/perl-catamount/lib/perl5/5.25.5
+# mkdir -p /opt/perl-catamount/lib/perl5/5.25.6
# mkdir -p /opt/perl-catamount/bin
# cp *.h /opt/perl-catamount/include
# cp libperl.a /opt/perl-catamount/lib
-# cp -pr lib/* /opt/perl-catamount/lib/perl5/5.25.5
+# cp -pr lib/* /opt/perl-catamount/lib/perl5/5.25.6
# cp miniperl perl run.sh cc.sh /opt/perl-catamount/lib
#
# With the headers and the libperl.a you can embed Perl to your Catamount
# From http://ftp.netbsd.org/pub/pkgsrc/current/pkgsrc/mk/platform/Darwin.mk
# and https://trac.macports.org/wiki/XcodeVersionInfo
# and https://trac.macports.org/wiki/UsingTheRightCompiler
+# and https://gist.github.com/yamaya/2924292
+# and http://opensource.apple.com/source/clang/
#
-# OS, Kernel, Xcode Version
-# Note that Xcode gets updates on older systems sometimes.
-# pkgsrc generally expects that the most up-to-date xcode available for
-# an OS version is installed
+# Note that Xcode gets updates on older systems sometimes, and in
+# general that the OS levels and XCode levels are not synchronized
+# since new releases of XCode usually support both some new and some
+# old OS releases.
#
# Note that Apple hijacks the clang preprocessor symbols __clang_major__
# and __clang_minor__ so they cannot be used (easily) to detect the
# 7.1 (clang 3.7 as 7.0/700.1.76)
# 7.2 (clang 3.7 as 7.0.2/700.1.81)
# 7.2.1 (clang 3.7 as 7.0.2/700.1.81)
-# 7.3 (clang 3.7 as 7.3.0/703.0.29)
+# 7.3 (clang 3.8 as 7.3.0/703.0.29)
+# Sierra 10.12.x 16.x.y 8.0.0 (clang 3.8 as 8.0/800.0.38)
#
# Processors Supported
sv_2mortal((SV *)gv)
);
}
- else if (klen == 3 && strnEQ(key, "ISA", 3) && GvAV(gv)) {
+ else if (klen == 3 && strEQs(key, "ISA") && GvAV(gv)) {
AV *isa = GvAV(gv);
MAGIC *mg = mg_find((SV*)isa, PERL_MAGIC_isa);
(HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), \
(val), (hash)))
+
+
#define hv_exists(hv, key, klen) \
(hv_common_key_len((hv), (key), (klen), HV_FETCH_ISEXISTS, NULL, 0) \
? TRUE : FALSE)
(MUTABLE_SV(hv_common_key_len((hv), (key), (klen), \
(flags) | HV_DELETE, NULL, 0)))
+/* Provide 's' suffix subs for constant strings (and avoid needing to count
+ * chars). See STR_WITH_LEN in handy.h - because these are macros we cant use
+ * STR_WITH_LEN to do the work, we have to unroll it. */
+#define hv_existss(hv, key) \
+ hv_exists((hv), ("" key ""), (sizeof(key)-1))
+
+#define hv_fetchs(hv, key, lval) \
+ hv_fetch((hv), ("" key ""), (sizeof(key)-1), (lval))
+
+#define hv_deletes(hv, key, flags) \
+ hv_delete((hv), ("" key ""), (sizeof(key)-1), (flags))
+
+#define hv_name_sets(hv, name, flags) \
+ hv_name_set((hv),("" name ""),(sizeof(name)-1), flags)
+
+#define hv_stores(hv, key, val) \
+ hv_store((hv), ("" key ""), (sizeof(key)-1), (val), 0)
+
#ifdef PERL_CORE
# define hv_storehek(hv, hek, val) \
hv_common((hv), NULL, HEK_KEY(hek), HEK_LEN(hek), HEK_UTF8(hek), \
/*
=for apidoc valid_utf8_to_uvchr
-Like L</utf8_to_uvchr_buf>(), but should only be called when it is known that
+Like C<L</utf8_to_uvchr_buf>>, but should only be called when it is known that
the next character in the input UTF-8 string C<s> is well-formed (I<e.g.>,
it passes C<L</isUTF8_CHAR>>. Surrogates, non-character code points, and
non-Unicode code points are allowed.
use this option, that C<s> can't have embedded C<NUL> characters and has to
have a terminating C<NUL> byte).
-See also L</is_utf8_string>(), L</is_utf8_string_loclen>(), and
-L</is_utf8_string_loc>().
+See also
+C<L</is_utf8_string>>,
+C<L</is_utf8_string_flags>>,
+C<L</is_utf8_string_loc>>,
+C<L</is_utf8_string_loc_flags>>,
+C<L</is_utf8_string_loclen>>,
+C<L</is_utf8_string_loclen_flags>>,
+C<L</is_utf8_fixed_width_buf_flags>>,
+C<L</is_utf8_fixed_width_buf_loc_flags>>,
+C<L</is_utf8_fixed_width_buf_loclen_flags>>,
+C<L</is_strict_utf8_string>>,
+C<L</is_strict_utf8_string_loc>>,
+C<L</is_strict_utf8_string_loclen>>,
+C<L</is_c9strict_utf8_string>>,
+C<L</is_c9strict_utf8_string_loc>>,
+and
+C<L</is_c9strict_utf8_string_loclen>>.
=cut
*/
can't have embedded C<NUL> characters and has to have a terminating C<NUL>
byte). Note that all characters being ASCII constitute 'a valid UTF-8 string'.
-Code points above Unicode, surrogates, and non-character code points are
-considered valid by this function.
+This function considers Perl's extended UTF-8 to be valid. That means that
+code points above Unicode, surrogates, and non-character code points are
+considered valid by this function. Use C<L</is_strict_utf8_string>>,
+C<L</is_c9strict_utf8_string>>, or C<L</is_utf8_string_flags>> to restrict what
+code points are considered valid.
-See also L</is_utf8_invariant_string>(), L</is_utf8_string_loclen>(), and
-L</is_utf8_string_loc>().
+See also
+C<L</is_utf8_invariant_string>>,
+C<L</is_utf8_string_loc>>,
+C<L</is_utf8_string_loclen>>,
+C<L</is_utf8_fixed_width_buf_flags>>,
+C<L</is_utf8_fixed_width_buf_loc_flags>>,
+C<L</is_utf8_fixed_width_buf_loclen_flags>>,
=cut
*/
}
/*
-Implemented as a macro in utf8.h
+=for apidoc is_strict_utf8_string
+
+Returns TRUE if the first C<len> bytes of string C<s> form a valid
+UTF-8-encoded string that is fully interchangeable by any application using
+Unicode rules; otherwise it returns FALSE. If C<len> is 0, it will be
+calculated using C<strlen(s)> (which means if you use this option, that C<s>
+can't have embedded C<NUL> characters and has to have a terminating C<NUL>
+byte). Note that all characters being ASCII constitute 'a valid UTF-8 string'.
+
+This function returns FALSE for strings containing any
+code points above the Unicode max of 0x10FFFF, surrogate code points, or
+non-character code points.
+
+See also
+C<L</is_utf8_invariant_string>>,
+C<L</is_utf8_string>>,
+C<L</is_utf8_string_flags>>,
+C<L</is_utf8_string_loc>>,
+C<L</is_utf8_string_loc_flags>>,
+C<L</is_utf8_string_loclen>>,
+C<L</is_utf8_string_loclen_flags>>,
+C<L</is_utf8_fixed_width_buf_flags>>,
+C<L</is_utf8_fixed_width_buf_loc_flags>>,
+C<L</is_utf8_fixed_width_buf_loclen_flags>>,
+C<L</is_strict_utf8_string_loc>>,
+C<L</is_strict_utf8_string_loclen>>,
+C<L</is_c9strict_utf8_string>>,
+C<L</is_c9strict_utf8_string_loc>>,
+and
+C<L</is_c9strict_utf8_string_loclen>>.
+
+=cut
+*/
+
+PERL_STATIC_INLINE bool
+S_is_strict_utf8_string(const U8 *s, const STRLEN len)
+{
+ const U8* const send = s + (len ? len : strlen((const char *)s));
+ const U8* x = s;
+
+ PERL_ARGS_ASSERT_IS_STRICT_UTF8_STRING;
+
+ while (x < send) {
+ const STRLEN cur_len = isSTRICT_UTF8_CHAR(x, send);
+ if (UNLIKELY(! cur_len)) {
+ return FALSE;
+ }
+ x += cur_len;
+ }
+
+ return TRUE;
+}
+
+/*
+=for apidoc is_c9strict_utf8_string
+
+Returns TRUE if the first C<len> bytes of string C<s> form a valid
+UTF-8-encoded string that conforms to
+L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>;
+otherwise it returns FALSE. If C<len> is 0, it will be calculated using
+C<strlen(s)> (which means if you use this option, that C<s> can't have embedded
+C<NUL> characters and has to have a terminating C<NUL> byte). Note that all
+characters being ASCII constitute 'a valid UTF-8 string'.
+
+This function returns FALSE for strings containing any code points above the
+Unicode max of 0x10FFFF or surrogate code points, but accepts non-character
+code points per
+L<Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>.
+
+See also
+C<L</is_utf8_invariant_string>>,
+C<L</is_utf8_string>>,
+C<L</is_utf8_string_flags>>,
+C<L</is_utf8_string_loc>>,
+C<L</is_utf8_string_loc_flags>>,
+C<L</is_utf8_string_loclen>>,
+C<L</is_utf8_string_loclen_flags>>,
+C<L</is_utf8_fixed_width_buf_flags>>,
+C<L</is_utf8_fixed_width_buf_loc_flags>>,
+C<L</is_utf8_fixed_width_buf_loclen_flags>>,
+C<L</is_strict_utf8_string>>,
+C<L</is_strict_utf8_string_loc>>,
+C<L</is_strict_utf8_string_loclen>>,
+C<L</is_c9strict_utf8_string_loc>>,
+and
+C<L</is_c9strict_utf8_string_loclen>>.
+
+=cut
+*/
+
+PERL_STATIC_INLINE bool
+S_is_c9strict_utf8_string(const U8 *s, const STRLEN len)
+{
+ const U8* const send = s + (len ? len : strlen((const char *)s));
+ const U8* x = s;
+
+ PERL_ARGS_ASSERT_IS_C9STRICT_UTF8_STRING;
+
+ while (x < send) {
+ const STRLEN cur_len = isC9_STRICT_UTF8_CHAR(x, send);
+ if (UNLIKELY(! cur_len)) {
+ return FALSE;
+ }
+ x += cur_len;
+ }
+
+ return TRUE;
+}
+
+/* The above 3 functions could have been moved into the more general one just
+ * below, and made #defines that call it with the right 'flags'. They are
+ * currently kept separate to increase their chances of getting inlined */
+
+/*
+=for apidoc is_utf8_string_flags
+
+Returns TRUE if the first C<len> bytes of string C<s> form a valid
+UTF-8 string, subject to the restrictions imposed by C<flags>;
+returns FALSE otherwise. If C<len> is 0, it will be calculated
+using C<strlen(s)> (which means if you use this option, that C<s> can't have
+embedded C<NUL> characters and has to have a terminating C<NUL> byte). Note
+that all characters being ASCII constitute 'a valid UTF-8 string'.
+
+If C<flags> is 0, this gives the same results as C<L</is_utf8_string>>; if
+C<flags> is C<UTF8_DISALLOW_ILLEGAL_INTERCHANGE>, this gives the same results
+as C<L</is_strict_utf8_string>>; and if C<flags> is
+C<UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE>, this gives the same results as
+C<L</is_c9strict_utf8_string>>. Otherwise C<flags> may be any
+combination of the C<UTF8_DISALLOW_I<foo>> flags understood by
+C<L</utf8n_to_uvchr>>, with the same meanings.
+
+See also
+C<L</is_utf8_invariant_string>>,
+C<L</is_utf8_string>>,
+C<L</is_utf8_string_loc>>,
+C<L</is_utf8_string_loc_flags>>,
+C<L</is_utf8_string_loclen>>,
+C<L</is_utf8_string_loclen_flags>>,
+C<L</is_utf8_fixed_width_buf_flags>>,
+C<L</is_utf8_fixed_width_buf_loc_flags>>,
+C<L</is_utf8_fixed_width_buf_loclen_flags>>,
+C<L</is_strict_utf8_string>>,
+C<L</is_strict_utf8_string_loc>>,
+C<L</is_strict_utf8_string_loclen>>,
+C<L</is_c9strict_utf8_string>>,
+C<L</is_c9strict_utf8_string_loc>>,
+and
+C<L</is_c9strict_utf8_string_loclen>>.
+
+=cut
+*/
+
+PERL_STATIC_INLINE bool
+S_is_utf8_string_flags(const U8 *s, const STRLEN len, const U32 flags)
+{
+ const U8* const send = s + (len ? len : strlen((const char *)s));
+ const U8* x = s;
+
+ PERL_ARGS_ASSERT_IS_UTF8_STRING_FLAGS;
+ assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
+ |UTF8_DISALLOW_ABOVE_31_BIT)));
+
+ if (flags == 0) {
+ return is_utf8_string(s, len);
+ }
+
+ if ((flags & ~UTF8_DISALLOW_ABOVE_31_BIT)
+ == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
+ {
+ return is_strict_utf8_string(s, len);
+ }
+
+ if ((flags & ~UTF8_DISALLOW_ABOVE_31_BIT)
+ == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
+ {
+ return is_c9strict_utf8_string(s, len);
+ }
+
+ while (x < send) {
+ STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
+ if (UNLIKELY(! cur_len)) {
+ return FALSE;
+ }
+ x += cur_len;
+ }
+
+ return TRUE;
+}
+
+/*
=for apidoc is_utf8_string_loc
-Like L</is_utf8_string> but stores the location of the failure (in the
+Like C<L</is_utf8_string>> but stores the location of the failure (in the
case of "utf8ness failure") or the location C<s>+C<len> (in the case of
"utf8ness success") in the C<ep> pointer.
-See also L</is_utf8_string_loclen>() and L</is_utf8_string>().
+See also C<L</is_utf8_string_loclen>>.
+
+=cut
+*/
+
+#define is_utf8_string_loc(s, len, ep) is_utf8_string_loclen(s, len, ep, 0)
+
+/*
=for apidoc is_utf8_string_loclen
-Like L</is_utf8_string>() but stores the location of the failure (in the
+Like C<L</is_utf8_string>> but stores the location of the failure (in the
case of "utf8ness failure") or the location C<s>+C<len> (in the case of
-"utf8ness success") in the C<ep>, and the number of UTF-8
+"utf8ness success") in the C<ep> pointer, and the number of UTF-8
encoded characters in the C<el> pointer.
-See also L</is_utf8_string_loc>() and L</is_utf8_string>().
+See also C<L</is_utf8_string_loc>>.
=cut
*/
}
/*
+
+=for apidoc is_strict_utf8_string_loc
+
+Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
+case of "utf8ness failure") or the location C<s>+C<len> (in the case of
+"utf8ness success") in the C<ep> pointer.
+
+See also C<L</is_strict_utf8_string_loclen>>.
+
+=cut
+*/
+
+#define is_strict_utf8_string_loc(s, len, ep) \
+ is_strict_utf8_string_loclen(s, len, ep, 0)
+
+/*
+
+=for apidoc is_strict_utf8_string_loclen
+
+Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
+case of "utf8ness failure") or the location C<s>+C<len> (in the case of
+"utf8ness success") in the C<ep> pointer, and the number of UTF-8
+encoded characters in the C<el> pointer.
+
+See also C<L</is_strict_utf8_string_loc>>.
+
+=cut
+*/
+
+PERL_STATIC_INLINE bool
+S_is_strict_utf8_string_loclen(const U8 *s, const STRLEN len, const U8 **ep, STRLEN *el)
+{
+ const U8* const send = s + (len ? len : strlen((const char *)s));
+ const U8* x = s;
+ STRLEN outlen = 0;
+
+ PERL_ARGS_ASSERT_IS_STRICT_UTF8_STRING_LOCLEN;
+
+ while (x < send) {
+ const STRLEN cur_len = isSTRICT_UTF8_CHAR(x, send);
+ if (UNLIKELY(! cur_len)) {
+ break;
+ }
+ x += cur_len;
+ outlen++;
+ }
+
+ if (el)
+ *el = outlen;
+
+ if (ep) {
+ *ep = x;
+ }
+
+ return (x == send);
+}
+
+/*
+
+=for apidoc is_c9strict_utf8_string_loc
+
+Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
+the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
+"utf8ness success") in the C<ep> pointer.
+
+See also C<L</is_c9strict_utf8_string_loclen>>.
+
+=cut
+*/
+
+#define is_c9strict_utf8_string_loc(s, len, ep) \
+ is_c9strict_utf8_string_loclen(s, len, ep, 0)
+
+/*
+
+=for apidoc is_c9strict_utf8_string_loclen
+
+Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
+the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
+"utf8ness success") in the C<ep> pointer, and the number of UTF-8 encoded
+characters in the C<el> pointer.
+
+See also C<L</is_c9strict_utf8_string_loc>>.
+
+=cut
+*/
+
+PERL_STATIC_INLINE bool
+S_is_c9strict_utf8_string_loclen(const U8 *s, const STRLEN len, const U8 **ep, STRLEN *el)
+{
+ const U8* const send = s + (len ? len : strlen((const char *)s));
+ const U8* x = s;
+ STRLEN outlen = 0;
+
+ PERL_ARGS_ASSERT_IS_C9STRICT_UTF8_STRING_LOCLEN;
+
+ while (x < send) {
+ const STRLEN cur_len = isC9_STRICT_UTF8_CHAR(x, send);
+ if (UNLIKELY(! cur_len)) {
+ break;
+ }
+ x += cur_len;
+ outlen++;
+ }
+
+ if (el)
+ *el = outlen;
+
+ if (ep) {
+ *ep = x;
+ }
+
+ return (x == send);
+}
+
+/*
+
+=for apidoc is_utf8_string_loc_flags
+
+Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
+case of "utf8ness failure") or the location C<s>+C<len> (in the case of
+"utf8ness success") in the C<ep> pointer.
+
+See also C<L</is_utf8_string_loclen_flags>>.
+
+=cut
+*/
+
+#define is_utf8_string_loc_flags(s, len, ep, flags) \
+ is_utf8_string_loclen_flags(s, len, ep, 0, flags)
+
+
+/* The above 3 actual functions could have been moved into the more general one
+ * just below, and made #defines that call it with the right 'flags'. They are
+ * currently kept separate to increase their chances of getting inlined */
+
+/*
+
+=for apidoc is_utf8_string_loclen_flags
+
+Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
+case of "utf8ness failure") or the location C<s>+C<len> (in the case of
+"utf8ness success") in the C<ep> pointer, and the number of UTF-8
+encoded characters in the C<el> pointer.
+
+See also C<L</is_utf8_string_loc_flags>>.
+
+=cut
+*/
+
+PERL_STATIC_INLINE bool
+S_is_utf8_string_loclen_flags(const U8 *s, const STRLEN len, const U8 **ep, STRLEN *el, const U32 flags)
+{
+ const U8* const send = s + (len ? len : strlen((const char *)s));
+ const U8* x = s;
+ STRLEN outlen = 0;
+
+ PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN_FLAGS;
+ assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
+ |UTF8_DISALLOW_ABOVE_31_BIT)));
+
+ if (flags == 0) {
+ return is_utf8_string_loclen(s, len, ep, el);
+ }
+
+ if ((flags & ~UTF8_DISALLOW_ABOVE_31_BIT)
+ == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
+ {
+ return is_strict_utf8_string_loclen(s, len, ep, el);
+ }
+
+ if ((flags & ~UTF8_DISALLOW_ABOVE_31_BIT)
+ == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
+ {
+ return is_c9strict_utf8_string_loclen(s, len, ep, el);
+ }
+
+ while (x < send) {
+ const STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
+ if (UNLIKELY(! cur_len)) {
+ break;
+ }
+ x += cur_len;
+ outlen++;
+ }
+
+ if (el)
+ *el = outlen;
+
+ if (ep) {
+ *ep = x;
+ }
+
+ return (x == send);
+}
+
+/*
=for apidoc utf8_distance
Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
=cut
*/
-#define is_utf8_valid_partial_char(s, e) is_utf8_valid_partial_char_flags(s, e, 0)
+#define is_utf8_valid_partial_char(s, e) \
+ is_utf8_valid_partial_char_flags(s, e, 0)
/*
of the C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>. If
there is any sequence of bytes that can complete the input partial character in
such a way that a non-prohibited character is formed, the function returns
-TRUE; otherwise FALSE. Non characters cannot be determined based on partial
-character input. But many of the other possible excluded types can be
+TRUE; otherwise FALSE. Non character code points cannot be determined based on
+partial character input. But many of the other possible excluded types can be
determined from just the first one or two bytes.
=cut
return cBOOL(_is_utf8_char_helper(s, e, flags));
}
+/*
+
+=for apidoc is_utf8_fixed_width_buf_flags
+
+Returns TRUE if the fixed-width buffer starting at C<s> with length C<len>
+is entirely valid UTF-8, subject to the restrictions given by C<flags>;
+otherwise it returns FALSE.
+
+If C<flags> is 0, any well-formed UTF-8, as extended by Perl, is accepted
+without restriction. If the final few bytes of the buffer do not form a
+complete code point, this will return TRUE anyway, provided that
+C<L</is_utf8_valid_partial_char_flags>> returns TRUE for them.
+
+If C<flags> in non-zero, it can be any combination of the
+C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>, and with the
+same meanings.
+
+This function differs from C<L</is_utf8_string_flags>> only in that the latter
+returns FALSE if the final few bytes of the string don't form a complete code
+point.
+
+=cut
+ */
+#define is_utf8_fixed_width_buf_flags(s, len, flags) \
+ is_utf8_fixed_width_buf_loclen_flags(s, len, 0, 0, flags)
+
+/*
+
+=for apidoc is_utf8_fixed_width_buf_loc_flags
+
+Like C<L</is_utf8_fixed_width_buf_flags>> but stores the location of the
+failure in the C<ep> pointer. If the function returns TRUE, C<*ep> will point
+to the beginning of any partial character at the end of the buffer; if there is
+no partial character C<*ep> will contain C<s>+C<len>.
+
+See also C<L</is_utf8_fixed_width_buf_loclen_flags>>.
+
+=cut
+*/
+
+#define is_utf8_fixed_width_buf_loc_flags(s, len, loc, flags) \
+ is_utf8_fixed_width_buf_loclen_flags(s, len, loc, 0, flags)
+
+/*
+
+=for apidoc is_utf8_fixed_width_buf_loclen_flags
+
+Like C<L</is_utf8_fixed_width_buf_loc_flags>> but stores the number of
+complete, valid characters found in the C<el> pointer.
+
+=cut
+*/
+
+PERL_STATIC_INLINE bool
+S_is_utf8_fixed_width_buf_loclen_flags(const U8 * const s,
+ const STRLEN len,
+ const U8 **ep,
+ STRLEN *el,
+ const U32 flags)
+{
+ const U8 * maybe_partial;
+
+ PERL_ARGS_ASSERT_IS_UTF8_FIXED_WIDTH_BUF_LOCLEN_FLAGS;
+
+ if (! ep) {
+ ep = &maybe_partial;
+ }
+
+ /* If it's entirely valid, return that; otherwise see if the only error is
+ * that the final few bytes are for a partial character */
+ return is_utf8_string_loclen_flags(s, len, ep, el, flags)
+ || is_utf8_valid_partial_char_flags(*ep, s + len, flags);
+}
+
/* ------------------------------- perl.h ----------------------------- */
/*
PERLVAR(I, compcv, CV *) /* currently compiling subroutine */
PERLVAR(I, comppad_name, PADNAMELIST *) /* variable names for "my" variables */
-PERLVAR(I, comppad_name_fill, I32) /* last "introduced" variable offset */
-PERLVAR(I, comppad_name_floor, I32) /* start of vars in innermost block */
+PERLVAR(I, comppad_name_fill, PADOFFSET)/* last "introduced" variable offset */
+PERLVAR(I, comppad_name_floor, PADOFFSET)/* start of vars in innermost block */
#ifdef HAVE_INTERP_INTERN
PERLVAR(I, sys_intern, struct interp_intern)
PERLVAR(I, subname, SV *) /* name of current subroutine */
PERLVAR(I, subline, I32) /* line this subroutine began on */
-PERLVAR(I, min_intro_pending, I32) /* start of vars to introduce */
+PERLVAR(I, min_intro_pending, PADOFFSET)/* start of vars to introduce */
-PERLVAR(I, max_intro_pending, I32) /* end of vars to introduce */
-PERLVAR(I, padix, I32) /* lowest unused index - 1
+PERLVAR(I, max_intro_pending, PADOFFSET)/* end of vars to introduce */
+PERLVAR(I, padix, PADOFFSET) /* lowest unused index - 1
in current "register" pad */
-PERLVAR(I, constpadix, I32) /* lowest unused for constants */
+PERLVAR(I, constpadix, PADOFFSET) /* lowest unused for constants */
-PERLVAR(I, padix_floor, I32) /* how low may inner block reset padix */
+PERLVAR(I, padix_floor, PADOFFSET) /* how low may inner block reset padix */
#ifdef USE_LOCALE_COLLATE
PERLVAR(I, collation_name, char *) /* Name of current collation */
OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER OPpREPEAT_DOLIST
OPpSORT_REVERSE OPpMULTIDEREF_EXISTS OPpMULTIDEREF_DELETE
+ OPpSPLIT_ASSIGN OPpSPLIT_LEX
SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG
SVs_PADTMP SVpad_TYPED
CVf_METHOD CVf_LVALUE
MDEREF_SHIFT
);
-$VERSION = '1.38';
+$VERSION = '1.39';
use strict;
use vars qw/$AUTOLOAD/;
use warnings ();
my($op, $cx, $name, $delim) = @_;
my $kid = $op->first;
my ($binop, $var, $re) = ("", "", "");
- if ($op->flags & OPf_STACKED) {
+ if ($op->name ne 'split' && $op->flags & OPf_STACKED) {
$binop = 1;
$var = $self->deparse($kid, 20);
$kid = $kid->sibling;
} elsif (!$have_kid) {
$re = re_uninterp(escape_re(re_unback($op->precomp)));
} elsif ($kid->name ne 'regcomp') {
- carp("found ".$kid->name." where regcomp expected");
+ if ($op->name eq 'split') {
+ # split has other kids, not just regcomp
+ $re = re_uninterp(escape_re(re_unback($op->precomp)));
+ }
+ else {
+ carp("found ".$kid->name." where regcomp expected");
+ }
} else {
($re, $quote) = $self->regcomp($kid, 21);
}
}
sub pp_match { matchop(@_, "m", "/") }
-sub pp_pushre { matchop(@_, "m", "/") }
sub pp_qr { matchop(@_, "qr", "") }
sub pp_runcv { unop(@_, "__SUB__"); }
sub pp_split {
- maybe_targmy(@_, \&split);
-}
-sub split {
my $self = shift;
my($op, $cx) = @_;
my($kid, @exprs, $ary, $expr);
+ my $stacked = $op->flags & OPf_STACKED;
+
$kid = $op->first;
+ $kid = $kid->sibling if $kid->name eq 'regcomp';
+ for (; !null($kid); $kid = $kid->sibling) {
+ push @exprs, $self->deparse($kid, 6);
+ }
- # For our kid (an OP_PUSHRE), pmreplroot is never actually the
- # root of a replacement; it's either empty, or abused to point to
- # the GV for an array we split into (an optimization to save
- # assignment overhead). Depending on whether we're using ithreads,
- # this OP* holds either a GV* or a PADOFFSET. Luckily, B.xs
- # figures out for us which it is.
- my $replroot = $kid->pmreplroot;
- my $gv = 0;
- my $stacked = $op->flags & OPf_STACKED;
- if (ref($replroot) eq "B::GV") {
- $gv = $replroot;
- } elsif (!ref($replroot) and $replroot > 0) {
- $gv = $self->padval($replroot);
- } elsif ($kid->targ) {
- $ary = $self->padname($kid->targ)
- } elsif ($stacked) {
- $ary = $self->deparse($op->last, 7);
- }
- $ary = $self->maybe_local(@_,
+ unshift @exprs, $self->matchop($op, $cx, "m", "/");
+
+ if ($op->private & OPpSPLIT_ASSIGN) {
+ # With C<@array = split(/pat/, str);>,
+ # array is stored in split's pmreplroot; either
+ # as an integer index into the pad (for a lexical array)
+ # or as GV for a package array (which will be a pad index
+ # on threaded builds)
+ # With my/our @array = split(/pat/, str), the array is instead
+ # accessed via an extra padav/rv2av op at the end of the
+ # split's kid ops.
+
+ if ($stacked) {
+ $ary = pop @exprs;
+ }
+ else {
+ if ($op->private & OPpSPLIT_LEX) {
+ $ary = $self->padname($op->pmreplroot);
+ }
+ else {
+ # union with op_pmtargetoff, op_pmtargetgv
+ my $gv = $op->pmreplroot;
+ $gv = $self->padval($gv) if !ref($gv);
+ $ary = $self->maybe_local(@_,
$self->stash_variable('@',
$self->gv_name($gv),
$cx))
- if $gv;
-
- # Skip the last kid when OPf_STACKED is set, since it is the array
- # on the left.
- for (; !null($stacked ? $kid->sibling : $kid); $kid = $kid->sibling) {
- push @exprs, $self->deparse($kid, 6);
+ }
+ if ($op->private & OPpLVAL_INTRO) {
+ $ary = $op->private & OPpSPLIT_LEX ? "my $ary" : "local $ary";
+ }
+ }
}
# handle special case of split(), and split(' ') that compiles to /\s+/
- # Under 5.10, the reflags may be undef if the split regexp isn't a constant
- # Under 5.17.5-5.17.9, the special flag is on split itself.
- $kid = $op->first;
- if ( $op->flags & OPf_SPECIAL
- or (
- $kid->flags & OPf_SPECIAL
- and ( $] < 5.009 ? $kid->pmflags & PMf_SKIPWHITE()
- : ($kid->reflags || 0) & RXf_SKIPWHITE()
- )
- )
- ) {
- $exprs[0] = "' '";
- }
+ $exprs[0] = q{' '} if ($op->reflags // 0) & RXf_SKIPWHITE();
$expr = "split(" . join(", ", @exprs) . ")";
if ($ary) {
our @ary;
@ary = split(' ', 'foo', 0);
####
+my @ary;
+@ary = split(' ', 'foo', 0);
+####
# Split to our array
our @array = split(//, 'foo', 0);
####
# Split to my array
my @array = split(//, 'foo', 0);
####
+our @array;
+my $c;
+@array = split(/x(?{ $c++; })y/, 'foo', 0);
+####
+my($x, $y, $p);
+our $c;
+($x, $y) = split(/$p(?{ $c++; })y/, 'foo', 2);
+####
+our @ary;
+my $pat;
+@ary = split(/$pat/, 'foo', 0);
+####
+my @ary;
+our $pat;
+@ary = split(/$pat/, 'foo', 0);
+####
+our @array;
+my $pat;
+local @array = split(/$pat/, 'foo', 0);
+####
+our $pat;
+my @array = split(/$pat/, 'foo', 0);
+####
# bug #40055
do { () };
####
our %bits;
-our $VERSION = "5.025005";
+our $VERSION = "5.025006";
$bits{$_}{3} = 'OPpENTERSUB_AMPER' for qw(entersub rv2cv);
$bits{$_}{6} = 'OPpENTERSUB_DB' for qw(entersub rv2cv);
$bits{$_}{1} = 'OPpITER_REVERSED' for qw(enteriter iter);
$bits{$_}{7} = 'OPpLVALUE' for qw(leave leaveloop);
$bits{$_}{6} = 'OPpLVAL_DEFER' for qw(aelem helem multideref);
-$bits{$_}{7} = 'OPpLVAL_INTRO' for qw(aelem aslice cond_expr delete enteriter entersub gvsv helem hslice list lvavref lvref lvrefslice multideref padav padhv padrange padsv pushmark refassign rv2av rv2gv rv2hv rv2sv);
+$bits{$_}{7} = 'OPpLVAL_INTRO' for qw(aelem aslice cond_expr delete enteriter entersub gvsv helem hslice list lvavref lvref lvrefslice multideref padav padhv padrange padsv pushmark refassign rv2av rv2gv rv2hv rv2sv split);
$bits{$_}{2} = 'OPpLVREF_ELEM' for qw(lvref refassign);
$bits{$_}{3} = 'OPpLVREF_ITER' for qw(lvref refassign);
$bits{$_}{3} = 'OPpMAYBE_LVSUB' for qw(aassign aelem akeys aslice av2arylen avhvswitch helem hslice keys kvaslice kvhslice multideref padav padhv pos rv2av rv2gv rv2hv substr vec);
$bits{$_}{6} = 'OPpPAD_STATE' for qw(lvavref lvref padav padhv padsv pushmark refassign);
$bits{$_}{7} = 'OPpPV_IS_UTF8' for qw(dump goto last next redo);
$bits{$_}{6} = 'OPpREFCOUNTED' for qw(leave leaveeval leavesub leavesublv leavewrite);
-$bits{$_}{6} = 'OPpRUNTIME' for qw(match pushre qr subst substcont);
+$bits{$_}{5} = 'OPpRUNTIME' for qw(match qr split subst substcont);
$bits{$_}{2} = 'OPpSLICEWARNING' for qw(aslice hslice padav padhv rv2av rv2hv);
$bits{$_}{4} = 'OPpTARGET_MY' for qw(abs add atan2 chdir chmod chomp chown chr chroot concat cos crypt divide exec exp flock getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_subtract index int kill left_shift length link log mkdir modulo multiply nbit_and nbit_or nbit_xor ncomplement oct ord pow push rand rename right_shift rindex rmdir schomp scomplement setpgrp setpriority sin sleep sqrt srand stringify subtract symlink system time unlink unshift utime wait waitpid);
$bits{$_}{5} = 'OPpTRANS_COMPLEMENT' for qw(trans transr);
bitmask => 3,
},
{
+ label => 'offset',
+ mask_def => 'OPpAVHVSWITCH_MASK',
bitmin => 0,
bitmax => 1,
bitmask => 3,
bitmask => 15,
},
{
- label => '-',
+ label => 'range',
mask_def => 'OPpPADRANGE_COUNTMASK',
bitcount_def => 'OPpPADRANGE_COUNTSHIFT',
bitmin => 0,
bitmask => 127,
},
{
- label => '-',
+ label => 'key',
bitmin => 0,
bitmax => 7,
bitmask => 255,
@{$bits{sockpair}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{sort}}{6,5,4,3,2,1,0} = ('OPpSORT_STABLE', 'OPpSORT_QSORT', 'OPpSORT_DESCEND', 'OPpSORT_INPLACE', 'OPpSORT_REVERSE', 'OPpSORT_INTEGER', 'OPpSORT_NUMERIC');
@{$bits{splice}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
-$bits{split}{7} = 'OPpSPLIT_IMPLIM';
+@{$bits{split}}{4,3,2} = ('OPpSPLIT_ASSIGN', 'OPpSPLIT_LEX', 'OPpSPLIT_IMPLIM');
@{$bits{sprintf}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{sprotoent}{0} = $bf[0];
$bits{sqrt}{0} = $bf[0];
OPpASSIGN_COMMON_RC1 => 32,
OPpASSIGN_COMMON_SCALAR => 64,
OPpASSIGN_CV_TO_GV => 128,
+ OPpAVHVSWITCH_MASK => 3,
OPpCONST_BARE => 64,
OPpCONST_ENTERED => 16,
OPpCONST_NOVER => 2,
OPpREFCOUNTED => 64,
OPpREPEAT_DOLIST => 64,
OPpREVERSE_INPLACE => 8,
- OPpRUNTIME => 64,
+ OPpRUNTIME => 32,
OPpSLICE => 64,
OPpSLICEWARNING => 4,
OPpSORT_DESCEND => 16,
OPpSORT_QSORT => 32,
OPpSORT_REVERSE => 4,
OPpSORT_STABLE => 64,
- OPpSPLIT_IMPLIM => 128,
+ OPpSPLIT_ASSIGN => 16,
+ OPpSPLIT_IMPLIM => 4,
+ OPpSPLIT_LEX => 8,
OPpSUBSTR_REPL_FIRST => 16,
OPpTARGET_MY => 16,
OPpTRANS_COMPLEMENT => 32,
OPpSORT_QSORT => 'QSORT',
OPpSORT_REVERSE => 'REV',
OPpSORT_STABLE => 'STABLE',
+ OPpSPLIT_ASSIGN => 'ASSIGN',
OPpSPLIT_IMPLIM => 'IMPLIM',
+ OPpSPLIT_LEX => 'LEX',
OPpSUBSTR_REPL_FIRST => 'REPL1ST',
OPpTARGET_MY => 'TARGMY',
OPpTRANS_COMPLEMENT => 'COMPL',
OPpLIST_GUESSED => [qw(list)],
OPpLVALUE => [qw(leave leaveloop)],
OPpLVAL_DEFER => [qw(aelem helem multideref)],
- OPpLVAL_INTRO => [qw(aelem aslice cond_expr delete enteriter entersub gvsv helem hslice list lvavref lvref lvrefslice multideref padav padhv padrange padsv pushmark refassign rv2av rv2gv rv2hv rv2sv)],
+ OPpLVAL_INTRO => [qw(aelem aslice cond_expr delete enteriter entersub gvsv helem hslice list lvavref lvref lvrefslice multideref padav padhv padrange padsv pushmark refassign rv2av rv2gv rv2hv rv2sv split)],
OPpLVREF_ELEM => [qw(lvref refassign)],
OPpMAYBE_LVSUB => [qw(aassign aelem akeys aslice av2arylen avhvswitch helem hslice keys kvaslice kvhslice multideref padav padhv pos rv2av rv2gv rv2hv substr vec)],
OPpMAYBE_TRUEBOOL => [qw(padhv rv2hv)],
OPpREFCOUNTED => [qw(leave leaveeval leavesub leavesublv leavewrite)],
OPpREPEAT_DOLIST => [qw(repeat)],
OPpREVERSE_INPLACE => [qw(reverse)],
- OPpRUNTIME => [qw(match pushre qr subst substcont)],
+ OPpRUNTIME => [qw(match qr split subst substcont)],
OPpSLICE => [qw(delete)],
OPpSLICEWARNING => [qw(aslice hslice padav padhv rv2av rv2hv)],
OPpSORT_DESCEND => [qw(sort)],
- OPpSPLIT_IMPLIM => [qw(split)],
+ OPpSPLIT_ASSIGN => [qw(split)],
OPpSUBSTR_REPL_FIRST => [qw(substr)],
OPpTARGET_MY => [qw(abs add atan2 chdir chmod chomp chown chr chroot concat cos crypt divide exec exp flock getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_subtract index int kill left_shift length link log mkdir modulo multiply nbit_and nbit_or nbit_xor ncomplement oct ord pow push rand rename right_shift rindex rmdir schomp scomplement setpgrp setpriority sin sleep sqrt srand stringify subtract symlink system time unlink unshift utime wait waitpid)],
OPpTRANS_COMPLEMENT => [qw(trans transr)],
$ops_using{OPpSORT_QSORT} = $ops_using{OPpSORT_DESCEND};
$ops_using{OPpSORT_REVERSE} = $ops_using{OPpSORT_DESCEND};
$ops_using{OPpSORT_STABLE} = $ops_using{OPpSORT_DESCEND};
+$ops_using{OPpSPLIT_IMPLIM} = $ops_using{OPpSPLIT_ASSIGN};
+$ops_using{OPpSPLIT_LEX} = $ops_using{OPpSPLIT_ASSIGN};
$ops_using{OPpTRANS_DELETE} = $ops_using{OPpTRANS_COMPLEMENT};
$ops_using{OPpTRANS_FROM_UTF} = $ops_using{OPpTRANS_COMPLEMENT};
$ops_using{OPpTRANS_GROWS} = $ops_using{OPpTRANS_COMPLEMENT};
package overload;
-our $VERSION = '1.26';
+our $VERSION = '1.27';
%ops = (
with_assign => "+ - * / % ** << >> x .",
);
my %ops_seen;
-for $category (keys %ops) {
- $ops_seen{$_}++ for (split /\s+/, $ops{$category});
-}
+@ops_seen{ map split(/ /), values %ops } = ();
sub nil {}
}
} else {
warnings::warnif("overload arg '$_' is invalid")
- unless $ops_seen{$_};
+ unless exists $ops_seen{$_};
$sub = $arg{$_};
if (not ref $sub) {
$ {$package . "::(" . $_} = $sub;
# or multiple lines. main::write doesn't count the lines.
my @output;
+ push @output, <<'EOF_CODE';
+Error('\p{Script=InGreek}'); # Bug #69018
+Test_GCB("1100 $nobreak 1161"); # Bug #70940
+Expect(0, 0x2028, '\p{Print}', ""); # Bug # 71722
+Expect(0, 0x2029, '\p{Print}', ""); # Bug # 71722
+Expect(1, 0xFF10, '\p{XDigit}', ""); # Bug # 71726
+
+# Make sure this gets tested; it was not part of the official test suite at
+# the time this was added. Note that this is as it would appear in the
+# official suite, and gets modified to check for the perl tailoring by
+# Test_WB()
+Test_WB("$breakable 0020 $breakable 0020 $breakable 0308 $breakable");
+Test_LB("$nobreak 200B $nobreak 0020 $nobreak 0020 $breakable 2060 $breakable");
+EOF_CODE
+
# Sort these so get results in same order on different runs of this
# program
foreach my $property (sort { $a->has_dependency <=> $b->has_dependency
? "\nsub TODO_FAILING_BREAKS { 1 }\n"
: "\nsub TODO_FAILING_BREAKS { 0 }\n";
+
+ push @output,
+ (map {"Test_GCB('$_');\n"} @backslash_X_tests),
+ (map {"Test_LB('$_');\n"} @LB_tests),
+ (map {"Test_SB('$_');\n"} @SB_tests),
+ (map {"Test_WB('$_');\n"} @WB_tests);
+
+ @output= map {
+ map s/^/ /mgr,
+ map "$_;\n",
+ split /;\n/, $_
+ } @output;
+
+ my @output_chunked;
+ my $chunk_count=0;
+ my $chunk_size= int(@output/10)+1;
+ while (@output) {
+ $chunk_count++;
+ my @chunk= splice @output, 0, $chunk_size;
+ push @output_chunked,
+ "if (!\$::TESTCHUNK or \$::TESTCHUNK == $chunk_count){\n",
+ @chunk,
+ "}\n";
+ }
+
&write($t_path,
0, # Not utf8;
[$HEADER,
$TODO_FAILING_BREAKS,
<DATA>,
- @output,
- (map {"Test_GCB('$_');\n"} @backslash_X_tests),
- (map {"Test_LB('$_');\n"} @LB_tests),
- (map {"Test_SB('$_');\n"} @SB_tests),
- (map {"Test_WB('$_');\n"} @WB_tests),
- "Finished();\n"
+ @output_chunked,
+ "Finished();\n",
]);
return;
exit($Fails ? -1 : 0);
}
-Error('\p{Script=InGreek}'); # Bug #69018
-Test_GCB("1100 $nobreak 1161"); # Bug #70940
-Expect(0, 0x2028, '\p{Print}', ""); # Bug # 71722
-Expect(0, 0x2029, '\p{Print}', ""); # Bug # 71722
-Expect(1, 0xFF10, '\p{XDigit}', ""); # Bug # 71726
-
-# Make sure this gets tested; it was not part of the official test suite at
-# the time this was added. Note that this is as it would appear in the
-# official suite, and gets modified to check for the perl tailoring by
-# Test_WB()
-Test_WB("$breakable 0020 $breakable 0020 $breakable 0308 $breakable");
-Test_LB("$nobreak 200B $nobreak 0020 $nobreak 0020 $breakable 2060 $breakable");
use utf8; %a = ("\xE1\xA0"=>"sterling");
print 'start'; printf '%x,', ord \$_ foreach keys %a; print "end\n";
BANG
- qr/^Malformed UTF-8 character \(\d bytes?, need \d, .+\).*start\d+,end$/sm
+ qr/^Malformed UTF-8 character: .*? \(too short; got \d bytes?, need \d\).*start\d+,end$/sm
],
);
foreach (@tests) {
{
char **e;
for (e = environ; *e; e++) {
- if (strnEQ(*e, "LC_", 3)
- && strnNE(*e, "LC_ALL=", 7)
+ if (strEQs(*e, "LC_")
+ && strNEs(*e, "LC_ALL=")
&& (p = strchr(*e, '=')))
PerlIO_printf(Perl_error_log, "\t%.*s = \"%s\",\n",
(int)(p - *e), *e, p + 1);
if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
sv_setsv(sv, &PL_sv_undef);
else {
- sv_setpvs(sv, "");
+ SvPVCLEAR(sv);
SvUTF8_off(sv);
if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
SV *const value = cop_hints_fetch_pvs(c, "open<", 0);
if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
else
- sv_setpvs(sv,"");
+ SvPVCLEAR(sv);
}
#elif defined(OS2)
if (!(_emx_env & 0x200)) { /* Under DOS */
fixup_errno_string(sv);
}
else
- sv_setpvs(sv, "");
+ SvPVCLEAR(sv);
SetLastError(dwErr);
}
# else
else
#endif
if (! errno) {
- sv_setpvs(sv, "");
+ SvPVCLEAR(sv);
}
else {
if (TAINTING_get) {
MgTAINTEDDIR_off(mg);
#ifdef VMS
- if (s && klen == 8 && strEQ(key, "DCL$PATH")) {
+ if (s && memEQs(key, klen, "DCL$PATH")) {
char pathbuf[256], eltbuf[256], *cp, *elt;
int i = 0, j = 0;
} while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
}
#endif /* VMS */
- if (s && klen == 4 && strEQ(key,"PATH")) {
+ if (s && memEQs(key, klen, "PATH")) {
const char * const strend = s + len;
/* set MGf_TAINTEDDIR if any component of the new path is
/* 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);
+ (void) hv_stores(stored, "UNIVERSAL", &PL_sv_undef);
av_push(retval,
newSVhek(HeKEY_hek(hv_store_ent(stored, sv,
&PL_sv_undef, 0))));
} 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_stores(stored, "UNIVERSAL", &PL_sv_undef);
}
(void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
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);
+ (void) hv_stores(isa_hash, "UNIVERSAL", &PL_sv_undef);
SvREADONLY_on(isa_hash);
svp = hv_fetchhek(PL_isarev, stashhek, 0);
isarev = svp ? MUTABLE_HV(*svp) : NULL;
- if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
- || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
+ if((memEQs(stashname, stashname_len, "UNIVERSAL"))
+ || (isarev && hv_existss(isarev, "UNIVERSAL"))) {
PL_sub_generation++;
is_universal = TRUE;
}
/* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
invalidate all method caches globally */
- if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
- || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
+ if((memEQs(stashname, stashname_len, "UNIVERSAL"))
+ || (isarev && hv_existss(isarev, "UNIVERSAL"))) {
PL_sub_generation++;
return;
}
{
const char* s = *sp;
int flags = 0;
+#if defined(NV_INF) || defined(NV_NAN)
bool odh = FALSE; /* one-dot-hash: 1.#INF */
PERL_ARGS_ASSERT_GROK_INFNAN;
while (s < send && isSPACE(*s))
s++;
+#else
+ PERL_UNUSED_ARG(send);
+#endif /* #if defined(NV_INF) || defined(NV_NAN) */
*sp = s;
return flags;
}
s++;
if (s >= send)
return numtype;
- if (len == 10 && memEQ(pv, "0 but true", 10)) {
+ if (len == 10 && _memEQs(pv, "0 but true")) {
if (valuep)
*valuep = 0;
return IS_NUMBER_IN_UV;
if ((s + 2 < send) && strchr("inqs#", toFOLD(*s))) {
/* Really detect inf/nan. Start at d, not s, since the above
* code might have already consumed the "1." or "1". */
- int infnan = Perl_grok_infnan(aTHX_ &d, send);
+ const int infnan = Perl_grok_infnan(aTHX_ &d, send);
if ((infnan & IS_NUMBER_INFINITY)) {
return (numtype | infnan); /* Keep sign for infinity. */
}
/* This could be unrolled like in grok_number(), but
* the expected uses of this are not speed-needy, and
* unlikely to need full 64-bitness. */
- U8 digit = *s++ - '0';
+ const U8 digit = *s++ - '0';
if (val < uv_max_div_10 ||
(val == uv_max_div_10 && digit <= uv_max_mod_10)) {
val = val * 10 + digit;
DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
STORE_LC_NUMERIC_SET_TO_NEEDED();
if (PL_numeric_radix_sv && IN_LC(LC_NUMERIC)) {
- const char *standard = NULL, *local = NULL;
- bool use_standard_radix;
-
/* Look through the string for the first thing that looks like a
* decimal point: either the value in the current locale or the
* standard fallback of '.'. The one which appears earliest in the
* that we have to determine this beforehand because on some
* systems, Perl_atof2 is just a wrapper around the system's atof.
* */
- standard = strchr(s, '.');
- local = strstr(s, SvPV_nolen(PL_numeric_radix_sv));
-
- use_standard_radix = standard && (!local || standard < local);
+ const char * const standard = strchr(s, '.');
+ const char * const local = strstr(s, SvPV_nolen(PL_numeric_radix_sv));
+ const bool use_standard_radix = standard && (!local || standard < local);
if (use_standard_radix)
SET_NUMERIC_STANDARD();
{
const char *p0 = negative ? s - 1 : s;
const char *p = p0;
- int infnan = grok_infnan(&p, send);
+ const int infnan = grok_infnan(&p, send);
if (infnan && p != p0) {
/* If we can generate inf/nan directly, let's do so. */
#ifdef NV_INF
/* the max number we can accumulate in a UV, and still safely do 10*N+9 */
#define MAX_ACCUMULATE ( (UV) ((UV_MAX - 9)/10))
+#if defined(NV_INF) || defined(NV_NAN)
{
- const char* endp;
+ char* endp;
if ((endp = S_my_atof_infnan(aTHX_ s, negative, send, value)))
- return (char*)endp;
+ return endp;
}
+#endif
/* we accumulate digits into an integer; when this becomes too
* large, we add the total to NV and start again */
bool
Perl_isinfnan(NV nv)
{
+ PERL_UNUSED_ARG(nv);
#ifdef Perl_isinf
if (Perl_isinf(nv))
return TRUE;
op_clear(o);
FreeOp(o);
-#ifdef DEBUG_LEAKING_SCALARS
if (PL_op == o)
PL_op = NULL;
-#endif
} while ( (o = POP_DEFERRED_OP()) );
Safefree(defer_stack);
case OP_SUBST:
op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
goto clear_pmop;
- case OP_PUSHRE:
+
+ case OP_SPLIT:
+ if ( (o->op_private & OPpSPLIT_ASSIGN) /* @array = split */
+ && !(o->op_flags & OPf_STACKED)) /* @{expr} = split */
+ {
+ if (o->op_private & OPpSPLIT_LEX)
+ pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
+ else
#ifdef USE_ITHREADS
- if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
- pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
- }
+ pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
#else
- SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
+ SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
#endif
+ }
/* FALLTHROUGH */
case OP_MATCH:
case OP_QR:
while (kid) {
switch (kid->op_type) {
case OP_SUBST:
- case OP_PUSHRE:
+ case OP_SPLIT:
case OP_MATCH:
case OP_QR:
forget_pmop((PMOP*)kid);
break;
case OP_SPLIT:
- kid = cLISTOPo->op_first;
- if (kid && kid->op_type == OP_PUSHRE
- && !kid->op_targ
- && !(o->op_flags & OPf_STACKED)
-#ifdef USE_ITHREADS
- && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
-#else
- && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
-#endif
- )
+ if (!(o->op_private & OPpSPLIT_ASSIGN))
useless = OP_DESC(o);
break;
|| family == OA_FILESTATOP
|| family == OA_LOOPEXOP
|| family == OA_METHOP
- /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
- || type == OP_SASSIGN
|| type == OP_CUSTOM
|| type == OP_NULL /* new_logop does this */
);
return o;
case OP_SPLIT:
- kid = cLISTOPo->op_first;
- if (kid && kid->op_type == OP_PUSHRE &&
- ( kid->op_targ
- || o->op_flags & OPf_STACKED
-#ifdef USE_ITHREADS
- || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
-#else
- || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
-#endif
- )) {
+ if ((o->op_private & OPpSPLIT_ASSIGN)) {
/* This is actually @array = split. */
PL_modcount = RETURN_UNLIMITED_NUMBER;
break;
}
}
- OpTYPE_set(o, type);
+ if (type != OP_SPLIT)
+ /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
+ * ck_split() create a real PMOP and leave the op's type as listop
+ * for now. Otherwise op_free() etc will crash.
+ */
+ OpTYPE_set(o, type);
+
o->op_flags |= flags;
if (flags & OPf_FOLDED)
o->op_folded = 1;
BINOP *binop;
ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
- || type == OP_SASSIGN || type == OP_NULL || type == OP_CUSTOM);
+ || type == OP_NULL || type == OP_CUSTOM);
NewOp(1101, binop, 1, BINOP);
tbl[i] = (short)i;
}
else {
- if (i < 128 && r[j] >= 128)
+ if (UVCHR_IS_INVARIANT(i) && ! UVCHR_IS_INVARIANT(r[j]))
grows = 1;
tbl[i] = r[j++];
}
--j;
}
if (tbl[t[i]] == -1) {
- if (t[i] < 128 && r[j] >= 128)
+ if ( UVCHR_IS_INVARIANT(t[i])
+ && ! UVCHR_IS_INVARIANT(r[j]))
grows = 1;
tbl[t[i]] = r[j];
}
* constant), or convert expr into a runtime regcomp op sequence (if it's
* not)
*
- * isreg indicates that the pattern is part of a regex construct, eg
+ * Flags currently has 2 bits of meaning:
+ * 1: isreg indicates that the pattern is part of a regex construct, eg
* $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
* split "pattern", which aren't. In the former case, expr will be a list
* if the pattern contains more than one term (eg /a$b/).
+ * 2: The pattern is for a split.
*
* When the pattern has been compiled within a new anon CV (for
* qr/(?{...})/ ), then floor indicates the savestack level just before
*/
OP *
-Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor)
+Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
{
PMOP *pm;
LOGOP *rcop;
bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
bool is_compiletime;
bool has_code;
+ bool isreg = cBOOL(flags & 1);
+ bool is_split = cBOOL(flags & 2);
PERL_ARGS_ASSERT_PMRUNTIME;
U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
regexp_engine const *eng = current_re_engine();
- if (o->op_flags & OPf_SPECIAL)
+ if (is_split) {
+ /* make engine handle split ' ' specially */
+ pm->op_pmflags |= PMf_SPLIT;
rx_flags |= RXf_SPLIT;
+ }
if (!has_code || !eng->op_comp) {
/* compile-time simple constant pattern */
SSize_t i = 0;
assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
while (++i <= AvFILLp(PL_comppad)) {
+# ifdef USE_PAD_RESET
+ /* under USE_PAD_RESET, pad swipe replaces a swiped
+ * folded constant with a fresh padtmp */
+ assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
+# else
assert(!PL_curpad[i]);
+# endif
}
#endif
/* But we know that one op is using this CV's slab. */
pm->op_pmflags |= PMf_CODELIST_PRIVATE;
}
- if (o->op_flags & OPf_SPECIAL)
+ if (is_split)
+ /* make engine handle split ' ' specially */
pm->op_pmflags |= PMf_SPLIT;
/* the OP_REGCMAYBE is a placeholder in the non-threaded case
if (optype) {
if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
+ right = scalar(right);
return newLOGOP(optype, 0,
op_lvalue(scalar(left), optype),
- newUNOP(OP_SASSIGN, 0, scalar(right)));
+ newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
}
else {
return newBINOP(optype, OPf_STACKED,
yyerror(no_list_state);
}
- if (right && right->op_type == OP_SPLIT
- && !(right->op_flags & OPf_STACKED)) {
- OP* tmpop = ((LISTOP*)right)->op_first;
- PMOP * const pm = (PMOP*)tmpop;
- assert (tmpop && (tmpop->op_type == OP_PUSHRE));
- if (
-#ifdef USE_ITHREADS
- !pm->op_pmreplrootu.op_pmtargetoff
-#else
- !pm->op_pmreplrootu.op_pmtargetgv
-#endif
- && !pm->op_targ
- ) {
- if (!(left->op_private & OPpLVAL_INTRO) &&
- ( (left->op_type == OP_RV2AV &&
- (tmpop=((UNOP*)left)->op_first)->op_type==OP_GV)
- || left->op_type == OP_PADAV )
- ) {
- if (tmpop != (OP *)pm) {
+ /* optimise @a = split(...) into:
+ * @{expr}: split(..., @{expr}) (where @a is not flattened)
+ * @a, my @a, local @a: split(...) (where @a is attached to
+ * the split op itself)
+ */
+
+ if ( right
+ && right->op_type == OP_SPLIT
+ /* don't do twice, e.g. @b = (@a = split) */
+ && !(right->op_private & OPpSPLIT_ASSIGN))
+ {
+ OP *gvop = NULL;
+
+ if ( ( left->op_type == OP_RV2AV
+ && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
+ || left->op_type == OP_PADAV)
+ {
+ /* @pkg or @lex or local @pkg' or 'my @lex' */
+ OP *tmpop;
+ if (gvop) {
#ifdef USE_ITHREADS
- pm->op_pmreplrootu.op_pmtargetoff
- = cPADOPx(tmpop)->op_padix;
- cPADOPx(tmpop)->op_padix = 0; /* steal it */
+ ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
+ = cPADOPx(gvop)->op_padix;
+ cPADOPx(gvop)->op_padix = 0; /* steal it */
#else
- pm->op_pmreplrootu.op_pmtargetgv
- = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
- cSVOPx(tmpop)->op_sv = NULL; /* steal it */
-#endif
- right->op_private |=
- left->op_private & OPpOUR_INTRO;
- }
- else {
- pm->op_targ = left->op_targ;
- left->op_targ = 0; /* filch it */
- }
- detach_split:
- tmpop = cUNOPo->op_first; /* to list (nulled) */
- tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
- /* detach rest of siblings from o subtree,
- * and free subtree */
- op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL);
- op_free(o); /* blow off assign */
- right->op_flags &= ~OPf_WANT;
- /* "I don't know and I don't care." */
- return right;
- }
- else if (left->op_type == OP_RV2AV
- || left->op_type == OP_PADAV)
- {
- /* Detach the array. */
-#ifdef DEBUGGING
- OP * const ary =
+ ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
+ = MUTABLE_GV(cSVOPx(gvop)->op_sv);
+ cSVOPx(gvop)->op_sv = NULL; /* steal it */
#endif
- op_sibling_splice(cBINOPo->op_last,
- cUNOPx(cBINOPo->op_last)
- ->op_first, 1, NULL);
- assert(ary == left);
- /* Attach it to the split. */
- op_sibling_splice(right, cLISTOPx(right)->op_last,
- 0, left);
- right->op_flags |= OPf_STACKED;
- /* Detach split and expunge aassign as above. */
- goto detach_split;
- }
- else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
- ((LISTOP*)right)->op_last->op_type == OP_CONST)
- {
- SV ** const svp =
- &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
- SV * const sv = *svp;
- if (SvIOK(sv) && SvIVX(sv) == 0)
- {
- if (right->op_private & OPpSPLIT_IMPLIM) {
- /* our own SV, created in ck_split */
- SvREADONLY_off(sv);
- sv_setiv(sv, PL_modcount+1);
- }
- else {
- /* SV may belong to someone else */
- SvREFCNT_dec(sv);
- *svp = newSViv(PL_modcount+1);
- }
- }
- }
- }
+ right->op_private |=
+ left->op_private & OPpOUR_INTRO;
+ }
+ else {
+ ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
+ left->op_targ = 0; /* steal it */
+ right->op_private |= OPpSPLIT_LEX;
+ }
+ right->op_private |= left->op_private & OPpLVAL_INTRO;
+
+ detach_split:
+ tmpop = cUNOPo->op_first; /* to list (nulled) */
+ tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
+ assert(OpSIBLING(tmpop) == right);
+ assert(!OpHAS_SIBLING(right));
+ /* detach the split subtreee from the o tree,
+ * then free the residual o tree */
+ op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
+ op_free(o); /* blow off assign */
+ right->op_private |= OPpSPLIT_ASSIGN;
+ right->op_flags &= ~OPf_WANT;
+ /* "I don't know and I don't care." */
+ return right;
+ }
+ else if (left->op_type == OP_RV2AV) {
+ /* @{expr} */
+
+ OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
+ assert(OpSIBLING(pushop) == left);
+ /* Detach the array ... */
+ op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
+ /* ... and attach it to the split. */
+ op_sibling_splice(right, cLISTOPx(right)->op_last,
+ 0, left);
+ right->op_flags |= OPf_STACKED;
+ /* Detach split and expunge aassign as above. */
+ goto detach_split;
+ }
+ else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
+ ((LISTOP*)right)->op_last->op_type == OP_CONST)
+ {
+ /* convert split(...,0) to split(..., PL_modcount+1) */
+ SV ** const svp =
+ &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
+ SV * const sv = *svp;
+ if (SvIOK(sv) && SvIVX(sv) == 0)
+ {
+ if (right->op_private & OPpSPLIT_IMPLIM) {
+ /* our own SV, created in ck_split */
+ SvREADONLY_off(sv);
+ sv_setiv(sv, PL_modcount+1);
+ }
+ else {
+ /* SV may belong to someone else */
+ SvREFCNT_dec(sv);
+ *svp = newSViv(PL_modcount+1);
+ }
+ }
+ }
}
return o;
}
}
}
- if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
- other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
-
/* optimize AND and OR ops that have NOTs as children */
if (first->op_type == OP_NOT
&& (first->op_flags & OPf_KIDS)
CvSTASH_set(cv, PL_curstash);
*spot = cv;
}
- sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
+ SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
CvXSUBANY(cv).any_ptr = const_sv;
CvXSUB(cv) = const_sv_xsub;
CvCONST_on(cv);
if (cv) {
assert(!CvROOT(cv) && !CvCONST(cv));
cv_forget_slab(cv);
- sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
+ SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
CvXSUBANY(cv).any_ptr = const_sv;
CvXSUB(cv) = const_sv_xsub;
CvCONST_on(cv);
if (want_dollar && *name != '$')
sv_setpvs(namesv, "$");
else
- sv_setpvs(namesv, "");
+ SvPVCLEAR(namesv);
sv_catpvn(namesv, name, len);
if ( name_utf8 ) SvUTF8_on(namesv);
}
Perl_ck_sassign(pTHX_ OP *o)
{
dVAR;
- OP * const kid = cLISTOPo->op_first;
+ OP * const kid = cBINOPo->op_first;
PERL_ARGS_ASSERT_CK_SASSIGN;
{
dVAR;
OP *kid;
+ OP *sibs;
PERL_ARGS_ASSERT_CK_SPLIT;
+ assert(o->op_type == OP_LIST);
+
if (o->op_flags & OPf_STACKED)
return no_fh_allowed(o);
kid = cLISTOPo->op_first;
- if (kid->op_type != OP_NULL)
- Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
/* delete leading NULL node, then add a CONST if no other nodes */
+ assert(kid->op_type == OP_NULL);
op_sibling_splice(o, NULL, 1,
OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
op_free(kid);
kid = cLISTOPo->op_first;
if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
- /* remove kid, and replace with new optree */
+ /* remove match expression, and replace with new optree with
+ * a match op at its head */
op_sibling_splice(o, NULL, 1, NULL);
- /* OPf_SPECIAL is used to trigger split " " behavior */
- kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, NULL, 0, 0);
+ /* pmruntime will handle split " " behavior with flag==2 */
+ kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
op_sibling_splice(o, NULL, 0, kid);
}
- OpTYPE_set(kid, OP_PUSHRE);
- /* target implies @ary=..., so wipe it */
- kid->op_targ = 0;
- scalar(kid);
+
+ assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
+
if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
"Use of /g modifier is meaningless in split");
}
- if (!OpHAS_SIBLING(kid))
- op_append_elem(OP_SPLIT, o, newDEFSVOP());
+ /* eliminate the split op, and move the match op (plus any children)
+ * into its place, then convert the match op into a split op. i.e.
+ *
+ * SPLIT MATCH SPLIT(ex-MATCH)
+ * | | |
+ * MATCH - A - B - C => R - A - B - C => R - A - B - C
+ * | | |
+ * R X - Y X - Y
+ * |
+ * X - Y
+ *
+ * (R, if it exists, will be a regcomp op)
+ */
+
+ op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
+ sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
+ op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
+ OpTYPE_set(kid, OP_SPLIT);
+ kid->op_flags = (o->op_flags | (kid->op_flags & OPf_KIDS));
+ assert(!(kid->op_private & ~OPpRUNTIME));
+ kid->op_private = (o->op_private | (kid->op_private & OPpRUNTIME));
+ op_free(o);
+ o = kid;
+ kid = sibs; /* kid is now the string arg of the split */
- kid = OpSIBLING(kid);
- assert(kid);
+ if (!kid) {
+ kid = newDEFSVOP();
+ op_append_elem(OP_SPLIT, o, kid);
+ }
scalar(kid);
- if (!OpHAS_SIBLING(kid))
- {
- op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
+ kid = OpSIBLING(kid);
+ if (!kid) {
+ kid = newSVOP(OP_CONST, 0, newSViv(0));
+ op_append_elem(OP_SPLIT, o, kid);
o->op_private |= OPpSPLIT_IMPLIM;
}
- assert(OpHAS_SIBLING(kid));
-
- kid = OpSIBLING(kid);
scalar(kid);
if (OpHAS_SIBLING(kid))
case OP_PADAV:
case OP_PADHV:
(*scalars_p) += 2;
+ /* if !top, could be e.g. @a[0,1] */
if (top && (o->op_flags & OPf_REF))
return (o->op_private & OPpLVAL_INTRO)
? AAS_MY_AGG : AAS_LEX_AGG;
if (cUNOPx(o)->op_first->op_type != OP_GV)
return AAS_DANGEROUS; /* @{expr}, %{expr} */
/* @pkg, %pkg */
+ /* if !top, could be e.g. @a[0,1] */
if (top && (o->op_flags & OPf_REF))
return AAS_PKG_AGG;
return AAS_DANGEROUS;
return AAS_PKG_SCALAR; /* $pkg */
case OP_SPLIT:
- if (cLISTOPo->op_first->op_type == OP_PUSHRE) {
- /* "@foo = split... " optimises away the aassign and stores its
- * destination array in the OP_PUSHRE that precedes it.
- * A flattened array is always dangerous.
+ if (o->op_private & OPpSPLIT_ASSIGN) {
+ /* the assign in @a = split() has been optimised away
+ * and the @a attached directly to the split op
+ * Treat the array as appearing on the RHS, i.e.
+ * ... = (@a = split)
+ * is treated like
+ * ... = @a;
*/
+
+ if (o->op_flags & OPf_STACKED)
+ /* @{expr} = split() - the array expression is tacked
+ * on as an extra child to split - process kid */
+ return S_aassign_scan(aTHX_ cLISTOPo->op_last, rhs,
+ top, scalars_p);
+
+ /* ... else array is directly attached to split op */
(*scalars_p) += 2;
- return AAS_DANGEROUS;
+ if (PL_op->op_private & OPpSPLIT_LEX)
+ return (o->op_private & OPpLVAL_INTRO)
+ ? AAS_MY_AGG : AAS_LEX_AGG;
+ else
+ return AAS_PKG_AGG;
}
- break;
+ (*scalars_p)++;
+ /* other args of split can't be returned */
+ return AAS_SAFE_SCALAR;
case OP_UNDEF:
/* undef counts as a scalar on the RHS:
if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
&& PL_check[o->op_type] != Perl_ck_null)
return;
+ /* similarly for customised exists and delete */
+ if ( (o->op_type == OP_EXISTS)
+ && PL_check[o->op_type] != Perl_ck_exists)
+ return;
+ if ( (o->op_type == OP_DELETE)
+ && PL_check[o->op_type] != Perl_ck_delete)
+ return;
if ( o->op_type != OP_AELEM
|| (o->op_private &
if ( intro
&& (8*sizeof(base) >
8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
- ? base
+ ? (Size_t)base
: (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
) >
(UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
/* On OP_NULL, saw a "do". */
/* On OP_EXISTS, treat av as av, not avhv. */
/* On OP_(ENTER|LEAVE)EVAL, don't clear $@ */
- /* On pushre, rx is used as part of split, e.g. split " " */
/* On regcomp, "use re 'eval'" was in scope */
/* On RV2[ACGHS]V, don't create GV--in
defined()*/
U32 op_pmflags;
union {
OP * op_pmreplroot; /* For OP_SUBST */
-#ifdef USE_ITHREADS
- PADOFFSET op_pmtargetoff; /* For OP_PUSHRE */
-#else
- GV * op_pmtargetgv;
-#endif
+ PADOFFSET op_pmtargetoff; /* For OP_SPLIT lex ary or thr GV */
+ GV * op_pmtargetgv; /* For OP_SPLIT non-threaded GV */
} op_pmreplrootu;
union {
OP * op_pmreplstart; /* Only used in OP_SUBST */
"padav",
"padhv",
"padany",
- "pushre",
"rv2gv",
"rv2sv",
"av2arylen",
"private array",
"private hash",
"private value",
- "push regexp",
"ref-to-glob cast",
"scalar dereference",
"array length",
Perl_pp_padav,
Perl_pp_padhv,
Perl_pp_padany, /* implemented by Perl_unimplemented_op */
- Perl_pp_pushre,
Perl_pp_rv2gv,
Perl_pp_rv2sv,
Perl_pp_av2arylen,
Perl_ck_null, /* padav */
Perl_ck_null, /* padhv */
Perl_ck_null, /* padany */
- Perl_ck_null, /* pushre */
Perl_ck_rvconst, /* rv2gv */
Perl_ck_rvconst, /* rv2sv */
Perl_ck_null, /* av2arylen */
0x00000040, /* padav */
0x00000040, /* padhv */
0x00000040, /* padany */
- 0x00000540, /* pushre */
0x00000144, /* rv2gv */
0x00000144, /* rv2sv */
0x00000104, /* av2arylen */
0x00000304, /* substcont */
0x00001804, /* trans */
0x00001804, /* transr */
- 0x00000004, /* sassign */
+ 0x00011204, /* sassign */
0x00022208, /* aassign */
0x00002b0d, /* chop */
0x00009b8c, /* schop */
0x00000f44, /* multideref */
0x00091480, /* unpack */
0x0002140f, /* pack */
- 0x00111408, /* split */
+ 0x00111508, /* split */
0x0002140f, /* join */
0x00002401, /* list */
0x00224200, /* lslice */
#define OPpSORT_INTEGER 0x02
#define OPpTRANS_TO_UTF 0x02
#define OPpARG2_MASK 0x03
+#define OPpAVHVSWITCH_MASK 0x03
#define OPpARGELEM_HV 0x04
#define OPpCONST_SHORTCIRCUIT 0x04
#define OPpDONT_INIT_GV 0x04
#define OPpLVREF_ELEM 0x04
#define OPpSLICEWARNING 0x04
#define OPpSORT_REVERSE 0x04
+#define OPpSPLIT_IMPLIM 0x04
#define OPpTRANS_IDENTICAL 0x04
#define OPpARGELEM_MASK 0x06
#define OPpARG3_MASK 0x07
#define OPpMAYBE_LVSUB 0x08
#define OPpREVERSE_INPLACE 0x08
#define OPpSORT_INPLACE 0x08
+#define OPpSPLIT_LEX 0x08
#define OPpTRANS_SQUASH 0x08
#define OPpARG4_MASK 0x0f
#define OPpASSIGN_COMMON_AGG 0x10
#define OPpMULTIDEREF_EXISTS 0x10
#define OPpOPEN_IN_RAW 0x10
#define OPpSORT_DESCEND 0x10
+#define OPpSPLIT_ASSIGN 0x10
#define OPpSUBSTR_REPL_FIRST 0x10
#define OPpTARGET_MY 0x10
#define OPpASSIGN_COMMON_RC1 0x20
#define OPpMAY_RETURN_CONSTANT 0x20
#define OPpMULTIDEREF_DELETE 0x20
#define OPpOPEN_IN_CRLF 0x20
+#define OPpRUNTIME 0x20
#define OPpSORT_QSORT 0x20
#define OPpTRANS_COMPLEMENT 0x20
#define OPpTRUEBOOL 0x20
#define OPpPAD_STATE 0x40
#define OPpREFCOUNTED 0x40
#define OPpREPEAT_DOLIST 0x40
-#define OPpRUNTIME 0x40
#define OPpSLICE 0x40
#define OPpSORT_STABLE 0x40
#define OPpTRANS_GROWS 0x40
#define OPpOFFBYONE 0x80
#define OPpOPEN_OUT_CRLF 0x80
#define OPpPV_IS_UTF8 0x80
-#define OPpSPLIT_IMPLIM 0x80
#define OPpTRANS_DELETE 0x80
START_EXTERN_C
'<','U','T','F','\0',
'>','U','T','F','\0',
'A','M','P','E','R','\0',
+ 'A','S','S','I','G','N','\0',
'A','V','\0',
'B','A','R','E','\0',
'B','K','W','A','R','D','\0',
'I','N','P','L','A','C','E','\0',
'I','N','T','\0',
'I','T','E','R','\0',
+ 'L','E','X','\0',
'L','I','N','E','N','U','M','\0',
'L','V','\0',
'L','V','D','E','F','E','R','\0',
'T','A','R','G','M','Y','\0',
'U','N','I','\0',
'U','T','F','\0',
+ 'k','e','y','\0',
+ 'o','f','f','s','e','t','\0',
+ 'r','a','n','g','e','\0',
};
EXTCONST I16 PL_op_private_bitfields[] = {
0, 8, -1,
0, 8, -1,
- 0, -1, -1,
+ 0, 545, -1,
0, 8, -1,
0, 8, -1,
- 0, 8, -1,
- 0, 8, -1,
- 1, -1, 0, 507, 1, 26, 2, 276, -1,
- 4, -1, 1, 157, 2, 164, 3, 171, -1,
- 4, -1, 0, 507, 1, 26, 2, 276, 3, 103, -1,
+ 0, 552, -1,
+ 0, 541, -1,
+ 1, -1, 0, 518, 1, 33, 2, 283, -1,
+ 4, -1, 1, 164, 2, 171, 3, 178, -1,
+ 4, -1, 0, 518, 1, 33, 2, 283, 3, 110, -1,
};
16, /* padav */
20, /* padhv */
-1, /* padany */
- 26, /* pushre */
- 27, /* rv2gv */
- 34, /* rv2sv */
- 39, /* av2arylen */
- 41, /* rv2cv */
+ 26, /* rv2gv */
+ 33, /* rv2sv */
+ 38, /* av2arylen */
+ 40, /* rv2cv */
-1, /* anoncode */
0, /* prototype */
0, /* refgen */
0, /* srefgen */
0, /* ref */
- 48, /* bless */
- 49, /* backtick */
- 48, /* glob */
+ 47, /* bless */
+ 48, /* backtick */
+ 47, /* glob */
0, /* readline */
-1, /* rcatline */
0, /* regcmaybe */
0, /* regcreset */
0, /* regcomp */
- 26, /* match */
- 26, /* qr */
- 26, /* subst */
+ 53, /* match */
+ 53, /* qr */
+ 53, /* subst */
54, /* substcont */
56, /* trans */
56, /* transr */
0, /* defined */
0, /* undef */
0, /* study */
- 39, /* pos */
+ 38, /* pos */
0, /* preinc */
0, /* i_preinc */
0, /* predec */
82, /* vec */
77, /* index */
77, /* rindex */
- 48, /* sprintf */
- 48, /* formline */
+ 47, /* sprintf */
+ 47, /* formline */
71, /* ord */
71, /* chr */
77, /* crypt */
99, /* kvaslice */
0, /* aeach */
0, /* avalues */
- 39, /* akeys */
+ 38, /* akeys */
0, /* each */
0, /* values */
- 39, /* keys */
+ 38, /* keys */
100, /* delete */
103, /* exists */
105, /* rv2hv */
96, /* hslice */
99, /* kvhslice */
113, /* multideref */
- 48, /* unpack */
- 48, /* pack */
+ 47, /* unpack */
+ 47, /* pack */
120, /* split */
- 48, /* join */
- 122, /* list */
+ 47, /* join */
+ 126, /* list */
12, /* lslice */
- 48, /* anonlist */
- 48, /* anonhash */
- 48, /* splice */
+ 47, /* anonlist */
+ 47, /* anonhash */
+ 47, /* splice */
77, /* push */
0, /* pop */
0, /* shift */
77, /* unshift */
- 124, /* sort */
- 131, /* reverse */
+ 128, /* sort */
+ 135, /* reverse */
0, /* grepstart */
0, /* grepwhile */
0, /* mapstart */
0, /* mapwhile */
0, /* range */
- 133, /* flip */
- 133, /* flop */
+ 137, /* flip */
+ 137, /* flop */
0, /* and */
0, /* or */
12, /* xor */
0, /* dor */
- 135, /* cond_expr */
+ 139, /* cond_expr */
0, /* andassign */
0, /* orassign */
0, /* dorassign */
0, /* method */
- 137, /* entersub */
- 144, /* leavesub */
- 144, /* leavesublv */
+ 141, /* entersub */
+ 148, /* leavesub */
+ 148, /* leavesublv */
0, /* argcheck */
- 146, /* argelem */
+ 150, /* argelem */
0, /* argdefelem */
- 148, /* caller */
- 48, /* warn */
- 48, /* die */
- 48, /* reset */
+ 152, /* caller */
+ 47, /* warn */
+ 47, /* die */
+ 47, /* reset */
-1, /* lineseq */
- 150, /* nextstate */
- 150, /* dbstate */
+ 154, /* nextstate */
+ 154, /* dbstate */
-1, /* unstack */
-1, /* enter */
- 151, /* leave */
+ 155, /* leave */
-1, /* scope */
- 153, /* enteriter */
- 157, /* iter */
+ 157, /* enteriter */
+ 161, /* iter */
-1, /* enterloop */
- 158, /* leaveloop */
+ 162, /* leaveloop */
-1, /* return */
- 160, /* last */
- 160, /* next */
- 160, /* redo */
- 160, /* dump */
- 160, /* goto */
- 48, /* exit */
+ 164, /* last */
+ 164, /* next */
+ 164, /* redo */
+ 164, /* dump */
+ 164, /* goto */
+ 47, /* exit */
0, /* method_named */
0, /* method_super */
0, /* method_redir */
0, /* leavewhen */
-1, /* break */
-1, /* continue */
- 162, /* open */
- 48, /* close */
- 48, /* pipe_op */
- 48, /* fileno */
- 48, /* umask */
- 48, /* binmode */
- 48, /* tie */
+ 166, /* open */
+ 47, /* close */
+ 47, /* pipe_op */
+ 47, /* fileno */
+ 47, /* umask */
+ 47, /* binmode */
+ 47, /* tie */
0, /* untie */
0, /* tied */
- 48, /* dbmopen */
+ 47, /* dbmopen */
0, /* dbmclose */
- 48, /* sselect */
- 48, /* select */
- 48, /* getc */
- 48, /* read */
- 48, /* enterwrite */
- 144, /* leavewrite */
+ 47, /* sselect */
+ 47, /* select */
+ 47, /* getc */
+ 47, /* read */
+ 47, /* enterwrite */
+ 148, /* leavewrite */
-1, /* prtf */
-1, /* print */
-1, /* say */
- 48, /* sysopen */
- 48, /* sysseek */
- 48, /* sysread */
- 48, /* syswrite */
- 48, /* eof */
- 48, /* tell */
- 48, /* seek */
- 48, /* truncate */
- 48, /* fcntl */
- 48, /* ioctl */
+ 47, /* sysopen */
+ 47, /* sysseek */
+ 47, /* sysread */
+ 47, /* syswrite */
+ 47, /* eof */
+ 47, /* tell */
+ 47, /* seek */
+ 47, /* truncate */
+ 47, /* fcntl */
+ 47, /* ioctl */
77, /* flock */
- 48, /* send */
- 48, /* recv */
- 48, /* socket */
- 48, /* sockpair */
- 48, /* bind */
- 48, /* connect */
- 48, /* listen */
- 48, /* accept */
- 48, /* shutdown */
- 48, /* gsockopt */
- 48, /* ssockopt */
+ 47, /* send */
+ 47, /* recv */
+ 47, /* socket */
+ 47, /* sockpair */
+ 47, /* bind */
+ 47, /* connect */
+ 47, /* listen */
+ 47, /* accept */
+ 47, /* shutdown */
+ 47, /* gsockopt */
+ 47, /* ssockopt */
0, /* getsockname */
0, /* getpeername */
0, /* lstat */
0, /* stat */
- 167, /* ftrread */
- 167, /* ftrwrite */
- 167, /* ftrexec */
- 167, /* fteread */
- 167, /* ftewrite */
- 167, /* fteexec */
- 172, /* ftis */
- 172, /* ftsize */
- 172, /* ftmtime */
- 172, /* ftatime */
- 172, /* ftctime */
- 172, /* ftrowned */
- 172, /* fteowned */
- 172, /* ftzero */
- 172, /* ftsock */
- 172, /* ftchr */
- 172, /* ftblk */
- 172, /* ftfile */
- 172, /* ftdir */
- 172, /* ftpipe */
- 172, /* ftsuid */
- 172, /* ftsgid */
- 172, /* ftsvtx */
- 172, /* ftlink */
- 172, /* fttty */
- 172, /* fttext */
- 172, /* ftbinary */
+ 171, /* ftrread */
+ 171, /* ftrwrite */
+ 171, /* ftrexec */
+ 171, /* fteread */
+ 171, /* ftewrite */
+ 171, /* fteexec */
+ 176, /* ftis */
+ 176, /* ftsize */
+ 176, /* ftmtime */
+ 176, /* ftatime */
+ 176, /* ftctime */
+ 176, /* ftrowned */
+ 176, /* fteowned */
+ 176, /* ftzero */
+ 176, /* ftsock */
+ 176, /* ftchr */
+ 176, /* ftblk */
+ 176, /* ftfile */
+ 176, /* ftdir */
+ 176, /* ftpipe */
+ 176, /* ftsuid */
+ 176, /* ftsgid */
+ 176, /* ftsvtx */
+ 176, /* ftlink */
+ 176, /* fttty */
+ 176, /* fttext */
+ 176, /* ftbinary */
77, /* chdir */
77, /* chown */
71, /* chroot */
0, /* readlink */
77, /* mkdir */
71, /* rmdir */
- 48, /* open_dir */
+ 47, /* open_dir */
0, /* readdir */
0, /* telldir */
- 48, /* seekdir */
+ 47, /* seekdir */
0, /* rewinddir */
0, /* closedir */
-1, /* fork */
- 176, /* wait */
+ 180, /* wait */
77, /* waitpid */
77, /* system */
77, /* exec */
77, /* kill */
- 176, /* getppid */
+ 180, /* getppid */
77, /* getpgrp */
77, /* setpgrp */
77, /* getpriority */
77, /* setpriority */
- 176, /* time */
+ 180, /* time */
-1, /* tms */
0, /* localtime */
- 48, /* gmtime */
+ 47, /* gmtime */
0, /* alarm */
77, /* sleep */
- 48, /* shmget */
- 48, /* shmctl */
- 48, /* shmread */
- 48, /* shmwrite */
- 48, /* msgget */
- 48, /* msgctl */
- 48, /* msgsnd */
- 48, /* msgrcv */
- 48, /* semop */
- 48, /* semget */
- 48, /* semctl */
+ 47, /* shmget */
+ 47, /* shmctl */
+ 47, /* shmread */
+ 47, /* shmwrite */
+ 47, /* msgget */
+ 47, /* msgctl */
+ 47, /* msgsnd */
+ 47, /* msgrcv */
+ 47, /* semop */
+ 47, /* semget */
+ 47, /* semctl */
0, /* require */
0, /* dofile */
-1, /* hintseval */
- 177, /* entereval */
- 144, /* leaveeval */
+ 181, /* entereval */
+ 148, /* leaveeval */
0, /* entertry */
-1, /* leavetry */
0, /* ghbyname */
- 48, /* ghbyaddr */
+ 47, /* ghbyaddr */
-1, /* ghostent */
0, /* gnbyname */
- 48, /* gnbyaddr */
+ 47, /* gnbyaddr */
-1, /* gnetent */
0, /* gpbyname */
- 48, /* gpbynumber */
+ 47, /* gpbynumber */
-1, /* gprotoent */
- 48, /* gsbyname */
- 48, /* gsbyport */
+ 47, /* gsbyname */
+ 47, /* gsbyport */
-1, /* gservent */
0, /* shostent */
0, /* snetent */
-1, /* sgrent */
-1, /* egrent */
-1, /* getlogin */
- 48, /* syscall */
+ 47, /* syscall */
0, /* lock */
0, /* once */
-1, /* custom */
- 183, /* coreargs */
- 187, /* avhvswitch */
+ 187, /* coreargs */
+ 191, /* avhvswitch */
3, /* runcv */
0, /* fc */
-1, /* padcv */
-1, /* introcv */
-1, /* clonecv */
- 189, /* padrange */
- 191, /* refassign */
- 197, /* lvref */
- 203, /* lvrefslice */
- 204, /* lvavref */
+ 193, /* padrange */
+ 195, /* refassign */
+ 201, /* lvref */
+ 207, /* lvrefslice */
+ 208, /* lvavref */
0, /* anonconst */
};
EXTCONST U16 PL_op_private_bitdefs[] = {
0x0003, /* scalar, prototype, refgen, srefgen, ref, readline, regcmaybe, regcreset, regcomp, chop, schop, defined, undef, study, preinc, i_preinc, predec, i_predec, postinc, i_postinc, postdec, i_postdec, negate, i_negate, not, complement, ucfirst, lcfirst, uc, lc, quotemeta, aeach, avalues, each, values, pop, shift, grepstart, grepwhile, mapstart, mapwhile, range, and, or, dor, andassign, orassign, dorassign, method, argcheck, argdefelem, method_named, method_super, method_redir, method_redir_super, entergiven, leavegiven, enterwhen, leavewhen, untie, tied, dbmclose, getsockname, getpeername, lstat, stat, readlink, readdir, telldir, rewinddir, closedir, localtime, alarm, require, dofile, entertry, ghbyname, gnbyname, gpbyname, shostent, snetent, sprotoent, sservent, gpwnam, gpwuid, ggrnam, ggrgid, lock, once, fc, anonconst */
- 0x2b5c, 0x3d59, /* pushmark */
+ 0x2cbc, 0x3eb9, /* pushmark */
0x00bd, /* wantarray, runcv */
- 0x03b8, 0x17f0, 0x3e0c, 0x38c8, 0x2f25, /* const */
- 0x2b5c, 0x3079, /* gvsv */
- 0x1655, /* gv */
+ 0x0498, 0x18d0, 0x3f6c, 0x3a28, 0x3085, /* const */
+ 0x2cbc, 0x31d9, /* gvsv */
+ 0x1735, /* gv */
0x0067, /* gelem, lt, i_lt, gt, i_gt, le, i_le, ge, i_ge, eq, i_eq, ne, i_ne, ncmp, i_ncmp, slt, sgt, sle, sge, seq, sne, scmp, bit_and, bit_xor, bit_or, sbit_and, sbit_xor, sbit_or, smartmatch, lslice, xor */
- 0x2b5c, 0x3d58, 0x03d7, /* padsv */
- 0x2b5c, 0x3d58, 0x2c4c, 0x3a49, /* padav */
- 0x2b5c, 0x3d58, 0x0534, 0x05d0, 0x2c4c, 0x3a49, /* padhv */
- 0x3819, /* pushre, match, qr, subst */
- 0x2b5c, 0x19d8, 0x03d6, 0x2c4c, 0x2e48, 0x3e04, 0x0003, /* rv2gv */
- 0x2b5c, 0x3078, 0x03d6, 0x3e04, 0x0003, /* rv2sv */
- 0x2c4c, 0x0003, /* av2arylen, pos, akeys, keys */
- 0x2dbc, 0x0e18, 0x0b74, 0x028c, 0x3fc8, 0x3e04, 0x0003, /* rv2cv */
+ 0x2cbc, 0x3eb8, 0x03d7, /* padsv */
+ 0x2cbc, 0x3eb8, 0x2dac, 0x3ba9, /* padav */
+ 0x2cbc, 0x3eb8, 0x0614, 0x06b0, 0x2dac, 0x3ba9, /* padhv */
+ 0x2cbc, 0x1ab8, 0x03d6, 0x2dac, 0x2fa8, 0x3f64, 0x0003, /* rv2gv */
+ 0x2cbc, 0x31d8, 0x03d6, 0x3f64, 0x0003, /* rv2sv */
+ 0x2dac, 0x0003, /* av2arylen, pos, akeys, keys */
+ 0x2f1c, 0x0ef8, 0x0c54, 0x028c, 0x4128, 0x3f64, 0x0003, /* rv2cv */
0x018f, /* bless, glob, sprintf, formline, unpack, pack, join, anonlist, anonhash, splice, warn, die, reset, exit, close, pipe_op, fileno, umask, binmode, tie, dbmopen, sselect, select, getc, read, enterwrite, sysopen, sysseek, sysread, syswrite, eof, tell, seek, truncate, fcntl, ioctl, send, recv, socket, sockpair, bind, connect, listen, accept, shutdown, gsockopt, ssockopt, open_dir, seekdir, gmtime, shmget, shmctl, shmread, shmwrite, msgget, msgctl, msgsnd, msgrcv, semop, semget, semctl, ghbyaddr, gnbyaddr, gpbynumber, gsbyname, gsbyport, syscall */
- 0x325c, 0x3178, 0x2634, 0x2570, 0x0003, /* backtick */
- 0x3818, 0x0003, /* substcont */
- 0x0f1c, 0x1f58, 0x0754, 0x3b8c, 0x22e8, 0x01e4, 0x0141, /* trans, transr */
- 0x0d5c, 0x0458, 0x0067, /* sassign */
- 0x0a18, 0x0914, 0x0810, 0x2c4c, 0x0067, /* aassign */
- 0x4070, 0x0003, /* chomp, schomp, ncomplement, scomplement, sin, cos, exp, log, sqrt, int, hex, oct, abs, length, ord, chr, chroot, rmdir */
- 0x4070, 0x0067, /* pow, multiply, i_multiply, divide, i_divide, modulo, i_modulo, add, i_add, subtract, i_subtract, concat, left_shift, right_shift, nbit_and, nbit_xor, nbit_or */
- 0x12d8, 0x0067, /* repeat */
- 0x4070, 0x018f, /* stringify, atan2, rand, srand, index, rindex, crypt, push, unshift, flock, chdir, chown, unlink, chmod, utime, rename, link, symlink, mkdir, waitpid, system, exec, kill, getpgrp, setpgrp, getpriority, setpriority, sleep */
- 0x3570, 0x2c4c, 0x012b, /* substr */
- 0x2c4c, 0x0067, /* vec */
- 0x2b5c, 0x3078, 0x2c4c, 0x3a48, 0x3e04, 0x0003, /* rv2av */
+ 0x33bc, 0x32d8, 0x2714, 0x2650, 0x0003, /* backtick */
+ 0x3975, /* match, qr, subst */
+ 0x3974, 0x0003, /* substcont */
+ 0x0ffc, 0x2038, 0x0834, 0x3cec, 0x23c8, 0x01e4, 0x0141, /* trans, transr */
+ 0x0e3c, 0x0538, 0x0067, /* sassign */
+ 0x0af8, 0x09f4, 0x08f0, 0x2dac, 0x0067, /* aassign */
+ 0x41d0, 0x0003, /* chomp, schomp, ncomplement, scomplement, sin, cos, exp, log, sqrt, int, hex, oct, abs, length, ord, chr, chroot, rmdir */
+ 0x41d0, 0x0067, /* pow, multiply, i_multiply, divide, i_divide, modulo, i_modulo, add, i_add, subtract, i_subtract, concat, left_shift, right_shift, nbit_and, nbit_xor, nbit_or */
+ 0x13b8, 0x0067, /* repeat */
+ 0x41d0, 0x018f, /* stringify, atan2, rand, srand, index, rindex, crypt, push, unshift, flock, chdir, chown, unlink, chmod, utime, rename, link, symlink, mkdir, waitpid, system, exec, kill, getpgrp, setpgrp, getpriority, setpriority, sleep */
+ 0x36d0, 0x2dac, 0x012b, /* substr */
+ 0x2dac, 0x0067, /* vec */
+ 0x2cbc, 0x31d8, 0x2dac, 0x3ba8, 0x3f64, 0x0003, /* rv2av */
0x025f, /* aelemfast, aelemfast_lex */
- 0x2b5c, 0x2a58, 0x03d6, 0x2c4c, 0x0067, /* aelem, helem */
- 0x2b5c, 0x2c4c, 0x3a49, /* aslice, hslice */
- 0x2c4d, /* kvaslice, kvhslice */
- 0x2b5c, 0x3998, 0x0003, /* delete */
- 0x3ef8, 0x0003, /* exists */
- 0x2b5c, 0x3078, 0x0534, 0x05d0, 0x2c4c, 0x3a48, 0x3e04, 0x0003, /* rv2hv */
- 0x2b5c, 0x2a58, 0x0f94, 0x18f0, 0x2c4c, 0x3e04, 0x0003, /* multideref */
- 0x23bc, 0x3079, /* split */
- 0x2b5c, 0x2019, /* list */
- 0x3c78, 0x3314, 0x1230, 0x26cc, 0x3668, 0x27c4, 0x2fe1, /* sort */
- 0x26cc, 0x0003, /* reverse */
- 0x28f8, 0x0003, /* flip, flop */
- 0x2b5c, 0x0003, /* cond_expr */
- 0x2b5c, 0x0e18, 0x03d6, 0x028c, 0x3fc8, 0x3e04, 0x2481, /* entersub */
- 0x33d8, 0x0003, /* leavesub, leavesublv, leavewrite, leaveeval */
+ 0x2cbc, 0x2bb8, 0x03d6, 0x2dac, 0x0067, /* aelem, helem */
+ 0x2cbc, 0x2dac, 0x3ba9, /* aslice, hslice */
+ 0x2dad, /* kvaslice, kvhslice */
+ 0x2cbc, 0x3af8, 0x0003, /* delete */
+ 0x4058, 0x0003, /* exists */
+ 0x2cbc, 0x31d8, 0x0614, 0x06b0, 0x2dac, 0x3ba8, 0x3f64, 0x0003, /* rv2hv */
+ 0x2cbc, 0x2bb8, 0x1074, 0x19d0, 0x2dac, 0x3f64, 0x0003, /* multideref */
+ 0x2cbc, 0x31d8, 0x3974, 0x0350, 0x29cc, 0x2489, /* split */
+ 0x2cbc, 0x20f9, /* list */
+ 0x3dd8, 0x3474, 0x1310, 0x27ac, 0x37c8, 0x28a4, 0x3141, /* sort */
+ 0x27ac, 0x0003, /* reverse */
+ 0x2a58, 0x0003, /* flip, flop */
+ 0x2cbc, 0x0003, /* cond_expr */
+ 0x2cbc, 0x0ef8, 0x03d6, 0x028c, 0x4128, 0x3f64, 0x2561, /* entersub */
+ 0x3538, 0x0003, /* leavesub, leavesublv, leavewrite, leaveeval */
0x02aa, 0x0003, /* argelem */
0x00bc, 0x018f, /* caller */
- 0x21f5, /* nextstate, dbstate */
- 0x29fc, 0x33d9, /* leave */
- 0x2b5c, 0x3078, 0x0e8c, 0x36e5, /* enteriter */
- 0x36e5, /* iter */
- 0x29fc, 0x0067, /* leaveloop */
- 0x41dc, 0x0003, /* last, next, redo, dump, goto */
- 0x325c, 0x3178, 0x2634, 0x2570, 0x018f, /* open */
- 0x1b90, 0x1dec, 0x1ca8, 0x1a64, 0x0003, /* ftrread, ftrwrite, ftrexec, fteread, ftewrite, fteexec */
- 0x1b90, 0x1dec, 0x1ca8, 0x0003, /* ftis, ftsize, ftmtime, ftatime, ftctime, ftrowned, fteowned, ftzero, ftsock, ftchr, ftblk, ftfile, ftdir, ftpipe, ftsuid, ftsgid, ftsvtx, ftlink, fttty, fttext, ftbinary */
- 0x4071, /* wait, getppid, time */
- 0x3474, 0x0c30, 0x068c, 0x4148, 0x2104, 0x0003, /* entereval */
- 0x2d1c, 0x0018, 0x1144, 0x1061, /* coreargs */
- 0x2c4c, 0x00c7, /* avhvswitch */
- 0x2b5c, 0x01fb, /* padrange */
- 0x2b5c, 0x3d58, 0x04f6, 0x284c, 0x1748, 0x0067, /* refassign */
- 0x2b5c, 0x3d58, 0x04f6, 0x284c, 0x1748, 0x0003, /* lvref */
- 0x2b5d, /* lvrefslice */
- 0x2b5c, 0x3d58, 0x0003, /* lvavref */
+ 0x22d5, /* nextstate, dbstate */
+ 0x2b5c, 0x3539, /* leave */
+ 0x2cbc, 0x31d8, 0x0f6c, 0x3845, /* enteriter */
+ 0x3845, /* iter */
+ 0x2b5c, 0x0067, /* leaveloop */
+ 0x433c, 0x0003, /* last, next, redo, dump, goto */
+ 0x33bc, 0x32d8, 0x2714, 0x2650, 0x018f, /* open */
+ 0x1c70, 0x1ecc, 0x1d88, 0x1b44, 0x0003, /* ftrread, ftrwrite, ftrexec, fteread, ftewrite, fteexec */
+ 0x1c70, 0x1ecc, 0x1d88, 0x0003, /* ftis, ftsize, ftmtime, ftatime, ftctime, ftrowned, fteowned, ftzero, ftsock, ftchr, ftblk, ftfile, ftdir, ftpipe, ftsuid, ftsgid, ftsvtx, ftlink, fttty, fttext, ftbinary */
+ 0x41d1, /* wait, getppid, time */
+ 0x35d4, 0x0d10, 0x076c, 0x42a8, 0x21e4, 0x0003, /* entereval */
+ 0x2e7c, 0x0018, 0x1224, 0x1141, /* coreargs */
+ 0x2dac, 0x00c7, /* avhvswitch */
+ 0x2cbc, 0x01fb, /* padrange */
+ 0x2cbc, 0x3eb8, 0x04f6, 0x292c, 0x1828, 0x0067, /* refassign */
+ 0x2cbc, 0x3eb8, 0x04f6, 0x292c, 0x1828, 0x0003, /* lvref */
+ 0x2cbd, /* lvrefslice */
+ 0x2cbc, 0x3eb8, 0x0003, /* lvavref */
};
/* PADAV */ (OPpSLICEWARNING|OPpMAYBE_LVSUB|OPpPAD_STATE|OPpLVAL_INTRO),
/* PADHV */ (OPpSLICEWARNING|OPpMAYBE_LVSUB|OPpMAYBE_TRUEBOOL|OPpTRUEBOOL|OPpPAD_STATE|OPpLVAL_INTRO),
/* PADANY */ (0),
- /* PUSHRE */ (OPpRUNTIME),
/* RV2GV */ (OPpARG1_MASK|OPpHINT_STRICT_REFS|OPpDONT_INIT_GV|OPpMAYBE_LVSUB|OPpDEREF|OPpALLOW_FAKE|OPpLVAL_INTRO),
/* RV2SV */ (OPpARG1_MASK|OPpHINT_STRICT_REFS|OPpDEREF|OPpOUR_INTRO|OPpLVAL_INTRO),
/* AV2ARYLEN */ (OPpARG1_MASK|OPpMAYBE_LVSUB),
/* MULTIDEREF */ (OPpARG1_MASK|OPpHINT_STRICT_REFS|OPpMAYBE_LVSUB|OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE|OPpLVAL_DEFER|OPpLVAL_INTRO),
/* UNPACK */ (OPpARG4_MASK),
/* PACK */ (OPpARG4_MASK),
- /* SPLIT */ (OPpOUR_INTRO|OPpSPLIT_IMPLIM),
+ /* SPLIT */ (OPpSPLIT_IMPLIM|OPpSPLIT_LEX|OPpSPLIT_ASSIGN|OPpRUNTIME|OPpOUR_INTRO|OPpLVAL_INTRO),
/* JOIN */ (OPpARG4_MASK),
/* LIST */ (OPpLIST_GUESSED|OPpLVAL_INTRO),
/* LSLICE */ (OPpARG2_MASK),
/* ONCE */ (OPpARG1_MASK),
/* CUSTOM */ (0xff),
/* COREARGS */ (OPpCOREARGS_DEREF1|OPpCOREARGS_DEREF2|OPpCOREARGS_SCALARMOD|OPpCOREARGS_PUSHMARK),
- /* AVHVSWITCH */ (3|OPpMAYBE_LVSUB),
+ /* AVHVSWITCH */ (OPpAVHVSWITCH_MASK|OPpMAYBE_LVSUB),
/* RUNCV */ (OPpOFFBYONE),
/* FC */ (OPpARG1_MASK),
/* PADCV */ (0),
OP_PADAV = 10,
OP_PADHV = 11,
OP_PADANY = 12,
- OP_PUSHRE = 13,
- OP_RV2GV = 14,
- OP_RV2SV = 15,
- OP_AV2ARYLEN = 16,
- OP_RV2CV = 17,
- OP_ANONCODE = 18,
- OP_PROTOTYPE = 19,
- OP_REFGEN = 20,
- OP_SREFGEN = 21,
- OP_REF = 22,
- OP_BLESS = 23,
- OP_BACKTICK = 24,
- OP_GLOB = 25,
- OP_READLINE = 26,
- OP_RCATLINE = 27,
- OP_REGCMAYBE = 28,
- OP_REGCRESET = 29,
- OP_REGCOMP = 30,
- OP_MATCH = 31,
- OP_QR = 32,
- OP_SUBST = 33,
- OP_SUBSTCONT = 34,
- OP_TRANS = 35,
- OP_TRANSR = 36,
- OP_SASSIGN = 37,
- OP_AASSIGN = 38,
- OP_CHOP = 39,
- OP_SCHOP = 40,
- OP_CHOMP = 41,
- OP_SCHOMP = 42,
- OP_DEFINED = 43,
- OP_UNDEF = 44,
- OP_STUDY = 45,
- OP_POS = 46,
- OP_PREINC = 47,
- OP_I_PREINC = 48,
- OP_PREDEC = 49,
- OP_I_PREDEC = 50,
- OP_POSTINC = 51,
- OP_I_POSTINC = 52,
- OP_POSTDEC = 53,
- OP_I_POSTDEC = 54,
- OP_POW = 55,
- OP_MULTIPLY = 56,
- OP_I_MULTIPLY = 57,
- OP_DIVIDE = 58,
- OP_I_DIVIDE = 59,
- OP_MODULO = 60,
- OP_I_MODULO = 61,
- OP_REPEAT = 62,
- OP_ADD = 63,
- OP_I_ADD = 64,
- OP_SUBTRACT = 65,
- OP_I_SUBTRACT = 66,
- OP_CONCAT = 67,
- OP_STRINGIFY = 68,
- OP_LEFT_SHIFT = 69,
- OP_RIGHT_SHIFT = 70,
- OP_LT = 71,
- OP_I_LT = 72,
- OP_GT = 73,
- OP_I_GT = 74,
- OP_LE = 75,
- OP_I_LE = 76,
- OP_GE = 77,
- OP_I_GE = 78,
- OP_EQ = 79,
- OP_I_EQ = 80,
- OP_NE = 81,
- OP_I_NE = 82,
- OP_NCMP = 83,
- OP_I_NCMP = 84,
- OP_SLT = 85,
- OP_SGT = 86,
- OP_SLE = 87,
- OP_SGE = 88,
- OP_SEQ = 89,
- OP_SNE = 90,
- OP_SCMP = 91,
- OP_BIT_AND = 92,
- OP_BIT_XOR = 93,
- OP_BIT_OR = 94,
- OP_NBIT_AND = 95,
- OP_NBIT_XOR = 96,
- OP_NBIT_OR = 97,
- OP_SBIT_AND = 98,
- OP_SBIT_XOR = 99,
- OP_SBIT_OR = 100,
- OP_NEGATE = 101,
- OP_I_NEGATE = 102,
- OP_NOT = 103,
- OP_COMPLEMENT = 104,
- OP_NCOMPLEMENT = 105,
- OP_SCOMPLEMENT = 106,
- OP_SMARTMATCH = 107,
- OP_ATAN2 = 108,
- OP_SIN = 109,
- OP_COS = 110,
- OP_RAND = 111,
- OP_SRAND = 112,
- OP_EXP = 113,
- OP_LOG = 114,
- OP_SQRT = 115,
- OP_INT = 116,
- OP_HEX = 117,
- OP_OCT = 118,
- OP_ABS = 119,
- OP_LENGTH = 120,
- OP_SUBSTR = 121,
- OP_VEC = 122,
- OP_INDEX = 123,
- OP_RINDEX = 124,
- OP_SPRINTF = 125,
- OP_FORMLINE = 126,
- OP_ORD = 127,
- OP_CHR = 128,
- OP_CRYPT = 129,
- OP_UCFIRST = 130,
- OP_LCFIRST = 131,
- OP_UC = 132,
- OP_LC = 133,
- OP_QUOTEMETA = 134,
- OP_RV2AV = 135,
- OP_AELEMFAST = 136,
- OP_AELEMFAST_LEX = 137,
- OP_AELEM = 138,
- OP_ASLICE = 139,
- OP_KVASLICE = 140,
- OP_AEACH = 141,
- OP_AVALUES = 142,
- OP_AKEYS = 143,
- OP_EACH = 144,
- OP_VALUES = 145,
- OP_KEYS = 146,
- OP_DELETE = 147,
- OP_EXISTS = 148,
- OP_RV2HV = 149,
- OP_HELEM = 150,
- OP_HSLICE = 151,
- OP_KVHSLICE = 152,
- OP_MULTIDEREF = 153,
- OP_UNPACK = 154,
- OP_PACK = 155,
- OP_SPLIT = 156,
- OP_JOIN = 157,
- OP_LIST = 158,
- OP_LSLICE = 159,
- OP_ANONLIST = 160,
- OP_ANONHASH = 161,
- OP_SPLICE = 162,
- OP_PUSH = 163,
- OP_POP = 164,
- OP_SHIFT = 165,
- OP_UNSHIFT = 166,
- OP_SORT = 167,
- OP_REVERSE = 168,
- OP_GREPSTART = 169,
- OP_GREPWHILE = 170,
- OP_MAPSTART = 171,
- OP_MAPWHILE = 172,
- OP_RANGE = 173,
- OP_FLIP = 174,
- OP_FLOP = 175,
- OP_AND = 176,
- OP_OR = 177,
- OP_XOR = 178,
- OP_DOR = 179,
- OP_COND_EXPR = 180,
- OP_ANDASSIGN = 181,
- OP_ORASSIGN = 182,
- OP_DORASSIGN = 183,
- OP_METHOD = 184,
- OP_ENTERSUB = 185,
- OP_LEAVESUB = 186,
- OP_LEAVESUBLV = 187,
- OP_ARGCHECK = 188,
- OP_ARGELEM = 189,
- OP_ARGDEFELEM = 190,
- OP_CALLER = 191,
- OP_WARN = 192,
- OP_DIE = 193,
- OP_RESET = 194,
- OP_LINESEQ = 195,
- OP_NEXTSTATE = 196,
- OP_DBSTATE = 197,
- OP_UNSTACK = 198,
- OP_ENTER = 199,
- OP_LEAVE = 200,
- OP_SCOPE = 201,
- OP_ENTERITER = 202,
- OP_ITER = 203,
- OP_ENTERLOOP = 204,
- OP_LEAVELOOP = 205,
- OP_RETURN = 206,
- OP_LAST = 207,
- OP_NEXT = 208,
- OP_REDO = 209,
- OP_DUMP = 210,
- OP_GOTO = 211,
- OP_EXIT = 212,
- OP_METHOD_NAMED = 213,
- OP_METHOD_SUPER = 214,
- OP_METHOD_REDIR = 215,
- OP_METHOD_REDIR_SUPER = 216,
- OP_ENTERGIVEN = 217,
- OP_LEAVEGIVEN = 218,
- OP_ENTERWHEN = 219,
- OP_LEAVEWHEN = 220,
- OP_BREAK = 221,
- OP_CONTINUE = 222,
- OP_OPEN = 223,
- OP_CLOSE = 224,
- OP_PIPE_OP = 225,
- OP_FILENO = 226,
- OP_UMASK = 227,
- OP_BINMODE = 228,
- OP_TIE = 229,
- OP_UNTIE = 230,
- OP_TIED = 231,
- OP_DBMOPEN = 232,
- OP_DBMCLOSE = 233,
- OP_SSELECT = 234,
- OP_SELECT = 235,
- OP_GETC = 236,
- OP_READ = 237,
- OP_ENTERWRITE = 238,
- OP_LEAVEWRITE = 239,
- OP_PRTF = 240,
- OP_PRINT = 241,
- OP_SAY = 242,
- OP_SYSOPEN = 243,
- OP_SYSSEEK = 244,
- OP_SYSREAD = 245,
- OP_SYSWRITE = 246,
- OP_EOF = 247,
- OP_TELL = 248,
- OP_SEEK = 249,
- OP_TRUNCATE = 250,
- OP_FCNTL = 251,
- OP_IOCTL = 252,
- OP_FLOCK = 253,
- OP_SEND = 254,
- OP_RECV = 255,
- OP_SOCKET = 256,
- OP_SOCKPAIR = 257,
- OP_BIND = 258,
- OP_CONNECT = 259,
- OP_LISTEN = 260,
- OP_ACCEPT = 261,
- OP_SHUTDOWN = 262,
- OP_GSOCKOPT = 263,
- OP_SSOCKOPT = 264,
- OP_GETSOCKNAME = 265,
- OP_GETPEERNAME = 266,
- OP_LSTAT = 267,
- OP_STAT = 268,
- OP_FTRREAD = 269,
- OP_FTRWRITE = 270,
- OP_FTREXEC = 271,
- OP_FTEREAD = 272,
- OP_FTEWRITE = 273,
- OP_FTEEXEC = 274,
- OP_FTIS = 275,
- OP_FTSIZE = 276,
- OP_FTMTIME = 277,
- OP_FTATIME = 278,
- OP_FTCTIME = 279,
- OP_FTROWNED = 280,
- OP_FTEOWNED = 281,
- OP_FTZERO = 282,
- OP_FTSOCK = 283,
- OP_FTCHR = 284,
- OP_FTBLK = 285,
- OP_FTFILE = 286,
- OP_FTDIR = 287,
- OP_FTPIPE = 288,
- OP_FTSUID = 289,
- OP_FTSGID = 290,
- OP_FTSVTX = 291,
- OP_FTLINK = 292,
- OP_FTTTY = 293,
- OP_FTTEXT = 294,
- OP_FTBINARY = 295,
- OP_CHDIR = 296,
- OP_CHOWN = 297,
- OP_CHROOT = 298,
- OP_UNLINK = 299,
- OP_CHMOD = 300,
- OP_UTIME = 301,
- OP_RENAME = 302,
- OP_LINK = 303,
- OP_SYMLINK = 304,
- OP_READLINK = 305,
- OP_MKDIR = 306,
- OP_RMDIR = 307,
- OP_OPEN_DIR = 308,
- OP_READDIR = 309,
- OP_TELLDIR = 310,
- OP_SEEKDIR = 311,
- OP_REWINDDIR = 312,
- OP_CLOSEDIR = 313,
- OP_FORK = 314,
- OP_WAIT = 315,
- OP_WAITPID = 316,
- OP_SYSTEM = 317,
- OP_EXEC = 318,
- OP_KILL = 319,
- OP_GETPPID = 320,
- OP_GETPGRP = 321,
- OP_SETPGRP = 322,
- OP_GETPRIORITY = 323,
- OP_SETPRIORITY = 324,
- OP_TIME = 325,
- OP_TMS = 326,
- OP_LOCALTIME = 327,
- OP_GMTIME = 328,
- OP_ALARM = 329,
- OP_SLEEP = 330,
- OP_SHMGET = 331,
- OP_SHMCTL = 332,
- OP_SHMREAD = 333,
- OP_SHMWRITE = 334,
- OP_MSGGET = 335,
- OP_MSGCTL = 336,
- OP_MSGSND = 337,
- OP_MSGRCV = 338,
- OP_SEMOP = 339,
- OP_SEMGET = 340,
- OP_SEMCTL = 341,
- OP_REQUIRE = 342,
- OP_DOFILE = 343,
- OP_HINTSEVAL = 344,
- OP_ENTEREVAL = 345,
- OP_LEAVEEVAL = 346,
- OP_ENTERTRY = 347,
- OP_LEAVETRY = 348,
- OP_GHBYNAME = 349,
- OP_GHBYADDR = 350,
- OP_GHOSTENT = 351,
- OP_GNBYNAME = 352,
- OP_GNBYADDR = 353,
- OP_GNETENT = 354,
- OP_GPBYNAME = 355,
- OP_GPBYNUMBER = 356,
- OP_GPROTOENT = 357,
- OP_GSBYNAME = 358,
- OP_GSBYPORT = 359,
- OP_GSERVENT = 360,
- OP_SHOSTENT = 361,
- OP_SNETENT = 362,
- OP_SPROTOENT = 363,
- OP_SSERVENT = 364,
- OP_EHOSTENT = 365,
- OP_ENETENT = 366,
- OP_EPROTOENT = 367,
- OP_ESERVENT = 368,
- OP_GPWNAM = 369,
- OP_GPWUID = 370,
- OP_GPWENT = 371,
- OP_SPWENT = 372,
- OP_EPWENT = 373,
- OP_GGRNAM = 374,
- OP_GGRGID = 375,
- OP_GGRENT = 376,
- OP_SGRENT = 377,
- OP_EGRENT = 378,
- OP_GETLOGIN = 379,
- OP_SYSCALL = 380,
- OP_LOCK = 381,
- OP_ONCE = 382,
- OP_CUSTOM = 383,
- OP_COREARGS = 384,
- OP_AVHVSWITCH = 385,
- OP_RUNCV = 386,
- OP_FC = 387,
- OP_PADCV = 388,
- OP_INTROCV = 389,
- OP_CLONECV = 390,
- OP_PADRANGE = 391,
- OP_REFASSIGN = 392,
- OP_LVREF = 393,
- OP_LVREFSLICE = 394,
- OP_LVAVREF = 395,
- OP_ANONCONST = 396,
+ OP_RV2GV = 13,
+ OP_RV2SV = 14,
+ OP_AV2ARYLEN = 15,
+ OP_RV2CV = 16,
+ OP_ANONCODE = 17,
+ OP_PROTOTYPE = 18,
+ OP_REFGEN = 19,
+ OP_SREFGEN = 20,
+ OP_REF = 21,
+ OP_BLESS = 22,
+ OP_BACKTICK = 23,
+ OP_GLOB = 24,
+ OP_READLINE = 25,
+ OP_RCATLINE = 26,
+ OP_REGCMAYBE = 27,
+ OP_REGCRESET = 28,
+ OP_REGCOMP = 29,
+ OP_MATCH = 30,
+ OP_QR = 31,
+ OP_SUBST = 32,
+ OP_SUBSTCONT = 33,
+ OP_TRANS = 34,
+ OP_TRANSR = 35,
+ OP_SASSIGN = 36,
+ OP_AASSIGN = 37,
+ OP_CHOP = 38,
+ OP_SCHOP = 39,
+ OP_CHOMP = 40,
+ OP_SCHOMP = 41,
+ OP_DEFINED = 42,
+ OP_UNDEF = 43,
+ OP_STUDY = 44,
+ OP_POS = 45,
+ OP_PREINC = 46,
+ OP_I_PREINC = 47,
+ OP_PREDEC = 48,
+ OP_I_PREDEC = 49,
+ OP_POSTINC = 50,
+ OP_I_POSTINC = 51,
+ OP_POSTDEC = 52,
+ OP_I_POSTDEC = 53,
+ OP_POW = 54,
+ OP_MULTIPLY = 55,
+ OP_I_MULTIPLY = 56,
+ OP_DIVIDE = 57,
+ OP_I_DIVIDE = 58,
+ OP_MODULO = 59,
+ OP_I_MODULO = 60,
+ OP_REPEAT = 61,
+ OP_ADD = 62,
+ OP_I_ADD = 63,
+ OP_SUBTRACT = 64,
+ OP_I_SUBTRACT = 65,
+ OP_CONCAT = 66,
+ OP_STRINGIFY = 67,
+ OP_LEFT_SHIFT = 68,
+ OP_RIGHT_SHIFT = 69,
+ OP_LT = 70,
+ OP_I_LT = 71,
+ OP_GT = 72,
+ OP_I_GT = 73,
+ OP_LE = 74,
+ OP_I_LE = 75,
+ OP_GE = 76,
+ OP_I_GE = 77,
+ OP_EQ = 78,
+ OP_I_EQ = 79,
+ OP_NE = 80,
+ OP_I_NE = 81,
+ OP_NCMP = 82,
+ OP_I_NCMP = 83,
+ OP_SLT = 84,
+ OP_SGT = 85,
+ OP_SLE = 86,
+ OP_SGE = 87,
+ OP_SEQ = 88,
+ OP_SNE = 89,
+ OP_SCMP = 90,
+ OP_BIT_AND = 91,
+ OP_BIT_XOR = 92,
+ OP_BIT_OR = 93,
+ OP_NBIT_AND = 94,
+ OP_NBIT_XOR = 95,
+ OP_NBIT_OR = 96,
+ OP_SBIT_AND = 97,
+ OP_SBIT_XOR = 98,
+ OP_SBIT_OR = 99,
+ OP_NEGATE = 100,
+ OP_I_NEGATE = 101,
+ OP_NOT = 102,
+ OP_COMPLEMENT = 103,
+ OP_NCOMPLEMENT = 104,
+ OP_SCOMPLEMENT = 105,
+ OP_SMARTMATCH = 106,
+ OP_ATAN2 = 107,
+ OP_SIN = 108,
+ OP_COS = 109,
+ OP_RAND = 110,
+ OP_SRAND = 111,
+ OP_EXP = 112,
+ OP_LOG = 113,
+ OP_SQRT = 114,
+ OP_INT = 115,
+ OP_HEX = 116,
+ OP_OCT = 117,
+ OP_ABS = 118,
+ OP_LENGTH = 119,
+ OP_SUBSTR = 120,
+ OP_VEC = 121,
+ OP_INDEX = 122,
+ OP_RINDEX = 123,
+ OP_SPRINTF = 124,
+ OP_FORMLINE = 125,
+ OP_ORD = 126,
+ OP_CHR = 127,
+ OP_CRYPT = 128,
+ OP_UCFIRST = 129,
+ OP_LCFIRST = 130,
+ OP_UC = 131,
+ OP_LC = 132,
+ OP_QUOTEMETA = 133,
+ OP_RV2AV = 134,
+ OP_AELEMFAST = 135,
+ OP_AELEMFAST_LEX = 136,
+ OP_AELEM = 137,
+ OP_ASLICE = 138,
+ OP_KVASLICE = 139,
+ OP_AEACH = 140,
+ OP_AVALUES = 141,
+ OP_AKEYS = 142,
+ OP_EACH = 143,
+ OP_VALUES = 144,
+ OP_KEYS = 145,
+ OP_DELETE = 146,
+ OP_EXISTS = 147,
+ OP_RV2HV = 148,
+ OP_HELEM = 149,
+ OP_HSLICE = 150,
+ OP_KVHSLICE = 151,
+ OP_MULTIDEREF = 152,
+ OP_UNPACK = 153,
+ OP_PACK = 154,
+ OP_SPLIT = 155,
+ OP_JOIN = 156,
+ OP_LIST = 157,
+ OP_LSLICE = 158,
+ OP_ANONLIST = 159,
+ OP_ANONHASH = 160,
+ OP_SPLICE = 161,
+ OP_PUSH = 162,
+ OP_POP = 163,
+ OP_SHIFT = 164,
+ OP_UNSHIFT = 165,
+ OP_SORT = 166,
+ OP_REVERSE = 167,
+ OP_GREPSTART = 168,
+ OP_GREPWHILE = 169,
+ OP_MAPSTART = 170,
+ OP_MAPWHILE = 171,
+ OP_RANGE = 172,
+ OP_FLIP = 173,
+ OP_FLOP = 174,
+ OP_AND = 175,
+ OP_OR = 176,
+ OP_XOR = 177,
+ OP_DOR = 178,
+ OP_COND_EXPR = 179,
+ OP_ANDASSIGN = 180,
+ OP_ORASSIGN = 181,
+ OP_DORASSIGN = 182,
+ OP_METHOD = 183,
+ OP_ENTERSUB = 184,
+ OP_LEAVESUB = 185,
+ OP_LEAVESUBLV = 186,
+ OP_ARGCHECK = 187,
+ OP_ARGELEM = 188,
+ OP_ARGDEFELEM = 189,
+ OP_CALLER = 190,
+ OP_WARN = 191,
+ OP_DIE = 192,
+ OP_RESET = 193,
+ OP_LINESEQ = 194,
+ OP_NEXTSTATE = 195,
+ OP_DBSTATE = 196,
+ OP_UNSTACK = 197,
+ OP_ENTER = 198,
+ OP_LEAVE = 199,
+ OP_SCOPE = 200,
+ OP_ENTERITER = 201,
+ OP_ITER = 202,
+ OP_ENTERLOOP = 203,
+ OP_LEAVELOOP = 204,
+ OP_RETURN = 205,
+ OP_LAST = 206,
+ OP_NEXT = 207,
+ OP_REDO = 208,
+ OP_DUMP = 209,
+ OP_GOTO = 210,
+ OP_EXIT = 211,
+ OP_METHOD_NAMED = 212,
+ OP_METHOD_SUPER = 213,
+ OP_METHOD_REDIR = 214,
+ OP_METHOD_REDIR_SUPER = 215,
+ OP_ENTERGIVEN = 216,
+ OP_LEAVEGIVEN = 217,
+ OP_ENTERWHEN = 218,
+ OP_LEAVEWHEN = 219,
+ OP_BREAK = 220,
+ OP_CONTINUE = 221,
+ OP_OPEN = 222,
+ OP_CLOSE = 223,
+ OP_PIPE_OP = 224,
+ OP_FILENO = 225,
+ OP_UMASK = 226,
+ OP_BINMODE = 227,
+ OP_TIE = 228,
+ OP_UNTIE = 229,
+ OP_TIED = 230,
+ OP_DBMOPEN = 231,
+ OP_DBMCLOSE = 232,
+ OP_SSELECT = 233,
+ OP_SELECT = 234,
+ OP_GETC = 235,
+ OP_READ = 236,
+ OP_ENTERWRITE = 237,
+ OP_LEAVEWRITE = 238,
+ OP_PRTF = 239,
+ OP_PRINT = 240,
+ OP_SAY = 241,
+ OP_SYSOPEN = 242,
+ OP_SYSSEEK = 243,
+ OP_SYSREAD = 244,
+ OP_SYSWRITE = 245,
+ OP_EOF = 246,
+ OP_TELL = 247,
+ OP_SEEK = 248,
+ OP_TRUNCATE = 249,
+ OP_FCNTL = 250,
+ OP_IOCTL = 251,
+ OP_FLOCK = 252,
+ OP_SEND = 253,
+ OP_RECV = 254,
+ OP_SOCKET = 255,
+ OP_SOCKPAIR = 256,
+ OP_BIND = 257,
+ OP_CONNECT = 258,
+ OP_LISTEN = 259,
+ OP_ACCEPT = 260,
+ OP_SHUTDOWN = 261,
+ OP_GSOCKOPT = 262,
+ OP_SSOCKOPT = 263,
+ OP_GETSOCKNAME = 264,
+ OP_GETPEERNAME = 265,
+ OP_LSTAT = 266,
+ OP_STAT = 267,
+ OP_FTRREAD = 268,
+ OP_FTRWRITE = 269,
+ OP_FTREXEC = 270,
+ OP_FTEREAD = 271,
+ OP_FTEWRITE = 272,
+ OP_FTEEXEC = 273,
+ OP_FTIS = 274,
+ OP_FTSIZE = 275,
+ OP_FTMTIME = 276,
+ OP_FTATIME = 277,
+ OP_FTCTIME = 278,
+ OP_FTROWNED = 279,
+ OP_FTEOWNED = 280,
+ OP_FTZERO = 281,
+ OP_FTSOCK = 282,
+ OP_FTCHR = 283,
+ OP_FTBLK = 284,
+ OP_FTFILE = 285,
+ OP_FTDIR = 286,
+ OP_FTPIPE = 287,
+ OP_FTSUID = 288,
+ OP_FTSGID = 289,
+ OP_FTSVTX = 290,
+ OP_FTLINK = 291,
+ OP_FTTTY = 292,
+ OP_FTTEXT = 293,
+ OP_FTBINARY = 294,
+ OP_CHDIR = 295,
+ OP_CHOWN = 296,
+ OP_CHROOT = 297,
+ OP_UNLINK = 298,
+ OP_CHMOD = 299,
+ OP_UTIME = 300,
+ OP_RENAME = 301,
+ OP_LINK = 302,
+ OP_SYMLINK = 303,
+ OP_READLINK = 304,
+ OP_MKDIR = 305,
+ OP_RMDIR = 306,
+ OP_OPEN_DIR = 307,
+ OP_READDIR = 308,
+ OP_TELLDIR = 309,
+ OP_SEEKDIR = 310,
+ OP_REWINDDIR = 311,
+ OP_CLOSEDIR = 312,
+ OP_FORK = 313,
+ OP_WAIT = 314,
+ OP_WAITPID = 315,
+ OP_SYSTEM = 316,
+ OP_EXEC = 317,
+ OP_KILL = 318,
+ OP_GETPPID = 319,
+ OP_GETPGRP = 320,
+ OP_SETPGRP = 321,
+ OP_GETPRIORITY = 322,
+ OP_SETPRIORITY = 323,
+ OP_TIME = 324,
+ OP_TMS = 325,
+ OP_LOCALTIME = 326,
+ OP_GMTIME = 327,
+ OP_ALARM = 328,
+ OP_SLEEP = 329,
+ OP_SHMGET = 330,
+ OP_SHMCTL = 331,
+ OP_SHMREAD = 332,
+ OP_SHMWRITE = 333,
+ OP_MSGGET = 334,
+ OP_MSGCTL = 335,
+ OP_MSGSND = 336,
+ OP_MSGRCV = 337,
+ OP_SEMOP = 338,
+ OP_SEMGET = 339,
+ OP_SEMCTL = 340,
+ OP_REQUIRE = 341,
+ OP_DOFILE = 342,
+ OP_HINTSEVAL = 343,
+ OP_ENTEREVAL = 344,
+ OP_LEAVEEVAL = 345,
+ OP_ENTERTRY = 346,
+ OP_LEAVETRY = 347,
+ OP_GHBYNAME = 348,
+ OP_GHBYADDR = 349,
+ OP_GHOSTENT = 350,
+ OP_GNBYNAME = 351,
+ OP_GNBYADDR = 352,
+ OP_GNETENT = 353,
+ OP_GPBYNAME = 354,
+ OP_GPBYNUMBER = 355,
+ OP_GPROTOENT = 356,
+ OP_GSBYNAME = 357,
+ OP_GSBYPORT = 358,
+ OP_GSERVENT = 359,
+ OP_SHOSTENT = 360,
+ OP_SNETENT = 361,
+ OP_SPROTOENT = 362,
+ OP_SSERVENT = 363,
+ OP_EHOSTENT = 364,
+ OP_ENETENT = 365,
+ OP_EPROTOENT = 366,
+ OP_ESERVENT = 367,
+ OP_GPWNAM = 368,
+ OP_GPWUID = 369,
+ OP_GPWENT = 370,
+ OP_SPWENT = 371,
+ OP_EPWENT = 372,
+ OP_GGRNAM = 373,
+ OP_GGRGID = 374,
+ OP_GGRENT = 375,
+ OP_SGRENT = 376,
+ OP_EGRENT = 377,
+ OP_GETLOGIN = 378,
+ OP_SYSCALL = 379,
+ OP_LOCK = 380,
+ OP_ONCE = 381,
+ OP_CUSTOM = 382,
+ OP_COREARGS = 383,
+ OP_AVHVSWITCH = 384,
+ OP_RUNCV = 385,
+ OP_FC = 386,
+ OP_PADCV = 387,
+ OP_INTROCV = 388,
+ OP_CLONECV = 389,
+ OP_PADRANGE = 390,
+ OP_REFASSIGN = 391,
+ OP_LVREF = 392,
+ OP_LVREFSLICE = 393,
+ OP_LVAVREF = 394,
+ OP_ANONCONST = 395,
OP_max
} opcode;
-#define MAXO 397
+#define MAXO 396
#define OP_FREED MAXO
/* the OP_IS_* macros are optimized to a simple range check because
package OS2::DLL;
-our $VERSION = '1.06';
+our $VERSION = '1.07';
use Carp;
use XSLoader;
if (result.strptr)
sv_setpvn(ST(0), result.strptr, result.strlength);
else
- sv_setpvn(ST(0), "", 0);
+ SvPVCLEAR(ST(0));
}
if (result.strptr && result.strptr != resbuf)
DosFreeMem(result.strptr);
if (buf[1] == '!')
s = buf + 2;
} else if (buf[0] == 'e') {
- if (strnEQ(buf, "extproc", 7)
+ if (strEQs(buf, "extproc")
&& isSPACE(buf[7]))
s = buf + 8;
} else if (buf[0] == 'E') {
- if (strnEQ(buf, "EXTPROC", 7)
+ if (strEQs(buf, "EXTPROC")
&& isSPACE(buf[7]))
s = buf + 8;
}
while (*cmd && isSPACE(*cmd))
cmd++;
- if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
+ if (strEQs(cmd,"/bin/sh") && isSPACE(cmd[7])) {
STRLEN l = strlen(PL_sh_path);
Newx(news, strlen(cmd) - 7 + l + 1, char);
if (*cmd == '.' && isSPACE(cmd[1]))
goto doshell;
- if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
+ if (strEQs(cmd,"exec") && isSPACE(cmd[4]))
goto doshell;
for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
if (DOS_suppression_state > 0)
sv_setpvn(ST(0), &DOS_suppression_state, 1);
else if (DOS_suppression_state == 0)
- sv_setpvn(ST(0), "", 0);
+ SvPVCLEAR(ST(0));
DOS_suppression_state = drive;
}
XSRETURN(1);
if (!pszName || !*pszName)
Perl_croak(aTHX_ "OS2::pipe(): empty pipe name");
s = SvPV(OpenMode, len);
- if (len == 4 && strEQ(s, "wait")) { /* DosWaitNPipe() */
+ if (memEQs(s, len, "wait")) { /* DosWaitNPipe() */
ULONG ms = 0xFFFFFFFF, ret = ERROR_INTERRUPT; /* Indefinite */
if (items == 3) {
os2cp_croak(ret, "DosWaitNPipe()");
XSRETURN_YES;
}
- if (len == 4 && strEQ(s, "call")) { /* DosCallNPipe() */
+ if (memEQs(s, len, "call")) { /* DosCallNPipe() */
ULONG ms = 0xFFFFFFFF, got; /* Indefinite */
STRLEN l;
char *s;
connect = -1; /* no wait */
else if (SvTRUE(ST(2))) {
s = SvPV(ST(2), len);
- if (len == 6 && strEQ(s, "nowait"))
+ if (memEQs(s, len, "nowait"))
connect = -1; /* no wait */
- else if (len == 4 && strEQ(s, "wait"))
+ else if (memEQs(s, len, "wait"))
connect = 1; /* wait */
else
Perl_croak(aTHX_ "OS2::pipe(): unknown connect argument: `%s'", s);
* [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
*/
-/* XXX DAPM
- * As of Sept 2002, this file is new and may be in a state of flux for
- * a while. I've marked things I intent to come back and look at further
- * with an 'XXX DAPM' comment.
- */
-
/*
=head1 Pad Data Structures
PERL_PADSEQ_INTRO 0 variable not yet introduced:
{ my ($x
valid-seq# PERL_PADSEQ_INTRO variable in scope:
- { my ($x)
+ { my ($x);
valid-seq# valid-seq# compilation of scope complete:
- { my ($x) }
+ { my ($x); .... }
+
+When a lexical var hasn't yet been introduced, it already exists from the
+perspective of duplicate declarations, but not for variable lookups, e.g.
+
+ my ($x, $x); # '"my" variable $x masks earlier declaration'
+ my $x = $x; # equal to my $x = $::x;
For typed lexicals C<PadnameTYPE> points at the type stash. For C<our>
lexicals, C<PadnameOURSTASH> points at the stash of the associated global (so
ASSERT_CURPAD_LEGAL("pad_new");
- /* XXX DAPM really need a new SAVEt_PAD which restores all or most
- * vars (based on flags) rather than storing vals + addresses for
- * each individually. Also see pad_block_start.
- * XXX DAPM Try to see whether all these conditionals are required
- */
-
/* save existing state, ... */
if (flags & padnew_SAVE) {
SAVECOMPPAD();
if (! (flags & padnew_CLONE)) {
SAVESPTR(PL_comppad_name);
- SAVEI32(PL_padix);
- SAVEI32(PL_constpadix);
- SAVEI32(PL_comppad_name_fill);
- SAVEI32(PL_min_intro_pending);
- SAVEI32(PL_max_intro_pending);
+ save_strlen((STRLEN *)&PL_padix);
+ save_strlen((STRLEN *)&PL_constpadix);
+ save_strlen((STRLEN *)&PL_comppad_name_fill);
+ save_strlen((STRLEN *)&PL_min_intro_pending);
+ save_strlen((STRLEN *)&PL_max_intro_pending);
SAVEBOOL(PL_cv_has_eval);
if (flags & padnew_SAVESUB) {
SAVEBOOL(PL_pad_reset_pending);
}
}
}
- /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
- * saved - check at some pt that this is okay */
/* ... create new pad ... */
pad = newAV();
if (flags & padnew_CLONE) {
- /* XXX DAPM I dont know why cv_clone needs it
- * doing differently yet - perhaps this separate branch can be
- * dispensed with eventually ???
- */
-
AV * const a0 = newAV(); /* will be @_ */
av_store(pad, 0, MUTABLE_SV(a0));
AvREIFY_only(a0);
pad_peg("pad_undef");
if (!CvISXSUB(&cvbody) && CvPADLIST(&cvbody)) {
- I32 ix;
+ PADOFFSET ix;
const PADLIST *padlist = CvPADLIST(&cvbody);
/* Free the padlist associated with a CV.
/* detach any '&' anon children in the pad; if afterwards they
* are still live, fix up their CvOUTSIDEs to point to our outside,
* bypassing us. */
- /* XXX DAPM for efficiency, we should only do this if we know we have
- * children, or integrate this loop with general cleanup */
if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
CV * const outercv = CvOUTSIDE(&cvbody);
=cut
*/
-/* XXX DAPM integrate alloc(), add_name() and add_anon(),
- * or at least rationalise ??? */
-
PADOFFSET
Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
{
SV *sv;
- I32 retval;
+ PADOFFSET retval;
PERL_UNUSED_ARG(optype);
ASSERT_CURPAD_ACTIVE("pad_alloc");
if (tmptype == SVs_PADMY) { /* Not & because this ‘flag’ is 0. */
/* For a my, simply push a null SV onto the end of PL_comppad. */
sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
- retval = AvFILLp(PL_comppad);
+ retval = (PADOFFSET)AvFILLp(PL_comppad);
}
else {
/* For a tmp, scan the pad from PL_padix upwards
sv = *av_fetch(PL_comppad, retval, TRUE);
if (!(SvFLAGS(sv) &
#ifdef USE_PAD_RESET
- (konst ? SVs_PADTMP : 0))
+ (konst ? SVs_PADTMP : 0)
#else
SVs_PADTMP
#endif
sv->sv_debug_optype = optype;
sv->sv_debug_inpad = 1;
#endif
- return (PADOFFSET)retval;
+ return retval;
}
/*
assert(COP_SEQ_RANGE_HIGH(name) != PERL_PADSEQ_INTRO);
ix = pad_alloc(optype, SVs_PADMY);
padnamelist_store(PL_comppad_name, ix, name);
- /* XXX DAPM use PL_curpad[] ? */
av_store(PL_comppad, ix, (SV*)func);
/* to avoid ref loops, we never have parent + child referencing each
svp = PadnamelistARRAY(PL_comppad_name);
top = PadnamelistMAX(PL_comppad_name);
/* check the current scope */
- /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
- * type ? */
- for (off = top; (I32)off > PL_comppad_name_floor; off--) {
+ for (off = top; off > PL_comppad_name_floor; off--) {
PADNAME * const sv = svp[off];
if (sv
&& PadnameLEN(sv) == PadnameLEN(name)
{
Perl_warner(aTHX_ packWARN(WARN_MISC),
"\"our\" variable %"PNf" redeclared", PNfARG(sv));
- if ((I32)off <= PL_comppad_name_floor)
+ if (off <= PL_comppad_name_floor)
Perl_warner(aTHX_ packWARN(WARN_MISC),
"\t(Did you mean \"local\" instead of \"our\"?)\n");
break;
{
PADNAME *out_pn;
int out_flags;
- I32 offset;
+ PADOFFSET offset;
const PADNAMELIST *namelist;
PADNAME **name_p;
offset = pad_findlex(namepv, namelen, flags,
PL_compcv, PL_cop_seqmax, 1, NULL, &out_pn, &out_flags);
- if ((PADOFFSET)offset != NOT_IN_PAD)
+ if (offset != NOT_IN_PAD)
return offset;
/* Skip the ‘our’ hack for subroutines, as the warning does not apply.
Note that C<pad_findlex()> is recursive; it recurses up the chain of CVs,
then comes back down, adding fake entries
as it goes. It has to be this way
-because fake names in anon protoypes have to store in C<xlow> the index into
-the parent pad.
+because fake names in anon protoypes have to store in C<xpadn_low> the
+index into the parent pad.
=cut
*/
S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
int warn, SV** out_capture, PADNAME** out_name, int *out_flags)
{
- I32 offset, new_offset;
+ PADOFFSET offset, new_offset;
SV *new_capture;
SV **new_capturep;
const PADLIST * const padlist = CvPADLIST(cv);
/* first, search this pad */
if (padlist) { /* not an undef CV */
- I32 fake_offset = 0;
+ PADOFFSET fake_offset = 0;
const PADNAMELIST * const names = PadlistNAMES(padlist);
PADNAME * const * const name_p = PadnamelistARRAY(names);
flags | padadd_STALEOK*(new_capturep == &new_capture),
CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
new_capturep, out_name, out_flags);
- if ((PADOFFSET)offset == NOT_IN_PAD)
+ if (offset == NOT_IN_PAD)
return NOT_IN_PAD;
/* found in an outer CV. Add appropriate fake entry to this pad */
=cut
*/
-/* XXX DAPM perhaps:
- * - integrate this in general state-saving routine ???
- * - combine with the state-saving going on in pad_new ???
- * - introduce a new SAVE type that does all this in one go ?
- */
-
void
Perl_pad_block_start(pTHX_ int full)
{
ASSERT_CURPAD_ACTIVE("pad_block_start");
- SAVEI32(PL_comppad_name_floor);
+ save_strlen((STRLEN *)&PL_comppad_name_floor);
PL_comppad_name_floor = PadnamelistMAX(PL_comppad_name);
if (full)
PL_comppad_name_fill = PL_comppad_name_floor;
if (PL_comppad_name_floor < 0)
PL_comppad_name_floor = 0;
- SAVEI32(PL_min_intro_pending);
- SAVEI32(PL_max_intro_pending);
+ save_strlen((STRLEN *)&PL_min_intro_pending);
+ save_strlen((STRLEN *)&PL_max_intro_pending);
PL_min_intro_pending = 0;
- SAVEI32(PL_comppad_name_fill);
- SAVEI32(PL_padix_floor);
+ save_strlen((STRLEN *)&PL_comppad_name_fill);
+ save_strlen((STRLEN *)&PL_padix_floor);
/* PL_padix_floor is what PL_padix is reset to at the start of each
statement, by pad_reset(). We set it when entering a new scope
to keep things like this working:
Perl_intro_my(pTHX)
{
PADNAME **svp;
- I32 i;
+ PADOFFSET i;
U32 seq;
ASSERT_CURPAD_ACTIVE("intro_my");
OP *
Perl_pad_leavemy(pTHX)
{
- I32 off;
+ PADOFFSET off;
OP *o = NULL;
PADNAME * const * const svp = PadnamelistARRAY(PL_comppad_name);
/* Use PL_constpadix here, not PL_padix. The latter may have been
reset by pad_reset. We don’t want pad_alloc to have to scan the
whole pad when allocating a constant. */
- if ((I32)po < PL_constpadix)
+ if (po < PL_constpadix)
PL_constpadix = po - 1;
}
=cut
*/
-/* XXX DAPM surely most of this stuff should be done properly
- * at the right time beforehand, rather than going around afterwards
- * cleaning up our mistakes ???
- */
-
void
Perl_pad_tidy(pTHX_ padtidy_type type)
{
}
}
else if (type == padtidy_SUB) {
- /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
AV * const av = newAV(); /* Will be @_ */
av_store(PL_comppad, 0, MUTABLE_SV(av));
AvREIFY_only(av);
=cut
*/
-/* XXX DAPM integrate with pad_swipe ???? */
void
Perl_pad_free(pTHX_ PADOFFSET po)
{
if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
SvFLAGS(sv) &= ~SVs_PADTMP;
- if ((I32)po < PL_padix)
+ if (po < PL_padix)
PL_padix = po - 1;
#endif
}
const AV *pad;
PADNAME **pname;
SV **ppad;
- I32 ix;
+ PADOFFSET ix;
PERL_ARGS_ASSERT_DO_DUMP_PAD;
S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned,
bool newcv)
{
- I32 ix;
+ PADOFFSET ix;
PADLIST* const protopadlist = CvPADLIST(proto);
PADNAMELIST *const protopad_name = PadlistNAMES(protopadlist);
const PAD *const protopad = PadlistARRAY(protopadlist)[1];
PADNAME** const pname = PadnamelistARRAY(protopad_name);
SV** const ppad = AvARRAY(protopad);
- const I32 fname = PadnamelistMAX(protopad_name);
- const I32 fpad = AvFILLp(protopad);
+ const PADOFFSET fname = PadnamelistMAX(protopad_name);
+ const PADOFFSET fpad = AvFILLp(protopad);
SV** outpad;
long depth;
U32 subclones = 0;
void
Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
{
- I32 ix;
+ PADOFFSET ix;
PADNAMELIST * const comppad_name = PadlistNAMES(padlist);
AV * const comppad = PadlistARRAY(padlist)[1];
PADNAME ** const namepad = PadnamelistARRAY(comppad_name);
PAD** const svp = PadlistARRAY(padlist);
AV* const newpad = newAV();
SV** const oldpad = AvARRAY(svp[depth-1]);
- I32 ix = AvFILLp((const AV *)svp[1]);
- const I32 names_fill = PadnamelistMAX((PADNAMELIST *)svp[0]);
+ PADOFFSET ix = AvFILLp((const AV *)svp[1]);
+ const PADOFFSET names_fill = PadnamelistMAX((PADNAMELIST *)svp[0]);
PADNAME ** const names = PadnamelistARRAY((PADNAMELIST *)svp[0]);
AV *av;
} else {
/* CvDEPTH() on our subroutine will be set to 0, so there's no need
to build anything other than the first level of pads. */
- I32 ix = AvFILLp(PadlistARRAY(srcpad)[1]);
+ PADOFFSET ix = AvFILLp(PadlistARRAY(srcpad)[1]);
AV *pad1;
- const I32 names_fill = PadnamelistMAX(PadlistNAMES(srcpad));
+ const PADOFFSET names_fill = PadnamelistMAX(PadlistNAMES(srcpad));
const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
SV **oldpad = AvARRAY(srcpad1);
PADNAME ** const names = PadnamelistARRAY(PadlistNAMES(dstpad));
/* offsets within a pad */
-#if PTRSIZE == 4
-typedef U32TYPE PADOFFSET;
-#else
-# if PTRSIZE == 8
-typedef U64TYPE PADOFFSET;
-# endif
-#endif
+typedef SSize_t PADOFFSET; /* signed so that -1 is a valid value */
#define NOT_IN_PAD ((PADOFFSET) -1)
/* B.xs expects the first members of these two structs to line up
#define PERL_REVISION 5 /* age */
#define PERL_VERSION 25 /* epoch */
-#define PERL_SUBVERSION 5 /* generation */
+#define PERL_SUBVERSION 6 /* generation */
/* The following numbers describe the earliest compatible version of
Perl ("compatibility" here being defined as sufficient binary/API
*/
#define PERL_API_REVISION 5
#define PERL_API_VERSION 25
-#define PERL_API_SUBVERSION 5
+#define PERL_API_SUBVERSION 6
/*
XXX Note: The selection of non-default Configure options, such
as -Duselonglong may invalidate these settings. Currently, Configure
PL_fdpid = newAV(); /* for remembering popen pids by fd */
PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
PL_errors = newSVpvs("");
- sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */
- sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */
- sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */
+ SvPVCLEAR(PERL_DEBUG_PAD(0)); /* For regex debugging. */
+ SvPVCLEAR(PERL_DEBUG_PAD(1)); /* ext/re needs these */
+ SvPVCLEAR(PERL_DEBUG_PAD(2)); /* even without DEBUGGING. */
#ifdef USE_ITHREADS
/* First entry is a list of empty elements. It needs to be initialised
else all hell breaks loose in S_find_uninit_var(). */
hv = PL_defstash;
/* break ref loop *:: <=> %:: */
- (void)hv_delete(hv, "main::", 6, G_DISCARD);
+ (void)hv_deletes(hv, "main::", G_DISCARD);
PL_defstash = 0;
SvREFCNT_dec(hv);
SvREFCNT_dec(PL_curstname);
PL_inplace = savepvn(start, s - start);
}
- if (*s) {
- ++s;
- if (*s == '-') /* Additional switches on #! line. */
- s++;
- }
return s;
case 'I': /* -I handled both here and in parse_body() */
forbid_setid('I', FALSE);
because otherwise all we do is delete "main" from it as a consequence
of the SvREFCNT_dec, only to add it again with hv_name_set */
SvREFCNT_dec(GvHV(gv));
- hv_name_set(PL_defstash, "main", 4, 0);
+ hv_name_sets(PL_defstash, "main", 0);
GvHV(gv) = MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
SvREADONLY_on(gv);
PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
/* if find_script() returns, it returns a malloc()-ed value */
scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
- if (strnEQ(scriptname, "/dev/fd/", 8)
+ if (strEQs(scriptname, "/dev/fd/")
&& isDIGIT(scriptname[8])
&& grok_atoUV(scriptname + 8, &uv, &s)
&& uv <= PERL_INT_MAX
if (*s++ == '-') {
while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
|| s2[-1] == '_') s2--;
- if (strnEQ(s2-4,"perl",4))
+ if (strEQs(s2-4,"perl"))
while ((s = moreswitches(s)))
;
}
PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
PL_toptarget = newSV_type(SVt_PVIV);
- sv_setpvs(PL_toptarget, "");
+ SvPVCLEAR(PL_toptarget);
PL_bodytarget = newSV_type(SVt_PVIV);
- sv_setpvs(PL_bodytarget, "");
+ SvPVCLEAR(PL_bodytarget);
PL_formtarget = PL_bodytarget;
TAINT;
if (lastslash) {
SV *tempsv;
while ((*lastslash = '\0'), /* Do that, come what may. */
- (libpath_len >= 3 && memEQ(libpath, "../", 3)
+ (libpath_len >= 3 && _memEQs(libpath, "../")
&& (lastslash = strrchr(prefix, '/')))) {
if (lastslash[1] == '\0'
|| (lastslash[1] == '.'
#ifndef H_PERL
#define H_PERL 1
+/* this is used for functions which take a depth trailing
+ * argument under debugging */
+#ifdef DEBUGGING
+#define _pDEPTH ,U32 depth
+#define _aDEPTH ,depth
+#else
+#define _pDEPTH
+#define _aDEPTH
+#endif
+
#ifdef PERL_FOR_X2P
/*
* This file is being used for x2p stuff.
*svp = newSVpvs(""); \
} else { \
SV *const errsv = *svp; \
- sv_setpvs(errsv, ""); \
+ SvPVCLEAR(errsv); \
SvPOK_only(errsv); \
if (SvMAGICAL(errsv)) { \
mg_free(errsv); \
/* In C99 we could use designated (named field) union initializers.
* In C89 we need to initialize the member declared first.
+ * In C++ we need extern C initializers.
*
* With the U8_NV version you will want to have inner braces,
- * while with the NV_U8 use just the NV.*/
-#define INFNAN_U8_NV_DECL EXTCONST union { U8 u8[NVSIZE]; NV nv; }
-#define INFNAN_NV_U8_DECL EXTCONST union { NV nv; U8 u8[NVSIZE]; }
-
-#ifdef DOINIT
-
-/* PL_inf and PL_nan initialization.
- *
- * For inf and nan initialization the ultimate fallback is dividing
- * one or zero by zero: however, some compilers will warn or even fail
- * on divide-by-zero, but hopefully something earlier will work.
- *
- * If you are thinking of using HUGE_VAL for infinity, or using
- * <math.h> functions to generate NV_INF (e.g. exp(1e9), log(-1.0)),
- * stop. Neither will work portably: HUGE_VAL can be just DBL_MAX,
- * and the math functions might be just generating DBL_MAX, or even zero.
- *
- * Also, do NOT try doing NV_NAN based on NV_INF and trying (NV_INF-NV_INF).
- * Though logically correct, some compilers (like Visual C 2003)
- * falsely misoptimize that to zero (x-x is always zero, right?)
- *
- * Finally, note that not all floating point formats define Inf (or NaN).
- * For the infinity a large number may be used instead. Operations that
- * under the IEEE floating point would return Inf or NaN may return
- * either large numbers (positive or negative), or they may cause
- * a floating point exception or some other fault.
- */
-
-/* The quadmath literals are anon structs which -Wc++-compat doesn't like. */
-GCC_DIAG_IGNORE(-Wc++-compat)
-
-# ifdef USE_QUADMATH
-/* Cannot use HUGE_VALQ for PL_inf because not a compile-time
- * constant. */
-INFNAN_NV_U8_DECL PL_inf = { 1.0Q/0.0Q };
-# elif NVSIZE == LONG_DOUBLESIZE && defined(LONGDBLINFBYTES)
-INFNAN_U8_NV_DECL PL_inf = { { LONGDBLINFBYTES } };
-# elif NVSIZE == DOUBLESIZE && defined(DOUBLEINFBYTES)
-INFNAN_U8_NV_DECL PL_inf = { { DOUBLEINFBYTES } };
-# else
-# if NVSIZE == LONG_DOUBLESIZE && defined(USE_LONG_DOUBLE)
-# if defined(LDBL_INFINITY)
-INFNAN_NV_U8_DECL PL_inf = { LDBL_INFINITY };
-# elif defined(LDBL_INF)
-INFNAN_NV_U8_DECL PL_inf = { LDBL_INF };
-# elif defined(INFINITY)
-INFNAN_NV_U8_DECL PL_inf = { (NV)INFINITY };
-# elif defined(INF)
-INFNAN_NV_U8_DECL PL_inf = { (NV)INF };
-# else
-INFNAN_NV_U8_DECL PL_inf = { 1.0L/0.0L }; /* keep last */
-# endif
-# else
-# if defined(DBL_INFINITY)
-INFNAN_NV_U8_DECL PL_inf = { DBL_INFINITY };
-# elif defined(DBL_INF)
-INFNAN_NV_U8_DECL PL_inf = { DBL_INF };
-# elif defined(INFINITY) /* C99 */
-INFNAN_NV_U8_DECL PL_inf = { (NV)INFINITY };
-# elif defined(INF)
-INFNAN_NV_U8_DECL PL_inf = { (NV)INF };
-# else
-INFNAN_NV_U8_DECL PL_inf = { 1.0/0.0 }; /* keep last */
-# endif
-# endif
-# endif
-
-# ifdef USE_QUADMATH
-/* Cannot use nanq("0") for PL_nan because not a compile-time
- * constant. */
-INFNAN_NV_U8_DECL PL_nan = { 0.0Q/0.0Q };
-# elif NVSIZE == LONG_DOUBLESIZE && defined(LONGDBLNANBYTES)
-INFNAN_U8_NV_DECL PL_nan = { { LONGDBLNANBYTES } };
-# elif NVSIZE == DOUBLESIZE && defined(DOUBLENANBYTES)
-INFNAN_U8_NV_DECL PL_nan = { { DOUBLENANBYTES } };
-# else
-# if NVSIZE == LONG_DOUBLESIZE && defined(USE_LONG_DOUBLE)
-# if defined(LDBL_NAN)
-INFNAN_NV_U8_DECL PL_nan = { LDBL_NAN };
-# elif defined(LDBL_QNAN)
-INFNAN_NV_U8_DECL PL_nan = { LDBL_QNAN };
-# elif defined(NAN)
-INFNAN_NV_U8_DECL PL_nan = { (NV)NAN };
-# else
-INFNAN_NV_U8_DECL PL_nan = { 0.0L/0.0L }; /* keep last */
-# endif
-# else
-# if defined(DBL_NAN)
-INFNAN_NV_U8_DECL PL_nan = { DBL_NAN };
-# elif defined(DBL_QNAN)
-INFNAN_NV_U8_DECL PL_nan = { DBL_QNAN };
-# elif defined(NAN) /* C99 */
-INFNAN_NV_U8_DECL PL_nan = { (NV)NAN };
-# else
-INFNAN_NV_U8_DECL PL_nan = { 0.0/0.0 }; /* keep last */
-# endif
-# endif
-# endif
-
-GCC_DIAG_RESTORE
+ * while with the NV_U8 use just the NV. */
+#ifdef __cplusplus
+#define INFNAN_U8_NV_DECL EXTERN_C const union { U8 u8[NVSIZE]; NV nv; }
+#define INFNAN_NV_U8_DECL EXTERN_C const union { NV nv; U8 u8[NVSIZE]; }
#else
-
-INFNAN_NV_U8_DECL PL_inf;
-INFNAN_NV_U8_DECL PL_nan;
-
-#endif
-
-/* If you have not defined NV_INF/NV_NAN (like for example win32/win32.h),
- * we will define NV_INF/NV_NAN as the nv part of the global const
- * PL_inf/PL_nan. Note, however, that the preexisting NV_INF/NV_NAN
- * might not be a compile-time constant, in which case it cannot be
- * used to initialize PL_inf/PL_nan above. */
-#ifndef NV_INF
-# define NV_INF PL_inf.nv
-#endif
-#ifndef NV_NAN
-# define NV_NAN PL_nan.nv
+#define INFNAN_U8_NV_DECL EXTCONST union { U8 u8[NVSIZE]; NV nv; }
+#define INFNAN_NV_U8_DECL EXTCONST union { NV nv; U8 u8[NVSIZE]; }
#endif
/* if these never got defined, they need defaults */
#ifdef DOUBLE_HAS_NAN
+#ifdef DOINIT
+
+/* PL_inf and PL_nan initialization.
+ *
+ * For inf and nan initialization the ultimate fallback is dividing
+ * one or zero by zero: however, some compilers will warn or even fail
+ * on divide-by-zero, but hopefully something earlier will work.
+ *
+ * If you are thinking of using HUGE_VAL for infinity, or using
+ * <math.h> functions to generate NV_INF (e.g. exp(1e9), log(-1.0)),
+ * stop. Neither will work portably: HUGE_VAL can be just DBL_MAX,
+ * and the math functions might be just generating DBL_MAX, or even zero.
+ *
+ * Also, do NOT try doing NV_NAN based on NV_INF and trying (NV_INF-NV_INF).
+ * Though logically correct, some compilers (like Visual C 2003)
+ * falsely misoptimize that to zero (x-x is always zero, right?)
+ *
+ * Finally, note that not all floating point formats define Inf (or NaN).
+ * For the infinity a large number may be used instead. Operations that
+ * under the IEEE floating point would return Inf or NaN may return
+ * either large numbers (positive or negative), or they may cause
+ * a floating point exception or some other fault.
+ */
+
+/* The quadmath literals are anon structs which -Wc++-compat doesn't like. */
+GCC_DIAG_IGNORE(-Wc++-compat)
+
+# ifdef USE_QUADMATH
+/* Cannot use HUGE_VALQ for PL_inf because not a compile-time
+ * constant. */
+INFNAN_NV_U8_DECL PL_inf = { 1.0Q/0.0Q };
+# elif NVSIZE == LONG_DOUBLESIZE && defined(LONGDBLINFBYTES)
+INFNAN_U8_NV_DECL PL_inf = { { LONGDBLINFBYTES } };
+# elif NVSIZE == DOUBLESIZE && defined(DOUBLEINFBYTES)
+INFNAN_U8_NV_DECL PL_inf = { { DOUBLEINFBYTES } };
+# else
+# if NVSIZE == LONG_DOUBLESIZE && defined(USE_LONG_DOUBLE)
+# if defined(LDBL_INFINITY)
+INFNAN_NV_U8_DECL PL_inf = { LDBL_INFINITY };
+# elif defined(LDBL_INF)
+INFNAN_NV_U8_DECL PL_inf = { LDBL_INF };
+# elif defined(INFINITY)
+INFNAN_NV_U8_DECL PL_inf = { (NV)INFINITY };
+# elif defined(INF)
+INFNAN_NV_U8_DECL PL_inf = { (NV)INF };
+# else
+INFNAN_NV_U8_DECL PL_inf = { 1.0L/0.0L }; /* keep last */
+# endif
+# else
+# if defined(DBL_INFINITY)
+INFNAN_NV_U8_DECL PL_inf = { DBL_INFINITY };
+# elif defined(DBL_INF)
+INFNAN_NV_U8_DECL PL_inf = { DBL_INF };
+# elif defined(INFINITY) /* C99 */
+INFNAN_NV_U8_DECL PL_inf = { (NV)INFINITY };
+# elif defined(INF)
+INFNAN_NV_U8_DECL PL_inf = { (NV)INF };
+# else
+INFNAN_NV_U8_DECL PL_inf = { 1.0/0.0 }; /* keep last */
+# endif
+# endif
+# endif
+
+# ifdef USE_QUADMATH
+/* Cannot use nanq("0") for PL_nan because not a compile-time
+ * constant. */
+INFNAN_NV_U8_DECL PL_nan = { 0.0Q/0.0Q };
+# elif NVSIZE == LONG_DOUBLESIZE && defined(LONGDBLNANBYTES)
+INFNAN_U8_NV_DECL PL_nan = { { LONGDBLNANBYTES } };
+# elif NVSIZE == DOUBLESIZE && defined(DOUBLENANBYTES)
+INFNAN_U8_NV_DECL PL_nan = { { DOUBLENANBYTES } };
+# else
+# if NVSIZE == LONG_DOUBLESIZE && defined(USE_LONG_DOUBLE)
+# if defined(LDBL_NAN)
+INFNAN_NV_U8_DECL PL_nan = { LDBL_NAN };
+# elif defined(LDBL_QNAN)
+INFNAN_NV_U8_DECL PL_nan = { LDBL_QNAN };
+# elif defined(NAN)
+INFNAN_NV_U8_DECL PL_nan = { (NV)NAN };
+# else
+INFNAN_NV_U8_DECL PL_nan = { 0.0L/0.0L }; /* keep last */
+# endif
+# else
+# if defined(DBL_NAN)
+INFNAN_NV_U8_DECL PL_nan = { DBL_NAN };
+# elif defined(DBL_QNAN)
+INFNAN_NV_U8_DECL PL_nan = { DBL_QNAN };
+# elif defined(NAN) /* C99 */
+INFNAN_NV_U8_DECL PL_nan = { (NV)NAN };
+# else
+INFNAN_NV_U8_DECL PL_nan = { 0.0/0.0 }; /* keep last */
+# endif
+# endif
+# endif
+
+GCC_DIAG_RESTORE
+
+#else
+
+INFNAN_NV_U8_DECL PL_inf;
+INFNAN_NV_U8_DECL PL_nan;
+
+#endif
+
+/* If you have not defined NV_INF/NV_NAN (like for example win32/win32.h),
+ * we will define NV_INF/NV_NAN as the nv part of the global const
+ * PL_inf/PL_nan. Note, however, that the preexisting NV_INF/NV_NAN
+ * might not be a compile-time constant, in which case it cannot be
+ * used to initialize PL_inf/PL_nan above. */
+#ifndef NV_INF
+# define NV_INF PL_inf.nv
+#endif
+#ifndef NV_NAN
+# define NV_NAN PL_nan.nv
+#endif
+
/* NaNs (not-a-numbers) can carry payload bits, in addition to
* "nan-ness". Part of the payload is the quiet/signaling bit.
* To back up a bit (harhar):
#endif /* DOUBLE_HAS_NAN */
+
/*
(KEEP THIS LAST IN perl.h!)
*/
case 2:
-#line 118 "perly.y"
+#line 118 "perly.y" /* yacc.c:1646 */
{
parser->expect = XSTATE;
- ;}
+ }
+
break;
case 3:
-#line 122 "perly.y"
+#line 122 "perly.y" /* yacc.c:1646 */
{
- newPROG(block_end((ps[(3) - (4)].val.ival),(ps[(4) - (4)].val.opval)));
+ newPROG(block_end((ps[-1].val.ival),(ps[0].val.opval)));
PL_compiling.cop_seq = 0;
(yyval.ival) = 0;
- ;}
+ }
+
break;
case 4:
-#line 128 "perly.y"
+#line 128 "perly.y" /* yacc.c:1646 */
{
parser->expect = XTERM;
- ;}
+ }
+
break;
case 5:
-#line 132 "perly.y"
+#line 132 "perly.y" /* yacc.c:1646 */
{
- PL_eval_root = (ps[(3) - (3)].val.opval);
+ PL_eval_root = (ps[0].val.opval);
(yyval.ival) = 0;
- ;}
+ }
+
break;
case 6:
-#line 137 "perly.y"
+#line 137 "perly.y" /* yacc.c:1646 */
{
parser->expect = XBLOCK;
- ;}
+ }
+
break;
case 7:
-#line 141 "perly.y"
+#line 141 "perly.y" /* yacc.c:1646 */
{
PL_pad_reset_pending = TRUE;
- PL_eval_root = (ps[(3) - (3)].val.opval);
+ PL_eval_root = (ps[0].val.opval);
(yyval.ival) = 0;
yyunlex();
parser->yychar = YYEOF;
- ;}
+ }
+
break;
case 8:
-#line 149 "perly.y"
+#line 149 "perly.y" /* yacc.c:1646 */
{
parser->expect = XSTATE;
- ;}
+ }
+
break;
case 9:
-#line 153 "perly.y"
+#line 153 "perly.y" /* yacc.c:1646 */
{
PL_pad_reset_pending = TRUE;
- PL_eval_root = (ps[(3) - (3)].val.opval);
+ PL_eval_root = (ps[0].val.opval);
(yyval.ival) = 0;
yyunlex();
parser->yychar = YYEOF;
- ;}
+ }
+
break;
case 10:
-#line 161 "perly.y"
+#line 161 "perly.y" /* yacc.c:1646 */
{
parser->expect = XSTATE;
- ;}
+ }
+
break;
case 11:
-#line 165 "perly.y"
+#line 165 "perly.y" /* yacc.c:1646 */
{
PL_pad_reset_pending = TRUE;
- PL_eval_root = (ps[(3) - (3)].val.opval);
+ PL_eval_root = (ps[0].val.opval);
(yyval.ival) = 0;
yyunlex();
parser->yychar = YYEOF;
- ;}
+ }
+
break;
case 12:
-#line 173 "perly.y"
+#line 173 "perly.y" /* yacc.c:1646 */
{
parser->expect = XSTATE;
- ;}
+ }
+
break;
case 13:
-#line 177 "perly.y"
+#line 177 "perly.y" /* yacc.c:1646 */
{
- PL_eval_root = (ps[(3) - (3)].val.opval);
+ PL_eval_root = (ps[0].val.opval);
(yyval.ival) = 0;
- ;}
+ }
+
break;
case 14:
-#line 185 "perly.y"
- { if (parser->copline > (line_t)(ps[(1) - (4)].val.ival))
- parser->copline = (line_t)(ps[(1) - (4)].val.ival);
- (yyval.opval) = block_end((ps[(2) - (4)].val.ival), (ps[(3) - (4)].val.opval));
- ;}
+#line 185 "perly.y" /* yacc.c:1646 */
+ { if (parser->copline > (line_t)(ps[-3].val.ival))
+ parser->copline = (line_t)(ps[-3].val.ival);
+ (yyval.opval) = block_end((ps[-2].val.ival), (ps[-1].val.opval));
+ }
+
break;
case 15:
-#line 193 "perly.y"
- { if (parser->copline > (line_t)(ps[(1) - (7)].val.ival))
- parser->copline = (line_t)(ps[(1) - (7)].val.ival);
- (yyval.opval) = block_end((ps[(2) - (7)].val.ival), (ps[(5) - (7)].val.opval));
- ;}
+#line 193 "perly.y" /* yacc.c:1646 */
+ { if (parser->copline > (line_t)(ps[-6].val.ival))
+ parser->copline = (line_t)(ps[-6].val.ival);
+ (yyval.opval) = block_end((ps[-5].val.ival), (ps[-2].val.opval));
+ }
+
break;
case 16:
-#line 200 "perly.y"
+#line 200 "perly.y" /* yacc.c:1646 */
{ (yyval.ival) = block_start(TRUE);
- parser->parsed_sub = 0; ;}
+ parser->parsed_sub = 0; }
+
break;
case 17:
-#line 205 "perly.y"
- { if (parser->copline > (line_t)(ps[(1) - (4)].val.ival))
- parser->copline = (line_t)(ps[(1) - (4)].val.ival);
- (yyval.opval) = block_end((ps[(2) - (4)].val.ival), (ps[(3) - (4)].val.opval));
- ;}
+#line 205 "perly.y" /* yacc.c:1646 */
+ { if (parser->copline > (line_t)(ps[-3].val.ival))
+ parser->copline = (line_t)(ps[-3].val.ival);
+ (yyval.opval) = block_end((ps[-2].val.ival), (ps[-1].val.opval));
+ }
+
break;
case 18:
-#line 212 "perly.y"
+#line 212 "perly.y" /* yacc.c:1646 */
{ (yyval.ival) = block_start(FALSE);
- parser->parsed_sub = 0; ;}
+ parser->parsed_sub = 0; }
+
break;
case 19:
-#line 218 "perly.y"
- { (yyval.opval) = (OP*)NULL; ;}
+#line 218 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = NULL; }
+
break;
case 20:
-#line 220 "perly.y"
- { (yyval.opval) = op_append_list(OP_LINESEQ, (ps[(1) - (2)].val.opval), (ps[(2) - (2)].val.opval));
+#line 220 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = op_append_list(OP_LINESEQ, (ps[-1].val.opval), (ps[0].val.opval));
PL_pad_reset_pending = TRUE;
- if ((ps[(1) - (2)].val.opval) && (ps[(2) - (2)].val.opval))
+ if ((ps[-1].val.opval) && (ps[0].val.opval))
PL_hints |= HINT_BLOCK_SCOPE;
- ;}
+ }
+
break;
case 21:
-#line 229 "perly.y"
- { (yyval.opval) = (OP*)NULL; ;}
+#line 229 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = NULL; }
+
break;
case 22:
-#line 231 "perly.y"
- { (yyval.opval) = op_append_list(OP_LINESEQ, (ps[(1) - (2)].val.opval), (ps[(2) - (2)].val.opval));
+#line 231 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = op_append_list(OP_LINESEQ, (ps[-1].val.opval), (ps[0].val.opval));
PL_pad_reset_pending = TRUE;
- if ((ps[(1) - (2)].val.opval) && (ps[(2) - (2)].val.opval))
+ if ((ps[-1].val.opval) && (ps[0].val.opval))
PL_hints |= HINT_BLOCK_SCOPE;
- ;}
+ }
+
break;
case 23:
-#line 240 "perly.y"
+#line 240 "perly.y" /* yacc.c:1646 */
{
- (yyval.opval) = (ps[(1) - (1)].val.opval) ? newSTATEOP(0, NULL, (ps[(1) - (1)].val.opval)) : NULL;
- ;}
+ (yyval.opval) = (ps[0].val.opval) ? newSTATEOP(0, NULL, (ps[0].val.opval)) : NULL;
+ }
+
break;
case 24:
-#line 244 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
+#line 244 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[0].val.opval); }
+
break;
case 25:
-#line 248 "perly.y"
+#line 248 "perly.y" /* yacc.c:1646 */
{
- (yyval.opval) = newSTATEOP(SVf_UTF8 * (ps[(1) - (2)].val.pval)[strlen((ps[(1) - (2)].val.pval))+1], (ps[(1) - (2)].val.pval), (ps[(2) - (2)].val.opval));
- ;}
+ (yyval.opval) = newSTATEOP(SVf_UTF8 * (ps[-1].val.pval)[strlen((ps[-1].val.pval))+1], (ps[-1].val.pval), (ps[0].val.opval));
+ }
+
break;
case 26:
-#line 252 "perly.y"
+#line 252 "perly.y" /* yacc.c:1646 */
{
- (yyval.opval) = newSTATEOP(SVf_UTF8 * (ps[(1) - (2)].val.pval)[strlen((ps[(1) - (2)].val.pval))+1], (ps[(1) - (2)].val.pval), (ps[(2) - (2)].val.opval));
- ;}
+ (yyval.opval) = newSTATEOP(SVf_UTF8 * (ps[-1].val.pval)[strlen((ps[-1].val.pval))+1], (ps[-1].val.pval), (ps[0].val.opval));
+ }
+
break;
case 27:
-#line 259 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
+#line 259 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[0].val.opval); }
+
break;
case 28:
-#line 261 "perly.y"
+#line 261 "perly.y" /* yacc.c:1646 */
{
CV *fmtcv = PL_compcv;
- newFORM((ps[(2) - (4)].val.ival), (ps[(3) - (4)].val.opval), (ps[(4) - (4)].val.opval));
- (yyval.opval) = (OP*)NULL;
+ newFORM((ps[-2].val.ival), (ps[-1].val.opval), (ps[0].val.opval));
+ (yyval.opval) = NULL;
if (CvOUTSIDE(fmtcv) && !CvEVAL(CvOUTSIDE(fmtcv))) {
pad_add_weakref(fmtcv);
}
parser->parsed_sub = 1;
- ;}
+ }
+
break;
case 29:
-#line 271 "perly.y"
+#line 271 "perly.y" /* yacc.c:1646 */
{
- if ((ps[(2) - (3)].val.opval)->op_type == OP_CONST) {
+ if ((ps[-1].val.opval)->op_type == OP_CONST) {
const char *const name =
- SvPV_nolen_const(((SVOP*)(ps[(2) - (3)].val.opval))->op_sv);
+ SvPV_nolen_const(((SVOP*)(ps[-1].val.opval))->op_sv);
if (strEQ(name, "BEGIN") || strEQ(name, "END")
|| strEQ(name, "INIT") || strEQ(name, "CHECK")
|| strEQ(name, "UNITCHECK"))
|| CvCLONE(CvOUTSIDE(PL_compcv))
|| !PadnameIsSTATE(PadlistNAMESARRAY(CvPADLIST(
CvOUTSIDE(PL_compcv)
- ))[(ps[(2) - (3)].val.opval)->op_targ]))
+ ))[(ps[-1].val.opval)->op_targ]))
CvCLONE_on(PL_compcv);
parser->in_my = 0;
parser->in_my_stash = NULL;
- ;}
+ }
+
break;
case 30:
-#line 293 "perly.y"
+#line 293 "perly.y" /* yacc.c:1646 */
{
SvREFCNT_inc_simple_void(PL_compcv);
- (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))
+ (ps[-5].val.opval)->op_type == OP_CONST
+ ? newATTRSUB((ps[-4].val.ival), (ps[-5].val.opval), (ps[-2].val.opval), (ps[-1].val.opval), (ps[0].val.opval))
+ : newMYSUB((ps[-4].val.ival), (ps[-5].val.opval), (ps[-2].val.opval), (ps[-1].val.opval), (ps[0].val.opval))
;
- (yyval.opval) = (OP*)NULL;
+ (yyval.opval) = NULL;
intro_my();
parser->parsed_sub = 1;
- ;}
+ }
+
break;
case 31:
-#line 304 "perly.y"
+#line 304 "perly.y" /* yacc.c:1646 */
{
- if ((ps[(2) - (3)].val.opval)->op_type == OP_CONST) {
+ if ((ps[-1].val.opval)->op_type == OP_CONST) {
const char *const name =
- SvPV_nolen_const(((SVOP*)(ps[(2) - (3)].val.opval))->op_sv);
+ SvPV_nolen_const(((SVOP*)(ps[-1].val.opval))->op_sv);
if (strEQ(name, "BEGIN") || strEQ(name, "END")
|| strEQ(name, "INIT") || strEQ(name, "CHECK")
|| strEQ(name, "UNITCHECK"))
|| CvCLONE(CvOUTSIDE(PL_compcv))
|| !PadnameIsSTATE(PadlistNAMESARRAY(CvPADLIST(
CvOUTSIDE(PL_compcv)
- ))[(ps[(2) - (3)].val.opval)->op_targ]))
+ ))[(ps[-1].val.opval)->op_targ]))
CvCLONE_on(PL_compcv);
parser->in_my = 0;
parser->in_my_stash = NULL;
- ;}
+ }
+
break;
case 32:
-#line 326 "perly.y"
+#line 326 "perly.y" /* yacc.c:1646 */
{
OP *body;
- if (parser->copline > (line_t)(ps[(8) - (10)].val.ival))
- parser->copline = (line_t)(ps[(8) - (10)].val.ival);
- body = block_end((ps[(5) - (10)].val.ival),
- op_append_list(OP_LINESEQ, (ps[(6) - (10)].val.opval), (ps[(9) - (10)].val.opval)));
+ if (parser->copline > (line_t)(ps[-2].val.ival))
+ parser->copline = (line_t)(ps[-2].val.ival);
+ body = block_end((ps[-5].val.ival),
+ op_append_list(OP_LINESEQ, (ps[-4].val.opval), (ps[-1].val.opval)));
SvREFCNT_inc_simple_void(PL_compcv);
- (ps[(2) - (10)].val.opval)->op_type == OP_CONST
- ? newATTRSUB((ps[(3) - (10)].val.ival), (ps[(2) - (10)].val.opval), NULL, (ps[(7) - (10)].val.opval), body)
- : newMYSUB((ps[(3) - (10)].val.ival), (ps[(2) - (10)].val.opval), NULL, (ps[(7) - (10)].val.opval), body)
+ (ps[-8].val.opval)->op_type == OP_CONST
+ ? newATTRSUB((ps[-7].val.ival), (ps[-8].val.opval), NULL, (ps[-3].val.opval), body)
+ : newMYSUB((ps[-7].val.ival), (ps[-8].val.opval), NULL, (ps[-3].val.opval), body)
;
- (yyval.opval) = (OP*)NULL;
+ (yyval.opval) = NULL;
intro_my();
parser->parsed_sub = 1;
- ;}
+ }
+
break;
case 33:
-#line 343 "perly.y"
+#line 343 "perly.y" /* yacc.c:1646 */
{
- package((ps[(3) - (4)].val.opval));
- if ((ps[(2) - (4)].val.opval))
- package_version((ps[(2) - (4)].val.opval));
- (yyval.opval) = (OP*)NULL;
- ;}
+ package((ps[-1].val.opval));
+ if ((ps[-2].val.opval))
+ package_version((ps[-2].val.opval));
+ (yyval.opval) = NULL;
+ }
+
break;
case 34:
-#line 350 "perly.y"
- { CvSPECIAL_on(PL_compcv); /* It's a BEGIN {} */ ;}
+#line 350 "perly.y" /* yacc.c:1646 */
+ { CvSPECIAL_on(PL_compcv); /* It's a BEGIN {} */ }
+
break;
case 35:
-#line 352 "perly.y"
+#line 352 "perly.y" /* yacc.c:1646 */
{
SvREFCNT_inc_simple_void(PL_compcv);
- utilize((ps[(1) - (7)].val.ival), (ps[(2) - (7)].val.ival), (ps[(4) - (7)].val.opval), (ps[(5) - (7)].val.opval), (ps[(6) - (7)].val.opval));
+ utilize((ps[-6].val.ival), (ps[-5].val.ival), (ps[-3].val.opval), (ps[-2].val.opval), (ps[-1].val.opval));
parser->parsed_sub = 1;
- (yyval.opval) = (OP*)NULL;
- ;}
+ (yyval.opval) = NULL;
+ }
+
break;
case 36:
-#line 359 "perly.y"
+#line 359 "perly.y" /* yacc.c:1646 */
{
- (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)));
- parser->copline = (line_t)(ps[(1) - (7)].val.ival);
- ;}
+ (yyval.opval) = block_end((ps[-4].val.ival),
+ newCONDOP(0, (ps[-3].val.opval), op_scope((ps[-1].val.opval)), (ps[0].val.opval)));
+ parser->copline = (line_t)(ps[-6].val.ival);
+ }
+
break;
case 37:
-#line 365 "perly.y"
+#line 365 "perly.y" /* yacc.c:1646 */
{
- (yyval.opval) = block_end((ps[(3) - (7)].val.ival),
- newCONDOP(0, (ps[(4) - (7)].val.opval), (ps[(7) - (7)].val.opval), op_scope((ps[(6) - (7)].val.opval))));
- parser->copline = (line_t)(ps[(1) - (7)].val.ival);
- ;}
+ (yyval.opval) = block_end((ps[-4].val.ival),
+ newCONDOP(0, (ps[-3].val.opval), (ps[0].val.opval), op_scope((ps[-1].val.opval))));
+ parser->copline = (line_t)(ps[-6].val.ival);
+ }
+
break;
case 38:
-#line 371 "perly.y"
+#line 371 "perly.y" /* yacc.c:1646 */
{
- (yyval.opval) = block_end((ps[(3) - (6)].val.ival), newGIVENOP((ps[(4) - (6)].val.opval), op_scope((ps[(6) - (6)].val.opval)), 0));
- parser->copline = (line_t)(ps[(1) - (6)].val.ival);
- ;}
+ (yyval.opval) = block_end((ps[-3].val.ival), newGIVENOP((ps[-2].val.opval), op_scope((ps[0].val.opval)), 0));
+ parser->copline = (line_t)(ps[-5].val.ival);
+ }
+
break;
case 39:
-#line 376 "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 376 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = block_end((ps[-3].val.ival), newWHENOP((ps[-2].val.opval), op_scope((ps[0].val.opval)))); }
+
break;
case 40:
-#line 378 "perly.y"
- { (yyval.opval) = newWHENOP(0, op_scope((ps[(2) - (2)].val.opval))); ;}
+#line 378 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newWHENOP(0, op_scope((ps[0].val.opval))); }
+
break;
case 41:
-#line 380 "perly.y"
+#line 380 "perly.y" /* yacc.c:1646 */
{
- (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)));
- parser->copline = (line_t)(ps[(1) - (8)].val.ival);
- ;}
+ (yyval.opval) = block_end((ps[-5].val.ival),
+ newWHILEOP(0, 1, NULL,
+ (ps[-4].val.opval), (ps[-1].val.opval), (ps[0].val.opval), (ps[-2].val.ival)));
+ parser->copline = (line_t)(ps[-7].val.ival);
+ }
+
break;
case 42:
-#line 387 "perly.y"
+#line 387 "perly.y" /* yacc.c:1646 */
{
- (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)));
- parser->copline = (line_t)(ps[(1) - (8)].val.ival);
- ;}
+ (yyval.opval) = block_end((ps[-5].val.ival),
+ newWHILEOP(0, 1, NULL,
+ (ps[-4].val.opval), (ps[-1].val.opval), (ps[0].val.opval), (ps[-2].val.ival)));
+ parser->copline = (line_t)(ps[-7].val.ival);
+ }
+
break;
case 43:
-#line 394 "perly.y"
- { parser->expect = XTERM; ;}
+#line 394 "perly.y" /* yacc.c:1646 */
+ { parser->expect = XTERM; }
+
break;
case 44:
-#line 396 "perly.y"
- { parser->expect = XTERM; ;}
+#line 396 "perly.y" /* yacc.c:1646 */
+ { parser->expect = XTERM; }
+
break;
case 45:
-#line 399 "perly.y"
+#line 399 "perly.y" /* yacc.c:1646 */
{
- OP *initop = (ps[(4) - (13)].val.opval);
- OP *forop = newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
- scalar((ps[(7) - (13)].val.opval)), (ps[(13) - (13)].val.opval), (ps[(11) - (13)].val.opval), (ps[(10) - (13)].val.ival));
+ OP *initop = (ps[-9].val.opval);
+ OP *forop = newWHILEOP(0, 1, NULL,
+ scalar((ps[-6].val.opval)), (ps[0].val.opval), (ps[-2].val.opval), (ps[-3].val.ival));
if (initop) {
forop = op_prepend_elem(OP_LINESEQ, initop,
op_append_elem(OP_LINESEQ,
forop));
}
PL_hints |= HINT_BLOCK_SCOPE;
- (yyval.opval) = block_end((ps[(3) - (13)].val.ival), forop);
- parser->copline = (line_t)(ps[(1) - (13)].val.ival);
- ;}
+ (yyval.opval) = block_end((ps[-10].val.ival), forop);
+ parser->copline = (line_t)(ps[-12].val.ival);
+ }
+
break;
case 46:
-#line 414 "perly.y"
+#line 414 "perly.y" /* yacc.c:1646 */
{
- (yyval.opval) = block_end((ps[(3) - (9)].val.ival), newFOROP(0, (ps[(4) - (9)].val.opval), (ps[(6) - (9)].val.opval), (ps[(8) - (9)].val.opval), (ps[(9) - (9)].val.opval)));
- parser->copline = (line_t)(ps[(1) - (9)].val.ival);
- ;}
+ (yyval.opval) = block_end((ps[-6].val.ival), newFOROP(0, (ps[-5].val.opval), (ps[-3].val.opval), (ps[-1].val.opval), (ps[0].val.opval)));
+ parser->copline = (line_t)(ps[-8].val.ival);
+ }
+
break;
case 47:
-#line 419 "perly.y"
+#line 419 "perly.y" /* yacc.c:1646 */
{
- (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)));
- parser->copline = (line_t)(ps[(1) - (8)].val.ival);
- ;}
+ (yyval.opval) = block_end((ps[-4].val.ival), newFOROP(0,
+ op_lvalue((ps[-6].val.opval), OP_ENTERLOOP), (ps[-3].val.opval), (ps[-1].val.opval), (ps[0].val.opval)));
+ parser->copline = (line_t)(ps[-7].val.ival);
+ }
+
break;
case 48:
-#line 425 "perly.y"
- { parser->in_my = 0; (yyval.opval) = my((ps[(4) - (4)].val.opval)); ;}
+#line 425 "perly.y" /* yacc.c:1646 */
+ { parser->in_my = 0; (yyval.opval) = my((ps[0].val.opval)); }
+
break;
case 49:
-#line 427 "perly.y"
+#line 427 "perly.y" /* yacc.c:1646 */
{
(yyval.opval) = block_end(
- (ps[(3) - (10)].val.ival),
+ (ps[-7].val.ival),
newFOROP(0,
op_lvalue(
newUNOP(OP_REFGEN, 0,
- (ps[(5) - (10)].val.opval)),
+ (ps[-5].val.opval)),
OP_ENTERLOOP),
- (ps[(7) - (10)].val.opval), (ps[(9) - (10)].val.opval), (ps[(10) - (10)].val.opval))
+ (ps[-3].val.opval), (ps[-1].val.opval), (ps[0].val.opval))
);
- parser->copline = (line_t)(ps[(1) - (10)].val.ival);
- ;}
+ parser->copline = (line_t)(ps[-9].val.ival);
+ }
+
break;
case 50:
-#line 440 "perly.y"
+#line 440 "perly.y" /* yacc.c:1646 */
{
- (yyval.opval) = block_end((ps[(5) - (9)].val.ival), newFOROP(
+ (yyval.opval) = block_end((ps[-4].val.ival), newFOROP(
0, op_lvalue(newUNOP(OP_REFGEN, 0,
- (ps[(3) - (9)].val.opval)),
- OP_ENTERLOOP), (ps[(6) - (9)].val.opval), (ps[(8) - (9)].val.opval), (ps[(9) - (9)].val.opval)));
- parser->copline = (line_t)(ps[(1) - (9)].val.ival);
- ;}
+ (ps[-6].val.opval)),
+ OP_ENTERLOOP), (ps[-3].val.opval), (ps[-1].val.opval), (ps[0].val.opval)));
+ parser->copline = (line_t)(ps[-8].val.ival);
+ }
+
break;
case 51:
-#line 448 "perly.y"
+#line 448 "perly.y" /* yacc.c:1646 */
{
- (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)));
- parser->copline = (line_t)(ps[(1) - (7)].val.ival);
- ;}
+ (yyval.opval) = block_end((ps[-4].val.ival),
+ newFOROP(0, NULL, (ps[-3].val.opval), (ps[-1].val.opval), (ps[0].val.opval)));
+ parser->copline = (line_t)(ps[-6].val.ival);
+ }
+
break;
case 52:
-#line 454 "perly.y"
+#line 454 "perly.y" /* yacc.c:1646 */
{
/* 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);
- ;}
+ (yyval.opval) = newWHILEOP(0, 1, NULL,
+ NULL, (ps[-1].val.opval), (ps[0].val.opval), 0);
+ }
+
break;
case 53:
-#line 460 "perly.y"
+#line 460 "perly.y" /* yacc.c:1646 */
{
- package((ps[(3) - (5)].val.opval));
- if ((ps[(2) - (5)].val.opval)) {
- package_version((ps[(2) - (5)].val.opval));
+ package((ps[-2].val.opval));
+ if ((ps[-3].val.opval)) {
+ package_version((ps[-3].val.opval));
}
- ;}
+ }
+
break;
case 54:
-#line 467 "perly.y"
+#line 467 "perly.y" /* yacc.c:1646 */
{
/* a block is a loop that happens once */
- (yyval.opval) = newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
- (OP*)NULL, block_end((ps[(5) - (8)].val.ival), (ps[(7) - (8)].val.opval)), (OP*)NULL, 0);
- if (parser->copline > (line_t)(ps[(4) - (8)].val.ival))
- parser->copline = (line_t)(ps[(4) - (8)].val.ival);
- ;}
+ (yyval.opval) = newWHILEOP(0, 1, NULL,
+ NULL, block_end((ps[-3].val.ival), (ps[-1].val.opval)), NULL, 0);
+ if (parser->copline > (line_t)(ps[-4].val.ival))
+ parser->copline = (line_t)(ps[-4].val.ival);
+ }
+
break;
case 55:
-#line 475 "perly.y"
+#line 475 "perly.y" /* yacc.c:1646 */
{
- (yyval.opval) = (ps[(1) - (2)].val.opval);
- ;}
+ (yyval.opval) = (ps[-1].val.opval);
+ }
+
break;
case 56:
-#line 479 "perly.y"
+#line 479 "perly.y" /* yacc.c:1646 */
{
- (yyval.opval) = (OP*)NULL;
+ (yyval.opval) = NULL;
parser->copline = NOLINE;
- ;}
+ }
+
break;
case 57:
-#line 487 "perly.y"
+#line 487 "perly.y" /* yacc.c:1646 */
{ OP *list;
- if ((ps[(2) - (2)].val.opval)) {
- OP *term = (ps[(2) - (2)].val.opval);
- list = op_append_elem(OP_LIST, (ps[(1) - (2)].val.opval), term);
+ if ((ps[0].val.opval)) {
+ OP *term = (ps[0].val.opval);
+ list = op_append_elem(OP_LIST, (ps[-1].val.opval), term);
}
else {
- list = (ps[(1) - (2)].val.opval);
+ list = (ps[-1].val.opval);
}
if (parser->copline == NOLINE)
parser->copline = CopLINE(PL_curcop)-1;
else parser->copline--;
(yyval.opval) = newSTATEOP(0, NULL,
op_convert_list(OP_FORMLINE, 0, list));
- ;}
+ }
+
break;
case 58:
-#line 504 "perly.y"
- { (yyval.opval) = NULL; ;}
+#line 504 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = NULL; }
+
break;
case 59:
-#line 506 "perly.y"
- { (yyval.opval) = op_unscope((ps[(2) - (3)].val.opval)); ;}
+#line 506 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = op_unscope((ps[-1].val.opval)); }
+
break;
case 60:
-#line 511 "perly.y"
- { (yyval.opval) = (OP*)NULL; ;}
+#line 511 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = NULL; }
+
break;
case 61:
-#line 513 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
+#line 513 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[0].val.opval); }
+
break;
case 62:
-#line 515 "perly.y"
- { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval)); ;}
+#line 515 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[0].val.opval), (ps[-2].val.opval)); }
+
break;
case 63:
-#line 517 "perly.y"
- { (yyval.opval) = newLOGOP(OP_OR, 0, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval)); ;}
+#line 517 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newLOGOP(OP_OR, 0, (ps[0].val.opval), (ps[-2].val.opval)); }
+
break;
case 64:
-#line 519 "perly.y"
- { (yyval.opval) = newLOOPOP(OPf_PARENS, 1, scalar((ps[(3) - (3)].val.opval)), (ps[(1) - (3)].val.opval)); ;}
+#line 519 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newLOOPOP(OPf_PARENS, 1, scalar((ps[0].val.opval)), (ps[-2].val.opval)); }
+
break;
case 65:
-#line 521 "perly.y"
- { (yyval.opval) = newLOOPOP(OPf_PARENS, 1, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval)); ;}
+#line 521 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newLOOPOP(OPf_PARENS, 1, (ps[0].val.opval), (ps[-2].val.opval)); }
+
break;
case 66:
-#line 523 "perly.y"
- { (yyval.opval) = newFOROP(0, (OP*)NULL, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval), (OP*)NULL);
- parser->copline = (line_t)(ps[(2) - (3)].val.ival); ;}
+#line 523 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newFOROP(0, NULL, (ps[0].val.opval), (ps[-2].val.opval), NULL);
+ parser->copline = (line_t)(ps[-1].val.ival); }
+
break;
case 67:
-#line 526 "perly.y"
- { (yyval.opval) = newWHENOP((ps[(3) - (3)].val.opval), op_scope((ps[(1) - (3)].val.opval))); ;}
+#line 526 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newWHENOP((ps[0].val.opval), op_scope((ps[-2].val.opval))); }
+
break;
case 68:
-#line 531 "perly.y"
- { (yyval.opval) = (OP*)NULL; ;}
+#line 531 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = NULL; }
+
break;
case 69:
-#line 533 "perly.y"
+#line 533 "perly.y" /* yacc.c:1646 */
{
- ((ps[(2) - (2)].val.opval))->op_flags |= OPf_PARENS;
- (yyval.opval) = op_scope((ps[(2) - (2)].val.opval));
- ;}
+ ((ps[0].val.opval))->op_flags |= OPf_PARENS;
+ (yyval.opval) = op_scope((ps[0].val.opval));
+ }
+
break;
case 70:
-#line 538 "perly.y"
- { parser->copline = (line_t)(ps[(1) - (6)].val.ival);
+#line 538 "perly.y" /* yacc.c:1646 */
+ { parser->copline = (line_t)(ps[-5].val.ival);
(yyval.opval) = newCONDOP(0,
- newSTATEOP(OPf_SPECIAL,NULL,(ps[(3) - (6)].val.opval)),
- op_scope((ps[(5) - (6)].val.opval)), (ps[(6) - (6)].val.opval));
+ newSTATEOP(OPf_SPECIAL,NULL,(ps[-3].val.opval)),
+ op_scope((ps[-1].val.opval)), (ps[0].val.opval));
PL_hints |= HINT_BLOCK_SCOPE;
- ;}
+ }
+
break;
case 71:
-#line 548 "perly.y"
- { (yyval.opval) = (OP*)NULL; ;}
+#line 548 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = NULL; }
+
break;
case 72:
-#line 550 "perly.y"
- { (yyval.opval) = op_scope((ps[(2) - (2)].val.opval)); ;}
+#line 550 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = op_scope((ps[0].val.opval)); }
+
break;
case 73:
-#line 555 "perly.y"
+#line 555 "perly.y" /* yacc.c:1646 */
{ (yyval.ival) = (PL_min_intro_pending &&
PL_max_intro_pending >= PL_min_intro_pending);
- intro_my(); ;}
+ intro_my(); }
+
break;
case 74:
-#line 561 "perly.y"
- { (yyval.opval) = (OP*)NULL; ;}
+#line 561 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = NULL; }
+
break;
case 76:
-#line 567 "perly.y"
+#line 567 "perly.y" /* yacc.c:1646 */
{ YYSTYPE tmplval;
(void)scan_num("1", &tmplval);
- (yyval.opval) = tmplval.opval; ;}
+ (yyval.opval) = tmplval.opval; }
+
break;
case 78:
-#line 575 "perly.y"
- { (yyval.opval) = invert(scalar((ps[(1) - (1)].val.opval))); ;}
+#line 575 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = invert(scalar((ps[0].val.opval))); }
+
break;
case 79:
-#line 580 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); ;}
+#line 580 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[0].val.opval); intro_my(); }
+
break;
case 80:
-#line 584 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); ;}
+#line 584 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[0].val.opval); intro_my(); }
+
break;
case 81:
-#line 587 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
+#line 587 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[0].val.opval); }
+
break;
case 82:
-#line 588 "perly.y"
- { (yyval.opval) = (OP*)NULL; ;}
+#line 588 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = NULL; }
+
break;
case 83:
-#line 592 "perly.y"
+#line 592 "perly.y" /* yacc.c:1646 */
{ (yyval.ival) = start_subparse(FALSE, 0);
- SAVEFREESV(PL_compcv); ;}
+ SAVEFREESV(PL_compcv); }
+
break;
case 84:
-#line 598 "perly.y"
+#line 598 "perly.y" /* yacc.c:1646 */
{ (yyval.ival) = start_subparse(FALSE, CVf_ANON);
- SAVEFREESV(PL_compcv); ;}
+ SAVEFREESV(PL_compcv); }
+
break;
case 85:
-#line 603 "perly.y"
+#line 603 "perly.y" /* yacc.c:1646 */
{ (yyval.ival) = start_subparse(TRUE, 0);
- SAVEFREESV(PL_compcv); ;}
+ SAVEFREESV(PL_compcv); }
+
break;
case 88:
-#line 614 "perly.y"
- { (yyval.opval) = (OP*)NULL; ;}
+#line 614 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = NULL; }
+
break;
case 90:
-#line 620 "perly.y"
- { (yyval.opval) = (OP*)NULL; ;}
+#line 620 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = NULL; }
+
break;
case 91:
-#line 622 "perly.y"
- { (yyval.opval) = (ps[(2) - (2)].val.opval); ;}
+#line 622 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[0].val.opval); }
+
break;
case 92:
-#line 624 "perly.y"
- { (yyval.opval) = (OP*)NULL; ;}
+#line 624 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = NULL; }
+
break;
case 93:
-#line 629 "perly.y"
- { (yyval.opval) = (ps[(2) - (2)].val.opval); ;}
+#line 629 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[0].val.opval); }
+
break;
case 94:
-#line 631 "perly.y"
- { (yyval.opval) = (OP*)NULL; ;}
+#line 631 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = NULL; }
+
break;
case 95:
-#line 642 "perly.y"
- { parser->in_my = 0; (yyval.opval) = (OP*)NULL; ;}
+#line 642 "perly.y" /* yacc.c:1646 */
+ { parser->in_my = 0; (yyval.opval) = NULL; }
+
break;
case 96:
-#line 644 "perly.y"
- { parser->in_my = 0; (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
+#line 644 "perly.y" /* yacc.c:1646 */
+ { parser->in_my = 0; (yyval.opval) = (ps[0].val.opval); }
+
break;
case 97:
-#line 649 "perly.y"
- { (yyval.ival) = '@'; ;}
+#line 649 "perly.y" /* yacc.c:1646 */
+ { (yyval.ival) = '@'; }
+
break;
case 98:
-#line 651 "perly.y"
- { (yyval.ival) = '%'; ;}
+#line 651 "perly.y" /* yacc.c:1646 */
+ { (yyval.ival) = '%'; }
+
break;
case 99:
-#line 655 "perly.y"
+#line 655 "perly.y" /* yacc.c:1646 */
{
- I32 sigil = (ps[(1) - (3)].val.ival);
- OP *var = (ps[(2) - (3)].val.opval);
- OP *defexpr = (ps[(3) - (3)].val.opval);
+ I32 sigil = (ps[-2].val.ival);
+ OP *var = (ps[-1].val.opval);
+ OP *defexpr = (ps[0].val.opval);
if (parser->sig_slurpy)
yyerror("Multiple slurpy parameters not allowed");
yyerror("A slurpy parameter may not have "
"a default value");
- (yyval.opval) = var ? newSTATEOP(0, NULL, var) : (OP*)NULL;
- ;}
+ (yyval.opval) = var ? newSTATEOP(0, NULL, var) : NULL;
+ }
+
break;
case 100:
-#line 674 "perly.y"
- { (yyval.opval) = (OP*)NULL; ;}
+#line 674 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = NULL; }
+
break;
case 101:
-#line 676 "perly.y"
- { (yyval.opval) = newOP(OP_NULL, 0); ;}
+#line 676 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newOP(OP_NULL, 0); }
+
break;
case 102:
-#line 678 "perly.y"
- { (yyval.opval) = (ps[(2) - (2)].val.opval); ;}
+#line 678 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[0].val.opval); }
+
break;
case 103:
-#line 684 "perly.y"
+#line 684 "perly.y" /* yacc.c:1646 */
{
- OP *var = (ps[(2) - (3)].val.opval);
- OP *defexpr = (ps[(3) - (3)].val.opval);
+ OP *var = (ps[-1].val.opval);
+ OP *defexpr = (ps[0].val.opval);
if (parser->sig_slurpy)
yyerror("Slurpy parameter not last");
"follows optional parameter");
}
- (yyval.opval) = var ? newSTATEOP(0, NULL, var) : (OP*)NULL;
- ;}
+ (yyval.opval) = var ? newSTATEOP(0, NULL, var) : NULL;
+ }
+
break;
case 104:
-#line 749 "perly.y"
- { parser->in_my = KEY_sigvar; (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
+#line 749 "perly.y" /* yacc.c:1646 */
+ { parser->in_my = KEY_sigvar; (yyval.opval) = (ps[0].val.opval); }
+
break;
case 105:
-#line 751 "perly.y"
- { parser->in_my = KEY_sigvar; (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
+#line 751 "perly.y" /* yacc.c:1646 */
+ { parser->in_my = KEY_sigvar; (yyval.opval) = (ps[0].val.opval); }
+
break;
case 106:
-#line 757 "perly.y"
- { (yyval.opval) = (ps[(1) - (2)].val.opval); ;}
+#line 757 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[-1].val.opval); }
+
break;
case 107:
-#line 759 "perly.y"
+#line 759 "perly.y" /* yacc.c:1646 */
{
- (yyval.opval) = op_append_list(OP_LINESEQ, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval));
- ;}
+ (yyval.opval) = op_append_list(OP_LINESEQ, (ps[-2].val.opval), (ps[0].val.opval));
+ }
+
break;
case 108:
-#line 763 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
+#line 763 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[0].val.opval); }
+
break;
case 109:
-#line 768 "perly.y"
- { (yyval.opval) = (OP*)NULL; ;}
+#line 768 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = NULL; }
+
break;
case 110:
-#line 770 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
+#line 770 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[0].val.opval); }
+
break;
case 111:
-#line 774 "perly.y"
+#line 774 "perly.y" /* yacc.c:1646 */
{
ENTER;
SAVEIV(parser->sig_elems);
parser->sig_optelems = 0;
parser->sig_slurpy = 0;
parser->in_my = KEY_sigvar;
- ;}
+ }
+
break;
case 112:
-#line 786 "perly.y"
+#line 786 "perly.y" /* yacc.c:1646 */
{
- OP *sigops = (ps[(3) - (4)].val.opval);
+ OP *sigops = (ps[-1].val.opval);
UNOP_AUX_item *aux;
OP *check;
parser->in_my = 0;
parser->expect = XATTRBLOCK;
LEAVE;
- ;}
+ }
+
break;
case 114:
-#line 826 "perly.y"
- { (yyval.opval) = (OP*)NULL; ;}
+#line 826 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = NULL; }
+
break;
case 115:
-#line 831 "perly.y"
- { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;}
+#line 831 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[-2].val.opval), (ps[0].val.opval)); }
+
break;
case 116:
-#line 833 "perly.y"
- { (yyval.opval) = newLOGOP((ps[(2) - (3)].val.ival), 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;}
+#line 833 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newLOGOP((ps[-1].val.ival), 0, (ps[-2].val.opval), (ps[0].val.opval)); }
+
break;
case 117:
-#line 835 "perly.y"
- { (yyval.opval) = newLOGOP(OP_DOR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;}
+#line 835 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newLOGOP(OP_DOR, 0, (ps[-2].val.opval), (ps[0].val.opval)); }
+
break;
case 119:
-#line 841 "perly.y"
- { (yyval.opval) = (ps[(1) - (2)].val.opval); ;}
+#line 841 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[-1].val.opval); }
+
break;
case 120:
-#line 843 "perly.y"
+#line 843 "perly.y" /* yacc.c:1646 */
{
- OP* term = (ps[(3) - (3)].val.opval);
- (yyval.opval) = op_append_elem(OP_LIST, (ps[(1) - (3)].val.opval), term);
- ;}
+ OP* term = (ps[0].val.opval);
+ (yyval.opval) = op_append_elem(OP_LIST, (ps[-2].val.opval), term);
+ }
+
break;
case 122:
-#line 852 "perly.y"
- { (yyval.opval) = op_convert_list((ps[(1) - (3)].val.ival), OPf_STACKED,
- op_prepend_elem(OP_LIST, newGVREF((ps[(1) - (3)].val.ival),(ps[(2) - (3)].val.opval)), (ps[(3) - (3)].val.opval)) );
- ;}
+#line 852 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = op_convert_list((ps[-2].val.ival), OPf_STACKED,
+ op_prepend_elem(OP_LIST, newGVREF((ps[-2].val.ival),(ps[-1].val.opval)), (ps[0].val.opval)) );
+ }
+
break;
case 123:
-#line 856 "perly.y"
- { (yyval.opval) = op_convert_list((ps[(1) - (5)].val.ival), OPf_STACKED,
- op_prepend_elem(OP_LIST, newGVREF((ps[(1) - (5)].val.ival),(ps[(3) - (5)].val.opval)), (ps[(4) - (5)].val.opval)) );
- ;}
+#line 856 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = op_convert_list((ps[-4].val.ival), OPf_STACKED,
+ op_prepend_elem(OP_LIST, newGVREF((ps[-4].val.ival),(ps[-2].val.opval)), (ps[-1].val.opval)) );
+ }
+
break;
case 124:
-#line 860 "perly.y"
+#line 860 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = op_convert_list(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST,
- op_prepend_elem(OP_LIST, scalar((ps[(1) - (6)].val.opval)), (ps[(5) - (6)].val.opval)),
- newMETHOP(OP_METHOD, 0, (ps[(3) - (6)].val.opval))));
- ;}
+ op_prepend_elem(OP_LIST, scalar((ps[-5].val.opval)), (ps[-1].val.opval)),
+ newMETHOP(OP_METHOD, 0, (ps[-3].val.opval))));
+ }
+
break;
case 125:
-#line 866 "perly.y"
+#line 866 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = op_convert_list(OP_ENTERSUB, OPf_STACKED,
- op_append_elem(OP_LIST, scalar((ps[(1) - (3)].val.opval)),
- newMETHOP(OP_METHOD, 0, (ps[(3) - (3)].val.opval))));
- ;}
+ op_append_elem(OP_LIST, scalar((ps[-2].val.opval)),
+ newMETHOP(OP_METHOD, 0, (ps[0].val.opval))));
+ }
+
break;
case 126:
-#line 871 "perly.y"
+#line 871 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = op_convert_list(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST,
- op_prepend_elem(OP_LIST, (ps[(2) - (3)].val.opval), (ps[(3) - (3)].val.opval)),
- newMETHOP(OP_METHOD, 0, (ps[(1) - (3)].val.opval))));
- ;}
+ op_prepend_elem(OP_LIST, (ps[-1].val.opval), (ps[0].val.opval)),
+ newMETHOP(OP_METHOD, 0, (ps[-2].val.opval))));
+ }
+
break;
case 127:
-#line 877 "perly.y"
+#line 877 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = op_convert_list(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST,
- op_prepend_elem(OP_LIST, (ps[(2) - (5)].val.opval), (ps[(4) - (5)].val.opval)),
- newMETHOP(OP_METHOD, 0, (ps[(1) - (5)].val.opval))));
- ;}
+ op_prepend_elem(OP_LIST, (ps[-3].val.opval), (ps[-1].val.opval)),
+ newMETHOP(OP_METHOD, 0, (ps[-4].val.opval))));
+ }
+
break;
case 128:
-#line 883 "perly.y"
- { (yyval.opval) = op_convert_list((ps[(1) - (2)].val.ival), 0, (ps[(2) - (2)].val.opval)); ;}
+#line 883 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = op_convert_list((ps[-1].val.ival), 0, (ps[0].val.opval)); }
+
break;
case 129:
-#line 885 "perly.y"
- { (yyval.opval) = op_convert_list((ps[(1) - (4)].val.ival), 0, (ps[(3) - (4)].val.opval)); ;}
+#line 885 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = op_convert_list((ps[-3].val.ival), 0, (ps[-1].val.opval)); }
+
break;
case 130:
-#line 887 "perly.y"
+#line 887 "perly.y" /* yacc.c:1646 */
{ 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[-1].val.ival), 0, NULL, (ps[0].val.opval)); }
+
break;
case 131:
-#line 890 "perly.y"
+#line 890 "perly.y" /* yacc.c:1646 */
{ (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)));
- ;}
+ op_prepend_elem(OP_LIST, (ps[-1].val.opval), (ps[0].val.opval)), (ps[-4].val.opval)));
+ }
+
break;
case 134:
-#line 905 "perly.y"
- { (yyval.opval) = newBINOP(OP_GELEM, 0, (ps[(1) - (5)].val.opval), scalar((ps[(3) - (5)].val.opval))); ;}
+#line 905 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newBINOP(OP_GELEM, 0, (ps[-4].val.opval), scalar((ps[-2].val.opval))); }
+
break;
case 135:
-#line 907 "perly.y"
- { (yyval.opval) = newBINOP(OP_AELEM, 0, oopsAV((ps[(1) - (4)].val.opval)), scalar((ps[(3) - (4)].val.opval)));
- ;}
+#line 907 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newBINOP(OP_AELEM, 0, oopsAV((ps[-3].val.opval)), scalar((ps[-1].val.opval)));
+ }
+
break;
case 136:
-#line 910 "perly.y"
+#line 910 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newBINOP(OP_AELEM, 0,
- ref(newAVREF((ps[(1) - (5)].val.opval)),OP_RV2AV),
- scalar((ps[(4) - (5)].val.opval)));
- ;}
+ ref(newAVREF((ps[-4].val.opval)),OP_RV2AV),
+ scalar((ps[-1].val.opval)));
+ }
+
break;
case 137:
-#line 915 "perly.y"
+#line 915 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newBINOP(OP_AELEM, 0,
- ref(newAVREF((ps[(1) - (4)].val.opval)),OP_RV2AV),
- scalar((ps[(3) - (4)].val.opval)));
- ;}
+ ref(newAVREF((ps[-3].val.opval)),OP_RV2AV),
+ scalar((ps[-1].val.opval)));
+ }
+
break;
case 138:
-#line 920 "perly.y"
- { (yyval.opval) = newBINOP(OP_HELEM, 0, oopsHV((ps[(1) - (5)].val.opval)), jmaybe((ps[(3) - (5)].val.opval)));
- ;}
+#line 920 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newBINOP(OP_HELEM, 0, oopsHV((ps[-4].val.opval)), jmaybe((ps[-2].val.opval)));
+ }
+
break;
case 139:
-#line 923 "perly.y"
+#line 923 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newBINOP(OP_HELEM, 0,
- ref(newHVREF((ps[(1) - (6)].val.opval)),OP_RV2HV),
- jmaybe((ps[(4) - (6)].val.opval))); ;}
+ ref(newHVREF((ps[-5].val.opval)),OP_RV2HV),
+ jmaybe((ps[-2].val.opval))); }
+
break;
case 140:
-#line 927 "perly.y"
+#line 927 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newBINOP(OP_HELEM, 0,
- ref(newHVREF((ps[(1) - (5)].val.opval)),OP_RV2HV),
- jmaybe((ps[(3) - (5)].val.opval))); ;}
+ ref(newHVREF((ps[-4].val.opval)),OP_RV2HV),
+ jmaybe((ps[-2].val.opval))); }
+
break;
case 141:
-#line 931 "perly.y"
+#line 931 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
- newCVREF(0, scalar((ps[(1) - (4)].val.opval)))); ;}
+ newCVREF(0, scalar((ps[-3].val.opval)))); }
+
break;
case 142:
-#line 934 "perly.y"
+#line 934 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
- op_append_elem(OP_LIST, (ps[(4) - (5)].val.opval),
- newCVREF(0, scalar((ps[(1) - (5)].val.opval))))); ;}
+ op_append_elem(OP_LIST, (ps[-1].val.opval),
+ newCVREF(0, scalar((ps[-4].val.opval))))); }
+
break;
case 143:
-#line 939 "perly.y"
+#line 939 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
- op_append_elem(OP_LIST, (ps[(3) - (4)].val.opval),
- newCVREF(0, scalar((ps[(1) - (4)].val.opval))))); ;}
+ op_append_elem(OP_LIST, (ps[-1].val.opval),
+ newCVREF(0, scalar((ps[-3].val.opval))))); }
+
break;
case 144:
-#line 943 "perly.y"
+#line 943 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
- newCVREF(0, scalar((ps[(1) - (3)].val.opval)))); ;}
+ newCVREF(0, scalar((ps[-2].val.opval)))); }
+
break;
case 145:
-#line 946 "perly.y"
- { (yyval.opval) = newSLICEOP(0, (ps[(5) - (6)].val.opval), (ps[(2) - (6)].val.opval)); ;}
+#line 946 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newSLICEOP(0, (ps[-1].val.opval), (ps[-4].val.opval)); }
+
break;
case 146:
-#line 948 "perly.y"
- { (yyval.opval) = newSLICEOP(0, (ps[(3) - (4)].val.opval), (ps[(1) - (4)].val.opval)); ;}
+#line 948 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newSLICEOP(0, (ps[-1].val.opval), (ps[-3].val.opval)); }
+
break;
case 147:
-#line 950 "perly.y"
- { (yyval.opval) = newSLICEOP(0, (ps[(4) - (5)].val.opval), (OP*)NULL); ;}
+#line 950 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newSLICEOP(0, (ps[-1].val.opval), NULL); }
+
break;
case 148:
-#line 955 "perly.y"
- { (yyval.opval) = newASSIGNOP(OPf_STACKED, (ps[(1) - (3)].val.opval), (ps[(2) - (3)].val.ival), (ps[(3) - (3)].val.opval)); ;}
+#line 955 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newASSIGNOP(OPf_STACKED, (ps[-2].val.opval), (ps[-1].val.ival), (ps[0].val.opval)); }
+
break;
case 149:
-#line 957 "perly.y"
- { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;}
+#line 957 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newBINOP((ps[-1].val.ival), 0, scalar((ps[-2].val.opval)), scalar((ps[0].val.opval))); }
+
break;
case 150:
-#line 959 "perly.y"
- { if ((ps[(2) - (3)].val.ival) != OP_REPEAT)
- scalar((ps[(1) - (3)].val.opval));
- (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, (ps[(1) - (3)].val.opval), scalar((ps[(3) - (3)].val.opval)));
- ;}
+#line 959 "perly.y" /* yacc.c:1646 */
+ { if ((ps[-1].val.ival) != OP_REPEAT)
+ scalar((ps[-2].val.opval));
+ (yyval.opval) = newBINOP((ps[-1].val.ival), 0, (ps[-2].val.opval), scalar((ps[0].val.opval)));
+ }
+
break;
case 151:
-#line 964 "perly.y"
- { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;}
+#line 964 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newBINOP((ps[-1].val.ival), 0, scalar((ps[-2].val.opval)), scalar((ps[0].val.opval))); }
+
break;
case 152:
-#line 966 "perly.y"
- { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;}
+#line 966 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newBINOP((ps[-1].val.ival), 0, scalar((ps[-2].val.opval)), scalar((ps[0].val.opval))); }
+
break;
case 153:
-#line 968 "perly.y"
- { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;}
+#line 968 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newBINOP((ps[-1].val.ival), 0, scalar((ps[-2].val.opval)), scalar((ps[0].val.opval))); }
+
break;
case 154:
-#line 970 "perly.y"
- { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;}
+#line 970 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newBINOP((ps[-1].val.ival), 0, scalar((ps[-2].val.opval)), scalar((ps[0].val.opval))); }
+
break;
case 155:
-#line 972 "perly.y"
- { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;}
+#line 972 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newBINOP((ps[-1].val.ival), 0, scalar((ps[-2].val.opval)), scalar((ps[0].val.opval))); }
+
break;
case 156:
-#line 974 "perly.y"
- { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;}
+#line 974 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newBINOP((ps[-1].val.ival), 0, scalar((ps[-2].val.opval)), scalar((ps[0].val.opval))); }
+
break;
case 157:
-#line 976 "perly.y"
- { (yyval.opval) = newRANGE((ps[(2) - (3)].val.ival), scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;}
+#line 976 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newRANGE((ps[-1].val.ival), scalar((ps[-2].val.opval)), scalar((ps[0].val.opval))); }
+
break;
case 158:
-#line 978 "perly.y"
- { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;}
+#line 978 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[-2].val.opval), (ps[0].val.opval)); }
+
break;
case 159:
-#line 980 "perly.y"
- { (yyval.opval) = newLOGOP(OP_OR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;}
+#line 980 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newLOGOP(OP_OR, 0, (ps[-2].val.opval), (ps[0].val.opval)); }
+
break;
case 160:
-#line 982 "perly.y"
- { (yyval.opval) = newLOGOP(OP_DOR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;}
+#line 982 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newLOGOP(OP_DOR, 0, (ps[-2].val.opval), (ps[0].val.opval)); }
+
break;
case 161:
-#line 984 "perly.y"
- { (yyval.opval) = bind_match((ps[(2) - (3)].val.ival), (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;}
+#line 984 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = bind_match((ps[-1].val.ival), (ps[-2].val.opval), (ps[0].val.opval)); }
+
break;
case 162:
-#line 989 "perly.y"
- { (yyval.opval) = newUNOP(OP_NEGATE, 0, scalar((ps[(2) - (2)].val.opval))); ;}
+#line 989 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newUNOP(OP_NEGATE, 0, scalar((ps[0].val.opval))); }
+
break;
case 163:
-#line 991 "perly.y"
- { (yyval.opval) = (ps[(2) - (2)].val.opval); ;}
+#line 991 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[0].val.opval); }
+
break;
case 164:
-#line 994 "perly.y"
- { (yyval.opval) = newUNOP(OP_NOT, 0, scalar((ps[(2) - (2)].val.opval))); ;}
+#line 994 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newUNOP(OP_NOT, 0, scalar((ps[0].val.opval))); }
+
break;
case 165:
-#line 996 "perly.y"
- { (yyval.opval) = newUNOP((ps[(1) - (2)].val.ival), 0, scalar((ps[(2) - (2)].val.opval))); ;}
+#line 996 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newUNOP((ps[-1].val.ival), 0, scalar((ps[0].val.opval))); }
+
break;
case 166:
-#line 998 "perly.y"
+#line 998 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_POSTINC, 0,
- op_lvalue(scalar((ps[(1) - (2)].val.opval)), OP_POSTINC)); ;}
+ op_lvalue(scalar((ps[-1].val.opval)), OP_POSTINC)); }
+
break;
case 167:
-#line 1001 "perly.y"
+#line 1001 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_POSTDEC, 0,
- op_lvalue(scalar((ps[(1) - (2)].val.opval)), OP_POSTDEC));;}
+ op_lvalue(scalar((ps[-1].val.opval)), OP_POSTDEC));}
+
break;
case 168:
-#line 1004 "perly.y"
+#line 1004 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = op_convert_list(OP_JOIN, 0,
op_append_elem(
OP_LIST,
newSVOP(OP_CONST,0,
newSVpvs("\""))
)),
- (ps[(1) - (2)].val.opval)
+ (ps[-1].val.opval)
));
- ;}
+ }
+
break;
case 169:
-#line 1015 "perly.y"
+#line 1015 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_PREINC, 0,
- op_lvalue(scalar((ps[(2) - (2)].val.opval)), OP_PREINC)); ;}
+ op_lvalue(scalar((ps[0].val.opval)), OP_PREINC)); }
+
break;
case 170:
-#line 1018 "perly.y"
+#line 1018 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_PREDEC, 0,
- op_lvalue(scalar((ps[(2) - (2)].val.opval)), OP_PREDEC)); ;}
+ op_lvalue(scalar((ps[0].val.opval)), OP_PREDEC)); }
+
break;
case 171:
-#line 1025 "perly.y"
- { (yyval.opval) = newANONLIST((ps[(2) - (3)].val.opval)); ;}
+#line 1025 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newANONLIST((ps[-1].val.opval)); }
+
break;
case 172:
-#line 1027 "perly.y"
- { (yyval.opval) = newANONLIST((OP*)NULL);;}
+#line 1027 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newANONLIST(NULL);}
+
break;
case 173:
-#line 1029 "perly.y"
- { (yyval.opval) = newANONHASH((ps[(2) - (4)].val.opval)); ;}
+#line 1029 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newANONHASH((ps[-2].val.opval)); }
+
break;
case 174:
-#line 1031 "perly.y"
- { (yyval.opval) = newANONHASH((OP*)NULL); ;}
+#line 1031 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newANONHASH(NULL); }
+
break;
case 175:
-#line 1033 "perly.y"
+#line 1033 "perly.y" /* yacc.c:1646 */
{ 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)); ;}
+ (yyval.opval) = newANONATTRSUB((ps[-3].val.ival), (ps[-2].val.opval), (ps[-1].val.opval), (ps[0].val.opval)); }
+
break;
case 176:
-#line 1036 "perly.y"
+#line 1036 "perly.y" /* yacc.c:1646 */
{
OP *body;
- if (parser->copline > (line_t)(ps[(6) - (8)].val.ival))
- parser->copline = (line_t)(ps[(6) - (8)].val.ival);
- body = block_end((ps[(3) - (8)].val.ival),
- op_append_list(OP_LINESEQ, (ps[(4) - (8)].val.opval), (ps[(7) - (8)].val.opval)));
+ if (parser->copline > (line_t)(ps[-2].val.ival))
+ parser->copline = (line_t)(ps[-2].val.ival);
+ body = block_end((ps[-5].val.ival),
+ op_append_list(OP_LINESEQ, (ps[-4].val.opval), (ps[-1].val.opval)));
SvREFCNT_inc_simple_void(PL_compcv);
- (yyval.opval) = newANONATTRSUB((ps[(2) - (8)].val.ival), NULL, (ps[(5) - (8)].val.opval), body);
- ;}
+ (yyval.opval) = newANONATTRSUB((ps[-6].val.ival), NULL, (ps[-3].val.opval), body);
+ }
+
break;
case 177:
-#line 1050 "perly.y"
- { (yyval.opval) = dofile((ps[(2) - (2)].val.opval), (ps[(1) - (2)].val.ival));;}
+#line 1050 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = dofile((ps[0].val.opval), (ps[-1].val.ival));}
+
break;
case 178:
-#line 1052 "perly.y"
- { (yyval.opval) = newUNOP(OP_NULL, OPf_SPECIAL, op_scope((ps[(2) - (2)].val.opval)));;}
+#line 1052 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newUNOP(OP_NULL, OPf_SPECIAL, op_scope((ps[0].val.opval)));}
+
break;
case 183:
-#line 1060 "perly.y"
- { (yyval.opval) = newCONDOP(0, (ps[(1) - (5)].val.opval), (ps[(3) - (5)].val.opval), (ps[(5) - (5)].val.opval)); ;}
+#line 1060 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newCONDOP(0, (ps[-4].val.opval), (ps[-2].val.opval), (ps[0].val.opval)); }
+
break;
case 184:
-#line 1062 "perly.y"
- { (yyval.opval) = newUNOP(OP_REFGEN, 0, (ps[(2) - (2)].val.opval)); ;}
+#line 1062 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newUNOP(OP_REFGEN, 0, (ps[0].val.opval)); }
+
break;
case 185:
-#line 1064 "perly.y"
- { (yyval.opval) = newUNOP(OP_REFGEN, 0, localize((ps[(3) - (3)].val.opval),1)); ;}
+#line 1064 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newUNOP(OP_REFGEN, 0, localize((ps[0].val.opval),1)); }
+
break;
case 186:
-#line 1066 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
+#line 1066 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[0].val.opval); }
+
break;
case 187:
-#line 1068 "perly.y"
- { (yyval.opval) = localize((ps[(2) - (2)].val.opval),0); ;}
+#line 1068 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = localize((ps[0].val.opval),0); }
+
break;
case 188:
-#line 1070 "perly.y"
- { (yyval.opval) = sawparens((ps[(2) - (3)].val.opval)); ;}
+#line 1070 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = sawparens((ps[-1].val.opval)); }
+
break;
case 189:
-#line 1072 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
+#line 1072 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[0].val.opval); }
+
break;
case 190:
-#line 1074 "perly.y"
- { (yyval.opval) = sawparens(newNULLLIST()); ;}
+#line 1074 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = sawparens(newNULLLIST()); }
+
break;
case 191:
-#line 1076 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
+#line 1076 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[0].val.opval); }
+
break;
case 192:
-#line 1078 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
+#line 1078 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[0].val.opval); }
+
break;
case 193:
-#line 1080 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
+#line 1080 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[0].val.opval); }
+
break;
case 194:
-#line 1082 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
+#line 1082 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[0].val.opval); }
+
break;
case 195:
-#line 1084 "perly.y"
- { (yyval.opval) = newUNOP(OP_AV2ARYLEN, 0, ref((ps[(1) - (1)].val.opval), OP_AV2ARYLEN));;}
+#line 1084 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newUNOP(OP_AV2ARYLEN, 0, ref((ps[0].val.opval), OP_AV2ARYLEN));}
+
break;
case 196:
-#line 1086 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
+#line 1086 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[0].val.opval); }
+
break;
case 197:
-#line 1088 "perly.y"
+#line 1088 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = op_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))
+ list((ps[-1].val.opval)),
+ ref((ps[-3].val.opval), OP_ASLICE)));
+ if ((yyval.opval) && (ps[-3].val.opval))
(yyval.opval)->op_private |=
- (ps[(1) - (4)].val.opval)->op_private & OPpSLICEWARNING;
- ;}
+ (ps[-3].val.opval)->op_private & OPpSLICEWARNING;
+ }
+
break;
case 198:
-#line 1098 "perly.y"
+#line 1098 "perly.y" /* yacc.c:1646 */
{ (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))
+ list((ps[-1].val.opval)),
+ ref(oopsAV((ps[-3].val.opval)), OP_KVASLICE)));
+ if ((yyval.opval) && (ps[-3].val.opval))
(yyval.opval)->op_private |=
- (ps[(1) - (4)].val.opval)->op_private & OPpSLICEWARNING;
- ;}
+ (ps[-3].val.opval)->op_private & OPpSLICEWARNING;
+ }
+
break;
case 199:
-#line 1108 "perly.y"
+#line 1108 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = op_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))
+ list((ps[-2].val.opval)),
+ ref(oopsHV((ps[-4].val.opval)), OP_HSLICE)));
+ if ((yyval.opval) && (ps[-4].val.opval))
(yyval.opval)->op_private |=
- (ps[(1) - (5)].val.opval)->op_private & OPpSLICEWARNING;
- ;}
+ (ps[-4].val.opval)->op_private & OPpSLICEWARNING;
+ }
+
break;
case 200:
-#line 1118 "perly.y"
+#line 1118 "perly.y" /* yacc.c:1646 */
{ (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))
+ list((ps[-2].val.opval)),
+ ref((ps[-4].val.opval), OP_KVHSLICE)));
+ if ((yyval.opval) && (ps[-4].val.opval))
(yyval.opval)->op_private |=
- (ps[(1) - (5)].val.opval)->op_private & OPpSLICEWARNING;
- ;}
+ (ps[-4].val.opval)->op_private & OPpSLICEWARNING;
+ }
+
break;
case 201:
-#line 1128 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
+#line 1128 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[0].val.opval); }
+
break;
case 202:
-#line 1130 "perly.y"
- { (yyval.opval) = newUNOP(OP_ENTERSUB, 0, scalar((ps[(1) - (1)].val.opval))); ;}
+#line 1130 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newUNOP(OP_ENTERSUB, 0, scalar((ps[0].val.opval))); }
+
break;
case 203:
-#line 1132 "perly.y"
- { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[(1) - (3)].val.opval)));
- ;}
+#line 1132 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[-2].val.opval)));
+ }
+
break;
case 204:
-#line 1135 "perly.y"
+#line 1135 "perly.y" /* yacc.c:1646 */
{
(yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
- op_append_elem(OP_LIST, (ps[(3) - (4)].val.opval), scalar((ps[(1) - (4)].val.opval))));
- ;}
+ op_append_elem(OP_LIST, (ps[-1].val.opval), scalar((ps[-3].val.opval))));
+ }
+
break;
case 205:
-#line 1140 "perly.y"
+#line 1140 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
- op_append_elem(OP_LIST, (ps[(3) - (3)].val.opval), scalar((ps[(2) - (3)].val.opval))));
- ;}
+ op_append_elem(OP_LIST, (ps[0].val.opval), scalar((ps[-1].val.opval))));
+ }
+
break;
case 206:
-#line 1144 "perly.y"
- { (yyval.opval) = newSVREF((ps[(1) - (4)].val.opval)); ;}
+#line 1144 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newSVREF((ps[-3].val.opval)); }
+
break;
case 207:
-#line 1146 "perly.y"
- { (yyval.opval) = newAVREF((ps[(1) - (4)].val.opval)); ;}
+#line 1146 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newAVREF((ps[-3].val.opval)); }
+
break;
case 208:
-#line 1148 "perly.y"
- { (yyval.opval) = newHVREF((ps[(1) - (4)].val.opval)); ;}
+#line 1148 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newHVREF((ps[-3].val.opval)); }
+
break;
case 209:
-#line 1150 "perly.y"
+#line 1150 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_ENTERSUB, 0,
- scalar(newCVREF((ps[(3) - (4)].val.ival),(ps[(1) - (4)].val.opval)))); ;}
+ scalar(newCVREF((ps[-1].val.ival),(ps[-3].val.opval)))); }
+
break;
case 210:
-#line 1153 "perly.y"
- { (yyval.opval) = newGVREF(0,(ps[(1) - (4)].val.opval)); ;}
+#line 1153 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newGVREF(0,(ps[-3].val.opval)); }
+
break;
case 211:
-#line 1155 "perly.y"
- { (yyval.opval) = newOP((ps[(1) - (1)].val.ival), OPf_SPECIAL);
- PL_hints |= HINT_BLOCK_SCOPE; ;}
+#line 1155 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newOP((ps[0].val.ival), OPf_SPECIAL);
+ PL_hints |= HINT_BLOCK_SCOPE; }
+
break;
case 212:
-#line 1158 "perly.y"
- { (yyval.opval) = newLOOPEX((ps[(1) - (2)].val.ival),(ps[(2) - (2)].val.opval)); ;}
+#line 1158 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newLOOPEX((ps[-1].val.ival),(ps[0].val.opval)); }
+
break;
case 213:
-#line 1160 "perly.y"
- { (yyval.opval) = newUNOP(OP_NOT, 0, scalar((ps[(2) - (2)].val.opval))); ;}
+#line 1160 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newUNOP(OP_NOT, 0, scalar((ps[0].val.opval))); }
+
break;
case 214:
-#line 1162 "perly.y"
- { (yyval.opval) = newOP((ps[(1) - (1)].val.ival), 0); ;}
+#line 1162 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newOP((ps[0].val.ival), 0); }
+
break;
case 215:
-#line 1164 "perly.y"
- { (yyval.opval) = newUNOP((ps[(1) - (2)].val.ival), 0, (ps[(2) - (2)].val.opval)); ;}
+#line 1164 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newUNOP((ps[-1].val.ival), 0, (ps[0].val.opval)); }
+
break;
case 216:
-#line 1166 "perly.y"
- { (yyval.opval) = newUNOP((ps[(1) - (2)].val.ival), 0, (ps[(2) - (2)].val.opval)); ;}
+#line 1166 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newUNOP((ps[-1].val.ival), 0, (ps[0].val.opval)); }
+
break;
case 217:
-#line 1168 "perly.y"
- { (yyval.opval) = newOP(OP_REQUIRE, (ps[(1) - (1)].val.ival) ? OPf_SPECIAL : 0); ;}
+#line 1168 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newOP(OP_REQUIRE, (ps[0].val.ival) ? OPf_SPECIAL : 0); }
+
break;
case 218:
-#line 1170 "perly.y"
- { (yyval.opval) = newUNOP(OP_REQUIRE, (ps[(1) - (2)].val.ival) ? OPf_SPECIAL : 0, (ps[(2) - (2)].val.opval)); ;}
+#line 1170 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newUNOP(OP_REQUIRE, (ps[-1].val.ival) ? OPf_SPECIAL : 0, (ps[0].val.opval)); }
+
break;
case 219:
-#line 1172 "perly.y"
- { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[(1) - (1)].val.opval))); ;}
+#line 1172 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[0].val.opval))); }
+
break;
case 220:
-#line 1174 "perly.y"
+#line 1174 "perly.y" /* yacc.c:1646 */
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
- op_append_elem(OP_LIST, (ps[(2) - (2)].val.opval), scalar((ps[(1) - (2)].val.opval)))); ;}
+ op_append_elem(OP_LIST, (ps[0].val.opval), scalar((ps[-1].val.opval)))); }
+
break;
case 221:
-#line 1177 "perly.y"
- { (yyval.opval) = newOP((ps[(1) - (1)].val.ival), 0); ;}
+#line 1177 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newOP((ps[0].val.ival), 0); }
+
break;
case 222:
-#line 1179 "perly.y"
- { (yyval.opval) = newOP((ps[(1) - (3)].val.ival), 0);;}
+#line 1179 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newOP((ps[-2].val.ival), 0);}
+
break;
case 223:
-#line 1181 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
+#line 1181 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[0].val.opval); }
+
break;
case 224:
-#line 1183 "perly.y"
- { (yyval.opval) = (ps[(1) - (3)].val.opval); ;}
+#line 1183 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[-2].val.opval); }
+
break;
case 225:
-#line 1185 "perly.y"
- { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[(1) - (1)].val.opval))); ;}
+#line 1185 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[0].val.opval))); }
+
break;
case 226:
-#line 1187 "perly.y"
- { (yyval.opval) = ((ps[(1) - (3)].val.ival) == OP_NOT)
- ? newUNOP((ps[(1) - (3)].val.ival), 0, newSVOP(OP_CONST, 0, newSViv(0)))
- : newOP((ps[(1) - (3)].val.ival), OPf_SPECIAL); ;}
+#line 1187 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = ((ps[-2].val.ival) == OP_NOT)
+ ? newUNOP((ps[-2].val.ival), 0, newSVOP(OP_CONST, 0, newSViv(0)))
+ : newOP((ps[-2].val.ival), OPf_SPECIAL); }
+
break;
case 227:
-#line 1191 "perly.y"
- { (yyval.opval) = newUNOP((ps[(1) - (4)].val.ival), 0, (ps[(3) - (4)].val.opval)); ;}
+#line 1191 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newUNOP((ps[-3].val.ival), 0, (ps[-1].val.opval)); }
+
break;
case 228:
-#line 1193 "perly.y"
+#line 1193 "perly.y" /* yacc.c:1646 */
{
- 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))
+ if ( (ps[0].val.opval)->op_type != OP_TRANS
+ && (ps[0].val.opval)->op_type != OP_TRANSR
+ && (((PMOP*)(ps[0].val.opval))->op_pmflags & PMf_HAS_CV))
{
(yyval.ival) = start_subparse(FALSE, CVf_ANON);
SAVEFREESV(PL_compcv);
} else
(yyval.ival) = 0;
- ;}
+ }
+
break;
case 229:
-#line 1204 "perly.y"
- { (yyval.opval) = pmruntime((ps[(1) - (6)].val.opval), (ps[(4) - (6)].val.opval), (ps[(5) - (6)].val.opval), 1, (ps[(2) - (6)].val.ival)); ;}
+#line 1204 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = pmruntime((ps[-5].val.opval), (ps[-2].val.opval), (ps[-1].val.opval), 1, (ps[-4].val.ival)); }
+
break;
case 232:
-#line 1208 "perly.y"
+#line 1208 "perly.y" /* yacc.c:1646 */
{
(yyval.opval) = newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0),
newSVOP(OP_CONST, 0, newSVpvs("Unimplemented")));
- ;}
+ }
+
break;
case 234:
-#line 1217 "perly.y"
- { (yyval.opval) = my_attrs((ps[(2) - (3)].val.opval),(ps[(3) - (3)].val.opval)); ;}
+#line 1217 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = my_attrs((ps[-1].val.opval),(ps[0].val.opval)); }
+
break;
case 235:
-#line 1219 "perly.y"
- { (yyval.opval) = localize((ps[(2) - (2)].val.opval),1); ;}
+#line 1219 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = localize((ps[0].val.opval),1); }
+
break;
case 236:
-#line 1221 "perly.y"
- { (yyval.opval) = newUNOP(OP_REFGEN, 0, my_attrs((ps[(3) - (4)].val.opval),(ps[(4) - (4)].val.opval))); ;}
+#line 1221 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newUNOP(OP_REFGEN, 0, my_attrs((ps[-1].val.opval),(ps[0].val.opval))); }
+
break;
case 237:
-#line 1226 "perly.y"
- { (yyval.opval) = sawparens((ps[(2) - (3)].val.opval)); ;}
+#line 1226 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = sawparens((ps[-1].val.opval)); }
+
break;
case 238:
-#line 1228 "perly.y"
- { (yyval.opval) = sawparens(newNULLLIST()); ;}
+#line 1228 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = sawparens(newNULLLIST()); }
+
break;
case 239:
-#line 1231 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
+#line 1231 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[0].val.opval); }
+
break;
case 240:
-#line 1233 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
+#line 1233 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[0].val.opval); }
+
break;
case 241:
-#line 1235 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
+#line 1235 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[0].val.opval); }
+
break;
case 242:
-#line 1240 "perly.y"
- { (yyval.opval) = (OP*)NULL; ;}
+#line 1240 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = NULL; }
+
break;
case 243:
-#line 1242 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
+#line 1242 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[0].val.opval); }
+
break;
case 244:
-#line 1246 "perly.y"
- { (yyval.opval) = (OP*)NULL; ;}
+#line 1246 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = NULL; }
+
break;
case 245:
-#line 1248 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
+#line 1248 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[0].val.opval); }
+
break;
case 246:
-#line 1252 "perly.y"
- { (yyval.opval) = (OP*)NULL; ;}
+#line 1252 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = NULL; }
+
break;
case 247:
-#line 1254 "perly.y"
- { (yyval.opval) = (ps[(2) - (2)].val.opval); ;}
+#line 1254 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[0].val.opval); }
+
break;
case 248:
-#line 1260 "perly.y"
- { parser->in_my = 0; (yyval.opval) = my((ps[(1) - (1)].val.opval)); ;}
+#line 1260 "perly.y" /* yacc.c:1646 */
+ { parser->in_my = 0; (yyval.opval) = my((ps[0].val.opval)); }
+
break;
case 256:
-#line 1277 "perly.y"
- { (yyval.opval) = newCVREF((ps[(1) - (2)].val.ival),(ps[(2) - (2)].val.opval)); ;}
+#line 1277 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newCVREF((ps[-1].val.ival),(ps[0].val.opval)); }
+
break;
case 257:
-#line 1281 "perly.y"
- { (yyval.opval) = newSVREF((ps[(2) - (2)].val.opval)); ;}
+#line 1281 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newSVREF((ps[0].val.opval)); }
+
break;
case 258:
-#line 1285 "perly.y"
- { (yyval.opval) = newAVREF((ps[(2) - (2)].val.opval));
- if ((yyval.opval)) (yyval.opval)->op_private |= (ps[(1) - (2)].val.ival);
- ;}
+#line 1285 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newAVREF((ps[0].val.opval));
+ if ((yyval.opval)) (yyval.opval)->op_private |= (ps[-1].val.ival);
+ }
+
break;
case 259:
-#line 1291 "perly.y"
- { (yyval.opval) = newHVREF((ps[(2) - (2)].val.opval));
- if ((yyval.opval)) (yyval.opval)->op_private |= (ps[(1) - (2)].val.ival);
- ;}
+#line 1291 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newHVREF((ps[0].val.opval));
+ if ((yyval.opval)) (yyval.opval)->op_private |= (ps[-1].val.ival);
+ }
+
break;
case 260:
-#line 1297 "perly.y"
- { (yyval.opval) = newAVREF((ps[(2) - (2)].val.opval)); ;}
+#line 1297 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newAVREF((ps[0].val.opval)); }
+
break;
case 261:
-#line 1299 "perly.y"
- { (yyval.opval) = newAVREF((ps[(1) - (4)].val.opval)); ;}
+#line 1299 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newAVREF((ps[-3].val.opval)); }
+
break;
case 262:
-#line 1303 "perly.y"
- { (yyval.opval) = newGVREF(0,(ps[(2) - (2)].val.opval)); ;}
+#line 1303 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newGVREF(0,(ps[0].val.opval)); }
+
break;
case 264:
-#line 1308 "perly.y"
- { (yyval.opval) = newAVREF((ps[(1) - (3)].val.opval)); ;}
+#line 1308 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newAVREF((ps[-2].val.opval)); }
+
break;
case 266:
-#line 1313 "perly.y"
- { (yyval.opval) = newHVREF((ps[(1) - (3)].val.opval)); ;}
+#line 1313 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newHVREF((ps[-2].val.opval)); }
+
break;
case 268:
-#line 1318 "perly.y"
- { (yyval.opval) = newGVREF(0,(ps[(1) - (3)].val.opval)); ;}
+#line 1318 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = newGVREF(0,(ps[-2].val.opval)); }
+
break;
case 269:
-#line 1323 "perly.y"
- { (yyval.opval) = scalar((ps[(1) - (1)].val.opval)); ;}
+#line 1323 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = scalar((ps[0].val.opval)); }
+
break;
case 270:
-#line 1325 "perly.y"
- { (yyval.opval) = scalar((ps[(1) - (1)].val.opval)); ;}
+#line 1325 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = scalar((ps[0].val.opval)); }
+
break;
case 271:
-#line 1327 "perly.y"
- { (yyval.opval) = op_scope((ps[(1) - (1)].val.opval)); ;}
+#line 1327 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = op_scope((ps[0].val.opval)); }
+
break;
case 272:
-#line 1330 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
+#line 1330 "perly.y" /* yacc.c:1646 */
+ { (yyval.opval) = (ps[0].val.opval); }
+
break;
-/* Line 1267 of yacc.c. */
default: break;
/* Generated from:
- * b1f32b9f6f7c53d22517de00b5b5bfe4dd9d657c8573b9ea9eab7a43e852850a perly.y
+ * 5646c76b3536061de3b69eb5df829f5643d09247aa0d249bf2d2e050594b3679 perly.y
* 3e1dff60f26df8933d7aed0c0e87177a0f022c14800c0707eb62a7db4196ac98 regen_perly.pl
* ex: set ro: */
Any changes made here will be lost!
*/
-#define PERL_BISON_VERSION 20003
+#define PERL_BISON_VERSION 30000
#ifdef PERL_CORE
-/* A Bison parser, made by GNU Bison 2.3. */
+/* A Bison parser, made by GNU Bison 3.0.4. */
-/* Skeleton interface for Bison's Yacc-like parsers in C
+/* Bison interface for Yacc-like parsers in C
- Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002, 2003, 2004, 2005, 2006
- Free Software Foundation, Inc.
+ Copyright (C) 1984, 1989-1990, 2000-2015 Free Software Foundation, Inc.
- This program is free software; you can redistribute it and/or modify
+ This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2, or (at your option)
- any later version.
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 51 Franklin Street, Fifth Floor,
- Boston, MA 02110-1301, USA. */
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
/* As a special exception, you may create a larger work that contains
part or all of the Bison parser skeleton and distribute that work
This special exception was added by the Free Software Foundation in
version 2.2 of Bison. */
-/* Tokens. */
+/* Debug traces. */
+#ifndef YYDEBUG
+# define YYDEBUG 0
+#endif
+#if YYDEBUG
+extern int yydebug;
+#endif
+
+/* Token type. */
#ifndef YYTOKENTYPE
# define YYTOKENTYPE
- /* Put the tokens into the symbol table, so that GDB and other debuggers
- know about them. */
- enum yytokentype {
- GRAMPROG = 258,
- GRAMEXPR = 259,
- GRAMBLOCK = 260,
- GRAMBARESTMT = 261,
- GRAMFULLSTMT = 262,
- GRAMSTMTSEQ = 263,
- BAREWORD = 264,
- METHOD = 265,
- FUNCMETH = 266,
- THING = 267,
- PMFUNC = 268,
- PRIVATEREF = 269,
- QWLIST = 270,
- FUNC0OP = 271,
- FUNC0SUB = 272,
- UNIOPSUB = 273,
- LSTOPSUB = 274,
- PLUGEXPR = 275,
- PLUGSTMT = 276,
- LABEL = 277,
- FORMAT = 278,
- SUB = 279,
- ANONSUB = 280,
- PACKAGE = 281,
- USE = 282,
- WHILE = 283,
- UNTIL = 284,
- IF = 285,
- UNLESS = 286,
- ELSE = 287,
- ELSIF = 288,
- CONTINUE = 289,
- FOR = 290,
- GIVEN = 291,
- WHEN = 292,
- DEFAULT = 293,
- LOOPEX = 294,
- DOTDOT = 295,
- YADAYADA = 296,
- FUNC0 = 297,
- FUNC1 = 298,
- FUNC = 299,
- UNIOP = 300,
- LSTOP = 301,
- RELOP = 302,
- EQOP = 303,
- MULOP = 304,
- ADDOP = 305,
- DOLSHARP = 306,
- DO = 307,
- HASHBRACK = 308,
- NOAMP = 309,
- LOCAL = 310,
- MY = 311,
- REQUIRE = 312,
- COLONATTR = 313,
- FORMLBRACK = 314,
- FORMRBRACK = 315,
- PREC_LOW = 316,
- DOROP = 317,
- OROP = 318,
- ANDOP = 319,
- NOTOP = 320,
- ASSIGNOP = 321,
- DORDOR = 322,
- OROR = 323,
- ANDAND = 324,
- BITOROP = 325,
- BITANDOP = 326,
- SHIFTOP = 327,
- MATCHOP = 328,
- REFGEN = 329,
- UMINUS = 330,
- POWOP = 331,
- POSTJOIN = 332,
- POSTDEC = 333,
- POSTINC = 334,
- PREDEC = 335,
- PREINC = 336,
- ARROW = 337
- };
+ enum yytokentype
+ {
+ GRAMPROG = 258,
+ GRAMEXPR = 259,
+ GRAMBLOCK = 260,
+ GRAMBARESTMT = 261,
+ GRAMFULLSTMT = 262,
+ GRAMSTMTSEQ = 263,
+ BAREWORD = 264,
+ METHOD = 265,
+ FUNCMETH = 266,
+ THING = 267,
+ PMFUNC = 268,
+ PRIVATEREF = 269,
+ QWLIST = 270,
+ FUNC0OP = 271,
+ FUNC0SUB = 272,
+ UNIOPSUB = 273,
+ LSTOPSUB = 274,
+ PLUGEXPR = 275,
+ PLUGSTMT = 276,
+ LABEL = 277,
+ FORMAT = 278,
+ SUB = 279,
+ ANONSUB = 280,
+ PACKAGE = 281,
+ USE = 282,
+ WHILE = 283,
+ UNTIL = 284,
+ IF = 285,
+ UNLESS = 286,
+ ELSE = 287,
+ ELSIF = 288,
+ CONTINUE = 289,
+ FOR = 290,
+ GIVEN = 291,
+ WHEN = 292,
+ DEFAULT = 293,
+ LOOPEX = 294,
+ DOTDOT = 295,
+ YADAYADA = 296,
+ FUNC0 = 297,
+ FUNC1 = 298,
+ FUNC = 299,
+ UNIOP = 300,
+ LSTOP = 301,
+ RELOP = 302,
+ EQOP = 303,
+ MULOP = 304,
+ ADDOP = 305,
+ DOLSHARP = 306,
+ DO = 307,
+ HASHBRACK = 308,
+ NOAMP = 309,
+ LOCAL = 310,
+ MY = 311,
+ REQUIRE = 312,
+ COLONATTR = 313,
+ FORMLBRACK = 314,
+ FORMRBRACK = 315,
+ PREC_LOW = 316,
+ OROP = 317,
+ DOROP = 318,
+ ANDOP = 319,
+ NOTOP = 320,
+ ASSIGNOP = 321,
+ OROR = 322,
+ DORDOR = 323,
+ ANDAND = 324,
+ BITOROP = 325,
+ BITANDOP = 326,
+ SHIFTOP = 327,
+ MATCHOP = 328,
+ UMINUS = 329,
+ REFGEN = 330,
+ POWOP = 331,
+ PREINC = 332,
+ PREDEC = 333,
+ POSTINC = 334,
+ POSTDEC = 335,
+ POSTJOIN = 336,
+ ARROW = 337
+ };
#endif
-/* Tokens. */
-#define GRAMPROG 258
-#define GRAMEXPR 259
-#define GRAMBLOCK 260
-#define GRAMBARESTMT 261
-#define GRAMFULLSTMT 262
-#define GRAMSTMTSEQ 263
-#define BAREWORD 264
-#define METHOD 265
-#define FUNCMETH 266
-#define THING 267
-#define PMFUNC 268
-#define PRIVATEREF 269
-#define QWLIST 270
-#define FUNC0OP 271
-#define FUNC0SUB 272
-#define UNIOPSUB 273
-#define LSTOPSUB 274
-#define PLUGEXPR 275
-#define PLUGSTMT 276
-#define LABEL 277
-#define FORMAT 278
-#define SUB 279
-#define ANONSUB 280
-#define PACKAGE 281
-#define USE 282
-#define WHILE 283
-#define UNTIL 284
-#define IF 285
-#define UNLESS 286
-#define ELSE 287
-#define ELSIF 288
-#define CONTINUE 289
-#define FOR 290
-#define GIVEN 291
-#define WHEN 292
-#define DEFAULT 293
-#define LOOPEX 294
-#define DOTDOT 295
-#define YADAYADA 296
-#define FUNC0 297
-#define FUNC1 298
-#define FUNC 299
-#define UNIOP 300
-#define LSTOP 301
-#define RELOP 302
-#define EQOP 303
-#define MULOP 304
-#define ADDOP 305
-#define DOLSHARP 306
-#define DO 307
-#define HASHBRACK 308
-#define NOAMP 309
-#define LOCAL 310
-#define MY 311
-#define REQUIRE 312
-#define COLONATTR 313
-#define FORMLBRACK 314
-#define FORMRBRACK 315
-#define PREC_LOW 316
-#define DOROP 317
-#define OROP 318
-#define ANDOP 319
-#define NOTOP 320
-#define ASSIGNOP 321
-#define DORDOR 322
-#define OROR 323
-#define ANDAND 324
-#define BITOROP 325
-#define BITANDOP 326
-#define SHIFTOP 327
-#define MATCHOP 328
-#define REFGEN 329
-#define UMINUS 330
-#define POWOP 331
-#define POSTJOIN 332
-#define POSTDEC 333
-#define POSTINC 334
-#define PREDEC 335
-#define PREINC 336
-#define ARROW 337
-
-
-
+/* Value type. */
#ifdef PERL_IN_TOKE_C
static bool
S_is_opval_token(int type) {
#endif /* PERL_IN_TOKE_C */
#endif /* PERL_CORE */
#if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED
-typedef union YYSTYPE
+
+union YYSTYPE
{
+
I32 ival; /* __DEFAULT__ (marker for regen_perly.pl;
must always be 1st union member) */
char *pval;
OP *opval;
GV *gvval;
-}
-/* Line 1529 of yacc.c. */
- YYSTYPE;
-# define yystype YYSTYPE /* obsolescent; will be withdrawn */
-# define YYSTYPE_IS_DECLARED 1
+
+};
+
+typedef union YYSTYPE YYSTYPE;
# define YYSTYPE_IS_TRIVIAL 1
+# define YYSTYPE_IS_DECLARED 1
#endif
+int yyparse (void);
+
/* Generated from:
- * b1f32b9f6f7c53d22517de00b5b5bfe4dd9d657c8573b9ea9eab7a43e852850a perly.y
+ * 5646c76b3536061de3b69eb5df829f5643d09247aa0d249bf2d2e050594b3679 perly.y
* 3e1dff60f26df8933d7aed0c0e87177a0f022c14800c0707eb62a7db4196ac98 regen_perly.pl
* ex: set ro: */
#define YYFINAL 14
/* YYLAST -- Last index in YYTABLE. */
-#define YYLAST 3099
+#define YYLAST 3085
/* YYNTOKENS -- Number of terminals. */
#define YYNTOKENS 105
#define YYNNTS 86
/* YYNRULES -- Number of rules. */
#define YYNRULES 272
-/* YYNRULES -- Number of states. */
+/* YYNSTATES -- Number of states. */
#define YYNSTATES 539
-/* YYTRANSLATE(YYLEX) -- Bison symbol number corresponding to YYLEX. */
+/* YYTRANSLATE[YYX] -- Symbol number corresponding to YYX as returned
+ by yylex, with out-of-bounds checking. */
#define YYUNDEFTOK 2
#define YYMAXUTOK 337
-#define YYTRANSLATE(YYX) \
+#define YYTRANSLATE(YYX) \
((unsigned int) (YYX) <= YYMAXUTOK ? yytranslate[YYX] : YYUNDEFTOK)
-/* YYTRANSLATE[YYLEX] -- Bison symbol number corresponding to YYLEX. */
+/* YYTRANSLATE[TOKEN-NUM] -- Symbol number corresponding to TOKEN-NUM
+ as returned by yylex, without out-of-bounds checking. */
static const yytype_uint8 yytranslate[] =
{
0, 2, 2, 2, 2, 2, 2, 2, 2, 2,
};
#if YYDEBUG
-/* YYPRHS[YYN] -- Index of the first RHS symbol of rule number YYN in
- 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, 79,
- 80, 88, 89, 100, 105, 106, 114, 122, 130, 137,
- 144, 147, 156, 165, 166, 167, 181, 191, 200, 201,
- 212, 222, 230, 233, 234, 243, 246, 248, 251, 252,
- 256, 258, 260, 264, 268, 272, 276, 280, 284, 285,
- 288, 295, 296, 299, 300, 301, 303, 304, 306, 308,
- 310, 312, 314, 315, 316, 317, 318, 320, 322, 323,
- 325, 326, 329, 331, 334, 336, 337, 339, 341, 343,
- 347, 348, 350, 353, 357, 359, 361, 364, 368, 370,
- 371, 373, 374, 379, 381, 383, 387, 391, 395, 397,
- 400, 404, 406, 410, 416, 423, 427, 431, 437, 440,
- 445, 446, 452, 454, 456, 462, 467, 473, 478, 484,
- 491, 497, 502, 508, 513, 517, 524, 529, 535, 539,
- 543, 547, 551, 555, 559, 563, 567, 571, 575, 579,
- 583, 587, 591, 594, 597, 600, 603, 606, 609, 612,
- 615, 618, 622, 625, 630, 634, 640, 649, 652, 655,
- 657, 659, 661, 663, 669, 672, 676, 678, 681, 685,
- 687, 690, 692, 694, 696, 698, 700, 702, 707, 712,
- 718, 724, 726, 728, 732, 737, 741, 746, 751, 756,
- 761, 766, 768, 771, 774, 776, 779, 782, 784, 787,
- 789, 792, 794, 798, 800, 804, 806, 810, 815, 816,
- 823, 825, 827, 829, 831, 835, 838, 843, 847, 850,
- 852, 854, 856, 857, 859, 860, 862, 863, 866, 868,
- 870, 872, 874, 876, 878, 881, 884, 887, 890, 893,
- 896, 899, 904, 907, 909, 913, 915, 919, 921, 925,
- 927, 929, 931
-};
-
-/* 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, 175, -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, 18,
- 115, 101, 71, 119, 101, 19, -1, -1, 9, 117,
- 118, 10, -1, -1, -1, 118, 120, -1, -1, 119,
- 130, -1, 122, -1, 121, -1, 33, 122, -1, 33,
- 121, -1, 32, -1, 34, 144, 141, 114, -1, -1,
- 35, 145, 142, 123, 146, 147, 159, -1, -1, 35,
- 145, 142, 124, 115, 157, 147, 9, 118, 10, -1,
- 37, 20, 20, 101, -1, -1, 38, 142, 125, 20,
- 20, 174, 101, -1, 41, 100, 115, 139, 99, 116,
- 133, -1, 42, 100, 115, 139, 99, 116, 133, -1,
- 47, 100, 115, 139, 99, 116, -1, 48, 100, 115,
- 139, 99, 116, -1, 49, 113, -1, 39, 100, 115,
- 137, 99, 135, 116, 134, -1, 40, 100, 115, 138,
- 99, 135, 116, 134, -1, -1, -1, 46, 100, 115,
- 140, 101, 126, 137, 101, 127, 135, 140, 99, 116,
- -1, 46, 67, 115, 177, 100, 139, 99, 116, 134,
- -1, 46, 182, 100, 115, 139, 99, 116, 134, -1,
- -1, 46, 180, 115, 178, 128, 100, 139, 99, 116,
- 134, -1, 46, 90, 179, 100, 115, 139, 99, 116,
- 134, -1, 46, 100, 115, 139, 99, 116, 134, -1,
- 113, 134, -1, -1, 37, 20, 20, 9, 115, 129,
- 118, 10, -1, 132, 101, -1, 101, -1, 23, 131,
- -1, -1, 70, 118, 71, -1, 1, -1, 160, -1,
- 160, 41, 160, -1, 160, 42, 160, -1, 160, 39,
- 160, -1, 160, 40, 138, -1, 160, 46, 160, -1,
- 160, 48, 160, -1, -1, 43, 116, -1, 44, 100,
- 139, 99, 116, 133, -1, -1, 45, 113, -1, -1,
- -1, 132, -1, -1, 160, -1, 160, -1, 160, -1,
- 136, -1, 20, -1, -1, -1, -1, -1, 20, -1,
- 25, -1, -1, 23, -1, -1, 69, 23, -1, 69,
- -1, 69, 23, -1, 69, -1, -1, 25, -1, 15,
- -1, 16, -1, 150, 149, 152, -1, -1, 78, -1,
- 78, 170, -1, 102, 149, 152, -1, 153, -1, 151,
- -1, 155, 77, -1, 155, 77, 154, -1, 154, -1,
- -1, 155, -1, -1, 100, 158, 156, 99, -1, 113,
- -1, 101, -1, 160, 75, 160, -1, 160, 74, 160,
- -1, 160, 73, 160, -1, 161, -1, 161, 77, -1,
- 161, 77, 170, -1, 170, -1, 57, 190, 161, -1,
- 55, 100, 190, 160, 99, -1, 170, 98, 164, 100,
- 175, 99, -1, 170, 98, 164, -1, 21, 190, 174,
- -1, 22, 190, 100, 175, 99, -1, 57, 174, -1,
- 55, 100, 175, 99, -1, -1, 30, 143, 113, 163,
- 174, -1, 21, -1, 182, -1, 189, 9, 160, 101,
- 10, -1, 182, 11, 160, 12, -1, 170, 98, 11,
- 160, 12, -1, 165, 11, 160, 12, -1, 182, 9,
- 160, 101, 10, -1, 170, 98, 9, 160, 101, 10,
- -1, 165, 9, 160, 101, 10, -1, 170, 98, 100,
- 99, -1, 170, 98, 100, 160, 99, -1, 165, 100,
- 160, 99, -1, 165, 100, 99, -1, 100, 160, 99,
- 11, 160, 12, -1, 26, 11, 160, 12, -1, 100,
- 99, 11, 160, 12, -1, 170, 78, 170, -1, 170,
- 92, 170, -1, 170, 60, 170, -1, 170, 61, 170,
- -1, 170, 86, 170, -1, 170, 58, 170, -1, 170,
- 59, 170, -1, 170, 85, 170, -1, 170, 84, 170,
- -1, 170, 51, 170, -1, 170, 83, 170, -1, 170,
- 82, 170, -1, 170, 81, 170, -1, 170, 87, 170,
- -1, 13, 170, -1, 14, 170, -1, 88, 170, -1,
- 89, 170, -1, 170, 95, -1, 170, 94, -1, 170,
- 93, -1, 97, 170, -1, 96, 170, -1, 11, 160,
- 12, -1, 11, 12, -1, 64, 160, 101, 10, -1,
- 64, 101, 10, -1, 36, 143, 146, 147, 113, -1,
- 36, 143, 115, 157, 147, 9, 118, 10, -1, 63,
- 170, -1, 63, 113, -1, 166, -1, 167, -1, 168,
- -1, 169, -1, 170, 79, 170, 80, 170, -1, 90,
- 170, -1, 67, 90, 170, -1, 172, -1, 66, 170,
- -1, 100, 160, 99, -1, 26, -1, 100, 99, -1,
- 182, -1, 186, -1, 184, -1, 183, -1, 185, -1,
- 165, -1, 187, 11, 160, 12, -1, 188, 11, 160,
- 12, -1, 187, 9, 160, 101, 10, -1, 188, 9,
- 160, 101, 10, -1, 23, -1, 181, -1, 181, 100,
- 99, -1, 181, 100, 160, 99, -1, 65, 145, 174,
- -1, 170, 98, 102, 103, -1, 170, 98, 15, 103,
- -1, 170, 98, 16, 103, -1, 170, 98, 17, 103,
- -1, 170, 98, 103, 103, -1, 50, -1, 50, 170,
- -1, 76, 161, -1, 56, -1, 56, 113, -1, 56,
- 170, -1, 68, -1, 68, 170, -1, 29, -1, 29,
- 170, -1, 53, -1, 53, 100, 99, -1, 27, -1,
- 27, 100, 99, -1, 28, -1, 54, 100, 99, -1,
- 54, 100, 160, 99, -1, -1, 24, 171, 100, 161,
- 176, 99, -1, 20, -1, 162, -1, 52, -1, 31,
- -1, 67, 173, 148, -1, 67, 173, -1, 67, 90,
- 173, 148, -1, 100, 160, 99, -1, 100, 99, -1,
- 182, -1, 184, -1, 183, -1, -1, 161, -1, -1,
- 160, -1, -1, 104, 160, -1, 182, -1, 182, -1,
- 183, -1, 184, -1, 178, -1, 181, -1, 67, 90,
- -1, 90, 67, -1, 17, 190, -1, 102, 190, -1,
- 15, 190, -1, 16, 190, -1, 62, 190, -1, 170,
- 98, 62, 103, -1, 103, 190, -1, 183, -1, 170,
- 98, 15, -1, 184, -1, 170, 98, 16, -1, 186,
- -1, 170, 98, 103, -1, 20, -1, 182, -1, 113,
- -1, 25, -1
-};
-
-/* YYRLINE[YYN] -- source line where rule number YYN was defined. */
+ /* YYRLINE[YYN] -- Source line where rule number YYN was defined. */
static const yytype_uint16 yyrline[] =
{
0, 118, 118, 117, 128, 127, 137, 136, 149, 148,
};
#endif
-#if YYDEBUG || YYERROR_VERBOSE || YYTOKEN_TABLE
+#if YYDEBUG || YYERROR_VERBOSE || 0
/* YYTNAME[SYMBOL-NUM] -- String name of the symbol SYMBOL-NUM.
First, the terminals, then, starting at YYNTOKENS, nonterminals. */
static const char *const yytname[] =
"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",
+ "FORMLBRACK", "FORMRBRACK", "PREC_LOW", "OROP", "DOROP", "ANDOP",
+ "NOTOP", "','", "ASSIGNOP", "'?'", "':'", "OROR", "DORDOR", "ANDAND",
+ "BITOROP", "BITANDOP", "SHIFTOP", "MATCHOP", "'!'", "'~'", "UMINUS",
+ "REFGEN", "POWOP", "PREINC", "PREDEC", "POSTINC", "POSTDEC", "POSTJOIN",
"ARROW", "')'", "'('", "';'", "'$'", "'*'", "'/'", "$accept", "grammar",
- "@1", "@2", "@3", "@4", "@5", "@6", "block", "formblock", "remember",
- "mblock", "mremember", "stmtseq", "formstmtseq", "fullstmt",
- "labfullstmt", "barestmt", "@7", "@8", "@9", "@10", "@11", "@12", "@13",
- "formline", "formarg", "sideff", "else", "cont", "mintro", "nexpr",
- "texpr", "iexpr", "mexpr", "mnexpr", "formname", "startsub",
+ "$@1", "$@2", "$@3", "$@4", "$@5", "$@6", "block", "formblock",
+ "remember", "mblock", "mremember", "stmtseq", "formstmtseq", "fullstmt",
+ "labfullstmt", "barestmt", "$@7", "$@8", "$@9", "$@10", "$@11", "@12",
+ "$@13", "formline", "formarg", "sideff", "else", "cont", "mintro",
+ "nexpr", "texpr", "iexpr", "mexpr", "mnexpr", "formname", "startsub",
"startanonsub", "startformsub", "subname", "proto", "subattrlist",
"myattrlist", "sigvarname", "sigslurpsigil", "sigslurpelem",
"sigdefault", "sigscalarelem", "sigelem", "siglist", "siglistornull",
- "subsignature", "@14", "optsubbody", "expr", "listexpr", "listop", "@15",
- "method", "subscripted", "termbinop", "termunop", "anonymous", "termdo",
- "term", "@16", "myattrterm", "myterm", "optlistexpr", "optexpr",
- "optrepl", "my_scalar", "my_var", "refgen_topic", "my_refgen", "amper",
- "scalar", "ary", "hsh", "arylen", "star", "sliceme", "kvslice", "gelem",
- "indirob", 0
+ "subsignature", "$@14", "optsubbody", "expr", "listexpr", "listop",
+ "@15", "method", "subscripted", "termbinop", "termunop", "anonymous",
+ "termdo", "term", "@16", "myattrterm", "myterm", "optlistexpr",
+ "optexpr", "optrepl", "my_scalar", "my_var", "refgen_topic", "my_refgen",
+ "amper", "scalar", "ary", "hsh", "arylen", "star", "sliceme", "kvslice",
+ "gelem", "indirob", YY_NULLPTR
};
#endif
# ifdef YYPRINT
-/* YYTOKNUM[YYLEX-NUM] -- Internal token number corresponding to
- token YYLEX-NUM. */
+/* YYTOKNUM[NUM] -- (External) token number corresponding to the
+ (internal) symbol number NUM (which must be that of a token). */
static const yytype_uint16 yytoknum[] =
{
0, 256, 257, 258, 259, 260, 261, 262, 263, 123,
};
# 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, 123,
- 122, 124, 122, 122, 125, 122, 122, 122, 122, 122,
- 122, 122, 122, 126, 127, 122, 122, 122, 128, 122,
- 122, 122, 122, 129, 122, 122, 122, 130, 131, 131,
- 132, 132, 132, 132, 132, 132, 132, 132, 133, 133,
- 133, 134, 134, 135, 136, 136, 137, 137, 138, 139,
- 140, 141, 141, 142, 143, 144, 145, 145, 146, 146,
- 147, 147, 147, 148, 148, 149, 149, 150, 150, 151,
- 152, 152, 152, 153, 154, 154, 155, 155, 155, 156,
- 156, 158, 157, 159, 159, 160, 160, 160, 160, 161,
- 161, 161, 162, 162, 162, 162, 162, 162, 162, 162,
- 163, 162, 164, 164, 165, 165, 165, 165, 165, 165,
- 165, 165, 165, 165, 165, 165, 165, 165, 166, 166,
- 166, 166, 166, 166, 166, 166, 166, 166, 166, 166,
- 166, 166, 167, 167, 167, 167, 167, 167, 167, 167,
- 167, 168, 168, 168, 168, 168, 168, 169, 169, 170,
- 170, 170, 170, 170, 170, 170, 170, 170, 170, 170,
- 170, 170, 170, 170, 170, 170, 170, 170, 170, 170,
- 170, 170, 170, 170, 170, 170, 170, 170, 170, 170,
- 170, 170, 170, 170, 170, 170, 170, 170, 170, 170,
- 170, 170, 170, 170, 170, 170, 170, 170, 171, 170,
- 170, 170, 170, 170, 172, 172, 172, 173, 173, 173,
- 173, 173, 174, 174, 175, 175, 176, 176, 177, 178,
- 178, 178, 179, 179, 180, 180, 181, 182, 183, 184,
- 185, 185, 186, 187, 187, 188, 188, 189, 189, 190,
- 190, 190, 190
-};
+#define YYPACT_NINF -440
-/* YYR2[YYN] -- Number of symbols composing right hand side of rule YYN. */
-static const yytype_uint8 yyr2[] =
+#define yypact_value_is_default(Yystate) \
+ (!!((Yystate) == (-440)))
+
+#define YYTABLE_NINF -268
+
+#define yytable_value_is_error(Yytable_value) \
+ (!!((Yytable_value) == (-268)))
+
+ /* YYPACT[STATE-NUM] -- Index in YYTABLE of the portion describing
+ STATE-NUM. */
+static const yytype_int16 yypact[] =
{
- 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, 4, 0,
- 7, 0, 10, 4, 0, 7, 7, 7, 6, 6,
- 2, 8, 8, 0, 0, 13, 9, 8, 0, 10,
- 9, 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, 0, 0, 0, 0, 1, 1, 0, 1,
- 0, 2, 1, 2, 1, 0, 1, 1, 1, 3,
- 0, 1, 2, 3, 1, 1, 2, 3, 1, 0,
- 1, 0, 4, 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, 8, 2, 2, 1,
- 1, 1, 1, 5, 2, 3, 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, 6,
- 1, 1, 1, 1, 3, 2, 4, 3, 2, 1,
- 1, 1, 0, 1, 0, 1, 0, 2, 1, 1,
- 1, 1, 1, 1, 2, 2, 2, 2, 2, 2,
- 2, 4, 2, 1, 3, 1, 3, 1, 3, 1,
- 1, 1, 1
+ 824, -440, -440, -440, -440, -440, -440, 21, -440, 2826,
+ 44, 1518, 1423, -440, -440, -440, 1989, 2826, 2826, 60,
+ 60, 60, -440, 60, 60, -440, -440, 8, -68, -440,
+ 2826, -440, -440, -440, 2826, -440, -46, -29, -18, 1896,
+ 1801, 60, 1896, 2082, 16, 2826, 137, 2826, 2826, 2826,
+ 2826, 2826, 2826, 2826, 2175, 60, 60, 170, 36, -440,
+ 7, -440, -440, -440, -440, 2945, -440, -440, 17, 126,
+ 209, 221, -440, 89, 239, 266, 113, -440, -440, -440,
+ -440, -440, 16, 106, -440, 29, 32, 57, 61, 149,
+ 66, 70, 44, -440, 102, -440, 116, 325, 1423, -440,
+ -440, -440, 663, 758, -440, 195, 442, 442, -440, -440,
+ -440, -440, -440, -440, -440, 2826, 73, 122, 2826, 127,
+ 318, 44, -8, 2945, 142, 2268, 1801, -440, 318, 561,
+ 36, -440, 485, 2826, -440, -440, 318, 215, 90, -440,
+ -440, 2826, 318, 2919, 2361, 186, -440, -440, -440, 318,
+ 36, 442, 442, 442, 535, 535, 252, 256, -440, -440,
+ 2826, 2826, 2826, 2826, 2826, 2826, 2454, 2826, 2826, 2826,
+ 2826, 2826, 2826, 2826, 2826, 2826, 2826, 2826, 2826, 2826,
+ 2826, 2826, -440, -440, -440, 72, 2547, 2826, 2826, 2826,
+ 2826, 2826, 2826, 2826, -440, 244, -440, 260, -440, -440,
+ -440, -440, -440, 190, 23, -440, -440, 184, -440, -440,
+ -440, 44, -440, -440, 2826, 2826, 2826, 2826, 2826, 2826,
+ -440, -440, -440, -440, -440, 2826, 2826, 217, -440, -440,
+ -440, 194, 227, -440, -440, 295, 187, 2826, 36, -440,
+ 296, -440, 2640, 442, 186, 47, 52, 75, -440, 309,
+ 284, -440, 2826, 301, 251, 251, -440, 2945, 160, 230,
+ -440, 455, 1600, 518, 1879, 498, 646, 2945, 369, 1692,
+ 1692, 419, 1786, 1972, 531, 442, 442, 2826, 2826, 224,
+ 229, 231, -440, 232, 2733, 48, 243, 274, -440, -440,
+ 475, 192, 235, 370, 246, 399, 250, 408, 853, -440,
+ 338, 290, -2, 355, 2826, 2826, 2826, 2826, -440, 299,
+ -440, -440, 297, -440, -440, -440, -440, 1612, 31, -440,
+ 2826, 2826, -440, 170, -440, 170, 170, 170, 170, 170,
+ 303, 19, -440, 2826, -440, 227, 380, 44, -440, -440,
+ 576, -440, 98, 648, -440, -440, -440, 264, 2826, 402,
+ -440, -440, 2826, 418, 270, -440, -440, -440, -440, -440,
+ 661, -440, -440, 2826, -440, 409, -440, 412, -440, 415,
+ -440, 416, -440, -440, -440, 386, -440, -440, -440, 411,
+ 333, 170, 336, 337, 170, 339, 341, -440, -440, -440,
+ -440, 340, 345, 312, -440, 2826, 358, 359, -440, 2826,
+ 363, -440, 112, 459, -440, -440, -440, 107, -440, 275,
+ -440, 2987, 465, -440, -440, 377, -440, -440, -440, -440,
+ 368, 227, 194, -440, 2826, -440, -440, 477, 477, 2826,
+ 2826, 477, -440, 384, 389, 477, 477, 170, -440, -440,
+ -440, 464, 464, -440, -440, -440, 413, 396, -440, -440,
+ -440, -440, 427, 5, 227, -440, 398, 477, 477, -440,
+ 134, 134, 414, 421, 102, 2826, 2826, 477, -440, -440,
+ -440, 423, 423, 112, -440, 948, -440, -440, -440, -440,
+ 499, 1043, -440, 102, 102, -440, 477, 407, -440, -440,
+ 477, 477, -440, 422, 433, 102, 2826, -440, -440, -440,
+ -440, 3, -440, -440, -440, -440, 1138, -440, 2826, 102,
+ 102, -440, 477, -440, 2945, 452, 493, -440, 1233, -440,
+ 436, -440, -440, -440, 102, -440, -440, -440, -440, 477,
+ 1706, -440, 1328, 134, 448, -440, -440, 477, -440
};
-/* 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. */
+ /* YYDEFACT[STATE-NUM] -- Default reduction number in state STATE-NUM.
+ Performed when YYTABLE does not specify something else to do. Zero
+ means the default is an error. */
static const yytype_uint16 yydefact[] =
{
0, 2, 4, 6, 8, 10, 12, 0, 16, 244,
220, 0, 88, 212, 0, 0, 244, 215, 216, 269,
243, 128, 270, 0, 260, 178, 177, 0, 0, 86,
87, 242, 187, 0, 0, 235, 239, 241, 240, 218,
- 213, 164, 165, 184, 170, 169, 190, 0, 257, 262,
+ 213, 164, 165, 184, 169, 170, 190, 0, 257, 262,
0, 0, 0, 119, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 168, 167, 166, 0, 0, 0, 0, 0,
+ 0, 0, 166, 167, 168, 0, 0, 0, 0, 0,
0, 0, 0, 0, 19, 82, 83, 0, 34, 16,
16, 16, 16, 16, 0, 16, 16, 0, 16, 16,
40, 0, 52, 55, 0, 0, 0, 0, 0, 0,
26, 25, 20, 171, 126, 244, 0, 0, 224, 130,
89, 0, 90, 222, 226, 0, 0, 0, 122, 174,
0, 205, 0, 185, 0, 191, 194, 193, 238, 0,
- 94, 234, 0, 188, 117, 116, 115, 120, 0, 0,
- 144, 0, 157, 153, 154, 150, 151, 148, 0, 160,
- 159, 158, 156, 155, 152, 161, 149, 0, 0, 264,
+ 94, 234, 0, 188, 116, 117, 115, 120, 0, 0,
+ 144, 0, 157, 153, 154, 150, 151, 148, 0, 159,
+ 160, 158, 156, 155, 152, 161, 149, 0, 0, 264,
266, 0, 132, 0, 0, 0, 268, 125, 133, 203,
0, 0, 0, 0, 0, 0, 0, 0, 0, 81,
0, 29, 0, 0, 76, 0, 0, 0, 254, 0,
0, 49, 0, 68, 0, 59, 70, 0, 45
};
-/* YYDEFGOTO[NTERM-NUM]. */
+ /* YYPGOTO[NTERM-NUM]. */
+static const yytype_int16 yypgoto[] =
+{
+ -440, -440, -440, -440, -440, -440, -440, -440, 10, -440,
+ -60, -95, -440, -15, -440, 529, 454, -3, -440, -440,
+ -440, -440, -440, -440, -440, -440, -440, -315, -439, -103,
+ -420, -440, 88, 282, -206, 26, -440, 361, 522, -440,
+ 506, 200, -330, 353, 156, -440, -440, 136, -440, 133,
+ -440, -440, 177, -440, -440, -6, -36, -440, -440, -440,
+ -440, -440, -440, -440, -440, 25, -440, -440, 468, -106,
+ -125, -440, -440, 306, -440, -440, 450, 233, -35, -33,
+ -440, -440, -440, -440, -440, 4
+};
+
+ /* YYDEFGOTO[NTERM-NUM]. */
static const yytype_int16 yydefgoto[] =
{
-1, 7, 8, 9, 10, 11, 12, 13, 94, 374,
72, 73, 74, 75, 76, 158
};
-/* YYPACT[STATE-NUM] -- Index in YYTABLE of the portion describing
- STATE-NUM. */
-#define YYPACT_NINF -440
-static const yytype_int16 yypact[] =
-{
- 724, -440, -440, -440, -440, -440, -440, 19, -440, 2837,
- 12, 1531, 1434, -440, -440, -440, 2000, 2837, 2837, 60,
- 60, 60, -440, 60, 60, -440, -440, 42, -46, -440,
- 2837, -440, -440, -440, 2837, -440, -29, -18, -4, 1907,
- 1812, 60, 1907, 2093, 16, 2837, 23, 2837, 2837, 2837,
- 2837, 2837, 2837, 2837, 2186, 60, 60, 464, 32, -440,
- 7, -440, -440, -440, -440, 2956, -440, -440, 22, 126,
- 152, 209, -440, 120, 255, 266, 123, -440, -440, -440,
- -440, -440, 16, 127, -440, 57, 70, 73, 76, 165,
- 77, 91, 12, -440, 107, -440, 116, 474, 1434, -440,
- -440, -440, 657, 755, -440, 155, 198, 198, -440, -440,
- -440, -440, -440, -440, -440, 2837, 122, 125, 2837, 138,
- 531, 12, -8, 2956, 151, 2279, 1812, -440, 531, 561,
- 32, -440, 485, 2837, -440, -440, 531, 216, 160, -440,
- -440, 2837, 531, 2930, 2372, 180, -440, -440, -440, 531,
- 32, 198, 198, 198, 150, 150, 252, 256, -440, -440,
- 2837, 2837, 2837, 2837, 2837, 2837, 2465, 2837, 2837, 2837,
- 2837, 2837, 2837, 2837, 2837, 2837, 2837, 2837, 2837, 2837,
- 2837, 2837, -440, -440, -440, 72, 2558, 2837, 2837, 2837,
- 2837, 2837, 2837, 2837, -440, 260, -440, 261, -440, -440,
- -440, -440, -440, 194, 149, -440, -440, 186, -440, -440,
- -440, 12, -440, -440, 2837, 2837, 2837, 2837, 2837, 2837,
- -440, -440, -440, -440, -440, 2837, 2837, 166, -440, -440,
- -440, 187, 225, -440, -440, 293, 207, 2837, 32, -440,
- 297, -440, 2651, 198, 180, 47, 52, 75, -440, 332,
- 289, -440, 2837, 315, 257, 257, -440, 2956, 296, 195,
- -440, 354, 1612, 1985, 352, 501, 327, 2956, 397, 1703,
- 1703, 1797, 413, 1892, 1662, 198, 198, 2837, 2837, 224,
- 232, 243, -440, 245, 2744, 48, 258, 278, -440, -440,
- 576, 300, 230, 325, 235, 329, 246, 392, 852, -440,
- 342, 281, -2, 344, 2837, 2837, 2837, 2837, -440, 280,
- -440, -440, 286, -440, -440, -440, -440, 1624, 31, -440,
- 2837, 2837, -440, 464, -440, 464, 464, 464, 464, 464,
- 291, 49, -440, 2837, -440, 225, 385, 12, -440, -440,
- 627, -440, 21, 642, -440, -440, -440, 250, 2837, 405,
- -440, -440, 2837, 455, 264, -440, -440, -440, -440, -440,
- 662, -440, -440, 2837, -440, 406, -440, 422, -440, 425,
- -440, 426, -440, -440, -440, 418, -440, -440, -440, 423,
- 350, 464, 353, 355, 464, 362, 351, -440, -440, -440,
- -440, 363, 367, 310, -440, 2837, 365, 370, -440, 2837,
- 387, -440, 112, 479, -440, -440, -440, 29, -440, 270,
- -440, 3001, 491, -440, -440, 404, -440, -440, -440, -440,
- 403, 225, 187, -440, 2837, -440, -440, 500, 500, 2837,
- 2837, 500, -440, 412, 420, 500, 500, 464, -440, -440,
- -440, 492, 492, -440, -440, -440, 446, 433, -440, -440,
- -440, -440, 463, 5, 225, -440, 434, 500, 500, -440,
- 74, 74, 441, 442, 107, 2837, 2837, 500, -440, -440,
- -440, 472, 472, 112, -440, 949, -440, -440, -440, -440,
- 543, 1046, -440, 107, 107, -440, 500, 453, -440, -440,
- 500, 500, -440, 454, 458, 107, 2837, -440, -440, -440,
- -440, 3, -440, -440, -440, -440, 1143, -440, 2837, 107,
- 107, -440, 500, -440, 2956, 484, 555, -440, 1240, -440,
- 476, -440, -440, -440, 107, -440, -440, -440, -440, 500,
- 1717, -440, 1337, 74, 477, -440, -440, 500, -440
-};
-
-/* YYPGOTO[NTERM-NUM]. */
-static const yytype_int16 yypgoto[] =
-{
- -440, -440, -440, -440, -440, -440, -440, -440, 10, -440,
- -60, -95, -440, -15, -440, 569, 487, -3, -440, -440,
- -440, -440, -440, -440, -440, -440, -440, -315, -439, -130,
- -420, -440, 117, 282, -206, 67, -440, 394, 565, -440,
- 522, 231, -330, 361, 168, -440, -440, 136, -440, 140,
- -440, -440, 189, -440, -440, -6, -36, -440, -440, -440,
- -440, -440, -440, -440, -440, 25, -440, -440, 471, -106,
- -125, -440, -440, 298, -440, -440, 411, 233, -35, -33,
- -440, -440, -440, -440, -440, 4
-};
-
-/* 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 zero, do what YYDEFACT says.
- If YYTABLE_NINF, syntax error. */
-#define YYTABLE_NINF -268
+ /* YYTABLE[YYPACT[STATE-NUM]] -- What to do in state STATE-NUM. If
+ positive, shift that token. If negative, reduce the rule whose
+ number is the opposite. If YYTABLE_NINF, syntax error. */
static const yytype_int16 yytable[] =
{
103, 236, 389, 57, 130, 403, 458, 377, 95, 224,
- 105, 147, 150, 148, 77, 230, 164, 194, 165, 14,
- 78, 77, 489, 112, 113, 114, 515, 115, 116, 110,
- 110, 110, 252, 110, 110, 241, 139, 138, 19, 20,
- 348, 140, 106, 107, 133, 134, 19, 20, 157, 127,
- 110, 110, 135, 118, 119, 120, 187, 77, 188, 123,
+ 105, 147, 150, 148, 77, 230, 164, 194, 165, 118,
+ 78, 14, 489, 112, 113, 114, 515, 115, 116, 110,
+ 110, 110, 119, 110, 110, 241, 139, 138, 19, 20,
+ 21, 140, 106, 107, 133, 134, 19, 20, 157, 127,
+ 110, 110, 135, 77, 124, 120, 187, 77, 188, 123,
159, -263, 231, -263, 128, 110, 110, 136, 108, 77,
- 142, 124, 149, 109, 151, 152, 153, 154, 155, 130,
- 108, 277, 125, 278, -265, 109, -265, 279, 280, 281,
- -238, 453, -16, 282, 536, 221, 126, 238, -237, 378,
- 330, 385, 210, 530, 516, 130, 477, 166, 246, 163,
- 247, 391, 227, 143, 396, 397, -239, 486, 487, 235,
- 57, -241, 186, 144, 480, 55, 163, 439, 440, -267,
- 237, 229, 193, 55, 283, 187, 110, 188, 249, 304,
- 305, 306, 307, 309, -240, 317, 318, 197, 320, 321,
- 55, 361, 211, 399, 254, 255, 256, 199, 258, 259,
- 261, -263, 55, -263, 19, 20, 21, 223, 243, 315,
- 200, 316, 284, 201, 285, 286, 202, 208, 332, 298,
+ 142, 125, 149, 109, 151, 152, 153, 154, 155, 130,
+ 108, 277, 126, 278, -265, 109, -265, 279, 280, 281,
+ 310, 453, -16, 282, 536, 221, 163, 238, -267, 378,
+ 330, 385, 210, 530, 516, 130, 477, 166, 246, 252,
+ 247, 391, 227, 163, 396, 397, -239, 186, 348, 235,
+ 57, -241, 193, 399, 480, 55, 197, 439, 440, 199,
+ 237, 229, 200, 55, 283, 187, 110, 188, 249, 304,
+ 305, 306, 307, 309, -240, 317, 318, 211, 320, 321,
+ 55, 361, 19, 20, 254, 255, 256, 201, 258, 259,
+ 261, 202, 55, 160, 161, 162, 208, -238, 243, 315,
+ 209, 316, 284, 225, 285, 286, -237, 486, 487, 298,
290, 291, 292, 293, 294, 295, 296, 297, 257, 434,
- 331, 209, 262, 263, 264, 265, 266, 267, 268, 269,
- 270, 271, 272, 273, 274, 275, 276, 350, 323, 325,
- 326, 327, 328, 329, 441, 389, 310, 213, -265, 57,
- -265, 322, 225, 462, 463, 226, 239, 401, 160, 161,
- 162, 340, 203, 160, 161, 162, 343, 228, 415, 160,
- 161, 162, 366, -268, -268, -268, 347, 368, 185, 250,
- 233, 55, 111, 111, 111, 204, 111, 111, 370, 395,
- 494, 240, 408, 252, 189, 205, 190, 55, 160, 161,
- 162, 353, 354, 132, 111, 191, 413, 192, 360, 146,
- 299, 302, 449, 315, 308, 316, 319, 334, 111, 111,
- 181, 182, 183, 184, 336, 110, 185, 130, 381, 325,
- 384, 384, 520, 160, 161, 162, 339, 341, 160, 161,
- 162, 393, 346, 420, 384, 384, 422, 423, 456, 160,
- 161, 162, 207, 160, 161, 162, 348, 355, 430, 160,
- 161, 162, 162, 461, 492, 356, 464, 160, 161, 162,
- 468, 469, 409, 160, 161, 162, 357, 405, 358, 214,
- 215, 216, 217, 504, 505, 253, 218, 57, 219, 132,
- 373, 362, 483, 484, 379, 513, 160, 161, 162, 160,
- 161, 162, 495, 160, 161, 162, 245, 411, 363, 521,
- 522, -31, 55, 160, 161, 162, 388, 170, 130, 384,
- 398, 507, 338, 437, 531, 509, 510, 349, 160, 161,
- 162, 365, 160, 161, 162, 160, 161, 162, 404, -79,
- 168, -268, 170, 171, 180, 410, 416, 524, 288, 181,
- 182, 183, 184, 384, 384, 185, 367, 160, 161, 162,
- 369, 345, 417, 475, 533, 418, 419, 314, 179, 180,
- 481, 230, 538, 424, 181, 182, 183, 184, 167, 425,
- 185, 429, 426, 351, 427, 168, 169, 170, 171, 381,
- 384, 428, 431, 478, 435, 160, 161, 162, 432, 436,
- 506, 168, 169, 170, 171, 172, 173, 352, 174, 175,
- 176, 177, 178, 179, 180, -191, 438, 518, 448, 181,
- 182, 183, 184, 371, 187, 185, 188, -191, 178, 179,
- 180, 450, 384, 451, 452, 181, 182, 183, 184, 459,
- 532, 185, 466, 214, 215, 216, 217, 470, 111, 467,
- 218, 514, 219, 473, -191, -191, -191, -191, 160, 161,
- 162, -191, 474, -191, 476, 482, -191, 160, 161, 162,
- 490, 491, 387, -191, -191, -191, -191, 160, 161, 162,
- 496, 314, 502, 508, 525, 511, 412, 512, -191, -191,
+ 331, 240, 262, 263, 264, 265, 266, 267, 268, 269,
+ 270, 271, 272, 273, 274, 275, 276, 223, 323, 325,
+ 326, 327, 328, 329, 441, 389, 203, 213, -263, 57,
+ -263, 322, 226, 462, 463, 239, 228, 401, 143, 332,
+ -265, 340, -265, 160, 161, 162, 343, 144, 415, 55,
+ 204, 233, 350, 160, 161, 162, 347, 366, 189, 205,
+ 190, 55, 111, 111, 111, 250, 111, 111, 368, 395,
+ 494, 349, 370, 252, 299, 160, 161, 162, 160, 161,
+ 162, 353, 354, 132, 111, 191, 408, 192, 360, 146,
+ 302, 308, 413, 315, 319, 316, 339, 449, 111, 111,
+ 160, 161, 162, 365, 334, 110, 336, 130, 381, 325,
+ 384, 384, 520, 160, 161, 162, 341, 346, 160, 161,
+ 162, 393, 348, 420, 384, 384, 422, 423, 456, 160,
+ 161, 162, 207, 160, 161, 162, 162, 355, 430, 160,
+ 161, 162, 356, 461, 357, 358, 464, 160, 161, 162,
+ 468, 469, 409, 160, 161, 162, 362, 405, 160, 161,
+ 162, 214, 215, 216, 217, 253, 373, 57, 218, 132,
+ 219, 492, 483, 484, 214, 215, 216, 217, 160, 161,
+ 162, 218, 495, 219, 363, 379, 245, 411, 170, 171,
+ 504, 505, 160, 161, 162, 160, 161, 162, 130, 384,
+ -31, 507, 513, 437, 338, 509, 510, 388, 160, 161,
+ 162, 55, 398, 404, 179, 180, 521, 522, 345, 230,
+ 181, -79, 410, 182, 183, 184, 185, 524, 288, 416,
+ 167, 531, 417, 384, 384, 418, 419, 168, 169, 170,
+ 171, 424, 425, 475, 533, 426, 427, 314, 428, 431,
+ 481, 429, 538, 160, 161, 162, 432, 172, 173, 352,
+ 174, 175, 176, 177, 178, 179, 180, 435, 436, 381,
+ 384, 181, 438, 478, 182, 183, 184, 185, 448, 452,
+ 506, 367, 160, 161, 162, 450, 451, 168, 169, 170,
+ 171, 160, 161, 162, 466, -191, 459, 518, 467, 470,
+ 473, 160, 161, 162, 187, 474, 188, -191, 476, 482,
+ 369, 496, 384, 177, 178, 179, 180, 508, 502, 371,
+ 532, 181, 527, 490, 182, 183, 184, 185, 111, 412,
+ 491, 514, 525, 511, -191, -191, -191, -191, 160, 161,
+ 162, -191, 512, -191, 181, 529, -191, 182, 183, 184,
+ 185, 99, 387, -191, -191, -191, -191, 537, 160, 161,
+ 162, 314, 220, 493, 351, 122, 534, 301, -191, -191,
-191, -230, -191, -191, -191, -191, -191, -191, -191, -191,
- -191, -191, -191, -230, 527, 529, 537, -191, -191, -191,
- -191, 99, 493, -191, -191, 220, -191, 382, 180, -191,
- 301, 170, 171, 181, 182, 183, 184, 534, 122, 185,
- -230, -230, -230, -230, 196, 344, 421, -230, 498, -230,
- 472, 454, -230, 499, 244, 313, 394, 179, 180, -230,
- -230, -230, -230, 181, 182, 183, 184, 0, 0, 185,
- 0, 0, 0, 0, -230, -230, -230, 0, -230, -230,
+ -191, -191, -191, -230, 364, 421, -268, -191, 170, 171,
+ -191, -191, -191, -191, -191, 180, -191, 382, 196, -191,
+ 181, 170, 171, 182, 183, 184, 185, 344, 472, 454,
+ -230, -230, -230, -230, 179, 180, 499, -230, 498, -230,
+ 181, 244, -230, 182, 183, 184, 185, 0, 180, -230,
+ -230, -230, -230, 181, 394, 0, 182, 183, 184, 185,
+ -268, -268, -268, 185, -230, -230, -230, 0, -230, -230,
-230, -230, -230, -230, -230, -230, -230, -230, -230, 160,
- 161, 162, 0, -230, -230, -230, -230, -13, 79, -230,
- -230, 0, -230, 0, 0, -230, 77, 0, 16, 0,
- 17, 18, 19, 20, 21, 364, 0, 22, 23, 24,
- 25, 26, 0, 27, 28, 29, 30, 31, 32, 80,
- 98, 81, 82, 33, 83, 84, 85, 86, 87, 88,
- 160, 161, 162, 89, 90, 91, 92, 34, 0, 35,
- 36, 37, 38, 39, 40, 160, 161, 162, 0, 41,
- 42, 43, 44, 45, 46, 47, 406, 1, 2, 3,
- 4, 5, 6, 48, 0, 160, 161, 162, 0, 0,
- 0, 407, 0, 0, 0, 49, 50, 51, 0, 0,
- 0, 0, 0, 52, 53, -3, 79, 54, 93, 55,
- 56, 414, 0, 0, 77, 0, 16, 0, 17, 18,
- 19, 20, 21, 0, 0, 22, 23, 24, 25, 26,
- 0, 27, 28, 29, 30, 31, 32, 80, 98, 81,
- 82, 33, 83, 84, 85, 86, 87, 88, 0, 0,
- 0, 89, 90, 91, 92, 34, 0, 35, 36, 37,
- 38, 39, 40, 0, 0, 0, 0, 41, 42, 43,
- 44, 45, 46, 47, 0, 0, 0, 0, 0, 0,
- 0, 48, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 49, 50, 51, 0, 0, 0, 0,
- 0, 52, 53, 79, 0, 54, 93, 55, 56, 0,
- 0, 77, 372, 16, 0, 17, 18, 19, 20, 21,
- 0, 0, 22, 23, 24, 25, 26, 0, 27, 28,
- 29, 30, 31, 32, 80, 98, 81, 82, 33, 83,
- 84, 85, 86, 87, 88, 0, 0, 0, 89, 90,
- 91, 92, 34, 0, 35, 36, 37, 38, 39, 40,
- 0, 0, 0, 0, 41, 42, 43, 44, 45, 46,
- 47, 0, 0, 0, 0, 0, 0, 0, 48, 0,
+ 161, 162, 0, -230, 313, 0, -230, -230, -230, -230,
+ -230, 0, -230, -13, 79, -230, 0, 0, 0, 0,
+ 0, 0, 77, 0, 16, 406, 17, 18, 19, 20,
+ 21, 0, 0, 22, 23, 24, 25, 26, 0, 27,
+ 28, 29, 30, 31, 32, 80, 98, 81, 82, 33,
+ 83, 84, 85, 86, 87, 88, 170, 0, 0, 89,
+ 90, 91, 92, 34, 0, 35, 36, 37, 38, 39,
+ 40, 160, 161, 162, 0, 41, 42, 43, 44, 45,
+ 46, 47, 0, 180, 160, 161, 162, 0, 181, 48,
+ 0, 182, 183, 184, 185, 0, 0, 407, 0, 0,
+ 0, 49, 50, 0, 51, 0, 52, 53, -3, 79,
+ 414, 0, 0, 54, 93, 55, 56, 77, 0, 16,
+ 0, 17, 18, 19, 20, 21, 0, 0, 22, 23,
+ 24, 25, 26, 0, 27, 28, 29, 30, 31, 32,
+ 80, 98, 81, 82, 33, 83, 84, 85, 86, 87,
+ 88, 0, 0, 0, 89, 90, 91, 92, 34, 0,
+ 35, 36, 37, 38, 39, 40, 0, 0, 0, 0,
+ 41, 42, 43, 44, 45, 46, 47, 1, 2, 3,
+ 4, 5, 6, 0, 48, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 49, 50, 0, 51,
+ 0, 52, 53, 0, 79, 0, 0, 0, 54, 93,
+ 55, 56, 77, 372, 16, 0, 17, 18, 19, 20,
+ 21, 0, 0, 22, 23, 24, 25, 26, 0, 27,
+ 28, 29, 30, 31, 32, 80, 98, 81, 82, 33,
+ 83, 84, 85, 86, 87, 88, 0, 0, 0, 89,
+ 90, 91, 92, 34, 0, 35, 36, 37, 38, 39,
+ 40, 0, 0, 0, 0, 41, 42, 43, 44, 45,
+ 46, 47, 0, 0, 0, 0, 0, 0, 0, 48,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 49, 50, 51, 0, 0, 0, 0, 0, 52, 53,
- 79, 0, 54, 93, 55, 56, 0, 0, 77, 500,
- 16, 0, 17, 18, 19, 20, 21, 0, 0, 22,
- 23, 24, 25, 26, 0, 27, 28, 29, 30, 31,
- 32, 80, 98, 81, 82, 33, 83, 84, 85, 86,
- 87, 88, 0, 0, 0, 89, 90, 91, 92, 34,
- 0, 35, 36, 37, 38, 39, 40, 0, 0, 0,
- 0, 41, 42, 43, 44, 45, 46, 47, 0, 0,
- 0, 0, 0, 0, 0, 48, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 49, 50, 51,
- 0, 0, 0, 0, 0, 52, 53, 79, 0, 54,
- 93, 55, 56, 0, 0, 77, 503, 16, 0, 17,
- 18, 19, 20, 21, 0, 0, 22, 23, 24, 25,
- 26, 0, 27, 28, 29, 30, 31, 32, 80, 98,
- 81, 82, 33, 83, 84, 85, 86, 87, 88, 0,
- 0, 0, 89, 90, 91, 92, 34, 0, 35, 36,
- 37, 38, 39, 40, 0, 0, 0, 0, 41, 42,
- 43, 44, 45, 46, 47, 0, 0, 0, 0, 0,
- 0, 0, 48, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 49, 50, 51, 0, 0, 0,
- 0, 0, 52, 53, 79, 0, 54, 93, 55, 56,
- 0, 0, 77, 519, 16, 0, 17, 18, 19, 20,
+ 0, 49, 50, 0, 51, 0, 52, 53, 0, 79,
+ 0, 0, 0, 54, 93, 55, 56, 77, 500, 16,
+ 0, 17, 18, 19, 20, 21, 0, 0, 22, 23,
+ 24, 25, 26, 0, 27, 28, 29, 30, 31, 32,
+ 80, 98, 81, 82, 33, 83, 84, 85, 86, 87,
+ 88, 0, 0, 0, 89, 90, 91, 92, 34, 0,
+ 35, 36, 37, 38, 39, 40, 0, 0, 0, 0,
+ 41, 42, 43, 44, 45, 46, 47, 0, 0, 0,
+ 0, 0, 0, 0, 48, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 49, 50, 0, 51,
+ 0, 52, 53, 0, 79, 0, 0, 0, 54, 93,
+ 55, 56, 77, 503, 16, 0, 17, 18, 19, 20,
21, 0, 0, 22, 23, 24, 25, 26, 0, 27,
28, 29, 30, 31, 32, 80, 98, 81, 82, 33,
83, 84, 85, 86, 87, 88, 0, 0, 0, 89,
40, 0, 0, 0, 0, 41, 42, 43, 44, 45,
46, 47, 0, 0, 0, 0, 0, 0, 0, 48,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 49, 50, 51, 0, 0, 0, 0, 0, 52,
- 53, 79, 0, 54, 93, 55, 56, 0, 0, 77,
- 528, 16, 0, 17, 18, 19, 20, 21, 0, 0,
- 22, 23, 24, 25, 26, 0, 27, 28, 29, 30,
- 31, 32, 80, 98, 81, 82, 33, 83, 84, 85,
- 86, 87, 88, 0, 0, 0, 89, 90, 91, 92,
- 34, 0, 35, 36, 37, 38, 39, 40, 0, 0,
- 0, 0, 41, 42, 43, 44, 45, 46, 47, 0,
- 0, 0, 0, 0, 0, 0, 48, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 49, 50,
- 51, 0, 0, 0, 0, 0, 52, 53, 79, 0,
- 54, 93, 55, 56, 0, 0, 77, 0, 16, 0,
- 17, 18, 19, 20, 21, 0, 0, 22, 23, 24,
- 25, 26, 0, 27, 28, 29, 30, 31, 32, 80,
- 98, 81, 82, 33, 83, 84, 85, 86, 87, 88,
- 0, 0, 0, 89, 90, 91, 92, 34, 0, 35,
- 36, 37, 38, 39, 40, 0, 0, 0, 0, 41,
- 42, 43, 44, 45, 46, 47, 0, 0, 535, 0,
- 0, 0, 0, 48, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 49, 50, 51, 0, 0,
- 0, 0, 0, 52, 53, 79, 0, 54, 93, 55,
- 56, 0, 0, 77, 0, 16, 0, 17, 18, 19,
- 20, 21, 0, 0, 22, 23, 24, 25, 26, 0,
- 27, 28, 29, 30, 31, 32, 80, 98, 81, 82,
- 33, 83, 84, 85, 86, 87, 88, 0, 0, 0,
- 89, 90, 91, 92, 34, 0, 35, 36, 37, 38,
- 39, 40, 0, 0, 0, 0, 41, 42, 43, 44,
- 45, 46, 47, 0, 0, 0, 0, 0, 0, 0,
- 48, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 49, 50, 51, 0, 0, 0, 0, 0,
- 52, 53, 79, 0, 54, 93, 55, 56, 0, 0,
- 77, 0, 16, 0, 17, 18, 19, 20, 21, 0,
- 0, 22, 23, 24, 25, 26, 0, 27, 28, 29,
- 30, 31, 32, 80, 0, 81, 82, 33, 83, 84,
- 85, 86, 87, 88, 0, 0, 0, 89, 90, 91,
- 92, 34, 0, 35, 36, 37, 38, 39, 40, 0,
- 0, 0, 0, 41, 42, 43, 44, 45, 46, 47,
- 0, 0, 0, 0, 0, 0, 0, 48, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 49,
- 50, 51, 0, 0, 0, 79, 0, 52, 53, 0,
- 0, 54, 93, 55, 56, 16, 0, 17, 18, 19,
- 20, 21, 0, 0, 22, 23, 24, 25, 26, 0,
- 27, 28, 29, 30, 31, 32, 0, 0, 0, 0,
- 33, 0, 0, -268, 0, 0, 0, 0, 0, 0,
- 168, 169, 170, 171, 34, 0, 35, 36, 37, 38,
- 39, 40, 0, 0, 0, 0, 41, 42, 43, 44,
- 45, 46, 47, 174, 175, 176, 177, 178, 179, 180,
- 48, 0, 0, 0, 181, 182, 183, 184, 0, 0,
- 185, 0, 49, 50, 51, 0, 0, 0, 79, 0,
- 52, 53, 170, 171, 54, -74, 55, 56, 16, 0,
- 17, 18, 19, 20, 21, 0, 0, 22, 23, 24,
- 25, 26, 0, 27, 28, 29, 30, 31, 32, 180,
- 0, 0, 0, 33, 181, 182, 183, 184, 0, 0,
- 185, 168, 169, 170, 171, 0, 0, 34, 0, 35,
- 36, 37, 38, 39, 40, 0, 0, 0, 0, 41,
- 42, 43, 44, 45, 46, 47, 176, 177, 178, 179,
- 180, 0, 0, 48, 0, 181, 182, 183, 184, 0,
- 0, 185, 0, 0, 0, 49, 50, 51, 0, 0,
- 0, 0, 0, 52, 53, 0, -74, 54, 0, 55,
- 56, 77, 0, 16, 0, 17, 18, 19, 20, 21,
- 0, 0, 129, 23, 24, 25, 26, 109, 27, 28,
- 29, 30, 31, 32, 0, 0, 0, 0, 33, 0,
- 0, 0, 0, 0, 0, 168, 169, 170, 171, 0,
- 0, 0, 34, 0, 35, 36, 37, 38, 39, 40,
- 0, 0, 0, 0, 41, 42, 43, 44, 45, 46,
- 47, 177, 178, 179, 180, 0, 0, 0, 48, 181,
- 182, 183, 184, 0, 0, 185, 0, 0, 0, 0,
- 49, 50, 51, 0, 0, 0, 0, 0, 52, 53,
- 0, 0, 54, 0, 55, 56, 77, 0, 16, 0,
- 17, 18, 19, 20, 21, 0, 0, 22, 23, 24,
- 25, 26, 0, 27, 28, 29, 30, 31, 32, 0,
- 0, 0, 0, 33, 0, 0, 0, 0, 0, 0,
- 168, 169, 170, 171, 0, 0, 0, 34, 0, 35,
- 36, 37, 38, 39, 40, 0, 0, 0, 0, 41,
- 42, 43, 44, 45, 46, 47, 0, 0, 179, 180,
- 0, 0, 0, 48, 181, 182, 183, 184, 0, 0,
- 185, 0, 0, 0, 0, 49, 50, 51, 0, 0,
- 0, 0, 0, 52, 53, 0, 0, 54, 0, 55,
- 56, 16, 104, 17, 18, 19, 20, 21, 0, 0,
- 22, 23, 24, 25, 26, 0, 27, 28, 29, 30,
- 31, 32, 0, 0, 0, 0, 33, 0, 0, 0,
- 0, 0, 0, -268, 0, 170, 171, 0, 0, 0,
- 34, 0, 35, 36, 37, 38, 39, 40, 0, 0,
- 0, 0, 41, 42, 43, 44, 45, 46, 47, 0,
- 0, 179, 180, 0, 0, 0, 48, 181, 182, 183,
- 184, 0, 0, 185, 0, 0, 0, 0, 49, 50,
- 51, 0, 0, 0, 0, 0, 52, 53, 0, 0,
- 54, 0, 55, 56, 16, 0, 17, 18, 19, 20,
+ 0, 49, 50, 0, 51, 0, 52, 53, 0, 79,
+ 0, 0, 0, 54, 93, 55, 56, 77, 519, 16,
+ 0, 17, 18, 19, 20, 21, 0, 0, 22, 23,
+ 24, 25, 26, 0, 27, 28, 29, 30, 31, 32,
+ 80, 98, 81, 82, 33, 83, 84, 85, 86, 87,
+ 88, 0, 0, 0, 89, 90, 91, 92, 34, 0,
+ 35, 36, 37, 38, 39, 40, 0, 0, 0, 0,
+ 41, 42, 43, 44, 45, 46, 47, 0, 0, 0,
+ 0, 0, 0, 0, 48, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 49, 50, 0, 51,
+ 0, 52, 53, 0, 79, 0, 0, 0, 54, 93,
+ 55, 56, 77, 528, 16, 0, 17, 18, 19, 20,
21, 0, 0, 22, 23, 24, 25, 26, 0, 27,
- 28, 29, 30, 31, 32, 0, 0, 0, 0, 33,
+ 28, 29, 30, 31, 32, 80, 98, 81, 82, 33,
+ 83, 84, 85, 86, 87, 88, 0, 0, 0, 89,
+ 90, 91, 92, 34, 0, 35, 36, 37, 38, 39,
+ 40, 0, 0, 0, 0, 41, 42, 43, 44, 45,
+ 46, 47, 0, 0, 0, 0, 0, 0, 0, 48,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 34, 0, 35, 36, 37, 38, 39,
+ 0, 49, 50, 0, 51, 0, 52, 53, 0, 79,
+ 0, 0, 0, 54, 93, 55, 56, 77, 0, 16,
+ 0, 17, 18, 19, 20, 21, 0, 0, 22, 23,
+ 24, 25, 26, 0, 27, 28, 29, 30, 31, 32,
+ 80, 98, 81, 82, 33, 83, 84, 85, 86, 87,
+ 88, 0, 0, 0, 89, 90, 91, 92, 34, 0,
+ 35, 36, 37, 38, 39, 40, 0, 0, 0, 0,
+ 41, 42, 43, 44, 45, 46, 47, 0, 0, 535,
+ 0, 0, 0, 0, 48, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 49, 50, 0, 51,
+ 0, 52, 53, 0, 79, 0, 0, 0, 54, 93,
+ 55, 56, 77, 0, 16, 0, 17, 18, 19, 20,
+ 21, 0, 0, 22, 23, 24, 25, 26, 0, 27,
+ 28, 29, 30, 31, 32, 80, 98, 81, 82, 33,
+ 83, 84, 85, 86, 87, 88, 0, 0, 0, 89,
+ 90, 91, 92, 34, 0, 35, 36, 37, 38, 39,
40, 0, 0, 0, 0, 41, 42, 43, 44, 45,
46, 47, 0, 0, 0, 0, 0, 0, 0, 48,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 49, 50, 51, 0, 0, 0, 0, 0, 52,
- 53, 0, 0, 54, 137, 55, 56, 16, 0, 17,
+ 0, 49, 50, 0, 51, 0, 52, 53, 0, 79,
+ 0, 0, 0, 54, 93, 55, 56, 77, 0, 16,
+ 0, 17, 18, 19, 20, 21, 0, 0, 22, 23,
+ 24, 25, 26, 0, 27, 28, 29, 30, 31, 32,
+ 80, 0, 81, 82, 33, 83, 84, 85, 86, 87,
+ 88, 0, 0, 0, 89, 90, 91, 92, 34, 0,
+ 35, 36, 37, 38, 39, 40, 0, 0, 0, 0,
+ 41, 42, 43, 44, 45, 46, 47, 0, 0, 0,
+ 0, 0, 0, 0, 48, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 49, 50, 0, 51,
+ 0, 52, 53, 79, 0, 0, 0, 0, 54, 93,
+ 55, 56, 0, 16, 0, 17, 18, 19, 20, 21,
+ 0, 0, 22, 23, 24, 25, 26, 0, 27, 28,
+ 29, 30, 31, 32, 0, 0, 0, 0, 33, 0,
+ 0, -268, 0, 0, 0, 0, 0, 0, 168, 169,
+ 170, 171, 34, 0, 35, 36, 37, 38, 39, 40,
+ 0, 0, 0, 0, 41, 42, 43, 44, 45, 46,
+ 47, 174, 175, 176, 177, 178, 179, 180, 48, 0,
+ 0, 0, 181, 0, 0, 182, 183, 184, 185, 0,
+ 49, 50, 0, 51, 0, 52, 53, 79, 0, 0,
+ 0, 0, 54, -74, 55, 56, 0, 16, 0, 17,
18, 19, 20, 21, 0, 0, 22, 23, 24, 25,
26, 0, 27, 28, 29, 30, 31, 32, 0, 0,
0, 0, 33, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 34, 0, 35, 36,
+ 168, 169, 170, 171, 0, 0, 34, 0, 35, 36,
37, 38, 39, 40, 0, 0, 0, 0, 41, 42,
- 43, 44, 45, 46, 47, 0, 0, 0, 0, 0,
- 0, 0, 48, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 49, 50, 51, 0, 0, 0,
- 0, 0, 52, 53, 0, 156, 54, 0, 55, 56,
- 16, 0, 17, 18, 19, 20, 21, 0, 0, 22,
+ 43, 44, 45, 46, 47, 176, 177, 178, 179, 180,
+ 0, 0, 48, 0, 181, 0, 0, 182, 183, 184,
+ 185, 0, 0, 0, 49, 50, 0, 51, 0, 52,
+ 53, 0, 0, 0, 0, -74, 54, 0, 55, 56,
+ 77, 0, 16, 0, 17, 18, 19, 20, 21, 0,
+ 0, 129, 23, 24, 25, 26, 109, 27, 28, 29,
+ 30, 31, 32, 0, 0, 0, 0, 33, 0, 0,
+ 0, 0, 0, 0, 168, 169, 170, 171, 0, 0,
+ 0, 34, 0, 35, 36, 37, 38, 39, 40, 0,
+ 0, 0, 0, 41, 42, 43, 44, 45, 46, 47,
+ 0, 178, 179, 180, 0, 0, 0, 48, 181, 0,
+ 0, 182, 183, 184, 185, 0, 0, 0, 0, 49,
+ 50, 0, 51, 0, 52, 53, 0, 0, 0, 0,
+ 0, 54, 0, 55, 56, 77, 0, 16, 0, 17,
+ 18, 19, 20, 21, 0, 0, 22, 23, 24, 25,
+ 26, 0, 27, 28, 29, 30, 31, 32, 0, 0,
+ 0, 0, 33, 0, 0, 0, 0, 168, -268, 170,
+ 171, 0, 0, 0, 0, 0, 34, 0, 35, 36,
+ 37, 38, 39, 40, 0, 0, 0, 0, 41, 42,
+ 43, 44, 45, 46, 47, 179, 180, 0, 0, 0,
+ 0, 181, 48, 0, 182, 183, 184, 185, 0, 0,
+ 0, 0, 0, 0, 49, 50, 0, 51, 0, 52,
+ 53, 0, 0, 0, 0, 0, 54, 0, 55, 56,
+ 16, 104, 17, 18, 19, 20, 21, 0, 0, 22,
23, 24, 25, 26, 0, 27, 28, 29, 30, 31,
32, 0, 0, 0, 0, 33, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 34,
+ 168, 169, 170, 171, 0, 0, 0, 0, 0, 34,
0, 35, 36, 37, 38, 39, 40, 0, 0, 0,
- 0, 41, 42, 43, 44, 45, 46, 47, 0, 0,
- 0, 0, 0, 0, 0, 48, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 49, 50, 51,
- 0, 0, 0, 0, 0, 52, 53, 0, 234, 54,
+ 0, 41, 42, 43, 44, 45, 46, 47, 179, 180,
+ 0, 0, 0, 0, 181, 48, 0, 182, 183, 184,
+ 185, 0, 0, 0, 0, 0, 0, 49, 50, 0,
+ 51, 0, 52, 53, 0, 0, 0, 0, 0, 54,
0, 55, 56, 16, 0, 17, 18, 19, 20, 21,
0, 0, 22, 23, 24, 25, 26, 0, 27, 28,
29, 30, 31, 32, 0, 0, 0, 0, 33, 0,
0, 0, 0, 0, 41, 42, 43, 44, 45, 46,
47, 0, 0, 0, 0, 0, 0, 0, 48, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 49, 50, 51, 0, 0, 0, 0, 0, 52, 53,
- 0, 248, 54, 0, 55, 56, 16, 0, 17, 18,
+ 49, 50, 0, 51, 0, 52, 53, 0, 0, 0,
+ 0, 0, 54, 137, 55, 56, 16, 0, 17, 18,
19, 20, 21, 0, 0, 22, 23, 24, 25, 26,
0, 27, 28, 29, 30, 31, 32, 0, 0, 0,
0, 33, 0, 0, 0, 0, 0, 0, 0, 0,
38, 39, 40, 0, 0, 0, 0, 41, 42, 43,
44, 45, 46, 47, 0, 0, 0, 0, 0, 0,
0, 48, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 49, 50, 51, 0, 0, 0, 0,
- 0, 52, 53, 0, 260, 54, 0, 55, 56, 16,
+ 0, 0, 0, 49, 50, 0, 51, 0, 52, 53,
+ 0, 0, 0, 0, 156, 54, 0, 55, 56, 16,
0, 17, 18, 19, 20, 21, 0, 0, 22, 23,
24, 25, 26, 0, 27, 28, 29, 30, 31, 32,
0, 0, 0, 0, 33, 0, 0, 0, 0, 0,
35, 36, 37, 38, 39, 40, 0, 0, 0, 0,
41, 42, 43, 44, 45, 46, 47, 0, 0, 0,
0, 0, 0, 0, 48, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 49, 50, 51, 0,
- 0, 0, 0, 0, 52, 53, 0, 289, 54, 0,
+ 0, 0, 0, 0, 0, 0, 49, 50, 0, 51,
+ 0, 52, 53, 0, 0, 0, 0, 234, 54, 0,
55, 56, 16, 0, 17, 18, 19, 20, 21, 0,
0, 22, 23, 24, 25, 26, 0, 27, 28, 29,
30, 31, 32, 0, 0, 0, 0, 33, 0, 0,
0, 0, 0, 41, 42, 43, 44, 45, 46, 47,
0, 0, 0, 0, 0, 0, 0, 48, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 49,
- 50, 51, 0, 0, 0, 0, 0, 52, 53, 0,
- 342, 54, 0, 55, 56, 16, 0, 17, 18, 19,
+ 50, 0, 51, 0, 52, 53, 0, 0, 0, 0,
+ 248, 54, 0, 55, 56, 16, 0, 17, 18, 19,
20, 21, 0, 0, 22, 23, 24, 25, 26, 0,
27, 28, 29, 30, 31, 32, 0, 0, 0, 0,
33, 0, 0, 0, 0, 0, 0, 0, 0, 0,
39, 40, 0, 0, 0, 0, 41, 42, 43, 44,
45, 46, 47, 0, 0, 0, 0, 0, 0, 0,
48, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 49, 50, 51, 0, 0, 0, 0, 0,
- 52, 53, 0, 359, 54, 0, 55, 56, 16, 0,
+ 0, 0, 49, 50, 0, 51, 0, 52, 53, 0,
+ 0, 0, 0, 260, 54, 0, 55, 56, 16, 0,
17, 18, 19, 20, 21, 0, 0, 22, 23, 24,
25, 26, 0, 27, 28, 29, 30, 31, 32, 0,
0, 0, 0, 33, 0, 0, 0, 0, 0, 0,
36, 37, 38, 39, 40, 0, 0, 0, 0, 41,
42, 43, 44, 45, 46, 47, 0, 0, 0, 0,
0, 0, 0, 48, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 49, 50, 51, 0, 0,
- 0, 0, 0, 52, 53, 0, 0, 54, 0, 55,
+ 0, 0, 0, 0, 0, 49, 50, 0, 51, 0,
+ 52, 53, 0, 0, 0, 0, 289, 54, 0, 55,
56, 16, 0, 17, 18, 19, 20, 21, 0, 0,
22, 23, 24, 25, 26, 0, 27, 28, 29, 30,
31, 32, 0, 0, 0, 0, 33, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
34, 0, 35, 36, 37, 38, 39, 40, 0, 0,
0, 0, 41, 42, 43, 44, 45, 46, 47, 0,
- 0, 0, 0, 0, 0, 0, 48, 167, 0, 0,
- 0, 0, 0, 0, 168, 169, 170, 171, 49, 50,
- 51, 0, 0, 0, 0, 0, 52, 53, 0, 0,
- 242, 0, 55, 56, 172, 173, 0, 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, 0,
+ 0, 0, 0, 0, 0, 0, 48, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 49, 50,
+ 0, 51, 0, 52, 53, 0, 0, 0, 0, 342,
+ 54, 0, 55, 56, 16, 0, 17, 18, 19, 20,
+ 21, 0, 0, 22, 23, 24, 25, 26, 0, 27,
+ 28, 29, 30, 31, 32, 0, 0, 0, 0, 33,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 34, 0, 35, 36, 37, 38, 39,
+ 40, 0, 0, 0, 0, 41, 42, 43, 44, 45,
+ 46, 47, 0, 0, 0, 0, 0, 0, 0, 48,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 49, 50, 0, 51, 0, 52, 53, 0, 0,
+ 0, 0, 359, 54, 0, 55, 56, 16, 0, 17,
+ 18, 19, 20, 21, 0, 0, 22, 23, 24, 25,
+ 26, 0, 27, 28, 29, 30, 31, 32, 0, 0,
+ 0, 0, 33, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 34, 0, 35, 36,
+ 37, 38, 39, 40, 0, 0, 0, 0, 41, 42,
+ 43, 44, 45, 46, 47, 0, 0, 0, 0, 0,
+ 0, 0, 48, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 49, 50, 0, 51, 0, 52,
+ 53, 0, 0, 0, 0, 0, 54, 0, 55, 56,
+ 16, 0, 17, 18, 19, 20, 21, 0, 0, 22,
+ 23, 24, 25, 26, 0, 27, 28, 29, 30, 31,
+ 32, 0, 0, 0, 0, 33, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 34,
+ 0, 35, 36, 37, 38, 39, 40, 0, 0, 0,
+ 0, 41, 42, 43, 44, 45, 46, 47, 0, 0,
+ 0, 0, 0, 0, 0, 48, 167, 0, 0, 0,
+ 0, 0, 0, 168, 169, 170, 171, 49, 50, 0,
+ 51, 0, 52, 53, 0, 0, 0, 0, 0, 242,
+ 0, 55, 56, 172, 173, 0, 174, 175, 176, 177,
+ 178, 179, 180, 0, 0, 0, 0, 181, 167, 0,
+ 182, 183, 184, 185, 0, 168, 169, 170, 171, 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, 0, 0, 0, 173, 0, 174, 175,
+ 176, 177, 178, 179, 180, 0, 0, 0, 0, 181,
+ 0, 0, 182, 183, 184, 185
};
static const yytype_int16 yycheck[] =
{
15, 126, 317, 9, 40, 335, 426, 9, 11, 115,
- 16, 46, 48, 46, 9, 23, 9, 77, 11, 0,
- 10, 9, 461, 19, 20, 21, 23, 23, 24, 19,
- 20, 21, 11, 23, 24, 141, 20, 43, 15, 16,
- 11, 25, 17, 18, 40, 41, 15, 16, 54, 39,
- 40, 41, 42, 11, 100, 30, 9, 9, 11, 34,
+ 16, 46, 48, 46, 9, 23, 9, 77, 11, 11,
+ 10, 0, 461, 19, 20, 21, 23, 23, 24, 19,
+ 20, 21, 100, 23, 24, 141, 20, 43, 15, 16,
+ 17, 25, 17, 18, 40, 41, 15, 16, 54, 39,
+ 40, 41, 42, 9, 100, 30, 9, 9, 11, 34,
56, 9, 122, 11, 39, 55, 56, 42, 20, 9,
45, 100, 47, 25, 49, 50, 51, 52, 53, 115,
20, 9, 100, 11, 9, 25, 11, 15, 16, 17,
- 69, 421, 100, 21, 533, 98, 100, 133, 69, 101,
- 225, 307, 92, 523, 101, 141, 101, 100, 143, 77,
- 143, 317, 118, 90, 320, 321, 69, 43, 44, 125,
- 126, 69, 100, 100, 454, 102, 77, 15, 16, 9,
- 126, 121, 9, 102, 62, 9, 126, 11, 144, 199,
- 200, 201, 202, 203, 69, 205, 206, 20, 208, 209,
- 102, 103, 45, 104, 160, 161, 162, 100, 164, 165,
- 166, 9, 102, 11, 15, 16, 17, 12, 143, 204,
- 100, 204, 100, 100, 102, 103, 100, 100, 12, 194,
+ 67, 421, 100, 21, 533, 98, 77, 133, 9, 101,
+ 225, 307, 92, 523, 101, 141, 101, 100, 143, 11,
+ 143, 317, 118, 77, 320, 321, 69, 100, 11, 125,
+ 126, 69, 9, 104, 454, 102, 20, 15, 16, 100,
+ 126, 121, 100, 102, 62, 9, 126, 11, 144, 199,
+ 200, 201, 202, 203, 69, 205, 206, 45, 208, 209,
+ 102, 103, 15, 16, 160, 161, 162, 100, 164, 165,
+ 166, 100, 102, 73, 74, 75, 100, 69, 143, 204,
+ 100, 204, 100, 100, 102, 103, 69, 43, 44, 194,
186, 187, 188, 189, 190, 191, 192, 193, 163, 395,
- 226, 100, 167, 168, 169, 170, 171, 172, 173, 174,
+ 226, 101, 167, 168, 169, 170, 171, 172, 173, 174,
175, 176, 177, 178, 179, 180, 181, 12, 214, 215,
216, 217, 218, 219, 102, 530, 67, 101, 9, 225,
- 11, 211, 100, 429, 430, 100, 10, 333, 73, 74,
- 75, 237, 67, 73, 74, 75, 242, 99, 363, 73,
- 74, 75, 12, 93, 94, 95, 252, 12, 98, 69,
- 99, 102, 19, 20, 21, 90, 23, 24, 12, 319,
- 466, 101, 12, 11, 9, 100, 11, 102, 73, 74,
+ 11, 211, 100, 429, 430, 10, 99, 333, 91, 12,
+ 9, 237, 11, 73, 74, 75, 242, 100, 363, 102,
+ 91, 99, 12, 73, 74, 75, 252, 12, 9, 100,
+ 11, 102, 19, 20, 21, 69, 23, 24, 12, 319,
+ 466, 101, 12, 11, 20, 73, 74, 75, 73, 74,
75, 277, 278, 40, 41, 9, 12, 11, 284, 46,
- 20, 20, 12, 318, 90, 318, 100, 100, 55, 56,
- 92, 93, 94, 95, 69, 285, 98, 333, 304, 305,
- 306, 307, 508, 73, 74, 75, 99, 10, 73, 74,
- 75, 317, 23, 373, 320, 321, 376, 377, 424, 73,
- 74, 75, 89, 73, 74, 75, 11, 103, 388, 73,
- 74, 75, 75, 428, 464, 103, 431, 73, 74, 75,
- 435, 436, 348, 73, 74, 75, 103, 337, 103, 39,
- 40, 41, 42, 483, 484, 99, 46, 363, 48, 126,
- 18, 103, 457, 458, 20, 495, 73, 74, 75, 73,
- 74, 75, 467, 73, 74, 75, 143, 352, 100, 509,
- 510, 100, 102, 73, 74, 75, 100, 60, 424, 395,
- 99, 486, 99, 399, 524, 490, 491, 101, 73, 74,
- 75, 101, 73, 74, 75, 73, 74, 75, 23, 99,
- 58, 59, 60, 61, 87, 10, 10, 512, 185, 92,
- 93, 94, 95, 429, 430, 98, 101, 73, 74, 75,
- 101, 99, 10, 448, 529, 10, 10, 204, 86, 87,
- 455, 23, 537, 20, 92, 93, 94, 95, 51, 99,
- 98, 100, 99, 99, 99, 58, 59, 60, 61, 465,
- 466, 99, 99, 453, 99, 73, 74, 75, 101, 99,
- 485, 58, 59, 60, 61, 78, 79, 80, 81, 82,
- 83, 84, 85, 86, 87, 0, 99, 502, 9, 92,
- 93, 94, 95, 101, 9, 98, 11, 12, 85, 86,
- 87, 10, 508, 99, 101, 92, 93, 94, 95, 9,
- 525, 98, 100, 39, 40, 41, 42, 25, 285, 99,
- 46, 496, 48, 77, 39, 40, 41, 42, 73, 74,
- 75, 46, 99, 48, 71, 101, 51, 73, 74, 75,
- 99, 99, 309, 58, 59, 60, 61, 73, 74, 75,
- 78, 318, 9, 100, 70, 101, 101, 99, 73, 74,
+ 20, 91, 12, 318, 100, 318, 99, 12, 55, 56,
+ 73, 74, 75, 101, 100, 285, 69, 333, 304, 305,
+ 306, 307, 508, 73, 74, 75, 10, 23, 73, 74,
+ 75, 317, 11, 373, 320, 321, 376, 377, 424, 73,
+ 74, 75, 89, 73, 74, 75, 75, 103, 388, 73,
+ 74, 75, 103, 428, 103, 103, 431, 73, 74, 75,
+ 435, 436, 348, 73, 74, 75, 103, 337, 73, 74,
+ 75, 39, 40, 41, 42, 99, 18, 363, 46, 126,
+ 48, 464, 457, 458, 39, 40, 41, 42, 73, 74,
+ 75, 46, 467, 48, 100, 20, 143, 352, 60, 61,
+ 483, 484, 73, 74, 75, 73, 74, 75, 424, 395,
+ 100, 486, 495, 399, 99, 490, 491, 100, 73, 74,
+ 75, 102, 99, 23, 86, 87, 509, 510, 99, 23,
+ 92, 99, 10, 95, 96, 97, 98, 512, 185, 10,
+ 51, 524, 10, 429, 430, 10, 10, 58, 59, 60,
+ 61, 20, 99, 448, 529, 99, 99, 204, 99, 99,
+ 455, 100, 537, 73, 74, 75, 101, 78, 79, 80,
+ 81, 82, 83, 84, 85, 86, 87, 99, 99, 465,
+ 466, 92, 99, 453, 95, 96, 97, 98, 9, 101,
+ 485, 101, 73, 74, 75, 10, 99, 58, 59, 60,
+ 61, 73, 74, 75, 100, 0, 9, 502, 99, 25,
+ 77, 73, 74, 75, 9, 99, 11, 12, 71, 101,
+ 101, 78, 508, 84, 85, 86, 87, 100, 9, 101,
+ 525, 92, 19, 99, 95, 96, 97, 98, 285, 101,
+ 99, 496, 70, 101, 39, 40, 41, 42, 73, 74,
+ 75, 46, 99, 48, 92, 99, 51, 95, 96, 97,
+ 98, 12, 309, 58, 59, 60, 61, 99, 73, 74,
+ 75, 318, 98, 465, 99, 33, 530, 196, 73, 74,
75, 0, 77, 78, 79, 80, 81, 82, 83, 84,
- 85, 86, 87, 12, 19, 99, 99, 92, 93, 94,
- 95, 12, 465, 98, 99, 98, 101, 305, 87, 104,
- 196, 60, 61, 92, 93, 94, 95, 530, 33, 98,
- 39, 40, 41, 42, 82, 244, 375, 46, 472, 48,
- 442, 422, 51, 473, 143, 204, 318, 86, 87, 58,
- 59, 60, 61, 92, 93, 94, 95, -1, -1, 98,
- -1, -1, -1, -1, 73, 74, 75, -1, 77, 78,
+ 85, 86, 87, 12, 99, 375, 58, 92, 60, 61,
+ 95, 96, 97, 98, 99, 87, 101, 305, 82, 104,
+ 92, 60, 61, 95, 96, 97, 98, 244, 442, 422,
+ 39, 40, 41, 42, 86, 87, 473, 46, 472, 48,
+ 92, 143, 51, 95, 96, 97, 98, -1, 87, 58,
+ 59, 60, 61, 92, 318, -1, 95, 96, 97, 98,
+ 95, 96, 97, 98, 73, 74, 75, -1, 77, 78,
79, 80, 81, 82, 83, 84, 85, 86, 87, 73,
- 74, 75, -1, 92, 93, 94, 95, 0, 1, 98,
- 99, -1, 101, -1, -1, 104, 9, -1, 11, -1,
- 13, 14, 15, 16, 17, 99, -1, 20, 21, 22,
- 23, 24, -1, 26, 27, 28, 29, 30, 31, 32,
- 33, 34, 35, 36, 37, 38, 39, 40, 41, 42,
- 73, 74, 75, 46, 47, 48, 49, 50, -1, 52,
- 53, 54, 55, 56, 57, 73, 74, 75, -1, 62,
- 63, 64, 65, 66, 67, 68, 99, 3, 4, 5,
- 6, 7, 8, 76, -1, 73, 74, 75, -1, -1,
- -1, 99, -1, -1, -1, 88, 89, 90, -1, -1,
- -1, -1, -1, 96, 97, 0, 1, 100, 101, 102,
- 103, 99, -1, -1, 9, -1, 11, -1, 13, 14,
- 15, 16, 17, -1, -1, 20, 21, 22, 23, 24,
- -1, 26, 27, 28, 29, 30, 31, 32, 33, 34,
- 35, 36, 37, 38, 39, 40, 41, 42, -1, -1,
- -1, 46, 47, 48, 49, 50, -1, 52, 53, 54,
- 55, 56, 57, -1, -1, -1, -1, 62, 63, 64,
- 65, 66, 67, 68, -1, -1, -1, -1, -1, -1,
- -1, 76, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, 88, 89, 90, -1, -1, -1, -1,
- -1, 96, 97, 1, -1, 100, 101, 102, 103, -1,
- -1, 9, 10, 11, -1, 13, 14, 15, 16, 17,
- -1, -1, 20, 21, 22, 23, 24, -1, 26, 27,
- 28, 29, 30, 31, 32, 33, 34, 35, 36, 37,
- 38, 39, 40, 41, 42, -1, -1, -1, 46, 47,
- 48, 49, 50, -1, 52, 53, 54, 55, 56, 57,
- -1, -1, -1, -1, 62, 63, 64, 65, 66, 67,
- 68, -1, -1, -1, -1, -1, -1, -1, 76, -1,
+ 74, 75, -1, 92, 204, -1, 95, 96, 97, 98,
+ 99, -1, 101, 0, 1, 104, -1, -1, -1, -1,
+ -1, -1, 9, -1, 11, 99, 13, 14, 15, 16,
+ 17, -1, -1, 20, 21, 22, 23, 24, -1, 26,
+ 27, 28, 29, 30, 31, 32, 33, 34, 35, 36,
+ 37, 38, 39, 40, 41, 42, 60, -1, -1, 46,
+ 47, 48, 49, 50, -1, 52, 53, 54, 55, 56,
+ 57, 73, 74, 75, -1, 62, 63, 64, 65, 66,
+ 67, 68, -1, 87, 73, 74, 75, -1, 92, 76,
+ -1, 95, 96, 97, 98, -1, -1, 99, -1, -1,
+ -1, 88, 89, -1, 91, -1, 93, 94, 0, 1,
+ 99, -1, -1, 100, 101, 102, 103, 9, -1, 11,
+ -1, 13, 14, 15, 16, 17, -1, -1, 20, 21,
+ 22, 23, 24, -1, 26, 27, 28, 29, 30, 31,
+ 32, 33, 34, 35, 36, 37, 38, 39, 40, 41,
+ 42, -1, -1, -1, 46, 47, 48, 49, 50, -1,
+ 52, 53, 54, 55, 56, 57, -1, -1, -1, -1,
+ 62, 63, 64, 65, 66, 67, 68, 3, 4, 5,
+ 6, 7, 8, -1, 76, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 88, 89, -1, 91,
+ -1, 93, 94, -1, 1, -1, -1, -1, 100, 101,
+ 102, 103, 9, 10, 11, -1, 13, 14, 15, 16,
+ 17, -1, -1, 20, 21, 22, 23, 24, -1, 26,
+ 27, 28, 29, 30, 31, 32, 33, 34, 35, 36,
+ 37, 38, 39, 40, 41, 42, -1, -1, -1, 46,
+ 47, 48, 49, 50, -1, 52, 53, 54, 55, 56,
+ 57, -1, -1, -1, -1, 62, 63, 64, 65, 66,
+ 67, 68, -1, -1, -1, -1, -1, -1, -1, 76,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- 88, 89, 90, -1, -1, -1, -1, -1, 96, 97,
- 1, -1, 100, 101, 102, 103, -1, -1, 9, 10,
- 11, -1, 13, 14, 15, 16, 17, -1, -1, 20,
- 21, 22, 23, 24, -1, 26, 27, 28, 29, 30,
- 31, 32, 33, 34, 35, 36, 37, 38, 39, 40,
- 41, 42, -1, -1, -1, 46, 47, 48, 49, 50,
- -1, 52, 53, 54, 55, 56, 57, -1, -1, -1,
- -1, 62, 63, 64, 65, 66, 67, 68, -1, -1,
- -1, -1, -1, -1, -1, 76, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, 88, 89, 90,
- -1, -1, -1, -1, -1, 96, 97, 1, -1, 100,
- 101, 102, 103, -1, -1, 9, 10, 11, -1, 13,
- 14, 15, 16, 17, -1, -1, 20, 21, 22, 23,
- 24, -1, 26, 27, 28, 29, 30, 31, 32, 33,
- 34, 35, 36, 37, 38, 39, 40, 41, 42, -1,
- -1, -1, 46, 47, 48, 49, 50, -1, 52, 53,
- 54, 55, 56, 57, -1, -1, -1, -1, 62, 63,
- 64, 65, 66, 67, 68, -1, -1, -1, -1, -1,
- -1, -1, 76, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, 88, 89, 90, -1, -1, -1,
- -1, -1, 96, 97, 1, -1, 100, 101, 102, 103,
- -1, -1, 9, 10, 11, -1, 13, 14, 15, 16,
+ -1, 88, 89, -1, 91, -1, 93, 94, -1, 1,
+ -1, -1, -1, 100, 101, 102, 103, 9, 10, 11,
+ -1, 13, 14, 15, 16, 17, -1, -1, 20, 21,
+ 22, 23, 24, -1, 26, 27, 28, 29, 30, 31,
+ 32, 33, 34, 35, 36, 37, 38, 39, 40, 41,
+ 42, -1, -1, -1, 46, 47, 48, 49, 50, -1,
+ 52, 53, 54, 55, 56, 57, -1, -1, -1, -1,
+ 62, 63, 64, 65, 66, 67, 68, -1, -1, -1,
+ -1, -1, -1, -1, 76, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 88, 89, -1, 91,
+ -1, 93, 94, -1, 1, -1, -1, -1, 100, 101,
+ 102, 103, 9, 10, 11, -1, 13, 14, 15, 16,
17, -1, -1, 20, 21, 22, 23, 24, -1, 26,
27, 28, 29, 30, 31, 32, 33, 34, 35, 36,
37, 38, 39, 40, 41, 42, -1, -1, -1, 46,
57, -1, -1, -1, -1, 62, 63, 64, 65, 66,
67, 68, -1, -1, -1, -1, -1, -1, -1, 76,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, 88, 89, 90, -1, -1, -1, -1, -1, 96,
- 97, 1, -1, 100, 101, 102, 103, -1, -1, 9,
- 10, 11, -1, 13, 14, 15, 16, 17, -1, -1,
- 20, 21, 22, 23, 24, -1, 26, 27, 28, 29,
- 30, 31, 32, 33, 34, 35, 36, 37, 38, 39,
- 40, 41, 42, -1, -1, -1, 46, 47, 48, 49,
- 50, -1, 52, 53, 54, 55, 56, 57, -1, -1,
- -1, -1, 62, 63, 64, 65, 66, 67, 68, -1,
- -1, -1, -1, -1, -1, -1, 76, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, 88, 89,
- 90, -1, -1, -1, -1, -1, 96, 97, 1, -1,
- 100, 101, 102, 103, -1, -1, 9, -1, 11, -1,
- 13, 14, 15, 16, 17, -1, -1, 20, 21, 22,
- 23, 24, -1, 26, 27, 28, 29, 30, 31, 32,
- 33, 34, 35, 36, 37, 38, 39, 40, 41, 42,
- -1, -1, -1, 46, 47, 48, 49, 50, -1, 52,
- 53, 54, 55, 56, 57, -1, -1, -1, -1, 62,
- 63, 64, 65, 66, 67, 68, -1, -1, 71, -1,
- -1, -1, -1, 76, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 88, 89, 90, -1, -1,
- -1, -1, -1, 96, 97, 1, -1, 100, 101, 102,
- 103, -1, -1, 9, -1, 11, -1, 13, 14, 15,
- 16, 17, -1, -1, 20, 21, 22, 23, 24, -1,
- 26, 27, 28, 29, 30, 31, 32, 33, 34, 35,
- 36, 37, 38, 39, 40, 41, 42, -1, -1, -1,
- 46, 47, 48, 49, 50, -1, 52, 53, 54, 55,
- 56, 57, -1, -1, -1, -1, 62, 63, 64, 65,
- 66, 67, 68, -1, -1, -1, -1, -1, -1, -1,
- 76, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, 88, 89, 90, -1, -1, -1, -1, -1,
- 96, 97, 1, -1, 100, 101, 102, 103, -1, -1,
- 9, -1, 11, -1, 13, 14, 15, 16, 17, -1,
- -1, 20, 21, 22, 23, 24, -1, 26, 27, 28,
- 29, 30, 31, 32, -1, 34, 35, 36, 37, 38,
- 39, 40, 41, 42, -1, -1, -1, 46, 47, 48,
- 49, 50, -1, 52, 53, 54, 55, 56, 57, -1,
- -1, -1, -1, 62, 63, 64, 65, 66, 67, 68,
- -1, -1, -1, -1, -1, -1, -1, 76, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, 88,
- 89, 90, -1, -1, -1, 1, -1, 96, 97, -1,
- -1, 100, 101, 102, 103, 11, -1, 13, 14, 15,
- 16, 17, -1, -1, 20, 21, 22, 23, 24, -1,
- 26, 27, 28, 29, 30, 31, -1, -1, -1, -1,
- 36, -1, -1, 51, -1, -1, -1, -1, -1, -1,
- 58, 59, 60, 61, 50, -1, 52, 53, 54, 55,
- 56, 57, -1, -1, -1, -1, 62, 63, 64, 65,
- 66, 67, 68, 81, 82, 83, 84, 85, 86, 87,
- 76, -1, -1, -1, 92, 93, 94, 95, -1, -1,
- 98, -1, 88, 89, 90, -1, -1, -1, 1, -1,
- 96, 97, 60, 61, 100, 101, 102, 103, 11, -1,
- 13, 14, 15, 16, 17, -1, -1, 20, 21, 22,
- 23, 24, -1, 26, 27, 28, 29, 30, 31, 87,
- -1, -1, -1, 36, 92, 93, 94, 95, -1, -1,
- 98, 58, 59, 60, 61, -1, -1, 50, -1, 52,
- 53, 54, 55, 56, 57, -1, -1, -1, -1, 62,
- 63, 64, 65, 66, 67, 68, 83, 84, 85, 86,
- 87, -1, -1, 76, -1, 92, 93, 94, 95, -1,
- -1, 98, -1, -1, -1, 88, 89, 90, -1, -1,
- -1, -1, -1, 96, 97, -1, 99, 100, -1, 102,
- 103, 9, -1, 11, -1, 13, 14, 15, 16, 17,
- -1, -1, 20, 21, 22, 23, 24, 25, 26, 27,
- 28, 29, 30, 31, -1, -1, -1, -1, 36, -1,
- -1, -1, -1, -1, -1, 58, 59, 60, 61, -1,
- -1, -1, 50, -1, 52, 53, 54, 55, 56, 57,
- -1, -1, -1, -1, 62, 63, 64, 65, 66, 67,
- 68, 84, 85, 86, 87, -1, -1, -1, 76, 92,
- 93, 94, 95, -1, -1, 98, -1, -1, -1, -1,
- 88, 89, 90, -1, -1, -1, -1, -1, 96, 97,
- -1, -1, 100, -1, 102, 103, 9, -1, 11, -1,
- 13, 14, 15, 16, 17, -1, -1, 20, 21, 22,
- 23, 24, -1, 26, 27, 28, 29, 30, 31, -1,
- -1, -1, -1, 36, -1, -1, -1, -1, -1, -1,
- 58, 59, 60, 61, -1, -1, -1, 50, -1, 52,
- 53, 54, 55, 56, 57, -1, -1, -1, -1, 62,
- 63, 64, 65, 66, 67, 68, -1, -1, 86, 87,
- -1, -1, -1, 76, 92, 93, 94, 95, -1, -1,
- 98, -1, -1, -1, -1, 88, 89, 90, -1, -1,
- -1, -1, -1, 96, 97, -1, -1, 100, -1, 102,
- 103, 11, 12, 13, 14, 15, 16, 17, -1, -1,
- 20, 21, 22, 23, 24, -1, 26, 27, 28, 29,
- 30, 31, -1, -1, -1, -1, 36, -1, -1, -1,
- -1, -1, -1, 58, -1, 60, 61, -1, -1, -1,
- 50, -1, 52, 53, 54, 55, 56, 57, -1, -1,
- -1, -1, 62, 63, 64, 65, 66, 67, 68, -1,
- -1, 86, 87, -1, -1, -1, 76, 92, 93, 94,
- 95, -1, -1, 98, -1, -1, -1, -1, 88, 89,
- 90, -1, -1, -1, -1, -1, 96, 97, -1, -1,
- 100, -1, 102, 103, 11, -1, 13, 14, 15, 16,
+ -1, 88, 89, -1, 91, -1, 93, 94, -1, 1,
+ -1, -1, -1, 100, 101, 102, 103, 9, 10, 11,
+ -1, 13, 14, 15, 16, 17, -1, -1, 20, 21,
+ 22, 23, 24, -1, 26, 27, 28, 29, 30, 31,
+ 32, 33, 34, 35, 36, 37, 38, 39, 40, 41,
+ 42, -1, -1, -1, 46, 47, 48, 49, 50, -1,
+ 52, 53, 54, 55, 56, 57, -1, -1, -1, -1,
+ 62, 63, 64, 65, 66, 67, 68, -1, -1, -1,
+ -1, -1, -1, -1, 76, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 88, 89, -1, 91,
+ -1, 93, 94, -1, 1, -1, -1, -1, 100, 101,
+ 102, 103, 9, 10, 11, -1, 13, 14, 15, 16,
17, -1, -1, 20, 21, 22, 23, 24, -1, 26,
- 27, 28, 29, 30, 31, -1, -1, -1, -1, 36,
+ 27, 28, 29, 30, 31, 32, 33, 34, 35, 36,
+ 37, 38, 39, 40, 41, 42, -1, -1, -1, 46,
+ 47, 48, 49, 50, -1, 52, 53, 54, 55, 56,
+ 57, -1, -1, -1, -1, 62, 63, 64, 65, 66,
+ 67, 68, -1, -1, -1, -1, -1, -1, -1, 76,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, 50, -1, 52, 53, 54, 55, 56,
+ -1, 88, 89, -1, 91, -1, 93, 94, -1, 1,
+ -1, -1, -1, 100, 101, 102, 103, 9, -1, 11,
+ -1, 13, 14, 15, 16, 17, -1, -1, 20, 21,
+ 22, 23, 24, -1, 26, 27, 28, 29, 30, 31,
+ 32, 33, 34, 35, 36, 37, 38, 39, 40, 41,
+ 42, -1, -1, -1, 46, 47, 48, 49, 50, -1,
+ 52, 53, 54, 55, 56, 57, -1, -1, -1, -1,
+ 62, 63, 64, 65, 66, 67, 68, -1, -1, 71,
+ -1, -1, -1, -1, 76, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 88, 89, -1, 91,
+ -1, 93, 94, -1, 1, -1, -1, -1, 100, 101,
+ 102, 103, 9, -1, 11, -1, 13, 14, 15, 16,
+ 17, -1, -1, 20, 21, 22, 23, 24, -1, 26,
+ 27, 28, 29, 30, 31, 32, 33, 34, 35, 36,
+ 37, 38, 39, 40, 41, 42, -1, -1, -1, 46,
+ 47, 48, 49, 50, -1, 52, 53, 54, 55, 56,
57, -1, -1, -1, -1, 62, 63, 64, 65, 66,
67, 68, -1, -1, -1, -1, -1, -1, -1, 76,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, 88, 89, 90, -1, -1, -1, -1, -1, 96,
- 97, -1, -1, 100, 101, 102, 103, 11, -1, 13,
+ -1, 88, 89, -1, 91, -1, 93, 94, -1, 1,
+ -1, -1, -1, 100, 101, 102, 103, 9, -1, 11,
+ -1, 13, 14, 15, 16, 17, -1, -1, 20, 21,
+ 22, 23, 24, -1, 26, 27, 28, 29, 30, 31,
+ 32, -1, 34, 35, 36, 37, 38, 39, 40, 41,
+ 42, -1, -1, -1, 46, 47, 48, 49, 50, -1,
+ 52, 53, 54, 55, 56, 57, -1, -1, -1, -1,
+ 62, 63, 64, 65, 66, 67, 68, -1, -1, -1,
+ -1, -1, -1, -1, 76, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 88, 89, -1, 91,
+ -1, 93, 94, 1, -1, -1, -1, -1, 100, 101,
+ 102, 103, -1, 11, -1, 13, 14, 15, 16, 17,
+ -1, -1, 20, 21, 22, 23, 24, -1, 26, 27,
+ 28, 29, 30, 31, -1, -1, -1, -1, 36, -1,
+ -1, 51, -1, -1, -1, -1, -1, -1, 58, 59,
+ 60, 61, 50, -1, 52, 53, 54, 55, 56, 57,
+ -1, -1, -1, -1, 62, 63, 64, 65, 66, 67,
+ 68, 81, 82, 83, 84, 85, 86, 87, 76, -1,
+ -1, -1, 92, -1, -1, 95, 96, 97, 98, -1,
+ 88, 89, -1, 91, -1, 93, 94, 1, -1, -1,
+ -1, -1, 100, 101, 102, 103, -1, 11, -1, 13,
14, 15, 16, 17, -1, -1, 20, 21, 22, 23,
24, -1, 26, 27, 28, 29, 30, 31, -1, -1,
-1, -1, 36, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, 50, -1, 52, 53,
+ 58, 59, 60, 61, -1, -1, 50, -1, 52, 53,
54, 55, 56, 57, -1, -1, -1, -1, 62, 63,
- 64, 65, 66, 67, 68, -1, -1, -1, -1, -1,
- -1, -1, 76, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, 88, 89, 90, -1, -1, -1,
- -1, -1, 96, 97, -1, 99, 100, -1, 102, 103,
- 11, -1, 13, 14, 15, 16, 17, -1, -1, 20,
+ 64, 65, 66, 67, 68, 83, 84, 85, 86, 87,
+ -1, -1, 76, -1, 92, -1, -1, 95, 96, 97,
+ 98, -1, -1, -1, 88, 89, -1, 91, -1, 93,
+ 94, -1, -1, -1, -1, 99, 100, -1, 102, 103,
+ 9, -1, 11, -1, 13, 14, 15, 16, 17, -1,
+ -1, 20, 21, 22, 23, 24, 25, 26, 27, 28,
+ 29, 30, 31, -1, -1, -1, -1, 36, -1, -1,
+ -1, -1, -1, -1, 58, 59, 60, 61, -1, -1,
+ -1, 50, -1, 52, 53, 54, 55, 56, 57, -1,
+ -1, -1, -1, 62, 63, 64, 65, 66, 67, 68,
+ -1, 85, 86, 87, -1, -1, -1, 76, 92, -1,
+ -1, 95, 96, 97, 98, -1, -1, -1, -1, 88,
+ 89, -1, 91, -1, 93, 94, -1, -1, -1, -1,
+ -1, 100, -1, 102, 103, 9, -1, 11, -1, 13,
+ 14, 15, 16, 17, -1, -1, 20, 21, 22, 23,
+ 24, -1, 26, 27, 28, 29, 30, 31, -1, -1,
+ -1, -1, 36, -1, -1, -1, -1, 58, 59, 60,
+ 61, -1, -1, -1, -1, -1, 50, -1, 52, 53,
+ 54, 55, 56, 57, -1, -1, -1, -1, 62, 63,
+ 64, 65, 66, 67, 68, 86, 87, -1, -1, -1,
+ -1, 92, 76, -1, 95, 96, 97, 98, -1, -1,
+ -1, -1, -1, -1, 88, 89, -1, 91, -1, 93,
+ 94, -1, -1, -1, -1, -1, 100, -1, 102, 103,
+ 11, 12, 13, 14, 15, 16, 17, -1, -1, 20,
21, 22, 23, 24, -1, 26, 27, 28, 29, 30,
31, -1, -1, -1, -1, 36, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, 50,
+ 58, 59, 60, 61, -1, -1, -1, -1, -1, 50,
-1, 52, 53, 54, 55, 56, 57, -1, -1, -1,
- -1, 62, 63, 64, 65, 66, 67, 68, -1, -1,
- -1, -1, -1, -1, -1, 76, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, 88, 89, 90,
- -1, -1, -1, -1, -1, 96, 97, -1, 99, 100,
+ -1, 62, 63, 64, 65, 66, 67, 68, 86, 87,
+ -1, -1, -1, -1, 92, 76, -1, 95, 96, 97,
+ 98, -1, -1, -1, -1, -1, -1, 88, 89, -1,
+ 91, -1, 93, 94, -1, -1, -1, -1, -1, 100,
-1, 102, 103, 11, -1, 13, 14, 15, 16, 17,
-1, -1, 20, 21, 22, 23, 24, -1, 26, 27,
28, 29, 30, 31, -1, -1, -1, -1, 36, -1,
-1, -1, -1, -1, 62, 63, 64, 65, 66, 67,
68, -1, -1, -1, -1, -1, -1, -1, 76, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- 88, 89, 90, -1, -1, -1, -1, -1, 96, 97,
- -1, 99, 100, -1, 102, 103, 11, -1, 13, 14,
+ 88, 89, -1, 91, -1, 93, 94, -1, -1, -1,
+ -1, -1, 100, 101, 102, 103, 11, -1, 13, 14,
15, 16, 17, -1, -1, 20, 21, 22, 23, 24,
-1, 26, 27, 28, 29, 30, 31, -1, -1, -1,
-1, 36, -1, -1, -1, -1, -1, -1, -1, -1,
55, 56, 57, -1, -1, -1, -1, 62, 63, 64,
65, 66, 67, 68, -1, -1, -1, -1, -1, -1,
-1, 76, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, 88, 89, 90, -1, -1, -1, -1,
- -1, 96, 97, -1, 99, 100, -1, 102, 103, 11,
+ -1, -1, -1, 88, 89, -1, 91, -1, 93, 94,
+ -1, -1, -1, -1, 99, 100, -1, 102, 103, 11,
-1, 13, 14, 15, 16, 17, -1, -1, 20, 21,
22, 23, 24, -1, 26, 27, 28, 29, 30, 31,
-1, -1, -1, -1, 36, -1, -1, -1, -1, -1,
52, 53, 54, 55, 56, 57, -1, -1, -1, -1,
62, 63, 64, 65, 66, 67, 68, -1, -1, -1,
-1, -1, -1, -1, 76, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, 88, 89, 90, -1,
- -1, -1, -1, -1, 96, 97, -1, 99, 100, -1,
+ -1, -1, -1, -1, -1, -1, 88, 89, -1, 91,
+ -1, 93, 94, -1, -1, -1, -1, 99, 100, -1,
102, 103, 11, -1, 13, 14, 15, 16, 17, -1,
-1, 20, 21, 22, 23, 24, -1, 26, 27, 28,
29, 30, 31, -1, -1, -1, -1, 36, -1, -1,
-1, -1, -1, 62, 63, 64, 65, 66, 67, 68,
-1, -1, -1, -1, -1, -1, -1, 76, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, 88,
- 89, 90, -1, -1, -1, -1, -1, 96, 97, -1,
+ 89, -1, 91, -1, 93, 94, -1, -1, -1, -1,
99, 100, -1, 102, 103, 11, -1, 13, 14, 15,
16, 17, -1, -1, 20, 21, 22, 23, 24, -1,
26, 27, 28, 29, 30, 31, -1, -1, -1, -1,
56, 57, -1, -1, -1, -1, 62, 63, 64, 65,
66, 67, 68, -1, -1, -1, -1, -1, -1, -1,
76, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, 88, 89, 90, -1, -1, -1, -1, -1,
- 96, 97, -1, 99, 100, -1, 102, 103, 11, -1,
+ -1, -1, 88, 89, -1, 91, -1, 93, 94, -1,
+ -1, -1, -1, 99, 100, -1, 102, 103, 11, -1,
13, 14, 15, 16, 17, -1, -1, 20, 21, 22,
23, 24, -1, 26, 27, 28, 29, 30, 31, -1,
-1, -1, -1, 36, -1, -1, -1, -1, -1, -1,
53, 54, 55, 56, 57, -1, -1, -1, -1, 62,
63, 64, 65, 66, 67, 68, -1, -1, -1, -1,
-1, -1, -1, 76, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 88, 89, 90, -1, -1,
- -1, -1, -1, 96, 97, -1, -1, 100, -1, 102,
+ -1, -1, -1, -1, -1, 88, 89, -1, 91, -1,
+ 93, 94, -1, -1, -1, -1, 99, 100, -1, 102,
103, 11, -1, 13, 14, 15, 16, 17, -1, -1,
20, 21, 22, 23, 24, -1, 26, 27, 28, 29,
30, 31, -1, -1, -1, -1, 36, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
50, -1, 52, 53, 54, 55, 56, 57, -1, -1,
-1, -1, 62, 63, 64, 65, 66, 67, 68, -1,
- -1, -1, -1, -1, -1, -1, 76, 51, -1, -1,
- -1, -1, -1, -1, 58, 59, 60, 61, 88, 89,
- 90, -1, -1, -1, -1, -1, 96, 97, -1, -1,
- 100, -1, 102, 103, 78, 79, -1, 81, 82, 83,
- 84, 85, 86, 87, -1, -1, -1, -1, 92, 93,
- 94, 95, 51, -1, 98, -1, -1, -1, -1, 58,
- 59, 60, 61, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 76, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 88, 89,
+ -1, 91, -1, 93, 94, -1, -1, -1, -1, 99,
+ 100, -1, 102, 103, 11, -1, 13, 14, 15, 16,
+ 17, -1, -1, 20, 21, 22, 23, 24, -1, 26,
+ 27, 28, 29, 30, 31, -1, -1, -1, -1, 36,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 50, -1, 52, 53, 54, 55, 56,
+ 57, -1, -1, -1, -1, 62, 63, 64, 65, 66,
+ 67, 68, -1, -1, -1, -1, -1, -1, -1, 76,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, 88, 89, -1, 91, -1, 93, 94, -1, -1,
+ -1, -1, 99, 100, -1, 102, 103, 11, -1, 13,
+ 14, 15, 16, 17, -1, -1, 20, 21, 22, 23,
+ 24, -1, 26, 27, 28, 29, 30, 31, -1, -1,
+ -1, -1, 36, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 50, -1, 52, 53,
+ 54, 55, 56, 57, -1, -1, -1, -1, 62, 63,
+ 64, 65, 66, 67, 68, -1, -1, -1, -1, -1,
+ -1, -1, 76, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 88, 89, -1, 91, -1, 93,
+ 94, -1, -1, -1, -1, -1, 100, -1, 102, 103,
+ 11, -1, 13, 14, 15, 16, 17, -1, -1, 20,
+ 21, 22, 23, 24, -1, 26, 27, 28, 29, 30,
+ 31, -1, -1, -1, -1, 36, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 50,
+ -1, 52, 53, 54, 55, 56, 57, -1, -1, -1,
+ -1, 62, 63, 64, 65, 66, 67, 68, -1, -1,
+ -1, -1, -1, -1, -1, 76, 51, -1, -1, -1,
+ -1, -1, -1, 58, 59, 60, 61, 88, 89, -1,
+ 91, -1, 93, 94, -1, -1, -1, -1, -1, 100,
+ -1, 102, 103, 78, 79, -1, 81, 82, 83, 84,
+ 85, 86, 87, -1, -1, -1, -1, 92, 51, -1,
+ 95, 96, 97, 98, -1, 58, 59, 60, 61, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- 79, -1, 81, 82, 83, 84, 85, 86, 87, -1,
- -1, -1, -1, 92, 93, 94, 95, -1, -1, 98
+ -1, -1, -1, -1, -1, -1, 79, -1, 81, 82,
+ 83, 84, 85, 86, 87, -1, -1, -1, -1, 92,
+ -1, -1, 95, 96, 97, 98
};
-/* YYSTOS[STATE-NUM] -- The (internal number of the) accessing
- symbol of state STATE-NUM. */
+ /* 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,
16, 17, 20, 21, 22, 23, 24, 26, 27, 28,
29, 30, 31, 36, 50, 52, 53, 54, 55, 56,
57, 62, 63, 64, 65, 66, 67, 68, 76, 88,
- 89, 90, 96, 97, 100, 102, 103, 160, 161, 162,
+ 89, 91, 93, 94, 100, 102, 103, 160, 161, 162,
165, 166, 167, 168, 169, 170, 172, 175, 181, 182,
183, 184, 185, 186, 187, 188, 189, 9, 113, 1,
32, 34, 35, 37, 38, 39, 40, 41, 42, 46,
113, 182, 190, 190, 190, 190, 190, 171, 11, 100,
170, 143, 143, 170, 100, 100, 100, 113, 170, 20,
161, 174, 182, 190, 190, 113, 170, 101, 160, 20,
- 25, 145, 170, 90, 100, 173, 182, 183, 184, 170,
+ 25, 145, 170, 91, 100, 173, 182, 183, 184, 170,
161, 170, 170, 170, 170, 170, 99, 160, 190, 190,
73, 74, 75, 77, 9, 11, 100, 51, 58, 59,
60, 61, 78, 79, 81, 82, 83, 84, 85, 86,
- 87, 92, 93, 94, 95, 98, 100, 9, 11, 9,
+ 87, 92, 95, 96, 97, 98, 100, 9, 11, 9,
11, 9, 11, 9, 115, 144, 145, 20, 142, 100,
- 100, 100, 100, 67, 90, 100, 180, 182, 100, 100,
+ 100, 100, 100, 67, 91, 100, 180, 182, 100, 100,
113, 45, 134, 101, 39, 40, 41, 42, 46, 48,
121, 122, 120, 12, 174, 100, 100, 160, 99, 113,
23, 115, 146, 99, 99, 160, 175, 190, 161, 10,
170, 170, 170, 170, 170, 170, 170, 9, 11, 15,
16, 17, 21, 62, 100, 102, 103, 164, 182, 99,
160, 160, 160, 160, 160, 160, 160, 160, 118, 20,
- 141, 142, 20, 125, 115, 115, 115, 115, 90, 115,
+ 141, 142, 20, 125, 115, 115, 115, 115, 91, 115,
67, 178, 179, 181, 182, 183, 184, 115, 115, 100,
115, 115, 113, 160, 138, 160, 160, 160, 160, 160,
175, 161, 12, 163, 100, 157, 69, 147, 99, 99,
135, 134, 118, 116, 140, 71, 133, 99, 116
};
+ /* 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, 123,
+ 122, 124, 122, 122, 125, 122, 122, 122, 122, 122,
+ 122, 122, 122, 126, 127, 122, 122, 122, 128, 122,
+ 122, 122, 122, 129, 122, 122, 122, 130, 131, 131,
+ 132, 132, 132, 132, 132, 132, 132, 132, 133, 133,
+ 133, 134, 134, 135, 136, 136, 137, 137, 138, 139,
+ 140, 141, 141, 142, 143, 144, 145, 145, 146, 146,
+ 147, 147, 147, 148, 148, 149, 149, 150, 150, 151,
+ 152, 152, 152, 153, 154, 154, 155, 155, 155, 156,
+ 156, 158, 157, 159, 159, 160, 160, 160, 160, 161,
+ 161, 161, 162, 162, 162, 162, 162, 162, 162, 162,
+ 163, 162, 164, 164, 165, 165, 165, 165, 165, 165,
+ 165, 165, 165, 165, 165, 165, 165, 165, 166, 166,
+ 166, 166, 166, 166, 166, 166, 166, 166, 166, 166,
+ 166, 166, 167, 167, 167, 167, 167, 167, 167, 167,
+ 167, 168, 168, 168, 168, 168, 168, 169, 169, 170,
+ 170, 170, 170, 170, 170, 170, 170, 170, 170, 170,
+ 170, 170, 170, 170, 170, 170, 170, 170, 170, 170,
+ 170, 170, 170, 170, 170, 170, 170, 170, 170, 170,
+ 170, 170, 170, 170, 170, 170, 170, 170, 170, 170,
+ 170, 170, 170, 170, 170, 170, 170, 170, 171, 170,
+ 170, 170, 170, 170, 172, 172, 172, 173, 173, 173,
+ 173, 173, 174, 174, 175, 175, 176, 176, 177, 178,
+ 178, 178, 179, 179, 180, 180, 181, 182, 183, 184,
+ 185, 185, 186, 187, 187, 188, 188, 189, 189, 190,
+ 190, 190, 190
+};
+
+ /* YYR2[YYN] -- Number of symbols on the 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, 4, 0,
+ 7, 0, 10, 4, 0, 7, 7, 7, 6, 6,
+ 2, 8, 8, 0, 0, 13, 9, 8, 0, 10,
+ 9, 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, 0, 0, 0, 0, 1, 1, 0, 1,
+ 0, 2, 1, 2, 1, 0, 1, 1, 1, 3,
+ 0, 1, 2, 3, 1, 1, 2, 3, 1, 0,
+ 1, 0, 4, 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, 8, 2, 2, 1,
+ 1, 1, 1, 5, 2, 3, 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, 6,
+ 1, 1, 1, 1, 3, 2, 4, 3, 2, 1,
+ 1, 1, 0, 1, 0, 1, 0, 2, 1, 1,
+ 1, 1, 1, 1, 2, 2, 2, 2, 2, 2,
+ 2, 4, 2, 1, 3, 1, 3, 1, 3, 1,
+ 1, 1, 1
+};
+
typedef enum {
toketype_ival, toketype_opval, toketype_pval
} toketypes;
toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival,
toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival,
toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival,
- toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_opval, toketype_opval, toketype_ival,
- toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval,
- toketype_opval, toketype_opval, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival,
- toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_ival, toketype_opval,
- toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_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_ival, toketype_ival, toketype_ival,
+ toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_ival,
+ toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_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_opval, toketype_opval, toketype_opval, toketype_opval, toketype_ival,
- toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval,
toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval,
- toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_ival, toketype_opval,
+ toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval,
+ toketype_opval, toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval,
+ toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_ival,
toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval,
- toketype_opval
+ toketype_opval, toketype_opval
};
/* Generated from:
- * b1f32b9f6f7c53d22517de00b5b5bfe4dd9d657c8573b9ea9eab7a43e852850a perly.y
+ * 5646c76b3536061de3b69eb5df829f5643d09247aa0d249bf2d2e050594b3679 perly.y
* 3e1dff60f26df8933d7aed0c0e87177a0f022c14800c0707eb62a7db4196ac98 regen_perly.pl
* ex: set ro: */
/* A sequence of statements in the program */
stmtseq : /* NULL */
- { $$ = (OP*)NULL; }
+ { $$ = NULL; }
| stmtseq fullstmt
{ $$ = op_append_list(OP_LINESEQ, $1, $2);
PL_pad_reset_pending = TRUE;
/* A sequence of format lines */
formstmtseq: /* NULL */
- { $$ = (OP*)NULL; }
+ { $$ = NULL; }
| formstmtseq formline
{ $$ = op_append_list(OP_LINESEQ, $1, $2);
PL_pad_reset_pending = TRUE;
{
CV *fmtcv = PL_compcv;
newFORM($2, $3, $4);
- $$ = (OP*)NULL;
+ $$ = NULL;
if (CvOUTSIDE(fmtcv) && !CvEVAL(CvOUTSIDE(fmtcv))) {
pad_add_weakref(fmtcv);
}
? newATTRSUB($3, $2, $5, $6, $7)
: newMYSUB($3, $2, $5, $6, $7)
;
- $$ = (OP*)NULL;
+ $$ = NULL;
intro_my();
parser->parsed_sub = 1;
}
? newATTRSUB($3, $2, NULL, $7, body)
: newMYSUB($3, $2, NULL, $7, body)
;
- $$ = (OP*)NULL;
+ $$ = NULL;
intro_my();
parser->parsed_sub = 1;
}
package($3);
if ($2)
package_version($2);
- $$ = (OP*)NULL;
+ $$ = NULL;
}
| USE startsub
{ CvSPECIAL_on(PL_compcv); /* It's a BEGIN {} */ }
SvREFCNT_inc_simple_void(PL_compcv);
utilize($1, $2, $4, $5, $6);
parser->parsed_sub = 1;
- $$ = (OP*)NULL;
+ $$ = NULL;
}
| IF '(' remember mexpr ')' mblock else
{
| WHILE '(' remember texpr ')' mintro mblock cont
{
$$ = block_end($3,
- newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
+ newWHILEOP(0, 1, NULL,
$4, $7, $8, $6));
parser->copline = (line_t)$1;
}
| UNTIL '(' remember iexpr ')' mintro mblock cont
{
$$ = block_end($3,
- newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
+ newWHILEOP(0, 1, NULL,
$4, $7, $8, $6));
parser->copline = (line_t)$1;
}
mblock
{
OP *initop = $4;
- OP *forop = newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
+ OP *forop = newWHILEOP(0, 1, NULL,
scalar($7), $13, $11, $10);
if (initop) {
forop = op_prepend_elem(OP_LINESEQ, initop,
| FOR '(' remember mexpr ')' mblock cont
{
$$ = block_end($3,
- newFOROP(0, (OP*)NULL, $4, $6, $7));
+ newFOROP(0, NULL, $4, $6, $7));
parser->copline = (line_t)$1;
}
| block cont
{
/* a block is a loop that happens once */
- $$ = newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
- (OP*)NULL, $1, $2, 0);
+ $$ = newWHILEOP(0, 1, NULL,
+ NULL, $1, $2, 0);
}
| PACKAGE BAREWORD BAREWORD '{' remember
{
stmtseq '}'
{
/* a block is a loop that happens once */
- $$ = newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
- (OP*)NULL, block_end($5, $7), (OP*)NULL, 0);
+ $$ = newWHILEOP(0, 1, NULL,
+ NULL, block_end($5, $7), NULL, 0);
if (parser->copline > (line_t)$4)
parser->copline = (line_t)$4;
}
}
| ';'
{
- $$ = (OP*)NULL;
+ $$ = NULL;
parser->copline = NOLINE;
}
;
/* An expression which may have a side-effect */
sideff : error
- { $$ = (OP*)NULL; }
+ { $$ = NULL; }
| expr
{ $$ = $1; }
| expr IF expr
| expr UNTIL iexpr
{ $$ = newLOOPOP(OPf_PARENS, 1, $3, $1); }
| expr FOR expr
- { $$ = newFOROP(0, (OP*)NULL, $3, $1, (OP*)NULL);
+ { $$ = newFOROP(0, NULL, $3, $1, NULL);
parser->copline = (line_t)$2; }
| expr WHEN expr
{ $$ = newWHENOP($3, op_scope($1)); }
/* else and elsif blocks */
else : /* NULL */
- { $$ = (OP*)NULL; }
+ { $$ = NULL; }
| ELSE mblock
{
($2)->op_flags |= OPf_PARENS;
/* Continue blocks */
cont : /* NULL */
- { $$ = (OP*)NULL; }
+ { $$ = NULL; }
| CONTINUE block
{ $$ = op_scope($2); }
;
/* Normal expression */
nexpr : /* NULL */
- { $$ = (OP*)NULL; }
+ { $$ = NULL; }
| sideff
;
;
formname: BAREWORD { $$ = $1; }
- | /* NULL */ { $$ = (OP*)NULL; }
+ | /* NULL */ { $$ = NULL; }
;
startsub: /* NULL */ /* start a regular subroutine scope */
/* Subroutine prototype */
proto : /* NULL */
- { $$ = (OP*)NULL; }
+ { $$ = NULL; }
| THING
;
/* Optional list of subroutine attributes */
subattrlist: /* NULL */
- { $$ = (OP*)NULL; }
+ { $$ = NULL; }
| COLONATTR THING
{ $$ = $2; }
| COLONATTR
- { $$ = (OP*)NULL; }
+ { $$ = NULL; }
;
/* List of attributes for a "my" variable declaration */
myattrlist: COLONATTR THING
{ $$ = $2; }
| COLONATTR
- { $$ = (OP*)NULL; }
+ { $$ = NULL; }
;
/* the '' or 'foo' part of a '$' or '@foo' etc signature variable */
sigvarname: /* NULL */
- { parser->in_my = 0; $$ = (OP*)NULL; }
+ { parser->in_my = 0; $$ = NULL; }
| PRIVATEREF
{ parser->in_my = 0; $$ = $1; }
;
yyerror("A slurpy parameter may not have "
"a default value");
- $$ = var ? newSTATEOP(0, NULL, var) : (OP*)NULL;
+ $$ = var ? newSTATEOP(0, NULL, var) : NULL;
}
;
/* default part of sub signature scalar element: i.e. '= default_expr' */
sigdefault: /* NULL */
- { $$ = (OP*)NULL; }
+ { $$ = NULL; }
| ASSIGNOP
{ $$ = newOP(OP_NULL, 0); }
| ASSIGNOP term
"follows optional parameter");
}
- $$ = var ? newSTATEOP(0, NULL, var) : (OP*)NULL;
+ $$ = var ? newSTATEOP(0, NULL, var) : NULL;
}
;
/* () or (....) */
siglistornull: /* NULL */
- { $$ = (OP*)NULL; }
+ { $$ = NULL; }
| siglist
{ $$ = $1; }
/* Optional subroutine body, for named subroutine declaration */
optsubbody: block
- | ';' { $$ = (OP*)NULL; }
+ | ';' { $$ = NULL; }
;
/* Ordinary expressions; logical combinations */
{ $$ = op_convert_list($1, 0, $3); }
| LSTOPSUB startanonsub block /* sub f(&@); f { foo } ... */
{ SvREFCNT_inc_simple_void(PL_compcv);
- $<opval>$ = newANONATTRSUB($2, 0, (OP*)NULL, $3); }
+ $<opval>$ = newANONATTRSUB($2, 0, NULL, $3); }
optlistexpr %prec LSTOP /* ... @bar */
{ $$ = newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST,
| QWLIST '[' expr ']' /* list literal slice */
{ $$ = newSLICEOP(0, $3, $1); }
| '(' ')' '[' expr ']' /* empty list slice! */
- { $$ = newSLICEOP(0, $4, (OP*)NULL); }
+ { $$ = newSLICEOP(0, $4, NULL); }
;
/* Binary operators between terms */
anonymous: '[' expr ']'
{ $$ = newANONLIST($2); }
| '[' ']'
- { $$ = newANONLIST((OP*)NULL);}
+ { $$ = newANONLIST(NULL);}
| HASHBRACK expr ';' '}' %prec '(' /* { foo => "Bar" } */
{ $$ = newANONHASH($2); }
| HASHBRACK ';' '}' %prec '(' /* { } (';' by tokener) */
- { $$ = newANONHASH((OP*)NULL); }
+ { $$ = newANONHASH(NULL); }
| ANONSUB startanonsub proto subattrlist block %prec '('
{ SvREFCNT_inc_simple_void(PL_compcv);
$$ = newANONATTRSUB($2, $3, $4, $5); }
/* Basic list expressions */
optlistexpr: /* NULL */ %prec PREC_LOW
- { $$ = (OP*)NULL; }
+ { $$ = NULL; }
| listexpr %prec PREC_LOW
{ $$ = $1; }
;
optexpr: /* NULL */
- { $$ = (OP*)NULL; }
+ { $$ = NULL; }
| expr
{ $$ = $1; }
;
optrepl: /* NULL */
- { $$ = (OP*)NULL; }
+ { $$ = NULL; }
| '/' expr
{ $$ = $2; }
;
* This symbol contains the ~name expanded version of PRIVLIB, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
-#define PRIVLIB "/sys/lib/perl/5.25.5" /**/
-#define PRIVLIB_EXP "/sys/lib/perl/5.25.5" /**/
+#define PRIVLIB "/sys/lib/perl/5.25.6" /**/
+#define PRIVLIB_EXP "/sys/lib/perl/5.25.6" /**/
/* PTRSIZE:
* This symbol contains the size of a pointer, so that the C preprocessor
* removed. The elements in inc_version_list (inc_version_list.U) can
* be tacked onto this variable to generate a list of directories to search.
*/
-#define SITELIB "/sys/lib/perl/5.25.5/site_perl" /**/
-#define SITELIB_EXP "/sys/lib/perl/5.25.5/site_perl" /**/
-#define SITELIB_STEM "/sys/lib/perl/5.25.5/site_perl" /**/
+#define SITELIB "/sys/lib/perl/5.25.6/site_perl" /**/
+#define SITELIB_EXP "/sys/lib/perl/5.25.6/site_perl" /**/
+#define SITELIB_STEM "/sys/lib/perl/5.25.6/site_perl" /**/
/* Size_t_size:
* This symbol holds the size of a Size_t in bytes.
ansi2knr=''
aphostname='/bin/uname -n'
api_revision='5'
-api_subversion='5'
+api_subversion='6'
api_version='25'
-api_versionstring='5.25.5'
+api_versionstring='5.25.6'
ar='ar'
-archlib='/sys/lib/perl5/5.25.5/386'
-archlibexp='/sys/lib/perl5/5.25.5/386'
+archlib='/sys/lib/perl5/5.25.6/386'
+archlibexp='/sys/lib/perl5/5.25.6/386'
archname64=''
archname='386'
archobjs=''
inc_version_list_init='0'
incpath=''
inews=''
-installarchlib='/sys/lib/perl/5.25.5/386'
+installarchlib='/sys/lib/perl/5.25.6/386'
installbin='/usr/bin'
installman1dir='/sys/man/1pub'
installman3dir='/sys/man/2pub'
installprefix='/usr'
installprefixexp='/usr'
-installprivlib='/sys/lib/perl/5.25.5'
+installprivlib='/sys/lib/perl/5.25.6'
installscript='/usr/bin'
-installsitearch='/sys/lib/perl/5.25.5/site_perl/386'
+installsitearch='/sys/lib/perl/5.25.6/site_perl/386'
installsitebin='/usr/bin'
-installsitelib='/sys/lib/perl/5.25.5/site_perl'
+installsitelib='/sys/lib/perl/5.25.6/site_perl'
installstyle='lib/perl5'
installusrbinperl='undef'
installvendorarch=''
pr=''
prefix='/usr'
prefixexp='/usr'
-privlib='/sys/lib/perl/5.25.5'
-privlibexp='/sys/lib/perl/5.25.5'
+privlib='/sys/lib/perl/5.25.6'
+privlibexp='/sys/lib/perl/5.25.6'
procselfexe=''
prototype='define'
ptrsize='4'
sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 0'
sig_size='50'
signal_t='void'
-sitearch='/sys/lib/perl/5.25.5/site_perl/386'
+sitearch='/sys/lib/perl/5.25.6/site_perl/386'
sitearchexp='/sys/lib/perl/site_perl/386'
sitebin='/usr/bin'
sitebinexp='/usr/bin'
-sitelib='/sys/lib/perl/5.25.5/site_perl'
-sitelib_stem='/sys/lib/perl/5.25.5/site_perl'
-sitelibexp='/sys/lib/perl/5.25.5/site_perl'
+sitelib='/sys/lib/perl/5.25.6/site_perl'
+sitelib_stem='/sys/lib/perl/5.25.6/site_perl'
+sitelibexp='/sys/lib/perl/5.25.6/site_perl'
siteprefix='/usr'
siteprefixexp='/usr'
sizesize='4'
strerror_r_proto='0'
strings='/sys/include/ape/string.h'
submit=''
-subversion='5'
+subversion='6'
sysman='/sys/man/1pub'
tail=''
tar=''
vendorlibexp=''
vendorprefix=''
vendorprefixexp=''
-version='5.25.5'
-version_patchlevel_string='version 25 subversion 5'
+version='5.25.6'
+version_patchlevel_string='version 25 subversion 6'
versiononly='undef'
vi=''
xlibpth=''
config_argc=0
PERL_REVISION=5
PERL_VERSION=25
-PERL_SUBVERSION=5
+PERL_SUBVERSION=6
PERL_API_REVISION=5
PERL_API_VERSION=25
-PERL_API_SUBVERSION=5
+PERL_API_SUBVERSION=6
PERL_PATCHLEVEL=
PERL_CONFIG_SH=true
/roffitall
# generated
-/perl5255delta.pod
+/perl5256delta.pod
/perlapi.pod
/perlintern.pod
*.html
perlhist Perl history records
perldelta Perl changes since previous version
+ perl5255delta Perl changes in version 5.25.5
perl5254delta Perl changes in version 5.25.4
perl5253delta Perl changes in version 5.25.3
perl5252delta Perl changes in version 5.25.2
--- /dev/null
+=encoding utf8
+
+=head1 NAME
+
+perl5255delta - what is new for perl v5.25.5
+
+=head1 DESCRIPTION
+
+This document describes differences between the 5.25.4 release and the 5.25.5
+release.
+
+If you are upgrading from an earlier release such as 5.25.3, first read
+L<perl5254delta>, which describes differences between 5.25.3 and 5.25.4.
+
+=head1 Security
+
+=head2 "Escaped" colons and relative paths in PATH
+
+On Unix systems, Perl treats any relative paths in the PATH environment
+variable as tainted when starting a new process. Previously, it was
+allowing a backslash to escape a colon (unlike the OS), consequently
+allowing relative paths to be considered safe if the PATH was set to
+something like C</\:.>. The check has been fixed to treat C<.> as tainted
+in that example.
+
+=head1 Modules and Pragmata
+
+=head2 Updated Modules and Pragmata
+
+=over 4
+
+=item *
+
+L<Filter::Simple> has been upgraded from version 0.92 to 0.93.
+
+It no longer treats C<no MyFilter> immediately following C<use MyFilter> as
+end-of-file. [perl #107726]
+
+=item *
+
+L<Locale::Codes> has been upgraded from 3.39 to 3.40.
+
+=item *
+
+L<Module::CoreList> has been upgraded from version 5.20160820 to 5.20160920.
+
+=item *
+
+L<POSIX> has been upgraded from version 1.71 to 1.72.
+
+=item *
+
+L<Sys::Syslog> has been upgraded from version 0.34_01 to 0.35.
+
+=item *
+
+L<Test::Simple> has been upgraded from version 1.302052 to 1.302056.
+
+=item *
+
+L<Thread::Semaphore> has been upgraded from 2.12 to 2.13.
+
+Added the C<down_timed> method.
+
+=item *
+
+L<XSLoader> has been upgraded from version 0.22 to 0.24.
+
+=back
+
+=head1 Documentation
+
+=head2 Changes to Existing Documentation
+
+=head3 L<perlinterp>
+
+=over 4
+
+=item *
+
+L<perlinterp> has been expanded to give a more detailed example of how to
+hunt around in the parser for how a given operator is handled.
+
+=back
+
+=head1 Testing
+
+=over 4
+
+=item *
+
+F<t/re/regexp_nonull.t> has been added to test that the regular expression
+engine can handle scalars that do not have a null byte just past the end of
+the string.
+
+=back
+
+=head1 Platform Support
+
+=head2 Platform-Specific Notes
+
+=over 4
+
+=item VMS
+
+=over 4
+
+=item *
+
+The path separator for the C<PERL5LIB> and C<PERLLIB> environment entries is
+now a colon (C<:>) when running under a Unix shell. There is no change when
+running under DCL (it's still C<|>).
+
+=item *
+
+Remove some VMS-specific hacks from C<showlex.t>. These were added 15 years
+ago, and are no longer necessary for any VMS version now supported.
+
+=back
+
+=back
+
+=over 4
+
+=item Win32
+
+=over 4
+
+=item *
+
+Tweaks for Win32 VC vs GCC detection makefile code. This fixes issue that CCHOME
+depends on CCTYPE, which in auto detect mode is set after CCHOME, so CCHOME uses
+the uninit CCTYPE var. Also fix else vs .ELSE in makefile.mk
+
+=back
+
+=back
+
+=head1 Internal Changes
+
+=over 4
+
+=item *
+
+Several macros and functions have been added to the public API for
+dealing with Unicode and UTF-8-encoded strings. See
+L<perlapi/Unicode Support>.
+
+=item *
+
+Use C<my_strlcat()> in C<locale.c>. While C<strcat()> is safe in this context,
+some compilers were optimizing this to C<strcpy()> causing a porting test to
+fail that looks for unsafe code. Rather than fighting this, we just use
+C<my_strlcat()> instead.
+
+=back
+
+=head1 Selected Bug Fixes
+
+=over 4
+
+=item *
+
+Invalid assignments to a reference constructor (e.g., C<\eval=time>) could
+sometimes crash in addition to giving a syntax error. [perl #125679]
+
+=item *
+
+The parser could sometimes crash if a bareword came after C<evalbytes>.
+[perl #129196]
+
+=item *
+
+Autoloading via a method call would warn erroneously ("Use of inherited
+AUTOLOAD for non-method") if there was a stub present in the package into
+which the invocant had been blessed. The warning is no longer emitted in
+such circumstances. [perl #47047]
+
+=item *
+
+A sub containing with a "forward" declaration with the same name (e.g.,
+C<sub c { sub c; }>) could sometimes crash or loop infinitely. [perl
+#129090]
+
+=item *
+
+The use of C<splice> on arrays with nonexistent elements could cause other
+operators to crash. [perl #129164]
+
+=item *
+
+Fixed case where C<re_untuit_start> will overshoot the length of a utf8
+string. [perl #129012]
+
+=item *
+
+Handle C<CXt_SUBST> better in C<Perl_deb_stack_all>, previously it wasn't
+checking that the I<current> C<cx> is the right type, and instead was always
+checking the base C<cx> (effectively a noop). [perl #129029]
+
+=item *
+
+Fixed two possible use-after-free bugs in C<Perl_yylex>. C<Perl_yylex>
+maintains up to two pointers into the parser buffer, one of which can
+become stale under the right conditions. [perl #129069]
+
+=item *
+
+Fixed a crash with C<s///l> where it thought it was dealing with UTF-8
+when it wasn't. [perl #129038]
+
+=item *
+
+Fixed place where regex was not setting the syntax error correctly.
+[perl #129122]
+
+=item *
+
+The C<&.> operator (and the C<&> operator, when it treats its arguments as
+strings) were failing to append a trailing null byte if at least one string
+was marked as utf8 internally. Many code paths (system calls, regexp
+compilation) still expect there to be a null byte in the string buffer
+just past the end of the logical string. An assertion failure was the
+result. [perl #129287]
+
+=item *
+
+Check C<pack_sockaddr_un()>'s return value because C<pack_sockaddr_un()>
+silently truncates the supplied path if it won't fit into the C<sun_path>
+member of C<sockaddr_un>. This may change in the future, but for now
+check the path in theC<sockaddr> matches the desired path, and skip if
+it doesn't. [perl #128095]
+
+=item *
+
+Make sure C<PL_oldoldbufptr> is preserved in C<scan_heredoc()>. In some
+cases this is used in building error messages. [perl #128988]
+
+=item *
+
+Check for null PL_curcop in IN_LC() [perl #129106]
+
+=item *
+
+Fixed the parser error handling for an 'C<:attr(foo>' that does not have
+an ending 'C<)>'.
+
+=item *
+
+Fix C<Perl_delimcpy()> to handle a backslash as last char, this
+actually fixed two bugs, [perl #129064] and [perl #129176].
+
+=item *
+
+[perl #129267] rework gv_fetchmethod_pvn_flags separator parsing to
+prevent possible string overrun with invalid len in gv.c
+
+=back
+
+=head1 Obituary
+
+Jon Portnoy (AVENJ), a prolific Perl author and admired Gentoo community
+member, has passed away on August 10, 2016. He will be remembered and
+missed by all those with which he came in contact and enriched with his
+intellect, wit, and spirit.
+
+=head1 Acknowledgements
+
+Perl 5.25.5 represents approximately 4 weeks of development since Perl 5.25.4
+and contains approximately 67,000 lines of changes across 230 files from 25
+authors.
+
+Excluding auto-generated files, documentation and release tools, there were
+approximately 62,000 lines of changes to 160 .pm, .t, .c and .h files.
+
+Perl continues to flourish into its third decade thanks to a vibrant community
+of users and developers. The following people are known to have contributed the
+improvements that became Perl 5.25.5:
+
+Aaron Crane, Aristotle Pagaltzis, Chris 'BinGOs' Williams, Craig A. Berry,
+Dagfinn Ilmari Mannsåker, Dan Collins, Daniel Dragan, Dave Cross, David
+Mitchell, E. Choroba, Father Chrysostomos, James E Keenan, Jerry D. Hedden,
+Karl Williamson, Lukas Mai, Ricardo Signes, Rick Delaney, Sawyer X, Stevan
+Little, Steve Hay, Sullivan Beck, Theo Buehler, Tony Cook, Yaroslav Kuzmin,
+Yves Orton.
+
+The list above is almost certainly incomplete as it is automatically generated
+from version control history. In particular, it does not include the names of
+the (very much appreciated) contributors who reported issues to the Perl bug
+tracker.
+
+Many of the changes included in this version originated in the CPAN modules
+included in Perl's core. We're grateful to the entire CPAN community for
+helping Perl to flourish.
+
+For a more complete list of all of Perl's historical contributors, please see
+the F<AUTHORS> file in the Perl source distribution.
+
+=head1 Reporting Bugs
+
+If you find what you think is a bug, you might check the perl bug database
+at L<https://rt.perl.org/> . There may also be information at
+L<http://www.perl.org/> , the Perl Home Page.
+
+If you believe you have an unreported bug, please run the L<perlbug> program
+included with your release. Be sure to trim your bug down to a tiny but
+sufficient test case. Your bug report, along with the output of C<perl -V>,
+will be sent off to perlbug@perl.org to be analysed by the Perl porting team.
+
+If the bug you are reporting has security implications which make it
+inappropriate to send to a publicly archived mailing list, then see
+L<perlsec/SECURITY VULNERABILITY CONTACT INFORMATION>
+for details of how to report the issue.
+
+=head1 SEE ALSO
+
+The F<Changes> file for an explanation of how to view exhaustive details on
+what changed.
+
+The F<INSTALL> file for how to build Perl.
+
+The F<README> file for general stuff.
+
+The F<Artistic> and F<Copying> files for copyright information.
+
+=cut
=head1 NAME
-perldelta - what is new for perl v5.25.5
+perldelta - what is new for perl v5.25.6
=head1 DESCRIPTION
-This document describes differences between the 5.25.4 release and the 5.25.5
+This document describes differences between the 5.25.5 release and the 5.25.6
release.
-If you are upgrading from an earlier release such as 5.25.3, first read
-L<perl5254delta>, which describes differences between 5.25.3 and 5.25.4.
+If you are upgrading from an earlier release such as 5.25.4, first read
+L<perl5255delta>, which describes differences between 5.25.4 and 5.25.5.
-=head1 Security
+=head1 Performance Enhancements
-=head2 "Escaped" colons and relative paths in PATH
+=over 4
+
+=item *
+
+Converting a single-digit string to a number is now substantially faster.
+
+=item *
-On Unix systems, Perl treats any relative paths in the PATH environment
-variable as tainted when starting a new process. Previously, it was
-allowing a backslash to escape a colon (unlike the OS), consequently
-allowing relative paths to be considered safe if the PATH was set to
-something like C</\:.>. The check has been fixed to treat C<.> as tainted
-in that example.
+The internal op implementing the C<split> builtin has been simplified and
+sped up. Firstly, it no longer requires a subsidiary internal C<pushre> op
+to do its work. Secondly, code of the form C<my @x = split(...)> is now
+optimised in the same way as C<@x = split(...)>, and is therefore a few
+percent faster.
+
+=back
=head1 Modules and Pragmata
=item *
-L<Filter::Simple> has been upgraded from version 0.92 to 0.93.
+L<Archive::Tar> has been upgraded from version 2.10 to 2.14.
-It no longer treats C<no MyFilter> immediately following C<use MyFilter> as
-end-of-file. [perl #107726]
+=item *
+
+L<attributes> has been upgraded from version 0.27 to 0.28.
=item *
-L<Locale::Codes> has been upgraded from 3.39 to 3.40.
+L<B> has been upgraded from version 1.63 to 1.64.
=item *
-L<Module::CoreList> has been upgraded from version 5.20160820 to 5.20160920.
+L<B::Concise> has been upgraded from version 0.998 to 0.999.
+
+Its output is now more descriptive for C<op_private> flags.
=item *
-L<POSIX> has been upgraded from version 1.71 to 1.72.
+L<B::Deparse> has been upgraded from version 1.38 to 1.39.
=item *
-L<Sys::Syslog> has been upgraded from version 0.34_01 to 0.35.
+L<Data::Dumper> has been upgraded from version 2.161 to 2.162.
=item *
-L<Test::Simple> has been upgraded from version 1.302052 to 1.302056.
+L<Devel::Peek> has been upgraded from version 1.24 to 1.25.
=item *
-L<Thread::Semaphore> has been upgraded from 2.12 to 2.13.
+L<HTTP::Tiny> has been upgraded from version 0.064 to 0.070.
-Added the C<down_timed> method.
+Internal 599-series errors now include the redirect history.
=item *
-L<XSLoader> has been upgraded from version 0.22 to 0.24.
+L<List::Util> has been upgraded from version 1.45_01 to 1.46.
-=back
+=item *
-=head1 Documentation
+L<Module::CoreList> has been upgraded from version 5.20160920 to 5.20161020.
-=head2 Changes to Existing Documentation
+=item *
-=head3 L<perlinterp>
+L<mro> has been upgraded from version 1.18 to 1.19.
-=over 4
+=item *
+
+L<Net::Ping> has been upgraded from version 2.44 to 2.51.
+
+IPv6 addresses and C<AF_INET6> sockets are now supported, along with several
+other enhancements.
=item *
-L<perlinterp> has been expanded to give a more detailed example of how to
-hunt around in the parser for how a given operator is handled.
+L<Opcode> has been upgraded from version 1.37 to 1.38.
-=back
+=item *
-=head1 Testing
+L<overload> has been upgraded from version 1.26 to 1.27.
-=over 4
+Its compilation speed has been improved slightly.
=item *
-F<t/re/regexp_nonull.t> has been added to test that the regular expression
-engine can handle scalars that do not have a null byte just past the end of
-the string.
+L<parent> has been upgraded from version 0.234 to 0.236.
-=back
+=item *
-=head1 Platform Support
+L<PerlIO::encoding> has been upgraded from version 0.24 to 0.25.
-=head2 Platform-Specific Notes
+=item *
-=over 4
+podlators has been upgraded from version 4.07 to 4.08.
-=item VMS
+=item *
-=over 4
+L<POSIX> has been upgraded from version 1.72 to 1.73.
=item *
-The path separator for the C<PERL5LIB> and C<PERLLIB> environment entries is
-now a colon (C<:>) when running under a Unix shell. There is no change when
-running under DCL (it's still C<|>).
+L<Scalar::Util> has been upgraded from version 1.45_01 to 1.46.
=item *
-Remove some VMS-specific hacks from C<showlex.t>. These were added 15 years
-ago, and are no longer necessary for any VMS version now supported.
+L<Storable> has been upgraded from version 2.57 to 2.58.
-=back
+=item *
-=back
+L<Test::Simple> has been upgraded from version 1.302056 to 1.302059.
-=over 4
+=item *
-=item Win32
+L<Time::HiRes> has been upgraded from version 1.9739 to 1.9740_01.
-=over 4
+It now builds on systems with C++11 compilers (such as G++ 6 and Clang++
+3.9).
=item *
-Tweaks for Win32 VC vs GCC detection makefile code. This fixes issue that CCHOME
-depends on CCTYPE, which in auto detect mode is set after CCHOME, so CCHOME uses
-the uninit CCTYPE var. Also fix else vs .ELSE in makefile.mk
+L<VMS::Stdio> has been upgraded from version 2.41 to 2.42.
=back
+=head1 Diagnostics
+
+The following additions or changes have been made to diagnostic output,
+including warnings and fatal error messages. For the complete list of
+diagnostic messages, see L<perldiag>.
+
+=head2 New Diagnostics
+
+=head3 New Errors
+
+=over 4
+
+=item *
+
+Using the empty pattern (which re-executes the last successfully-matched
+pattern) inside a code block in another regex, as in C</(?{ s!!new! })/>, has
+always previously yielded a segfault. It now produces an error: L<Use of the
+empty pattern inside of a regex code block is forbidden|perldiag/"Use of the
+empty pattern inside of a regex code block is forbidden">.
+
=back
-=head1 Internal Changes
+=head2 Changes to Existing Diagnostics
=over 4
=item *
-Several macros and functions have been added to the public API for
-dealing with Unicode and UTF-8-encoded strings. See
-L<perlapi/Unicode Support>.
+Details as to the exact problem have been added to the diagnostics that
+occur when malformed UTF-8 is encountered when trying to convert to a
+code point.
=item *
-Use C<my_strlcat()> in C<locale.c>. While C<strcat()> is safe in this context,
-some compilers were optimizing this to C<strcpy()> causing a porting test to
-fail that looks for unsafe code. Rather than fighting this, we just use
-C<my_strlcat()> instead.
+Executing C<undef $x> where C<$x> is tied or magical no longer incorrectly
+blames the variable for an uninitialized-value warning encountered by the
+tied/magical code.
=back
-=head1 Selected Bug Fixes
+=head1 Configuration and Compilation
=over 4
=item *
-Invalid assignments to a reference constructor (e.g., C<\eval=time>) could
-sometimes crash in addition to giving a syntax error. [perl #125679]
+Builds using C<USE_PAD_RESET> now work again; this configuration had
+bit-rotted.
+
+=back
+
+=head1 Testing
+
+=over 4
=item *
-The parser could sometimes crash if a bareword came after C<evalbytes>.
-[perl #129196]
+Some parts of the test suite that try to exhaustively test edge cases in the
+regex implementation have been restricted to running for a maximum of five
+minutes. On slow systems they could otherwise take several hours, without
+significantly improving our understanding of the correctness of the code
+under test.
+
+In addition, some of those test cases have been split into more files, to
+allow them to be run in parallel on suitable systems.
=item *
-Autoloading via a method call would warn erroneously ("Use of inherited
-AUTOLOAD for non-method") if there was a stub present in the package into
-which the invocant had been blessed. The warning is no longer emitted in
-such circumstances. [perl #47047]
+A new internal facility allows analysing the time taken by the individual
+tests in Perl's own test suite; see F<Porting/harness-timer-report.pl>.
+
+=back
+
+=head1 Platform Support
+
+=head2 New Platforms
+
+=over 4
+
+=item NetBSD/VAX
+
+Perl now compiles under NetBSD on VAX machines. However, it's not
+possible for that platform to implement floating-point infinities and
+NaNs compatibly with most modern systems, which implement the IEEE-754
+floating point standard. The hexadecimal floating point (C<0x...p[+-]n>
+literals, C<printf %a>) is not implemented, either.
+The C<make test> passes 98% of tests.
+
+=back
+
+=head1 Internal Changes
+
+=over 4
=item *
-A sub containing with a "forward" declaration with the same name (e.g.,
-C<sub c { sub c; }>) could sometimes crash or loop infinitely. [perl
-#129090]
+The C<PADOFFSET> type has changed from being unsigned to signed, and
+several pad-related variables such as C<PL_padix> have changed from being
+of type C<I32> to type C<PADOFFSET>.
=item *
-The use of C<splice> on arrays with nonexistent elements could cause other
-operators to crash. [perl #129164]
+The function C<L<perlapi/utf8n_to_uvchr>> has been changed to not
+abandon searching for other malformations when the first one is
+encountered. A call to it thus can generate multiple diagnostics,
+instead of just one.
=item *
-Fixed case where C<re_untuit_start> will overshoot the length of a utf8
-string. [perl #129012]
+A new function, C<L<perlapi/utf8n_to_uvchr_error>>, has been added for
+use by modules that need to know the details of UTF-8 malformations
+beyond pass/fail. Previously, the only ways to know why a sequence was
+ill-formed was to capture and parse the generated diagnostics, or to do
+your own analysis.
=item *
-Handle C<CXt_SUBST> better in C<Perl_deb_stack_all>, previously it wasn't
-checking that the I<current> C<cx> is the right type, and instead was always
-checking the base C<cx> (effectively a noop). [perl #129029]
+Several new functions for handling Unicode have been added to the API:
+C<L<perlapi/is_strict_utf8_string>>,
+C<L<perlapi/is_c9strict_utf8_string>>,
+C<L<perlapi/is_utf8_string_flags>>,
+C<L<perlapi/is_strict_utf8_string_loc>>,
+C<L<perlapi/is_strict_utf8_string_loclen>>,
+C<L<perlapi/is_c9strict_utf8_string_loc>>,
+C<L<perlapi/is_c9strict_utf8_string_loclen>>,
+C<L<perlapi/is_utf8_string_loc_flags>>,
+C<L<perlapi/is_utf8_string_loclen_flags>>,
+C<L<perlapi/is_utf8_fixed_width_buf_flags>>,
+C<L<perlapi/is_utf8_fixed_width_buf_loc_flags>>,
+C<L<perlapi/is_utf8_fixed_width_buf_loclen_flags>>.
+
+These functions are all extensions of the C<is_utf8_string_*()> functions,
+that apply various restrictions to the UTF-8 recognized as valid.
=item *
-Fixed two possible use-after-free bugs in C<Perl_yylex>. C<Perl_yylex>
-maintains up to two pointers into the parser buffer, one of which can
-become stale under the right conditions. [perl #129069]
+A new API function C<sv_setvpv_bufsize()> allows simultaneously setting the
+length and allocated size of the buffer in an C<SV>, growing the buffer if
+necessary.
=item *
-Fixed a crash with C<s///l> where it thought it was dealing with UTF-8
-when it wasn't. [perl #129038]
+A new API macro C<SvPVCLEAR()> sets its C<SV> argument to an empty string,
+like Perl-space C<$x = ''>, but with several optimisations.
=item *
-Fixed place where regex was not setting the syntax error correctly.
-[perl #129122]
+All parts of the internals now agree that the C<sassign> op is a C<BINOP>;
+previously it was listed as a C<BASEOP> in F<regen/opcodes>, which meant
+that several parts of the internals had to be special-cased to accommodate
+it. This oddity's original motivation was to handle code like C<$x ||= 1>;
+that is now handled in a simpler way.
=item *
-The C<&.> operator (and the C<&> operator, when it treats its arguments as
-strings) were failing to append a trailing null byte if at least one string
-was marked as utf8 internally. Many code paths (system calls, regexp
-compilation) still expect there to be a null byte in the string buffer
-just past the end of the logical string. An assertion failure was the
-result. [perl #129287]
+Several new internal C macros have been added that take a string literal as
+arguments, alongside existing routines that take the equivalent value as two
+arguments, a character pointer and a length. The advantage of this is that
+the length of the string is calculated automatically, rather than having to
+be done manually. These routines are now used where appropriate across the
+entire codebase.
=item *
-Check C<pack_sockaddr_un()>'s return value because C<pack_sockaddr_un()>
-silently truncates the supplied path if it won't fit into the C<sun_path>
-member of C<sockaddr_un>. This may change in the future, but for now
-check the path in theC<sockaddr> matches the desired path, and skip if
-it doesn't. [perl #128095]
+The code in F<gv.c> that determines whether a variable has a special meaning
+to Perl has been simplified.
=item *
-Make sure C<PL_oldoldbufptr> is preserved in C<scan_heredoc()>. In some
-cases this is used in building error messages. [perl #128988]
+The C<DEBUGGING>-mode output for regex compilation and execution has been
+enhanced.
+
+=back
+
+=head1 Selected Bug Fixes
+
+=over 4
=item *
-Check for null PL_curcop in IN_LC() [perl #129106]
+A sub containing a "forward" declaration with the same name (e.g.,
+C<sub c { sub c; }>) could sometimes crash or loop infinitely. [perl
+#129090]
=item *
-Fixed the parser error handling for an 'C<:attr(foo>' that does not have
-an ending 'C<)>'.
+A crash in executing a regex with a floating UTF-8 substring against a
+target string that also used UTF-8 has been fixed. [perl #129350]
=item *
-Fix C<Perl_delimcpy()> to handle a backslash as last char, this
-actually fixed two bugs, [perl #129064] and [perl #129176].
+Previously, a shebang line like C<#!perl -i u> could be erroneously
+interpreted as requesting the C<-u> option. This has been fixed. [perl
+#129336]
=item *
-[perl #129267] rework gv_fetchmethod_pvn_flags separator parsing to
-prevent possible string overrun with invalid len in gv.c
+The regex engine was previously producing incorrect results in some rare
+situations when backtracking past a trie that matches only one thing; this
+showed up as capture buffers (C<$1>, C<$2>, etc) erroneously containing data
+from regex execution paths that weren't actually executed for the final
+match. [perl #129897]
-=back
+=item *
-=head1 Obituary
+Certain regexes making use of the experimental C<regex_sets> feature could
+trigger an assertion failure. This has been fixed. [perl #129322]
-Jon Portnoy (AVENJ), a prolific Perl author and admired Gentoo community
-member, has passed away on August 10, 2016. He will be remembered and
-missed by all those with which he came in contact and enriched with his
-intellect, wit, and spirit.
+=back
=head1 Acknowledgements
-Perl 5.25.5 represents approximately 4 weeks of development since Perl 5.25.4
-and contains approximately 67,000 lines of changes across 230 files from 25
+Perl 5.25.6 represents approximately 4 weeks of development since Perl 5.25.5
+and contains approximately 16,000 lines of changes across 300 files from 23
authors.
Excluding auto-generated files, documentation and release tools, there were
-approximately 62,000 lines of changes to 160 .pm, .t, .c and .h files.
+approximately 10,000 lines of changes to 190 .pm, .t, .c and .h files.
Perl continues to flourish into its third decade thanks to a vibrant community
of users and developers. The following people are known to have contributed the
-improvements that became Perl 5.25.5:
-
-Aaron Crane, Aristotle Pagaltzis, Chris 'BinGOs' Williams, Craig A. Berry,
-Dagfinn Ilmari Mannsåker, Dan Collins, Daniel Dragan, Dave Cross, David
-Mitchell, E. Choroba, Father Chrysostomos, James E Keenan, Jerry D. Hedden,
-Karl Williamson, Lukas Mai, Ricardo Signes, Rick Delaney, Sawyer X, Stevan
-Little, Steve Hay, Sullivan Beck, Theo Buehler, Tony Cook, Yaroslav Kuzmin,
-Yves Orton.
+improvements that became Perl 5.25.6:
+
+Aaron Crane, Andy Lester, Chris 'BinGOs' Williams, Dagfinn Ilmari Mannsåker,
+Dan Collins, David Mitchell, François Perrad, Hugo van der Sanden, James E
+Keenan, James Raspass, Jarkko Hietaniemi, Karl Williamson, Lukas Mai, Nicolas
+R., Reini Urban, Sawyer X, Sergey Aleynikov, Stevan Little, Steve Hay, Steven
+Humphrey, Thomas Sibley, Tony Cook, Yves Orton.
The list above is almost certainly incomplete as it is automatically generated
from version control history. In particular, it does not include the names of
but didn't enable that feature first (C<use feature 'signatures'>),
so the signature was instead interpreted as a bad prototype.
-=item Malformed UTF-8 character (%s)
+=item Malformed UTF-8 character%s
-(S utf8)(F) Perl detected a string that didn't comply with UTF-8
-encoding rules, even though it had the UTF8 flag on.
+(S utf8)(F) Perl detected a string that should be UTF-8, but didn't
+comply with UTF-8 encoding rules, or represents a code point whose
+ordinal integer value doesn't fit into the word size of the current
+platform (overflows). Details as to the exact malformation are given in
+the variable, C<%s>, part of the message.
One possible cause is that you set the UTF8 flag yourself for data that
you thought to be in UTF-8 but it wasn't (it was for example legacy
(P) Failed an internal consistency check trying to compile a grep.
-=item panic: ck_split, type=%u
-
-(P) Failed an internal consistency check trying to compile a split.
-
=item panic: corrupt saved stack index %ld
(P) The savestack was requested to restore more localized values than
(P) The internal pp_match() routine was called with invalid operational
data.
-=item panic: pp_split, pm=%p, s=%p
-
-(P) Something terrible went wrong in setting up for the split.
-
=item panic: realloc, %s
(P) Something requested a negative number of bytes of realloc.
it may skip items, or visit items more than once. Consider using
C<keys()> instead of C<each()>.
+=item Use of the empty pattern inside of a regex code block is forbidden
+
+(F) You tried to use the empty pattern inside of a regex code block,
+for instance C</(?{ s!!! })/>. Currently for implementation reasons
+this is forbidden. Generally you can rewrite code that uses the empty
+pattern with the appropriate use of C<qr//>.
+
=item Use of := for an empty attribute list is not allowed
(F) The construction C<my $x := 42> used to parse as equivalent to
If you don't need the existing content of the SV, you can avoid some
copying with:
- sv_setpvn(sv, "", 0);
+ SvPVCLEAR(sv);
s = SvGROW(sv, needlen + 1);
/* something that modifies up to needlen bytes at s, but modifies
newlen bytes
items = SP - MARK;
MARK++;
- sv_setpvn(cat, "", 0);
+ SvPVCLEAR(cat);
+ patcopy = pat;
while (pat < patend) {
Steve 5.22.3-RC1 2016-Jul-17
Steve 5.22.3-RC2 2016-Jul-25
Steve 5.22.3-RC3 2016-Aug-11
+ Steve 5.22.3-RC4 2016-Oct-12
Ricardo 5.23.0 2015-Jun-20 The 5.23 development track
Matthew 5.23.1 2015-Jul-20
Steve 5.24.1-RC1 2016-Jul-17
Steve 5.24.1-RC2 2016-Jul-25
Steve 5.24.1-RC3 2016-Aug-11
+ Steve 5.24.1-RC4 2016-Oct-12
Ricardo 5.25.0 2016-May-09 The 5.25 development track
Sawyer X 5.25.1 2016-May-20
Steve 5.25.3 2016-Jul-20
BinGOs 5.25.4 2016-Aug-20
Stevan 5.25.5 2016-Sep-20
+ Aaron 5.25.6 2016-Oct-20
=head2 SELECTED RELEASE SIZES
X<-c>
causes Perl to check the syntax of the program and then exit without
-executing it. Actually, it I<will> execute and C<BEGIN>, C<UNITCHECK>,
+executing it. Actually, it I<will> execute any C<BEGIN>, C<UNITCHECK>,
or C<CHECK> blocks and any C<use> statements: these are considered as
occurring outside the execution of your program. C<INIT> and C<END>
blocks, however, will be skipped.
kernel bug that plagues set-id scripts. Here's a simple wrapper, written
in C:
+ #include <unistd.h>
+ #include <stdio.h>
+ #include <string.h>
+ #include <errno.h>
+
#define REAL_PATH "/path/to/script"
- main(ac, av)
- char **av;
+
+ int main(int argc, char **argv)
{
- execv(REAL_PATH, av);
+ execv(REAL_PATH, argv);
+ fprintf(stderr, "%s: %s: %s\n",
+ argv[0], REAL_PATH, strerror(errno));
+ return 127;
}
Compile this wrapper into a binary executable and then make I<it> rather
sv = NULL;
if (elem) {
/* elem will always be NUL terminated. */
- const char * const second_letter = elem + 1;
switch (*elem) {
case 'A':
- if (len == 5 && strEQ(second_letter, "RRAY"))
+ if (memEQs(elem, len, "ARRAY"))
{
tmpRef = MUTABLE_SV(GvAV(gv));
if (tmpRef && !AvREAL((const AV *)tmpRef)
}
break;
case 'C':
- if (len == 4 && strEQ(second_letter, "ODE"))
+ if (memEQs(elem, len, "CODE"))
tmpRef = MUTABLE_SV(GvCVu(gv));
break;
case 'F':
- if (len == 10 && strEQ(second_letter, "ILEHANDLE")) {
+ if (memEQs(elem, len, "FILEHANDLE")) {
tmpRef = MUTABLE_SV(GvIOp(gv));
}
else
- if (len == 6 && strEQ(second_letter, "ORMAT"))
+ if (memEQs(elem, len, "FORMAT"))
tmpRef = MUTABLE_SV(GvFORM(gv));
break;
case 'G':
- if (len == 4 && strEQ(second_letter, "LOB"))
+ if (memEQs(elem, len, "GLOB"))
tmpRef = MUTABLE_SV(gv);
break;
case 'H':
- if (len == 4 && strEQ(second_letter, "ASH"))
+ if (memEQs(elem, len, "HASH"))
tmpRef = MUTABLE_SV(GvHV(gv));
break;
case 'I':
- if (*second_letter == 'O' && !elem[2] && len == 2)
+ if (memEQs(elem, len, "IO"))
tmpRef = MUTABLE_SV(GvIOp(gv));
break;
case 'N':
- if (len == 4 && strEQ(second_letter, "AME"))
+ if (memEQs(elem, len, "NAME"))
sv = newSVhek(GvNAME_HEK(gv));
break;
case 'P':
- if (len == 7 && strEQ(second_letter, "ACKAGE")) {
+ if (memEQs(elem, len, "PACKAGE")) {
const HV * const stash = GvSTASH(gv);
const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
}
break;
case 'S':
- if (len == 6 && strEQ(second_letter, "CALAR"))
+ if (memEQs(elem, len, "SCALAR"))
tmpRef = GvSVn(gv);
break;
}
}
}
else
- sv_setpvs(retval, "");
+ SvPVCLEAR(retval);
}
else if (s && len) {
s += --len;
SvNIOK_off(sv);
}
else
- sv_setpvs(retval, "");
+ SvPVCLEAR(retval);
SvSETMAGIC(sv);
}
return count;
{
SV * const arg = TOPs;
const NV value = SvNV_nomg(arg);
+#ifdef NV_NAN
NV result = NV_NAN;
+#else
+ NV result = 0.0;
+#endif
if (neg_report) { /* log or sqrt */
if (
#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
repl = SvPV_const(repl_sv_copy, repl_len);
}
if (!SvOK(sv))
- sv_setpvs(sv, "");
+ SvPVCLEAR(sv);
sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
SvREFCNT_dec(repl_sv_copy);
}
PP(pp_split)
{
dSP; dTARG;
- AV *ary = PL_op->op_flags & OPf_STACKED ? (AV *)POPs : NULL;
+ AV *ary = ( (PL_op->op_private & OPpSPLIT_ASSIGN) /* @a = split */
+ && (PL_op->op_flags & OPf_STACKED)) /* @{expr} = split */
+ ? (AV *)POPs : NULL;
IV limit = POPi; /* note, negative is forever */
SV * const sv = POPs;
STRLEN len;
const char *s = SvPV_const(sv, len);
const bool do_utf8 = DO_UTF8(sv);
const char *strend = s + len;
- PMOP *pm;
+ PMOP *pm = cPMOPx(PL_op);
REGEXP *rx;
SV *dstr;
const char *m;
I32 base;
const U8 gimme = GIMME_V;
bool gimme_scalar;
- const I32 oldsave = PL_savestack_ix;
+ I32 oldsave = PL_savestack_ix;
U32 make_mortal = SVs_TEMP;
bool multiline = 0;
MAGIC *mg = NULL;
-#ifdef DEBUGGING
- Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
-#else
- pm = (PMOP*)POPs;
-#endif
- if (!pm)
- DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
rx = PM_GETRE(pm);
TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
(RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
+ /* handle @ary = split(...) optimisation */
+ if (PL_op->op_private & OPpSPLIT_ASSIGN) {
+ if (!(PL_op->op_flags & OPf_STACKED)) {
+ if (PL_op->op_private & OPpSPLIT_LEX) {
+ if (PL_op->op_private & OPpLVAL_INTRO)
+ SAVECLEARSV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
+ ary = (AV *)PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff);
+ }
+ else {
+ GV *gv =
#ifdef USE_ITHREADS
- if (pm->op_pmreplrootu.op_pmtargetoff) {
- ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
- goto have_av;
- }
+ MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
#else
- if (pm->op_pmreplrootu.op_pmtargetgv) {
- ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
- goto have_av;
- }
+ pm->op_pmreplrootu.op_pmtargetgv;
#endif
- else if (pm->op_targ)
- ary = (AV *)PAD_SVl(pm->op_targ);
- if (ary) {
- have_av:
+ if (PL_op->op_private & OPpLVAL_INTRO)
+ ary = save_ary(gv);
+ else
+ ary = GvAVn(gv);
+ }
+ /* skip anything pushed by OPpLVAL_INTRO above */
+ oldsave = PL_savestack_ix;
+ }
+
realarray = 1;
PUTBACK;
av_extend(ary,0);
make_mortal = 0;
}
}
+
base = SP - PL_stack_base;
orig = s;
if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
dVAR; dSP;
return PL_ppaddr[
(SvTYPE(TOPs) == SVt_PVAV ? OP_AEACH : OP_EACH)
- + (PL_op->op_private & 3)
+ + (PL_op->op_private & OPpAVHVSWITCH_MASK)
](aTHX);
}
assert (re != (REGEXP*) &PL_sv_undef);
eng = re ? RX_ENGINE(re) : current_re_engine();
- /*
- In the below logic: these are basically the same - check if this regcomp is part of a split.
-
- (PL_op->op_pmflags & PMf_split )
- (PL_op->op_next->op_type == OP_PUSHRE)
-
- We could add a new mask for this and copy the PMf_split, if we did
- some bit definition fiddling first.
-
- For now we leave this
- */
-
new_re = (eng->op_comp
? eng->op_comp
: &Perl_re_op_compile
#if !defined(USE_ITHREADS)
/* can't change the optree at runtime either */
/* PMf_KEEP is handled differently under threads to avoid these problems */
- if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
+ /* Handle empty pattern */
+ if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm) {
+ if (PL_curpm == PL_reg_curpm)
+ Perl_croak(aTHX_ "Use of the empty pattern inside of "
+ "a regex code block is forbidden");
pm = PL_curpm;
+ }
if (pm->op_pmflags & PMf_KEEP) {
pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
cLOGOP->op_first->op_next = PL_op->op_next;
RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
}
}
- sv_setpvs(TARG, "");
+ SvPVCLEAR(TARG);
SETs(targ);
RETURN;
}
{
PERL_CONTEXT *cx;
U8 gimme;
+ SV **base;
SV **oldsp;
- SV **mark;
cx = CX_CUR();
assert(CxTYPE_is_LOOP(cx));
- mark = PL_stack_base + cx->blk_oldsp;
- oldsp = CxTYPE(cx) == CXt_LOOP_LIST
+ oldsp = PL_stack_base + cx->blk_oldsp;
+ base = CxTYPE(cx) == CXt_LOOP_LIST
? PL_stack_base + cx->blk_loop.state_u.stack.basesp
- : mark;
+ : oldsp;
gimme = cx->blk_gimme;
if (gimme == G_VOID)
- PL_stack_sp = oldsp;
+ PL_stack_sp = base;
else
- leave_adjust_stacks(MARK, oldsp, gimme,
+ leave_adjust_stacks(oldsp, base, gimme,
PL_op->op_private & OPpLVALUE ? 3 : 1);
CX_LEAVE_SCOPE(cx);
*/
SV *left = POPs; SV *right = TOPs;
- if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
+ if (PL_op->op_private & OPpASSIGN_BACKWARDS) { /* {or,and,dor}assign */
SV * const temp = left;
left = right; right = temp;
}
&& ckWARN(WARN_UNINITIALIZED)
)
report_uninit(left);
- sv_setpvs(left, "");
+ SvPVCLEAR(left);
}
else {
SvPV_force_nomg_nolen(left);
| (count << SAVE_TIGHT_SHIFT)
| SAVEt_CLEARPADRANGE);
STATIC_ASSERT_STMT(OPpPADRANGE_COUNTMASK + 1 == (1 << OPpPADRANGE_COUNTSHIFT));
- assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) == base);
+ assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
+ == (Size_t)base);
{
dSS_ADD;
SS_ADD_UV(payload);
RETURN;
}
-PP(pp_pushre)
-{
- dSP;
-#ifdef DEBUGGING
- /*
- * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
- * will be enough to hold an OP*.
- */
- SV* const sv = sv_newmortal();
- sv_upgrade(sv, SVt_PVLV);
- LvTYPE(sv) = '/';
- Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
- XPUSHs(sv);
-#else
- XPUSHs(MUTABLE_SV(PL_op));
-#endif
- RETURN;
-}
-
/* Oversized hot code. */
/* also used for: pp_say() */
/* empty pattern special-cased to use last successful pattern if
possible, except for qr// */
- if (!ReANY(rx)->mother_re && !RX_PRELEN(rx)
- && PL_curpm) {
+ if (!ReANY(rx)->mother_re && !RX_PRELEN(rx) && PL_curpm) {
+ if (PL_curpm == PL_reg_curpm)
+ Perl_croak(aTHX_ "Use of the empty pattern inside of "
+ "a regex code block is forbidden");
pm = PL_curpm;
rx = PM_GETRE(pm);
}
position, once with zero-length,
second time with non-zero. */
- if (!RX_PRELEN(rx) && PL_curpm
- && !ReANY(rx)->mother_re) {
+ /* handle the empty pattern */
+ if (!RX_PRELEN(rx) && PL_curpm && !ReANY(rx)->mother_re) {
+ if (PL_curpm == PL_reg_curpm)
+ Perl_croak(aTHX_ "Use of the empty pattern inside of "
+ "a regex code block is forbidden");
pm = PL_curpm;
rx = PM_GETRE(pm);
}
const char *patend = pat + fromlen;
MARK++;
- sv_setpvs(cat, "");
+ SvPVCLEAR(cat);
SvUTF8_off(cat);
packlist(cat, pat, patend, MARK, SP + 1);
PERL_CALLCONV OP *Perl_pp_prtf(pTHX);
PERL_CALLCONV OP *Perl_pp_push(pTHX);
PERL_CALLCONV OP *Perl_pp_pushmark(pTHX);
-PERL_CALLCONV OP *Perl_pp_pushre(pTHX);
PERL_CALLCONV OP *Perl_pp_qr(pTHX);
PERL_CALLCONV OP *Perl_pp_quotemeta(pTHX);
PERL_CALLCONV OP *Perl_pp_rand(pTHX);
ENTER_with_name("backtick");
SAVESPTR(PL_rs);
PL_rs = &PL_sv_undef;
- sv_setpvs(TARG, ""); /* note that this preserves previous buffer */
+ SvPVCLEAR(TARG); /* note that this preserves previous buffer */
while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
NOOP;
LEAVE_with_name("backtick");
goto say_undef;
bufsv = *++MARK;
if (! SvOK(bufsv))
- sv_setpvs(bufsv, "");
+ SvPVCLEAR(bufsv);
length = SvIVx(*++MARK);
if (length < 0)
DIE(aTHX_ "Negative length");
havefp = FALSE;
PL_laststype = OP_STAT;
PL_statgv = gv ? gv : (GV *)io;
- sv_setpvs(PL_statname, "");
+ SvPVCLEAR(PL_statname);
if(gv) {
io = GvIO(gv);
}
}
else {
PL_statgv = gv;
- sv_setpvs(PL_statname, "");
+ SvPVCLEAR(PL_statname);
io = GvIO(PL_statgv);
}
PL_laststatval = -1;
assert(len);
if (! is_utf8_invariant_string((U8 *) s, len)) {
- const U8 *ep;
/* Here contains a variant under UTF-8 . See if the entire string is
- * UTF-8. But the buffer may end in a partial character, so if it
- * failed, see if the failure was due just to that */
- if ( is_utf8_string_loc((U8 *) s, len, &ep)
- || is_utf8_valid_partial_char(ep, (U8 *) s + len))
- {
+ * UTF-8. */
+ if (is_utf8_fixed_width_buf_flags((U8 *) s, len, 0)) {
if (PL_op->op_type == OP_FTTEXT) {
FT_RETURNYES;
}
__attribute__warn_unused_result__
__attribute__pure__; */
+PERL_STATIC_INLINE bool S_is_c9strict_utf8_string(const U8 *s, const STRLEN len)
+ __attribute__pure__;
+#define PERL_ARGS_ASSERT_IS_C9STRICT_UTF8_STRING \
+ assert(s)
+
+/* PERL_CALLCONV bool is_c9strict_utf8_string_loc(const U8 *s, const STRLEN len, const U8 **ep); */
+PERL_STATIC_INLINE bool S_is_c9strict_utf8_string_loclen(const U8 *s, const STRLEN len, const U8 **ep, STRLEN *el);
+#define PERL_ARGS_ASSERT_IS_C9STRICT_UTF8_STRING_LOCLEN \
+ assert(s)
/* PERL_CALLCONV bool Perl_is_invariant_string(const U8* const s, const STRLEN len)
__attribute__warn_unused_result__
__attribute__pure__; */
PERL_CALLCONV I32 Perl_is_lvalue_sub(pTHX)
__attribute__warn_unused_result__;
+PERL_STATIC_INLINE bool S_is_strict_utf8_string(const U8 *s, const STRLEN len)
+ __attribute__pure__;
+#define PERL_ARGS_ASSERT_IS_STRICT_UTF8_STRING \
+ assert(s)
+
+/* PERL_CALLCONV bool is_strict_utf8_string_loc(const U8 *s, const STRLEN len, const U8 **ep); */
+PERL_STATIC_INLINE bool S_is_strict_utf8_string_loclen(const U8 *s, const STRLEN len, const U8 **ep, STRLEN *el);
+#define PERL_ARGS_ASSERT_IS_STRICT_UTF8_STRING_LOCLEN \
+ assert(s)
PERL_CALLCONV bool Perl_is_uni_alnum(pTHX_ UV c)
__attribute__deprecated__
__attribute__warn_unused_result__
#define PERL_ARGS_ASSERT_IS_UTF8_DIGIT \
assert(p)
+/* PERL_CALLCONV bool is_utf8_fixed_width_buf_flags(const U8 * const s, const STRLEN len, const U32 flags); */
+/* PERL_CALLCONV bool is_utf8_fixed_width_buf_loc_flags(const U8 * const s, const STRLEN len, const U8 **ep, const U32 flags); */
+PERL_STATIC_INLINE bool S_is_utf8_fixed_width_buf_loclen_flags(const U8 * const s, const STRLEN len, const U8 **ep, STRLEN *el, const U32 flags);
+#define PERL_ARGS_ASSERT_IS_UTF8_FIXED_WIDTH_BUF_LOCLEN_FLAGS \
+ assert(s)
PERL_CALLCONV bool Perl_is_utf8_graph(pTHX_ const U8 *p)
__attribute__deprecated__
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_IS_UTF8_STRING \
assert(s)
+PERL_STATIC_INLINE bool S_is_utf8_string_flags(const U8 *s, const STRLEN len, const U32 flags)
+ __attribute__pure__;
+#define PERL_ARGS_ASSERT_IS_UTF8_STRING_FLAGS \
+ assert(s)
+
#ifndef NO_MATHOMS
PERL_CALLCONV bool Perl_is_utf8_string_loc(const U8 *s, const STRLEN len, const U8 **ep);
#define PERL_ARGS_ASSERT_IS_UTF8_STRING_LOC \
assert(s); assert(ep)
#endif
+/* PERL_CALLCONV bool is_utf8_string_loc_flags(const U8 *s, const STRLEN len, const U8 **ep, const U32 flags); */
PERL_STATIC_INLINE bool Perl_is_utf8_string_loclen(const U8 *s, const STRLEN len, const U8 **ep, STRLEN *el);
#define PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN \
assert(s)
+PERL_STATIC_INLINE bool S_is_utf8_string_loclen_flags(const U8 *s, const STRLEN len, const U8 **ep, STRLEN *el, const U32 flags);
+#define PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN_FLAGS \
+ assert(s)
PERL_CALLCONV bool Perl_is_utf8_upper(pTHX_ const U8 *p)
__attribute__deprecated__
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_PERL_RUN \
assert(my_perl)
PERL_CALLCONV void Perl_pmop_dump(pTHX_ PMOP* pm);
-PERL_CALLCONV OP* Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor);
+PERL_CALLCONV OP* Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor);
#define PERL_ARGS_ASSERT_PMRUNTIME \
assert(o); assert(expr)
PERL_CALLCONV void Perl_pop_scope(pTHX);
PERL_CALLCONV void Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr);
#define PERL_ARGS_ASSERT_SV_SETPV \
assert(sv)
+PERL_CALLCONV char * Perl_sv_setpv_bufsize(pTHX_ SV *const sv, const STRLEN cur, const STRLEN len);
+#define PERL_ARGS_ASSERT_SV_SETPV_BUFSIZE \
+ assert(sv)
PERL_CALLCONV void Perl_sv_setpv_mg(pTHX_ SV *const sv, const char *const ptr);
#define PERL_ARGS_ASSERT_SV_SETPV_MG \
assert(sv)
#define PERL_ARGS_ASSERT_UTF8_TO_UVUNI_BUF \
assert(s); assert(send)
-PERL_CALLCONV UV Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags);
+PERL_CALLCONV UV Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, const U32 flags);
#define PERL_ARGS_ASSERT_UTF8N_TO_UVCHR \
assert(s)
+PERL_CALLCONV UV Perl_utf8n_to_uvchr_error(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, const U32 flags, U32 * errors);
+#define PERL_ARGS_ASSERT_UTF8N_TO_UVCHR_ERROR \
+ assert(s)
PERL_CALLCONV UV Perl_utf8n_to_uvuni(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags);
#define PERL_ARGS_ASSERT_UTF8N_TO_UVUNI \
assert(s)
assert(s); assert(e)
# endif
#endif
+#if defined(DEBUGGING) && defined(ENABLE_REGEX_SETS_DEBUGGING)
+# if defined(PERL_IN_REGCOMP_C)
+STATIC void S_dump_regex_sets_structures(pTHX_ RExC_state_t *pRExC_state, AV * stack, const IV fence, AV * fence_stack);
+#define PERL_ARGS_ASSERT_DUMP_REGEX_SETS_STRUCTURES \
+ assert(pRExC_state); assert(stack); assert(fence_stack)
+# endif
+#endif
#if defined(DEBUG_LEAKING_SCALARS_FORK_DUMP)
PERL_CALLCONV void Perl_dump_sv_child(pTHX_ SV *sv);
#define PERL_ARGS_ASSERT_DUMP_SV_CHILD \
#define PERL_ARGS_ASSERT_REG_CHECK_NAMED_BUFF_MATCHED \
assert(rex); assert(scan)
-STATIC void S_regcppop(pTHX_ regexp *rex, U32 *maxopenparen_p);
+STATIC void S_regcp_restore(pTHX_ regexp *rex, I32 ix, U32 *maxopenparen_p _pDEPTH);
+#define PERL_ARGS_ASSERT_REGCP_RESTORE \
+ assert(rex); assert(maxopenparen_p)
+STATIC void S_regcppop(pTHX_ regexp *rex, U32 *maxopenparen_p _pDEPTH);
#define PERL_ARGS_ASSERT_REGCPPOP \
assert(rex); assert(maxopenparen_p)
-STATIC CHECKPOINT S_regcppush(pTHX_ const regexp *rex, I32 parenfloor, U32 maxopenparen);
+STATIC CHECKPOINT S_regcppush(pTHX_ const regexp *rex, I32 parenfloor, U32 maxopenparen _pDEPTH);
#define PERL_ARGS_ASSERT_REGCPPUSH \
assert(rex)
STATIC U8* S_reghop3(U8 *s, SSize_t off, const U8 *lim)
#define PERL_ARGS_ASSERT_REGMATCH \
assert(reginfo); assert(startpos); assert(prog)
-STATIC I32 S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, regmatch_info *const reginfo, I32 max, int depth)
+STATIC I32 S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, regmatch_info *const reginfo, I32 max _pDEPTH)
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_REGREPEAT \
assert(prog); assert(startposp); assert(p); assert(reginfo)
assert(stash); assert(name)
#endif
#if defined(PERL_IN_UTF8_C)
+STATIC char * S__byte_dump_string(pTHX_ const U8 * s, const STRLEN len);
+#define PERL_ARGS_ASSERT__BYTE_DUMP_STRING \
+ assert(s)
STATIC UV S__to_utf8_case(pTHX_ const UV uv1, const U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp, const char *normal, const char *special);
#define PERL_ARGS_ASSERT__TO_UTF8_CASE \
assert(p); assert(ustrp); assert(swashp); assert(normal)
#define PERL_ARGS_ASSERT_CHECK_LOCALE_BOUNDARY_CROSSING \
assert(p); assert(ustrp); assert(lenp)
+PERL_STATIC_INLINE bool S_does_utf8_overflow(const U8 * const s, const U8 * e)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+#define PERL_ARGS_ASSERT_DOES_UTF8_OVERFLOW \
+ assert(s); assert(e)
+
PERL_STATIC_INLINE bool S_is_utf8_common(pTHX_ const U8 *const p, SV **swash, const char * const swashname, SV* const invlist)
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_IS_UTF8_COMMON \
#define PERL_ARGS_ASSERT_IS_UTF8_CP_ABOVE_31_BITS \
assert(s); assert(e)
+PERL_STATIC_INLINE bool S_is_utf8_overlong_given_start_byte_ok(const U8 * const s, const STRLEN len)
+ __attribute__warn_unused_result__
+ __attribute__pure__;
+#define PERL_ARGS_ASSERT_IS_UTF8_OVERLONG_GIVEN_START_BYTE_OK \
+ assert(s)
+
STATIC U8* S_swash_scan_list_line(pTHX_ U8* l, U8* const lend, UV* min, UV* max, UV* val, const bool wants_value, const U8* const typestr)
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_SWASH_SCAN_LIST_LINE \
STATIC U8 S_to_lower_latin1(const U8 c, U8 *p, STRLEN *lenp)
__attribute__warn_unused_result__;
+STATIC char * S_unexpected_non_continuation_text(pTHX_ const U8 * const s, STRLEN print_len, const STRLEN non_cont_byte_pos, const STRLEN expect_len)
+ __attribute__warn_unused_result__;
+#define PERL_ARGS_ASSERT_UNEXPECTED_NON_CONTINUATION_TEXT \
+ assert(s)
+
#endif
#if defined(PERL_IN_UTF8_C) || defined(PERL_IN_PP_C)
PERL_CALLCONV UV Perl__to_upper_title_latin1(pTHX_ const U8 c, U8 *p, STRLEN *lenp, const char S_or_s);
* 37f6186253da9824bdb27f4ad867bfe8c25d4dc6bdb2f05585e40a034675a348 lib/unicore/extracted/DLineBreak.txt
* ef24061b5a5dc93d7e90c2e34530ec757180ee75d872cba65ffc946e52624ae8 lib/unicore/extracted/DNumType.txt
* a197371fec9a1b517058b440841f60f9378d81682084eef8db22a88cb2f96e90 lib/unicore/extracted/DNumValues.txt
- * 5c7eb94310e2aaa15702fd6bed24ff0e7ab5448f9a8231d8c49ca96c9e941089 lib/unicore/mktables
+ * 421444fcd83fcdfecffa743c8888c3a1a8e88bcde472a80fca57d199ec5db10a lib/unicore/mktables
* cdecb300baad839a6f62791229f551a4fa33f3cbdca08e378dc976466354e778 lib/unicore/version
* 913d2f93f3cb6cdf1664db888bf840bc4eb074eef824e082fceda24a9445e60c regen/charset_translations.pl
* 66e20f857451956f9fc7ad7432de972e84fb857885009838878bcf6f91ffbeef regen/regcharclass.pl
#define STATIC static
#endif
-#ifndef MIN
-#define MIN(a,b) ((a) < (b) ? (a) : (b))
-#endif
-
-#ifndef MAX
-#define MAX(a,b) ((a) > (b) ? (a) : (b))
-#endif
-
/* this is a chain of data about sub patterns we are processing that
need to be handled separately/specially in study_chunk. Its so
we can simulate recursion without losing state. */
STATIC void
S_invlist_replace_list_destroys_src(pTHX_ SV * dest, SV * src)
{
- /* Replaces the inversion list in 'src' with the one in 'dest'. It steals
- * the list from 'src', so 'src' is made to have a NULL list. This is
- * similar to what SvSetMagicSV() would do, if it were implemented on
+ /* Replaces the inversion list in 'dest' with the one from 'src'. It
+ * steals the list from 'src', so 'src' is made to have a NULL list. This
+ * is similar to what SvSetMagicSV() would do, if it were implemented on
* inversion lists, though this routine avoids a copy */
const UV src_len = _invlist_len(src);
Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
const bool complement_b, SV** output)
{
- /* Take the union of two inversion lists and point <output> to it. *output
- * SHOULD BE DEFINED upon input, and if it points to one of the two lists,
- * the reference count to that list will be decremented if not already a
- * temporary (mortal); otherwise just its contents will be modified to be
- * the union. The first list, <a>, may be NULL, in which case a copy of
- * the second list is returned. If <complement_b> is TRUE, the union is
- * taken of the complement (inversion) of <b> instead of b itself.
+ /* Take the union of two inversion lists and point '*output' to it. On
+ * input, '*output' MUST POINT TO NULL OR TO AN SV* INVERSION LIST (possibly
+ * even 'a' or 'b'). If to an inversion list, the contents of the original
+ * list will be replaced by the union. The first list, 'a', may be
+ * NULL, in which case a copy of the second list is placed in '*output'.
+ * If 'complement_b' is TRUE, the union is taken of the complement
+ * (inversion) of 'b' instead of b itself.
*
* The basis for this comes from "Unicode Demystified" Chapter 13 by
* Richard Gillam, published by Addison-Wesley, and explained at some
PERL_ARGS_ASSERT__INVLIST_UNION_MAYBE_COMPLEMENT_2ND;
assert(a != b);
+ assert(*output == NULL || SvTYPE(*output) == SVt_INVLIST);
len_b = _invlist_len(b);
if (len_b == 0) {
- /* Here, 'b' is empty. If the output is the complement of 'b', the
- * union is all possible code points, and we need not even look at 'a'.
- * It's easiest to create a new inversion list that matches everything.
- * */
+ /* Here, 'b' is empty, hence it's complement is all possible code
+ * points. So if the union includes the complement of 'b', it includes
+ * everything, and we need not even look at 'a'. It's easiest to
+ * create a new inversion list that matches everything. */
if (complement_b) {
SV* everything = _add_range_to_invlist(NULL, 0, UV_MAX);
- /* If the output didn't exist, just point it at the new list */
- if (*output == NULL) {
+ if (*output == NULL) { /* If the output didn't exist, just point it
+ at the new list */
*output = everything;
- return;
+ }
+ else { /* Otherwise, replace its contents with the new list */
+ invlist_replace_list_destroys_src(*output, everything);
+ SvREFCNT_dec_NN(everything);
}
- /* Otherwise, replace its contents with the new list */
- invlist_replace_list_destroys_src(*output, everything);
- SvREFCNT_dec_NN(everything);
return;
}
- /* Here, we don't want the complement of 'b', and since it is empty,
+ /* Here, we don't want the complement of 'b', and since 'b' is empty,
* the union will come entirely from 'a'. If 'a' is NULL or empty, the
* output will be empty */
- if (a == NULL) {
- *output = _new_invlist(0);
+ if (a == NULL || _invlist_len(a) == 0) {
+ if (*output == NULL) {
+ *output = _new_invlist(0);
+ }
+ else {
+ invlist_clear(*output);
+ }
return;
}
- if (_invlist_len(a) == 0) {
- invlist_clear(*output);
+ /* Here, 'a' is not empty, but 'b' is, so 'a' entirely determines the
+ * union. We can just return a copy of 'a' if '*output' doesn't point
+ * to an existing list */
+ if (*output == NULL) {
+ *output = invlist_clone(a);
return;
}
- /* Here, 'a' is not empty, and entirely determines the union. If the
- * output is not to overwrite 'b', we can just return 'a'. */
- if (*output != b) {
-
- /* If the output is to overwrite 'a', we have a no-op, as it's
- * already in 'a' */
- if (*output == a) {
- return;
- }
-
- /* But otherwise we have to copy 'a' to the output */
- *output = invlist_clone(a);
+ /* If the output is to overwrite 'a', we have a no-op, as it's
+ * already in 'a' */
+ if (*output == a) {
return;
}
- /* Here, 'b' is to be overwritten by the output, which will be 'a' */
+ /* Here, '*output' is to be overwritten by 'a' */
u = invlist_clone(a);
invlist_replace_list_destroys_src(*output, u);
SvREFCNT_dec_NN(u);
return;
}
+ /* Here 'b' is not empty. See about 'a' */
+
if (a == NULL || ((len_a = _invlist_len(a)) == 0)) {
/* Here, 'a' is empty (and b is not). That means the union will come
- * entirely from 'b'. If the output is not to overwrite 'a', we can
- * just return what's in 'b'. */
- if (*output != a) {
-
- /* If the output is to overwrite 'b', it's already in 'b', but
- * otherwise we have to copy 'b' to the output */
- if (*output != b) {
- *output = invlist_clone(b);
- }
+ * entirely from 'b'. If '*output' is NULL, we can directly return a
+ * clone of 'b'. Otherwise, we replace the contents of '*output' with
+ * the clone */
- /* And if the output is to be the inversion of 'b', do that */
- if (complement_b) {
- _invlist_invert(*output);
- }
-
- return;
+ SV ** dest = (*output == NULL) ? output : &u;
+ *dest = invlist_clone(b);
+ if (complement_b) {
+ _invlist_invert(*dest);
}
- /* Here, 'a', which is empty or even NULL, is to be overwritten by the
- * output, which will either be 'b' or the complement of 'b' */
-
- if (a == NULL) {
- *output = invlist_clone(b);
- }
- else {
- u = invlist_clone(b);
+ if (dest == &u) {
invlist_replace_list_destroys_src(*output, u);
SvREFCNT_dec_NN(u);
- }
-
- if (complement_b) {
- _invlist_invert(*output);
}
return;
array_u = _invlist_array_init(u, ( len_a > 0 && array_a[0] == 0)
|| (len_b > 0 && array_b[0] == 0));
- /* Go through each input list item by item, stopping when exhausted one of
- * them */
+ /* Go through each input list item by item, stopping when have exhausted
+ * one of them */
while (i_a < len_a && i_b < len_b) {
UV cp; /* The element to potentially add to the union's array */
bool cp_in_set; /* is it in the the input list's set or not */
array_u = invlist_array(u);
}
- /* If the output is not to overwrite either of the inputs, just return the
- * calculated union */
- if (a != *output && b != *output) {
+ if (*output == NULL) { /* Simply return the new inversion list */
*output = u;
}
else {
- /* Here, the output is to be the same as one of the input scalars,
- * hence replacing it. The simple thing to do is to free the input
- * scalar, making it instead be the output one. But experience has
- * shown [perl #127392] that if the input is a mortal, we can get a
- * huge build-up of these during regex compilation before they get
- * freed. So for that case, replace just the input's interior with
- * the union's, and then free the union */
-
- assert(! invlist_is_iterating(*output));
-
- if (! SvTEMP(*output)) {
- SvREFCNT_dec_NN(*output);
- *output = u;
- }
- else {
- invlist_replace_list_destroys_src(*output, u);
- SvREFCNT_dec_NN(u);
- }
+ /* Otherwise, overwrite the inversion list that was in '*output'. We
+ * could instead free '*output', and then set it to 'u', but experience
+ * has shown [perl #127392] that if the input is a mortal, we can get a
+ * huge build-up of these during regex compilation before they get
+ * freed. */
+ invlist_replace_list_destroys_src(*output, u);
+ SvREFCNT_dec_NN(u);
}
return;
Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
const bool complement_b, SV** i)
{
- /* Take the intersection of two inversion lists and point <i> to it. *i
- * SHOULD BE DEFINED upon input, and if it points to one of the two lists,
- * the reference count to that list will be decremented if not already a
- * temporary (mortal); otherwise just its contents will be modified to be
- * the intersection. The first list, <a>, may be NULL, in which case an
- * empty list is returned. If <complement_b> is TRUE, the result will be
- * the intersection of <a> and the complement (or inversion) of <b> instead
- * of <b> directly.
+ /* Take the intersection of two inversion lists and point '*i' to it. On
+ * input, '*i' MUST POINT TO NULL OR TO AN SV* INVERSION LIST (possibly
+ * even 'a' or 'b'). If to an inversion list, the contents of the original
+ * list will be replaced by the intersection. The first list, 'a', may be
+ * NULL, in which case '*i' will be an empty list. If 'complement_b' is
+ * TRUE, the result will be the intersection of 'a' and the complement (or
+ * inversion) of 'b' instead of 'b' directly.
*
* The basis for this comes from "Unicode Demystified" Chapter 13 by
* Richard Gillam, published by Addison-Wesley, and explained at some
PERL_ARGS_ASSERT__INVLIST_INTERSECTION_MAYBE_COMPLEMENT_2ND;
assert(a != b);
+ assert(*i == NULL || SvTYPE(*i) == SVt_INVLIST);
/* Special case if either one is empty */
len_a = (a == NULL) ? 0 : _invlist_len(a);
return;
}
- /* If not overwriting either input, just make a copy of 'a' */
- if (*i != b) {
+ if (*i == NULL) {
*i = invlist_clone(a);
return;
}
- /* Here we are overwriting 'b' with 'a's contents */
r = invlist_clone(a);
invlist_replace_list_destroys_src(*i, r);
SvREFCNT_dec_NN(r);
array_r = _invlist_array_init(r, len_a > 0 && array_a[0] == 0
&& len_b > 0 && array_b[0] == 0);
- /* Go through each list item by item, stopping when exhausted one of
+ /* Go through each list item by item, stopping when have exhausted one of
* them */
while (i_a < len_a && i_b < len_b) {
UV cp; /* The element to potentially add to the intersection's
array_r = invlist_array(r);
}
- /* Finish outputting any remaining */
- if (count >= 2) { /* At most one will have a non-zero copy count */
- IV copy_count;
- if ((copy_count = len_a - i_a) > 0) {
- Copy(array_a + i_a, array_r + i_r, copy_count, UV);
- }
- else if ((copy_count = len_b - i_b) > 0) {
- Copy(array_b + i_b, array_r + i_r, copy_count, UV);
- }
- }
-
- /* If the output is not to overwrite either of the inputs, just return the
- * calculated intersection */
- if (a != *i && b != *i) {
+ if (*i == NULL) { /* Simply return the calculated intersection */
*i = r;
}
- else {
- /* Here, the output is to be the same as one of the input scalars,
- * hence replacing it. The simple thing to do is to free the input
- * scalar, making it instead be the output one. But experience has
- * shown [perl #127392] that if the input is a mortal, we can get a
- * huge build-up of these during regex compilation before they get
- * freed. So for that case, replace just the input's interior with
- * the output's, and then free the output. A short-cut in this case
- * is if the output is empty, we can just set the input to be empty */
-
- assert(! invlist_is_iterating(*i));
-
- if (! SvTEMP(*i)) {
- SvREFCNT_dec_NN(*i);
- *i = r;
+ else { /* Otherwise, replace the existing inversion list in '*i'. We could
+ instead free '*i', and then set it to 'r', but experience has
+ shown [perl #127392] that if the input is a mortal, we can get a
+ huge build-up of these during regex compilation before they get
+ freed. */
+ if (len_r) {
+ invlist_replace_list_destroys_src(*i, r);
}
else {
- if (len_r) {
- invlist_replace_list_destroys_src(*i, r);
- }
- else {
- invlist_clear(*i);
- }
- SvREFCNT_dec_NN(r);
+ invlist_clear(*i);
}
+ SvREFCNT_dec_NN(r);
}
return;
redo_curchar:
+#ifdef ENABLE_REGEX_SETS_DEBUGGING
+ /* Enable with -Accflags=-DENABLE_REGEX_SETS_DEBUGGING */
+ DEBUG_U(dump_regex_sets_structures(pRExC_state,
+ stack, fence, fence_stack));
+#endif
+
top_index = av_tindex_nomg(stack);
switch (curchar) {
{
SV* i = NULL;
SV* u = NULL;
- SV* element;
_invlist_union(lhs, rhs, &u);
_invlist_intersection(lhs, rhs, &i);
- /* _invlist_subtract will overwrite rhs
- without freeing what it already contains */
- element = rhs;
_invlist_subtract(u, i, &rhs);
SvREFCNT_dec_NN(i);
SvREFCNT_dec_NN(u);
- SvREFCNT_dec_NN(element);
break;
}
}
Set_Node_Length(node, RExC_parse - oregcomp_parse + 1); /* MJD */
return node;
}
+
+#ifdef ENABLE_REGEX_SETS_DEBUGGING
+
+STATIC void
+S_dump_regex_sets_structures(pTHX_ RExC_state_t *pRExC_state,
+ AV * stack, const IV fence, AV * fence_stack)
+{ /* Dumps the stacks in handle_regex_sets() */
+
+ const SSize_t stack_top = av_tindex_nomg(stack);
+ const SSize_t fence_stack_top = av_tindex_nomg(fence_stack);
+ SSize_t i;
+
+ PERL_ARGS_ASSERT_DUMP_REGEX_SETS_STRUCTURES;
+
+ PerlIO_printf(Perl_debug_log, "\nParse position is:%s\n", RExC_parse);
+
+ if (stack_top < 0) {
+ PerlIO_printf(Perl_debug_log, "Nothing on stack\n");
+ }
+ else {
+ PerlIO_printf(Perl_debug_log, "Stack: (fence=%d)\n", (int) fence);
+ for (i = stack_top; i >= 0; i--) {
+ SV ** element_ptr = av_fetch(stack, i, FALSE);
+ if (! element_ptr) {
+ }
+
+ if (IS_OPERATOR(*element_ptr)) {
+ PerlIO_printf(Perl_debug_log, "[%d]: %c\n",
+ (int) i, (int) SvIV(*element_ptr));
+ }
+ else {
+ PerlIO_printf(Perl_debug_log, "[%d] ", (int) i);
+ sv_dump(*element_ptr);
+ }
+ }
+ }
+
+ if (fence_stack_top < 0) {
+ PerlIO_printf(Perl_debug_log, "Nothing on fence_stack\n");
+ }
+ else {
+ PerlIO_printf(Perl_debug_log, "Fence_stack: \n");
+ for (i = fence_stack_top; i >= 0; i--) {
+ SV ** element_ptr = av_fetch(fence_stack, i, FALSE);
+ if (! element_ptr) {
+ }
+
+ PerlIO_printf(Perl_debug_log, "[%d]: %d\n",
+ (int) i, (int) SvIV(*element_ptr));
+ }
+ }
+}
+
+#endif
+
#undef IS_OPERATOR
#undef IS_OPERAND
PERL_ARGS_ASSERT_REGPROP;
- sv_setpvn(sv, "", 0);
+ SvPVCLEAR(sv);
if (OP(o) > REGNODE_MAX) /* regnode.type is unsigned */
/* It would be nice to FAIL() here, but this may be called from
= (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]);
- DEBUG_TRIE_COMPILE_r(
+ DEBUG_TRIE_COMPILE_r({
+ if (trie->jump)
+ sv_catpvs(sv, "(JUMP)");
Perl_sv_catpvf(aTHX_ sv,
"<S:%"UVuf"/%"IVdf" W:%"UVuf" L:%"UVuf"/%"UVuf" C:%"UVuf"/%"UVuf">",
(UV)trie->startstate,
(UV)TRIE_CHARCOUNT(trie),
(UV)trie->uniquecharcount
);
- );
+ });
if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
sv_catpvs(sv, "[");
(void) put_charclass_bitmap_innards(sv,
);
sv_catpvs(sv, "]");
}
-
} else if (k == CURLY) {
U32 lo = ARG1(o), hi = ARG2(o);
if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
#endif
const regnode *nextbranch= NULL;
I32 word_idx;
- sv_setpvs(sv, "");
+ SvPVCLEAR(sv);
for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
}
my ($flags,$retval,$plain_func,@args) = @$_;
- if ($flags =~ / ( [^AabDdEfiMmnOoPpRrsUXx] ) /x) {
+ if ($flags =~ / ( [^AabDdEfiMmnOoPpRrsUWXx] ) /x) {
warn "flag $1 is not legal (for function $plain_func)";
}
my @nonnull;
+ my $has_depth = ( $flags =~ /W/ );
my $has_context = ( $flags !~ /n/ );
my $never_returns = ( $flags =~ /r/ );
my $binarycompat = ( $flags =~ /b/ );
else {
$ret .= "void" if !$has_context;
}
+ $ret .= " _pDEPTH" if $has_depth;
$ret .= ")";
my @attrs;
if ( $flags =~ /r/ ) {
$ret .= "\t" x ($t < 4 ? 4 - $t : 1);
$ret .= full_name($func, $flags) . "(aTHX";
$ret .= "_ " if $alist;
- $ret .= $alist . ")\n";
+ $ret .= $alist;
+ if ($flags =~ /W/) {
+ if ($alist) {
+ $ret .= " _aDEPTH";
+ } else {
+ die "Can't use W without other args (currently)";
+ }
+ }
+ $ret .= ")\n";
}
$ret = "#ifndef NO_MATHOMS\n$ret#endif\n" if $flags =~ /b/;
}
# my $x
addbits($_, 7 => qw(OPpLVAL_INTRO LVINTRO))
- for qw(gvsv rv2sv rv2hv rv2gv rv2av aelem helem aslice
+ for qw(gvsv rv2sv rv2hv rv2gv rv2av aelem helem aslice split
hslice delete padsv padav padhv enteriter entersub padrange
pushmark cond_expr refassign lvref lvrefslice lvavref multideref),
'list', # this gets set in my_attrs() for some reason
# Pattern coming in on the stack
-addbits($_, 6 => qw(OPpRUNTIME RTIME))
- for qw(match subst substcont qr pushre);
+addbits($_, 5 => qw(OPpRUNTIME RTIME))
+ for qw(match subst substcont qr split);
addbits('padrange',
# bits 0..6 hold target range
'0..6' => {
- label => '-',
+ label => 'range',
mask_def => 'OPpPADRANGE_COUNTMASK',
bitcount_def => 'OPpPADRANGE_COUNTSHIFT',
}
for (qw(aelemfast aelemfast_lex)) {
addbits($_,
'0..7' => {
- label => '-',
+ label => 'key',
}
);
}
-addbits('split', 7 => qw(OPpSPLIT_IMPLIM IMPLIM)); # implicit limit
-
+addbits('split',
+ # @a = split() has been replaced with split() where split itself
+ # does the array assign
+ 4 => qw(OPpSPLIT_ASSIGN ASSIGN),
+ 3 => qw(OPpSPLIT_LEX LEX), # the OPpSPLIT_ASSIGN is a lexical array
+ 2 => qw(OPpSPLIT_IMPLIM IMPLIM), # implicit limit
+);
addbits($_,
-addbits('avhvswitch', '0..1' => { });
+addbits('avhvswitch',
+ '0..1' => {
+ mask_def => 'OPpAVHVSWITCH_MASK',
+ label => 'offset',
+ }
+);
+
addbits('argelem',
'1..2' => {
padhv private hash ck_null d0
padany private value ck_null d0
-pushre push regexp ck_null d/
-
# References and stuff.
rv2gv ref-to-glob cast ck_rvconst ds1
transr transliteration (tr///) ck_match is" S
# Lvalue operators.
-# sassign is special-cased for op class
-sassign scalar assignment ck_sassign s0
+sassign scalar assignment ck_sassign s2 S S
aassign list assignment ck_null t2 L L
chop chop ck_spair mts% L
unpack unpack ck_fun u@ S S?
pack pack ck_fun fmst@ S L
-split split ck_split t@ S S S
+split split ck_split t/ S S S
join join or string ck_join fmst@ S L
# List operators.
* are needed for the regexp context stack bookkeeping. */
STATIC CHECKPOINT
-S_regcppush(pTHX_ const regexp *rex, I32 parenfloor, U32 maxopenparen)
+S_regcppush(pTHX_ const regexp *rex, I32 parenfloor, U32 maxopenparen _pDEPTH)
{
const int retval = PL_savestack_ix;
const int paren_elems_to_push =
DEBUG_BUFFERS_r(
if ((int)maxopenparen > (int)parenfloor)
- Perl_re_printf( aTHX_
+ Perl_re_exec_indentf( aTHX_
"rex=0x%"UVxf" offs=0x%"UVxf": saving capture indices:\n",
- PTR2UV(rex),
+ depth,
+ PTR2UV(rex),
PTR2UV(rex->offs)
);
);
SSPUSHIV(rex->offs[p].end);
SSPUSHIV(rex->offs[p].start);
SSPUSHINT(rex->offs[p].start_tmp);
- DEBUG_BUFFERS_r(Perl_re_printf( aTHX_
+ DEBUG_BUFFERS_r(Perl_re_exec_indentf( aTHX_
" \\%"UVuf": %"IVdf"(%"IVdf")..%"IVdf"\n",
- (UV)p,
+ depth,
+ (UV)p,
(IV)rex->offs[p].start,
(IV)rex->offs[p].start_tmp,
(IV)rex->offs[p].end
STATIC void
-S_regcppop(pTHX_ regexp *rex, U32 *maxopenparen_p)
+S_regcppop(pTHX_ regexp *rex, U32 *maxopenparen_p _pDEPTH)
{
UV i;
U32 paren;
/* Now restore the parentheses context. */
DEBUG_BUFFERS_r(
if (i || rex->lastparen + 1 <= rex->nparens)
- Perl_re_printf( aTHX_
+ Perl_re_exec_indentf( aTHX_
"rex=0x%"UVxf" offs=0x%"UVxf": restoring capture indices to:\n",
- PTR2UV(rex),
+ depth,
+ PTR2UV(rex),
PTR2UV(rex->offs)
);
);
tmps = SSPOPIV;
if (paren <= rex->lastparen)
rex->offs[paren].end = tmps;
- DEBUG_BUFFERS_r( Perl_re_printf( aTHX_
+ DEBUG_BUFFERS_r( Perl_re_exec_indentf( aTHX_
" \\%"UVuf": %"IVdf"(%"IVdf")..%"IVdf"%s\n",
- (UV)paren,
+ depth,
+ (UV)paren,
(IV)rex->offs[paren].start,
(IV)rex->offs[paren].start_tmp,
(IV)rex->offs[paren].end,
if (i > *maxopenparen_p)
rex->offs[i].start = -1;
rex->offs[i].end = -1;
- DEBUG_BUFFERS_r( Perl_re_printf( aTHX_
+ DEBUG_BUFFERS_r( Perl_re_exec_indentf( aTHX_
" \\%"UVuf": %s ..-1 undeffing\n",
- (UV)i,
+ depth,
+ (UV)i,
(i > *maxopenparen_p) ? "-1" : " "
));
}
* but without popping the stack */
STATIC void
-S_regcp_restore(pTHX_ regexp *rex, I32 ix, U32 *maxopenparen_p)
+S_regcp_restore(pTHX_ regexp *rex, I32 ix, U32 *maxopenparen_p _pDEPTH)
{
I32 tmpix = PL_savestack_ix;
+ PERL_ARGS_ASSERT_REGCP_RESTORE;
+
PL_savestack_ix = ix;
regcppop(rex, maxopenparen_p);
PL_savestack_ix = tmpix;
reginfo->poscache_maxiter = 0;
if (utf8_target) {
- if (!prog->check_utf8 && prog->check_substr)
+ if ((!prog->anchored_utf8 && prog->anchored_substr)
+ || (!prog->float_utf8 && prog->float_substr))
to_utf8_substr(prog);
check = prog->check_utf8;
} else {
swap = prog->offs;
/* do we need a save destructor here for eval dies? */
Newxz(prog->offs, (prog->nparens + 1), regexp_paren_pair);
- DEBUG_BUFFERS_r(Perl_re_printf( aTHX_
+ DEBUG_BUFFERS_r(Perl_re_exec_indentf( aTHX_
"rex=0x%"UVxf" saving offs: orig=0x%"UVxf" new=0x%"UVxf"\n",
- PTR2UV(prog),
+ 0,
+ PTR2UV(prog),
PTR2UV(swap),
PTR2UV(prog->offs)
));
DEBUG_BUFFERS_r(
if (swap)
- Perl_re_printf( aTHX_
+ Perl_re_exec_indentf( aTHX_
"rex=0x%"UVxf" freeing offs: 0x%"UVxf"\n",
- PTR2UV(prog),
+ 0,
+ PTR2UV(prog),
PTR2UV(swap)
);
);
if (swap) {
/* we failed :-( roll it back */
- DEBUG_BUFFERS_r(Perl_re_printf( aTHX_
+ DEBUG_BUFFERS_r(Perl_re_exec_indentf( aTHX_
"rex=0x%"UVxf" rolling back offs: freeing=0x%"UVxf" restoring=0x%"UVxf"\n",
- PTR2UV(prog),
+ 0,
+ PTR2UV(prog),
PTR2UV(prog->offs),
PTR2UV(swap)
));
* above-mentioned test suite tests to succeed. The common theme
* on those tests seems to be returning null fields from matches.
* --jhi updated by dapm */
+
+ /* After encountering a variant of the issue mentioned above I think
+ * the point Ilya was making is that if we properly unwind whenever
+ * we set lastparen to a smaller value then we should not need to do
+ * this every time, only when needed. So if we have tests that fail if
+ * we remove this, then it suggests somewhere else we are improperly
+ * unwinding the lastparen/paren buffers. See UNWIND_PARENS() and
+ * places it is called, and related regcp() routines. - Yves */
#if 1
if (prog->nparens) {
regexp_paren_pair *pp = prog->offs;
I32 nextchr; /* is always set to UCHARAT(locinput), or -1 at EOS */
bool result = 0; /* return value of S_regmatch */
- int depth = 0; /* depth of backtrack stack */
+ U32 depth = 0; /* depth of backtrack stack */
U32 nochange_depth = 0; /* depth of GOSUB recursion with nochange */
const U32 max_nochange_depth =
(3 * rex->nparens > MAX_RECURSE_EVAL_NOCHANGE_DEPTH) ?
PERL_ARGS_ASSERT_REGMATCH;
- DEBUG_OPTIMISE_r( DEBUG_EXECUTE_r({
- Perl_re_printf( aTHX_ "regmatch start\n");
- }));
-
st = PL_regmatch_state;
/* Note that nextchr is a byte even in UTF */
SET_nextchr;
scan = prog;
+
+ DEBUG_OPTIMISE_r( DEBUG_EXECUTE_r({
+ DUMP_EXEC_POS( locinput, scan, utf8_target, depth );
+ Perl_re_printf( aTHX_ "regmatch start\n" );
+ }));
+
while (scan != NULL) {
DEBUG_TRIE_EXECUTE_r({
DUMP_EXEC_POS( (char *)uc, scan, utf8_target, depth );
- Perl_re_exec_indentf( aTHX_
- "%sState: %4"UVxf" Accepted: %c ",
- depth, PL_colors[4],
+ /* HERE */
+ PerlIO_printf( Perl_debug_log,
+ "%*s%sState: %4"UVxf" Accepted: %c ",
+ INDENT_CHARS(depth), "", PL_colors[4],
(UV)state, (accepted ? 'Y' : 'N'));
});
case TRIE_next_fail: /* we failed - try next alternative */
{
U8 *uc;
- if ( ST.jump) {
+ if ( ST.jump ) {
REGCP_UNWIND(ST.cp);
UNWIND_PAREN(ST.lastparen, ST.lastcloseparen);
}
no_final = 0;
}
- if ( ST.jump) {
+ if ( ST.jump ) {
ST.lastparen = rex->lastparen;
ST.lastcloseparen = rex->lastcloseparen;
REGCP_SET(ST.cp);
);
});
- if (ST.accepted > 1 || has_cutgroup) {
+ if ( ST.accepted > 1 || has_cutgroup || ST.jump ) {
PUSH_STATE_GOTO(TRIE_next, scan, (char*)uc);
NOT_REACHED; /* NOTREACHED */
}
CV *newcv;
/* save *all* paren positions */
- regcppush(rex, 0, maxopenparen);
+ regcppush(rex, 0, maxopenparen);
REGCP_SET(runops_cp);
if (!caller_cv)
* in the regexp code uses the pad ! */
PL_op = oop;
PL_curcop = ocurcop;
- S_regcp_restore(aTHX_ rex, runops_cp, &maxopenparen);
+ regcp_restore(rex, runops_cp, &maxopenparen);
PL_curpm = PL_reg_curpm;
if (logical != 2)
rexi = RXi_GET(rex);
REGCP_UNWIND(ST.lastcp);
- regcppop(rex, &maxopenparen);
+ regcppop(rex, &maxopenparen);
cur_eval = ST.prev_eval;
cur_curlyx = ST.prev_curlyx;
rex->offs[n].start_tmp = locinput - reginfo->strbeg;
if (n > maxopenparen)
maxopenparen = n;
- DEBUG_BUFFERS_r(Perl_re_printf( aTHX_
+ DEBUG_BUFFERS_r(Perl_re_exec_indentf( aTHX_
"rex=0x%"UVxf" offs=0x%"UVxf": \\%"UVuf": set %"IVdf" tmp; maxopenparen=%"UVuf"\n",
+ depth,
PTR2UV(rex),
PTR2UV(rex->offs),
(UV)n,
#define CLOSE_CAPTURE \
rex->offs[n].start = rex->offs[n].start_tmp; \
rex->offs[n].end = locinput - reginfo->strbeg; \
- DEBUG_BUFFERS_r(Perl_re_printf( aTHX_ \
+ DEBUG_BUFFERS_r(Perl_re_exec_indentf( aTHX_ \
"rex=0x%"UVxf" offs=0x%"UVxf": \\%"UVuf": set %"IVdf"..%"IVdf"\n", \
+ depth, \
PTR2UV(rex), \
PTR2UV(rex->offs), \
(UV)n, \
/* First just match a string of min A's. */
if (n < min) {
- ST.cp = regcppush(rex, cur_curlyx->u.curlyx.parenfloor,
- maxopenparen);
+ ST.cp = regcppush(rex, cur_curlyx->u.curlyx.parenfloor, maxopenparen);
cur_curlyx->u.curlyx.lastloc = locinput;
REGCP_SET(ST.lastcp);
if (cur_curlyx->u.curlyx.minmod) {
ST.save_curlyx = cur_curlyx;
cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
- ST.cp = regcppush(rex, ST.save_curlyx->u.curlyx.parenfloor,
+ ST.cp = regcppush(rex, ST.save_curlyx->u.curlyx.parenfloor,
maxopenparen);
REGCP_SET(ST.lastcp);
PUSH_YES_STATE_GOTO(WHILEM_B_min, ST.save_curlyx->u.curlyx.B,
/* Prefer A over B for maximal matching. */
if (n < max) { /* More greed allowed? */
- ST.cp = regcppush(rex, cur_curlyx->u.curlyx.parenfloor,
+ ST.cp = regcppush(rex, cur_curlyx->u.curlyx.parenfloor,
maxopenparen);
cur_curlyx->u.curlyx.lastloc = locinput;
REGCP_SET(ST.lastcp);
/* FALLTHROUGH */
case WHILEM_A_pre_fail: /* just failed to match even minimal A */
REGCP_UNWIND(ST.lastcp);
- regcppop(rex, &maxopenparen);
+ regcppop(rex, &maxopenparen);
cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
cur_curlyx->u.curlyx.count--;
CACHEsayNO;
case WHILEM_A_max_fail: /* just failed to match A in a maximal match */
REGCP_UNWIND(ST.lastcp);
- regcppop(rex, &maxopenparen); /* Restore some previous $<digit>s? */
+ regcppop(rex, &maxopenparen); /* Restore some previous $<digit>s? */
DEBUG_EXECUTE_r(Perl_re_exec_indentf( aTHX_ "whilem: failed, trying continuation...\n",
depth)
);
case WHILEM_B_min_fail: /* just failed to match B in a minimal match */
cur_curlyx = ST.save_curlyx;
REGCP_UNWIND(ST.lastcp);
- regcppop(rex, &maxopenparen);
+ regcppop(rex, &maxopenparen);
if (cur_curlyx->u.curlyx.count >= /*max*/ARG2(cur_curlyx->u.curlyx.me)) {
/* Maximum greed exceeded */
);
/* Try grabbing another A and see if it helps. */
cur_curlyx->u.curlyx.lastloc = locinput;
- ST.cp = regcppush(rex, cur_curlyx->u.curlyx.parenfloor,
+ ST.cp = regcppush(rex, cur_curlyx->u.curlyx.parenfloor,
maxopenparen);
REGCP_SET(ST.lastcp);
PUSH_STATE_GOTO(WHILEM_A_min,
char *li = locinput;
minmod = 0;
if (ST.min &&
- regrepeat(rex, &li, ST.A, reginfo, ST.min, depth)
+ regrepeat(rex, &li, ST.A, reginfo, ST.min)
< ST.min)
sayNO;
SET_locinput(li);
/* avoid taking address of locinput, so it can remain
* a register var */
char *li = locinput;
- ST.count = regrepeat(rex, &li, ST.A, reginfo, ST.max, depth);
+ ST.count = regrepeat(rex, &li, ST.A, reginfo, ST.max);
if (ST.count < ST.min)
sayNO;
SET_locinput(li);
* locinput matches */
char *li = ST.oldloc;
ST.count += n;
- if (regrepeat(rex, &li, ST.A, reginfo, n, depth) < n)
+ if (regrepeat(rex, &li, ST.A, reginfo, n) < n)
sayNO;
assert(n == REG_INFTY || locinput == li);
}
/* failed -- move forward one */
{
char *li = locinput;
- if (!regrepeat(rex, &li, ST.A, reginfo, 1, depth)) {
+ if (!regrepeat(rex, &li, ST.A, reginfo, 1)) {
sayNO;
}
locinput = li;
st->u.eval.prev_rex = rex_sv; /* inner */
/* Save *all* the positions. */
- st->u.eval.cp = regcppush(rex, 0, maxopenparen);
+ st->u.eval.cp = regcppush(rex, 0, maxopenparen);
rex_sv = CUR_EVAL.prev_rex;
is_utf8_pat = reginfo->is_utf8_pat = cBOOL(RX_UTF8(rex_sv));
SET_reg_curpm(rex_sv);
/* Restore parens of the outer rex without popping the
* savestack */
- S_regcp_restore(aTHX_ rex, CUR_EVAL.lastcp,
- &maxopenparen);
+ regcp_restore(rex, CUR_EVAL.lastcp, &maxopenparen);
st->u.eval.prev_eval = cur_eval;
cur_eval = CUR_EVAL.prev_eval;
*/
STATIC I32
S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p,
- regmatch_info *const reginfo, I32 max, int depth)
+ regmatch_info *const reginfo, I32 max _pDEPTH)
{
char *scan; /* Pointer to current position in target string */
I32 c;
unsigned int to_complement = 0; /* Invert the result? */
UV utf8_flags;
_char_class_number classnum;
-#ifndef DEBUGGING
- PERL_UNUSED_ARG(depth);
-#endif
PERL_ARGS_ASSERT_REGREPEAT;
*/
/*
- Set in Perl_pmruntime if op_flags & OPf_SPECIAL, i.e. split. Will
- be used by regex engines to check whether they should set
- RXf_SKIPWHITE
+ Set in Perl_pmruntime for a split. Will be used by regex engines to
+ check whether they should set RXf_SKIPWHITE
*/
#define RXf_SPLIT RXf_PMf_SPLIT
=for apidoc Ams||LEAVE
Closing bracket on a callback. See C<L</ENTER>> and L<perlcall>.
-=over
+=for apidoc Ams||ENTER_with_name(name)
-=item ENTER_with_name(name)
-
-Same as C<ENTER>, but when debugging is enabled it also associates the
+Same as C<L</ENTER>>, but when debugging is enabled it also associates the
given literal string with the new scope.
-=item LEAVE_with_name(name)
+=for apidoc Ams||LEAVE_with_name(name)
-Same as C<LEAVE>, but when debugging is enabled it first checks that the
+Same as C<L</LEAVE>>, but when debugging is enabled it first checks that the
scope has the given name. C<name> must be a C<NUL>-terminated literal string.
-=back
-
=cut
*/
}
else if (SvPOKp(sv)) {
UV value;
- const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
+ int numtype;
+ const char *s = SvPVX_const(sv);
+ const STRLEN cur = SvCUR(sv);
+
+ /* short-cut for a single digit string like "1" */
+
+ if (cur == 1) {
+ char c = *s;
+ if (isDIGIT(c)) {
+ if (SvTYPE(sv) < SVt_PVIV)
+ sv_upgrade(sv, SVt_PVIV);
+ (void)SvIOK_on(sv);
+ SvIV_set(sv, (IV)(c - '0'));
+ return FALSE;
+ }
+ }
+
+ numtype = grok_number(s, cur, &value);
/* We want to avoid a possible problem when we cache an IV/ a UV which
may be later translated to an NV, and the resulting NV is not
the same as the direct translation of the initial string
/*
=for apidoc sv_utf8_decode
-If the PV of the SV is an octet sequence in UTF-8
+If the PV of the SV is an octet sequence in Perl's extended UTF-8
and contains a multiple-byte character, the C<SvUTF8> flag is turned on
so that it looks like a character. If the PV contains only single-byte
characters, the C<SvUTF8> flag stays off.
-Scans PV for validity and returns false if the PV is invalid UTF-8.
+Scans PV for validity and returns FALSE if the PV is invalid UTF-8.
=cut
*/
#endif
/*
+=for apidoc sv_setpv_bufsize
+
+Sets the SV to be a string of cur bytes length, with at least
+len bytes available. Ensures that there is a null byte at SvEND.
+Returns a char * pointer to the SvPV buffer.
+
+=cut
+*/
+
+char *
+Perl_sv_setpv_bufsize(pTHX_ SV *const sv, const STRLEN cur, const STRLEN len)
+{
+ char *pv;
+
+ PERL_ARGS_ASSERT_SV_SETPV_BUFSIZE;
+
+ SV_CHECK_THINKFIRST_COW_DROP(sv);
+ SvUPGRADE(sv, SVt_PV);
+ pv = SvGROW(sv, len + 1);
+ SvCUR_set(sv, cur);
+ *(SvEND(sv))= '\0';
+ (void)SvPOK_only_UTF8(sv); /* validate pointer */
+
+ SvTAINT(sv);
+ if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
+ return pv;
+}
+
+/*
=for apidoc sv_setpvn
Copies a string (possibly containing embedded C<NUL> characters) into an SV.
if (ob && SvOBJECT(sv)) {
HvNAME_get(SvSTASH(sv))
? sv_sethek(dst, HvNAME_HEK(SvSTASH(sv)))
- : sv_setpvn(dst, "__ANON__", 8);
+ : sv_setpvs(dst, "__ANON__");
}
else {
const char * reftype = sv_reftype(sv, 0);
{
PERL_ARGS_ASSERT_SV_VSETPVFN;
- sv_setpvs(sv, "");
+ SvPVCLEAR(sv);
sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, 0);
}
* vectorize happen normally
*/
if (sv_isobject(vecsv) && sv_derived_from(vecsv, "version")) {
- if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
+ if ( hv_existss(MUTABLE_HV(SvRV(vecsv)), "alpha") ) {
Perl_ck_warner_d(aTHX_ packWARN(WARN_PRINTF),
"vector argument not supported with alpha versions");
goto vdblank;
/* magical thingies */
- sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */
- sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */
- sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */
+ SvPVCLEAR(PERL_DEBUG_PAD(0)); /* For regex debugging. */
+ SvPVCLEAR(PERL_DEBUG_PAD(1)); /* ext/re needs these */
+ SvPVCLEAR(PERL_DEBUG_PAD(2)); /* even without DEBUGGING. */
/* Clone the regex array */
switch (obase->op_type) {
+ case OP_UNDEF:
+ /* undef should care if its args are undef - any warnings
+ * will be from tied/magic vars */
+ break;
+
case OP_RV2AV:
case OP_RV2HV:
case OP_PADAV:
case OP_ALARM:
case OP_SEMGET:
case OP_GETLOGIN:
- case OP_UNDEF:
case OP_SUBSTR:
case OP_AEACH:
case OP_EACH:
union _xnvu {
NV xnv_nv; /* numeric value, if any */
HV * xgv_stash;
- struct {
- U32 xlow;
- U32 xhigh;
- } xpad_cop_seq; /* used by pad.c for cop_sequence */
+ line_t xnv_lines; /* used internally by S_scan_subst() */
};
union _xivu {
buffer. SV must be of type >= C<SVt_PV>. One
alternative is to call C<sv_grow> if you are not sure of the type of SV.
+=for apidoc Am|char *|SvPVCLEAR|SV* sv
+Ensures that sv is a SVt_PV and that its SvCUR is 0, and that it is
+properly null terminated. Equivalent to sv_setpvs(""), but more efficient.
+
=cut
*/
+#define SvPVCLEAR(sv) sv_setpv_bufsize(sv,0,0)
#define SvSHARE(sv) PL_sharehook(aTHX_ sv)
#define SvLOCK(sv) PL_lockhook(aTHX_ sv)
#define SvUNLOCK(sv) PL_unlockhook(aTHX_ sv)
local $SIG{__WARN__} = sub { push @warnings, $_[0]; };
eval { sprintf "%vd\n", $x };
is (scalar @warnings, 1);
- like ($warnings[0], qr/Malformed UTF-8 character \(unexpected continuation byte 0x82, with no preceding start byte/);
+ like ($warnings[0], qr/Malformed UTF-8 character: \\x82 \(unexpected continuation byte 0x82, with no preceding start byte/);
}
}
my $x = "" . open my $fh, "<", "no / such / file";
EXPECT
Use of uninitialized value in concatenation (.) or string at - line 3.
+########
+# RT #123910
+# undef's arg being undef doesn't trigger warnings - any warning will be
+# from tied/magic vars
+use warnings 'uninitialized';
+undef $0;
+EXPECT
+Use of uninitialized value in undef operator at - line 5.
my $a = "snøstorm";
}
EXPECT
-Malformed UTF-8 character (unexpected non-continuation byte 0x73, immediately after start byte 0xf8) at - line 9.
-Malformed UTF-8 character (unexpected non-continuation byte 0x73, immediately after start byte 0xf8) at - line 14.
+Malformed UTF-8 character: \xf8\x73\x74\x6f\x72 (unexpected non-continuation byte 0x73, immediately after start byte 0xf8; need 5 bytes, got 1) at - line 9.
+Malformed UTF-8 character: \xf8\x73\x74\x6f\x72 (unexpected non-continuation byte 0x73, immediately after start byte 0xf8; need 5 bytes, got 1) at - line 14.
########
use warnings 'utf8';
my $d7ff = uc(chr(0xD7FF));
}
{};$^H=2**400}Â
EXPECT
-Malformed UTF-8 character (unexpected non-continuation byte 0x0a, immediately after start byte 0xc2) at - line 6.
+Malformed UTF-8 character: \xc2\x0a (unexpected non-continuation byte 0x0a, immediately after start byte 0xc2; need 2 bytes, got 1) at - line 6.
use warnings;
-plan(tests => 277 );
+plan(tests => 280);
# type coercion on assignment
$foo = 'foo';
is ($? & 127, 0,"[perl #128597] No crash when gp_free calls ckWARN_d");
}
+# test gv_try_downgrade()
+# If a GV can be stored in a stash in a compact, non-GV form, then
+# whenever ops are freed which reference the GV, an attempt is made to
+# downgrade the GV to something simpler. Made sure this happens.
+
+package GV_DOWNGRADE {
+ use constant FOO => 1;
+
+ ::like "$GV_DOWNGRADE::{FOO}", qr/SCALAR/, "gv_downgrade: pre";
+ eval q{
+ my $x = \&FOO; # upgrades compact to full GV
+ ::like "$GV_DOWNGRADE::{FOO}", qr/^\*/, "gv_downgrade: full";
+ };
+ # after the eval's ops are freed, the GV should get downgraded again
+ ::like "$GV_DOWNGRADE::{FOO}", qr/SCALAR/, "gv_downgrade: post";
+}
+
__END__
Perl
Rules
BEGIN { chdir 't' if -d 't'; require './test.pl'; }
-plan(tests => 30);
+plan(tests => 32);
{
no warnings 'deprecated';
{},
'[perl #129069] - "Missing name" warning and valgrind clean'
);
+
+fresh_perl_like(
+ "#!perl -i u\nprint 'OK'",
+ qr/OK/,
+ {},
+ '[perl #129336] - #!perl -i argument handling'
+);
+fresh_perl_is(
+ "BEGIN{\$^H=hex ~0}\xF3",
+ "Integer overflow in hexadecimal number at - line 1.\n" .
+ "Malformed UTF-8 character: \\xf3 (too short; got 1 byte, need 4) at - line 1.",
+ {},
+ '[perl #128996] - use of PL_op after op is freed'
+);
my $bad = pack("U0C", 202);
local $SIG{__WARN__} = sub { $@ = "@_" };
my @null = unpack('U0U', $bad);
- like($@, qr/^Malformed UTF-8 character /);
+ like($@, qr/^Malformed UTF-8 character: /);
}
}
set_up_inc('../lib');
}
-plan tests => 131;
+plan tests => 159;
$FS = ':';
}
(@{\@a} = split //, "abc") = 1..10;
is "@a", '1 2 3', 'assignment to split-to-array (stacked)';
+
+# check that re-evals work
+
+{
+ my $c = 0;
+ @a = split /-(?{ $c++ })/, "a-b-c";
+ is "@a", "a b c", "compile-time re-eval";
+ is $c, 2, "compile-time re-eval count";
+
+ my $sep = '-';
+ $c = 0;
+ @a = split /$sep(?{ $c++ })/, "a-b-c";
+ is "@a", "a b c", "run-time re-eval";
+ is $c, 2, "run-time re-eval count";
+}
+
+# check that that my/local @array = split works
+
+{
+ my $s = "a:b:c";
+
+ local @a = qw(x y z);
+ {
+ local @a = split /:/, $s;
+ is "@a", "a b c", "local split inside";
+ }
+ is "@a", "x y z", "local split outside";
+
+ my @b = qw(x y z);
+ {
+ my @b = split /:/, $s;
+ is "@b", "a b c", "my split inside";
+ }
+ is "@b", "x y z", "my split outside";
+}
+
+# check that the (@a = split) optimisation works in scalar/list context
+
+{
+ my $s = "a:b:c:d:e";
+ my @outer;
+ my $outer;
+ my @lex;
+ local our @pkg;
+
+ $outer = (@lex = split /:/, $s);
+ is "@lex", "a b c d e", "array split: scalar cx lex: inner";
+ is $outer, 5, "array split: scalar cx lex: outer";
+
+ @outer = (@lex = split /:/, $s);
+ is "@lex", "a b c d e", "array split: list cx lex: inner";
+ is "@outer", "a b c d e", "array split: list cx lex: outer";
+
+ $outer = (@pkg = split /:/, $s);
+ is "@pkg", "a b c d e", "array split: scalar cx pkg inner";
+ is $outer, 5, "array split: scalar cx pkg outer";
+
+ @outer = (@pkg = split /:/, $s);
+ is "@pkg", "a b c d e", "array split: list cx pkg inner";
+ is "@outer", "a b c d e", "array split: list cx pkg outer";
+
+ $outer = (my @a1 = split /:/, $s);
+ is "@a1", "a b c d e", "array split: scalar cx my lex: inner";
+ is $outer, 5, "array split: scalar cx my lex: outer";
+
+ @outer = (my @a2 = split /:/, $s);
+ is "@a2", "a b c d e", "array split: list cx my lex: inner";
+ is "@outer", "a b c d e", "array split: list cx my lex: outer";
+
+ $outer = (local @pkg = split /:/, $s);
+ is "@pkg", "a b c d e", "array split: scalar cx local pkg inner";
+ is $outer, 5, "array split: scalar cx local pkg outer";
+
+ @outer = (local @pkg = split /:/, $s);
+ is "@pkg", "a b c d e", "array split: list cx local pkg inner";
+ is "@outer", "a b c d e", "array split: list cx local pkg outer";
+
+ $outer = (@{\@lex} = split /:/, $s);
+ is "@lex", "a b c d e", "array split: scalar cx lexref inner";
+ is $outer, 5, "array split: scalar cx lexref outer";
+
+ @outer = (@{\@pkg} = split /:/, $s);
+ is "@pkg", "a b c d e", "array split: list cx pkgref inner";
+ is "@outer", "a b c d e", "array split: list cx pkgref outer";
+
+
+}
my $ordwide = ord($wide);
printf "# under use bytes ord(v256) = 0x%02x\n", $ordwide;
skip_all('UTF-8-centric tests (not valid for UTF-EBCDIC)') if $ordwide == 140;
+ # This could be ported to EBCDIC, but a lot of trouble.
+ # ext/XS-APItest/t/utf8.t contains comprehensive tests for both platforms
if ($ordwide != 196) {
printf "# v256 starts with 0x%02x\n", $ordwide;
no utf8;
+my $is64bit = length sprintf("%x", ~0) > 8;
+
foreach (<DATA>) {
if (/^(?:\d+(?:\.\d+)?)\s/ || /^#/) {
# print "# $_\n";
} elsif (my ($id, $okay, $Unicode, $byteslen, $hex, $charslen, $experr)
= /^(\d+\.\d+\.\d+[bu]?) # ID
- \s+(y|n|N-?\d+) # expect to pass or fail
+ \s+(y|n|N-?\d+(?:,\d+)?) # expect to pass or fail
+ # 'n' means expect one diagnostic
+ # 'N\d+' means expect this
+ # number of diagnostics
+ # 'N\d+,\d+' means expect the first
+ # number of diagnostics
+ # on a 32-bit system; the
+ # second number on a
+ # 64-bit one
\s+([0-9a-f]{1,8}(?:,[0-9a-f]{1,8})*|-) # Unicode characters
\s+(\d+) # number of octets
\s+([0-9a-f]{2}(?::[0-9a-f]{2})*) # octets in hex
isnt($experr, '', "Expected warning for $id provided");
warnings_like(sub {unpack 'C0U*', $octets}, [qr/$experr/],
"Only expected warning for $id");
- } elsif ($okay !~ /^N(-?\d+)/) {
+ } elsif ($okay !~ /^N-?(\d+)(?:,(\d+))?/) {
is($okay, 'n', "Confused test description for $id");
} else {
- my $expect = $1;
+ my $expect32 = $1;
+ my $expect64 = $2 // $expect32;
+ my $expect = ($is64bit) ? $expect64 : $expect32;
my @warnings;
{
unpack 'C0U*', $octets;
}
+ unless (is(scalar @warnings, $expect, "Expected number of warnings for $id seen")) {
+ note(join "", "Got:\n", @warnings);
+ }
isnt($experr, '', "Expected first warning for $id provided");
- like($warnings[0], qr/$experr/, "Expected first warning for $id seen");
+
+ my $message;
+ if ($expect64 != $expect32 && ! $is64bit) {
+ like($warnings[0], qr/overflow/, "overflow warning for $id seen");
+ shift @warnings;
+ $message = "Expected first warning after overflow for $id seen";
+ }
+ else {
+ $message = "Expected first warning for $id seen";
+ }
+ like($warnings[0], qr/$experr/, $message);
local $::TODO;
if ($expect < 0) {
$expect = -$expect;
$::TODO = "Markus Kuhn states that $expect invalid sequences should be signalled";
}
- unless (is(scalar @warnings, $expect, "Expected number of warnings for $id seen")) {
- note(join "", "Got:\n", @warnings);
- }
}
} else {
# This table is based on Markus Kuhn's UTF-8 Decode Stress Tester,
# http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt,
# version dated 2015-08-28.
+#
+# See the code that parses these lines for comments as to the column meanings
__DATA__
1 Correct UTF-8
3.1.8 N7 - 7 80:bf:80:bf:80:bf:80 - unexpected continuation byte 0x80
3.1.9 N64 - 64 80:81:82:83:84:85:86:87:88:89:8a:8b:8c:8d:8e:8f:90:91:92:93:94:95:96:97:98:99:9a:9b:9c:9d:9e:9f:a0:a1:a2:a3:a4:a5:a6:a7:a8:a9:aa:ab:ac:ad:ae:af:b0:b1:b2:b3:b4:b5:b6:b7:b8:b9:ba:bb:bc:bd:be:bf - unexpected continuation byte 0x80
3.2 Lonely start characters
-3.2.1 N32 - 64 c0:20:c1:20:c2:20:c3:20:c4:20:c5:20:c6:20:c7:20:c8:20:c9:20:ca:20:cb:20:cc:20:cd:20:ce:20:cf:20:d0:20:d1:20:d2:20:d3:20:d4:20:d5:20:d6:20:d7:20:d8:20:d9:20:da:20:db:20:dc:20:dd:20:de:20:df:20 - unexpected non-continuation byte 0x20, immediately after start byte 0xc0
+3.2.1 N34 - 64 c0:20:c1:20:c2:20:c3:20:c4:20:c5:20:c6:20:c7:20:c8:20:c9:20:ca:20:cb:20:cc:20:cd:20:ce:20:cf:20:d0:20:d1:20:d2:20:d3:20:d4:20:d5:20:d6:20:d7:20:d8:20:d9:20:da:20:db:20:dc:20:dd:20:de:20:df:20 - unexpected non-continuation byte 0x20, immediately after start byte 0xc0
3.2.2 N16 - 32 e0:20:e1:20:e2:20:e3:20:e4:20:e5:20:e6:20:e7:20:e8:20:e9:20:ea:20:eb:20:ec:20:ed:20:ee:20:ef:20 - unexpected non-continuation byte 0x20, immediately after start byte 0xe0
3.2.3 N8 - 16 f0:20:f1:20:f2:20:f3:20:f4:20:f5:20:f6:20:f7:20 - unexpected non-continuation byte 0x20, immediately after start byte 0xf0
3.2.4 N4 - 8 f8:20:f9:20:fa:20:fb:20 - unexpected non-continuation byte 0x20, immediately after start byte 0xf8
3.2.5 N2 - 4 fc:20:fd:20 - unexpected non-continuation byte 0x20, immediately after start byte 0xfc
3.3 Sequences with last continuation byte missing
-3.3.1 n - 1 c0 - 1 byte, need 2
-3.3.2 n - 2 e0:80 - 2 bytes, need 3
-3.3.3 n - 3 f0:80:80 - 3 bytes, need 4
-3.3.4 n - 4 f8:80:80:80 - 4 bytes, need 5
-3.3.5 n - 5 fc:80:80:80:80 - 5 bytes, need 6
+3.3.1 N2 - 1 c0 - 1 byte, need 2
+3.3.2 N2 - 2 e0:80 - 2 bytes, need 3
+3.3.3 N2 - 3 f0:80:80 - 3 bytes, need 4
+3.3.4 N2 - 4 f8:80:80:80 - 4 bytes, need 5
+3.3.5 N2 - 5 fc:80:80:80:80 - 5 bytes, need 6
3.3.6 n - 1 df - 1 byte, need 2
3.3.7 n - 2 ef:bf - 2 bytes, need 3
3.3.8 n - 3 f7:bf:bf - 3 bytes, need 4
3.3.9 n - 4 fb:bf:bf:bf - 4 bytes, need 5
3.3.10 n - 5 fd:bf:bf:bf:bf - 5 bytes, need 6
3.4 Concatenation of incomplete sequences
-3.4.1 N10 - 30 c0:e0:80:f0:80:80:f8:80:80:80:fc:80:80:80:80:df:ef:bf:f7:bf:bf:fb:bf:bf:bf:fd:bf:bf:bf:bf - unexpected non-continuation byte 0xe0, immediately after start byte 0xc0
-3.5 Impossible bytes
-3.5.1 n - 1 fe - byte 0xfe
-3.5.2 n - 1 ff - byte 0xff
-3.5.3 N4 - 4 fe:fe:ff:ff - byte 0xfe
+3.4.1 N15 - 30 c0:e0:80:f0:80:80:f8:80:80:80:fc:80:80:80:80:df:ef:bf:f7:bf:bf:fb:bf:bf:bf:fd:bf:bf:bf:bf - unexpected non-continuation byte 0xe0, immediately after start byte 0xc0
+3.5 Impossible bytes (but not with Perl's extended UTF-8)
+3.5.1 n - 1 fe - 1 byte, need 7
+3.5.2 N2,1 - 1 ff - 1 byte, need 13
+3.5.3 N8,5 - 4 fe:fe:ff:ff - byte 0xfe
4 Overlong sequences
4.1 Examples of an overlong ASCII character
-4.1.1 n - 2 c0:af - 2 bytes, need 1
-4.1.2 n - 3 e0:80:af - 3 bytes, need 1
-4.1.3 n - 4 f0:80:80:af - 4 bytes, need 1
-4.1.4 n - 5 f8:80:80:80:af - 5 bytes, need 1
-4.1.5 n - 6 fc:80:80:80:80:af - 6 bytes, need 1
+4.1.1 n - 2 c0:af - overlong
+4.1.2 n - 3 e0:80:af - overlong
+4.1.3 n - 4 f0:80:80:af - overlong
+4.1.4 n - 5 f8:80:80:80:af - overlong
+4.1.5 n - 6 fc:80:80:80:80:af - overlong
4.2 Maximum overlong sequences
-4.2.1 n - 2 c1:bf - 2 bytes, need 1
-4.2.2 n - 3 e0:9f:bf - 3 bytes, need 2
-4.2.3 n - 4 f0:8f:bf:bf - 4 bytes, need 3
-4.2.4 n - 5 f8:87:bf:bf:bf - 5 bytes, need 4
-4.2.5 n - 6 fc:83:bf:bf:bf:bf - 6 bytes, need 5
+4.2.1 n - 2 c1:bf - overlong
+4.2.2 n - 3 e0:9f:bf - overlong
+4.2.3 n - 4 f0:8f:bf:bf - overlong
+4.2.4 n - 5 f8:87:bf:bf:bf - overlong
+4.2.5 n - 6 fc:83:bf:bf:bf:bf - overlong
4.3 Overlong representation of the NUL character
-4.3.1 n - 2 c0:80 - 2 bytes, need 1
-4.3.2 n - 3 e0:80:80 - 3 bytes, need 1
-4.3.3 n - 4 f0:80:80:80 - 4 bytes, need 1
-4.3.4 n - 5 f8:80:80:80:80 - 5 bytes, need 1
-4.3.5 n - 6 fc:80:80:80:80:80 - 6 bytes, need 1
+4.3.1 n - 2 c0:80 - overlong
+4.3.2 n - 3 e0:80:80 - overlong
+4.3.3 n - 4 f0:80:80:80 - overlong
+4.3.4 n - 5 f8:80:80:80:80 - overlong
+4.3.5 n - 6 fc:80:80:80:80:80 - overlong
5 Illegal code positions
5.1 Single UTF-16 surrogates
5.1.1 y d800 3 ed:a0:80 1 UTF-16 surrogate 0xd800
setup => 'my ($x,$y); ($x,$y,$z) = (1, 2.2, 3.3);',
code => '$z = $x + $y',
},
+ 'expr::arith::add_lex_ss' => {
+ desc => 'add two short strings and assign to a lexical var',
+ setup => 'my ($x,$y,$z) = ("1", "2", 1);',
+ code => '$z = $x + $y; $x = "1"; ',
+ },
+
+ 'expr::arith::add_lex_ll' => {
+ desc => 'add two long strings and assign to a lexical var',
+ setup => 'my ($x,$y,$z) = ("12345", "23456", 1);',
+ code => '$z = $x + $y; $x = "12345"; ',
+ },
'expr::arith::sub_lex_ii' => {
desc => 'subtract two integers and assign to a lexical var',
},
+
'func::sort::num' => {
desc => 'plain numeric sort',
setup => 'my (@a, @b); @a = reverse 1..10;',
},
+ 'func::split::vars' => {
+ desc => 'split into two lexical vars',
+ setup => 'my $s = "abc:def";',
+ code => 'my ($x, $y) = split /:/, $s, 2;',
+ },
+
+ 'func::split::array' => {
+ desc => 'split into a lexical array',
+ setup => 'my @a; my $s = "abc:def";',
+ code => '@a = split /:/, $s, 2;',
+ },
+ 'func::split::myarray' => {
+ desc => 'split into a lexical array declared in the assign',
+ setup => 'my $s = "abc:def";',
+ code => 'my @a = split /:/, $s, 2;',
+ },
+ 'func::split::arrayexpr' => {
+ desc => 'split into an @{$expr} ',
+ setup => 'my $s = "abc:def"; my $r = []',
+ code => '@$r = split /:/, $s, 2;',
+ },
+ 'func::split::arraylist' => {
+ desc => 'split into an array with extra arg',
+ setup => 'my @a; my $s = "abc:def";',
+ code => '@a = (split(/:/, $s, 2), 1);',
+ },
+
+
'loop::block' => {
desc => 'empty basic loop',
setup => '',
use warnings;
use strict;
-plan 2256;
+plan 2261;
use B ();
}
+
+# in-place assign optimisation for @a = split
+
+{
+ local our @pkg;
+ my @lex;
+
+ for (['@pkg', 0, ],
+ ['local @pkg', 0, ],
+ ['@lex', 0, ],
+ ['my @a', 0, ],
+ ['@{[]}', 1, ],
+ ){
+ # partial implies that the aassign has been optimised away, but
+ # not the rv2av
+ my ($code, $partial) = @$_;
+ test_opcount(0, "in-place assignment for split: $code",
+ eval qq{sub { $code = split }},
+ {
+ padav => 0,
+ rv2av => $partial,
+ aassign => 0,
+ });
+ }
+}
@INC = '../lib';
}
-plan 54;
+plan 59;
use v5.10; # state
use B qw(svref_2object
[ "---", '(undef,$x) = f()', 'single scalar on LHS' ],
[ "---", '($x,$y) = ($x)', 'single scalar on RHS, no AGG' ],
[ "--A", '($x,@b) = ($x)', 'single scalar on RHS' ],
+ [ "--A", 'my @a; @a = (@a = split())', 'split a/a' ],
+ [ "--A", 'my (@a,@b); @a = (@b = split())', 'split a/b' ],
+ [ "---", 'my @a; @a = (split(), 1)', '(split(),1)' ],
+ [ "---", '@a = (split(//, @a), 1)', 'split(@a)' ],
+ [ "--A", 'my @a; my $ar = @a; @a = (@$ar = split())', 'a/ar split' ],
) {
my ($exp, $code, $desc) = @$test;
my $sub = eval "sub { $code }"
Pod::Checker cpan/Pod-Checker/t/pod/selfcheck.t 8ce3cfd38e4b9bcf5bc7fe7f2a14195e49aed7d8
Pod::Checker cpan/Pod-Checker/t/pod/testcmp.pl a0cd5c8eca775c7753f4464eee96fa916e3d8a16
Pod::Checker cpan/Pod-Checker/t/pod/testpchk.pl b2072c7f4379fd050e15424175d7cac5facf5b3b
-Scalar-List-Utils cpan/Scalar-List-Utils/lib/List/Util.pm e479a29c6b66ac5cbbde4ef2296afaab6c4635a6
-Scalar-List-Utils cpan/Scalar-List-Utils/lib/List/Util/XS.pm cbc38838d32fd213ae7b37ac38e30195355be3b9
-Scalar-List-Utils cpan/Scalar-List-Utils/lib/Scalar/Util.pm 14a20075dfb9a4ef33b99115ed6f43e6d1a15f9b
-Scalar-List-Utils cpan/Scalar-List-Utils/lib/Sub/Util.pm b984c0a2935bd5f5cf1733df846c8a8c0661ef32
-Scalar-List-Utils cpan/Scalar-List-Utils/ListUtil.xs 362a247c65878265fd8acae607b207400628ef3b
Socket cpan/Socket/Socket.pm 98e38176d745c38282907f391c077298f5a3d0ba
Socket cpan/Socket/Socket.xs edd4fed212785f11c5c2095a75941dad27d586d9
Test::Harness cpan/Test-Harness/bin/prove 9b2866928cb1125de2c68f9773b25723e02c54c0
YAML::Tiny
dist/data-dumper/changes Verbatim line length including indents exceeds 79 by 1
dist/data-dumper/dumper.pm ? Should you be using L<...> instead of 1
+dist/net-ping/lib/net/ping.pm Apparent broken link 1
ext/amiga-exec/exec.pm Verbatim line length including indents exceeds 79 by 1
ext/dynaloader/dynaloader.pm Verbatim line length including indents exceeds 79 by 1
ext/hash-util/lib/hash/util.pm Verbatim line length including indents exceeds 79 by 2
pod/perltie.pod Verbatim line length including indents exceeds 79 by 3
pod/perltru64.pod Verbatim line length including indents exceeds 79 by 1
pod/perlwin32.pod Verbatim line length including indents exceeds 79 by 7
-porting/epigraphs.pod Verbatim line length including indents exceeds 79 by 16
+porting/epigraphs.pod Verbatim line length including indents exceeds 79 by -1
porting/release_managers_guide.pod Verbatim line length including indents exceeds 79 by 1
porting/todo.pod ? Should you be using F<...> or maybe L<...> instead of 1
-utils/ptar Verbatim paragraph in NAME section 1
lib/benchmark.pm Verbatim line length including indents exceeds 79 by 2
lib/config.pod ? Should you be using L<...> instead of -1
lib/perl5db.pl ? Should you be using L<...> instead of 1
}
}
-if ($^O eq 'linux' && $Config{archname} !~ /^x86/) {
+if ($^O eq 'linux' && $Config{archname} !~ /^(?:x|i6)86/) {
# For example in ppc most (but not all!) code symbols are placed
# in 'D' (data), not in ' T '. We cannot work under such conditions.
skip_all "linux but archname $Config{archname} not x86*";
| $dl_ext # dynamic libraries
| gif # GIF images (example files from CGI.pm)
| eg # examples from libnet
+ | core
)
$
) | ~$ | \ \(Autosaved\)\.txt$ # Other editor droppings
if ($^O eq 'dec_osf') {
skip_all("$^O cannot handle this test");
}
+ watchdog(5 * 60);
require './loc_tools.pl';
}
if ($^O eq 'dec_osf') {
skip_all("$^O cannot handle this test");
}
+ watchdog(5 * 60);
}
aa$|a(?R)a|a aaa y $& aaa # [perl 128420] recursive matches
(?:\1|a)([bcd])\1(?:(?R)|e)\1 abbaccaddedcb y $& abbaccaddedcb # [perl 128420] recursive match with backreferences
AB\s+\x{100} AB \x{100}X y - -
+\b\z0*\x{100} .\x{100} n - - # [perl #129350] crashed in intuit_start
+(.*(a(a)|i(i))n) riiaan y $2-$3-$4-$1 aa-a--riiaan # Jump trie capture buffer issue [perl #129897]
+(^(?:(\d)x)?\d$) 1 y [$1-$2] [1-] # make sure that we reset capture buffers properly (from regtry)
# Keep these lines at the end of the file
# vim: softtabstop=0 noexpandtab
unlike("g", qr/$pat/, "'g' doesn't match /$pat/");
}
+{ # [perl #129322 ] This crashed perl, so keep after the ones that don't
+ my $pat = '(?[[!]&[0]^[!]&[0]+[a]])';
+ like("a", qr/$pat/, "/$pat/ compiles and matches 'a'");
+}
+
done_testing();
1;
no warnings 'once';
if ($^O eq 'dec_osf') {
- print "1..0 # $^O cannot handle this test\n";
- exit(0);
+ print "1..0 # $^O cannot handle this test\n";
+ exit(0);
}
+# TODO: it would be good to have watchdog(5 * 60) in here
+# for slow machines, but unfortunately we cannot trivially
+# use test.pl because the TestProp.pl avoids using that.
+
# This is a wrapper for a generated file. Assumes being run from 't'
# directory.
exit;
}
+$::TESTCHUNK=1;
do '../lib/unicore/TestProp.pl';
# Since TestProp.pl explicitly exits, we will only get here if it
--- /dev/null
+use strict;
+use warnings;
+no warnings 'once';
+
+if ($^O eq 'dec_osf') {
+ print "1..0 # $^O cannot handle this test\n";
+ exit(0);
+}
+
+# TODO: it would be good to have watchdog(5 * 60) in here
+# for slow machines, but unfortunately we cannot trivially
+# use test.pl because the TestProp.pl avoids using that.
+
+# This is a wrapper for a generated file. Assumes being run from 't'
+# directory.
+
+# It is skipped by default under PERL_DEBUG_READONLY_COW, but you can run
+# it directly via: cd t; ./perl -I../lib ../lib/unicore/TestProp.pl
+
+require Config;
+if ($Config::Config{ccflags} =~ /(?:^|\s)-DPERL_DEBUG_READONLY_COW\b/) {
+ print "1..0 # Skip PERL_DEBUG_READONLY_COW\n";
+ exit;
+}
+
+$::TESTCHUNK=2;
+do '../lib/unicore/TestProp.pl';
+
+# Since TestProp.pl explicitly exits, we will only get here if it
+# could not load.
+if (defined &DynaLoader::boot_DynaLoader # not miniperl
+ || eval 'require "unicore/Heavy.pl"' # or tables are built
+) {
+ die "Could not run lib/unicore/TestProp.pl: ", $@||$!;
+}
+else {
+ print "1..0 # Skip Unicode tables not built yet\n";
+}
+
+0
--- /dev/null
+use strict;
+use warnings;
+no warnings 'once';
+
+if ($^O eq 'dec_osf') {
+ print "1..0 # $^O cannot handle this test\n";
+ exit(0);
+}
+
+# TODO: it would be good to have watchdog(5 * 60) in here
+# for slow machines, but unfortunately we cannot trivially
+# use test.pl because the TestProp.pl avoids using that.
+
+# This is a wrapper for a generated file. Assumes being run from 't'
+# directory.
+
+# It is skipped by default under PERL_DEBUG_READONLY_COW, but you can run
+# it directly via: cd t; ./perl -I../lib ../lib/unicore/TestProp.pl
+
+require Config;
+if ($Config::Config{ccflags} =~ /(?:^|\s)-DPERL_DEBUG_READONLY_COW\b/) {
+ print "1..0 # Skip PERL_DEBUG_READONLY_COW\n";
+ exit;
+}
+
+$::TESTCHUNK=3;
+do '../lib/unicore/TestProp.pl';
+
+# Since TestProp.pl explicitly exits, we will only get here if it
+# could not load.
+if (defined &DynaLoader::boot_DynaLoader # not miniperl
+ || eval 'require "unicore/Heavy.pl"' # or tables are built
+) {
+ die "Could not run lib/unicore/TestProp.pl: ", $@||$!;
+}
+else {
+ print "1..0 # Skip Unicode tables not built yet\n";
+}
+
+0
--- /dev/null
+use strict;
+use warnings;
+no warnings 'once';
+
+if ($^O eq 'dec_osf') {
+ print "1..0 # $^O cannot handle this test\n";
+ exit(0);
+}
+
+# TODO: it would be good to have watchdog(5 * 60) in here
+# for slow machines, but unfortunately we cannot trivially
+# use test.pl because the TestProp.pl avoids using that.
+
+# This is a wrapper for a generated file. Assumes being run from 't'
+# directory.
+
+# It is skipped by default under PERL_DEBUG_READONLY_COW, but you can run
+# it directly via: cd t; ./perl -I../lib ../lib/unicore/TestProp.pl
+
+require Config;
+if ($Config::Config{ccflags} =~ /(?:^|\s)-DPERL_DEBUG_READONLY_COW\b/) {
+ print "1..0 # Skip PERL_DEBUG_READONLY_COW\n";
+ exit;
+}
+
+$::TESTCHUNK=4;
+do '../lib/unicore/TestProp.pl';
+
+# Since TestProp.pl explicitly exits, we will only get here if it
+# could not load.
+if (defined &DynaLoader::boot_DynaLoader # not miniperl
+ || eval 'require "unicore/Heavy.pl"' # or tables are built
+) {
+ die "Could not run lib/unicore/TestProp.pl: ", $@||$!;
+}
+else {
+ print "1..0 # Skip Unicode tables not built yet\n";
+}
+
+0
--- /dev/null
+use strict;
+use warnings;
+no warnings 'once';
+
+if ($^O eq 'dec_osf') {
+ print "1..0 # $^O cannot handle this test\n";
+ exit(0);
+}
+
+# TODO: it would be good to have watchdog(5 * 60) in here
+# for slow machines, but unfortunately we cannot trivially
+# use test.pl because the TestProp.pl avoids using that.
+
+# This is a wrapper for a generated file. Assumes being run from 't'
+# directory.
+
+# It is skipped by default under PERL_DEBUG_READONLY_COW, but you can run
+# it directly via: cd t; ./perl -I../lib ../lib/unicore/TestProp.pl
+
+require Config;
+if ($Config::Config{ccflags} =~ /(?:^|\s)-DPERL_DEBUG_READONLY_COW\b/) {
+ print "1..0 # Skip PERL_DEBUG_READONLY_COW\n";
+ exit;
+}
+
+$::TESTCHUNK=5;
+do '../lib/unicore/TestProp.pl';
+
+# Since TestProp.pl explicitly exits, we will only get here if it
+# could not load.
+if (defined &DynaLoader::boot_DynaLoader # not miniperl
+ || eval 'require "unicore/Heavy.pl"' # or tables are built
+) {
+ die "Could not run lib/unicore/TestProp.pl: ", $@||$!;
+}
+else {
+ print "1..0 # Skip Unicode tables not built yet\n";
+}
+
+0
--- /dev/null
+use strict;
+use warnings;
+no warnings 'once';
+
+if ($^O eq 'dec_osf') {
+ print "1..0 # $^O cannot handle this test\n";
+ exit(0);
+}
+
+# TODO: it would be good to have watchdog(5 * 60) in here
+# for slow machines, but unfortunately we cannot trivially
+# use test.pl because the TestProp.pl avoids using that.
+
+# This is a wrapper for a generated file. Assumes being run from 't'
+# directory.
+
+# It is skipped by default under PERL_DEBUG_READONLY_COW, but you can run
+# it directly via: cd t; ./perl -I../lib ../lib/unicore/TestProp.pl
+
+require Config;
+if ($Config::Config{ccflags} =~ /(?:^|\s)-DPERL_DEBUG_READONLY_COW\b/) {
+ print "1..0 # Skip PERL_DEBUG_READONLY_COW\n";
+ exit;
+}
+
+$::TESTCHUNK=6;
+do '../lib/unicore/TestProp.pl';
+
+# Since TestProp.pl explicitly exits, we will only get here if it
+# could not load.
+if (defined &DynaLoader::boot_DynaLoader # not miniperl
+ || eval 'require "unicore/Heavy.pl"' # or tables are built
+) {
+ die "Could not run lib/unicore/TestProp.pl: ", $@||$!;
+}
+else {
+ print "1..0 # Skip Unicode tables not built yet\n";
+}
+
+0
--- /dev/null
+use strict;
+use warnings;
+no warnings 'once';
+
+if ($^O eq 'dec_osf') {
+ print "1..0 # $^O cannot handle this test\n";
+ exit(0);
+}
+
+# TODO: it would be good to have watchdog(5 * 60) in here
+# for slow machines, but unfortunately we cannot trivially
+# use test.pl because the TestProp.pl avoids using that.
+
+# This is a wrapper for a generated file. Assumes being run from 't'
+# directory.
+
+# It is skipped by default under PERL_DEBUG_READONLY_COW, but you can run
+# it directly via: cd t; ./perl -I../lib ../lib/unicore/TestProp.pl
+
+require Config;
+if ($Config::Config{ccflags} =~ /(?:^|\s)-DPERL_DEBUG_READONLY_COW\b/) {
+ print "1..0 # Skip PERL_DEBUG_READONLY_COW\n";
+ exit;
+}
+
+$::TESTCHUNK=7;
+do '../lib/unicore/TestProp.pl';
+
+# Since TestProp.pl explicitly exits, we will only get here if it
+# could not load.
+if (defined &DynaLoader::boot_DynaLoader # not miniperl
+ || eval 'require "unicore/Heavy.pl"' # or tables are built
+) {
+ die "Could not run lib/unicore/TestProp.pl: ", $@||$!;
+}
+else {
+ print "1..0 # Skip Unicode tables not built yet\n";
+}
+
+0
--- /dev/null
+use strict;
+use warnings;
+no warnings 'once';
+
+if ($^O eq 'dec_osf') {
+ print "1..0 # $^O cannot handle this test\n";
+ exit(0);
+}
+
+# TODO: it would be good to have watchdog(5 * 60) in here
+# for slow machines, but unfortunately we cannot trivially
+# use test.pl because the TestProp.pl avoids using that.
+
+# This is a wrapper for a generated file. Assumes being run from 't'
+# directory.
+
+# It is skipped by default under PERL_DEBUG_READONLY_COW, but you can run
+# it directly via: cd t; ./perl -I../lib ../lib/unicore/TestProp.pl
+
+require Config;
+if ($Config::Config{ccflags} =~ /(?:^|\s)-DPERL_DEBUG_READONLY_COW\b/) {
+ print "1..0 # Skip PERL_DEBUG_READONLY_COW\n";
+ exit;
+}
+
+$::TESTCHUNK=8;
+do '../lib/unicore/TestProp.pl';
+
+# Since TestProp.pl explicitly exits, we will only get here if it
+# could not load.
+if (defined &DynaLoader::boot_DynaLoader # not miniperl
+ || eval 'require "unicore/Heavy.pl"' # or tables are built
+) {
+ die "Could not run lib/unicore/TestProp.pl: ", $@||$!;
+}
+else {
+ print "1..0 # Skip Unicode tables not built yet\n";
+}
+
+0
--- /dev/null
+use strict;
+use warnings;
+no warnings 'once';
+
+if ($^O eq 'dec_osf') {
+ print "1..0 # $^O cannot handle this test\n";
+ exit(0);
+}
+
+# TODO: it would be good to have watchdog(5 * 60) in here
+# for slow machines, but unfortunately we cannot trivially
+# use test.pl because the TestProp.pl avoids using that.
+
+# This is a wrapper for a generated file. Assumes being run from 't'
+# directory.
+
+# It is skipped by default under PERL_DEBUG_READONLY_COW, but you can run
+# it directly via: cd t; ./perl -I../lib ../lib/unicore/TestProp.pl
+
+require Config;
+if ($Config::Config{ccflags} =~ /(?:^|\s)-DPERL_DEBUG_READONLY_COW\b/) {
+ print "1..0 # Skip PERL_DEBUG_READONLY_COW\n";
+ exit;
+}
+
+$::TESTCHUNK=9;
+do '../lib/unicore/TestProp.pl';
+
+# Since TestProp.pl explicitly exits, we will only get here if it
+# could not load.
+if (defined &DynaLoader::boot_DynaLoader # not miniperl
+ || eval 'require "unicore/Heavy.pl"' # or tables are built
+) {
+ die "Could not run lib/unicore/TestProp.pl: ", $@||$!;
+}
+else {
+ print "1..0 # Skip Unicode tables not built yet\n";
+}
+
+0
--- /dev/null
+use strict;
+use warnings;
+no warnings 'once';
+
+if ($^O eq 'dec_osf') {
+ print "1..0 # $^O cannot handle this test\n";
+ exit(0);
+}
+
+# TODO: it would be good to have watchdog(5 * 60) in here
+# for slow machines, but unfortunately we cannot trivially
+# use test.pl because the TestProp.pl avoids using that.
+
+# This is a wrapper for a generated file. Assumes being run from 't'
+# directory.
+
+# It is skipped by default under PERL_DEBUG_READONLY_COW, but you can run
+# it directly via: cd t; ./perl -I../lib ../lib/unicore/TestProp.pl
+
+require Config;
+if ($Config::Config{ccflags} =~ /(?:^|\s)-DPERL_DEBUG_READONLY_COW\b/) {
+ print "1..0 # Skip PERL_DEBUG_READONLY_COW\n";
+ exit;
+}
+
+$::TESTCHUNK=10;
+do '../lib/unicore/TestProp.pl';
+
+# Since TestProp.pl explicitly exits, we will only get here if it
+# could not load.
+if (defined &DynaLoader::boot_DynaLoader # not miniperl
+ || eval 'require "unicore/Heavy.pl"' # or tables are built
+) {
+ die "Could not run lib/unicore/TestProp.pl: ", $@||$!;
+}
+else {
+ print "1..0 # Skip Unicode tables not built yet\n";
+}
+
+0
got_some = 0;
} else {
if (!SvPOK(linestr)) /* can get undefined by filter_gets */
- sv_setpvs(linestr, "");
+ SvPVCLEAR(linestr);
eof:
/* End of real input. Close filehandle (unless it was STDIN),
* then add implicit termination.
return;
while (SPACE_OR_TAB(*s))
s++;
- if (strnEQ(s, "line", 4))
+ if (strEQs(s, "line"))
s += 4;
else
return;
sv = *av_fetch(av, 0, 1);
SvUPGRADE(sv, SVt_PVMG);
}
- if (!SvPOK(sv)) sv_setpvs(sv,"");
+ if (!SvPOK(sv)) SvPVCLEAR(sv);
if (orig_sv)
sv_catsv(sv, orig_sv);
else
if (check_keyword) {
char *s2 = PL_tokenbuf;
STRLEN len2 = len;
- if (allow_pack && len > 6 && strnEQ(s2, "CORE::", 6))
+ if (allow_pack && len > 6 && strEQs(s2, "CORE::"))
s2 += 6, len2 -= 6;
if (keyword(s2, len2, 0))
return start;
}
}
NEXTVAL_NEXTTOKE.opval
- = (OP*)newSVOP(OP_CONST,0,
+ = newSVOP(OP_CONST,0,
S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
force_next(token);
if (s[0]) {
const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
- OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
+ OP* const o = newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
UTF ? SVf_UTF8 : 0));
NEXTVAL_NEXTTOKE.opval = o;
force_next(BAREWORD);
SvREFCNT_dec(sv);
sv = nsv;
}
- pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
+ pl_yylval.opval = newSVOP(op_type, 0, sv);
return THING;
}
if (SvUTF8(PL_linestr))
SvUTF8_on(sv);
PL_expect = XOPERATOR;
- pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
+ pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
return THING;
}
}
if (SvTYPE(PL_linestr) >= SVt_PVNV) {
CopLINE(PL_curcop) +=
- ((XPVNV*)SvANY(PL_linestr))->xnv_u.xpad_cop_seq.xlow
+ ((XPVNV*)SvANY(PL_linestr))->xnv_u.xnv_lines
+ PL_parser->herelines;
PL_parser->herelines = 0;
}
* Ranges entirely within Latin1 are expanded out entirely, in
* order to avoid the significant overhead of making a swash.
* Ranges that extend above Latin1 have to have a swash, so there
- * is no advantage to abbreviate them here, so they are stored here
- * as Min, ILLEGAL_UTF8_BYTE, Max. The illegal byte signifies a
- * hyphen without any possible ambiguity. On EBCDIC machines, if
+ * is no advantage to abbreviating them here, so they are stored
+ * here as Min, ILLEGAL_UTF8_BYTE, Max. The illegal byte signifies
+ * a hyphen without any possible ambiguity. On EBCDIC machines, if
* the range is expressed as Unicode, the Latin1 portion is
* expanded out even if the entire range extends above Latin1.
* This is because each code point in it has to be processed here
sv_utf8_upgrade_flags_grow(
sv,
SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
- UVCHR_SKIP(uv) + (STRLEN)(send - e) + 1);
+ OFFUNISKIP(uv) + (STRLEN)(send - e) + 1);
d = SvPVX(sv) + SvCUR(sv);
has_utf8 = TRUE;
}
sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
type, typelen);
}
- pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
+ pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
}
LEAVE_with_name("scan_const");
return s;
if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
return 0; /* no assumptions -- "=>" quotes bareword */
bare_package:
- NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
+ NEXTVAL_NEXTTOKE.opval = newSVOP(OP_CONST, 0,
S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
PL_expect = XTERM;
else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
PL_bufptr - PL_parser->lex_shared->re_eval_start);
NEXTVAL_NEXTTOKE.opval =
- (OP*)newSVOP(OP_CONST, 0,
+ newSVOP(OP_CONST, 0,
sv);
force_next(THING);
PL_parser->lex_shared->re_eval_start = NULL;
if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
SV *sv = newSVsv(PL_linestr);
sv = tokeq(sv);
- pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
+ pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
s = PL_bufend;
}
else {
}
PL_parser->preambling = CopLINE(PL_curcop);
} else
- sv_setpvs(PL_linestr,"");
+ SvPVCLEAR(PL_linestr);
if (PL_preambleav) {
SV **svp = AvARRAY(PL_preambleav);
SV **const end = svp + AvFILLp(PL_preambleav);
}
if (PL_parser->in_pod) {
/* Incest with pod. */
- if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
- sv_setpvs(PL_linestr, "");
+ if (*s == '=' && strEQs(s, "=cut") && !isALPHA(s[4])) {
+ SvPVCLEAR(PL_linestr);
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
PL_last_lop = PL_last_uni = NULL;
/* if we have already added "LINE: while (<>) {",
we must not do it again */
{
- sv_setpvs(PL_linestr, "");
+ SvPVCLEAR(PL_linestr);
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
PL_last_lop = PL_last_uni = NULL;
while (s < PL_bufend && SPACE_OR_TAB(*s))
s++;
- if (strnEQ(s,"=>",2)) {
+ if (strEQs(s,"=>")) {
s = force_word(PL_bufptr,BAREWORD,FALSE,FALSE);
DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
OPERATOR('-'); /* unary minus */
PL_expect = XTERM;
break;
}
- if (strnEQ(s, "sub", 3)) {
+ if (strEQs(s, "sub")) {
d = s + 3;
d = skipspace(d);
if (*d == ':') {
{
const char tmp = *s++;
if (tmp == '=') {
- if ((s == PL_linestart+2 || s[-3] == '\n') && strnEQ(s, "=====", 5)) {
+ if ((s == PL_linestart+2 || s[-3] == '\n') && strEQs(s, "=====")) {
s = vcs_conflict_marker(s + 5);
goto retry;
}
while (s < d) {
if (*s++ == '\n') {
incline(s);
- if (strnEQ(s,"=cut",4)) {
+ if (strEQs(s,"=cut")) {
s = strchr(s,'\n');
if (s)
s++;
if (s[1] != '<' && !strchr(s,'>'))
check_uni();
if (s[1] == '<' && s[2] != '>') {
- if ((s == PL_linestart || s[-1] == '\n') && strnEQ(s+2, "<<<<<", 5)) {
+ if ((s == PL_linestart || s[-1] == '\n') && strEQs(s+2, "<<<<<")) {
s = vcs_conflict_marker(s + 7);
goto retry;
}
{
char tmp = *s++;
if (tmp == '<') {
- if ((s == PL_linestart+2 || s[-3] == '\n') && strnEQ(s, "<<<<<", 5)) {
+ if ((s == PL_linestart+2 || s[-3] == '\n') && strEQs(s, "<<<<<")) {
s = vcs_conflict_marker(s + 5);
goto retry;
}
{
const char tmp = *s++;
if (tmp == '>') {
- if ((s == PL_linestart+2 || s[-3] == '\n') && strnEQ(s, ">>>>>", 5)) {
+ if ((s == PL_linestart+2 || s[-3] == '\n') && strEQs(s, ">>>>>")) {
s = vcs_conflict_marker(s + 5);
goto retry;
}
fat_arrow:
CLINE;
pl_yylval.opval
- = (OP*)newSVOP(OP_CONST, 0,
+ = newSVOP(OP_CONST, 0,
S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
pl_yylval.opval->op_private = OPpCONST_BARE;
TERM(BAREWORD);
reserved_word:
switch (tmp) {
- default: /* not a keyword */
/* Trade off - by using this evil construction we can pull the
variable gv into the block labelled keylookup. If not, then
we have to give it function scope so that the goto from the
earlier ':' case doesn't bypass the initialisation. */
- if (0) {
just_a_word_zero_gv:
sv = NULL;
cv = NULL;
orig_keyword = 0;
lex = 0;
off = 0;
- }
+ default: /* not a keyword */
just_a_word: {
int pkgname = 0;
const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
/* Presume this is going to be a bareword of some sort. */
CLINE;
- pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
+ pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
pl_yylval.opval->op_private = OPpCONST_BARE;
/* And if "Foo::", then that's what it certainly is. */
op_free(pl_yylval.opval);
pl_yylval.opval =
- off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op;
+ off ? newCVREF(0, rv2cv_op) : rv2cv_op;
pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
PL_last_lop = PL_oldbufptr;
PL_last_lop_op = OP_ENTERSUB;
case KEY___FILE__:
FUN0OP(
- (OP*)newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
+ newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
);
case KEY___LINE__:
FUN0OP(
- (OP*)newSVOP(OP_CONST, 0,
+ newSVOP(OP_CONST, 0,
Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)))
);
case KEY___PACKAGE__:
FUN0OP(
- (OP*)newSVOP(OP_CONST, 0,
+ newSVOP(OP_CONST, 0,
(PL_curstash
? newSVhek(HvNAME_HEK(PL_curstash))
: &PL_sv_undef))
char *p = s;
if ((PL_bufend - p) >= 3
- && strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
+ && strEQs(p, "my") && isSPACE(*(p + 2)))
{
p += 2;
}
else if ((PL_bufend - p) >= 4
- && strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
+ && strEQs(p, "our") && isSPACE(*(p + 3)))
p += 3;
p = skipspace(p);
/* skip optional package name, as in "for my abc $x (..)" */
s = skipspace(s);
if (isIDFIRST_lazy_if(s,UTF)) {
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
- if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
+ if (len == 3 && strEQs(PL_tokenbuf, "sub"))
goto really_sub;
PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
if (!PL_in_my_stash) {
if (key == KEY_format) {
if (format_name) {
NEXTVAL_NEXTTOKE.opval
- = (OP*)newSVOP(OP_CONST,0, format_name);
+ = newSVOP(OP_CONST,0, format_name);
NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
force_next(BAREWORD);
}
if (have_proto) {
NEXTVAL_NEXTTOKE.opval =
- (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
+ newSVOP(OP_CONST, 0, PL_lex_stuff);
PL_lex_stuff = NULL;
force_next(THING);
}
SV * const sym = newSVhek(stashname);
sv_catpvs(sym, "::");
sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
- pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
+ pl_yylval.opval = newSVOP(OP_CONST, 0, sym);
pl_yylval.opval->op_private = OPpCONST_ENTERED;
if (pit != '&')
gv_fetchsv(sym,
}
/* build ops for a bareword */
- pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
+ pl_yylval.opval = newSVOP(OP_CONST, 0,
newSVpvn_flags(PL_tokenbuf + 1,
tokenbuf_len - 1,
UTF ? SVf_UTF8 : 0 ));
|| isDIGIT_A((U8)s[1])
|| s[1] == '$'
|| s[1] == '{'
- || strnEQ(s+1,"::",2)) )
+ || strEQs(s+1,"::")) )
{
/* Dereferencing a value in a scalar variable.
The alternatives are different syntaxes for a scalar variable.
}
if (CopLINE(PL_curcop) != first_line) {
sv_upgrade(PL_parser->lex_sub_repl, SVt_PVNV);
- ((XPVNV*)SvANY(PL_parser->lex_sub_repl))->xnv_u.xpad_cop_seq.xlow =
+ ((XPVNV*)SvANY(PL_parser->lex_sub_repl))->xnv_u.xnv_lines =
CopLINE(PL_curcop) - first_line;
CopLINE_set(PL_curcop, first_line);
}
char *oldbufptr_save;
char *oldoldbufptr_save;
streaming:
- sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
+ SvPVCLEAR(tmpstr); /* avoid "uninitialized" warning */
term = PL_tokenbuf[1];
len--;
linestr_save = PL_linestr; /* must restore this afterwards */
OP * const o = newOP(OP_PADSV, 0);
o->op_targ = tmp;
PL_lex_op = readline_overriden
- ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
+ ? newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST, o,
newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
- : (OP*)newUNOP(OP_READLINE, 0, o);
+ : newUNOP(OP_READLINE, 0, o);
}
}
else {
GV_ADDMULTI | ( UTF ? SVf_UTF8 : 0 ),
SVt_PV);
PL_lex_op = readline_overriden
- ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
+ ? newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST,
newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
- : (OP*)newUNOP(OP_READLINE, 0,
+ : newUNOP(OP_READLINE, 0,
newUNOP(OP_RV2SV, 0,
newGVOP(OP_GV, 0, gv)));
}
else {
GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO);
PL_lex_op = readline_overriden
- ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
+ ? newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST,
newGVOP(OP_GV, 0, gv),
newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
- : (OP*)newUNOP(OP_READLINE, nomagicopen ? OPf_SPECIAL : 0, newGVOP(OP_GV, 0, gv));
+ : newUNOP(OP_READLINE, nomagicopen ? OPf_SPECIAL : 0, newGVOP(OP_GV, 0, gv));
pl_yylval.ival = OP_NULL;
}
}
if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
SvUTF8_on(stuff);
}
- NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
+ NEXTVAL_NEXTTOKE.opval = newSVOP(OP_CONST, 0, stuff);
force_next(THING);
}
else {
PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
- sv_setpvs(filter, "");
+ SvPVCLEAR(filter);
IoLINES(filter) = reversed;
IoPAGE(filter) = 1; /* Not EOF */
if (*s == 'v')
s++; /* get past 'v' */
- sv_setpvs(sv, "");
+ SvPVCLEAR(sv);
for (;;) {
/* this is atoi() that tolerates underscores */
* DOUBLE_IS_VAX_F_FLOAT
* DOUBLE_IS_VAX_D_FLOAT
* DOUBLE_IS_VAX_G_FLOAT
+ * DOUBLE_IS_IBM_SINGLE_32_BIT
+ * DOUBLE_IS_IBM_DOUBLE_64_BIT
+ * DOUBLE_IS_CRAY_SINGLE_64_BIT
* DOUBLE_IS_UNKNOWN_FORMAT
*/
#define DOUBLEKIND 3 /**/
#define DOUBLE_IS_VAX_F_FLOAT 9
#define DOUBLE_IS_VAX_D_FLOAT 10
#define DOUBLE_IS_VAX_G_FLOAT 11
+#define DOUBLE_IS_IBM_SINGLE_32_BIT 12
+#define DOUBLE_IS_IBM_DOUBLE_64_BIT 13
+#define DOUBLE_IS_CRAY_SINGLE_64_BIT 14
#define DOUBLE_IS_UNKNOWN_FORMAT -1
/*#define PERL_PRIfldbl "llf" / **/
/*#define PERL_PRIgldbl "llg" / **/
#endif
/* Generated from:
- * 42be1deadbcceadd92a1463d6c11c441bad7c83fe2a4cd1c2ebec7742bb5e8a3 config_h.SH
+ * 6b650d833a54250188bb71d659ae15d31148e6b005c50a63ef8e3599668a1c43 config_h.SH
* 0fca2bf99ac976bba919b593a18bacd059c581dbe6c8638dc0861b1e613b8406 uconfig.sh
* ex: set ro: */
switch (*key) {
case 'i':
- if (klen == 5 && memEQ(key, "input", 5)) {
+ if (memEQs(key, klen, "input")) {
input = SvTRUE(*valp);
break;
}
goto fail;
case 'o':
- if (klen == 6 && memEQ(key, "output", 6)) {
+ if (memEQs(key, klen, "output")) {
input = !SvTRUE(*valp);
break;
}
goto fail;
case 'd':
- if (klen == 7 && memEQ(key, "details", 7)) {
+ if (memEQs(key, klen, "details")) {
details = SvTRUE(*valp);
break;
}
#include "perl.h"
#include "invlist_inline.h"
+static const char malformed_text[] = "Malformed UTF-8 character";
static const char unees[] =
- "Malformed UTF-8 character (unexpected end of string)";
+ "Malformed UTF-8 character (unexpected end of string)";
static const char cp_above_legal_max[] =
"Use of code point 0x%"UVXf" is deprecated; the permissible max is 0x%"UVXf"";
#ifdef EBCDIC
- /* [0] is start byte [1] [2] [3] [4] [5] [6] [7] */
- const U8 * const prefix = "\x41\x41\x41\x41\x41\x41\x42";
+ /* [0] is start byte [1] [2] [3] [4] [5] [6] [7] */
+ const U8 * const prefix = (U8 *) "\x41\x41\x41\x41\x41\x41\x42";
const STRLEN prefix_len = sizeof(prefix) - 1;
const STRLEN len = e - s;
- const cmp_len = MIN(prefix_len, len - 1);
+ const STRLEN cmp_len = MIN(prefix_len, len - 1);
#else
}
+PERL_STATIC_INLINE bool
+S_does_utf8_overflow(const U8 * const s, const U8 * e)
+{
+ const U8 *x;
+ const U8 * y = (const U8 *) HIGHEST_REPRESENTABLE_UTF8;
+
+ /* Returns a boolean as to if this UTF-8 string would overflow a UV on this
+ * platform, that is if it represents a code point larger than the highest
+ * representable code point. (For ASCII platforms, we could use memcmp()
+ * because we don't have to convert each byte to I8, but it's very rare
+ * input indeed that would approach overflow, so the loop below will likely
+ * only get executed once.
+ *
+ * 'e' must not be beyond a full character. If it is less than a full
+ * character, the function returns FALSE if there is any input beyond 'e'
+ * that could result in a non-overflowing code point */
+
+ PERL_ARGS_ASSERT_DOES_UTF8_OVERFLOW;
+ assert(s + UTF8SKIP(s) >= e);
+
+ for (x = s; x < e; x++, y++) {
+
+ /* If this byte is larger than the corresponding highest UTF-8 byte, it
+ * overflows */
+ if (UNLIKELY(NATIVE_UTF8_TO_I8(*x) > *y)) {
+ return TRUE;
+ }
+
+ /* If not the same as this byte, it must be smaller, doesn't overflow */
+ if (LIKELY(NATIVE_UTF8_TO_I8(*x) != *y)) {
+ return FALSE;
+ }
+ }
+
+ /* Got to the end and all bytes are the same. If the input is a whole
+ * character, it doesn't overflow. And if it is a partial character,
+ * there's not enough information to tell, so assume doesn't overflow */
+ return FALSE;
+}
+
+PERL_STATIC_INLINE bool
+S_is_utf8_overlong_given_start_byte_ok(const U8 * const s, const STRLEN len)
+{
+ /* Overlongs can occur whenever the number of continuation bytes
+ * changes. That means whenever the number of leading 1 bits in a start
+ * byte increases from the next lower start byte. That happens for start
+ * bytes C0, E0, F0, F8, FC, FE, and FF. On modern perls, the following
+ * illegal start bytes have already been excluded, so don't need to be
+ * tested here;
+ * ASCII platforms: C0, C1
+ * EBCDIC platforms C0, C1, C2, C3, C4, E0
+ *
+ * At least a second byte is required to determine if other sequences will
+ * be an overlong. */
+
+ const U8 s0 = NATIVE_UTF8_TO_I8(s[0]);
+ const U8 s1 = NATIVE_UTF8_TO_I8(s[1]);
+
+ PERL_ARGS_ASSERT_IS_UTF8_OVERLONG_GIVEN_START_BYTE_OK;
+ assert(len > 1 && UTF8_IS_START(*s));
+
+ /* Each platform has overlongs after the start bytes given above (expressed
+ * in I8 for EBCDIC). What constitutes an overlong varies by platform, but
+ * the logic is the same, except the E0 overlong has already been excluded
+ * on EBCDIC platforms. The values below were found by manually
+ * inspecting the UTF-8 patterns. See the tables in utf8.h and
+ * utfebcdic.h. */
+
+# ifdef EBCDIC
+# define F0_ABOVE_OVERLONG 0xB0
+# define F8_ABOVE_OVERLONG 0xA8
+# define FC_ABOVE_OVERLONG 0xA4
+# define FE_ABOVE_OVERLONG 0xA2
+# define FF_OVERLONG_PREFIX "\xfe\x41\x41\x41\x41\x41\x41\x41"
+ /* I8(0xfe) is FF */
+# else
+
+ if (s0 == 0xE0 && UNLIKELY(s1 < 0xA0)) {
+ return TRUE;
+ }
+
+# define F0_ABOVE_OVERLONG 0x90
+# define F8_ABOVE_OVERLONG 0x88
+# define FC_ABOVE_OVERLONG 0x84
+# define FE_ABOVE_OVERLONG 0x82
+# define FF_OVERLONG_PREFIX "\xff\x80\x80\x80\x80\x80\x80"
+# endif
+
+
+ if ( (s0 == 0xF0 && UNLIKELY(s1 < F0_ABOVE_OVERLONG))
+ || (s0 == 0xF8 && UNLIKELY(s1 < F8_ABOVE_OVERLONG))
+ || (s0 == 0xFC && UNLIKELY(s1 < FC_ABOVE_OVERLONG))
+ || (s0 == 0xFE && UNLIKELY(s1 < FE_ABOVE_OVERLONG)))
+ {
+ return TRUE;
+ }
+
+# if defined(UV_IS_QUAD) || defined(EBCDIC)
+
+ /* Check for the FF overlong. This happens only if all these bytes match;
+ * what comes after them doesn't matter. See tables in utf8.h,
+ * utfebcdic.h. (Can't happen on ASCII 32-bit platforms, as overflows
+ * instead.) */
+
+ if ( len >= sizeof(FF_OVERLONG_PREFIX) - 1
+ && UNLIKELY(memEQ(s, FF_OVERLONG_PREFIX,
+ sizeof(FF_OVERLONG_PREFIX) - 1)))
+ {
+ return TRUE;
+ }
+
+#endif
+
+ return FALSE;
+}
+
+#undef F0_ABOVE_OVERLONG
+#undef F8_ABOVE_OVERLONG
+#undef FC_ABOVE_OVERLONG
+#undef FE_ABOVE_OVERLONG
+#undef FF_OVERLONG_PREFIX
+
STRLEN
Perl__is_utf8_char_helper(const U8 * const s, const U8 * e, const U32 flags)
{
STRLEN len;
- const U8 *x, *y;
+ const U8 *x;
/* A helper function that should not be called directly.
*
#ifdef EBCDIC /* On EBCDIC, these are actually I8 bytes */
# define FIRST_START_BYTE_THAT_IS_DEFINITELY_SUPER 0xFA
-# define IS_SUPER_2_BYTE(s0, s1) ((s0) == 0xF9 && (s1) >= 0xA2)
+# define IS_UTF8_2_BYTE_SUPER(s0, s1) ((s0) == 0xF9 && (s1) >= 0xA2)
- /* B6 and B7 */
-# define IS_SURROGATE(s0, s1) ((s0) == 0xF1 && ((s1) & 0xFE ) == 0xB6)
+# define IS_UTF8_2_BYTE_SURROGATE(s0, s1) ((s0) == 0xF1 \
+ /* B6 and B7 */ \
+ && ((s1) & 0xFE ) == 0xB6)
#else
# define FIRST_START_BYTE_THAT_IS_DEFINITELY_SUPER 0xF5
-# define IS_SUPER_2_BYTE(s0, s1) ((s0) == 0xF4 && (s1) >= 0x90)
-# define IS_SURROGATE(s0, s1) ((s0) == 0xED && (s1) >= 0xA0)
+# define IS_UTF8_2_BYTE_SUPER(s0, s1) ((s0) == 0xF4 && (s1) >= 0x90)
+# define IS_UTF8_2_BYTE_SURROGATE(s0, s1) ((s0) == 0xED && (s1) >= 0xA0)
#endif
if ( (flags & UTF8_DISALLOW_SUPER)
const U8 s1 = NATIVE_UTF8_TO_I8(s[1]);
if ( (flags & UTF8_DISALLOW_SUPER)
- && UNLIKELY(IS_SUPER_2_BYTE(s0, s1)))
+ && UNLIKELY(IS_UTF8_2_BYTE_SUPER(s0, s1)))
{
return 0; /* Above Unicode */
}
if ( (flags & UTF8_DISALLOW_SURROGATE)
- && UNLIKELY(IS_SURROGATE(s0, s1)))
+ && UNLIKELY(IS_UTF8_2_BYTE_SURROGATE(s0, s1)))
{
return 0; /* Surrogate */
}
}
/* Here is syntactically valid. Next, make sure this isn't the start of an
- * overlong. Overlongs can occur whenever the number of continuation bytes
- * changes. That means whenever the number of leading 1 bits in a start
- * byte increases from the next lower start byte. That happens for start
- * bytes C0, E0, F0, F8, FC, FE, and FF. On modern perls, the following
- * illegal start bytes have already been excluded, so don't need to be
- * tested here;
- * ASCII platforms: C0, C1
- * EBCDIC platforms C0, C1, C2, C3, C4, E0
- *
- * At least a second byte is required to determine if other sequences will
- * be an overlong. */
-
- if (len > 1) {
- const U8 s0 = NATIVE_UTF8_TO_I8(s[0]);
- const U8 s1 = NATIVE_UTF8_TO_I8(s[1]);
+ * overlong. */
+ if (len > 1 && is_utf8_overlong_given_start_byte_ok(s, len)) {
+ return 0;
+ }
- /* Each platform has overlongs after the start bytes given above
- * (expressed in I8 for EBCDIC). What constitutes an overlong varies
- * by platform, but the logic is the same, except the E0 overlong has
- * already been excluded on EBCDIC platforms. The values below were
- * found by manually inspecting the UTF-8 patterns. See the tables in
- * utf8.h and utfebcdic.h */
+ /* And finally, that the code point represented fits in a word on this
+ * platform */
+ if (does_utf8_overflow(s, e)) {
+ return 0;
+ }
-# ifdef EBCDIC
-# define F0_ABOVE_OVERLONG 0xB0
-# define F8_ABOVE_OVERLONG 0xA8
-# define FC_ABOVE_OVERLONG 0xA4
-# define FE_ABOVE_OVERLONG 0xA2
-# define FF_OVERLONG_PREFIX "\xfe\x41\x41\x41\x41\x41\x41\x41"
- /* I8(0xfe) is FF */
-# else
+ return UTF8SKIP(s);
+}
- if (s0 == 0xE0 && UNLIKELY(s1 < 0xA0)) {
- return 0; /* Overlong */
- }
+STATIC char *
+S__byte_dump_string(pTHX_ const U8 * s, const STRLEN len)
+{
+ /* Returns a mortalized C string that is a displayable copy of the 'len'
+ * bytes starting at 's', each in a \xXY format. */
-# define F0_ABOVE_OVERLONG 0x90
-# define F8_ABOVE_OVERLONG 0x88
-# define FC_ABOVE_OVERLONG 0x84
-# define FE_ABOVE_OVERLONG 0x82
-# define FF_OVERLONG_PREFIX "\xff\x80\x80\x80\x80\x80\x80"
-# endif
+ const STRLEN output_len = 4 * len + 1; /* 4 bytes per each input, plus a
+ trailing NUL */
+ const U8 * const e = s + len;
+ char * output;
+ char * d;
+ PERL_ARGS_ASSERT__BYTE_DUMP_STRING;
- if ( (s0 == 0xF0 && UNLIKELY(s1 < F0_ABOVE_OVERLONG))
- || (s0 == 0xF8 && UNLIKELY(s1 < F8_ABOVE_OVERLONG))
- || (s0 == 0xFC && UNLIKELY(s1 < FC_ABOVE_OVERLONG))
- || (s0 == 0xFE && UNLIKELY(s1 < FE_ABOVE_OVERLONG)))
- {
- return 0; /* Overlong */
- }
+ Newx(output, output_len, char);
+ SAVEFREEPV(output);
-# if defined(UV_IS_QUAD) || defined(EBCDIC)
+ d = output;
+ for (; s < e; s++) {
+ const unsigned high_nibble = (*s & 0xF0) >> 4;
+ const unsigned low_nibble = (*s & 0x0F);
- /* Check for the FF overlong. This happens only if all these bytes
- * match; what comes after them doesn't matter. See tables in utf8.h,
- * utfebcdic.h. (Can't happen on ASCII 32-bit platforms, as overflows
- * instead.) */
+ *d++ = '\\';
+ *d++ = 'x';
- if ( len >= sizeof(FF_OVERLONG_PREFIX) - 1
- && UNLIKELY(memEQ(s, FF_OVERLONG_PREFIX,
- sizeof(FF_OVERLONG_PREFIX) - 1)))
- {
- return 0; /* Overlong */
+ if (high_nibble < 10) {
+ *d++ = high_nibble + '0';
+ }
+ else {
+ *d++ = high_nibble - 10 + 'a';
}
-#endif
-
+ if (low_nibble < 10) {
+ *d++ = low_nibble + '0';
+ }
+ else {
+ *d++ = low_nibble - 10 + 'a';
+ }
}
- /* Finally, see if this would overflow a UV on this platform. See if the
- * UTF8 for this code point is larger than that for the highest
- * representable code point. (For ASCII platforms, we could use memcmp()
- * because we don't have to convert each byte to I8, but it's very rare
- * input indeed that would approach overflow, so the loop below will likely
- * only get executed once */
- y = (const U8 *) HIGHEST_REPRESENTABLE_UTF8;
+ *d = '\0';
+ return output;
+}
- for (x = s; x < e; x++, y++) {
+PERL_STATIC_INLINE char *
+S_unexpected_non_continuation_text(pTHX_ const U8 * const s,
- /* If the same as this byte, go on to the next */
- if (UNLIKELY(NATIVE_UTF8_TO_I8(*x) == *y)) {
- continue;
- }
+ /* How many bytes to print */
+ STRLEN print_len,
- /* If this is larger, it overflows */
- if (UNLIKELY(NATIVE_UTF8_TO_I8(*x) > *y)) {
- return 0;
- }
+ /* Which one is the non-continuation */
+ const STRLEN non_cont_byte_pos,
- /* But if smaller, it won't */
- break;
+ /* How many bytes should there be? */
+ const STRLEN expect_len)
+{
+ /* Return the malformation warning text for an unexpected continuation
+ * byte. */
+
+ const char * const where = (non_cont_byte_pos == 1)
+ ? "immediately"
+ : Perl_form(aTHX_ "%d bytes",
+ (int) non_cont_byte_pos);
+ unsigned int i;
+
+ PERL_ARGS_ASSERT_UNEXPECTED_NON_CONTINUATION_TEXT;
+
+ /* We don't need to pass this parameter, but since it has already been
+ * calculated, it's likely faster to pass it; verify under DEBUGGING */
+ assert(expect_len == UTF8SKIP(s));
+
+ /* It is possible that utf8n_to_uvchr() was called incorrectly, with a
+ * length that is larger than is actually available in the buffer. If we
+ * print all the bytes based on that length, we will read past the buffer
+ * end. Often, the strings are NUL terminated, so to lower the chances of
+ * this happening, print the malformed bytes only up through any NUL. */
+ for (i = 1; i < print_len; i++) {
+ if (*(s + i) == '\0') {
+ print_len = i + 1; /* +1 gets the NUL printed */
+ break;
+ }
}
- return UTF8SKIP(s);
+ return Perl_form(aTHX_ "%s: %s (unexpected non-continuation byte 0x%02x,"
+ " %s after start byte 0x%02x; need %d bytes, got %d)",
+ malformed_text,
+ _byte_dump_string(s, print_len),
+ *(s + non_cont_byte_pos),
+ where,
+ *s,
+ (int) expect_len,
+ (int) non_cont_byte_pos);
}
-#undef FIRST_START_BYTE_THAT_IS_DEFINITELY_SUPER
-#undef IS_SUPER_2_BYTE
-#undef IS_SURROGATE
-#undef F0_ABOVE_OVERLONG
-#undef F8_ABOVE_OVERLONG
-#undef FC_ABOVE_OVERLONG
-#undef FE_ABOVE_OVERLONG
-#undef FF_OVERLONG_PREFIX
-
/*
=for apidoc utf8n_to_uvchr
the length, in bytes, of that character.
The value of C<flags> determines the behavior when C<s> does not point to a
-well-formed UTF-8 character. If C<flags> is 0, when a malformation is found,
-zero is returned and C<*retlen> is set so that (S<C<s> + C<*retlen>>) is the
-next possible position in C<s> that could begin a non-malformed character.
-Also, if UTF-8 warnings haven't been lexically disabled, a warning is raised.
+well-formed UTF-8 character. If C<flags> is 0, encountering a malformation
+causes zero to be returned and C<*retlen> is set so that (S<C<s> + C<*retlen>>)
+is the next possible position in C<s> that could begin a non-malformed
+character. Also, if UTF-8 warnings haven't been lexically disabled, a warning
+is raised. Some UTF-8 input sequences may contain multiple malformations.
+This function tries to find every possible one in each call, so multiple
+warnings can be raised for each sequence.
Various ALLOW flags can be set in C<flags> to allow (and not warn on)
individual types of malformations, such as the sequence being overlong (that
in both cases, 0 is returned, and, depending on the malformation, C<retlen> may
be set to 1. To disambiguate, upon a zero return, see if the first byte of
C<s> is 0 as well. If so, the input was a C<NUL>; if not, the input had an
-error.
+error. Or you can use C<L</utf8n_to_uvchr_error>>.
Certain code points are considered problematic. These are Unicode surrogates,
Unicode non-characters, and code points above the Unicode maximum of 0x10FFFF.
It is now deprecated to have very high code points (above C<IV_MAX> on the
platforms) and this function will raise a deprecation warning for these (unless
-such warnings are turned off). This value, is typically 0x7FFF_FFFF (2**31 -1)
+such warnings are turned off). This value is typically 0x7FFF_FFFF (2**31 -1)
in a 32-bit word.
Code points above 0x7FFF_FFFF (2**31 - 1) were never specified in any standard,
so using them is more problematic than other above-Unicode code points. Perl
invented an extension to UTF-8 to represent the ones above 2**36-1, so it is
likely that non-Perl languages will not be able to read files that contain
-these that written by the perl interpreter; nor would Perl understand files
+these; nor would Perl understand files
written by something that uses a different extension. For these reasons, there
is a separate set of flags that can warn and/or disallow these extremely high
code points, even if other above-Unicode ones are accepted. These are the
warn.
=cut
+
+Also implemented as a macro in utf8.h
+*/
+
+UV
+Perl_utf8n_to_uvchr(pTHX_ const U8 *s,
+ STRLEN curlen,
+ STRLEN *retlen,
+ const U32 flags)
+{
+ PERL_ARGS_ASSERT_UTF8N_TO_UVCHR;
+
+ return utf8n_to_uvchr_error(s, curlen, retlen, flags, NULL);
+}
+
+/*
+
+=for apidoc utf8n_to_uvchr_error
+
+THIS FUNCTION SHOULD BE USED IN ONLY VERY SPECIALIZED CIRCUMSTANCES.
+Most code should use L</utf8_to_uvchr_buf>() rather than call this directly.
+
+This function is for code that needs to know what the precise malformation(s)
+are when an error is found.
+
+It is like C<L</utf8n_to_uvchr>> but it takes an extra parameter placed after
+all the others, C<errors>. If this parameter is 0, this function behaves
+identically to C<L</utf8n_to_uvchr>>. Otherwise, C<errors> should be a pointer
+to a C<U32> variable, which this function sets to indicate any errors found.
+Upon return, if C<*errors> is 0, there were no errors found. Otherwise,
+C<*errors> is the bit-wise C<OR> of the bits described in the list below. Some
+of these bits will be set if a malformation is found, even if the input
+C<flags> parameter indicates that the given malformation is allowed; the
+exceptions are noted:
+
+=over 4
+
+=item C<UTF8_GOT_ABOVE_31_BIT>
+
+The code point represented by the input UTF-8 sequence occupies more than 31
+bits.
+This bit is set only if the input C<flags> parameter contains either the
+C<UTF8_DISALLOW_ABOVE_31_BIT> or the C<UTF8_WARN_ABOVE_31_BIT> flags.
+
+=item C<UTF8_GOT_CONTINUATION>
+
+The input sequence was malformed in that the first byte was a a UTF-8
+continuation byte.
+
+=item C<UTF8_GOT_EMPTY>
+
+The input C<curlen> parameter was 0.
+
+=item C<UTF8_GOT_LONG>
+
+The input sequence was malformed in that there is some other sequence that
+evaluates to the same code point, but that sequence is shorter than this one.
+
+=item C<UTF8_GOT_NONCHAR>
+
+The code point represented by the input UTF-8 sequence is for a Unicode
+non-character code point.
+This bit is set only if the input C<flags> parameter contains either the
+C<UTF8_DISALLOW_NONCHAR> or the C<UTF8_WARN_NONCHAR> flags.
+
+=item C<UTF8_GOT_NON_CONTINUATION>
+
+The input sequence was malformed in that a non-continuation type byte was found
+in a position where only a continuation type one should be.
+
+=item C<UTF8_GOT_OVERFLOW>
+
+The input sequence was malformed in that it is for a code point that is not
+representable in the number of bits available in a UV on the current platform.
+
+=item C<UTF8_GOT_SHORT>
+
+The input sequence was malformed in that C<curlen> is smaller than required for
+a complete sequence. In other words, the input is for a partial character
+sequence.
+
+=item C<UTF8_GOT_SUPER>
+
+The input sequence was malformed in that it is for a non-Unicode code point;
+that is, one above the legal Unicode maximum.
+This bit is set only if the input C<flags> parameter contains either the
+C<UTF8_DISALLOW_SUPER> or the C<UTF8_WARN_SUPER> flags.
+
+=item C<UTF8_GOT_SURROGATE>
+
+The input sequence was malformed in that it is for a -Unicode UTF-16 surrogate
+code point.
+This bit is set only if the input C<flags> parameter contains either the
+C<UTF8_DISALLOW_SURROGATE> or the C<UTF8_WARN_SURROGATE> flags.
+
+=back
+
+=cut
*/
UV
-Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
+Perl_utf8n_to_uvchr_error(pTHX_ const U8 *s,
+ STRLEN curlen,
+ STRLEN *retlen,
+ const U32 flags,
+ U32 * errors)
{
const U8 * const s0 = s;
- U8 overflow_byte = '\0'; /* Save byte in case of overflow */
- U8 * send;
+ U8 * send = NULL; /* (initialized to silence compilers' wrong
+ warning) */
+ U32 possible_problems = 0; /* A bit is set here for each potential problem
+ found as we go along */
UV uv = *s;
- STRLEN expectlen;
- SV* sv = NULL;
- UV outlier_ret = 0; /* return value when input is in error or problematic
- */
- UV pack_warn = 0; /* Save result of packWARN() for later */
- bool unexpected_non_continuation = FALSE;
- bool overflowed = FALSE;
- bool do_overlong_test = TRUE; /* May have to skip this test */
+ STRLEN expectlen = 0; /* How long should this sequence be?
+ (initialized to silence compilers' wrong
+ warning) */
+ U32 discard_errors = 0; /* Used to save branches when 'errors' is NULL;
+ this gets set and discarded */
- const char* const malformed_text = "Malformed UTF-8 character";
+ /* The below are used only if there is both an overlong malformation and a
+ * too short one. Otherwise the first two are set to 's0' and 'send', and
+ * the third not used at all */
+ U8 * adjusted_s0 = (U8 *) s0;
+ U8 * adjusted_send = NULL; /* (Initialized to silence compilers' wrong
+ warning) */
+ UV uv_so_far = 0; /* (Initialized to silence compilers' wrong warning) */
- PERL_ARGS_ASSERT_UTF8N_TO_UVCHR;
+ PERL_ARGS_ASSERT_UTF8N_TO_UVCHR_ERROR;
+
+ if (errors) {
+ *errors = 0;
+ }
+ else {
+ errors = &discard_errors;
+ }
/* The order of malformation tests here is important. We should consume as
* few bytes as possible in order to not skip any valid character. This is
* returning to the caller C<*retlen> pointing to the very next byte (one
* which is actually part of of the overflowing sequence), that could look
* legitimate to the caller, which could discard the initial partial
- * sequence and process the rest, inappropriately */
+ * sequence and process the rest, inappropriately.
+ *
+ * Some possible input sequences are malformed in more than one way. This
+ * function goes to lengths to try to find all of them. This is necessary
+ * for correctness, as the inputs may allow one malformation but not
+ * another, and if we abandon searching for others after finding the
+ * allowed one, we could allow in something that shouldn't have been.
+ */
- /* Zero length strings, if allowed, of necessity are zero */
if (UNLIKELY(curlen == 0)) {
- if (retlen) {
- *retlen = 0;
- }
-
- if (flags & UTF8_ALLOW_EMPTY) {
- return 0;
- }
- if (! (flags & UTF8_CHECK_ONLY)) {
- sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (empty string)", malformed_text));
- }
- goto malformed;
+ possible_problems |= UTF8_GOT_EMPTY;
+ curlen = 0;
+ uv = 0; /* XXX It could be argued that this should be
+ UNICODE_REPLACEMENT? */
+ goto ready_to_handle_errors;
}
expectlen = UTF8SKIP(s);
/* A continuation character can't start a valid sequence */
if (UNLIKELY(UTF8_IS_CONTINUATION(uv))) {
- if (flags & UTF8_ALLOW_CONTINUATION) {
- if (retlen) {
- *retlen = 1;
- }
- return UNICODE_REPLACEMENT;
- }
-
- if (! (flags & UTF8_CHECK_ONLY)) {
- sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (unexpected continuation byte 0x%02x, with no preceding start byte)", malformed_text, *s0));
- }
- curlen = 1;
- goto malformed;
+ possible_problems |= UTF8_GOT_CONTINUATION;
+ curlen = 1;
+ uv = UNICODE_REPLACEMENT;
+ goto ready_to_handle_errors;
}
/* Here is not a continuation byte, nor an invariant. The only thing left
/* Now, loop through the remaining bytes in the character's sequence,
* accumulating each into the working value as we go. Be sure to not look
* past the end of the input string */
- send = (U8*) s0 + ((expectlen <= curlen) ? expectlen : curlen);
-
+ send = adjusted_send = (U8*) s0 + ((expectlen <= curlen)
+ ? expectlen
+ : curlen);
for (s = s0 + 1; s < send; s++) {
if (LIKELY(UTF8_IS_CONTINUATION(*s))) {
- if (uv & UTF_ACCUMULATION_OVERFLOW_MASK) {
-
- /* The original implementors viewed this malformation as more
- * serious than the others (though I, khw, don't understand
- * why, since other malformations also give very very wrong
- * results), so there is no way to turn off checking for it.
- * Set a flag, but keep going in the loop, so that we absorb
- * the rest of the bytes that comprise the character. */
- overflowed = TRUE;
- overflow_byte = *s; /* Save for warning message's use */
- }
uv = UTF8_ACCUMULATE(uv, *s);
- }
- else {
- /* Here, found a non-continuation before processing all expected
- * bytes. This byte begins a new character, so quit, even if
- * allowing this malformation. */
- unexpected_non_continuation = TRUE;
- break;
- }
+ continue;
+ }
+
+ /* Here, found a non-continuation before processing all expected bytes.
+ * This byte indicates the beginning of a new character, so quit, even
+ * if allowing this malformation. */
+ curlen = s - s0; /* Save how many bytes we actually got */
+ possible_problems |= UTF8_GOT_NON_CONTINUATION;
+ goto finish_short;
} /* End of loop through the character's bytes */
/* Save how many bytes were actually in the character */
curlen = s - s0;
- /* The loop above finds two types of malformations: non-continuation and/or
- * overflow. The non-continuation malformation is really a too-short
- * malformation, as it means that the current character ended before it was
- * expected to (being terminated prematurely by the beginning of the next
- * character, whereas in the too-short malformation there just are too few
- * bytes available to hold the character. In both cases, the check below
- * that we have found the expected number of bytes would fail if executed.)
- * Thus the non-continuation malformation is really unnecessary, being a
- * subset of the too-short malformation. But there may be existing
- * applications that are expecting the non-continuation type, so we retain
- * it, and return it in preference to the too-short malformation. (If this
- * code were being written from scratch, the two types might be collapsed
- * into one.) I, khw, am also giving priority to returning the
- * non-continuation and too-short malformations over overflow when multiple
- * ones are present. I don't know of any real reason to prefer one over
- * the other, except that it seems to me that multiple-byte errors trumps
- * errors from a single byte */
- if (UNLIKELY(unexpected_non_continuation)) {
- if (!(flags & UTF8_ALLOW_NON_CONTINUATION)) {
- if (! (flags & UTF8_CHECK_ONLY)) {
- if (curlen == 1) {
- sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (unexpected non-continuation byte 0x%02x, immediately after start byte 0x%02x)", malformed_text, *s, *s0));
- }
- else {
- sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (unexpected non-continuation byte 0x%02x, %d bytes after start byte 0x%02x, expected %d bytes)", malformed_text, *s, (int) curlen, *s0, (int)expectlen));
- }
- }
- goto malformed;
- }
- uv = UNICODE_REPLACEMENT;
-
- /* Skip testing for overlongs, as the REPLACEMENT may not be the same
- * as what the original expectations were. */
- do_overlong_test = FALSE;
- if (retlen) {
- *retlen = curlen;
- }
- }
- else if (UNLIKELY(curlen < expectlen)) {
- if (! (flags & UTF8_ALLOW_SHORT)) {
- if (! (flags & UTF8_CHECK_ONLY)) {
- sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (%d byte%s, need %d, after start byte 0x%02x)", malformed_text, (int)curlen, curlen == 1 ? "" : "s", (int)expectlen, *s0));
- }
- goto malformed;
- }
- uv = UNICODE_REPLACEMENT;
- do_overlong_test = FALSE;
- if (retlen) {
- *retlen = curlen;
- }
- }
-
- if (UNLIKELY(overflowed)) {
- sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (overflow at byte 0x%02x, after start byte 0x%02x)", malformed_text, overflow_byte, *s0));
- goto malformed;
- }
-
- if (do_overlong_test
- && expectlen > (STRLEN) OFFUNISKIP(uv)
- && ! (flags & UTF8_ALLOW_LONG))
+ /* Did we get all the continuation bytes that were expected? Note that we
+ * know this result even without executing the loop above. But we had to
+ * do the loop to see if there are unexpected non-continuations. */
+ if (UNLIKELY(curlen < expectlen)) {
+ possible_problems |= UTF8_GOT_SHORT;
+
+ finish_short:
+ uv_so_far = uv;
+ uv = UNICODE_REPLACEMENT;
+ }
+
+ /* Note that there are two types of too-short malformation. One is when
+ * there is actual wrong data before the normal termination of the
+ * sequence. The other is that the sequence wasn't complete before the end
+ * of the data we are allowed to look at, based on the input 'curlen'.
+ * This means that we were passed data for a partial character, but it is
+ * valid as far as we saw. The other is definitely invalid. This
+ * distinction could be important to a caller, so the two types are kept
+ * separate. */
+
+ /* Check for overflow */
+ if (UNLIKELY(does_utf8_overflow(s0, send))) {
+ possible_problems |= UTF8_GOT_OVERFLOW;
+ uv = UNICODE_REPLACEMENT;
+ }
+
+ /* Check for overlong. If no problems so far, 'uv' is the correct code
+ * point value. Simply see if it is expressible in fewer bytes. Otherwise
+ * we must look at the UTF-8 byte sequence itself to see if it is for an
+ * overlong */
+ if ( ( LIKELY(! possible_problems)
+ && UNLIKELY(expectlen > (STRLEN) OFFUNISKIP(uv)))
+ || ( UNLIKELY( possible_problems)
+ && ( UNLIKELY(! UTF8_IS_START(*s0))
+ || ( curlen > 1
+ && UNLIKELY(is_utf8_overlong_given_start_byte_ok(s0,
+ send - s0))))))
{
- /* The overlong malformation has lower precedence than the others.
- * Note that if this malformation is allowed, we return the actual
- * value, instead of the replacement character. This is because this
- * value is actually well-defined. */
- if (! (flags & UTF8_CHECK_ONLY)) {
- sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (%d byte%s, need %d, after start byte 0x%02x)", malformed_text, (int)expectlen, expectlen == 1 ? "": "s", OFFUNISKIP(uv), *s0));
- }
- goto malformed;
+ possible_problems |= UTF8_GOT_LONG;
+
+ /* A convenience macro that matches either of the too-short conditions.
+ * */
+# define UTF8_GOT_TOO_SHORT (UTF8_GOT_SHORT|UTF8_GOT_NON_CONTINUATION)
+
+ if (UNLIKELY(possible_problems & UTF8_GOT_TOO_SHORT)) {
+ UV min_uv = uv_so_far;
+ STRLEN i;
+
+ /* Here, the input is both overlong and is missing some trailing
+ * bytes. There is no single code point it could be for, but there
+ * may be enough information present to determine if what we have
+ * so far is for an unallowed code point, such as for a surrogate.
+ * The code below has the intelligence to determine this, but just
+ * for non-overlong UTF-8 sequences. What we do here is calculate
+ * the smallest code point the input could represent if there were
+ * no too short malformation. Then we compute and save the UTF-8
+ * for that, which is what the code below looks at instead of the
+ * raw input. It turns out that the smallest such code point is
+ * all we need. */
+ for (i = curlen; i < expectlen; i++) {
+ min_uv = UTF8_ACCUMULATE(min_uv,
+ I8_TO_NATIVE_UTF8(UTF_CONTINUATION_MARK));
+ }
+
+ Newx(adjusted_s0, OFFUNISKIP(min_uv) + 1, U8);
+ SAVEFREEPV((U8 *) adjusted_s0); /* Needed because we may not get
+ to free it ourselves if
+ warnings are made fatal */
+ adjusted_send = uvoffuni_to_utf8_flags(adjusted_s0, min_uv, 0);
+ }
}
- /* Here, the input is considered to be well-formed, but it still could be a
- * problematic code point that is not allowed by the input parameters. */
- if (uv >= UNICODE_SURROGATE_FIRST /* isn't problematic if < this */
+ /* Now check that the input isn't for a problematic code point not allowed
+ * by the input parameters. */
+ /* isn't problematic if < this */
+ if ( ( ( LIKELY(! possible_problems) && uv >= UNICODE_SURROGATE_FIRST)
+ || ( UNLIKELY(possible_problems)
+ && isUTF8_POSSIBLY_PROBLEMATIC(*adjusted_s0)))
&& ((flags & ( UTF8_DISALLOW_NONCHAR
|UTF8_DISALLOW_SURROGATE
|UTF8_DISALLOW_SUPER
|UTF8_WARN_SURROGATE
|UTF8_WARN_SUPER
|UTF8_WARN_ABOVE_31_BIT))
+ /* In case of a malformation, 'uv' is not valid, and has
+ * been changed to something in the Unicode range.
+ * Currently we don't output a deprecation message if there
+ * is already a malformation, so we don't have to special
+ * case the test immediately below */
|| ( UNLIKELY(uv > MAX_NON_DEPRECATED_CP)
&& ckWARN_d(WARN_DEPRECATED))))
{
- if (UNICODE_IS_SURROGATE(uv)) {
-
- /* By adding UTF8_CHECK_ONLY to the test, we avoid unnecessary
- * generation of the sv, since no warnings are raised under CHECK */
- if ((flags & (UTF8_WARN_SURROGATE|UTF8_CHECK_ONLY)) == UTF8_WARN_SURROGATE
- && ckWARN_d(WARN_SURROGATE))
- {
- sv = sv_2mortal(Perl_newSVpvf(aTHX_ "UTF-16 surrogate U+%04"UVXf"", uv));
- pack_warn = packWARN(WARN_SURROGATE);
- }
- if (flags & UTF8_DISALLOW_SURROGATE) {
- goto disallowed;
- }
- }
- else if ((uv > PERL_UNICODE_MAX)) {
- if ((flags & (UTF8_WARN_SUPER|UTF8_CHECK_ONLY)) == UTF8_WARN_SUPER
- && ckWARN_d(WARN_NON_UNICODE))
- {
- sv = sv_2mortal(Perl_newSVpvf(aTHX_
- "Code point 0x%04"UVXf" is not Unicode, may not be portable",
- uv));
- pack_warn = packWARN(WARN_NON_UNICODE);
- }
+ /* If there were no malformations, or the only malformation is an
+ * overlong, 'uv' is valid */
+ if (LIKELY(! (possible_problems & ~UTF8_GOT_LONG))) {
+ if (UNLIKELY(UNICODE_IS_SURROGATE(uv))) {
+ possible_problems |= UTF8_GOT_SURROGATE;
+ }
+ else if (UNLIKELY(uv > PERL_UNICODE_MAX)) {
+ possible_problems |= UTF8_GOT_SUPER;
+ }
+ else if (UNLIKELY(UNICODE_IS_NONCHAR(uv))) {
+ possible_problems |= UTF8_GOT_NONCHAR;
+ }
+ }
+ else { /* Otherwise, need to look at the source UTF-8, possibly
+ adjusted to be non-overlong */
- /* The maximum code point ever specified by a standard was
- * 2**31 - 1. Anything larger than that is a Perl extension that
- * very well may not be understood by other applications (including
- * earlier perl versions on EBCDIC platforms). We test for these
- * after the regular SUPER ones, and before possibly bailing out,
- * so that the slightly more dire warning will override the regular
- * one. */
- if ( (flags & (UTF8_WARN_ABOVE_31_BIT
- |UTF8_WARN_SUPER
- |UTF8_DISALLOW_ABOVE_31_BIT))
- && UNLIKELY(is_utf8_cp_above_31_bits(s0, send)))
+ if (UNLIKELY(NATIVE_UTF8_TO_I8(*adjusted_s0)
+ >= FIRST_START_BYTE_THAT_IS_DEFINITELY_SUPER))
{
- if ( ! (flags & UTF8_CHECK_ONLY)
- && (flags & (UTF8_WARN_ABOVE_31_BIT|UTF8_WARN_SUPER))
- && ckWARN_d(WARN_UTF8))
+ possible_problems |= UTF8_GOT_SUPER;
+ }
+ else if (curlen > 1) {
+ if (UNLIKELY(IS_UTF8_2_BYTE_SUPER(
+ NATIVE_UTF8_TO_I8(*adjusted_s0),
+ NATIVE_UTF8_TO_I8(*(adjusted_s0 + 1)))))
{
- sv = sv_2mortal(Perl_newSVpvf(aTHX_
- "Code point 0x%"UVXf" is not Unicode, and not portable",
- uv));
- pack_warn = packWARN(WARN_UTF8);
+ possible_problems |= UTF8_GOT_SUPER;
}
- if (flags & UTF8_DISALLOW_ABOVE_31_BIT) {
- goto disallowed;
+ else if (UNLIKELY(IS_UTF8_2_BYTE_SURROGATE(
+ NATIVE_UTF8_TO_I8(*adjusted_s0),
+ NATIVE_UTF8_TO_I8(*(adjusted_s0 + 1)))))
+ {
+ possible_problems |= UTF8_GOT_SURROGATE;
}
}
- if (flags & UTF8_DISALLOW_SUPER) {
- goto disallowed;
- }
+ /* We need a complete well-formed UTF-8 character to discern
+ * non-characters, so can't look for them here */
+ }
+ }
- /* The deprecated warning overrides any non-deprecated one */
- if (UNLIKELY(uv > MAX_NON_DEPRECATED_CP) && ckWARN_d(WARN_DEPRECATED))
- {
- sv = sv_2mortal(Perl_newSVpvf(aTHX_ cp_above_legal_max,
- uv, MAX_NON_DEPRECATED_CP));
- pack_warn = packWARN(WARN_DEPRECATED);
+ ready_to_handle_errors:
+
+ /* At this point:
+ * curlen contains the number of bytes in the sequence that
+ * this call should advance the input by.
+ * possible_problems' is 0 if there weren't any problems; otherwise a bit
+ * is set in it for each potential problem found.
+ * uv contains the code point the input sequence
+ * represents; or if there is a problem that prevents
+ * a well-defined value from being computed, it is
+ * some subsitute value, typically the REPLACEMENT
+ * CHARACTER.
+ * s0 points to the first byte of the character
+ * send points to just after where that (potentially
+ * partial) character ends
+ * adjusted_s0 normally is the same as s0, but in case of an
+ * overlong for which the UTF-8 matters below, it is
+ * the first byte of the shortest form representation
+ * of the input.
+ * adjusted_send normally is the same as 'send', but if adjusted_s0
+ * is set to something other than s0, this points one
+ * beyond its end
+ */
+
+ if (UNLIKELY(possible_problems)) {
+ bool disallowed = FALSE;
+ const U32 orig_problems = possible_problems;
+
+ while (possible_problems) { /* Handle each possible problem */
+ UV pack_warn = 0;
+ char * message = NULL;
+
+ /* Each 'if' clause handles one problem. They are ordered so that
+ * the first ones' messages will be displayed before the later
+ * ones; this is kinda in decreasing severity order */
+ if (possible_problems & UTF8_GOT_OVERFLOW) {
+
+ /* Overflow means also got a super and above 31 bits, but we
+ * handle all three cases here */
+ possible_problems
+ &= ~(UTF8_GOT_OVERFLOW|UTF8_GOT_SUPER|UTF8_GOT_ABOVE_31_BIT);
+ *errors |= UTF8_GOT_OVERFLOW;
+
+ /* But the API says we flag all errors found */
+ if (flags & (UTF8_WARN_SUPER|UTF8_DISALLOW_SUPER)) {
+ *errors |= UTF8_GOT_SUPER;
+ }
+ if (flags & (UTF8_WARN_ABOVE_31_BIT|UTF8_DISALLOW_ABOVE_31_BIT)) {
+ *errors |= UTF8_GOT_ABOVE_31_BIT;
+ }
+
+ disallowed = TRUE;
+
+ /* The warnings code explicitly says it doesn't handle the case
+ * of packWARN2 and two categories which have parent-child
+ * relationship. Even if it works now to raise the warning if
+ * either is enabled, it wouldn't necessarily do so in the
+ * future. We output (only) the most dire warning*/
+ if (! (flags & UTF8_CHECK_ONLY)) {
+ if (ckWARN_d(WARN_UTF8)) {
+ pack_warn = packWARN(WARN_UTF8);
+ }
+ else if (ckWARN_d(WARN_NON_UNICODE)) {
+ pack_warn = packWARN(WARN_NON_UNICODE);
+ }
+ if (pack_warn) {
+ message = Perl_form(aTHX_ "%s: %s (overflows)",
+ malformed_text,
+ _byte_dump_string(s0, send - s0));
+ }
+ }
}
- }
- else if (UNICODE_IS_NONCHAR(uv)) {
- if ((flags & (UTF8_WARN_NONCHAR|UTF8_CHECK_ONLY)) == UTF8_WARN_NONCHAR
- && ckWARN_d(WARN_NONCHAR))
- {
- sv = sv_2mortal(Perl_newSVpvf(aTHX_ "Unicode non-character U+%04"UVXf" is not recommended for open interchange", uv));
- pack_warn = packWARN(WARN_NONCHAR);
- }
- if (flags & UTF8_DISALLOW_NONCHAR) {
- goto disallowed;
- }
- }
+ else if (possible_problems & UTF8_GOT_EMPTY) {
+ possible_problems &= ~UTF8_GOT_EMPTY;
+ *errors |= UTF8_GOT_EMPTY;
+
+ if (! (flags & UTF8_ALLOW_EMPTY)) {
+ disallowed = TRUE;
+ if (ckWARN_d(WARN_UTF8) && ! (flags & UTF8_CHECK_ONLY)) {
+ pack_warn = packWARN(WARN_UTF8);
+ message = Perl_form(aTHX_ "%s (empty string)",
+ malformed_text);
+ }
+ }
+ }
+ else if (possible_problems & UTF8_GOT_CONTINUATION) {
+ possible_problems &= ~UTF8_GOT_CONTINUATION;
+ *errors |= UTF8_GOT_CONTINUATION;
+
+ if (! (flags & UTF8_ALLOW_CONTINUATION)) {
+ disallowed = TRUE;
+ if (ckWARN_d(WARN_UTF8) && ! (flags & UTF8_CHECK_ONLY)) {
+ pack_warn = packWARN(WARN_UTF8);
+ message = Perl_form(aTHX_
+ "%s: %s (unexpected continuation byte 0x%02x,"
+ " with no preceding start byte)",
+ malformed_text,
+ _byte_dump_string(s0, 1), *s0);
+ }
+ }
+ }
+ else if (possible_problems & UTF8_GOT_NON_CONTINUATION) {
+ possible_problems &= ~UTF8_GOT_NON_CONTINUATION;
+ *errors |= UTF8_GOT_NON_CONTINUATION;
+
+ if (! (flags & UTF8_ALLOW_NON_CONTINUATION)) {
+ disallowed = TRUE;
+ if (ckWARN_d(WARN_UTF8) && ! (flags & UTF8_CHECK_ONLY)) {
+ pack_warn = packWARN(WARN_UTF8);
+ message = Perl_form(aTHX_ "%s",
+ unexpected_non_continuation_text(s0,
+ send - s0,
+ s - s0,
+ (int) expectlen));
+ }
+ }
+ }
+ else if (possible_problems & UTF8_GOT_SHORT) {
+ possible_problems &= ~UTF8_GOT_SHORT;
+ *errors |= UTF8_GOT_SHORT;
+
+ if (! (flags & UTF8_ALLOW_SHORT)) {
+ disallowed = TRUE;
+ if (ckWARN_d(WARN_UTF8) && ! (flags & UTF8_CHECK_ONLY)) {
+ pack_warn = packWARN(WARN_UTF8);
+ message = Perl_form(aTHX_
+ "%s: %s (too short; got %d byte%s, need %d)",
+ malformed_text,
+ _byte_dump_string(s0, send - s0),
+ (int)curlen,
+ curlen == 1 ? "" : "s",
+ (int)expectlen);
+ }
+ }
- if (sv) {
- outlier_ret = uv; /* Note we don't bother to convert to native,
- as all the outlier code points are the same
- in both ASCII and EBCDIC */
- goto do_warn;
- }
+ }
+ else if (possible_problems & UTF8_GOT_LONG) {
+ possible_problems &= ~UTF8_GOT_LONG;
+ *errors |= UTF8_GOT_LONG;
+
+ if (! (flags & UTF8_ALLOW_LONG)) {
+ disallowed = TRUE;
+
+ if (ckWARN_d(WARN_UTF8) && ! (flags & UTF8_CHECK_ONLY)) {
+ pack_warn = packWARN(WARN_UTF8);
+
+ /* These error types cause 'uv' to be something that
+ * isn't what was intended, so can't use it in the
+ * message. The other error types either can't
+ * generate an overlong, or else the 'uv' is valid */
+ if (orig_problems &
+ (UTF8_GOT_TOO_SHORT|UTF8_GOT_OVERFLOW))
+ {
+ message = Perl_form(aTHX_
+ "%s: %s (any UTF-8 sequence that starts"
+ " with \"%s\" is overlong which can and"
+ " should be represented with a"
+ " different, shorter sequence)",
+ malformed_text,
+ _byte_dump_string(s0, send - s0),
+ _byte_dump_string(s0, curlen));
+ }
+ else {
+ U8 tmpbuf[UTF8_MAXBYTES+1];
+ const U8 * const e = uvoffuni_to_utf8_flags(tmpbuf,
+ uv, 0);
+ message = Perl_form(aTHX_
+ "%s: %s (overlong; instead use %s to represent"
+ " U+%0*"UVXf")",
+ malformed_text,
+ _byte_dump_string(s0, send - s0),
+ _byte_dump_string(tmpbuf, e - tmpbuf),
+ ((uv < 256) ? 2 : 4), /* Field width of 2 for
+ small code points */
+ uv);
+ }
+ }
+ }
+ }
+ else if (possible_problems & UTF8_GOT_SURROGATE) {
+ possible_problems &= ~UTF8_GOT_SURROGATE;
- /* Here, this is not considered a malformed character, so drop through
- * to return it */
- }
+ if (flags & UTF8_WARN_SURROGATE) {
+ *errors |= UTF8_GOT_SURROGATE;
- return UNI_TO_NATIVE(uv);
+ if ( ! (flags & UTF8_CHECK_ONLY)
+ && ckWARN_d(WARN_SURROGATE))
+ {
+ pack_warn = packWARN(WARN_SURROGATE);
+
+ /* These are the only errors that can occur with a
+ * surrogate when the 'uv' isn't valid */
+ if (orig_problems & UTF8_GOT_TOO_SHORT) {
+ message = Perl_form(aTHX_
+ "UTF-16 surrogate (any UTF-8 sequence that"
+ " starts with \"%s\" is for a surrogate)",
+ _byte_dump_string(s0, curlen));
+ }
+ else {
+ message = Perl_form(aTHX_
+ "UTF-16 surrogate U+%04"UVXf"", uv);
+ }
+ }
+ }
- /* There are three cases which get to beyond this point. In all 3 cases:
- * <sv> if not null points to a string to print as a warning.
- * <curlen> is what <*retlen> should be set to if UTF8_CHECK_ONLY isn't
- * set.
- * <outlier_ret> is what return value to use if UTF8_CHECK_ONLY isn't set.
- * This is done by initializing it to 0, and changing it only
- * for case 1).
- * The 3 cases are:
- * 1) The input is valid but problematic, and to be warned about. The
- * return value is the resultant code point; <*retlen> is set to
- * <curlen>, the number of bytes that comprise the code point.
- * <pack_warn> contains the result of packWARN() for the warning
- * types. The entry point for this case is the label <do_warn>;
- * 2) The input is a valid code point but disallowed by the parameters to
- * this function. The return value is 0. If UTF8_CHECK_ONLY is set,
- * <*relen> is -1; otherwise it is <curlen>, the number of bytes that
- * comprise the code point. <pack_warn> contains the result of
- * packWARN() for the warning types. The entry point for this case is
- * the label <disallowed>.
- * 3) The input is malformed. The return value is 0. If UTF8_CHECK_ONLY
- * is set, <*relen> is -1; otherwise it is <curlen>, the number of
- * bytes that comprise the malformation. All such malformations are
- * assumed to be warning type <utf8>. The entry point for this case
- * is the label <malformed>.
- */
+ if (flags & UTF8_DISALLOW_SURROGATE) {
+ disallowed = TRUE;
+ *errors |= UTF8_GOT_SURROGATE;
+ }
+ }
+ else if (possible_problems & UTF8_GOT_SUPER) {
+ possible_problems &= ~UTF8_GOT_SUPER;
- malformed:
+ if (flags & UTF8_WARN_SUPER) {
+ *errors |= UTF8_GOT_SUPER;
- if (sv && ckWARN_d(WARN_UTF8)) {
- pack_warn = packWARN(WARN_UTF8);
- }
+ if ( ! (flags & UTF8_CHECK_ONLY)
+ && ckWARN_d(WARN_NON_UNICODE))
+ {
+ pack_warn = packWARN(WARN_NON_UNICODE);
+
+ if (orig_problems & UTF8_GOT_TOO_SHORT) {
+ message = Perl_form(aTHX_
+ "Any UTF-8 sequence that starts with"
+ " \"%s\" is for a non-Unicode code point,"
+ " may not be portable",
+ _byte_dump_string(s0, curlen));
+ }
+ else {
+ message = Perl_form(aTHX_
+ "Code point 0x%04"UVXf" is not"
+ " Unicode, may not be portable",
+ uv);
+ }
+ }
+ }
- disallowed:
+ /* The maximum code point ever specified by a standard was
+ * 2**31 - 1. Anything larger than that is a Perl extension
+ * that very well may not be understood by other applications
+ * (including earlier perl versions on EBCDIC platforms). We
+ * test for these after the regular SUPER ones, and before
+ * possibly bailing out, so that the slightly more dire warning
+ * will override the regular one. */
+ if ( (flags & (UTF8_WARN_ABOVE_31_BIT
+ |UTF8_WARN_SUPER
+ |UTF8_DISALLOW_ABOVE_31_BIT))
+ && ( ( UNLIKELY(orig_problems & UTF8_GOT_TOO_SHORT)
+ && UNLIKELY(is_utf8_cp_above_31_bits(
+ adjusted_s0,
+ adjusted_send)))
+ || ( LIKELY(! (orig_problems & UTF8_GOT_TOO_SHORT))
+ && UNLIKELY(UNICODE_IS_ABOVE_31_BIT(uv)))))
+ {
+ if ( ! (flags & UTF8_CHECK_ONLY)
+ && (flags & (UTF8_WARN_ABOVE_31_BIT|UTF8_WARN_SUPER))
+ && ckWARN_d(WARN_UTF8))
+ {
+ pack_warn = packWARN(WARN_UTF8);
+
+ if (orig_problems & UTF8_GOT_TOO_SHORT) {
+ message = Perl_form(aTHX_
+ "Any UTF-8 sequence that starts with"
+ " \"%s\" is for a non-Unicode code"
+ " point, and is not portable",
+ _byte_dump_string(s0, curlen));
+ }
+ else {
+ message = Perl_form(aTHX_
+ "Code point 0x%"UVXf" is not Unicode,"
+ " and not portable",
+ uv);
+ }
+ }
- if (flags & UTF8_CHECK_ONLY) {
- if (retlen)
- *retlen = ((STRLEN) -1);
- return 0;
- }
+ if (flags & (UTF8_WARN_ABOVE_31_BIT|UTF8_DISALLOW_ABOVE_31_BIT)) {
+ *errors |= UTF8_GOT_ABOVE_31_BIT;
- do_warn:
+ if (flags & UTF8_DISALLOW_ABOVE_31_BIT) {
+ disallowed = TRUE;
+ }
+ }
+ }
- if (pack_warn) { /* <pack_warn> was initialized to 0, and changed only
- if warnings are to be raised. */
- const char * const string = SvPVX_const(sv);
+ if (flags & UTF8_DISALLOW_SUPER) {
+ *errors |= UTF8_GOT_SUPER;
+ disallowed = TRUE;
+ }
- if (PL_op)
- Perl_warner(aTHX_ pack_warn, "%s in %s", string, OP_DESC(PL_op));
- else
- Perl_warner(aTHX_ pack_warn, "%s", string);
- }
+ /* The deprecated warning overrides any non-deprecated one. If
+ * there are other problems, a deprecation message is not
+ * really helpful, so don't bother to raise it in that case.
+ * This also keeps the code from having to handle the case
+ * where 'uv' is not valid. */
+ if ( ! (orig_problems
+ & (UTF8_GOT_TOO_SHORT|UTF8_GOT_OVERFLOW))
+ && UNLIKELY(uv > MAX_NON_DEPRECATED_CP)
+ && ckWARN_d(WARN_DEPRECATED))
+ {
+ message = Perl_form(aTHX_ cp_above_legal_max,
+ uv, MAX_NON_DEPRECATED_CP);
+ pack_warn = packWARN(WARN_DEPRECATED);
+ }
+ }
+ else if (possible_problems & UTF8_GOT_NONCHAR) {
+ possible_problems &= ~UTF8_GOT_NONCHAR;
- if (retlen) {
- *retlen = curlen;
+ if (flags & UTF8_WARN_NONCHAR) {
+ *errors |= UTF8_GOT_NONCHAR;
+
+ if ( ! (flags & UTF8_CHECK_ONLY)
+ && ckWARN_d(WARN_NONCHAR))
+ {
+ /* The code above should have guaranteed that we don't
+ * get here with errors other than overlong */
+ assert (! (orig_problems
+ & ~(UTF8_GOT_LONG|UTF8_GOT_NONCHAR)));
+
+ pack_warn = packWARN(WARN_NONCHAR);
+ message = Perl_form(aTHX_ "Unicode non-character"
+ " U+%04"UVXf" is not recommended"
+ " for open interchange", uv);
+ }
+ }
+
+ if (flags & UTF8_DISALLOW_NONCHAR) {
+ disallowed = TRUE;
+ *errors |= UTF8_GOT_NONCHAR;
+ }
+ } /* End of looking through the possible flags */
+
+ /* Display the message (if any) for the problem being handled in
+ * this iteration of the loop */
+ if (message) {
+ if (PL_op)
+ Perl_warner(aTHX_ pack_warn, "%s in %s", message,
+ OP_DESC(PL_op));
+ else
+ Perl_warner(aTHX_ pack_warn, "%s", message);
+ }
+ } /* End of 'while (possible_problems) {' */
+
+ /* Since there was a possible problem, the returned length may need to
+ * be changed from the one stored at the beginning of this function.
+ * Instead of trying to figure out if that's needed, just do it. */
+ if (retlen) {
+ *retlen = curlen;
+ }
+
+ if (disallowed) {
+ if (flags & UTF8_CHECK_ONLY && retlen) {
+ *retlen = ((STRLEN) -1);
+ }
+ return 0;
+ }
}
- return outlier_ret;
+ return UNI_TO_NATIVE(uv);
}
/*
if (UTF8_IS_CONTINUATION(c1)) {
c = EIGHT_BIT_UTF8_TO_NATIVE(c, c1);
} else {
+ /* diag_listed_as: Malformed UTF-8 character%s */
Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
- "Malformed UTF-8 character "
- "(unexpected non-continuation byte 0x%02x"
- ", immediately after start byte 0x%02x)"
- /* Dear diag.t, it's in the pod. */
- "%s%s", c1, c,
- PL_op ? " in " : "",
- PL_op ? OP_DESC(PL_op) : "");
+ "%s %s%s",
+ unexpected_non_continuation_text(u - 1, 2, 1, 2),
+ PL_op ? " in " : "",
+ PL_op ? OP_DESC(PL_op) : "");
return -2;
}
} else {
PERL_ARGS_ASSERT_PV_UNI_DISPLAY;
- sv_setpvs(dsv, "");
+ SvPVCLEAR(dsv);
SvUTF8_off(dsv);
for (s = (const char *)spv, e = s + len; s < e; s += UTF8SKIP(s)) {
UV u;
#define utf8_to_uvchr_buf(s, e, lenp) \
utf8n_to_uvchr(s, (U8*)(e) - (U8*)(s), lenp, \
ckWARN_d(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY)
+#define utf8n_to_uvchr(s, len, lenp, flags) \
+ utf8n_to_uvchr_error(s, len, lenp, flags, 0)
#define to_uni_fold(c, p, lenp) _to_uni_fold_flags(c, p, lenp, FOLD_FLAGS_FULL)
#define to_utf8_fold(c, p, lenp) _to_utf8_fold_flags(c, p, lenp, FOLD_FLAGS_FULL)
#define to_utf8_upper(a,b,c) _to_utf8_upper_flags(a,b,c,0)
#define to_utf8_title(a,b,c) _to_utf8_title_flags(a,b,c,0)
-/* Source backward compatibility. */
-#define is_utf8_string_loc(s, len, ep) is_utf8_string_loclen(s, len, ep, 0)
-
#define foldEQ_utf8(s1, pe1, l1, u1, s2, pe2, l2, u2) \
foldEQ_utf8_flags(s1, pe1, l1, u1, s2, pe2, l2, u2, 0)
#define FOLDEQ_UTF8_NOMIX_ASCII (1 << 0)
| ((NATIVE_UTF8_TO_I8((U8)new)) \
& UTF_CONTINUATION_MASK))
-/* If a value is anded with this, and the result is non-zero, then using the
- * original value in UTF8_ACCUMULATE will overflow, shifting bits off the left
- * */
-#define UTF_ACCUMULATION_OVERFLOW_MASK \
- (((UV) UTF_CONTINUATION_MASK) << ((sizeof(UV) * CHARBITS) \
- - UTF_ACCUMULATION_SHIFT))
-
/* This works in the face of malformed UTF-8. */
#define UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, e) (UTF8_IS_DOWNGRADEABLE_START(*s) \
&& ( (e) - (s) > 1) \
#define UTF8_ALLOW_EMPTY 0x0001 /* Allow a zero length string */
+#define UTF8_GOT_EMPTY UTF8_ALLOW_EMPTY
/* Allow first byte to be a continuation byte */
#define UTF8_ALLOW_CONTINUATION 0x0002
+#define UTF8_GOT_CONTINUATION UTF8_ALLOW_CONTINUATION
-/* Allow second... bytes to be non-continuation bytes */
+/* Unexpected continuation byte */
#define UTF8_ALLOW_NON_CONTINUATION 0x0004
+#define UTF8_GOT_NON_CONTINUATION UTF8_ALLOW_NON_CONTINUATION
/* expecting more bytes than were available in the string */
#define UTF8_ALLOW_SHORT 0x0008
+#define UTF8_GOT_SHORT UTF8_ALLOW_SHORT
/* Overlong sequence; i.e., the code point can be specified in fewer bytes. */
#define UTF8_ALLOW_LONG 0x0010
+#define UTF8_GOT_LONG UTF8_ALLOW_LONG
-#define UTF8_DISALLOW_SURROGATE 0x0020 /* Unicode surrogates */
-#define UTF8_WARN_SURROGATE 0x0040
+/* Currently no way to allow overflow */
+#define UTF8_GOT_OVERFLOW 0x0020
-#define UTF8_DISALLOW_NONCHAR 0x0080 /* Unicode non-character */
-#define UTF8_WARN_NONCHAR 0x0100 /* code points */
+#define UTF8_DISALLOW_SURROGATE 0x0040 /* Unicode surrogates */
+#define UTF8_GOT_SURROGATE UTF8_DISALLOW_SURROGATE
+#define UTF8_WARN_SURROGATE 0x0080
-#define UTF8_DISALLOW_SUPER 0x0200 /* Super-set of Unicode: code */
-#define UTF8_WARN_SUPER 0x0400 /* points above the legal max */
+#define UTF8_DISALLOW_NONCHAR 0x0100 /* Unicode non-character */
+#define UTF8_GOT_NONCHAR UTF8_DISALLOW_NONCHAR
+#define UTF8_WARN_NONCHAR 0x0200 /* code points */
+
+#define UTF8_DISALLOW_SUPER 0x0400 /* Super-set of Unicode: code */
+#define UTF8_GOT_SUPER UTF8_DISALLOW_SUPER
+#define UTF8_WARN_SUPER 0x0800 /* points above the legal max */
/* Code points which never were part of the original UTF-8 standard, which only
* went up to 2 ** 31 - 1. Note that these all overflow a signed 32-bit word,
* The first byte of these code points is FE or FF on ASCII platforms. If the
* first byte is FF, it will overflow a 32-bit word. */
-#define UTF8_DISALLOW_ABOVE_31_BIT 0x0800
-#define UTF8_WARN_ABOVE_31_BIT 0x1000
+#define UTF8_DISALLOW_ABOVE_31_BIT 0x1000
+#define UTF8_GOT_ABOVE_31_BIT UTF8_DISALLOW_ABOVE_31_BIT
+#define UTF8_WARN_ABOVE_31_BIT 0x2000
/* For back compat, these old names are misleading for UTF_EBCDIC */
#define UTF8_DISALLOW_FE_FF UTF8_DISALLOW_ABOVE_31_BIT
#define UTF8_WARN_FE_FF UTF8_WARN_ABOVE_31_BIT
-#define UTF8_CHECK_ONLY 0x2000
+#define UTF8_CHECK_ONLY 0x4000
/* For backwards source compatibility. They do nothing, as the default now
* includes what they used to mean. The first one's meaning was to allow the
#define UTF8_ALLOW_ANY \
(~( UTF8_DISALLOW_ILLEGAL_INTERCHANGE|UTF8_DISALLOW_ABOVE_31_BIT \
|UTF8_WARN_ILLEGAL_INTERCHANGE|UTF8_WARN_ABOVE_31_BIT))
-#define UTF8_ALLOW_ANYUV \
- (UTF8_ALLOW_EMPTY \
- & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE|UTF8_WARN_ILLEGAL_INTERCHANGE))
+#define UTF8_ALLOW_ANYUV UTF8_ALLOW_EMPTY
#define UTF8_ALLOW_DEFAULT (ckWARN(WARN_UTF8) ? 0 : \
UTF8_ALLOW_ANYUV)
looking no further than S<C<e - 1>> are well-formed UTF-8, as extended by Perl,
that represents some code point; otherwise it evaluates to 0. If non-zero, the
value gives how many bytes starting at C<s> comprise the code point's
-representation.
+representation. Any bytes remaining before C<e>, but beyond the ones needed to
+form the first code point in C<s>, are not examined.
The code point can be any that will fit in a UV on this machine, using Perl's
extension to official UTF-8 to represent those higher than the Unicode maximum
of 0x10FFFF. That means that this macro is used to efficiently decide if the
-next few bytes in C<s> is legal UTF-8 for a single character. Use
-L</is_utf8_string>(), L</is_utf8_string_loclen>(), and
-L</is_utf8_string_loc>() to check entire strings.
+next few bytes in C<s> is legal UTF-8 for a single character.
+
+Use C<L</isSTRICT_UTF8_CHAR>> to restrict the acceptable code points to those
+defined by Unicode to be fully interchangeable across applications;
+C<L</isC9_STRICT_UTF8_CHAR>> to use the L<Unicode Corrigendum
+#9|http://www.unicode.org/versions/corrigendum9.html> definition of allowable
+code points; and C<L</isUTF8_CHAR_flags>> for a more customized definition.
+
+Use C<L</is_utf8_string>>, C<L</is_utf8_string_loc>>, and
+C<L</is_utf8_string_loclen>> to check entire strings.
Note that it is deprecated to use code points higher than what will fit in an
IV. This macro does not raise any warnings for such code points, treating them
looking no further than S<C<e - 1>> are well-formed UTF-8 that represents some
Unicode code point completely acceptable for open interchange between all
applications; otherwise it evaluates to 0. If non-zero, the value gives how
-many bytes starting at C<s> comprise the code point's representation.
+many bytes starting at C<s> comprise the code point's representation. Any
+bytes remaining before C<e>, but beyond the ones needed to form the first code
+point in C<s>, are not examined.
The largest acceptable code point is the Unicode maximum 0x10FFFF, and must not
be a surrogate nor a non-character code point. Thus this excludes any code
point from Perl's extended UTF-8.
This is used to efficiently decide if the next few bytes in C<s> is
-legal Unicode-acceptable UTF-8 for a single character. Use
-C<L</isC9_STRICT_UTF8_CHAR>> to also accept non-character code points.
+legal Unicode-acceptable UTF-8 for a single character.
+
+Use C<L</isC9_STRICT_UTF8_CHAR>> to use the L<Unicode Corrigendum
+#9|http://www.unicode.org/versions/corrigendum9.html> definition of allowable
+code points; C<L</isUTF8_CHAR>> to check for Perl's extended UTF-8;
+and C<L</isUTF8_CHAR_flags>> for a more customized definition.
+
+Use C<L</is_strict_utf8_string>>, C<L</is_strict_utf8_string_loc>>, and
+C<L</is_strict_utf8_string_loclen>> to check entire strings.
=cut
*/
looking no further than S<C<e - 1>> are well-formed UTF-8 that represents some
Unicode non-surrogate code point; otherwise it evaluates to 0. If non-zero,
the value gives how many bytes starting at C<s> comprise the code point's
-representation.
+representation. Any bytes remaining before C<e>, but beyond the ones needed to
+form the first code point in C<s>, are not examined.
The largest acceptable code point is the Unicode maximum 0x10FFFF. This
differs from C<L</isSTRICT_UTF8_CHAR>> only in that it accepts non-character
completely forbidden in open interchange. See
L<perlunicode/Noncharacter code points>.
+Use C<L</isUTF8_CHAR>> to check for Perl's extended UTF-8; and
+C<L</isUTF8_CHAR_flags>> for a more customized definition.
+
+Use C<L</is_c9strict_utf8_string>>, C<L</is_c9strict_utf8_string_loc>>, and
+C<L</is_c9strict_utf8_string_loclen>> to check entire strings.
+
=cut
*/
looking no further than S<C<e - 1>> are well-formed UTF-8, as extended by Perl,
that represents some code point, subject to the restrictions given by C<flags>;
otherwise it evaluates to 0. If non-zero, the value gives how many bytes
-starting at C<s> comprise the code point's representation.
+starting at C<s> comprise the code point's representation. Any bytes remaining
+before C<e>, but beyond the ones needed to form the first code point in C<s>,
+are not examined.
If C<flags> is 0, this gives the same results as C<L</isUTF8_CHAR>>;
if C<flags> is C<UTF8_DISALLOW_ILLEGAL_INTERCHANGE>, this gives the same results
are likely to run somewhat faster than this more general one, as they can be
inlined into your code.
+Use L</is_utf8_string_flags>, L</is_utf8_string_loc_flags>, and
+L</is_utf8_string_loclen_flags> to check entire strings.
+
=cut
*/
extra.pods : miniperl
@ @extra_pods.com
-PERLDELTA_CURRENT = [.pod]perl5255delta.pod
+PERLDELTA_CURRENT = [.pod]perl5256delta.pod
$(PERLDELTA_CURRENT) : [.pod]perldelta.pod
Copy/NoConfirm/Log $(MMS$SOURCE) $(PERLDELTA_CURRENT)
envhv = GvHVn(PL_envgv);
/* Perform a dummy fetch as an lval to insure that the hash table is
* set up. Otherwise, the hv_store() will turn into a nullop. */
- (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
+ (void) hv_fetchs(envhv,"DEFAULT",TRUE);
for (i = 0; env_tables[i]; i++) {
if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
ver = SvRV(ver);
/* Begin copying all of the elements */
- if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
+ if ( hv_existss(MUTABLE_HV(ver), "qv") )
(void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
- if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
+ if ( hv_existss(MUTABLE_HV(ver), "alpha") )
(void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
{
SV ** svp = hv_fetchs(MUTABLE_HV(ver), "width", FALSE);
Perl_croak(aTHX_ "Invalid version object");
/* see if various flags exist */
- if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
+ if ( hv_existss(MUTABLE_HV(vs), "alpha") )
alpha = TRUE;
if (alpha) {
return &PL_sv_undef;
}
else {
- if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
+ if ( hv_existss(MUTABLE_HV(vs), "qv") )
return VNORMAL(vs);
else
return VNUMIFY(vs);
}
if ( VCMP( req, sv ) > 0 ) {
- if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
+ if ( hv_existss(MUTABLE_HV(SvRV(req)), "qv") ) {
req = VNORMAL(req);
sv = VNORMAL(sv);
}
# versioned installation can be obtained by setting INST_TOP above to a
# path that includes an arbitrary version string.
#
-#INST_VER := \5.25.5
+#INST_VER := \5.25.6
#
# Comment this out if you DON'T want your perl installation to have
copy ..\README.tw ..\pod\perltw.pod
copy ..\README.vos ..\pod\perlvos.pod
copy ..\README.win32 ..\pod\perlwin32.pod
- copy ..\pod\perldelta.pod ..\pod\perl5255delta.pod
+ copy ..\pod\perldelta.pod ..\pod\perl5256delta.pod
$(MINIPERL) -I..\lib $(PL2BAT) $(UTILS)
$(MINIPERL) -I..\lib ..\autodoc.pl ..
$(MINIPERL) -I..\lib ..\pod\perlmodlib.PL -q ..
-if exist $(LIBDIR)\Win32API rmdir /s /q $(LIBDIR)\Win32API
-if exist $(LIBDIR)\XS rmdir /s /q $(LIBDIR)\XS
-cd $(PODDIR) && del /f *.html *.bat roffitall \
- perl5255delta.pod perlaix.pod perlamiga.pod perlandroid.pod \
+ perl5256delta.pod perlaix.pod perlamiga.pod perlandroid.pod \
perlapi.pod perlbs2000.pod perlce.pod perlcn.pod perlcygwin.pod \
perldos.pod perlfreebsd.pod perlhaiku.pod perlhpux.pod \
perlhurd.pod perlintern.pod perlirix.pod perljp.pod perlko.pod \
# versioned installation can be obtained by setting INST_TOP above to a
# path that includes an arbitrary version string.
#
-#INST_VER = \5.25.5
+#INST_VER = \5.25.6
#
# Comment this out if you DON'T want your perl installation to have
copy ..\README.tw ..\pod\perltw.pod
copy ..\README.vos ..\pod\perlvos.pod
copy ..\README.win32 ..\pod\perlwin32.pod
- copy ..\pod\perldelta.pod ..\pod\perl5255delta.pod
+ copy ..\pod\perldelta.pod ..\pod\perl5256delta.pod
cd ..\win32
$(PERLEXE) $(PL2BAT) $(UTILS)
$(MINIPERL) -I..\lib ..\autodoc.pl ..
-if exist $(LIBDIR)\Win32API rmdir /s /q $(LIBDIR)\Win32API
-if exist $(LIBDIR)\XS rmdir /s /q $(LIBDIR)\XS
-cd $(PODDIR) && del /f *.html *.bat roffitall \
- perl5255delta.pod perlaix.pod perlamiga.pod perlandroid.pod \
+ perl5256delta.pod perlaix.pod perlamiga.pod perlandroid.pod \
perlapi.pod perlbs2000.pod perlce.pod perlcn.pod perlcygwin.pod \
perldos.pod perlfreebsd.pod perlhaiku.pod perlhpux.pod \
perlhurd.pod perlintern.pod perlirix.pod perljp.pod perlko.pod \
# versioned installation can be obtained by setting INST_TOP above to a
# path that includes an arbitrary version string.
#
-#INST_VER *= \5.25.5
+#INST_VER *= \5.25.6
#
# Comment this out if you DON'T want your perl installation to have
copy ..\README.tw ..\pod\perltw.pod
copy ..\README.vos ..\pod\perlvos.pod
copy ..\README.win32 ..\pod\perlwin32.pod
- copy ..\pod\perldelta.pod ..\pod\perl5255delta.pod
+ copy ..\pod\perldelta.pod ..\pod\perl5256delta.pod
$(MINIPERL) -I..\lib $(PL2BAT) $(UTILS)
$(MINIPERL) -I..\lib ..\autodoc.pl ..
$(MINIPERL) -I..\lib ..\pod\perlmodlib.PL -q ..
-if exist $(LIBDIR)\Win32API rmdir /s /q $(LIBDIR)\Win32API
-if exist $(LIBDIR)\XS rmdir /s /q $(LIBDIR)\XS
-cd $(PODDIR) && del /f *.html *.bat roffitall \
- perl5255delta.pod perlaix.pod perlamiga.pod perlandroid.pod \
+ perl5256delta.pod perlaix.pod perlamiga.pod perlandroid.pod \
perlapi.pod perlbs2000.pod perlce.pod perlcn.pod perlcygwin.pod \
perldos.pod perlfreebsd.pod perlhaiku.pod perlhpux.pod \
perlhurd.pod perlintern.pod perlirix.pod perljp.pod perlko.pod \
perl5253delta.pod \
perl5254delta.pod \
perl5255delta.pod \
+ perl5256delta.pod \
perl561delta.pod \
perl56delta.pod \
perl581delta.pod \
perl5253delta.man \
perl5254delta.man \
perl5255delta.man \
+ perl5256delta.man \
perl561delta.man \
perl56delta.man \
perl581delta.man \
perl5253delta.html \
perl5254delta.html \
perl5255delta.html \
+ perl5256delta.html \
perl561delta.html \
perl56delta.html \
perl581delta.html \
perl5253delta.tex \
perl5254delta.tex \
perl5255delta.tex \
+ perl5256delta.tex \
perl561delta.tex \
perl56delta.tex \
perl581delta.tex \
{
dTHX;
- sv_setpvn((SV*)sv, "Error", 5);
+ sv_setpvs((SV*)sv, "Error");
}
projects / platform / upstream / perl.git / commitdiff