Colin Kuskie <ckuskie@cadence.com>
Colin McMillen <mcmi0073@tc.umn.edu>
Colin Meyer <cmeyer@helvella.org>
+Colin Newell <colin.newell@gmail.com>
Colin Watson <colinw@zeus.com>
Conrad Augustin
Conrad E. Kimball <cek@tblv021.ca.boeing.com>
Osvaldo Villalon <ovillalon@dextratech.com>
Owain G. Ainsworth <oga@nicotinebsd.org>
Owen Taylor <owt1@cornell.edu>
+Pali <pali@cpan.org>
Papp Zoltan <padre@elte.hu>
parv <parv@pair.com>
Pascal Rigaux <pixel@mandriva.com>
ansi2knr=''
aphostname='/bin/hostname'
api_revision='5'
-api_subversion='9'
+api_subversion='10'
api_version='25'
-api_versionstring='5.25.9'
+api_versionstring='5.25.10'
ar='ar'
-archlib='/usr/lib/perl5/5.25.9/armv4l-linux'
-archlibexp='/usr/lib/perl5/5.25.9/armv4l-linux'
+archlib='/usr/lib/perl5/5.25.10/armv4l-linux'
+archlibexp='/usr/lib/perl5/5.25.10/armv4l-linux'
archname64=''
archname='armv4l-linux'
archobjs=''
cat='cat'
cc='cc'
cccdlflags='-fpic'
-ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.25.9/armv4l-linux/CORE'
+ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.25.10/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.9/armv4l-linux'
+installarchlib='./install_me_here/usr/lib/perl5/5.25.10/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.9'
+installprivlib='./install_me_here/usr/lib/perl5/5.25.10'
installscript='./install_me_here/usr/bin'
-installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.25.9/armv4l-linux'
+installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.25.10/armv4l-linux'
installsitebin='./install_me_here/usr/bin'
installsitehtml1dir=''
installsitehtml3dir=''
-installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.25.9'
+installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.25.10'
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.9'
-privlibexp='/usr/lib/perl5/5.25.9'
+privlib='/usr/lib/perl5/5.25.10'
+privlibexp='/usr/lib/perl5/5.25.10'
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.9/armv4l-linux'
-sitearchexp='/usr/lib/perl5/site_perl/5.25.9/armv4l-linux'
+sitearch='/usr/lib/perl5/site_perl/5.25.10/armv4l-linux'
+sitearchexp='/usr/lib/perl5/site_perl/5.25.10/armv4l-linux'
sitebin='/usr/bin'
sitebinexp='/usr/bin'
sitehtml1dir=''
sitehtml1direxp=''
sitehtml3dir=''
sitehtml3direxp=''
-sitelib='/usr/lib/perl5/site_perl/5.25.9'
+sitelib='/usr/lib/perl5/site_perl/5.25.10'
sitelib_stem='/usr/lib/perl5/site_perl'
-sitelibexp='/usr/lib/perl5/site_perl/5.25.9'
+sitelibexp='/usr/lib/perl5/site_perl/5.25.10'
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='9'
+subversion='10'
sysman='/usr/share/man/man1'
tail=''
tar=''
vendorprefixexp=''
vendorscript=''
vendorscriptexp=''
-version='5.25.9'
-version_patchlevel_string='version 25 subversion 9'
+version='5.25.10'
+version_patchlevel_string='version 25 subversion 10'
versiononly='undef'
vi=''
xlibpth='/usr/lib/386 /lib/386'
config_argc=0
PERL_REVISION=5
PERL_VERSION=25
-PERL_SUBVERSION=9
+PERL_SUBVERSION=10
PERL_API_REVISION=5
PERL_API_VERSION=25
-PERL_API_SUBVERSION=9
+PERL_API_SUBVERSION=10
PERL_PATCHLEVEL=
PERL_CONFIG_SH=true
ansi2knr=''
aphostname='/bin/hostname'
api_revision='5'
-api_subversion='9'
+api_subversion='10'
api_version='25'
-api_versionstring='5.25.9'
+api_versionstring='5.25.10'
ar='ar'
-archlib='/usr/lib/perl5/5.25.9/armv4l-linux'
-archlibexp='/usr/lib/perl5/5.25.9/armv4l-linux'
+archlib='/usr/lib/perl5/5.25.10/armv4l-linux'
+archlibexp='/usr/lib/perl5/5.25.10/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.9/armv4l-linux/CORE'
+ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.25.10/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.9/armv4l-linux'
+installarchlib='./install_me_here/usr/lib/perl5/5.25.10/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.9'
+installprivlib='./install_me_here/usr/lib/perl5/5.25.10'
installscript='./install_me_here/usr/bin'
-installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.25.9/armv4l-linux'
+installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.25.10/armv4l-linux'
installsitebin='./install_me_here/usr/bin'
installsitehtml1dir=''
installsitehtml3dir=''
-installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.25.9'
+installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.25.10'
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.9'
-privlibexp='/usr/lib/perl5/5.25.9'
+privlib='/usr/lib/perl5/5.25.10'
+privlibexp='/usr/lib/perl5/5.25.10'
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.9/armv4l-linux'
-sitearchexp='/usr/lib/perl5/site_perl/5.25.9/armv4l-linux'
+sitearch='/usr/lib/perl5/site_perl/5.25.10/armv4l-linux'
+sitearchexp='/usr/lib/perl5/site_perl/5.25.10/armv4l-linux'
sitebin='/usr/bin'
sitebinexp='/usr/bin'
sitehtml1dir=''
sitehtml1direxp=''
sitehtml3dir=''
sitehtml3direxp=''
-sitelib='/usr/lib/perl5/site_perl/5.25.9'
+sitelib='/usr/lib/perl5/site_perl/5.25.10'
sitelib_stem='/usr/lib/perl5/site_perl'
-sitelibexp='/usr/lib/perl5/site_perl/5.25.9'
+sitelibexp='/usr/lib/perl5/site_perl/5.25.10'
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='9'
+subversion='10'
sysman='/usr/share/man/man1'
tail=''
tar=''
vendorprefixexp=''
vendorscript=''
vendorscriptexp=''
-version='5.25.9'
-version_patchlevel_string='version 25 subversion 9'
+version='5.25.10'
+version_patchlevel_string='version 25 subversion 10'
versiononly='undef'
vi=''
xlibpth='/usr/lib/386 /lib/386'
config_argc=0
PERL_REVISION=5
PERL_VERSION=25
-PERL_SUBVERSION=9
+PERL_SUBVERSION=10
PERL_API_REVISION=5
PERL_API_VERSION=25
-PERL_API_SUBVERSION=9
+PERL_API_SUBVERSION=10
PERL_PATCHLEVEL=
PERL_CONFIG_SH=true
=item Directories for the perl distribution
-By default, Configure will use the following directories for 5.25.9.
+By default, Configure will use the following directories for 5.25.10.
$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.9 is not binary compatible with earlier versions of Perl.
+Perl 5.25.10 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.9
+ sh Configure -Dprefix=/opt/perl5.25.10
-and adding /opt/perl5.25.9/bin to the shell PATH variable. Such users
+and adding /opt/perl5.25.10/bin to the shell PATH variable. Such users
may also wish to add a symbolic link /usr/local/bin/perl so that
scripts can still start with #!/usr/local/bin/perl.
subversions may not have all the compatibility wrinkles ironed out
yet.
-=head2 Upgrading from 5.25.2 or earlier
+=head2 Upgrading from 5.25.9 or earlier
-B<Perl 5.25.9 may not be binary compatible with Perl 5.25.3 or
+B<Perl 5.25.10 may not be binary compatible with Perl 5.25.9 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.9. If you find you do need to rebuild an extension with
-5.25.9, you may safely do so without disturbing the older
+used with 5.25.10. If you find you do need to rebuild an extension with
+5.25.10, 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.9 is as follows (under $Config{prefix}):
+in Linux with perl-5.25.10 is as follows (under $Config{prefix}):
./bin/perl
- ./lib/perl5/5.25.9/strict.pm
- ./lib/perl5/5.25.9/warnings.pm
- ./lib/perl5/5.25.9/i686-linux/File/Glob.pm
- ./lib/perl5/5.25.9/feature.pm
- ./lib/perl5/5.25.9/XSLoader.pm
- ./lib/perl5/5.25.9/i686-linux/auto/File/Glob/Glob.so
+ ./lib/perl5/5.25.10/strict.pm
+ ./lib/perl5/5.25.10/warnings.pm
+ ./lib/perl5/5.25.10/i686-linux/File/Glob.pm
+ ./lib/perl5/5.25.10/feature.pm
+ ./lib/perl5/5.25.10/XSLoader.pm
+ ./lib/perl5/5.25.10/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
ext/XS-APItest/t/gv_fetchmeth_autoload.t XS::APItest: tests for gv_fetchmeth_autoload() and variants
ext/XS-APItest/t/gv_fetchmethod_flags.t XS::APItest: tests for gv_fetchmethod_flags() and variants
ext/XS-APItest/t/gv_init.t XS::APItest: tests for gv_init and variants
-ext/XS-APItest/t/handy.t XS::APItest: tests for handy.h
+ext/XS-APItest/t/handy0.t XS::APItest: tests for handy.h
+ext/XS-APItest/t/handy1.t XS::APItest: tests for handy.h
+ext/XS-APItest/t/handy2.t XS::APItest: tests for handy.h
+ext/XS-APItest/t/handy3.t XS::APItest: tests for handy.h
+ext/XS-APItest/t/handy4.t XS::APItest: tests for handy.h
+ext/XS-APItest/t/handy5.t XS::APItest: tests for handy.h
+ext/XS-APItest/t/handy6.t XS::APItest: tests for handy.h
+ext/XS-APItest/t/handy7.t XS::APItest: tests for handy.h
+ext/XS-APItest/t/handy8.t XS::APItest: tests for handy.h
+ext/XS-APItest/t/handy9.t XS::APItest: tests for handy.h
+ext/XS-APItest/t/handy_base.pl XS::APItest: tests for handy.h
ext/XS-APItest/t/hash.t XS::APItest: tests for hash related APIs
ext/XS-APItest/t/join_with_space.t test op_convert_list
ext/XS-APItest/t/keyword_multiline.t test keyword plugin parsing across lines
ext/XS-APItest/t/underscore_length.t Test find_rundefsv()
ext/XS-APItest/t/utf16_to_utf8.t Test behaviour of utf16_to_utf8{,reversed}
ext/XS-APItest/t/utf8.t Tests for code in utf8.c
+ext/XS-APItest/t/utf8_malformed.t Tests for code in utf8.c
+ext/XS-APItest/t/utf8_setup.pl Tests for code in utf8.c
+ext/XS-APItest/t/utf8_warn0.t Tests for code in utf8.c
+ext/XS-APItest/t/utf8_warn1.t Tests for code in utf8.c
+ext/XS-APItest/t/utf8_warn2.t Tests for code in utf8.c
+ext/XS-APItest/t/utf8_warn3.t Tests for code in utf8.c
+ext/XS-APItest/t/utf8_warn4.t Tests for code in utf8.c
+ext/XS-APItest/t/utf8_warn5.t Tests for code in utf8.c
+ext/XS-APItest/t/utf8_warn6.t Tests for code in utf8.c
+ext/XS-APItest/t/utf8_warn7.t Tests for code in utf8.c
+ext/XS-APItest/t/utf8_warn8.t Tests for code in utf8.c
+ext/XS-APItest/t/utf8_warn9.t Tests for code in utf8.c
+ext/XS-APItest/t/utf8_warn_base.pl Tests for code in utf8.c
ext/XS-APItest/t/weaken.t XS::APItest: tests for sv_rvweaken() and sv_get_backrefs()
ext/XS-APItest/t/whichsig.t XS::APItest: tests for whichsig() and variants
ext/XS-APItest/t/win32.t Test Win32 specific APIs
pod/perl5256delta.pod Perl changes in version 5.25.6
pod/perl5257delta.pod Perl changes in version 5.25.7
pod/perl5258delta.pod Perl changes in version 5.25.8
+pod/perl5259delta.pod Perl changes in version 5.25.9
pod/perl561delta.pod Perl changes in version 5.6.1
pod/perl56delta.pod Perl changes in version 5.6
pod/perl581delta.pod Perl changes in version 5.8.1
t/lib/croak/pp_hot Test croak calls from pp_hot.c
t/lib/croak/pp_sys Test croak calls from pp_sys.c
t/lib/croak/toke Test croak calls from toke.c
+t/lib/croak/toke_l1 Test croak calls from toke.c; file is not UTF-8 encoded
t/lib/cygwin.t Builtin cygwin function tests
t/lib/dbmt_common.pl Common functionality for ?DBM_File tests
t/lib/deprecate.t Test deprecate.pm
"url" : "http://perl5.git.perl.org/"
}
},
- "version" : "5.025009",
+ "version" : "5.025010",
"x_serialization_backend" : "JSON::PP version 2.27400_02"
}
homepage: http://www.perl.org/
license: http://dev.perl.org/licenses/
repository: http://perl5.git.perl.org/
-version: '5.025009'
+version: '5.025010'
x_serialization_backend: 'CPAN::Meta::YAML version 0.018'
$spitshell >>$Makefile <<'!NO!SUBS!'
-perltoc_pod_prereqs = extra.pods pod/perl5259delta.pod pod/perlapi.pod pod/perlintern.pod pod/perlmodlib.pod pod/perluniprops.pod
+perltoc_pod_prereqs = extra.pods pod/perl52510delta.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/perl5259delta.pod: pod/perldelta.pod
- $(RMS) pod/perl5259delta.pod
- $(LNS) perldelta.pod pod/perl5259delta.pod
+pod/perl52510delta.pod: pod/perldelta.pod
+ $(RMS) pod/perl52510delta.pod
+ $(LNS) perldelta.pod pod/perl52510delta.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.9 for NetWare"
+MODULE_DESC = "Perl 5.25.10 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.9
+INST_VER = \5.25.10
#
# 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.9\\lib\\NetWare-x86-multi-thread" /**/
+#define ARCHLIB "c:\\perl\\5.25.10\\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.9\\bin\\NetWare-x86-multi-thread" /**/
-#define BIN_EXP "c:\\perl\\5.25.9\\bin\\NetWare-x86-multi-thread" /**/
+#define BIN "c:\\perl\\5.25.10\\bin\\NetWare-x86-multi-thread" /**/
+#define BIN_EXP "c:\\perl\\5.25.10\\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.9\\lib\\NetWare-x86-multi-thread" /**/
+#define SITEARCH "c:\\perl\\site\\5.25.10\\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.9\\lib" /**/
+#define SITELIB "c:\\perl\\site\\5.25.10\\lib" /**/
/*#define SITELIB_EXP "" /**/
#define SITELIB_STEM "" /**/
},
'CPAN' => {
- 'DISTRIBUTION' => 'ANDK/CPAN-2.16-TRIAL2.tar.gz',
+ 'DISTRIBUTION' => 'ANDK/CPAN-2.17-TRIAL2.tar.gz',
'FILES' => q[cpan/CPAN],
'EXCLUDED' => [
qr{^distroprefs/},
},
'Module::CoreList' => {
- 'DISTRIBUTION' => 'BINGOS/Module-CoreList-5.20161220.tar.gz',
+ 'DISTRIBUTION' => 'BINGOS/Module-CoreList-5.20170120.tar.gz',
'FILES' => q[dist/Module-CoreList],
},
'lib/Sub/Util.pm', # CPAN RT 118470
't/lln.t', # CPAN RT 118470
't/uniq.t', # CPAN RT 118470
+ 't/tainted.t', # CPAN RT 119169
],
},
# correct for this (and Thread::Semaphore, threads, and threads::shared)
# to be under dist/ rather than cpan/
'Thread::Queue' => {
- 'DISTRIBUTION' => 'JDHEDDEN/Thread-Queue-3.11.tar.gz',
+ 'DISTRIBUTION' => 'JDHEDDEN/Thread-Queue-3.12.tar.gz',
'FILES' => q[dist/Thread-Queue],
'EXCLUDED' => [
qr{^examples/},
+ github@renee-baecker.de
+ otrs\100ubuntu.(none)
+ perl\100renee-baecker.de
++ reb\100perl-services.de
richard.foley\100rfi.net richard.foley\100t-online.de
+ richard.foley\100ubs.com
+ richard.foley\100ubsw.com
ansi2knr=''
aphostname='/bin/hostname'
api_revision='5'
-api_subversion='9'
+api_subversion='10'
api_version='25'
-api_versionstring='5.25.9'
+api_versionstring='5.25.10'
ar='ar'
-archlib='/tmp/mblead/lib/perl5/5.25.9/darwin-2level'
-archlibexp='/tmp/mblead/lib/perl5/5.25.9/darwin-2level'
+archlib='/tmp/mblead/lib/perl5/5.25.10/darwin-2level'
+archlibexp='/tmp/mblead/lib/perl5/5.25.10/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.9/darwin-2level'
+installarchlib='/tmp/mblead/lib/perl5/5.25.10/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.9'
+installprivlib='/tmp/mblead/lib/perl5/5.25.10'
installscript='/tmp/mblead/bin'
-installsitearch='/tmp/mblead/lib/perl5/site_perl/5.25.9/darwin-2level'
+installsitearch='/tmp/mblead/lib/perl5/site_perl/5.25.10/darwin-2level'
installsitebin='/tmp/mblead/bin'
installsitehtml1dir=''
installsitehtml3dir=''
-installsitelib='/tmp/mblead/lib/perl5/site_perl/5.25.9'
+installsitelib='/tmp/mblead/lib/perl5/site_perl/5.25.10'
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.9'
+perlpath='/tmp/mblead/bin/perl5.25.10'
pg='pg'
phostname='hostname'
pidtype='pid_t'
pr=''
prefix='/tmp/mblead'
prefixexp='/tmp/mblead'
-privlib='/tmp/mblead/lib/perl5/5.25.9'
-privlibexp='/tmp/mblead/lib/perl5/5.25.9'
+privlib='/tmp/mblead/lib/perl5/5.25.10'
+privlibexp='/tmp/mblead/lib/perl5/5.25.10'
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.9/darwin-2level'
-sitearchexp='/tmp/mblead/lib/perl5/site_perl/5.25.9/darwin-2level'
+sitearch='/tmp/mblead/lib/perl5/site_perl/5.25.10/darwin-2level'
+sitearchexp='/tmp/mblead/lib/perl5/site_perl/5.25.10/darwin-2level'
sitebin='/tmp/mblead/bin'
sitebinexp='/tmp/mblead/bin'
sitehtml1dir=''
sitehtml1direxp=''
sitehtml3dir=''
sitehtml3direxp=''
-sitelib='/tmp/mblead/lib/perl5/site_perl/5.25.9'
+sitelib='/tmp/mblead/lib/perl5/site_perl/5.25.10'
sitelib_stem='/tmp/mblead/lib/perl5/site_perl'
-sitelibexp='/tmp/mblead/lib/perl5/site_perl/5.25.9'
+sitelibexp='/tmp/mblead/lib/perl5/site_perl/5.25.10'
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.9'
+startperl='#!/tmp/mblead/bin/perl5.25.10'
startsh='#!/bin/sh'
static_ext=' '
stdchar='char'
strerror_r_proto='0'
strings='/usr/include/string.h'
submit=''
-subversion='9'
+subversion='10'
sysman='/usr/share/man/man1'
sysroot=''
tail=''
vendorprefixexp=''
vendorscript=''
vendorscriptexp=''
-version='5.25.9'
-version_patchlevel_string='version 25 subversion 9'
+version='5.25.10'
+version_patchlevel_string='version 25 subversion 10'
versiononly='define'
vi=''
xlibpth='/usr/lib/386 /lib/386'
zip='zip'
PERL_REVISION=5
PERL_VERSION=25
-PERL_SUBVERSION=9
+PERL_SUBVERSION=10
PERL_API_REVISION=5
PERL_API_VERSION=25
-PERL_API_SUBVERSION=9
+PERL_API_SUBVERSION=10
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.9/i686-linux-64int-ld" /**/
-#define ARCHLIB_EXP "/pro/lib/perl5/5.25.9/i686-linux-64int-ld" /**/
+#define ARCHLIB "/pro/lib/perl5/5.25.10/i686-linux-64int-ld" /**/
+#define ARCHLIB_EXP "/pro/lib/perl5/5.25.10/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.9" /**/
-#define PRIVLIB_EXP "/pro/lib/perl5/5.25.9" /**/
+#define PRIVLIB "/pro/lib/perl5/5.25.10" /**/
+#define PRIVLIB_EXP "/pro/lib/perl5/5.25.10" /**/
/* 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.9/i686-linux-64int-ld" /**/
-#define SITEARCH_EXP "/pro/lib/perl5/site_perl/5.25.9/i686-linux-64int-ld" /**/
+#define SITEARCH "/pro/lib/perl5/site_perl/5.25.10/i686-linux-64int-ld" /**/
+#define SITEARCH_EXP "/pro/lib/perl5/site_perl/5.25.10/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.9" /**/
-#define SITELIB_EXP "/pro/lib/perl5/site_perl/5.25.9" /**/
+#define SITELIB "/pro/lib/perl5/site_perl/5.25.10" /**/
+#define SITELIB_EXP "/pro/lib/perl5/site_perl/5.25.10" /**/
#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.9" /**/
+#define STARTPERL "#!/pro/bin/perl5.25.10" /**/
/* HAS_STDIO_STREAM_ARRAY:
* This symbol, if defined, tells that there is an array
=head1 EPIGRAPHS
+=head2 v5.25.9 - A. A. Milne, "Winnie-the-Pooh", 1926
+
+L<Announced on 2017-01-20 by Abigail|http://www.nntp.perl.org/group/perl.perl5.porters/2017/01/msg242405.html>
+
+ Pooh always liked a little something at eleven o'clock in the
+ morning, and he was very glad to see Rabbit getting out the plates
+ and mugs; and when Rabbit said, "Honey or condensed milk with
+ your bread?" he was so excited that he said, "Both," and then,
+ so as not to seem greedy, he added, "But don't bother about the
+ bread, please."
+
=head2 v5.25.8 - Langston Hughes, So long
L<Announced on 2016-12-20 by Sawyer X|http://www.nntp.perl.org/group/perl.perl5.porters/2016/12/msg241739.html>
Code freezes (which happen in the 5.25.X series)
2016-12-20 5.25.8 Contentious changes freeze
- 2017-01-20 5.25.9 User-visible changes freeze
+ 2017-01-20 5.25.9 User-visible changes to correctly
+ functioning programs freeze
2017-02-20 5.25.10 Full code freeze
2017-04-20 5.26.0 Stable release!
2016-10-20 5.25.6 ✓ Aaron Crane
2016-11-20 5.25.7 ✓ Chad Granum
2016-12-20 5.25.8 ✓ Sawyer X
- 2017-01-20 5.25.9 Abigail
+ 2017-01-20 5.25.9 ✓ Abigail
2017-02-20 5.25.10 Renée Bäcker
(RC0 for 5.26.0 will be released once we think that all the blockers have been
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.9.
+options would be nice for perl 5.25.10.
=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.9"
+of 5.25.10"
=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.9/BePC-haiku/CORE/libperl.so .
+ cd /boot/common/lib; ln -s perl5/5.25.10/BePC-haiku/CORE/libperl.so .
-Replace C<5.25.9> with your respective version of Perl.
+Replace C<5.25.10> 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.9.tar.gz
- tar -xzf perl-5.25.9.tar.gz
- cd perl-5.25.9
+ curl -O http://www.cpan.org/src/perl-5.25.10.tar.gz
+ tar -xzf perl-5.25.10.tar.gz
+ cd perl-5.25.10
./Configure -des -Dprefix=/usr/local/
make
make test
=head1 DESCRIPTION
-The latest Perl release (5.25.9 as of this writing) builds without changes
+The latest Perl release (5.25.10 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.9/
+ unzip perl_ste.zip -d f:/perllib/lib/site_perl/5.25.10/
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^.9.tar
+ vmstar -xvf perl-5^.25^.10.tar
Then set default to the top-level source directory like so:
- set default [.perl-5^.25^.9]
+ set default [.perl-5^.25^.10]
and proceed with configuration as described in the next section.
=back
The Microsoft Visual C++ compilers are also now being given away free. They are
-available as "Visual C++ Toolkit 2003" or "Visual C++ 2005-2013 Express
+available as "Visual C++ Toolkit 2003" or "Visual C++ 2005-2015 Express
Edition" (and also as part of the ".NET Framework SDK") and are the same
compilers that ship with "Visual C++ .NET 2003 Professional" or "Visual C++
-2005-2013 Professional" respectively.
+2005-2015 Professional" respectively.
This port can also be built on IA64/AMD64 using:
With the newer compilers, you may also use the older batch files if you choose
so.
-=item Microsoft Visual C++ 2008-2013 Express Edition
+=item Microsoft Visual C++ 2008-2015 Express Edition
-These free versions of Visual C++ 2008-2013 Professional contain the same
+These free versions of Visual C++ 2008-2015 Professional contain the same
compilers and linkers that ship with the full versions, and also contain
everything necessary to build Perl, rather than requiring a separate download
of the Windows SDK like previous versions did.
links to these packages has proven a pointless task because the links keep on
changing so often.)
-Install Visual C++ 2008-2013 Express, then setup your environment using, e.g.
+Install Visual C++ 2008-2015 Express, then setup your environment using, e.g.
C:\Program Files\Microsoft Visual Studio 12.0\Common7\Tools\vsvars32.bat
(assuming the default installation location was chosen).
Perl should now build using the win32/Makefile. You will need to edit that
-file to set CCTYPE to one of MSVC90FREE-MSVC120FREE first.
+file to set CCTYPE to one of MSVC90FREE-MSVC140FREE first.
=item Microsoft Visual C++ 2005 Express Edition
If you build with Visual C++ 2013 then three tests currently may fail with
Daylight Saving Time related problems: F<t/io/fs.t>,
F<cpan/HTTP-Tiny/t/110_mirror.t> and F<lib/File/Copy.t>. The failures are
-caused by bugs in the CRT in VC++ 2013 which will be fixed in future releases
-of VC++, as explained by Microsoft here:
+caused by bugs in the CRT in VC++ 2013 which are fixed in VC++2015 and
+later, as explained by Microsoft here:
L<https://connect.microsoft.com/VisualStudio/feedback/details/811534/utime-sometimes-fails-to-set-the-correct-file-times-in-visual-c-2013>. In the meantime,
if you need fixed C<stat> and C<utime> functions then have a look at the
CPAN distribution Win32::UTCFileTime.
Support for 64-bit Windows added in 5.8 (ActiveState Corp).
-Last updated: 07 October 2014
+Last updated: 19 February 2017
=cut
? mg_size(MUTABLE_SV(av)) : AvFILLp(av))
#define av_tindex(av) av_top_index(av)
-#if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_REGEXEC_C) || defined(PERL_IN_UTF8_C)
/* Note that it doesn't make sense to do this:
* SvGETMAGIC(av); IV x = av_tindex_nomg(av);
- * This name is controversial, and so is restricted by the #ifdef to the places
- * it already occurs
*/
-# define av_tindex_nomg(av) (__ASSERT_(SvTYPE(av) == SVt_PVAV) AvFILLp(av))
-#endif
+# define av_top_index_skip_len_mg(av) \
+ (__ASSERT_(SvTYPE(av) == SVt_PVAV) AvFILLp(av))
+# define av_tindex_skip_len_mg(av) av_top_index_skip_len_mg(av)
#define NEGATIVE_INDICES_VAR "NEGATIVE_INDICES"
* 37f6186253da9824bdb27f4ad867bfe8c25d4dc6bdb2f05585e40a034675a348 lib/unicore/extracted/DLineBreak.txt
* ef24061b5a5dc93d7e90c2e34530ec757180ee75d872cba65ffc946e52624ae8 lib/unicore/extracted/DNumType.txt
* a197371fec9a1b517058b440841f60f9378d81682084eef8db22a88cb2f96e90 lib/unicore/extracted/DNumValues.txt
- * 4bcfb4545be21663ca38a2acbfcbf2b0f3252652a34b50f1a56ef76cb959861b lib/unicore/mktables
+ * 79a7216aceb1d291f2857085545fdda289518bc540a09bc0a15cde105d76028d lib/unicore/mktables
* cdecb300baad839a6f62791229f551a4fa33f3cbdca08e378dc976466354e778 lib/unicore/version
* 913d2f93f3cb6cdf1664db888bf840bc4eb074eef824e082fceda24a9445e60c regen/charset_translations.pl
* 9534d0cc3914fa1f5d574332c3199605c3d14f8691a0729d68d8498ac2b36280 regen/mk_invlists.pl
# vim: ts=4 sts=4 sw=4:
use strict;
package CPAN;
-$CPAN::VERSION = '2.16';
+$CPAN::VERSION = '2.17';
$CPAN::VERSION =~ s/_//;
# we need to run chdir all over and we would get at wrong libraries
use File::Path ();
@CPAN::Distribution::ISA = qw(CPAN::InfoObj);
use vars qw($VERSION);
-$VERSION = "2.16";
+$VERSION = "2.17";
# no prepare, because prepare is not a command on the shell command line
# TODO: clear instance cache on reload
? $ENV{PERL5LIB}
: ($ENV{PERLLIB} || "");
local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
+ # local $ENV{PERL_USE_UNSAFE_INC} = exists $ENV{PERL_USE_UNSAFE_INC} ? $ENV{PERL_USE_UNSAFE_INC} : 1; # get
$CPAN::META->set_perl5lib;
local $ENV{MAKEFLAGS}; # protect us from outer make calls
: ($ENV{PERLLIB} || "");
local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
+ # local $ENV{PERL_USE_UNSAFE_INC} = exists $ENV{PERL_USE_UNSAFE_INC} ? $ENV{PERL_USE_UNSAFE_INC} : 1; # look
$CPAN::META->set_perl5lib;
local $ENV{MAKEFLAGS}; # protect us from outer make calls
? $ENV{PERL5LIB}
: ($ENV{PERLLIB} || "");
local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
+ local $ENV{PERL_USE_UNSAFE_INC} = exists $ENV{PERL_USE_UNSAFE_INC} ? $ENV{PERL_USE_UNSAFE_INC} : 1; # prepare
$CPAN::META->set_perl5lib;
local $ENV{MAKEFLAGS}; # protect us from outer make calls
? $ENV{PERL5LIB}
: ($ENV{PERLLIB} || "");
local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
+ local $ENV{PERL_USE_UNSAFE_INC} = exists $ENV{PERL_USE_UNSAFE_INC} ? $ENV{PERL_USE_UNSAFE_INC} : 1; # make
$CPAN::META->set_perl5lib;
local $ENV{MAKEFLAGS}; # protect us from outer make calls
: ($ENV{PERLLIB} || "");
local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
+ local $ENV{PERL_USE_UNSAFE_INC} = exists $ENV{PERL_USE_UNSAFE_INC} ? $ENV{PERL_USE_UNSAFE_INC} : 1; # test
$CPAN::META->set_perl5lib;
local $ENV{MAKEFLAGS}; # protect us from outer make calls
local $ENV{PERL_MM_USE_DEFAULT} = 1 if $CPAN::Config->{use_prompt_default};
: ($ENV{PERLLIB} || "");
local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
+ # local $ENV{PERL_USE_UNSAFE_INC} = exists $ENV{PERL_USE_UNSAFE_INC} ? $ENV{PERL_USE_UNSAFE_INC} : 1; # install
$CPAN::META->set_perl5lib;
local $ENV{PERL_MM_USE_DEFAULT} = 1 if $CPAN::Config->{use_prompt_default};
local $ENV{NONINTERACTIVE_TESTING} = 1 if $CPAN::Config->{use_prompt_default};
ok( !tainted($var), 'known variable');
-my $key = (grep { !/^PERL/ } keys %ENV)[0];
+ok( tainted($^X), 'interpreter variable');
-SKIP: { # Skip these to get blead to pass, but the skip expires soon
-skip 'is randomly failing', 2 unless $] gt 5.025009;
-ok( tainted($ENV{$key}), 'environment variable');
-
-$var = $ENV{$key};
-ok( tainted($var), 'copy of environment variable');
-}
+$var = $^X;
+ok( tainted($var), 'copy of interpreter variable');
{
package Tainted;
+5.20170220
+ - Updated for v5.25.10
+
5.20170120
- Updated for v5.25.9
use vars qw/$VERSION %released %version %families %upstream
%bug_tracker %deprecated %delta/;
use version;
-$VERSION = '5.20170120';
+$VERSION = '5.20170220';
sub _undelta {
my ($delta) = @_;
5.022003 => '2017-01-14',
5.024001 => '2017-01-14',
5.025009 => '2017-01-20',
+ 5.025010 => '2017-02-20',
);
for my $version ( sort { $a <=> $b } keys %released ) {
removed => {
}
},
+ 5.025010 => {
+ delta_from => 5.025009,
+ changed => {
+ 'B' => '1.68',
+ 'B::Op_private' => '5.025010',
+ 'CPAN' => '2.17',
+ 'CPAN::Distribution' => '2.17',
+ 'Config' => '5.02501',
+ 'Getopt::Std' => '1.12',
+ 'Module::CoreList' => '5.20170220',
+ 'Module::CoreList::TieHashDelta'=> '5.20170220',
+ 'Module::CoreList::Utils'=> '5.20170220',
+ 'PerlIO' => '1.10',
+ 'Storable' => '2.62',
+ 'Thread::Queue' => '3.12',
+ 'feature' => '1.47',
+ 'open' => '1.11',
+ 'threads' => '2.13',
+ },
+ removed => {
+ }
+ },
);
sub is_core
removed => {
}
},
+ 5.025010 => {
+ delta_from => 5.025009,
+ changed => {
+ },
+ removed => {
+ }
+ },
);
%deprecated = _undelta(\%deprecated);
use strict;
use vars qw($VERSION);
-$VERSION = '5.20170120';
+$VERSION = '5.20170220';
sub TIEHASH {
my ($class, $changed, $removed, $parent) = @_;
use vars qw[$VERSION %utilities];
use Module::CoreList;
-$VERSION = '5.20170120';
+$VERSION = '5.20170220';
sub utilities {
my $perl = shift;
'pstruct' => 1,
}
},
+ 5.025010 => {
+ delta_from => 5.025009,
+ changed => {
+ },
+ removed => {
+ }
+ },
);
%utilities = Module::CoreList::_undelta(\%delta);
use Test::More tests => 2;
BEGIN {use_ok('Net::Ping')};
-my $result = pingecho("127.0.0.1");
-is($result, 1, "pingecho works");
+TODO: {
+ local $TODO = "Not working on os390 smoker; may be a prermissions problem"
+ if $^O eq 'os390';
+ my $result = pingecho("127.0.0.1");
+ is($result, 1, "pingecho works");
+}
use vars qw($canonical $forgive_me $VERSION);
-$VERSION = '2.61';
+$VERSION = '2.62';
BEGIN {
if (eval {
*/
static SV *retrieve_blessed(pTHX_ stcxt_t *cxt, const char *cname)
{
- I32 len;
+ U32 len;
SV *sv;
char buf[LG_BLESS + 1]; /* Avoid malloc() if possible */
char *classname = buf;
if (len & 0x80) {
RLEN(len);
TRACEME(("** allocating %d bytes for class name", len+1));
+ if (len > I32_MAX) {
+ CROAK(("Corrupted classname length"));
+ }
New(10003, classname, len+1, char);
malloced_classname = classname;
}
*/
static SV *retrieve_hook(pTHX_ stcxt_t *cxt, const char *cname)
{
- I32 len;
+ U32 len;
char buf[LG_BLESS + 1]; /* Avoid malloc() if possible */
char *classname = buf;
unsigned int flags;
else
GETMARK(len);
+ if (len > I32_MAX) {
+ CROAK(("Corrupted classname length"));
+ }
+
if (len > LG_BLESS) {
TRACEME(("** allocating %d bytes for class name", len+1));
New(10003, classname, len+1, char);
TRACEME(("class name: %s", classname));
+ if (!(flags & SHF_IDX_CLASSNAME) && classname != buf) {
+ /* some execution paths can throw an exception */
+ SAVEFREEPV(classname);
+ }
+
/*
* Decode user-frozen string length and read it in an SV.
*
SEEN0_NN(sv, 0);
SvRV_set(attached, NULL);
SvREFCNT_dec(attached);
- if (!(flags & SHF_IDX_CLASSNAME) && classname != buf)
- Safefree(classname);
return sv;
}
CROAK(("STORABLE_attach did not return a %s object", classname));
SvREFCNT_dec(frozen);
av_undef(av);
sv_free((SV *) av);
- if (!(flags & SHF_IDX_CLASSNAME) && classname != buf)
- Safefree(classname);
/*
* If we had an <extra> type, then the object was not as simple, and
use Storable qw(store retrieve store_fd nstore_fd fd_retrieve);
-use Test::More tests => 24;
+use Test::More tests => 25;
$a = 'toto';
$b = \$a;
}
}
+{
+
+ my $frozen =
+ "\x70\x73\x74\x30\x04\x0a\x08\x31\x32\x33\x34\x35\x36\x37\x38\x04\x08\x08\x08\x03\xff\x00\x00\x00\x19\x08\xff\x00\x00\x00\x08\x08\xf9\x16\x16\x13\x16\x10\x10\x10\xff\x15\x16\x16\x16\x1e\x16\x16\x16\x16\x16\x16\x16\x16\x16\x16\x13\xf0\x16\x16\x16\xfe\x16\x41\x41\x41\x41\xe8\x03\x41\x41\x41\x41\x41\x41\x41\x41\x51\x41\xa9\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xb8\xac\xac\xac\xac\xac\xac\xac\xac\x9a\xac\xac\xac\xac\xac\xac\xac\xac\xac\x93\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\x00\x64\xac\xa8\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\x2c\xac\x41\x41\x41\x41\x41\x41\x41\x41\x41\x00\x80\x41\x80\x41\x41\x41\x41\x41\x41\x51\x41\xac\xac\xac";
+ open my $fh, '<', \$frozen;
+ eval { Storable::fd_retrieve($fh); };
+ pass('RT 130635: no stack smashing error when retrieving hook');
+
+}
+
close OUT or die "Could not close: $!";
END { 1 while unlink 'store' }
use strict;
use warnings;
-our $VERSION = '3.11';
+our $VERSION = '3.12';
$VERSION = eval $VERSION;
use threads::shared 1.21;
lock(%$self);
# No more data is coming
$$self{'ENDED'} = 1;
- # Try to release at least one blocked thread
- cond_signal(%$self);
+
+ cond_signal(%$self); # Unblock possibly waiting threads
}
# Return 1 or more items from the head of a queue, blocking if needed
# Wait for requisite number of items
cond_wait(%$self) while ((@$queue < $count) && ! $$self{'ENDED'});
- cond_signal(%$self) if ((@$queue >= $count) || $$self{'ENDED'});
# If no longer blocking, try getting whatever is left on the queue
return $self->dequeue_nb($count) if ($$self{'ENDED'});
# Return single item
- return shift(@$queue) if ($count == 1);
+ if ($count == 1) {
+ my $item = shift(@$queue);
+ cond_signal(%$self); # Unblock possibly waiting threads
+ return $item;
+ }
# Return multiple items
my @items;
push(@items, shift(@$queue)) for (1..$count);
+ cond_signal(%$self); # Unblock possibly waiting threads
return @items;
}
my $count = @_ ? $self->_validate_count(shift) : 1;
# Return single item
- return shift(@$queue) if ($count == 1);
+ if ($count == 1) {
+ my $item = shift(@$queue);
+ cond_signal(%$self); # Unblock possibly waiting threads
+ return $item;
+ }
# Return multiple items
my @items;
last if (! @$queue);
push(@items, shift(@$queue));
}
+ cond_signal(%$self); # Unblock possibly waiting threads
return @items;
}
while ((@$queue < $count) && ! $$self{'ENDED'}) {
last if (! cond_timedwait(%$self, $timeout));
}
- cond_signal(%$self) if ((@$queue >= $count) || $$self{'ENDED'});
# Get whatever we need off the queue if available
return $self->dequeue_nb($count);
# Add previous items back onto the queue
push(@$queue, @tmp);
- # Soup's up
- cond_signal(%$self);
+ cond_signal(%$self); # Unblock possibly waiting threads
}
# Remove items from anywhere in a queue
$index += @$queue;
if ($index < 0) {
$count += $index;
- return if ($count <= 0); # Beyond the head of the queue
+ return if ($count <= 0); # Beyond the head of the queue
return $self->dequeue_nb($count); # Extract from the head
}
}
# Add back any removed items
push(@$queue, @tmp);
+ cond_signal(%$self); # Unblock possibly waiting threads
+
# Return single item
return $items[0] if ($count == 1);
if (! defined($count) ||
! looks_like_number($count) ||
(int($count) != $count) ||
- ($count < 1))
+ ($count < 1) ||
+ ($$self{'LIMIT'} && $count > $$self{'LIMIT'}))
{
require Carp;
my ($method) = (caller(1))[3];
my $class_name = ref($self);
$method =~ s/$class_name\:://;
$count = 'undef' if (! defined($count));
- Carp::croak("Invalid 'count' argument ($count) to '$method' method");
+ if ($$self{'LIMIT'} && $count > $$self{'LIMIT'}) {
+ Carp::croak("'count' argument ($count) to '$method' method exceeds queue size limit ($$self{'LIMIT'})");
+ } else {
+ Carp::croak("Invalid 'count' argument ($count) to '$method' method");
+ }
}
return $count;
=head1 VERSION
-This document describes Thread::Queue version 3.11
+This document describes Thread::Queue version 3.12
=head1 SYNOPSIS
# 'undef')
$q->limit = 0; # Queue size is now unlimited
+Calling any of the dequeue methods with C<COUNT> greater than a queue's
+C<limit> will generate an error.
+
=item ->end()
Declares that no more items will be added to the queue.
use Thread::Queue;
if ($] == 5.008) {
- require './t/test.pl'; # Test::More work-alike for Perl 5.8.0
+ require 't/test.pl'; # Test::More work-alike for Perl 5.8.0
} else {
require Test::More;
}
use Thread::Queue;
if ($] == 5.008) {
- require './t/test.pl'; # Test::More work-alike for Perl 5.8.0
+ require 't/test.pl'; # Test::More work-alike for Perl 5.8.0
} else {
require Test::More;
}
use Thread::Queue;
if ($] == 5.008) {
- require './t/test.pl'; # Test::More work-alike for Perl 5.8.0
+ require 't/test.pl'; # Test::More work-alike for Perl 5.8.0
} else {
require Test::More;
}
use Thread::Queue;
if ($] == 5.008) {
- require './t/test.pl'; # Test::More work-alike for Perl 5.8.0
+ require 't/test.pl'; # Test::More work-alike for Perl 5.8.0
} else {
require Test::More;
}
use Thread::Queue;
if ($] == 5.008) {
- require './t/test.pl'; # Test::More work-alike for Perl 5.8.0
+ require 't/test.pl'; # Test::More work-alike for Perl 5.8.0
} else {
require Test::More;
}
use Thread::Semaphore;
if ($] == 5.008) {
- require './t/test.pl'; # Test::More work-alike for Perl 5.8.0
+ require 't/test.pl'; # Test::More work-alike for Perl 5.8.0
} else {
require Test::More;
}
use Thread::Queue;
if ($] == 5.008) {
- require './t/test.pl'; # Test::More work-alike for Perl 5.8.0
+ require 't/test.pl'; # Test::More work-alike for Perl 5.8.0
} else {
require Test::More;
}
use Test::More;
-plan tests => 8;
+plan tests => 13;
my $q = Thread::Queue->new();
my $rpt = Thread::Queue->new();
# q = (4, 5, 'foo'); r = (4, 3, 4, 3)
# Read all items from queue
-my @item = $q->dequeue(3);
-is_deeply(\@item, [4, 5, 'foo'], 'Dequeued 3 items');
+my @items = $q->dequeue(3);
+is_deeply(\@items, [4, 5, 'foo'], 'Dequeued 3 items');
# Thread is now unblocked
-@item = $q->dequeue(2);
-is_deeply(\@item, [6, 7], 'Dequeued 2 items');
+@items = $q->dequeue(2);
+is_deeply(\@items, [6, 7], 'Dequeued 2 items');
# Thread is now unblocked
# Handshake with thread
# (7) - Done
$th->join;
+# It's an error to call dequeue methods with COUNT > LIMIT
+eval { $q->dequeue(5); };
+like($@, qr/exceeds queue size limit/, $@);
+
+# Bug #120157
+# Fix deadlock from combination of dequeue_nb, enqueue and queue size limit
+
+# (1) Fill queue
+$q->enqueue(1..3);
+is($q->pending, 3, 'Queue loaded');
+
+# (2) Thread will block trying to add to full queue
+$th = threads->create( sub {
+ $q->enqueue(99);
+ return('OK');
+});
+threads->yield();
+
+# (3) Dequeue an item so that thread can unblock
+is($q->dequeue_nb(), 1, 'Dequeued item');
+
+# (4) Thread unblocks
+is($th->join(), 'OK', 'Thread exited');
+
+# (5) Fetch queue to show thread's item was enqueued
+@items = ();
+while (my $item = $q->dequeue_nb()) {
+ push(@items, $item);
+}
+is_deeply(\@items, [2,3,99], 'Dequeued remaining');
+
exit(0);
# EOF
use strict;
use warnings;
-our $VERSION = '2.12';
+our $VERSION = '2.13';
my $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
#endif
}
#if defined(__clang__) || defined(__clang)
-CLANG_DIAG_RESTORE;
+CLANG_DIAG_RESTORE
#endif
#endif /* USE_ITHREADS */
#if defined(HAS_FCNTL) && defined(F_SETFD)
/* The dup trick has lost close-on-exec on ofd,
* and possibly any other flags, so restore them. */
- fcntl(ofd,F_SETFD, fd_flags);
+ if (fcntl(ofd,F_SETFD, fd_flags) < 0) {
+ if (dupfd >= 0)
+ PerlLIO_close(dupfd);
+ goto say_false;
+ }
#endif
PerlLIO_close(dupfd);
}
/* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat
* too so it will actually look into the files for magic numbers
*/
- return (mode & statbufp->st_mode) ? TRUE : FALSE;
+ return cBOOL(mode & statbufp->st_mode);
#else /* ! DOSISH */
# ifdef __CYGWIN__
dc = SvPVX(sv); /* sv_usepvn() calls Renew() */
}
if (left_utf || right_utf) {
- UV duc, luc, ruc;
char *dcorig = dc;
char *dcsave = NULL;
STRLEN lulen = leftlen;
STRLEN rulen = rightlen;
- STRLEN ulen;
switch (optype) {
case OP_BIT_AND:
while (lulen && rulen) {
+ UV duc, luc, ruc;
+ STRLEN ulen;
luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
lc += ulen;
lulen -= ulen;
break;
case OP_BIT_XOR:
while (lulen && rulen) {
+ UV duc, luc, ruc;
+ STRLEN ulen;
luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
lc += ulen;
lulen -= ulen;
goto mop_up_utf;
case OP_BIT_OR:
while (lulen && rulen) {
+ UV duc, luc, ruc;
+ STRLEN ulen;
luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
lc += ulen;
lulen -= ulen;
clearer[i++] = result;
clearer[i++] = '\0';
- Perl_ck_warner_d(aTHX_ packWARN2(WARN_SYNTAX,WARN_DEPRECATED),
- "\"\\c%c\" is more clearly written simply as \"%s\". "
- "This will be a fatal error in Perl 5.28",
- source, clearer);
+ Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "\"\\c%c\" is more clearly written simply as \"%s\"",
+ source,
+ clearer);
}
return result;
chsize = 1;
break;
default:
- if ( (flags & PERL_PV_ESCAPE_DWIM) && c != '\0' ) {
+ if ( (flags & PERL_PV_ESCAPE_DWIM) && c != '\0' ) {
chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
isuni ? "%cx{%02" UVxf "}" : "%cx%02" UVxf,
esc, u);
- }
- else if ( (pv+readsize < end) && isDIGIT((U8)*(pv+readsize)) )
- chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
+ }
+ else if ((pv+readsize < end) && isDIGIT((U8)*(pv+readsize)))
+ chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
"%c%03o", esc, c);
- else
- chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
+ else
+ chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
"%c%o", esc, c);
}
} else {
PerlIO_vprintf(file, pat, *args);
}
+
+/* Like Perl_dump_indent(), but specifically for ops: adds a vertical bar
+ * for each indent level as appropriate.
+ *
+ * bar contains bits indicating which indent columns should have a
+ * vertical bar displayed. Bit 0 is the RH-most column. If there are more
+ * levels than bits in bar, then the first few indents are displayed
+ * without a bar.
+ *
+ * The start of a new op is signalled by passing a value for level which
+ * has been negated and offset by 1 (so that level 0 is passed as -1 and
+ * can thus be distinguished from -0); in this case, emit a suitably
+ * indented blank line, then on the next line, display the op's sequence
+ * number, and make the final indent an '+----'.
+ *
+ * e.g.
+ *
+ * | FOO # level = 1, bar = 0b1
+ * | | # level =-2-1, bar = 0b11
+ * 1234 | +---BAR
+ * | BAZ # level = 2, bar = 0b10
+ */
+
+static void
+S_opdump_indent(pTHX_ const OP *o, I32 level, UV bar, PerlIO *file,
+ const char* pat, ...)
+{
+ va_list args;
+ I32 i;
+ bool newop = (level < 0);
+
+ va_start(args, pat);
+
+ /* start displaying a new op? */
+ if (newop) {
+ UV seq = sequence_num(o);
+
+ level = -level - 1;
+
+ /* output preceding blank line */
+ PerlIO_puts(file, " ");
+ for (i = level-1; i >= 0; i--)
+ PerlIO_puts(file, i == 0 || (bar & (1 << i)) ? "| " : " ");
+ PerlIO_puts(file, "\n");
+
+ /* output sequence number */
+ if (seq)
+ PerlIO_printf(file, "%-4" UVuf " ", seq);
+ else
+ PerlIO_puts(file, "???? ");
+
+ }
+ else
+ PerlIO_printf(file, " ");
+
+ for (i = level-1; i >= 0; i--)
+ PerlIO_puts(file,
+ (i == 0 && newop) ? "+--"
+ : (bar & (1 << i)) ? "| "
+ : " ");
+ PerlIO_vprintf(file, pat, args);
+ va_end(args);
+}
+
+
+/* display a link field (e.g. op_next) in the format
+ * ====> sequence_number [opname 0x123456]
+ */
+
+static void
+S_opdump_link(pTHX_ const OP *o, PerlIO *file)
+{
+ PerlIO_puts(file, " ===> ");
+ if (o)
+ PerlIO_printf(file, "%" UVuf " [%s 0x%" UVxf "]\n",
+ sequence_num(o), OP_NAME(o), PTR2UV(o));
+ else
+ PerlIO_puts(file, "[0x0]\n");
+}
+
/*
=for apidoc dump_all
void
Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
{
- STRLEN len;
- SV * const sv = newSVpvs_flags("", SVs_TEMP);
- SV *tmpsv;
- const char * name;
+ CV *cv;
PERL_ARGS_ASSERT_DUMP_SUB_PERL;
- if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
+ cv = isGV_with_GP(gv) ? GvCV(gv) :
+ (assert(SvROK((SV*)gv)), (CV*)SvRV((SV*)gv));
+ if (justperl && (CvISXSUB(cv) || !CvROOT(cv)))
return;
- tmpsv = newSVpvs_flags("", SVs_TEMP);
- gv_fullname3(sv, gv, NULL);
- name = SvPV_const(sv, len);
- Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ",
- generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
- if (CvISXSUB(GvCV(gv)))
+ if (isGV_with_GP(gv)) {
+ SV * const namesv = newSVpvs_flags("", SVs_TEMP);
+ SV *escsv = newSVpvs_flags("", SVs_TEMP);
+ const char *namepv;
+ STRLEN namelen;
+ gv_fullname3(namesv, gv, NULL);
+ namepv = SvPV_const(namesv, namelen);
+ Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ",
+ generic_pv_escape(escsv, namepv, namelen, SvUTF8(namesv)));
+ } else {
+ Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB = ");
+ }
+ if (CvISXSUB(cv))
Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%" UVxf " %d)\n",
- PTR2UV(CvXSUB(GvCV(gv))),
- (int)CvXSUBANY(GvCV(gv)).any_i32);
- else if (CvROOT(GvCV(gv)))
- op_dump(CvROOT(GvCV(gv)));
+ PTR2UV(CvXSUB(cv)),
+ (int)CvXSUBANY(cv).any_i32);
+ else if (CvROOT(cv))
+ op_dump(CvROOT(cv));
else
Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
}
op_dump(PL_eval_root);
}
-void
-Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
+
+/* returns a temp SV displaying the name of a GV. Handles the case where
+ * a GV is in fact a ref to a CV */
+
+static SV *
+S_gv_display(pTHX_ GV *gv)
{
- char ch;
+ SV * const name = newSVpvs_flags("", SVs_TEMP);
+ if (gv) {
+ SV * const raw = newSVpvs_flags("", SVs_TEMP);
+ STRLEN len;
+ const char * rawpv;
+
+ if (isGV_with_GP(gv))
+ gv_fullname3(raw, gv, NULL);
+ else {
+ assert(SvROK(gv));
+ assert(SvTYPE(SvRV(gv)) == SVt_PVCV);
+ Perl_sv_catpvf(aTHX_ raw, "cv ref: %s",
+ SvPV_nolen_const(cv_name((CV *)SvRV(gv), name, 0)));
+ }
+ rawpv = SvPV_const(raw, len);
+ generic_pv_escape(name, rawpv, len, SvUTF8(raw));
+ }
+ else
+ sv_catpvs(name, "(NULL)");
- PERL_ARGS_ASSERT_DO_PMOP_DUMP;
+ return name;
+}
+
+
+
+/* forward decl */
+static void
+S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o);
+
+
+static void
+S_do_pmop_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const PMOP *pm)
+{
+ UV kidbar;
if (!pm)
return;
- if (pm->op_pmflags & PMf_ONCE)
- ch = '?';
- else
- ch = '/';
- if (PM_GETRE(pm))
- Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%.*s%c\n",
+
+ kidbar = ((bar << 1) | cBOOL(pm->op_flags & OPf_KIDS)) << 1;
+
+ if (PM_GETRE(pm)) {
+ char ch = (pm->op_pmflags & PMf_ONCE) ? '?' : '/';
+ S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE %c%.*s%c\n",
ch,(int)RX_PRELEN(PM_GETRE(pm)), RX_PRECOMP(PM_GETRE(pm)), ch);
+ }
else
- Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
+ S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE (RUNTIME)\n");
+
+ if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
+ SV * const tmpsv = pm_description(pm);
+ S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMFLAGS = (%s)\n",
+ SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
+ SvREFCNT_dec_NN(tmpsv);
+ }
if (pm->op_type == OP_SPLIT)
- Perl_dump_indent(aTHX_ level, file, "TARGOFF/GV = 0x%" UVxf "\n",
- PTR2UV(pm->op_pmreplrootu.op_pmtargetgv));
+ S_opdump_indent(aTHX_ (OP*)pm, level, bar, 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);
+ S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_REPL =\n");
+ S_do_op_dump_bar(aTHX_ level + 2,
+ (kidbar|cBOOL(OpHAS_SIBLING(pm->op_pmreplrootu.op_pmreplroot))),
+ file, pm->op_pmreplrootu.op_pmreplroot);
}
}
if (pm->op_code_list) {
if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
- Perl_dump_indent(aTHX_ level, file, "CODE_LIST =\n");
- do_op_dump(level, file, pm->op_code_list);
+ S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "CODE_LIST =\n");
+ S_do_op_dump_bar(aTHX_ level + 2,
+ (kidbar | cBOOL(OpHAS_SIBLING(pm->op_code_list))),
+ file, pm->op_code_list);
}
else
- Perl_dump_indent(aTHX_ level, file, "CODE_LIST = 0x%" UVxf "\n",
- PTR2UV(pm->op_code_list));
- }
- if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
- SV * const tmpsv = pm_description(pm);
- Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
- SvREFCNT_dec_NN(tmpsv);
+ S_opdump_indent(aTHX_ (OP*)pm, level, bar, file,
+ "CODE_LIST = 0x%" UVxf "\n", PTR2UV(pm->op_code_list));
}
}
+
+void
+Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
+{
+ PERL_ARGS_ASSERT_DO_PMOP_DUMP;
+ S_do_pmop_dump_bar(aTHX_ level, 0, file, pm);
+}
+
+
const struct flag_to_name pmflags_flags_names[] = {
{PMf_CONST, ",CONST"},
{PMf_KEEP, ",KEEP"},
};
-void
-Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
+/* indexed by enum OPclass */
+const char * op_class_names[] = {
+ "NULL",
+ "OP",
+ "UNOP",
+ "BINOP",
+ "LOGOP",
+ "LISTOP",
+ "PMOP",
+ "SVOP",
+ "PADOP",
+ "PVOP",
+ "LOOP",
+ "COP",
+ "METHOP",
+ "UNOP_AUX",
+};
+
+
+/* dump an op and any children. level indicates the initial indent.
+ * The bits of bar indicate which indents should receive a vertical bar.
+ * For example if level == 5 and bar == 0b01101, then the indent prefix
+ * emitted will be (not including the <>'s):
+ *
+ * < | | | >
+ * 55554444333322221111
+ *
+ * For heavily nested output, the level may exceed the number of bits
+ * in bar; in this case the first few columns in the output will simply
+ * not have a bar, which is harmless.
+ */
+
+static void
+S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o)
{
- UV seq;
const OPCODE optype = o->op_type;
PERL_ARGS_ASSERT_DO_OP_DUMP;
- Perl_dump_indent(aTHX_ level, file, "{\n");
- level++;
- seq = sequence_num(o);
- if (seq)
- PerlIO_printf(file, "%-4" UVuf, seq);
- else
- PerlIO_printf(file, "????");
- PerlIO_printf(file,
- "%*sTYPE = %s ===> ",
- (int)(PL_dumpindent*level-4), "", OP_NAME(o));
- if (o->op_next)
- PerlIO_printf(file,
- o->op_type == OP_NULL ? "(%" UVuf ")\n" : "%" UVuf "\n",
- sequence_num(o->op_next));
- else
- PerlIO_printf(file, "NULL\n");
- if (o->op_targ) {
- if (optype == OP_NULL) {
- Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
- }
- else
- Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
- }
-#ifdef DUMPADDR
- Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%" UVxf " => 0x%" UVxf "\n",
- (UV)o, (UV)o->op_next);
-#endif
+ /* print op header line */
+
+ S_opdump_indent(aTHX_ o, -level-1, bar, file, "%s", OP_NAME(o));
+
+ if (optype == OP_NULL && o->op_targ)
+ PerlIO_printf(file, " (ex-%s)",PL_op_name[o->op_targ]);
+
+ PerlIO_printf(file, " %s(0x%" UVxf ")",
+ op_class_names[op_class(o)], PTR2UV(o));
+ S_opdump_link(aTHX_ o->op_next, file);
+
+ /* print op common fields */
+
+ if (o->op_targ && optype != OP_NULL)
+ S_opdump_indent(aTHX_ o, level, bar, file, "TARG = %ld\n",
+ (long)o->op_targ);
if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) {
SV * const tmpsv = newSVpvs("");
if (o->op_static) sv_catpvs(tmpsv, ",STATIC");
if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED");
if (o->op_moresib) sv_catpvs(tmpsv, ",MORESIB");
- Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n",
+ S_opdump_indent(aTHX_ o, level, bar, file, "FLAGS = (%s)\n",
SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
}
}
}
if (tmpsv && SvCUR(tmpsv)) {
- Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
+ S_opdump_indent(aTHX_ o, level, bar, file, "PRIVATE = (%s)\n",
+ SvPVX_const(tmpsv) + 1);
} else
- Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%" UVxf ")\n",
- (UV)oppriv);
+ S_opdump_indent(aTHX_ o, level, bar, file,
+ "PRIVATE = (0x%" UVxf ")\n", (UV)oppriv);
}
switch (optype) {
case OP_GVSV:
case OP_GV:
#ifdef USE_ITHREADS
- Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
+ S_opdump_indent(aTHX_ o, level, bar, file,
+ "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
#else
- if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
- if (cSVOPo->op_sv) {
- STRLEN len;
- const char * name;
- SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
- SV * const tmpsv2 = newSVpvs_flags("", SVs_TEMP);
- gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
- name = SvPV_const(tmpsv, len);
- Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
- generic_pv_escape( tmpsv2, name, len, SvUTF8(tmpsv)));
- }
- else
- Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
- }
+ S_opdump_indent(aTHX_ o, level, bar, file,
+ "GV = %" SVf " (0x%" UVxf ")\n",
+ SVfARG(S_gv_display(aTHX_ cGVOPo_gv)), PTR2UV(cGVOPo_gv));
#endif
break;
UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
UV i, count = items[-1].uv;
- Perl_dump_indent(aTHX_ level, file, "ARGS = \n");
+ S_opdump_indent(aTHX_ o, level, bar, file, "ARGS = \n");
for (i=0; i < count; i++)
- Perl_dump_indent(aTHX_ level+1, file, "%" UVuf " => 0x%" UVxf "\n",
+ S_opdump_indent(aTHX_ o, level+1, (bar << 1), file,
+ "%" UVuf " => 0x%" UVxf "\n",
i, items[i].uv);
break;
}
#ifndef USE_ITHREADS
/* with ITHREADS, consts are stored in the pad, and the right pad
* may not be active here, so skip */
- Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cMETHOPx_meth(o)));
+ S_opdump_indent(aTHX_ o, level, bar, file, "SV = %s\n",
+ SvPEEK(cMETHOPx_meth(o)));
#endif
break;
case OP_NULL:
case OP_NEXTSTATE:
case OP_DBSTATE:
if (CopLINE(cCOPo))
- Perl_dump_indent(aTHX_ level, file, "LINE = %" UVuf "\n",
+ S_opdump_indent(aTHX_ o, level, bar, file, "LINE = %" UVuf "\n",
(UV)CopLINE(cCOPo));
- if (CopSTASHPV(cCOPo)) {
- SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
- HV *stash = CopSTASH(cCOPo);
- const char * const hvname = HvNAME_get(stash);
-
- Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
- generic_pv_escape(tmpsv, hvname,
- HvNAMELEN(stash), HvNAMEUTF8(stash)));
- }
- if (CopLABEL(cCOPo)) {
- SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
- STRLEN label_len;
- U32 label_flags;
- const char *label = CopLABEL_len_flags(cCOPo,
- &label_len, &label_flags);
- Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
- generic_pv_escape( tmpsv, label, label_len,
- (label_flags & SVf_UTF8)));
- }
- Perl_dump_indent(aTHX_ level, file, "SEQ = %u\n",
+
+ if (CopSTASHPV(cCOPo)) {
+ SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
+ HV *stash = CopSTASH(cCOPo);
+ const char * const hvname = HvNAME_get(stash);
+
+ S_opdump_indent(aTHX_ o, level, bar, file, "PACKAGE = \"%s\"\n",
+ generic_pv_escape(tmpsv, hvname,
+ HvNAMELEN(stash), HvNAMEUTF8(stash)));
+ }
+
+ if (CopLABEL(cCOPo)) {
+ SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
+ STRLEN label_len;
+ U32 label_flags;
+ const char *label = CopLABEL_len_flags(cCOPo,
+ &label_len, &label_flags);
+ S_opdump_indent(aTHX_ o, level, bar, file, "LABEL = \"%s\"\n",
+ generic_pv_escape( tmpsv, label, label_len,
+ (label_flags & SVf_UTF8)));
+ }
+
+ S_opdump_indent(aTHX_ o, level, bar, file, "SEQ = %u\n",
(unsigned int)cCOPo->cop_seq);
break;
+
+ case OP_ENTERITER:
case OP_ENTERLOOP:
- Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
- if (cLOOPo->op_redoop)
- PerlIO_printf(file, "%" UVuf "\n", sequence_num(cLOOPo->op_redoop));
- else
- PerlIO_printf(file, "DONE\n");
- Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
- if (cLOOPo->op_nextop)
- PerlIO_printf(file, "%" UVuf "\n", sequence_num(cLOOPo->op_nextop));
- else
- PerlIO_printf(file, "DONE\n");
- Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
- if (cLOOPo->op_lastop)
- PerlIO_printf(file, "%" UVuf "\n", sequence_num(cLOOPo->op_lastop));
- else
- PerlIO_printf(file, "DONE\n");
+ S_opdump_indent(aTHX_ o, level, bar, file, "REDO");
+ S_opdump_link(aTHX_ cLOOPo->op_redoop, file);
+ S_opdump_indent(aTHX_ o, level, bar, file, "NEXT");
+ S_opdump_link(aTHX_ cLOOPo->op_nextop, file);
+ S_opdump_indent(aTHX_ o, level, bar, file, "LAST");
+ S_opdump_link(aTHX_ cLOOPo->op_lastop, file);
break;
+
+ case OP_REGCOMP:
+ case OP_SUBSTCONT:
case OP_COND_EXPR:
case OP_RANGE:
case OP_MAPWHILE:
case OP_GREPWHILE:
case OP_OR:
+ case OP_DOR:
case OP_AND:
- Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
- if (cLOGOPo->op_other)
- PerlIO_printf(file, "%" UVuf "\n", sequence_num(cLOGOPo->op_other));
- else
- PerlIO_printf(file, "DONE\n");
+ case OP_ORASSIGN:
+ case OP_DORASSIGN:
+ case OP_ANDASSIGN:
+ case OP_ARGDEFELEM:
+ case OP_ENTERGIVEN:
+ case OP_ENTERWHEN:
+ case OP_ENTERTRY:
+ case OP_ONCE:
+ S_opdump_indent(aTHX_ o, level, bar, file, "OTHER");
+ S_opdump_link(aTHX_ cLOGOPo->op_other, file);
break;
case OP_SPLIT:
case OP_MATCH:
case OP_QR:
case OP_SUBST:
- do_pmop_dump(level, file, cPMOPo);
+ S_do_pmop_dump_bar(aTHX_ level, bar, file, cPMOPo);
break;
case OP_LEAVE:
case OP_LEAVEEVAL:
case OP_LEAVEWRITE:
case OP_SCOPE:
if (o->op_private & OPpREFCOUNTED)
- Perl_dump_indent(aTHX_ level, file, "REFCNT = %" UVuf "\n", (UV)o->op_targ);
+ S_opdump_indent(aTHX_ o, level, bar, file,
+ "REFCNT = %" UVuf "\n", (UV)o->op_targ);
break;
+
+ case OP_DUMP:
+ case OP_GOTO:
+ case OP_NEXT:
+ case OP_LAST:
+ case OP_REDO:
+ if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
+ break;
+ /* FALLTHROUGH */
+ case OP_TRANS:
+ case OP_TRANSR:
+ if ( (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
+ && (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)))
+ break;
+
+ {
+ SV * const label = newSVpvs_flags("", SVs_TEMP);
+ generic_pv_escape(label, cPVOPo->op_pv, strlen(cPVOPo->op_pv), 0);
+ S_opdump_indent(aTHX_ o, level, bar, file,
+ "PV = \"%" SVf "\" (0x%" UVxf ")\n",
+ SVfARG(label), PTR2UV(cPVOPo->op_pv));
+ }
+
+
default:
break;
}
if (o->op_flags & OPf_KIDS) {
OP *kid;
+ level++;
+ bar <<= 1;
for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
- do_op_dump(level, file, kid);
+ S_do_op_dump_bar(aTHX_ level,
+ (bar | cBOOL(OpHAS_SIBLING(kid))),
+ file, kid);
}
- Perl_dump_indent(aTHX_ level-1, file, "}\n");
}
+
+void
+Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
+{
+ S_do_op_dump_bar(aTHX_ level, 0, file, o);
+}
+
+
/*
=for apidoc op_dump
const char *hvname;
HV * const stash = GvSTASH(sv);
PerlIO_printf(file, "\t");
- /* TODO might have an extra \" here */
+ /* TODO might have an extra \" here */
if (stash && (hvname = HvNAME_get(stash))) {
PerlIO_printf(file, "\"%s\" :: \"",
generic_pv_escape(tmp, hvname,
(UV)aux->xhv_aux_flags);
}
Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf, PTR2UV(HvARRAY(sv)));
- usedkeys = HvUSEDKEYS(sv);
+ usedkeys = HvUSEDKEYS(MUTABLE_HV(sv));
if (HvARRAY(sv) && usedkeys) {
/* Show distribution of HEs in the ARRAY */
int freq[200];
{
const char * const hvname = HvNAME_get(sv);
if (hvname) {
- SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
- Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
+ SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
+ Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
generic_pv_escape( tmpsv, hvname,
HvNAMELEN(sv), HvNAMEUTF8(sv)));
}
+ (count < 0 ? -count : count);
while (hekp < endp) {
if (*hekp) {
- SV *tmp = newSVpvs_flags("", SVs_TEMP);
+ SV *tmp = newSVpvs_flags("", SVs_TEMP);
Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
} else {
case SVt_PVCV:
if (CvAUTOLOAD(sv)) {
SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
- STRLEN len;
+ STRLEN len;
const char *const name = SvPV_const(sv, len);
Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
}
if (SvPOK(sv)) {
- SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
- const char *const proto = CvPROTO(sv);
+ SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
+ const char *const proto = CvPROTO(sv);
Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
SvUTF8(sv)));
if (isREGEXP(sv)) goto dumpregexp;
if (!isGV_with_GP(sv))
break;
- {
- SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
- Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
- generic_pv_escape(tmpsv, GvNAME(sv),
- GvNAMELEN(sv),
- GvNAMEUTF8(sv)));
- }
+ {
+ SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
+ Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
+ generic_pv_escape(tmpsv, GvNAME(sv),
+ GvNAMELEN(sv),
+ GvNAMEUTF8(sv)));
+ }
Perl_dump_indent(aTHX_ level, file, " NAMELEN = %" IVdf "\n", (IV)GvNAMELEN(sv));
do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)GvFLAGS(sv));
void
Perl_sv_dump(pTHX_ SV *sv)
{
- PERL_ARGS_ASSERT_SV_DUMP;
-
- if (SvROK(sv))
+ if (sv && SvROK(sv))
do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
else
do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
break;
case OP_GVSV:
case OP_GV:
- if (cGVOPo_gv && isGV(cGVOPo_gv)) {
- SV * const sv = newSV(0);
- gv_fullname3(sv, cGVOPo_gv, NULL);
- PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
- SvREFCNT_dec_NN(sv);
- }
- else if (cGVOPo_gv) {
- SV * const sv = newSV(0);
- assert(SvROK(cGVOPo_gv));
- assert(SvTYPE(SvRV(cGVOPo_gv)) == SVt_PVCV);
- PerlIO_printf(Perl_debug_log, "(cv ref: %s)",
- SvPV_nolen_const(cv_name((CV *)SvRV(cGVOPo_gv),sv,0)));
- SvREFCNT_dec_NN(sv);
- }
- else
- PerlIO_printf(Perl_debug_log, "(NULL)");
+ PerlIO_printf(Perl_debug_log, "(%" SVf ")",
+ SVfARG(S_gv_display(aTHX_ cGVOPo_gv)));
break;
case OP_PADSV:
return 0;
}
+
+/*
+=for apidoc op_class
+
+Given an op, determine what type of struct it has been allocated as.
+Returns one of the OPclass enums, such as OPclass_LISTOP.
+
+=cut
+*/
+
+
+OPclass
+Perl_op_class(pTHX_ const OP *o)
+{
+ bool custom = 0;
+
+ if (!o)
+ return OPclass_NULL;
+
+ if (o->op_type == 0) {
+ if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
+ return OPclass_COP;
+ return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
+ }
+
+ if (o->op_type == OP_SASSIGN)
+ return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPclass_UNOP : OPclass_BINOP);
+
+ if (o->op_type == OP_AELEMFAST) {
+#ifdef USE_ITHREADS
+ return OPclass_PADOP;
+#else
+ return OPclass_SVOP;
+#endif
+ }
+
+#ifdef USE_ITHREADS
+ if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
+ o->op_type == OP_RCATLINE)
+ return OPclass_PADOP;
+#endif
+
+ if (o->op_type == OP_CUSTOM)
+ custom = 1;
+
+ switch (OP_CLASS(o)) {
+ case OA_BASEOP:
+ return OPclass_BASEOP;
+
+ case OA_UNOP:
+ return OPclass_UNOP;
+
+ case OA_BINOP:
+ return OPclass_BINOP;
+
+ case OA_LOGOP:
+ return OPclass_LOGOP;
+
+ case OA_LISTOP:
+ return OPclass_LISTOP;
+
+ case OA_PMOP:
+ return OPclass_PMOP;
+
+ case OA_SVOP:
+ return OPclass_SVOP;
+
+ case OA_PADOP:
+ return OPclass_PADOP;
+
+ case OA_PVOP_OR_SVOP:
+ /*
+ * Character translations (tr///) are usually a PVOP, keeping a
+ * pointer to a table of shorts used to look up translations.
+ * Under utf8, however, a simple table isn't practical; instead,
+ * the OP is an SVOP (or, under threads, a PADOP),
+ * and the SV is a reference to a swash
+ * (i.e., an RV pointing to an HV).
+ */
+ return (!custom &&
+ (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
+ )
+#if defined(USE_ITHREADS)
+ ? OPclass_PADOP : OPclass_PVOP;
+#else
+ ? OPclass_SVOP : OPclass_PVOP;
+#endif
+
+ case OA_LOOP:
+ return OPclass_LOOP;
+
+ case OA_COP:
+ return OPclass_COP;
+
+ case OA_BASEOP_OR_UNOP:
+ /*
+ * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
+ * whether parens were seen. perly.y uses OPf_SPECIAL to
+ * signal whether a BASEOP had empty parens or none.
+ * Some other UNOPs are created later, though, so the best
+ * test is OPf_KIDS, which is set in newUNOP.
+ */
+ return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
+
+ case OA_FILESTATOP:
+ /*
+ * The file stat OPs are created via UNI(OP_foo) in toke.c but use
+ * the OPf_REF flag to distinguish between OP types instead of the
+ * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
+ * return OPclass_UNOP so that walkoptree can find our children. If
+ * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
+ * (no argument to the operator) it's an OP; with OPf_REF set it's
+ * an SVOP (and op_sv is the GV for the filehandle argument).
+ */
+ return ((o->op_flags & OPf_KIDS) ? OPclass_UNOP :
+#ifdef USE_ITHREADS
+ (o->op_flags & OPf_REF) ? OPclass_PADOP : OPclass_BASEOP);
+#else
+ (o->op_flags & OPf_REF) ? OPclass_SVOP : OPclass_BASEOP);
+#endif
+ case OA_LOOPEXOP:
+ /*
+ * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
+ * label was omitted (in which case it's a BASEOP) or else a term was
+ * seen. In this last case, all except goto are definitely PVOP but
+ * goto is either a PVOP (with an ordinary constant label), an UNOP
+ * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
+ * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
+ * get set.
+ */
+ if (o->op_flags & OPf_STACKED)
+ return OPclass_UNOP;
+ else if (o->op_flags & OPf_SPECIAL)
+ return OPclass_BASEOP;
+ else
+ return OPclass_PVOP;
+ case OA_METHOP:
+ return OPclass_METHOP;
+ case OA_UNOP_AUX:
+ return OPclass_UNOP_AUX;
+ }
+ Perl_warn(aTHX_ "Can't determine class of operator %s, assuming BASEOP\n",
+ OP_NAME(o));
+ return OPclass_BASEOP;
+}
+
+
+
STATIC CV*
S_deb_curcv(pTHX_ I32 ix)
{
Ap |void |dump_eval
Ap |void |dump_form |NN const GV* gv
Ap |void |gv_dump |NULLOK GV* gv
+Apd |OPclass|op_class |NULLOK const OP *o
Ap |void |op_dump |NN const OP *o
Ap |void |pmop_dump |NULLOK PMOP* pm
Ap |void |dump_packsubs |NN const HV* stash
Amd |void |hv_undef |NULLOK HV *hv
poX |void |hv_undef_flags |NULLOK HV *hv|U32 flags
AmP |I32 |ibcmp |NN const char* a|NN const char* b|I32 len
-AnpP |I32 |foldEQ |NN const char* a|NN const char* b|I32 len
+Ainp |I32 |foldEQ |NN const char* a|NN const char* b|I32 len
AmP |I32 |ibcmp_locale |NN const char* a|NN const char* b|I32 len
-AnpP |I32 |foldEQ_locale |NN const char* a|NN const char* b|I32 len
+Ainp |I32 |foldEQ_locale |NN const char* a|NN const char* b|I32 len
Am |I32 |ibcmp_utf8 |NN const char *s1|NULLOK char **pe1|UV l1 \
|bool u1|NN const char *s2|NULLOK char **pe2 \
|UV l2|bool u2
AMp |I32 |foldEQ_utf8_flags |NN const char *s1|NULLOK char **pe1|UV l1 \
|bool u1|NN const char *s2|NULLOK char **pe2 \
|UV l2|bool u2|U32 flags
-AnpP |I32 |foldEQ_latin1 |NN const char* a|NN const char* b|I32 len
+Ainp |I32 |foldEQ_latin1 |NN const char* a|NN const char* b|I32 len
#if defined(PERL_IN_DOIO_C)
sR |bool |ingroup |Gid_t testgid|bool effective
#endif
s |void |inplace_aassign |NN OP* o
#endif
Ap |void |leave_scope |I32 base
+p |void |notify_parser_that_changed_to_utf8
: Public lexer API
AMpd |void |lex_start |NULLOK SV* line|NULLOK PerlIO *rsfp|U32 flags
AMpd |bool |lex_bufutf8
Apd |int |getcwd_sv |NN SV* sv
Apd |void |sv_dec |NULLOK SV *const sv
Apd |void |sv_dec_nomg |NULLOK SV *const sv
-Ap |void |sv_dump |NN SV* sv
+Ap |void |sv_dump |NULLOK SV* sv
ApdR |bool |sv_derived_from|NN SV* sv|NN const char *const name
ApdR |bool |sv_derived_from_sv|NN SV* sv|NN SV *namesv|U32 flags
ApdR |bool |sv_derived_from_pv|NN SV* sv|NN const char *const name|U32 flags
|const STRLEN len|NN const char *const little \
|const STRLEN littlelen
Apd |void |sv_insert_flags|NN SV *const bigstr|const STRLEN offset|const STRLEN len \
- |NN const char *const little|const STRLEN littlelen|const U32 flags
+ |NN const char *little|const STRLEN littlelen|const U32 flags
Apd |int |sv_isa |NULLOK SV* sv|NN const char *const name
Apd |int |sv_isobject |NULLOK SV* sv
Apd |STRLEN |sv_len |NULLOK SV *const sv
|NN SV **swashp \
|NN const char *normal| \
NULLOK const char *special
+ApM |char * |_byte_dump_string \
+ |NN const U8 * s \
+ |const STRLEN len \
+ |const bool format
#if defined(PERL_IN_UTF8_C)
inR |bool |does_utf8_overflow|NN const U8 * const s|NN const U8 * e
inR |bool |is_utf8_overlong_given_start_byte_ok|NN const U8 * const s|const STRLEN len
|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 |void |warn_on_first_deprecated_use \
|NN const char * const name \
|NN const char * const alternative \
ApdD |UV |utf8_to_uvchr |NN const U8 *s|NULLOK STRLEN *retlen
ApdD |UV |utf8_to_uvuni |NN const U8 *s|NULLOK STRLEN *retlen
ApMD |UV |valid_utf8_to_uvuni |NN const U8 *s|NULLOK STRLEN *retlen
-Amd |UV |utf8_to_uvchr_buf |NN const U8 *s|NN const U8 *send|NULLOK STRLEN *retlen
+Aopd |UV |utf8_to_uvchr_buf |NN const U8 *s|NN const U8 *send|NULLOK STRLEN *retlen
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
p |void |write_to_stderr|NN SV* msv
: Used in op.c
p |int |yyerror |NN const char *const s
+p |void |yyquit
+p |void |abort_execution|NN const char * const msg|NN const char * const name
p |int |yyerror_pv |NN const char *const s|U32 flags
-p |int |yyerror_pvn |NN const char *const s|STRLEN len|U32 flags
+p |int |yyerror_pvn |NULLOK const char *const s|STRLEN len|U32 flags
: Used in perly.y, and by Data::Alias
EXp |int |yylex
p |void |yyunlex
|const bool strict \
|const U32 depth
Es |void |reginsert |NN RExC_state_t *pRExC_state \
- |U8 op|NN regnode *opnd|U32 depth
+ |U8 op|NN regnode *operand|U32 depth
Es |void |regtail |NN RExC_state_t * pRExC_state \
|NN const regnode * const p \
|NN const regnode * const val \
|NN const char* const e
sR |char* |scan_formline |NN char *s
sR |char* |scan_heredoc |NN char *s
-s |char* |scan_ident |NN char *s|NN char *dest \
+s |char* |scan_ident |NN char *s|NN char *dest \
|STRLEN destlen|I32 ck_uni
sR |char* |scan_inputsymbol|NN char *start
sR |char* |scan_pat |NN char *start|I32 type
/* Hide global symbols */
#define Gv_AMupdate(a,b) Perl_Gv_AMupdate(aTHX_ a,b)
+#define _byte_dump_string(a,b,c) Perl__byte_dump_string(aTHX_ a,b,c)
#define _force_out_malformed_utf8_message(a,b,c,d) Perl__force_out_malformed_utf8_message(aTHX_ a,b,c,d)
#define _is_in_locale_category(a,b) Perl__is_in_locale_category(aTHX_ a,b)
#define _is_uni_FOO(a,b) Perl__is_uni_FOO(aTHX_ a,b)
#define nothreadhook() Perl_nothreadhook(aTHX)
#define op_append_elem(a,b,c) Perl_op_append_elem(aTHX_ a,b,c)
#define op_append_list(a,b,c) Perl_op_append_list(aTHX_ a,b,c)
+#define op_class(a) Perl_op_class(aTHX_ a)
#define op_contextualize(a,b) Perl_op_contextualize(aTHX_ a,b)
#define op_convert_list(a,b,c) Perl_op_convert_list(aTHX_ a,b,c)
#define op_dump(a) Perl_op_dump(aTHX_ a)
#ifdef PERL_CORE
#define Slab_Alloc(a) Perl_Slab_Alloc(aTHX_ a)
#define Slab_Free(a) Perl_Slab_Free(aTHX_ a)
+#define abort_execution(a,b) Perl_abort_execution(aTHX_ a,b)
#define alloc_LOGOP(a,b,c) Perl_alloc_LOGOP(aTHX_ a,b,c)
#define allocmy(a,b,c) Perl_allocmy(aTHX_ a,b,c)
#define amagic_is_enabled(a) Perl_amagic_is_enabled(aTHX_ a)
#define newXS_len_flags(a,b,c,d,e,f,g) Perl_newXS_len_flags(aTHX_ a,b,c,d,e,f,g)
#define nextargv(a,b) Perl_nextargv(aTHX_ a,b)
#define noperl_die Perl_noperl_die
+#define notify_parser_that_changed_to_utf8() Perl_notify_parser_that_changed_to_utf8(aTHX)
#define oopsAV(a) Perl_oopsAV(aTHX_ a)
#define oopsHV(a) Perl_oopsHV(aTHX_ a)
#define op_unscope(a) Perl_op_unscope(aTHX_ a)
#define yyerror_pv(a,b) Perl_yyerror_pv(aTHX_ a,b)
#define yyerror_pvn(a,b,c) Perl_yyerror_pvn(aTHX_ a,b,c)
#define yyparse(a) Perl_yyparse(aTHX_ a)
+#define yyquit() Perl_yyquit(aTHX)
#define yyunlex() Perl_yyunlex(aTHX)
# if !(defined(DEBUGGING))
# if !defined(NV_PRESERVES_UV)
#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_and_deprecate(a,b,c,d,e,f) S_check_and_deprecate(aTHX_ a,b,c,d,e,f)
#define check_locale_boundary_crossing(a,b,c,d) S_check_locale_boundary_crossing(aTHX_ a,b,c,d)
# walkoptree comes from B.xs
BEGIN {
- $B::VERSION = '1.65';
+ $B::VERSION = '1.68';
@B::EXPORT_OK = ();
# Our BOOT code needs $VERSION set, and will append to @EXPORT_OK.
"B::IO",
};
-typedef enum {
- OPc_NULL, /* 0 */
- OPc_BASEOP, /* 1 */
- OPc_UNOP, /* 2 */
- OPc_BINOP, /* 3 */
- OPc_LOGOP, /* 4 */
- OPc_LISTOP, /* 5 */
- OPc_PMOP, /* 6 */
- OPc_SVOP, /* 7 */
- OPc_PADOP, /* 8 */
- OPc_PVOP, /* 9 */
- OPc_LOOP, /* 10 */
- OPc_COP, /* 11 */
- OPc_METHOP, /* 12 */
- OPc_UNOP_AUX /* 13 */
-} opclass;
static const char* const opclassnames[] = {
"B::NULL",
cxt->x_specialsv_list[6] = (SV *) pWARN_STD;
}
-static opclass
-cc_opclass(pTHX_ const OP *o)
-{
- bool custom = 0;
-
- if (!o)
- return OPc_NULL;
-
- if (o->op_type == 0) {
- if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
- return OPc_COP;
- return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
- }
-
- if (o->op_type == OP_SASSIGN)
- return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
-
- if (o->op_type == OP_AELEMFAST) {
-#ifdef USE_ITHREADS
- return OPc_PADOP;
-#else
- return OPc_SVOP;
-#endif
- }
-
-#ifdef USE_ITHREADS
- if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
- o->op_type == OP_RCATLINE)
- return OPc_PADOP;
-#endif
-
- if (o->op_type == OP_CUSTOM)
- custom = 1;
-
- switch (OP_CLASS(o)) {
- case OA_BASEOP:
- return OPc_BASEOP;
-
- case OA_UNOP:
- return OPc_UNOP;
-
- case OA_BINOP:
- return OPc_BINOP;
-
- case OA_LOGOP:
- return OPc_LOGOP;
-
- case OA_LISTOP:
- return OPc_LISTOP;
-
- case OA_PMOP:
- return OPc_PMOP;
-
- case OA_SVOP:
- return OPc_SVOP;
-
- case OA_PADOP:
- return OPc_PADOP;
-
- case OA_PVOP_OR_SVOP:
- /*
- * Character translations (tr///) are usually a PVOP, keeping a
- * pointer to a table of shorts used to look up translations.
- * Under utf8, however, a simple table isn't practical; instead,
- * the OP is an SVOP (or, under threads, a PADOP),
- * and the SV is a reference to a swash
- * (i.e., an RV pointing to an HV).
- */
- return (!custom &&
- (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
- )
-#if defined(USE_ITHREADS)
- ? OPc_PADOP : OPc_PVOP;
-#else
- ? OPc_SVOP : OPc_PVOP;
-#endif
-
- case OA_LOOP:
- return OPc_LOOP;
-
- case OA_COP:
- return OPc_COP;
-
- case OA_BASEOP_OR_UNOP:
- /*
- * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
- * whether parens were seen. perly.y uses OPf_SPECIAL to
- * signal whether a BASEOP had empty parens or none.
- * Some other UNOPs are created later, though, so the best
- * test is OPf_KIDS, which is set in newUNOP.
- */
- return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
-
- case OA_FILESTATOP:
- /*
- * The file stat OPs are created via UNI(OP_foo) in toke.c but use
- * the OPf_REF flag to distinguish between OP types instead of the
- * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
- * return OPc_UNOP so that walkoptree can find our children. If
- * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
- * (no argument to the operator) it's an OP; with OPf_REF set it's
- * an SVOP (and op_sv is the GV for the filehandle argument).
- */
- return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
-#ifdef USE_ITHREADS
- (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
-#else
- (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
-#endif
- case OA_LOOPEXOP:
- /*
- * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
- * label was omitted (in which case it's a BASEOP) or else a term was
- * seen. In this last case, all except goto are definitely PVOP but
- * goto is either a PVOP (with an ordinary constant label), an UNOP
- * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
- * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
- * get set.
- */
- if (o->op_flags & OPf_STACKED)
- return OPc_UNOP;
- else if (o->op_flags & OPf_SPECIAL)
- return OPc_BASEOP;
- else
- return OPc_PVOP;
- case OA_METHOP:
- return OPc_METHOP;
- case OA_UNOP_AUX:
- return OPc_UNOP_AUX;
- }
- warn("can't determine class of operator %s, assuming BASEOP\n",
- OP_NAME(o));
- return OPc_BASEOP;
-}
static SV *
make_op_object(pTHX_ const OP *o)
{
SV *opsv = sv_newmortal();
- sv_setiv(newSVrv(opsv, opclassnames[cc_opclass(aTHX_ o)]), PTR2IV(o));
+ sv_setiv(newSVrv(opsv, opclassnames[op_class(o)]), PTR2IV(o));
return opsv;
}
dSP;
OP *kid;
SV *object;
- const char *const classname = opclassnames[cc_opclass(aTHX_ o)];
+ const char *const classname = opclassnames[op_class(o)];
dMY_CXT;
/* Check that no-one has changed our reference, or is holding a reference
ref = walkoptree(aTHX_ kid, method, ref);
}
}
- if (o && (cc_opclass(aTHX_ o) == OPc_PMOP) && o->op_type != OP_SPLIT
+ if (o && (op_class(o) == OPclass_PMOP) && o->op_type != OP_SPLIT
&& (kid = PMOP_pmreplroot(cPMOPo)))
{
ref = walkoptree(aTHX_ kid, method, ref);
: &PL_sv_undef);
break;
case 26: /* B::OP::size */
- ret = sv_2mortal(newSVuv((UV)(opsizes[cc_opclass(aTHX_ o)])));
+ ret = sv_2mortal(newSVuv((UV)(opsizes[op_class(o)])));
break;
case 27: /* B::OP::name */
case 28: /* B::OP::desc */
isGV_with_GP = 1
CODE:
if (ix) {
- RETVAL = isGV_with_GP(gv) ? TRUE : FALSE;
+ RETVAL = cBOOL(isGV_with_GP(gv));
} else {
RETVAL = GvGP(gv) == Null(GP*);
}
HASH(h)
B::RHE h
CODE:
- RETVAL = newRV( (SV*)cophh_2hv(h, 0) );
+ RETVAL = newRV_noinc( (SV*)cophh_2hv(h, 0) );
OUTPUT:
RETVAL
local $TODO = 'This gets mangled by the current pipe implementation' if $^O eq 'VMS';
my $e = <<'EODUMP';
dumpindent is 4 at -e line 1.
-{
-1 TYPE = leave ===> NULL
- TARG = 1
- FLAGS = (VOID,KIDS,PARENS,SLABBED)
- PRIVATE = (REFC)
- REFCNT = 1
- {
-2 TYPE = enter ===> 3
- FLAGS = (UNKNOWN,SLABBED,MORESIB)
- }
- {
-3 TYPE = nextstate ===> 4
- FLAGS = (VOID,SLABBED,MORESIB)
- LINE = 1
- PACKAGE = "t"
- }
- {
-5 TYPE = entersub ===> 1
- TARG = 1
- FLAGS = (VOID,KIDS,STACKED,SLABBED)
- PRIVATE = (TARG)
- {
-6 TYPE = null ===> (5)
- (was list)
- FLAGS = (UNKNOWN,KIDS,SLABBED)
- {
-4 TYPE = pushmark ===> 7
- FLAGS = (SCALAR,SLABBED,MORESIB)
- }
- {
-8 TYPE = null ===> (6)
- (was rv2cv)
- FLAGS = (SCALAR,KIDS,SLABBED)
- PRIVATE = (0x1)
- {
-7 TYPE = gv ===> 5
- FLAGS = (SCALAR,SLABBED)
- GV_OR_PADIX
- }
- }
- }
- }
-}
+
+1 leave LISTOP(0xNNN) ===> [0x0]
+ TARG = 1
+ FLAGS = (VOID,KIDS,PARENS,SLABBED)
+ PRIVATE = (REFC)
+ REFCNT = 1
+ |
+2 +--enter OP(0xNNN) ===> 3 [nextstate 0xNNN]
+ | FLAGS = (UNKNOWN,SLABBED,MORESIB)
+ |
+3 +--nextstate COP(0xNNN) ===> 4 [pushmark 0xNNN]
+ | FLAGS = (VOID,SLABBED,MORESIB)
+ | LINE = 1
+ | PACKAGE = "t"
+ | |
+5 +--entersub UNOP(0xNNN) ===> 1 [leave 0xNNN]
+ TARG = 1
+ FLAGS = (VOID,KIDS,STACKED,SLABBED)
+ PRIVATE = (TARG)
+ |
+6 +--null (ex-list) UNOP(0xNNN) ===> 5 [entersub 0xNNN]
+ FLAGS = (UNKNOWN,KIDS,SLABBED)
+ |
+4 +--pushmark OP(0xNNN) ===> 7 [gv 0xNNN]
+ | FLAGS = (SCALAR,SLABBED,MORESIB)
+ |
+8 +--null (ex-rv2cv) UNOP(0xNNN) ===> 6 [null 0xNNN]
+ FLAGS = (SCALAR,KIDS,SLABBED)
+ PRIVATE = (0x1)
+ |
+7 +--gv SVOP(0xNNN) ===> 5 [entersub 0xNNN]
+ FLAGS = (SCALAR,SLABBED)
+ GV_OR_PADIX
EODUMP
- $e =~ s/GV_OR_PADIX/$threads ? "PADIX = 2" : "GV = t::DumpProg"/e;
- $e =~ s/.*PRIVATE = \(0x1\).*\n// if $] < 5.021004;
+ $e =~ s/GV_OR_PADIX/$threads ? "PADIX = 2" : "GV = t::DumpProg (0xNNN)"/e;
+ $e =~ s/SVOP/PADOP/g if $threads;
my $out = t::runperl
switches => ['-Ilib'],
prog => 'package t; use Devel::Peek q-DumpProg-; DumpProg();',
stderr=>1;
$out =~ s/ *SEQ = .*\n//;
+ $out =~ s/0x[0-9a-f]{2,}\]/${1}0xNNN]/g;
+ $out =~ s/\(0x[0-9a-f]{3,}\)/(0xNNN)/g;
is $out, $e, "DumpProg() has no 'Attempt to free X prematurely' warning";
}
done_testing();
--- /dev/null
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 0;
+
+do './t/handy_base.pl';
--- /dev/null
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 1;
+
+do './t/handy_base.pl';
--- /dev/null
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 2;
+
+do './t/handy_base.pl';
--- /dev/null
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 3;
+
+do './t/handy_base.pl';
--- /dev/null
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 4;
+
+do './t/handy_base.pl';
--- /dev/null
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 5;
+
+do './t/handy_base.pl';
--- /dev/null
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 6;
+
+do './t/handy_base.pl';
--- /dev/null
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 7;
+
+do './t/handy_base.pl';
--- /dev/null
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 8;
+
+do './t/handy_base.pl';
--- /dev/null
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 9;
+
+do './t/handy_base.pl';
"deprecated mathoms" => -2,
);
+# This test is split into this number of files.
+my $num_test_files = $ENV{TEST_JOBS} || 1;
+$num_test_files = 10 if $num_test_files > 10;
+
+my $property_count = -1;
foreach my $name (sort keys %properties, 'octal') {
+
+ # We test every nth property in this run so that this test is split into
+ # smaller chunks to minimize test suite elapsed time when run in parallel.
+ $property_count++;
+ next if $property_count % $num_test_files != $::TEST_CHUNK;
+
my @invlist;
if ($name eq 'octal') {
# Hand-roll an inversion list with 0-7 in it and nothing else.
UPPER => 'Uppercase_Mapping',
);
-
+$property_count = -1;
foreach my $name (sort keys %to_properties) {
+
+ $property_count++;
+ next if $property_count % $num_test_files != $::TEST_CHUNK;
+
my $property = $to_properties{$name};
my ($list_ref, $map_ref, $format, $missing)
= prop_invmap($property, );
use strict;
use Test::More;
+
+# This file tests various functions and macros in the API related to UTF-8.
+
+BEGIN {
+ use_ok('XS::APItest');
+ require 'charset_tools.pl';
+ require './t/utf8_setup.pl';
+};
+
$|=1;
no warnings 'deprecated'; # Some of the below are above IV_MAX on 32 bit
# 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 display_bytes {
- use bytes;
- my $string = shift;
- return '"'
- . join("", map { sprintf("\\x%02x", ord $_) } split "", $string)
- . '"';
-}
-sub output_warnings(@) {
- diag "The warnings were:\n" . join("", @_);
-}
+my $pound_sign = chr utf8::unicode_to_native(163);
# 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
-# lookup to translate into the appropriate code page.
-
-my @i8_to_native = ( # Only code page 1047 so far.
-# _0 _1 _2 _3 _4 _5 _6 _7 _8 _9 _A _B _C _D _E _F
-0x00,0x01,0x02,0x03,0x37,0x2D,0x2E,0x2F,0x16,0x05,0x15,0x0B,0x0C,0x0D,0x0E,0x0F,
-0x10,0x11,0x12,0x13,0x3C,0x3D,0x32,0x26,0x18,0x19,0x3F,0x27,0x1C,0x1D,0x1E,0x1F,
-0x40,0x5A,0x7F,0x7B,0x5B,0x6C,0x50,0x7D,0x4D,0x5D,0x5C,0x4E,0x6B,0x60,0x4B,0x61,
-0xF0,0xF1,0xF2,0xF3,0xF4,0xF5,0xF6,0xF7,0xF8,0xF9,0x7A,0x5E,0x4C,0x7E,0x6E,0x6F,
-0x7C,0xC1,0xC2,0xC3,0xC4,0xC5,0xC6,0xC7,0xC8,0xC9,0xD1,0xD2,0xD3,0xD4,0xD5,0xD6,
-0xD7,0xD8,0xD9,0xE2,0xE3,0xE4,0xE5,0xE6,0xE7,0xE8,0xE9,0xAD,0xE0,0xBD,0x5F,0x6D,
-0x79,0x81,0x82,0x83,0x84,0x85,0x86,0x87,0x88,0x89,0x91,0x92,0x93,0x94,0x95,0x96,
-0x97,0x98,0x99,0xA2,0xA3,0xA4,0xA5,0xA6,0xA7,0xA8,0xA9,0xC0,0x4F,0xD0,0xA1,0x07,
-0x20,0x21,0x22,0x23,0x24,0x25,0x06,0x17,0x28,0x29,0x2A,0x2B,0x2C,0x09,0x0A,0x1B,
-0x30,0x31,0x1A,0x33,0x34,0x35,0x36,0x08,0x38,0x39,0x3A,0x3B,0x04,0x14,0x3E,0xFF,
-0x41,0x42,0x43,0x44,0x45,0x46,0x47,0x48,0x49,0x4A,0x51,0x52,0x53,0x54,0x55,0x56,
-0x57,0x58,0x59,0x62,0x63,0x64,0x65,0x66,0x67,0x68,0x69,0x6A,0x70,0x71,0x72,0x73,
-0x74,0x75,0x76,0x77,0x78,0x80,0x8A,0x8B,0x8C,0x8D,0x8E,0x8F,0x90,0x9A,0x9B,0x9C,
-0x9D,0x9E,0x9F,0xA0,0xAA,0xAB,0xAC,0xAE,0xAF,0xB0,0xB1,0xB2,0xB3,0xB4,0xB5,0xB6,
-0xB7,0xB8,0xB9,0xBA,0xBB,0xBC,0xBE,0xBF,0xCA,0xCB,0xCC,0xCD,0xCE,0xCF,0xDA,0xDB,
-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 "start_byte_to_cont() is expecting a UTF-8 variant";
- }
-
- $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 : 0xA0;
- return I8_to_native(chr $byte);
-}
-
-my $is64bit = length sprintf("%x", ~0) > 8;
-
-
-# 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_ALLOW_LONG_AND_ITS_VALUE = $UTF8_ALLOW_LONG|0x0020;
-my $UTF8_GOT_LONG = $UTF8_ALLOW_LONG;
-my $UTF8_ALLOW_OVERFLOW = 0x0080;
-my $UTF8_GOT_OVERFLOW = $UTF8_ALLOW_OVERFLOW;
-my $UTF8_DISALLOW_SURROGATE = 0x0100;
-my $UTF8_GOT_SURROGATE = $UTF8_DISALLOW_SURROGATE;
-my $UTF8_WARN_SURROGATE = 0x0200;
-my $UTF8_DISALLOW_NONCHAR = 0x0400;
-my $UTF8_GOT_NONCHAR = $UTF8_DISALLOW_NONCHAR;
-my $UTF8_WARN_NONCHAR = 0x0800;
-my $UTF8_DISALLOW_SUPER = 0x1000;
-my $UTF8_GOT_SUPER = $UTF8_DISALLOW_SUPER;
-my $UTF8_WARN_SUPER = 0x2000;
-my $UTF8_DISALLOW_ABOVE_31_BIT = 0x4000;
-my $UTF8_GOT_ABOVE_31_BIT = $UTF8_DISALLOW_ABOVE_31_BIT;
-my $UTF8_WARN_ABOVE_31_BIT = 0x8000;
-my $UTF8_CHECK_ONLY = 0x10000;
-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;
-my $UNICODE_WARN_NONCHAR = 0x0002;
-my $UNICODE_WARN_SUPER = 0x0004;
-my $UNICODE_WARN_ABOVE_31_BIT = 0x0008;
-my $UNICODE_DISALLOW_SURROGATE = 0x0010;
-my $UNICODE_DISALLOW_NONCHAR = 0x0020;
-my $UNICODE_DISALLOW_SUPER = 0x0040;
-my $UNICODE_DISALLOW_ABOVE_31_BIT = 0x0080;
+# strings are hard-coded as I8 strings in this file instead, and we use the
+# translation functions to/from I8 from that file instead.
my $look_for_everything_utf8n_to
- = $UTF8_DISALLOW_SURROGATE
- | $UTF8_WARN_SURROGATE
- | $UTF8_DISALLOW_NONCHAR
- | $UTF8_WARN_NONCHAR
- | $UTF8_DISALLOW_SUPER
- | $UTF8_WARN_SUPER
- | $UTF8_DISALLOW_ABOVE_31_BIT
- | $UTF8_WARN_ABOVE_31_BIT;
+ = $::UTF8_DISALLOW_SURROGATE
+ | $::UTF8_WARN_SURROGATE
+ | $::UTF8_DISALLOW_NONCHAR
+ | $::UTF8_WARN_NONCHAR
+ | $::UTF8_DISALLOW_SUPER
+ | $::UTF8_WARN_SUPER
+ | $::UTF8_DISALLOW_ABOVE_31_BIT
+ | $::UTF8_WARN_ABOVE_31_BIT;
my $look_for_everything_uvchr_to
- = $UNICODE_DISALLOW_SURROGATE
- | $UNICODE_WARN_SURROGATE
- | $UNICODE_DISALLOW_NONCHAR
- | $UNICODE_WARN_NONCHAR
- | $UNICODE_DISALLOW_SUPER
- | $UNICODE_WARN_SUPER
- | $UNICODE_DISALLOW_ABOVE_31_BIT
- | $UNICODE_WARN_ABOVE_31_BIT;
+ = $::UNICODE_DISALLOW_SURROGATE
+ | $::UNICODE_WARN_SURROGATE
+ | $::UNICODE_DISALLOW_NONCHAR
+ | $::UNICODE_WARN_NONCHAR
+ | $::UNICODE_DISALLOW_SUPER
+ | $::UNICODE_WARN_SUPER
+ | $::UNICODE_DISALLOW_ABOVE_31_BIT
+ | $::UNICODE_WARN_ABOVE_31_BIT;
foreach ([0, '', '', 'empty'],
[0, 'N', 'N', '1 char'],
: I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa3\xbf\xbf\xbf\xbf\xbf\xbf"),
);
-if ($is64bit) {
+if ($::is64bit) {
no warnings qw(overflow portable);
$code_points{0x100000000}
= (isASCII)
# continuation bytes can be in, and what the lowest start byte can be. So we
# cycle through them.
-my $first_continuation = (isASCII) ? 0x80 : 0xA0;
my $final_continuation = 0xBF;
my $start = (isASCII) ? 0xC2 : 0xC5;
-my $max_bytes = (isASCII) ? 13 : 14; # Max number of bytes in a UTF-8 sequence
- # representing a single code point
-
-my $continuation = $first_continuation - 1;
+my $continuation = $::first_continuation - 1;
while ($cp < 255) {
if (++$continuation > $final_continuation) {
# Wrap to the next start byte when we reach the final continuation
# byte possible
- $continuation = $first_continuation;
+ $continuation = $::first_continuation;
$start++;
}
$code_points{$cp} = I8_to_native(chr($start) . chr($continuation));
$u < 0x10000 ? 3 :
$u < 0x200000 ? 4 :
$u < 0x4000000 ? 5 :
- $u < 0x80000000 ? 6 : (($is64bit)
- ? ($u < 0x1000000000 ? 7 : $max_bytes)
+ $u < 0x80000000 ? 6 : (($::is64bit)
+ ? ($u < 0x1000000000 ? 7 : $::max_bytes)
: 7)
)
: ($u < 0xA0 ? 1 :
$u < 0x40000 ? 4 :
$u < 0x400000 ? 5 :
$u < 0x4000000 ? 6 :
- $u < 0x40000000 ? 7 : $max_bytes );
+ $u < 0x40000000 ? 7 : $::max_bytes );
}
# If this test fails, subsequent ones are meaningless.
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);
+ $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);
+ ~($::UTF8_DISALLOW_ABOVE_31_BIT|$::UTF8_WARN_ABOVE_31_BIT);
$valid_for_fits_in_31_bits = 0;
}
}
elsif (($n >= 0xFDD0 && $n <= 0xFDEF) || ($n & 0xFFFE) == 0xFFFE) {
- $this_utf8_flags &= ~($UTF8_DISALLOW_NONCHAR|$UTF8_WARN_NONCHAR);
+ $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);
+ $this_utf8_flags &= ~($::UTF8_DISALLOW_SURROGATE|$::UTF8_WARN_SURROGATE);
$valid_under_c9strict = 0;
$valid_under_strict = 0;
}
undef @warnings;
$ret = test_isUTF8_CHAR_flags($bytes, $len,
- $UTF8_DISALLOW_ILLEGAL_INTERCHANGE);
+ $::UTF8_DISALLOW_ILLEGAL_INTERCHANGE);
is($ret, $expected_len,
"Verify isUTF8_CHAR_flags('DISALLOW_ILLEGAL_INTERCHANGE')"
. " acts like isSTRICT_UTF8_CHAR");
undef @warnings;
$ret = test_isUTF8_CHAR_flags($bytes, $len,
- $UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE);
+ $::UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE);
is($ret, $expected_len,
"Verify isUTF8_CHAR_flags('DISALLOW_ILLEGAL_C9_INTERCHANGE')"
." acts like isC9_STRICT_UTF8_CHAR");
my $this_uvchr_flags = $look_for_everything_uvchr_to;
if ($n > 2 ** 31 - 1) {
$this_uvchr_flags &=
- ~($UNICODE_DISALLOW_ABOVE_31_BIT|$UNICODE_WARN_ABOVE_31_BIT);
+ ~($::UNICODE_DISALLOW_ABOVE_31_BIT|$::UNICODE_WARN_ABOVE_31_BIT);
}
if ($n > 0x10FFFF) {
- $this_uvchr_flags &= ~($UNICODE_DISALLOW_SUPER|$UNICODE_WARN_SUPER);
+ $this_uvchr_flags &= ~($::UNICODE_DISALLOW_SUPER|$::UNICODE_WARN_SUPER);
}
elsif (($n >= 0xFDD0 && $n <= 0xFDEF) || ($n & 0xFFFE) == 0xFFFE) {
- $this_uvchr_flags &= ~($UNICODE_DISALLOW_NONCHAR|$UNICODE_WARN_NONCHAR);
+ $this_uvchr_flags &= ~($::UNICODE_DISALLOW_NONCHAR|$::UNICODE_WARN_NONCHAR);
}
elsif ($n >= 0xD800 && $n <= 0xDFFF) {
$this_uvchr_flags
- &= ~($UNICODE_DISALLOW_SURROGATE|$UNICODE_WARN_SURROGATE);
+ &= ~($::UNICODE_DISALLOW_SURROGATE|$::UNICODE_WARN_SURROGATE);
}
$display_flags = sprintf "0x%x", $this_uvchr_flags;
$this_name .= "($restriction)";
if ($restriction eq "c9strict") {
$test
- .= ", $UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE";
+ .= ", $::UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE";
}
elsif ($restriction eq "strict") {
- $test .= ", $UTF8_DISALLOW_ILLEGAL_INTERCHANGE";
+ $test .= ", $::UTF8_DISALLOW_ILLEGAL_INTERCHANGE";
}
elsif ($restriction eq "fits_in_31_bits") {
- $test .= ", $UTF8_DISALLOW_ABOVE_31_BIT";
+ $test .= ", $::UTF8_DISALLOW_ABOVE_31_BIT";
}
else {
fail("Internal test error: Unknown restriction "
}
}
-my $REPLACEMENT = 0xFFFD;
-
-# Now test the malformations. All these raise category utf8 warnings.
-my @malformations = (
- # ($testname, $bytes, $length, $allow_flags, $expected_error_flags,
- # $allowed_uv, $expected_len, $needed_to_discern_len, $message )
-
-# Now considered a program bug, and asserted against
- #[ "zero length string malformation", "", 0,
- # $UTF8_ALLOW_EMPTY, $UTF8_GOT_EMPTY, $REPLACEMENT, 0, 0,
- # qr/empty string/
- #],
- [ "orphan continuation byte malformation", I8_to_native("${I8c}a"), 2,
- $UTF8_ALLOW_CONTINUATION, $UTF8_GOT_CONTINUATION, $REPLACEMENT,
- 1, 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, $UTF8_GOT_NON_CONTINUATION, $REPLACEMENT,
- 1, 2,
- qr/unexpected non-continuation byte.*immediately after start byte/
- ],
- [ "premature next character malformation (non-immediate)",
- I8_to_native("\xef${I8c}a"), 3,
- $UTF8_ALLOW_NON_CONTINUATION, $UTF8_GOT_NON_CONTINUATION, $REPLACEMENT,
- 2, 3,
- qr/unexpected non-continuation byte .* 2 bytes after start byte/
- ],
- [ "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, $UTF8_GOT_SHORT, $REPLACEMENT,
- 2, 2,
- qr/2 bytes available, need 4/
- ],
- [ "overlong malformation, lowest 2-byte",
- (isASCII) ? "\xc0\x80" : I8_to_native("\xc0\xa0"),
- 2,
- $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
- 0, # NUL
- 2, 1,
- qr/overlong/
- ],
- [ "overlong malformation, highest 2-byte",
- (isASCII) ? "\xc1\xbf" : I8_to_native("\xc4\xbf"),
- 2,
- $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
- (isASCII) ? 0x7F : utf8::unicode_to_native(0x9F),
- 2, 1,
- qr/overlong/
- ],
- [ "overlong malformation, lowest 3-byte",
- (isASCII) ? "\xe0\x80\x80" : I8_to_native("\xe0\xa0\xa0"),
- 3,
- $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
- 0, # NUL
- 3, (isASCII) ? 2 : 1,
- qr/overlong/
- ],
- [ "overlong malformation, highest 3-byte",
- (isASCII) ? "\xe0\x9f\xbf" : I8_to_native("\xe0\xbf\xbf"),
- 3,
- $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
- (isASCII) ? 0x7FF : 0x3FF,
- 3, (isASCII) ? 2 : 1,
- qr/overlong/
- ],
- [ "overlong malformation, lowest 4-byte",
- (isASCII) ? "\xf0\x80\x80\x80" : I8_to_native("\xf0\xa0\xa0\xa0"),
- 4,
- $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
- 0, # NUL
- 4, 2,
- qr/overlong/
- ],
- [ "overlong malformation, highest 4-byte",
- (isASCII) ? "\xf0\x8F\xbf\xbf" : I8_to_native("\xf0\xaf\xbf\xbf"),
- 4,
- $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
- (isASCII) ? 0xFFFF : 0x3FFF,
- 4, 2,
- 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_GOT_LONG,
- 0, # NUL
- 5, 2,
- 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_GOT_LONG,
- (isASCII) ? 0x1FFFFF : 0x3FFFF,
- 5, 2,
- 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_GOT_LONG,
- 0, # NUL
- 6, 2,
- 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_GOT_LONG,
- (isASCII) ? 0x3FFFFFF : 0x3FFFFF,
- 6, 2,
- 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_GOT_LONG,
- 0, # NUL
- 7, 2,
- 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_GOT_LONG,
- (isASCII) ? 0x7FFFFFFF : 0x3FFFFFF,
- 7, 2,
- qr/overlong/
- ],
-);
-
-if (isASCII && ! $is64bit) { # 32-bit ASCII platform
- no warnings 'portable';
- push @malformations,
- [ "overflow malformation",
- "\xfe\x84\x80\x80\x80\x80\x80", # Represents 2**32
- 7,
- $UTF8_ALLOW_OVERFLOW, $UTF8_GOT_OVERFLOW,
- $REPLACEMENT,
- 7, 2,
- qr/overflows/
- ],
- [ "overflow malformation",
- "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80",
- $max_bytes,
- $UTF8_ALLOW_OVERFLOW, $UTF8_GOT_OVERFLOW,
- $REPLACEMENT,
- $max_bytes, 1,
- qr/overflows/
- ];
-}
-else { # 64-bit ASCII, or EBCDIC of any size.
- # On EBCDIC platforms, another overlong test is needed even on 32-bit
- # systems, whereas it doesn't happen on ASCII except on 64-bit ones.
-
- no warnings 'portable';
- no warnings 'overflow'; # Doesn't run on 32-bit systems, but compiles
- push @malformations,
- [ "overlong malformation, lowest max-byte",
- (isASCII)
- ? "\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"),
- $max_bytes,
- $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
- 0, # NUL
- $max_bytes, (isASCII) ? 7 : 8,
- 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"),
- $max_bytes,
- $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
- (isASCII) ? 0xFFFFFFFFF : 0x3FFFFFFF,
- $max_bytes, (isASCII) ? 7 : 8,
- qr/overlong/,
- ];
-
- if (! $is64bit) { # 32-bit EBCDIC
- push @malformations,
- [ "overflow malformation",
- I8_to_native(
- "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa4\xa0\xa0\xa0\xa0\xa0\xa0"),
- $max_bytes,
- $UTF8_ALLOW_OVERFLOW, $UTF8_GOT_OVERFLOW,
- $REPLACEMENT,
- $max_bytes, 8,
- qr/overflows/
- ];
- }
- else { # 64-bit, either ASCII or EBCDIC
- push @malformations,
- [ "overflow malformation",
- (isASCII)
- ? "\xff\x80\x90\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"
- : I8_to_native(
- "\xff\xb0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
- $max_bytes,
- $UTF8_ALLOW_OVERFLOW, $UTF8_GOT_OVERFLOW,
- $REPLACEMENT,
- $max_bytes, (isASCII) ? 3 : 2,
- qr/overflows/
- ];
- }
-}
-
-# For each overlong malformation in the list, we modify it, so that there are
-# two tests. The first one returns the replacement character given the input
-# flags, and the second test adds a flag that causes the actual code point the
-# malformation represents to be returned.
-my @added_overlongs;
-foreach my $test (@malformations) {
- my ($testname, $bytes, $length, $allow_flags, $expected_error_flags,
- $allowed_uv, $expected_len, $needed_to_discern_len, $message ) = @$test;
- next unless $testname =~ /overlong/;
-
- $test->[0] .= "; use REPLACEMENT CHAR";
- $test->[5] = $REPLACEMENT;
-
- push @added_overlongs,
- [ $testname . "; use actual value",
- $bytes, $length,
- $allow_flags | $UTF8_ALLOW_LONG_AND_ITS_VALUE,
- $expected_error_flags, $allowed_uv, $expected_len,
- $needed_to_discern_len, $message
- ];
-}
-push @malformations, @added_overlongs;
-
-foreach my $test (@malformations) {
- my ($testname, $bytes, $length, $allow_flags, $expected_error_flags,
- $allowed_uv, $expected_len, $needed_to_discern_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;
-
- my $ret = test_isUTF8_CHAR($bytes, $length);
- is($ret, 0, "$testname: isUTF8_CHAR returns 0");
- is(scalar @warnings, 0, "$testname: isUTF8_CHAR() generated no warnings")
- or output_warnings(@warnings);
-
- undef @warnings;
-
- $ret = test_isUTF8_CHAR_flags($bytes, $length, 0);
- is($ret, 0, "$testname: isUTF8_CHAR_flags returns 0");
- is(scalar @warnings, 0, "$testname: isUTF8_CHAR_flags() generated no"
- . " warnings")
- or output_warnings(@warnings);
-
- $ret = test_isSTRICT_UTF8_CHAR($bytes, $length);
- is($ret, 0, "$testname: isSTRICT_UTF8_CHAR returns 0");
- is(scalar @warnings, 0,
- "$testname: isSTRICT_UTF8_CHAR() generated no warnings")
- or output_warnings(@warnings);
-
- $ret = test_isC9_STRICT_UTF8_CHAR($bytes, $length);
- is($ret, 0, "$testname: isC9_STRICT_UTF8_CHAR returns 0");
- is(scalar @warnings, 0,
- "$testname: isC9_STRICT_UTF8_CHAR() generated no warnings")
- or output_warnings(@warnings);
-
- for my $j (1 .. $length - 1) {
- my $partial = substr($bytes, 0, $j);
-
- undef @warnings;
-
- $ret = test_is_utf8_valid_partial_char_flags($bytes, $j, 0);
-
- my $ret_should_be = 0;
- my $comment = "";
- if ($j < $needed_to_discern_len) {
- $ret_should_be = 1;
- $comment = ", but need $needed_to_discern_len bytes to discern:";
- }
-
- is($ret, $ret_should_be, "$testname: is_utf8_valid_partial_char_flags("
- . display_bytes($partial)
- . ")$comment returns $ret_should_be");
- is(scalar @warnings, 0,
- "$testname: is_utf8_valid_partial_char_flags() generated"
- . " no warnings")
- or output_warnings(@warnings);
- }
-
-
- # Test what happens when this malformation is not allowed
- undef @warnings;
- 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_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) {
- 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_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_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"))
- {
- 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_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"))
- {
- 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
-# be allowed/warned on.
-my @tests = (
- # ($testname, $bytes, $warn_flags, $disallow_flags, $expected_error_flags,
- # $category, $allowed_uv, $expected_len, $needed_to_discern_len, $message )
- [ "lowest surrogate",
- (isASCII) ? "\xed\xa0\x80" : I8_to_native("\xf1\xb6\xa0\xa0"),
- $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE, $UTF8_GOT_SURROGATE,
- 'surrogate', 0xD800,
- (isASCII) ? 3 : 4,
- 2,
- qr/surrogate/
- ],
- [ "a middle surrogate",
- (isASCII) ? "\xed\xa4\x8d" : I8_to_native("\xf1\xb6\xa8\xad"),
- $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE, $UTF8_GOT_SURROGATE,
- 'surrogate', 0xD90D,
- (isASCII) ? 3 : 4,
- 2,
- qr/surrogate/
- ],
- [ "highest surrogate",
- (isASCII) ? "\xed\xbf\xbf" : I8_to_native("\xf1\xb7\xbf\xbf"),
- $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE, $UTF8_GOT_SURROGATE,
- 'surrogate', 0xDFFF,
- (isASCII) ? 3 : 4,
- 2,
- 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_GOT_SUPER,
- 'non_unicode', 0x110000,
- (isASCII) ? 4 : 5,
- 2,
- 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_GOT_SUPER,
- 'non_unicode',
- (isASCII) ? 0x140000 : 0x200000,
- (isASCII) ? 4 : 5,
- 1,
- 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_GOT_NONCHAR,
- 'nonchar', 0xFDD0,
- (isASCII) ? 3 : 4,
- (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_GOT_NONCHAR,
- 'nonchar', 0xFDE0,
- (isASCII) ? 3 : 4,
- (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_GOT_NONCHAR,
- 'nonchar', 0xFDEF,
- (isASCII) ? 3 : 4,
- (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_GOT_NONCHAR,
- 'nonchar', 0xFFFE,
- (isASCII) ? 3 : 4,
- (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_GOT_NONCHAR,
- 'nonchar', 0xFFFF,
- (isASCII) ? 3 : 4,
- (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_GOT_NONCHAR,
- 'nonchar', 0x1FFFE,
- 4, 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_GOT_NONCHAR,
- 'nonchar', 0x1FFFF,
- 4, 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_GOT_NONCHAR,
- 'nonchar', 0x2FFFE,
- 4, 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_GOT_NONCHAR,
- 'nonchar', 0x2FFFF,
- 4, 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_GOT_NONCHAR,
- 'nonchar', 0x3FFFE,
- 4, 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_GOT_NONCHAR,
- 'nonchar', 0x3FFFF,
- 4, 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_GOT_NONCHAR,
- 'nonchar', 0x4FFFE,
- (isASCII) ? 4 : 5,
- (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_GOT_NONCHAR,
- 'nonchar', 0x4FFFF,
- (isASCII) ? 4 : 5,
- (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_GOT_NONCHAR,
- 'nonchar', 0x5FFFE,
- (isASCII) ? 4 : 5,
- (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_GOT_NONCHAR,
- 'nonchar', 0x5FFFF,
- (isASCII) ? 4 : 5,
- (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_GOT_NONCHAR,
- 'nonchar', 0x6FFFE,
- (isASCII) ? 4 : 5,
- (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_GOT_NONCHAR,
- 'nonchar', 0x6FFFF,
- (isASCII) ? 4 : 5,
- (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_GOT_NONCHAR,
- 'nonchar', 0x7FFFE,
- (isASCII) ? 4 : 5,
- (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_GOT_NONCHAR,
- 'nonchar', 0x7FFFF,
- (isASCII) ? 4 : 5,
- (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_GOT_NONCHAR,
- 'nonchar', 0x8FFFE,
- (isASCII) ? 4 : 5,
- (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_GOT_NONCHAR,
- 'nonchar', 0x8FFFF,
- (isASCII) ? 4 : 5,
- (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_GOT_NONCHAR,
- 'nonchar', 0x9FFFE,
- (isASCII) ? 4 : 5,
- (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_GOT_NONCHAR,
- 'nonchar', 0x9FFFF,
- (isASCII) ? 4 : 5,
- (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_GOT_NONCHAR,
- 'nonchar', 0xAFFFE,
- (isASCII) ? 4 : 5,
- (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_GOT_NONCHAR,
- 'nonchar', 0xAFFFF,
- (isASCII) ? 4 : 5,
- (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_GOT_NONCHAR,
- 'nonchar', 0xBFFFE,
- (isASCII) ? 4 : 5,
- (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_GOT_NONCHAR,
- 'nonchar', 0xBFFFF,
- (isASCII) ? 4 : 5,
- (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_GOT_NONCHAR,
- 'nonchar', 0xCFFFE,
- (isASCII) ? 4 : 5,
- (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_GOT_NONCHAR,
- 'nonchar', 0xCFFFF,
- (isASCII) ? 4 : 5,
- (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_GOT_NONCHAR,
- 'nonchar', 0xDFFFE,
- (isASCII) ? 4 : 5,
- (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_GOT_NONCHAR,
- 'nonchar', 0xDFFFF,
- (isASCII) ? 4 : 5,
- (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_GOT_NONCHAR,
- 'nonchar', 0xEFFFE,
- (isASCII) ? 4 : 5,
- (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_GOT_NONCHAR,
- 'nonchar', 0xEFFFF,
- (isASCII) ? 4 : 5,
- (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_GOT_NONCHAR,
- 'nonchar', 0xFFFFE,
- (isASCII) ? 4 : 5,
- (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_GOT_NONCHAR,
- 'nonchar', 0xFFFFF,
- (isASCII) ? 4 : 5,
- (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_GOT_NONCHAR,
- 'nonchar', 0x10FFFE,
- (isASCII) ? 4 : 5,
- (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_GOT_NONCHAR,
- 'nonchar', 0x10FFFF,
- (isASCII) ? 4 : 5,
- (isASCII) ? 4 : 5,
- qr/Unicode non-character.*is not recommended for open interchange/
- ],
- [ "requires at least 32 bits",
- (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"),
- # 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 : $max_bytes,
- (isASCII) ? 1 : 8,
- nonportable_regex(0x80000000)
- ],
- [ "highest 32 bit code point",
- (isASCII)
- ? "\xfe\x83\xbf\xbf\xbf\xbf\xbf"
- : I8_to_native(
- "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa3\xbf\xbf\xbf\xbf\xbf\xbf"),
- $UTF8_WARN_ABOVE_31_BIT, $UTF8_DISALLOW_ABOVE_31_BIT,
- $UTF8_GOT_ABOVE_31_BIT,
- 'utf8', 0xFFFFFFFF,
- (isASCII) ? 7 : $max_bytes,
- (isASCII) ? 1 : 8,
- nonportable_regex(0xffffffff)
- ],
- [ "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_GOT_SUPER,
- 'utf8', 0x80000000,
- (isASCII) ? 7 : $max_bytes,
- 1,
- 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
- # with overflow. The overflow malformation is never allowed, so
- # preventing it takes precedence if the ABOVE_31_BIT options would
- # otherwise allow in an overflowing value. The ASCII code points (1
- # for 32-bits; 1 for 64) were chosen because the old overflow
- # detection algorithm did not catch them; this means this test also
- # checks for that fix. The EBCDIC are arbitrary overflowing ones
- # since we have no reports of failures with it.
- (($is64bit)
- ? ((isASCII)
- ? "\xff\x80\x90\x90\x90\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf"
- : I8_to_native(
- "\xff\xB0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"))
- : ((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"))),
- $UTF8_WARN_ABOVE_31_BIT,
- $UTF8_DISALLOW_ABOVE_31_BIT,
- $UTF8_GOT_ABOVE_31_BIT,
- 'utf8', 0,
- (! isASCII || $is64bit) ? $max_bytes : 7,
- (isASCII || $is64bit) ? 2 : 8,
- qr/overflows/
- ],
-);
-
-if (! $is64bit) {
- if (isASCII) {
- no warnings qw{portable overflow};
- push @tests,
- [ "Lowest 33 bit code point: overflow",
- "\xFE\x84\x80\x80\x80\x80\x80",
- $UTF8_WARN_ABOVE_31_BIT, $UTF8_DISALLOW_ABOVE_31_BIT,
- $UTF8_GOT_ABOVE_31_BIT,
- 'utf8', 0x100000000,
- 7, 1,
- qr/and( is)? not portable/
- ];
- }
-}
-else {
- no warnings qw{portable overflow};
- push @tests,
- [ "More than 32 bits",
- (isASCII)
- ? "\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,
- $max_bytes, (isASCII) ? 1 : 7,
- 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,
- $max_bytes, 7,
- 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,
- $max_bytes, 6,
- 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,
- $max_bytes, 5,
- 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,
- $max_bytes, 4,
- 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,
- $max_bytes, 3,
- 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"),
- $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
- $UTF8_GOT_ABOVE_31_BIT,
- 'utf8', 0x1000000000000000,
- $max_bytes, 2,
- nonportable_regex(0x1000000000000000)
- ];
- }
-}
-
-foreach my $test (@tests) {
- my ($testname, $bytes, $warn_flags, $disallow_flags, $expected_error_flags,
- $category, $allowed_uv, $expected_len, $needed_to_discern_len, $message
- ) = @$test;
-
- my $length = length $bytes;
- my $will_overflow = $testname =~ /overflow/ ? 'overflow' : "";
-
- {
- use warnings;
- undef @warnings;
- my $ret = test_isUTF8_CHAR($bytes, $length);
- my $ret_flags = test_isUTF8_CHAR_flags($bytes, $length, 0);
- if ($will_overflow) {
- is($ret, 0, "isUTF8_CHAR() $testname: returns 0");
- is($ret_flags, 0, "isUTF8_CHAR_flags() $testname: returns 0");
- }
- else {
- is($ret, $length,
- "isUTF8_CHAR() $testname: returns expected length: $length");
- is($ret_flags, $length, "isUTF8_CHAR_flags(...,0) $testname:"
- . " returns expected length: $length");
- }
- is(scalar @warnings, 0,
- "isUTF8_CHAR() and isUTF8_CHAR()_flags $testname: generated"
- . " no warnings")
- or output_warnings(@warnings);
-
- undef @warnings;
- $ret = test_isSTRICT_UTF8_CHAR($bytes, $length);
- if ($will_overflow) {
- is($ret, 0, "isSTRICT_UTF8_CHAR() $testname: returns 0");
- }
- else {
- my $expected_ret = ( $testname =~ /surrogate|non-character/
- || $allowed_uv > 0x10FFFF)
- ? 0
- : $length;
- is($ret, $expected_ret, "isSTRICT_UTF8_CHAR() $testname: returns"
- . " expected length: $expected_ret");
- $ret = test_isUTF8_CHAR_flags($bytes, $length,
- $UTF8_DISALLOW_ILLEGAL_INTERCHANGE);
- is($ret, $expected_ret,
- "isUTF8_CHAR_flags('DISALLOW_ILLEGAL_INTERCHANGE')"
- . " acts like isSTRICT_UTF8_CHAR");
- }
- is(scalar @warnings, 0,
- "isSTRICT_UTF8_CHAR() and isUTF8_CHAR_flags $testname:"
- . " generated no warnings")
- or output_warnings(@warnings);
-
- undef @warnings;
- $ret = test_isC9_STRICT_UTF8_CHAR($bytes, $length);
- if ($will_overflow) {
- is($ret, 0, "isC9_STRICT_UTF8_CHAR() $testname: returns 0");
- }
- else {
- my $expected_ret = ( $testname =~ /surrogate/
- || $allowed_uv > 0x10FFFF)
- ? 0
- : $length;
- is($ret, $expected_ret, "isC9_STRICT_UTF8_CHAR() $testname:"
- ." returns expected length: $expected_ret");
- $ret = test_isUTF8_CHAR_flags($bytes, $length,
- $UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE);
- is($ret, $expected_ret,
- "isUTF8_CHAR_flags('DISALLOW_ILLEGAL_C9_INTERCHANGE')"
- . " acts like isC9_STRICT_UTF8_CHAR");
- }
- is(scalar @warnings, 0,
- "isC9_STRICT_UTF8_CHAR() and isUTF8_CHAR_flags $testname:"
- . " generated no warnings")
- or output_warnings(@warnings);
-
- # Test partial character handling, for each byte not a full character
- for my $j (1.. $length - 1) {
-
- # Skip the test for the interaction between overflow and above-31
- # bit. It is really testing other things than the partial
- # character tests, for which other tests in this file are
- # sufficient
- last if $testname =~ /overflow/;
-
- foreach my $disallow_flag (0, $disallow_flags) {
- my $partial = substr($bytes, 0, $j);
- my $ret_should_be;
- my $comment;
- if ($disallow_flag) {
- $ret_should_be = 0;
- $comment = "disallowed";
- if ($j < $needed_to_discern_len) {
- $ret_should_be = 1;
- $comment .= ", but need $needed_to_discern_len bytes"
- . " to discern:";
- }
- }
- else {
- $ret_should_be = 1;
- $comment = "allowed";
- }
-
- undef @warnings;
-
- $ret = test_is_utf8_valid_partial_char_flags($partial, $j,
- $disallow_flag);
- is($ret, $ret_should_be,
- "$testname: is_utf8_valid_partial_char_flags("
- . display_bytes($partial)
- . "), $comment: returns $ret_should_be");
- is(scalar @warnings, 0,
- "$testname: is_utf8_valid_partial_char_flags()"
- . " generated no warnings")
- or output_warnings(@warnings);
- }
- }
- }
-
- # This is more complicated than the malformations tested earlier, as there
- # are several orthogonal variables involved. We test all the subclasses
- # of utf8 warnings to verify they work with and without the utf8 class,
- # and don't have effects on other sublass warnings
- foreach my $warning ('utf8', 'surrogate', 'nonchar', 'non_unicode') {
- foreach my $warn_flag (0, $warn_flags) {
- foreach my $disallow_flag (0, $disallow_flags) {
- foreach my $do_warning (0, 1) {
-
- # We try each of the above with various combinations of
- # malformations that can occur on the same input sequence.
- foreach my $short ("", "short") {
- foreach my $unexpected_noncont ("",
- "unexpected non-continuation")
- {
- foreach my $overlong ("", "overlong") {
-
- # If we're already at the longest possible, we
- # can't create an overlong (which would be longer)
- # can't handle anything larger.
- next if $overlong && $expected_len >= $max_bytes;
-
- my @malformations;
- my @expected_errors;
- push @malformations, $short if $short;
- push @malformations, $unexpected_noncont
- if $unexpected_noncont;
- 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;
- }
-
- 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;
- my $this_needed_to_discern_len = $needed_to_discern_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
- = I8_to_native("\xff")
- . (I8_to_native(chr $first_continuation)
- x ( $max_bytes - 1 - length($this_bytes)))
- . $this_bytes;
- $this_length = length($this_bytes);
- $this_needed_to_discern_len
- = $max_bytes - ($this_expected_len
- - $this_needed_to_discern_len);
- $this_expected_len = $max_bytes;
- 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;
- }
- if ($malformations_name
- =~ /non-continuation/)
- {
- # Change the final continuation byte into
- # a non one.
- my $pos = ($short) ? -2 : -1;
- substr($this_bytes, $pos, 1) = '?';
- $this_expected_len--;
- push @expected_errors,
- $UTF8_GOT_NON_CONTINUATION;
- }
- }
-
- 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 "\$!='$!'; eval'd=\"$call\"";
- next;
- }
- if ($disallowed) {
- is($ret_ref->[0], 0, "$this_name: Returns 0")
- or diag $call;
- }
- else {
- is($ret_ref->[0], $expected_uv,
- "$this_name: Returns expected uv: "
- . sprintf("0x%04X", $expected_uv))
- or diag $call;
- }
- is($ret_ref->[1], $this_expected_len,
- "$this_name: Returns expected length:"
- . " $this_expected_len")
- or diag $call;
-
- my $errors = $ret_ref->[2];
-
- 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;
- }
- is(scalar @expected_errors, 0,
- "Got all the expected malformation errors")
- or diag Dumper \@expected_errors;
-
- if ( $this_expected_len >= $this_needed_to_discern_len
- && ($warn_flag || $disallow_flag))
- {
- is($errors, $expected_error_flags,
- "Got the correct error flag")
- or diag $call;
- }
- else {
- is($errors, 0, "Got no other error 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");
-
- }
- }
-
- # Any overflow will override any super or above-31
- # warnings.
- goto no_warnings_expected
- if $will_overflow || $this_expected_len
- < $this_needed_to_discern_len;
-
- 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 "))
- {
- like($warnings[0], $message,
- "$this_name: Got expected warning")
- or 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);
- is($ret_ref->[0], 0,
- "$this_name, CHECK_ONLY: Returns 0")
- or diag $call;
- is($ret_ref->[1], -1,
- "$this_name: CHECK_ONLY: returns -1 for length")
- or 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 "\$!='$!'; eval'd=\"$eval_text\"";
- next;
- }
- if ($disallowed) {
- is($ret, undef, "$this_name: Returns undef")
- or diag $call;
- }
- else {
- is($ret, $bytes, "$this_name: Returns expected string")
- or 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 "))
- {
- like($warnings[0], $message,
- "$this_name: Got expected warning")
- or diag $call;
- }
- else {
- diag $call;
- output_warnings(@warnings)
- if scalar @warnings;
- }
- }
- }
- }
- }
- }
- }
- }
- }
-}
-
SKIP:
{
isASCII
--- /dev/null
+#!perl -w
+
+# Test handling of various UTF-8 malformations
+
+use strict;
+use Test::More;
+
+BEGIN {
+ use_ok('XS::APItest');
+ require 'charset_tools.pl';
+ require './t/utf8_setup.pl';
+};
+
+$|=1;
+
+no warnings 'deprecated'; # Some of the below are above IV_MAX on 32 bit
+ # machines, and that is tested elsewhere
+
+use XS::APItest;
+
+my @warnings;
+
+use warnings 'utf8';
+local $SIG{__WARN__} = sub { push @warnings, @_ };
+
+my $I8c = $::I8c;
+
+my $REPLACEMENT = 0xFFFD;
+
+# Now test the malformations. All these raise category utf8 warnings.
+my @malformations = (
+ # ($testname, $bytes, $length, $allow_flags, $expected_error_flags,
+ # $allowed_uv, $expected_len, $needed_to_discern_len, $message )
+
+# Now considered a program bug, and asserted against
+ #[ "zero length string malformation", "", 0,
+ # $::UTF8_ALLOW_EMPTY, $::UTF8_GOT_EMPTY, $REPLACEMENT, 0, 0,
+ # qr/empty string/
+ #],
+ [ "orphan continuation byte malformation", I8_to_native("${I8c}a"), 2,
+ $::UTF8_ALLOW_CONTINUATION, $::UTF8_GOT_CONTINUATION, $REPLACEMENT,
+ 1, 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, $::UTF8_GOT_NON_CONTINUATION, $REPLACEMENT,
+ 1, 2,
+ qr/unexpected non-continuation byte.*immediately after start byte/
+ ],
+ [ "premature next character malformation (non-immediate)",
+ I8_to_native("\xef${I8c}a"), 3,
+ $::UTF8_ALLOW_NON_CONTINUATION, $::UTF8_GOT_NON_CONTINUATION, $REPLACEMENT,
+ 2, 3,
+ qr/unexpected non-continuation byte .* 2 bytes after start byte/
+ ],
+ [ "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, $::UTF8_GOT_SHORT, $REPLACEMENT,
+ 2, 2,
+ qr/2 bytes available, need 4/
+ ],
+ [ "overlong malformation, lowest 2-byte",
+ (isASCII) ? "\xc0\x80" : I8_to_native("\xc0\xa0"),
+ 2,
+ $::UTF8_ALLOW_LONG, $::UTF8_GOT_LONG,
+ 0, # NUL
+ 2, 1,
+ qr/overlong/
+ ],
+ [ "overlong malformation, highest 2-byte",
+ (isASCII) ? "\xc1\xbf" : I8_to_native("\xc4\xbf"),
+ 2,
+ $::UTF8_ALLOW_LONG, $::UTF8_GOT_LONG,
+ (isASCII) ? 0x7F : utf8::unicode_to_native(0x9F),
+ 2, 1,
+ qr/overlong/
+ ],
+ [ "overlong malformation, lowest 3-byte",
+ (isASCII) ? "\xe0\x80\x80" : I8_to_native("\xe0\xa0\xa0"),
+ 3,
+ $::UTF8_ALLOW_LONG, $::UTF8_GOT_LONG,
+ 0, # NUL
+ 3, (isASCII) ? 2 : 1,
+ qr/overlong/
+ ],
+ [ "overlong malformation, highest 3-byte",
+ (isASCII) ? "\xe0\x9f\xbf" : I8_to_native("\xe0\xbf\xbf"),
+ 3,
+ $::UTF8_ALLOW_LONG, $::UTF8_GOT_LONG,
+ (isASCII) ? 0x7FF : 0x3FF,
+ 3, (isASCII) ? 2 : 1,
+ qr/overlong/
+ ],
+ [ "overlong malformation, lowest 4-byte",
+ (isASCII) ? "\xf0\x80\x80\x80" : I8_to_native("\xf0\xa0\xa0\xa0"),
+ 4,
+ $::UTF8_ALLOW_LONG, $::UTF8_GOT_LONG,
+ 0, # NUL
+ 4, 2,
+ qr/overlong/
+ ],
+ [ "overlong malformation, highest 4-byte",
+ (isASCII) ? "\xf0\x8F\xbf\xbf" : I8_to_native("\xf0\xaf\xbf\xbf"),
+ 4,
+ $::UTF8_ALLOW_LONG, $::UTF8_GOT_LONG,
+ (isASCII) ? 0xFFFF : 0x3FFF,
+ 4, 2,
+ 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_GOT_LONG,
+ 0, # NUL
+ 5, 2,
+ 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_GOT_LONG,
+ (isASCII) ? 0x1FFFFF : 0x3FFFF,
+ 5, 2,
+ 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_GOT_LONG,
+ 0, # NUL
+ 6, 2,
+ 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_GOT_LONG,
+ (isASCII) ? 0x3FFFFFF : 0x3FFFFF,
+ 6, 2,
+ 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_GOT_LONG,
+ 0, # NUL
+ 7, 2,
+ 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_GOT_LONG,
+ (isASCII) ? 0x7FFFFFFF : 0x3FFFFFF,
+ 7, 2,
+ qr/overlong/
+ ],
+);
+
+if (isASCII && ! $::is64bit) { # 32-bit ASCII platform
+ no warnings 'portable';
+ push @malformations,
+ [ "overflow malformation",
+ "\xfe\x84\x80\x80\x80\x80\x80", # Represents 2**32
+ 7,
+ $::UTF8_ALLOW_OVERFLOW, $::UTF8_GOT_OVERFLOW,
+ $REPLACEMENT,
+ 7, 2,
+ qr/overflows/
+ ],
+ [ "overflow malformation",
+ "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80",
+ $::max_bytes,
+ $::UTF8_ALLOW_OVERFLOW, $::UTF8_GOT_OVERFLOW,
+ $REPLACEMENT,
+ $::max_bytes, 1,
+ qr/overflows/
+ ];
+}
+else { # 64-bit ASCII, or EBCDIC of any size.
+ # On EBCDIC platforms, another overlong test is needed even on 32-bit
+ # systems, whereas it doesn't happen on ASCII except on 64-bit ones.
+
+ no warnings 'portable';
+ no warnings 'overflow'; # Doesn't run on 32-bit systems, but compiles
+ push @malformations,
+ [ "overlong malformation, lowest max-byte",
+ (isASCII)
+ ? "\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"),
+ $::max_bytes,
+ $::UTF8_ALLOW_LONG, $::UTF8_GOT_LONG,
+ 0, # NUL
+ $::max_bytes, (isASCII) ? 7 : 8,
+ 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"),
+ $::max_bytes,
+ $::UTF8_ALLOW_LONG, $::UTF8_GOT_LONG,
+ (isASCII) ? 0xFFFFFFFFF : 0x3FFFFFFF,
+ $::max_bytes, (isASCII) ? 7 : 8,
+ qr/overlong/,
+ ];
+
+ if (! $::is64bit) { # 32-bit EBCDIC
+ push @malformations,
+ [ "overflow malformation",
+ I8_to_native(
+ "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa4\xa0\xa0\xa0\xa0\xa0\xa0"),
+ $::max_bytes,
+ $::UTF8_ALLOW_OVERFLOW, $::UTF8_GOT_OVERFLOW,
+ $REPLACEMENT,
+ $::max_bytes, 8,
+ qr/overflows/
+ ];
+ }
+ else { # 64-bit, either ASCII or EBCDIC
+ push @malformations,
+ [ "overflow malformation",
+ (isASCII)
+ ? "\xff\x80\x90\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"
+ : I8_to_native(
+ "\xff\xb0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
+ $::max_bytes,
+ $::UTF8_ALLOW_OVERFLOW, $::UTF8_GOT_OVERFLOW,
+ $REPLACEMENT,
+ $::max_bytes, (isASCII) ? 3 : 2,
+ qr/overflows/
+ ];
+ }
+}
+
+# For each overlong malformation in the list, we modify it, so that there are
+# two tests. The first one returns the replacement character given the input
+# flags, and the second test adds a flag that causes the actual code point the
+# malformation represents to be returned.
+my @added_overlongs;
+foreach my $test (@malformations) {
+ my ($testname, $bytes, $length, $allow_flags, $expected_error_flags,
+ $allowed_uv, $expected_len, $needed_to_discern_len, $message ) = @$test;
+ next unless $testname =~ /overlong/;
+
+ $test->[0] .= "; use REPLACEMENT CHAR";
+ $test->[5] = $REPLACEMENT;
+
+ push @added_overlongs,
+ [ $testname . "; use actual value",
+ $bytes, $length,
+ $allow_flags | $::UTF8_ALLOW_LONG_AND_ITS_VALUE,
+ $expected_error_flags, $allowed_uv, $expected_len,
+ $needed_to_discern_len, $message
+ ];
+}
+push @malformations, @added_overlongs;
+
+foreach my $test (@malformations) {
+ my ($testname, $bytes, $length, $allow_flags, $expected_error_flags,
+ $allowed_uv, $expected_len, $needed_to_discern_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;
+
+ my $ret = test_isUTF8_CHAR($bytes, $length);
+ is($ret, 0, "$testname: isUTF8_CHAR returns 0");
+ is(scalar @warnings, 0, "$testname: isUTF8_CHAR() generated no warnings")
+ or output_warnings(@warnings);
+
+ undef @warnings;
+
+ $ret = test_isUTF8_CHAR_flags($bytes, $length, 0);
+ is($ret, 0, "$testname: isUTF8_CHAR_flags returns 0");
+ is(scalar @warnings, 0, "$testname: isUTF8_CHAR_flags() generated no"
+ . " warnings")
+ or output_warnings(@warnings);
+
+ $ret = test_isSTRICT_UTF8_CHAR($bytes, $length);
+ is($ret, 0, "$testname: isSTRICT_UTF8_CHAR returns 0");
+ is(scalar @warnings, 0,
+ "$testname: isSTRICT_UTF8_CHAR() generated no warnings")
+ or output_warnings(@warnings);
+
+ $ret = test_isC9_STRICT_UTF8_CHAR($bytes, $length);
+ is($ret, 0, "$testname: isC9_STRICT_UTF8_CHAR returns 0");
+ is(scalar @warnings, 0,
+ "$testname: isC9_STRICT_UTF8_CHAR() generated no warnings")
+ or output_warnings(@warnings);
+
+ for my $j (1 .. $length - 1) {
+ my $partial = substr($bytes, 0, $j);
+
+ undef @warnings;
+
+ $ret = test_is_utf8_valid_partial_char_flags($bytes, $j, 0);
+
+ my $ret_should_be = 0;
+ my $comment = "";
+ if ($j < $needed_to_discern_len) {
+ $ret_should_be = 1;
+ $comment = ", but need $needed_to_discern_len bytes to discern:";
+ }
+
+ is($ret, $ret_should_be, "$testname: is_utf8_valid_partial_char_flags("
+ . display_bytes($partial)
+ . ")$comment returns $ret_should_be");
+ is(scalar @warnings, 0,
+ "$testname: is_utf8_valid_partial_char_flags() generated"
+ . " no warnings")
+ or output_warnings(@warnings);
+ }
+
+
+ # Test what happens when this malformation is not allowed
+ undef @warnings;
+ 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_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) {
+ 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_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_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"))
+ {
+ 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_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"))
+ {
+ output_warnings(@warnings);
+ }
+ is($ret_ref->[2], $expected_error_flags,
+ "$testname: utf8n_to_uvchr_error(), disallowed: Returns"
+ . " expected error");
+}
+
+done_testing;
--- /dev/null
+# Common subroutines and constants, called by .t files in this directory that
+# deal with UTF-8
+
+# The test files 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 the
+# translation functions to/from I8 from that file instead.
+
+sub isASCII { ord "A" == 65 }
+
+sub display_bytes {
+ use bytes;
+ my $string = shift;
+ return '"'
+ . join("", map { sprintf("\\x%02x", ord $_) } split "", $string)
+ . '"';
+}
+
+sub output_warnings(@) {
+ diag "The warnings were:\n" . join("", @_);
+}
+
+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 "start_byte_to_cont() is expecting a UTF-8 variant";
+ }
+
+ $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 : 0xA0;
+ return I8_to_native(chr $byte);
+}
+
+$::is64bit = length sprintf("%x", ~0) > 8;
+
+$::first_continuation = (isASCII) ? 0x80 : 0xA0;
+
+$::I8c = (isASCII) ? "\x80" : "\xa0"; # A continuation byte
+
+
+$::max_bytes = (isASCII) ? 13 : 14; # Max number of bytes in a UTF-8 sequence
+ # representing a single code point
+
+# Copied from utf8.h
+$::UTF8_ALLOW_EMPTY = 0x0001;
+$::UTF8_GOT_EMPTY = $UTF8_ALLOW_EMPTY;
+$::UTF8_ALLOW_CONTINUATION = 0x0002;
+$::UTF8_GOT_CONTINUATION = $UTF8_ALLOW_CONTINUATION;
+$::UTF8_ALLOW_NON_CONTINUATION = 0x0004;
+$::UTF8_GOT_NON_CONTINUATION = $UTF8_ALLOW_NON_CONTINUATION;
+$::UTF8_ALLOW_SHORT = 0x0008;
+$::UTF8_GOT_SHORT = $UTF8_ALLOW_SHORT;
+$::UTF8_ALLOW_LONG = 0x0010;
+$::UTF8_ALLOW_LONG_AND_ITS_VALUE = $UTF8_ALLOW_LONG|0x0020;
+$::UTF8_GOT_LONG = $UTF8_ALLOW_LONG;
+$::UTF8_ALLOW_OVERFLOW = 0x0080;
+$::UTF8_GOT_OVERFLOW = $UTF8_ALLOW_OVERFLOW;
+$::UTF8_DISALLOW_SURROGATE = 0x0100;
+$::UTF8_GOT_SURROGATE = $UTF8_DISALLOW_SURROGATE;
+$::UTF8_WARN_SURROGATE = 0x0200;
+$::UTF8_DISALLOW_NONCHAR = 0x0400;
+$::UTF8_GOT_NONCHAR = $UTF8_DISALLOW_NONCHAR;
+$::UTF8_WARN_NONCHAR = 0x0800;
+$::UTF8_DISALLOW_SUPER = 0x1000;
+$::UTF8_GOT_SUPER = $UTF8_DISALLOW_SUPER;
+$::UTF8_WARN_SUPER = 0x2000;
+$::UTF8_DISALLOW_ABOVE_31_BIT = 0x4000;
+$::UTF8_GOT_ABOVE_31_BIT = $UTF8_DISALLOW_ABOVE_31_BIT;
+$::UTF8_WARN_ABOVE_31_BIT = 0x8000;
+$::UTF8_CHECK_ONLY = 0x10000;
+$::UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE
+ = $UTF8_DISALLOW_SUPER|$UTF8_DISALLOW_SURROGATE;
+$::UTF8_DISALLOW_ILLEGAL_INTERCHANGE
+ = $UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE|$UTF8_DISALLOW_NONCHAR;
+$::UTF8_WARN_ILLEGAL_C9_INTERCHANGE
+ = $UTF8_WARN_SUPER|$UTF8_WARN_SURROGATE;
+$::UTF8_WARN_ILLEGAL_INTERCHANGE
+ = $UTF8_WARN_ILLEGAL_C9_INTERCHANGE|$UTF8_WARN_NONCHAR;
+
+# Test uvchr_to_utf8().
+$::UNICODE_WARN_SURROGATE = 0x0001;
+$::UNICODE_WARN_NONCHAR = 0x0002;
+$::UNICODE_WARN_SUPER = 0x0004;
+$::UNICODE_WARN_ABOVE_31_BIT = 0x0008;
+$::UNICODE_DISALLOW_SURROGATE = 0x0010;
+$::UNICODE_DISALLOW_NONCHAR = 0x0020;
+$::UNICODE_DISALLOW_SUPER = 0x0040;
+$::UNICODE_DISALLOW_ABOVE_31_BIT = 0x0080;
--- /dev/null
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 0;
+
+do './t/utf8_warn_base.pl';
--- /dev/null
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 1;
+
+do './t/utf8_warn_base.pl';
--- /dev/null
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 2;
+
+do './t/utf8_warn_base.pl';
--- /dev/null
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 3;
+
+do './t/utf8_warn_base.pl';
--- /dev/null
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 4;
+
+do './t/utf8_warn_base.pl';
--- /dev/null
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 5;
+
+do './t/utf8_warn_base.pl';
--- /dev/null
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 6;
+
+do './t/utf8_warn_base.pl';
--- /dev/null
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 7;
+
+do './t/utf8_warn_base.pl';
--- /dev/null
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 8;
+
+do './t/utf8_warn_base.pl';
--- /dev/null
+use strict;
+use warnings;
+no warnings 'once';
+
+$::TEST_CHUNK = 9;
+
+do './t/utf8_warn_base.pl';
--- /dev/null
+#!perl -w
+
+# This is a base file to be used by various .t's in its directory
+
+use strict;
+use Test::More;
+
+BEGIN {
+ use_ok('XS::APItest');
+ require 'charset_tools.pl';
+ require './t/utf8_setup.pl';
+};
+
+$|=1;
+
+no warnings 'deprecated'; # Some of the below are above IV_MAX on 32 bit
+ # machines, and that is tested elsewhere
+
+use XS::APItest;
+use Data::Dumper;
+
+my @warnings;
+
+use warnings 'utf8';
+local $SIG{__WARN__} = sub { push @warnings, @_ };
+
+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
+# be allowed/warned on.
+my @tests = (
+ # ($testname, $bytes, $warn_flags, $disallow_flags, $expected_error_flags,
+ # $category, $allowed_uv, $expected_len, $needed_to_discern_len, $message )
+ [ "lowest surrogate",
+ (isASCII) ? "\xed\xa0\x80" : I8_to_native("\xf1\xb6\xa0\xa0"),
+ $::UTF8_WARN_SURROGATE, $::UTF8_DISALLOW_SURROGATE, $::UTF8_GOT_SURROGATE,
+ 'surrogate', 0xD800,
+ (isASCII) ? 3 : 4,
+ 2,
+ qr/surrogate/
+ ],
+ [ "a middle surrogate",
+ (isASCII) ? "\xed\xa4\x8d" : I8_to_native("\xf1\xb6\xa8\xad"),
+ $::UTF8_WARN_SURROGATE, $::UTF8_DISALLOW_SURROGATE, $::UTF8_GOT_SURROGATE,
+ 'surrogate', 0xD90D,
+ (isASCII) ? 3 : 4,
+ 2,
+ qr/surrogate/
+ ],
+ [ "highest surrogate",
+ (isASCII) ? "\xed\xbf\xbf" : I8_to_native("\xf1\xb7\xbf\xbf"),
+ $::UTF8_WARN_SURROGATE, $::UTF8_DISALLOW_SURROGATE, $::UTF8_GOT_SURROGATE,
+ 'surrogate', 0xDFFF,
+ (isASCII) ? 3 : 4,
+ 2,
+ 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_GOT_SUPER,
+ 'non_unicode', 0x110000,
+ (isASCII) ? 4 : 5,
+ 2,
+ 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_GOT_SUPER,
+ 'non_unicode',
+ (isASCII) ? 0x140000 : 0x200000,
+ (isASCII) ? 4 : 5,
+ 1,
+ 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_GOT_NONCHAR,
+ 'nonchar', 0xFDD0,
+ (isASCII) ? 3 : 4,
+ (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_GOT_NONCHAR,
+ 'nonchar', 0xFDE0,
+ (isASCII) ? 3 : 4,
+ (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_GOT_NONCHAR,
+ 'nonchar', 0xFDEF,
+ (isASCII) ? 3 : 4,
+ (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_GOT_NONCHAR,
+ 'nonchar', 0xFFFE,
+ (isASCII) ? 3 : 4,
+ (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_GOT_NONCHAR,
+ 'nonchar', 0xFFFF,
+ (isASCII) ? 3 : 4,
+ (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_GOT_NONCHAR,
+ 'nonchar', 0x1FFFE,
+ 4, 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_GOT_NONCHAR,
+ 'nonchar', 0x1FFFF,
+ 4, 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_GOT_NONCHAR,
+ 'nonchar', 0x2FFFE,
+ 4, 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_GOT_NONCHAR,
+ 'nonchar', 0x2FFFF,
+ 4, 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_GOT_NONCHAR,
+ 'nonchar', 0x3FFFE,
+ 4, 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_GOT_NONCHAR,
+ 'nonchar', 0x3FFFF,
+ 4, 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_GOT_NONCHAR,
+ 'nonchar', 0x4FFFE,
+ (isASCII) ? 4 : 5,
+ (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_GOT_NONCHAR,
+ 'nonchar', 0x4FFFF,
+ (isASCII) ? 4 : 5,
+ (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_GOT_NONCHAR,
+ 'nonchar', 0x5FFFE,
+ (isASCII) ? 4 : 5,
+ (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_GOT_NONCHAR,
+ 'nonchar', 0x5FFFF,
+ (isASCII) ? 4 : 5,
+ (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_GOT_NONCHAR,
+ 'nonchar', 0x6FFFE,
+ (isASCII) ? 4 : 5,
+ (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_GOT_NONCHAR,
+ 'nonchar', 0x6FFFF,
+ (isASCII) ? 4 : 5,
+ (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_GOT_NONCHAR,
+ 'nonchar', 0x7FFFE,
+ (isASCII) ? 4 : 5,
+ (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_GOT_NONCHAR,
+ 'nonchar', 0x7FFFF,
+ (isASCII) ? 4 : 5,
+ (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_GOT_NONCHAR,
+ 'nonchar', 0x8FFFE,
+ (isASCII) ? 4 : 5,
+ (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_GOT_NONCHAR,
+ 'nonchar', 0x8FFFF,
+ (isASCII) ? 4 : 5,
+ (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_GOT_NONCHAR,
+ 'nonchar', 0x9FFFE,
+ (isASCII) ? 4 : 5,
+ (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_GOT_NONCHAR,
+ 'nonchar', 0x9FFFF,
+ (isASCII) ? 4 : 5,
+ (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_GOT_NONCHAR,
+ 'nonchar', 0xAFFFE,
+ (isASCII) ? 4 : 5,
+ (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_GOT_NONCHAR,
+ 'nonchar', 0xAFFFF,
+ (isASCII) ? 4 : 5,
+ (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_GOT_NONCHAR,
+ 'nonchar', 0xBFFFE,
+ (isASCII) ? 4 : 5,
+ (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_GOT_NONCHAR,
+ 'nonchar', 0xBFFFF,
+ (isASCII) ? 4 : 5,
+ (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_GOT_NONCHAR,
+ 'nonchar', 0xCFFFE,
+ (isASCII) ? 4 : 5,
+ (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_GOT_NONCHAR,
+ 'nonchar', 0xCFFFF,
+ (isASCII) ? 4 : 5,
+ (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_GOT_NONCHAR,
+ 'nonchar', 0xDFFFE,
+ (isASCII) ? 4 : 5,
+ (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_GOT_NONCHAR,
+ 'nonchar', 0xDFFFF,
+ (isASCII) ? 4 : 5,
+ (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_GOT_NONCHAR,
+ 'nonchar', 0xEFFFE,
+ (isASCII) ? 4 : 5,
+ (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_GOT_NONCHAR,
+ 'nonchar', 0xEFFFF,
+ (isASCII) ? 4 : 5,
+ (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_GOT_NONCHAR,
+ 'nonchar', 0xFFFFE,
+ (isASCII) ? 4 : 5,
+ (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_GOT_NONCHAR,
+ 'nonchar', 0xFFFFF,
+ (isASCII) ? 4 : 5,
+ (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_GOT_NONCHAR,
+ 'nonchar', 0x10FFFE,
+ (isASCII) ? 4 : 5,
+ (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_GOT_NONCHAR,
+ 'nonchar', 0x10FFFF,
+ (isASCII) ? 4 : 5,
+ (isASCII) ? 4 : 5,
+ qr/Unicode non-character.*is not recommended for open interchange/
+ ],
+ [ "requires at least 32 bits",
+ (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"),
+ # 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 : $::max_bytes,
+ (isASCII) ? 1 : 8,
+ nonportable_regex(0x80000000)
+ ],
+ [ "highest 32 bit code point",
+ (isASCII)
+ ? "\xfe\x83\xbf\xbf\xbf\xbf\xbf"
+ : I8_to_native(
+ "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa3\xbf\xbf\xbf\xbf\xbf\xbf"),
+ $::UTF8_WARN_ABOVE_31_BIT, $::UTF8_DISALLOW_ABOVE_31_BIT,
+ $::UTF8_GOT_ABOVE_31_BIT,
+ 'utf8', 0xFFFFFFFF,
+ (isASCII) ? 7 : $::max_bytes,
+ (isASCII) ? 1 : 8,
+ nonportable_regex(0xffffffff)
+ ],
+ [ "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_GOT_SUPER,
+ 'utf8', 0x80000000,
+ (isASCII) ? 7 : $::max_bytes,
+ 1,
+ 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
+ # with overflow. The overflow malformation is never allowed, so
+ # preventing it takes precedence if the ABOVE_31_BIT options would
+ # otherwise allow in an overflowing value. The ASCII code points (1
+ # for 32-bits; 1 for 64) were chosen because the old overflow
+ # detection algorithm did not catch them; this means this test also
+ # checks for that fix. The EBCDIC are arbitrary overflowing ones
+ # since we have no reports of failures with it.
+ (($::is64bit)
+ ? ((isASCII)
+ ? "\xff\x80\x90\x90\x90\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf"
+ : I8_to_native(
+ "\xff\xB0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"))
+ : ((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"))),
+ $::UTF8_WARN_ABOVE_31_BIT,
+ $::UTF8_DISALLOW_ABOVE_31_BIT,
+ $::UTF8_GOT_ABOVE_31_BIT,
+ 'utf8', 0,
+ (! isASCII || $::is64bit) ? $::max_bytes : 7,
+ (isASCII || $::is64bit) ? 2 : 8,
+ qr/overflows/
+ ],
+);
+
+if (! $::is64bit) {
+ if (isASCII) {
+ no warnings qw{portable overflow};
+ push @tests,
+ [ "Lowest 33 bit code point: overflow",
+ "\xFE\x84\x80\x80\x80\x80\x80",
+ $::UTF8_WARN_ABOVE_31_BIT, $::UTF8_DISALLOW_ABOVE_31_BIT,
+ $::UTF8_GOT_ABOVE_31_BIT,
+ 'utf8', 0x100000000,
+ 7, 1,
+ qr/and( is)? not portable/
+ ];
+ }
+}
+else {
+ no warnings qw{portable overflow};
+ push @tests,
+ [ "More than 32 bits",
+ (isASCII)
+ ? "\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,
+ $::max_bytes, (isASCII) ? 1 : 7,
+ 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,
+ $::max_bytes, 7,
+ 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,
+ $::max_bytes, 6,
+ 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,
+ $::max_bytes, 5,
+ 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,
+ $::max_bytes, 4,
+ 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,
+ $::max_bytes, 3,
+ 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"),
+ $::UTF8_WARN_ABOVE_31_BIT,$::UTF8_DISALLOW_ABOVE_31_BIT,
+ $::UTF8_GOT_ABOVE_31_BIT,
+ 'utf8', 0x1000000000000000,
+ $::max_bytes, 2,
+ nonportable_regex(0x1000000000000000)
+ ];
+ }
+}
+
+# This test is split into this number of files.
+my $num_test_files = $ENV{TEST_JOBS} || 1;
+$num_test_files = 10 if $num_test_files > 10;
+
+my $test_count = -1;
+foreach my $test (@tests) {
+ $test_count++;
+ next if $test_count % $num_test_files != $::TEST_CHUNK;
+
+ my ($testname, $bytes, $warn_flags, $disallow_flags, $expected_error_flags,
+ $category, $allowed_uv, $expected_len, $needed_to_discern_len, $message
+ ) = @$test;
+
+ my $length = length $bytes;
+ my $will_overflow = $testname =~ /overflow/ ? 'overflow' : "";
+
+ {
+ use warnings;
+ undef @warnings;
+ my $ret = test_isUTF8_CHAR($bytes, $length);
+ my $ret_flags = test_isUTF8_CHAR_flags($bytes, $length, 0);
+ if ($will_overflow) {
+ is($ret, 0, "isUTF8_CHAR() $testname: returns 0");
+ is($ret_flags, 0, "isUTF8_CHAR_flags() $testname: returns 0");
+ }
+ else {
+ is($ret, $length,
+ "isUTF8_CHAR() $testname: returns expected length: $length");
+ is($ret_flags, $length, "isUTF8_CHAR_flags(...,0) $testname:"
+ . " returns expected length: $length");
+ }
+ is(scalar @warnings, 0,
+ "isUTF8_CHAR() and isUTF8_CHAR()_flags $testname: generated"
+ . " no warnings")
+ or output_warnings(@warnings);
+
+ undef @warnings;
+ $ret = test_isSTRICT_UTF8_CHAR($bytes, $length);
+ if ($will_overflow) {
+ is($ret, 0, "isSTRICT_UTF8_CHAR() $testname: returns 0");
+ }
+ else {
+ my $expected_ret = ( $testname =~ /surrogate|non-character/
+ || $allowed_uv > 0x10FFFF)
+ ? 0
+ : $length;
+ is($ret, $expected_ret, "isSTRICT_UTF8_CHAR() $testname: returns"
+ . " expected length: $expected_ret");
+ $ret = test_isUTF8_CHAR_flags($bytes, $length,
+ $::UTF8_DISALLOW_ILLEGAL_INTERCHANGE);
+ is($ret, $expected_ret,
+ "isUTF8_CHAR_flags('DISALLOW_ILLEGAL_INTERCHANGE')"
+ . " acts like isSTRICT_UTF8_CHAR");
+ }
+ is(scalar @warnings, 0,
+ "isSTRICT_UTF8_CHAR() and isUTF8_CHAR_flags $testname:"
+ . " generated no warnings")
+ or output_warnings(@warnings);
+
+ undef @warnings;
+ $ret = test_isC9_STRICT_UTF8_CHAR($bytes, $length);
+ if ($will_overflow) {
+ is($ret, 0, "isC9_STRICT_UTF8_CHAR() $testname: returns 0");
+ }
+ else {
+ my $expected_ret = ( $testname =~ /surrogate/
+ || $allowed_uv > 0x10FFFF)
+ ? 0
+ : $length;
+ is($ret, $expected_ret, "isC9_STRICT_UTF8_CHAR() $testname:"
+ ." returns expected length: $expected_ret");
+ $ret = test_isUTF8_CHAR_flags($bytes, $length,
+ $::UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE);
+ is($ret, $expected_ret,
+ "isUTF8_CHAR_flags('DISALLOW_ILLEGAL_C9_INTERCHANGE')"
+ . " acts like isC9_STRICT_UTF8_CHAR");
+ }
+ is(scalar @warnings, 0,
+ "isC9_STRICT_UTF8_CHAR() and isUTF8_CHAR_flags $testname:"
+ . " generated no warnings")
+ or output_warnings(@warnings);
+
+ # Test partial character handling, for each byte not a full character
+ for my $j (1.. $length - 1) {
+
+ # Skip the test for the interaction between overflow and above-31
+ # bit. It is really testing other things than the partial
+ # character tests, for which other tests in this file are
+ # sufficient
+ last if $testname =~ /overflow/;
+
+ foreach my $disallow_flag (0, $disallow_flags) {
+ my $partial = substr($bytes, 0, $j);
+ my $ret_should_be;
+ my $comment;
+ if ($disallow_flag) {
+ $ret_should_be = 0;
+ $comment = "disallowed";
+ if ($j < $needed_to_discern_len) {
+ $ret_should_be = 1;
+ $comment .= ", but need $needed_to_discern_len bytes"
+ . " to discern:";
+ }
+ }
+ else {
+ $ret_should_be = 1;
+ $comment = "allowed";
+ }
+
+ undef @warnings;
+
+ $ret = test_is_utf8_valid_partial_char_flags($partial, $j,
+ $disallow_flag);
+ is($ret, $ret_should_be,
+ "$testname: is_utf8_valid_partial_char_flags("
+ . display_bytes($partial)
+ . "), $comment: returns $ret_should_be");
+ is(scalar @warnings, 0,
+ "$testname: is_utf8_valid_partial_char_flags()"
+ . " generated no warnings")
+ or output_warnings(@warnings);
+ }
+ }
+ }
+
+ # This is more complicated than the malformations tested earlier, as there
+ # are several orthogonal variables involved. We test all the subclasses
+ # of utf8 warnings to verify they work with and without the utf8 class,
+ # and don't have effects on other sublass warnings
+ foreach my $warning ('utf8', 'surrogate', 'nonchar', 'non_unicode') {
+ foreach my $warn_flag (0, $warn_flags) {
+ foreach my $disallow_flag (0, $disallow_flags) {
+ foreach my $do_warning (0, 1) {
+
+ # We try each of the above with various combinations of
+ # malformations that can occur on the same input sequence.
+ foreach my $short ("", "short") {
+ foreach my $unexpected_noncont ("",
+ "unexpected non-continuation")
+ {
+ foreach my $overlong ("", "overlong") {
+
+ # If we're already at the longest possible, we
+ # can't create an overlong (which would be longer)
+ # can't handle anything larger.
+ next if $overlong && $expected_len >= $::max_bytes;
+
+ my @malformations;
+ my @expected_errors;
+ push @malformations, $short if $short;
+ push @malformations, $unexpected_noncont
+ if $unexpected_noncont;
+ 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;
+ }
+
+ 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;
+ my $this_needed_to_discern_len = $needed_to_discern_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
+ = I8_to_native("\xff")
+ . (I8_to_native(chr $::first_continuation)
+ x ( $::max_bytes - 1 - length($this_bytes)))
+ . $this_bytes;
+ $this_length = length($this_bytes);
+ $this_needed_to_discern_len
+ = $::max_bytes - ($this_expected_len
+ - $this_needed_to_discern_len);
+ $this_expected_len = $::max_bytes;
+ 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;
+ }
+ if ($malformations_name
+ =~ /non-continuation/)
+ {
+ # Change the final continuation byte into
+ # a non one.
+ my $pos = ($short) ? -2 : -1;
+ substr($this_bytes, $pos, 1) = '?';
+ $this_expected_len--;
+ push @expected_errors,
+ $::UTF8_GOT_NON_CONTINUATION;
+ }
+ }
+
+ 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 "\$!='$!'; eval'd=\"$call\"";
+ next;
+ }
+ if ($disallowed) {
+ is($ret_ref->[0], 0, "$this_name: Returns 0")
+ or diag $call;
+ }
+ else {
+ is($ret_ref->[0], $expected_uv,
+ "$this_name: Returns expected uv: "
+ . sprintf("0x%04X", $expected_uv))
+ or diag $call;
+ }
+ is($ret_ref->[1], $this_expected_len,
+ "$this_name: Returns expected length:"
+ . " $this_expected_len")
+ or diag $call;
+
+ my $errors = $ret_ref->[2];
+
+ 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;
+ }
+ is(scalar @expected_errors, 0,
+ "Got all the expected malformation errors")
+ or diag Dumper \@expected_errors;
+
+ if ( $this_expected_len >= $this_needed_to_discern_len
+ && ($warn_flag || $disallow_flag))
+ {
+ is($errors, $expected_error_flags,
+ "Got the correct error flag")
+ or diag $call;
+ }
+ else {
+ is($errors, 0, "Got no other error 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");
+
+ }
+ }
+
+ # Any overflow will override any super or above-31
+ # warnings.
+ goto no_warnings_expected
+ if $will_overflow || $this_expected_len
+ < $this_needed_to_discern_len;
+
+ 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 "))
+ {
+ like($warnings[0], $message,
+ "$this_name: Got expected warning")
+ or 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);
+ is($ret_ref->[0], 0,
+ "$this_name, CHECK_ONLY: Returns 0")
+ or diag $call;
+ is($ret_ref->[1], -1,
+ "$this_name: CHECK_ONLY: returns -1 for length")
+ or 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 "\$!='$!'; eval'd=\"$eval_text\"";
+ next;
+ }
+ if ($disallowed) {
+ is($ret, undef, "$this_name: Returns undef")
+ or diag $call;
+ }
+ else {
+ is($ret, $bytes, "$this_name: Returns expected string")
+ or 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 "))
+ {
+ like($warnings[0], $message,
+ "$this_name: Got expected warning")
+ or diag $call;
+ }
+ else {
+ diag $call;
+ output_warnings(@warnings)
+ if scalar @warnings;
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+}
+
+done_testing;
/* check locally for a real method or a cache entry */
he = (HE*)hv_common(
- cachestash, meth, name, len, (flags & SVf_UTF8) ? HVhek_UTF8 : 0, create, NULL, 0
+ cachestash, meth, name, len, is_utf8 ? HVhek_UTF8 : 0, create, NULL, 0
);
if (he) gvp = (GV**)&HeVAL(he);
else gvp = NULL;
name_cursor++;
*name = name_cursor+1;
if (*name == name_end) {
- if (!*gv)
- *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
+ if (!*gv) {
+ *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
+ if (SvTYPE(*gv) != SVt_PVGV) {
+ gv_init_pvn(*gv, PL_defstash, "main::", 6,
+ GV_ADDMULTI);
+ GvHV(*gv) =
+ MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
+ }
+ }
return TRUE;
}
}
#define strnNE(s1,s2,l) (strncmp(s1,s2,l))
#define strnEQ(s1,s2,l) (!strncmp(s1,s2,l))
+/* These names are controversial, so guarding against their being used in more
+ * places than they already are. strBEGs and StrStartsWith are potential
+ * candidates */
+#if defined(PERL_IN_DOIO_C) || defined(PERL_IN_GV_C) || defined(PERL_IN_HV_C) || defined(PERL_IN_LOCALE_C) || defined(PERL_IN_PERL_C) || defined(PERL_IN_TOKE_C) || defined(PERL_EXT)
#define strNEs(s1,s2) (strncmp(s1,"" s2 "", sizeof(s2)-1))
#define strEQs(s1,s2) (!strncmp(s1,"" s2 "", sizeof(s2)-1))
+#endif
#ifdef HAS_MEMCMP
# define memNE(s1,s2,l) (memcmp(s1,s2,l))
# 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.9
+# mkdir -p /opt/perl-catamount/lib/perl5/5.25.10
# 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.9
+# cp -pr lib/* /opt/perl-catamount/lib/perl5/5.25.10
# 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
flags = is_utf8 ? HVhek_UTF8 : 0;
}
} else {
- is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
+ is_utf8 = cBOOL(flags & HVhek_UTF8);
}
if (action & HV_DELETE) {
}
sv = sv_newmortal();
- if (HvUSEDKEYS((const HV *)hv))
+ if (HvUSEDKEYS((HV *)hv))
Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
(long)HvFILL(hv), (long)HvMAX(hv) + 1);
else
HE *entry;
HE **oentry;
HE **first_entry;
- bool is_utf8 = (k_flags & HVhek_UTF8) ? TRUE : FALSE;
+ bool is_utf8 = cBOOL(k_flags & HVhek_UTF8);
int masked_flags;
HEK *keysv_hek = NULL;
U8 mro_changes = 0; /* 1 = isa; 2 = package moved */
((SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name && HvAUX(hv)->xhv_name_count != -1) \
? HEK_UTF8(HvENAME_HEK_NN(hv)) : 0)
-/* the number of keys (including any placeholders) */
+/* the number of keys (including any placeholders) - NOT PART OF THE API */
#define XHvTOTALKEYS(xhv) ((xhv)->xhv_keys)
/*
(val), (hash)))
#define hv_exists_ent(hv, keysv, hash) \
- (hv_common((hv), (keysv), NULL, 0, 0, HV_FETCH_ISEXISTS, 0, (hash)) \
- ? TRUE : FALSE)
+ cBOOL(hv_common((hv), (keysv), NULL, 0, 0, HV_FETCH_ISEXISTS, 0, (hash)))
#define hv_fetch_ent(hv, keysv, lval, hash) \
((HE *) hv_common((hv), (keysv), NULL, 0, 0, \
((lval) ? HV_FETCH_LVALUE : 0), NULL, (hash)))
#define hv_exists(hv, key, klen) \
- (hv_common_key_len((hv), (key), (klen), HV_FETCH_ISEXISTS, NULL, 0) \
- ? TRUE : FALSE)
+ cBOOL(hv_common_key_len((hv), (key), (klen), HV_FETCH_ISEXISTS, NULL, 0))
#define hv_fetch(hv, key, klen, lval) \
((SV**) hv_common_key_len((hv), (key), (klen), (lval) \
SvREFCNT_dec(sv);
}
+/* ------------------ util.h ------------------------------------------- */
+
+/*
+=head1 Miscellaneous Functions
+
+=for apidoc foldEQ
+
+Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
+same
+case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
+match themselves and their opposite case counterparts. Non-cased and non-ASCII
+range bytes match only themselves.
+
+=cut
+*/
+
+PERL_STATIC_INLINE I32
+Perl_foldEQ(const char *s1, const char *s2, I32 len)
+{
+ const U8 *a = (const U8 *)s1;
+ const U8 *b = (const U8 *)s2;
+
+ PERL_ARGS_ASSERT_FOLDEQ;
+
+ assert(len >= 0);
+
+ while (len--) {
+ if (*a != *b && *a != PL_fold[*b])
+ return 0;
+ a++,b++;
+ }
+ return 1;
+}
+
+I32
+Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
+{
+ /* Compare non-utf8 using Unicode (Latin1) semantics. Does not work on
+ * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
+ * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these. Nor
+ * does it check that the strings each have at least 'len' characters */
+
+ const U8 *a = (const U8 *)s1;
+ const U8 *b = (const U8 *)s2;
+
+ PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
+
+ assert(len >= 0);
+
+ while (len--) {
+ if (*a != *b && *a != PL_fold_latin1[*b]) {
+ return 0;
+ }
+ a++, b++;
+ }
+ return 1;
+}
+
+/*
+=for apidoc foldEQ_locale
+
+Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
+same case-insensitively in the current locale; false otherwise.
+
+=cut
+*/
+
+I32
+Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
+{
+ dVAR;
+ const U8 *a = (const U8 *)s1;
+ const U8 *b = (const U8 *)s2;
+
+ PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
+
+ assert(len >= 0);
+
+ while (len--) {
+ if (*a != *b && *a != PL_fold_locale[*b])
+ return 0;
+ a++,b++;
+ }
+ return 1;
+}
+
/*
* ex: set ts=8 sts=4 sw=4 et:
*/
our %bits;
-our $VERSION = "5.025009";
+our $VERSION = "5.025010";
$bits{$_}{3} = 'OPpENTERSUB_AMPER' for qw(entersub rv2cv);
$bits{$_}{6} = 'OPpENTERSUB_DB' for qw(entersub rv2cv);
=head1 NAME
-getopt, getopts - Process single-character switches with switch clustering
+Getopt::Std - Process single-character switches with switch clustering
=head1 SYNOPSIS
@ISA = qw(Exporter);
@EXPORT = qw(getopt getopts);
-$VERSION = '1.11';
+$VERSION = '1.12';
# uncomment the next line to disable 1.03-backward compatibility paranoia
# $STANDARD_HELP_VERSION = 1;
package PerlIO;
-our $VERSION = '1.09';
+our $VERSION = '1.10';
# Map layer name to package that defines it
our %alias;
digits and common punctuation) human readable in the encoded file.
(B<CAUTION>: This layer does not validate byte sequences. For reading input,
-you should instead use C<:encoding(utf8)> instead of bare C<:utf8>.)
+you should instead use C<:encoding(UTF-8)> instead of bare C<:utf8>.)
Here is how to write your native data out using UTF-8 (or UTF-EBCDIC)
and then read it back in.
package feature;
-our $VERSION = '1.46';
+our $VERSION = '1.47';
our %feature = (
fc => 'feature_fc',
=head2 The 'unicode_eval' and 'evalbytes' features
-Under the C<unicode_eval> feature, Perl's C<eval> function, when passed a
-string, will evaluate it as a string of characters, ignoring any
-C<use utf8> declarations. C<use utf8> exists to declare the encoding of
-the script, which only makes sense for a stream of bytes, not a string of
-characters. Source filters are forbidden, as they also really only make
-sense on strings of bytes. Any attempt to activate a source filter will
-result in an error.
-
-The C<evalbytes> feature enables the C<evalbytes> keyword, which evaluates
-the argument passed to it as a string of bytes. It dies if the string
-contains any characters outside the 8-bit range. Source filters work
-within C<evalbytes>: they apply to the contents of the string being
-evaluated.
-
-Together, these two features are intended to replace the historical C<eval>
-function, which has (at least) two bugs in it, that cannot easily be fixed
-without breaking existing programs:
-
-=over
-
-=item *
-
-C<eval> behaves differently depending on the internal encoding of the
-string, sometimes treating its argument as a string of bytes, and sometimes
-as a string of characters.
-
-=item *
-
-Source filters activated within C<eval> leak out into whichever I<file>
-scope is currently being compiled. To give an example with the CPAN module
-L<Semi::Semicolons>:
-
- BEGIN { eval "use Semi::Semicolons; # not filtered here " }
- # filtered here!
-
-C<evalbytes> fixes that to work the way one would expect:
-
- use feature "evalbytes";
- BEGIN { evalbytes "use Semi::Semicolons; # filtered " }
- # not filtered
-
-=back
-
-These two features are available starting with Perl 5.16.
+Together, these two features are intended to replace the legacy string
+C<eval> function, which behaves problematically in some instances. They are
+available starting with Perl 5.16, and are enabled by default by a
+S<C<use 5.16>> or higher declaration.
+
+C<unicode_eval> changes the behavior of plain string C<eval> to work more
+consistently, especially in the Unicode world. Certain (mis)behaviors
+couldn't be changed without breaking some things that had come to rely on
+them, so the feature can be enabled and disabled. Details are at
+L<perlfunc/Under the "unicode_eval" feature>.
+
+C<evalbytes> is like string C<eval>, but operating on a byte stream that is
+not UTF-8 encoded. Details are at L<perlfunc/evalbytes EXPR>. Without a
+S<C<use feature 'evalbytes'>> nor a S<C<use v5.16>> (or higher) declaration in
+the current scope, you can still access it by instead writing
+C<CORE::evalbytes>.
=head2 The 'current_sub' feature
package open;
use warnings;
-our $VERSION = '1.10';
+our $VERSION = '1.11';
require 5.008001; # for PerlIO::get_layers()
use open IO => ':locale';
- use open ':encoding(utf8)';
+ use open ':encoding(UTF-8)';
use open ':locale';
use open ':encoding(iso-8859-7)';
These are equivalent
- use open ':encoding(utf8)';
- use open IO => ':encoding(utf8)';
+ use open ':encoding(UTF-8)';
+ use open IO => ':encoding(UTF-8)';
as are these
the C<:utf8> or C<:encoding> subpragmas, it converts the standard
filehandles (STDIN, STDOUT, STDERR) to comply with encoding selected
for input/output handles. For example, if both input and out are
-chosen to be C<:encoding(utf8)>, a C<:std> will mean that STDIN, STDOUT,
-and STDERR are also in C<:encoding(utf8)>. On the other hand, if only
+chosen to be C<:encoding(UTF-8)>, a C<:std> will mean that STDIN, STDOUT,
+and STDERR are also in C<:encoding(UTF-8)>. On the other hand, if only
output is chosen to be in C<< :encoding(koi8r) >>, a C<:std> will cause
only the STDOUT and STDERR to be in C<koi8r>. The C<:locale> subpragma
implicitly turns on C<:std>.
? "\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;
+ # Cause there to be 'if' statements to only execute a portion of this
+ # long-running test each time, so that we can have a bunch of .t's running
+ # in parallel
+ my $chunks = 10 # Number of test files
+ - 1 # For GCB & SB
+ - 1 # For WB
+ - 4; # LB split into this many files
my @output_chunked;
my $chunk_count=0;
- my $chunk_size= int(@output/10)+1;
+ my $chunk_size= int(@output / $chunks) + 1;
while (@output) {
$chunk_count++;
my @chunk= splice @output, 0, $chunk_size;
push @output_chunked,
- "if (!\$::TESTCHUNK or \$::TESTCHUNK == $chunk_count){\n",
- @chunk,
+ "if (!\$::TESTCHUNK or \$::TESTCHUNK == $chunk_count) {\n",
+ @chunk,
+ "}\n";
+ }
+
+ $chunk_count++;
+ push @output_chunked,
+ "if (!\$::TESTCHUNK or \$::TESTCHUNK == $chunk_count) {\n",
+ (map {" Test_GCB('$_');\n"} @backslash_X_tests),
+ (map {" Test_SB('$_');\n"} @SB_tests),
+ "}\n";
+
+
+ $chunk_size= int(@LB_tests / 4) + 1;
+ @LB_tests = map {" Test_LB('$_');\n"} @LB_tests;
+ while (@LB_tests) {
+ $chunk_count++;
+ my @chunk= splice @LB_tests, 0, $chunk_size;
+ push @output_chunked,
+ "if (!\$::TESTCHUNK or \$::TESTCHUNK == $chunk_count) {\n",
+ @chunk,
"}\n";
}
+ $chunk_count++;
+ push @output_chunked,
+ "if (!\$::TESTCHUNK or \$::TESTCHUNK == $chunk_count) {\n",
+ (map {" Test_WB('$_');\n"} @WB_tests),
+ "}\n";
+
&write($t_path,
0, # Not utf8;
[$HEADER,
= join " . ", map {sprintf 'chr (%d)', ord $_} split //, $char;
push @char, [$_, $char, $charsubst, $char_as_ord];
}
+ my $malformed = $::IS_ASCII
+ ? "\xE1\xA0"
+ : I8_to_native("\xE6\xA0");
# Now we've done all the UTF8 munching hopefully we're safe
my @tests = (
['check our detection program works',
# "out of memory" error. We really need the "" [rather than qq()
# or q()] to get the best explosion.
["!Feed malformed utf8 into perl.", <<"BANG",
- use utf8; %a = ("\xE1\xA0"=>"sterling");
+ use utf8; %a = ("$malformed" =>"sterling");
print 'start'; printf '%x,', ord \$_ foreach keys %a; print "end\n";
BANG
- qr/^Malformed UTF-8 character: .*? \(too short; \d bytes? available, need \d\).*start\d+,end$/sm
+ qr/^Malformed UTF-8 character: .*? \(unexpected non-continuation byte/
],
);
foreach (@tests) {
#endif
#ifdef DEBUGGING
- DEBUG_INITIALIZATION_set((PerlEnv_getenv("PERL_DEBUG_LOCALE_INIT"))
- ? TRUE
- : FALSE);
+ DEBUG_INITIALIZATION_set(cBOOL(PerlEnv_getenv("PERL_DEBUG_LOCALE_INIT")));
# define DEBUG_LOCALE_INIT(category, locale, result) \
STMT_START { \
if (debug_initialization) { \
char * x; /* j's xfrm plus collation index */
STRLEN x_len; /* length of 'x' */
STRLEN trial_len = 1;
+ char cur_source[] = { '\0', '\0' };
- /* Create a 1 byte string of the current code point */
- char cur_source[] = { (char) j, '\0' };
-
+ /* Skip non-controls the first time through the loop. The
+ * controls in a UTF-8 locale are the L1 ones */
if (! try_non_controls && (PL_in_utf8_COLLATE_locale)
? ! isCNTRL_L1(j)
: ! isCNTRL_LC(j))
continue;
}
+ /* Create a 1-char string of the current code point */
+ cur_source[0] = (char) j;
+
/* Then transform it */
x = _mem_collxfrm(cur_source, trial_len, &x_len,
0 /* The string is not in UTF-8 */);
for (j = 1; j < 256; j++) {
char * x;
STRLEN x_len;
+ char cur_source[] = { '\0', '\0' };
- /* Create a 1-char string of the current code point. */
- char cur_source[] = { (char) j, '\0' };
+ /* Create a 1-char string of the current code point */
+ cur_source[0] = (char) j;
/* Then transform it */
x = _mem_collxfrm(cur_source, 1, &x_len, FALSE);
#ifdef DEBUGGING
if (DEBUG_Lv_TEST || debug_initialization) {
- Size_t i;
print_collxfrm_input_and_return(s, s + len, xlen, utf8);
PerlIO_printf(Perl_debug_log, "Its xfrm is:");
- for (i = COLLXFRM_HDR_LEN; i < *xlen + COLLXFRM_HDR_LEN; i++) {
- PerlIO_printf(Perl_debug_log, " %02x", (U8) xbuf[i]);
- }
- PerlIO_printf(Perl_debug_log, "\n");
+ PerlIO_printf(Perl_debug_log, "%s\n",
+ _byte_dump_string((U8 *) xbuf + COLLXFRM_HDR_LEN,
+ *xlen, 1));
}
#endif
{
PERL_ARGS_ASSERT_HV_EXISTS_ENT;
- return hv_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISEXISTS, 0, hash)
- ? TRUE : FALSE;
+ return cBOOL(hv_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISEXISTS, 0, hash));
}
HE *
klen = klen_i32;
flags = 0;
}
- return hv_common(hv, NULL, key, klen, flags, HV_FETCH_ISEXISTS, 0, 0)
- ? TRUE : FALSE;
+ return cBOOL(hv_common(hv, NULL, key, klen, flags, HV_FETCH_ISEXISTS, 0, 0));
}
SV**
const I32 mgs_ix = SSNEW(sizeof(MGS));
bool saved = FALSE;
bool have_new = 0;
+ bool taint_only = TRUE; /* the only get method seen is taint */
MAGIC *newmg, *head, *cur, *mg;
PERL_ARGS_ASSERT_MG_GET;
if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
/* taint's mg get is so dumb it doesn't need flag saving */
- if (!saved && mg->mg_type != PERL_MAGIC_taint) {
- save_magic(mgs_ix, sv);
- saved = TRUE;
- }
+ if (mg->mg_type != PERL_MAGIC_taint) {
+ taint_only = FALSE;
+ if (!saved) {
+ save_magic(mgs_ix, sv);
+ saved = TRUE;
+ }
+ }
vtbl->svt_get(aTHX_ sv, mg);
~(SVs_GMG|SVs_SMG|SVs_RMG);
}
else if (vtbl == &PL_vtbl_utf8) {
- /* get-magic can reallocate the PV */
- magic_setutf8(sv, mg);
+ /* get-magic can reallocate the PV, unless there's only taint
+ * magic */
+ if (taint_only) {
+ MAGIC *mg2;
+ for (mg2 = nextmg; mg2; mg2 = mg2->mg_moremagic) {
+ if ( mg2->mg_type != PERL_MAGIC_taint
+ && !(mg2->mg_flags & MGf_GSKIP)
+ && mg2->mg_virtual
+ && mg2->mg_virtual->svt_get
+ ) {
+ taint_only = FALSE;
+ break;
+ }
+ }
+ }
+ if (!taint_only)
+ magic_setutf8(sv, mg);
}
mg = nextmg;
MAGIC *mg, *prevmg, *moremg;
PERL_ARGS_ASSERT_MG_FREE_TYPE;
for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
- MAGIC *newhead;
moremg = mg->mg_moremagic;
if (mg->mg_type == how) {
+ MAGIC *newhead;
/* temporarily move to the head of the magic chain, in case
custom free code relies on this historical aspect of mg_free */
if (prevmg) {
}
break;
case '\010': /* ^H */
- sv_setiv(sv, (IV)PL_hints);
+ sv_setuv(sv, PL_hints);
break;
case '\011': /* ^I */ /* NOT \t in EBCDIC */
sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
break;
case '\027': /* ^W & $^WARNING_BITS */
if (nextchar == '\0')
- sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
+ sv_setiv(sv, (IV)cBOOL(PL_dowarn & G_WARN_ON));
else if (strEQ(remaining, "ARNING_BITS")) {
if (PL_compiling.cop_warnings == pWARN_NONE) {
sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
#ifdef HAS_GETGROUPS
{
Groups_t *gary = NULL;
- I32 i;
I32 num_groups = getgroups(0, gary);
if (num_groups > 0) {
+ I32 i;
Newx(gary, num_groups, Groups_t);
num_groups = getgroups(num_groups, gary);
for (i = 0; i < num_groups; i++)
SV* const lsv = LvTARG(sv);
SSize_t pos;
STRLEN len;
- STRLEN ulen = 0;
MAGIC* found;
const char *s;
pos = SvIV(sv);
if (DO_UTF8(lsv)) {
- ulen = sv_or_pv_len_utf8(lsv, s, len);
+ const STRLEN ulen = sv_or_pv_len_utf8(lsv, s, len);
if (ulen)
len = ulen;
}
PL_maxsysfd = SvIV(sv);
break;
case '\010': /* ^H */
- PL_hints = SvIV(sv);
+ {
+ U32 save_hints = PL_hints;
+ PL_hints = SvUV(sv);
+
+ /* If wasn't UTF-8, and now is, notify the parser */
+ if ((PL_hints & HINT_UTF8) && ! (save_hints & HINT_UTF8)) {
+ notify_parser_that_changed_to_utf8();
+ }
+ }
break;
case '\011': /* ^I */ /* NOT \t in EBCDIC */
Safefree(PL_inplace);
Perl_opslab_force_free(pTHX_ OPSLAB *slab)
{
OPSLAB *slab2;
- OPSLOT *slot;
#ifdef DEBUGGING
size_t savestack_count = 0;
#endif
PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
slab2 = slab;
do {
+ OPSLOT *slot;
for (slot = slab2->opslab_first;
slot->opslot_next;
slot = slot->opslot_next) {
/* FALLTHROUGH */
case OP_TRANS:
case OP_TRANSR:
- if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
- assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
+ if ( (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
+ && (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)))
+ {
#ifdef USE_ITHREADS
if (cPADOPo->op_padix > 0) {
pad_swipe(cPADOPo->op_padix, TRUE);
dVAR;
OP *kid;
SV* sv;
- U8 want;
SSize_t defer_stack_alloc = 0;
SSize_t defer_ix = -1;
OP **defer_stack = NULL;
PERL_ARGS_ASSERT_SCALARVOID;
do {
+ U8 want;
SV *useless_sv = NULL;
const char* useless = NULL;
S_gen_constant_list(pTHX_ OP *o)
{
dVAR;
- OP *curop;
- const SSize_t oldtmps_floor = PL_tmps_floor;
+ OP *curop, *old_next;
+ SV * const oldwarnhook = PL_warnhook;
+ SV * const olddiehook = PL_diehook;
+ COP *old_curcop;
+ U8 oldwarn = PL_dowarn;
SV **svp;
AV *av;
+ I32 old_cxix;
+ COP not_compiling;
+ int ret = 0;
+ dJMPENV;
+ bool op_was_null;
list(o);
if (PL_parser && PL_parser->error_count)
return o; /* Don't attempt to run with errors */
curop = LINKLIST(o);
+ old_next = o->op_next;
o->op_next = 0;
+ op_was_null = o->op_type == OP_NULL;
+ if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
+ o->op_type = OP_CUSTOM;
CALL_PEEP(curop);
+ if (op_was_null)
+ o->op_type = OP_NULL;
S_prune_chain_head(&curop);
PL_op = curop;
- Perl_pp_pushmark(aTHX);
- CALLRUNOPS(aTHX);
- PL_op = curop;
- assert (!(curop->op_flags & OPf_SPECIAL));
- assert(curop->op_type == OP_RANGE);
- Perl_pp_anonlist(aTHX);
- PL_tmps_floor = oldtmps_floor;
+
+ old_cxix = cxstack_ix;
+ create_eval_scope(NULL, G_FAKINGEVAL);
+
+ old_curcop = PL_curcop;
+ StructCopy(old_curcop, ¬_compiling, COP);
+ PL_curcop = ¬_compiling;
+ /* The above ensures that we run with all the correct hints of the
+ current COP, but that IN_PERL_RUNTIME is true. */
+ assert(IN_PERL_RUNTIME);
+ PL_warnhook = PERL_WARNHOOK_FATAL;
+ PL_diehook = NULL;
+ JMPENV_PUSH(ret);
+
+ /* Effective $^W=1. */
+ if ( ! (PL_dowarn & G_WARN_ALL_MASK))
+ PL_dowarn |= G_WARN_ON;
+
+ switch (ret) {
+ case 0:
+ Perl_pp_pushmark(aTHX);
+ CALLRUNOPS(aTHX);
+ PL_op = curop;
+ assert (!(curop->op_flags & OPf_SPECIAL));
+ assert(curop->op_type == OP_RANGE);
+ Perl_pp_anonlist(aTHX);
+ break;
+ case 3:
+ CLEAR_ERRSV();
+ o->op_next = old_next;
+ break;
+ default:
+ JMPENV_POP;
+ PL_warnhook = oldwarnhook;
+ PL_diehook = olddiehook;
+ Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
+ ret);
+ }
+
+ JMPENV_POP;
+ PL_dowarn = oldwarn;
+ PL_warnhook = oldwarnhook;
+ PL_diehook = olddiehook;
+ PL_curcop = old_curcop;
+
+ if (cxstack_ix > old_cxix) {
+ assert(cxstack_ix == old_cxix + 1);
+ assert(CxTYPE(CX_CUR()) == CXt_EVAL);
+ delete_eval_scope();
+ }
+ if (ret)
+ return o;
OpTYPE_set(o, OP_RV2AV);
o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
rx_flags |= RXf_SPLIT;
}
+ /* Skip compiling if parser found an error for this pattern */
+ if (pm->op_pmflags & PMf_HAS_ERROR) {
+ return o;
+ }
+
if (!has_code || !eng->op_comp) {
/* compile-time simple constant pattern */
op_sibling_splice(o, NULL, 0, first);
/* Implicitly take a reference to a regular expression */
- if (first->op_type == OP_MATCH) {
+ if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
OpTYPE_set(first, OP_QR);
}
- if (second->op_type == OP_MATCH) {
+ if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
OpTYPE_set(second, OP_QR);
}
}
if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
SVOP * const kid = (SVOP*)cUNOPo->op_first;
- HEK *hek;
U32 hash;
char *s;
STRLEN len;
if (kid->op_private & OPpCONST_BARE) {
dVAR;
const char *end;
+ HEK *hek;
if (was_readonly) {
SvREADONLY_off(sv);
}
else {
dVAR;
+ HEK *hek;
if (was_readonly) SvREADONLY_off(sv);
PERL_HASH(hash, s, len);
hek = share_hek(s,
PERL_ARGS_ASSERT_CK_RETURN;
kid = OpSIBLING(cLISTOPo->op_first);
- if (CvLVALUE(PL_compcv)) {
+ if (PL_compcv && CvLVALUE(PL_compcv)) {
for (; kid; kid = OpSIBLING(kid))
op_lvalue(kid, OP_LEAVESUBLV);
}
&& ( (o->op_private & OPpDEREF) == OPpDEREF_AV
|| (o->op_private & OPpDEREF) == OPpDEREF_HV);
+ /* This doesn't make much sense but is legal:
+ * @{ local $x[0][0] } = 1
+ * Since scope exit will undo the autovivification,
+ * don't bother in the first place. The OP_LEAVE
+ * assertion is in case there are other cases of both
+ * OPpLVAL_INTRO and OPpDEREF which don't include a scope
+ * exit that would undo the local - in which case this
+ * block of code would need rethinking.
+ */
+ if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
+#ifdef DEBUGGING
+ OP *n = o->op_next;
+ while (n && ( n->op_type == OP_NULL
+ || n->op_type == OP_LIST))
+ n = n->op_next;
+ assert(n && n->op_type == OP_LEAVE);
+#endif
+ o->op_private &= ~OPpDEREF;
+ is_deref = FALSE;
+ }
+
if (is_deref) {
ASSUME(!(o->op_flags &
~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
&& ( kid->op_targ == OP_NEXTSTATE
|| kid->op_targ == OP_DBSTATE ))
|| kid->op_type == OP_STUB
- || kid->op_type == OP_ENTER);
- nullop->op_next = kLISTOP->op_next;
+ || kid->op_type == OP_ENTER
+ || (PL_parser && PL_parser->error_count));
+ nullop->op_next = kid->op_next;
DEFER(nullop->op_next);
}
* other end instead; this preserves binary compatibility. */
#define PMf_BASE_SHIFT (_RXf_PMf_SHIFT_NEXT+2)
+/* Set by the parser if it discovers an error, so the regex shouldn't be
+ * compiled */
+#define PMf_HAS_ERROR (1U<<(PMf_BASE_SHIFT+4))
+
/* 'use re "taint"' in scope: taint $1 etc. if target tainted */
#define PMf_RETAINT (1U<<(PMf_BASE_SHIFT+5))
#define kLOOP cLOOPx(kid)
+typedef enum {
+ OPclass_NULL, /* 0 */
+ OPclass_BASEOP, /* 1 */
+ OPclass_UNOP, /* 2 */
+ OPclass_BINOP, /* 3 */
+ OPclass_LOGOP, /* 4 */
+ OPclass_LISTOP, /* 5 */
+ OPclass_PMOP, /* 6 */
+ OPclass_SVOP, /* 7 */
+ OPclass_PADOP, /* 8 */
+ OPclass_PVOP, /* 9 */
+ OPclass_LOOP, /* 10 */
+ OPclass_COP, /* 11 */
+ OPclass_METHOP, /* 12 */
+ OPclass_UNOP_AUX /* 13 */
+} OPclass;
+
+
#ifdef USE_ITHREADS
# define cGVOPx_gv(o) ((GV*)PAD_SVl(cPADOPx(o)->op_padix))
# ifndef PERL_CORE
=for apidoc Am|U32|OP_CLASS|OP *o
Return the class of the provided OP: that is, which of the *OP
structures it uses. For core ops this currently gets the information out
-of C<PL_opargs>, which does not always accurately reflect the type used.
+of C<PL_opargs>, which does not always accurately reflect the type used;
+in v5.26 onwards, see also the function C<L</op_class>> which can do a better
+job of determining the used type.
+
For custom ops the type is returned from the registration, and it is up
to the registree to ensure it is accurate. The value returned will be
one of the C<OA_>* constants from F<op.h>.
IV sig_optelems; /* number of optional signature elems seen */
char sig_slurpy; /* the sigil of the slurpy var (or null) */
+ bool recheck_utf8_validity;
+
PERL_BITFIELD16 in_pod:1; /* lexer is within a =pod section */
PERL_BITFIELD16 filtered:1; /* source filters in evalbytes */
PERL_BITFIELD16 saw_infix_sigil:1; /* saw & or * or % operator */
#define PERL_REVISION 5 /* age */
#define PERL_VERSION 25 /* epoch */
-#define PERL_SUBVERSION 9 /* generation */
+#define PERL_SUBVERSION 10 /* 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 9
+#define PERL_API_SUBVERSION 10
/*
XXX Note: The selection of non-default Configure options, such
as -Duselonglong may invalidate these settings. Currently, Configure
* the original argv[0]. (See below for 'contiguous', though.)
* --jhi */
const char *s = NULL;
- int i;
const UV mask = ~(UV)(PTRSIZE-1);
/* Do the mask check only if the args seem like aligned. */
const UV aligned =
* like the argv[] interleaved with some other data, we are
* fine. (Did I just evoke Murphy's Law?) --jhi */
if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
+ int i;
while (*s) s++;
for (i = 1; i < PL_origargc; i++) {
if ((PL_origargv[i] == s + 1
INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
)
{
+ int i;
#ifndef OS2 /* ENVIRON is read by the kernel too. */
s = PL_origenviron[0];
while (*s) s++;
SETERRNO(0,SS_NORMAL);
if (yyparse(GRAMPROG) || PL_parser->error_count) {
- if (PL_minus_c)
- Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
- else {
- Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
- PL_origfilename);
- }
+ abort_execution("", PL_origfilename);
}
CopLINE_set(PL_curcop, 0);
SET_CURSTASH(PL_defstash);
# define USEMYBINMODE /**/
# include <io.h> /* for setmode() prototype */
# define my_binmode(fp, iotype, mode) \
- (PerlLIO_setmode(fileno(fp), mode) != -1 ? TRUE : FALSE)
+ cBOOL(PerlLIO_setmode(fileno(fp), mode) != -1)
#endif
#ifdef __CYGWIN__
(for example :unix which is never going to call them)
it can do the flush when it is pushed.
*/
- return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
+ return cBOOL(PerlIO_apply_layers(aTHX_ f, NULL, names) == 0);
}
else {
/* Fake 5.6 legacy of using this call to turn ON O_TEXT */
/* Legacy binmode is now _defined_ as being equivalent to pushing :raw
So code that used to be here is now in PerlIORaw_pushed().
*/
- return PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL) ? TRUE : FALSE;
+ return cBOOL(PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL));
}
}
structure at all
*/
# else
- f->_file = -1;
+ PERLIO_FILE_file(f) = -1;
# endif
return 1;
# else
* Although it's not designed for this purpose, we can use
* NATIVE_TO_UNI here. It returns its argument on ASCII
* platforms, and on EBCDIC translates native to ascii in
- * the 0-255 range, leaving everything else unchanged.
- * This jibes with yylex() returning some bare characters
- * in that range, but all tokens it returns are either 0,
- * or above 255. There could be a problem if NULs weren't
- * 0, or were ever returned as raw chars by yylex() */
+ * the 0-255 range, leaving every other possible input
+ * unchanged. This jibes with yylex() returning some bare
+ * characters in that range, but all tokens it returns are
+ * either 0, or above 255. There could be a problem if NULs
+ * weren't 0, or were ever returned as raw chars by yylex() */
yytoken = YYTRANSLATE(NATIVE_TO_UNI(parser->yychar));
}
* 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.9" /**/
-#define PRIVLIB_EXP "/sys/lib/perl/5.25.9" /**/
+#define PRIVLIB "/sys/lib/perl/5.25.10" /**/
+#define PRIVLIB_EXP "/sys/lib/perl/5.25.10" /**/
/* 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.9/site_perl" /**/
-#define SITELIB_EXP "/sys/lib/perl/5.25.9/site_perl" /**/
-#define SITELIB_STEM "/sys/lib/perl/5.25.9/site_perl" /**/
+#define SITELIB "/sys/lib/perl/5.25.10/site_perl" /**/
+#define SITELIB_EXP "/sys/lib/perl/5.25.10/site_perl" /**/
+#define SITELIB_STEM "/sys/lib/perl/5.25.10/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='9'
+api_subversion='10'
api_version='25'
-api_versionstring='5.25.9'
+api_versionstring='5.25.10'
ar='ar'
-archlib='/sys/lib/perl5/5.25.9/386'
-archlibexp='/sys/lib/perl5/5.25.9/386'
+archlib='/sys/lib/perl5/5.25.10/386'
+archlibexp='/sys/lib/perl5/5.25.10/386'
archname64=''
archname='386'
archobjs=''
inc_version_list_init='0'
incpath=''
inews=''
-installarchlib='/sys/lib/perl/5.25.9/386'
+installarchlib='/sys/lib/perl/5.25.10/386'
installbin='/usr/bin'
installman1dir='/sys/man/1pub'
installman3dir='/sys/man/2pub'
installprefix='/usr'
installprefixexp='/usr'
-installprivlib='/sys/lib/perl/5.25.9'
+installprivlib='/sys/lib/perl/5.25.10'
installscript='/usr/bin'
-installsitearch='/sys/lib/perl/5.25.9/site_perl/386'
+installsitearch='/sys/lib/perl/5.25.10/site_perl/386'
installsitebin='/usr/bin'
-installsitelib='/sys/lib/perl/5.25.9/site_perl'
+installsitelib='/sys/lib/perl/5.25.10/site_perl'
installstyle='lib/perl5'
installusrbinperl='undef'
installvendorarch=''
pr=''
prefix='/usr'
prefixexp='/usr'
-privlib='/sys/lib/perl/5.25.9'
-privlibexp='/sys/lib/perl/5.25.9'
+privlib='/sys/lib/perl/5.25.10'
+privlibexp='/sys/lib/perl/5.25.10'
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.9/site_perl/386'
+sitearch='/sys/lib/perl/5.25.10/site_perl/386'
sitearchexp='/sys/lib/perl/site_perl/386'
sitebin='/usr/bin'
sitebinexp='/usr/bin'
-sitelib='/sys/lib/perl/5.25.9/site_perl'
-sitelib_stem='/sys/lib/perl/5.25.9/site_perl'
-sitelibexp='/sys/lib/perl/5.25.9/site_perl'
+sitelib='/sys/lib/perl/5.25.10/site_perl'
+sitelib_stem='/sys/lib/perl/5.25.10/site_perl'
+sitelibexp='/sys/lib/perl/5.25.10/site_perl'
siteprefix='/usr'
siteprefixexp='/usr'
sizesize='4'
strerror_r_proto='0'
strings='/sys/include/ape/string.h'
submit=''
-subversion='9'
+subversion='10'
sysman='/sys/man/1pub'
tail=''
tar=''
vendorlibexp=''
vendorprefix=''
vendorprefixexp=''
-version='5.25.9'
-version_patchlevel_string='version 25 subversion 9'
+version='5.25.10'
+version_patchlevel_string='version 25 subversion 10'
versiononly='undef'
vi=''
xlibpth=''
config_argc=0
PERL_REVISION=5
PERL_VERSION=25
-PERL_SUBVERSION=9
+PERL_SUBVERSION=10
PERL_API_REVISION=5
PERL_API_VERSION=25
-PERL_API_SUBVERSION=9
+PERL_API_SUBVERSION=10
PERL_PATCHLEVEL=
PERL_CONFIG_SH=true
/roffitall
# generated
-/perl5259delta.pod
+/perl52510delta.pod
/perlapi.pod
/perlintern.pod
/perlmodlib.pod
perlhist Perl history records
perldelta Perl changes since previous version
+ perl5259delta Perl changes in version 5.25.9
perl5258delta Perl changes in version 5.25.8
perl5257delta Perl changes in version 5.25.7
perl5256delta Perl changes in version 5.25.6
--- /dev/null
+=encoding utf8
+
+=head1 NAME
+
+perl5259delta - what is new for perl v5.25.9
+
+=head1 DESCRIPTION
+
+This document describes differences between the 5.25.8 release and the 5.25.9
+release.
+
+If you are upgrading from an earlier release such as 5.25.7, first read
+L<perl5258delta>, which describes differences between 5.25.7 and 5.25.8.
+
+=head1 Core Enhancements
+
+=head2 New regular expression modifier C</xx>
+
+Specifying two C<x> characters to modify a regular expression pattern
+does everything that a single one does, but additionally TAB and SPACE
+characters within a bracketed character class are generally ignored and
+can be added to improve readability, like
+S<C</[ ^ A-Z d-f p-x ]/xx>>. Details are at
+L<perlre/E<sol>x and E<sol>xx>.
+
+=head1 Deprecations
+
+=head2 String delimiters that aren't stand-alone graphemes are now deprecated
+
+In order for Perl to eventually allow string delimiters to be Unicode
+grapheme clusters (which look like a single character, but may be
+a sequence of several ones), we have to stop allowing a single char
+delimiter that isn't a grapheme by itself. These are unlikely to exist
+in actual code, as they would typically display as attached to the
+character in front of them.
+
+=head1 Performance Enhancements
+
+=over 4
+
+=item *
+
+A hash in boolean context is now sometimes faster, e.g.
+
+ if (!%h) { ... }
+
+This was already special-cased, but some cases were missed, and even the
+ones which weren't have been improved.
+
+=item *
+
+Several other ops may now also be faster in boolean context.
+
+=back
+
+=head1 Modules and Pragmata
+
+=head2 Updated Modules and Pragmata
+
+=over 4
+
+=item *
+
+L<attributes> has been upgraded from version 0.28 to 0.29.
+
+The deprecation message for the C<:unique> and C<:locked> attributes
+now mention they will disappear in Perl 5.28.
+
+=item *
+
+L<B::Deparse> has been upgraded from version 1.39 to 1.40.
+
+=item *
+
+L<B::Xref> has been upgraded from version 1.05 to 1.06.
+
+It now uses 3-arg C<open()> instead of 2-arg C<open()>. [perl #130122]
+
+=item *
+
+L<Compress::Raw::Bzip2> has been upgraded from version 2.069 to 2.070.
+
+=item *
+
+L<Compress::Raw::Zlib> has been upgraded from version 2.069 to 2.070.
+
+=item *
+
+L<CPAN> has been upgraded from version 2.14_01 to 2.16.
+
+=item *
+
+L<Data::Dumper> was upgraded from version 2.166 to 2.167.
+
+This fixes a stack management bug. [perl #130487].
+
+=item *
+
+L<DB_File> has been upgraded from version 1.838 to 1.840.
+
+=item *
+
+L<Devel::SelfStubber> has been upgraded from version 1.05 to 1.06.
+
+It now uses 3-arg C<open()> instead of 2-arg C<open()>. [perl #130122]
+
+=item *
+
+L<diagnostics> has been upgraded from version 1.35 to 1.36.
+
+It now uses 3-arg C<open()> instead of 2-arg C<open()>. [perl #130122]
+
+=item *
+
+L<DynaLoader> has been upgraded from version 1.40 to 1.41.
+
+=item *
+
+L<Errno> has been upgraded from version 1.27 to 1.28.
+
+It now uses 3-arg C<open()> instead of 2-arg C<open()>. [perl #130122]
+
+=item *
+
+L<ExtUtils::Embed> has been upgraded from version 1.33 to 1.34.
+
+It now uses 3-arg C<open()> instead of 2-arg C<open()>. [perl #130122]
+
+=item *
+
+L<feature> has been upgraded from version 1.45 to 1.46.
+
+Fixes the Unicode Bug in the range operator.
+
+=item *
+
+L<File::Glob> has been upgraded from version 1.27 to 1.28.
+
+Issue a deprecation message for C<File::Glob::glob()>.
+
+=item *
+
+L<I18N::LangTags> has been upgraded from version 0.41 to 0.42.
+
+It now uses 3-arg C<open()> instead of 2-arg C<open()>. [perl #130122]
+
+=item *
+
+L<lib> has been upgraded from version 0.63 to 0.64.
+
+It now uses 3-arg C<open()> instead of 2-arg C<open()>. [perl #130122]
+
+=item *
+
+L<Module::CoreList> has been upgraded from version 5.20161220 to 5.20170120.
+
+=item *
+
+L<OS2::Process> has been upgraded from version 1.11 to 1.12.
+
+It now uses 3-arg C<open()> instead of 2-arg C<open()>. [perl #130122]
+
+=item *
+
+L<overload> has been upgraded from version 1.27 to 1.28.
+
+=item *
+
+L<perl5db.pl> has been upgraded from version 1.50 to 1.51.
+
+Ignore F</dev/tty> on non-Unix systems. [perl #113960]
+
+=item *
+
+L<PerlIO::scalar> has been upgraded from version 0.25 to 0.26.
+
+=item *
+
+L<Pod::Html> has been upgraded from version 1.2201 to 1.2202.
+
+=item *
+
+L<re> has been upgraded from version 0.33 to 0.34
+
+This adds support for the new L<C<E<47>xx>|perlre/E<sol>x and E<sol>xx>
+regular expression pattern modifier, and a change to the L<S<C<use re
+'strict'>>|re/'strict' mode> experimental feature. When S<C<re
+'strict'>> is enabled, a warning now will be generated for all
+unescaped uses of the two characters C<}> and C<]> in regular
+expression patterns (outside bracketed character classes) that are taken
+literally. This brings them more in line with the C<)> character which
+is always a metacharacter unless escaped. Being a metacharacter only
+sometimes, depending on action at a distance, can lead to silently
+having the pattern mean something quite different than was intended,
+which the S<C<re 'strict'>> mode is intended to minimize.
+
+=item *
+
+L<Storable> has been upgraded from version 2.59 to 2.61.
+
+Fixes [perl #130098].
+
+=item *
+
+L<Symbol> has been upgraded from version 1.07 to 1.08.
+
+=item *
+
+L<Term::ReadLine> has been upgraded from version 1.15 to 1.16.
+
+It now uses 3-arg C<open()> instead of 2-arg C<open()>. [perl #130122]
+
+=item *
+
+L<Test> has been upgraded from version 1.29 to 1.30.
+
+It now uses 3-arg C<open()> instead of 2-arg C<open()>. [perl #130122]
+
+=item *
+
+L<threads> has been upgraded from version 2.10 to 2.12.
+
+Fixes [perl #130469].
+
+=item *
+
+L<threads::shared> has been upgraded from version 1.52 to 1.54.
+
+This fixes [cpan #119529], [perl #130457]
+
+=item *
+
+L<Unicode::UCD> has been upgraded from version 0.67 to 0.68.
+
+It now uses 3-arg C<open()> instead of 2-arg C<open()>. [perl #130122]
+
+=item *
+
+L<VMS::DCLsym> has been upgraded from version 1.07 to 1.08.
+
+It now uses 3-arg C<open()> instead of 2-arg C<open()>. [perl #130122]
+
+=item *
+
+L<XSLoader> has been upgraded from version 0.24 to 0.26.
+
+It now uses 3-arg C<open()> instead of 2-arg C<open()>. [perl #130122]
+
+=back
+
+=head1 Documentation
+
+=head2 New Documentation
+
+=head3 L<perldeprecation>
+
+This file documents all upcoming deprecations, and some of the deprecations
+which already have been removed. The purpose of this documentation is
+two-fold: document what will disappear, and by which version, and serve
+as a guide for people dealing with code which has features that no longer
+work after an upgrade of their perl.
+
+=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 Warnings
+
+=over 4
+
+=item *
+
+L<Use of unassigned code point or non-standalone grapheme for a delimiter will be a fatal error starting in Perl v5.30|perldiag/"Use of unassigned code point or non-standalone grapheme for a delimiter will be a fatal error starting in Perl v5.30">
+
+See L</Deprecations>
+
+=back
+
+=head2 Changes to Existing Diagnostics
+
+As of Perl 5.25.9, all new deprecations will come with a version in
+which the feature will disappear. And with a few exceptions, most
+existing deprecations will state when they'll disappear. As such, most
+deprecation messages have changed.
+
+=over 4
+
+=item *
+
+Attribute "locked" is deprecated, and will disappear in Perl 5.28
+
+=item *
+
+Attribute "unique" is deprecated, and will disappear in Perl 5.28
+
+=item *
+
+"\c%c" is more clearly written simply as "%s". This will be a fatal error
+in Perl 5.28
+
+=item *
+
+Constants from lexical variables potentially modified elsewhere are
+deprecated. This will not be allowed in Perl 5.32
+
+=item *
+
+Deprecated use of my() in false conditional. This will be a fatal error
+in Perl 5.30
+
+=item *
+
+dump() better written as CORE::dump(). dump() will no longer be available
+in Perl 5.30
+
+=item *
+
+${^ENCODING} is no longer supported. Its use will be fatal in Perl 5.28
+
+=item *
+
+File::Glob::glob() will disappear in perl 5.30. Use File::Glob::bsd_glob()
+instead.
+
+=item *
+
+%s() is deprecated on :utf8 handles. This will be a fatal error in Perl 5.30
+
+=item *
+
+$* is no longer supported. Its use will be fatal in Perl 5.30
+
+=item *
+
+$* is no longer supported. Its use will be fatal in Perl 5.30
+
+=item *
+
+Opening dirhandle %s also as a file. This will be a fatal error in Perl 5.28
+
+=item *
+
+Opening filehandle %s also as a directory. This will be a fatal
+error in Perl 5.28
+
+=item *
+
+Setting $/ to a reference to %s as a form of slurp is deprecated,
+treating as undef. This will be fatal in Perl 5.28
+
+=item *
+
+Unescaped left brace in regex is deprecated here (and will be fatal
+in Perl 5.30), passed through in regex; marked by S<< E<lt>-- HERE >> in m/%s/
+
+=item *
+
+Unknown charname '' is deprecated. Its use will be fatal in Perl 5.28
+
+=item *
+
+Use of bare E<lt>E<lt> to mean E<lt>E<lt>"" is deprecated. Its use will be fatal in Perl 5.28
+
+=item *
+
+Use of code point 0x%s is deprecated; the permissible max is 0x%s.
+This will be fatal in Perl 5.28
+
+=item *
+
+Use of comma-less variable list is deprecated. Its use will be fatal
+in Perl 5.28
+
+=item *
+
+Use of inherited AUTOLOAD for non-method %s() is deprecated. This
+will be fatal in Perl 5.28
+
+=item *
+
+Use of strings with code points over 0xFF as arguments to %s operator
+is deprecated. This will be a fatal error in Perl 5.28
+
+=back
+
+=head1 Utility Changes
+
+=head2 F<c2ph> and F<pstruct>
+
+=over 4
+
+=item *
+
+These old utilities have long since superceded by L<h2xs>, and are
+now gone from the distribution.
+
+=back
+
+=head2 F<Porting/sync-with-cpan>
+
+=over 4
+
+=item *
+
+Many improvements
+
+=back
+
+
+=head1 Configuration and Compilation
+
+=over 4
+
+=item *
+
+The C<dtrace> build process has further changes:
+
+=over
+
+=item *
+
+If the C<-xnolibs> is available, use that so a F<dtrace> perl can be
+built within a FreeBSD jail.
+
+=item *
+
+On systems that build a dtrace object file (FreeBSD, Solaris and
+SystemTap's dtrace emulation), copy the input objects to a separate
+directory and process them there, and use those objects in the link,
+since C<dtrace -G> also modifies these objects.
+
+=item *
+
+Add libelf to the build on FreeBSD 10.x, since dtrace adds references
+to libelf symbols.
+
+=item *
+
+Generate a dummy dtrace_main.o if C<dtrace -G> fails to build it. A
+default build on Solaris generates probes from the unused inline
+functions, while they don't on FreeBSD, which causes C<dtrace -G> to
+fail.
+
+=back
+
+[perl #130108]
+
+=item *
+
+You can now disable perl's use of the PERL_HASH_SEED and
+PERL_PERTURB_KEYS environment variables by configuring perl with
+C<-Accflags=NO_PERL_HASH_ENV>.
+
+=item *
+
+You can now disable perl's use of the PERL_HASH_SEED_DEBUG environment
+variable by configuring perl with
+C<-Accflags=-DNO_PERL_HASH_SEED_DEBUG>.
+
+=back
+
+=head1 Internal Changes
+
+=over 4
+
+=item *
+
+New versions of macros like C<isALPHA_utf8> and C<toLOWER_utf8> have
+been added, each with the
+suffix C<_safe>, like C<isSPACE_utf8_safe>. These take an extra
+parameter, giving an upper limit of how far into the string it is safe
+to read. Using the old versions could cause attempts to read beyond the
+end of the input buffer if the UTF-8 is not well-formed, and their use
+now raises a deprecation warning. Details are at
+L<perlapi/Character classification>.
+
+=item *
+
+Calling macros like C<isALPHA_utf8> on malformed UTF-8 have issued a
+deprecation warning since Perl v5.18. They now die.
+Similarly, macros like C<toLOWER_utf8> on malformed UTF-8 now die.
+
+=item *
+
+Calling the functions C<utf8n_to_uvchr> and its derivatives, while
+passing a string length of 0 is now asserted against in DEBUGGING
+builds, and otherwise returns the Unicode REPLACEMENT CHARACTER. If
+you have nothing to decode, you shouldn't call the decode function.
+
+=item *
+
+The functions C<utf8n_to_uvchr> and its derivatives now return the
+Unicode REPLACEMENT CHARACTER if called with UTF-8 that has the overlong
+malformation, and that malformation is allowed by the input parameters.
+This malformation is where the UTF-8 looks valid syntactically, but
+there is a shorter sequence that yields the same code point. This has
+been forbidden since Unicode version 3.1.
+
+=item *
+
+The functions C<utf8n_to_uvchr> and its derivatives now accept an input
+flag to allow the overflow malformation. This malformation is when the
+UTF-8 may be syntactically valid, but the code point it represents is
+not capable of being represented in the word length on the platform.
+What "allowed" means in this case is that the function doesn't return an
+error, and advances the parse pointer to beyond the UTF-8 in question,
+but it returns the Unicode REPLACEMENT CHARACTER as the value of the
+code point (since the real value is not representable).
+
+=back
+
+=head1 Selected Bug Fixes
+
+=over 4
+
+=item *
+
+Under C<use utf8>, the entire Perl program is now checked that the UTF-8
+is wellformed. This resolves [perl #126310].
+
+=item *
+
+The range operator C<..> on strings now handles its arguments correctly when in
+the scope of the L<< C<unicode_strings>|feature/"The 'unicode_strings' feature" >>
+feature. The previous behaviour was sufficiently unexpected that we believe no
+correct program could have made use of it.
+
+=item *
+
+The S<split> operator did not ensure enough space was allocated for
+its return value in scalar context. It could then write a single
+pointer immediately beyond the end of the memory block allocated for
+the stack. [perl #130262]
+
+=item *
+
+Using a large code point with the C<W> pack template character with
+the current output position aligned at just the right point could
+cause a write a single zero byte immediately beyond the end of an
+allocated buffer. [perl #129149]
+
+=item *
+
+Supplying the form picture argument as part of the form argument list
+where the picture specifies modifying the argument could cause an
+access to the new freed compiled form. [perl #129125]
+
+=item *
+
+Fix a problem with sort's build-in compare, where it would not sort
+correctly with 64-bit integers, and non-long doubles. [perl #130335]
+
+=item *
+
+Fix issues with /(?{ ... E<lt>E<lt>EOF })/ that broke Method-Signatures. [perl #130398]
+
+=item *
+
+Fix a macro which caused syntax error on an EBCDIC build.
+
+=item *
+
+Prevent tests from getting hung up on 'NonStop' option. [perl #130445]
+
+=item *
+
+Fixed an assertion failure with C<chop> and C<chomp>, which
+could be triggered by C<chop(@x =~ tr/1/1/)>. [perl #130198].
+
+=item *
+
+Fixed a comment skipping error under C</x>; it could stop skipping a
+byte early, which could be in the middle of a UTF-8 character.
+[perl #130495].
+
+=item *
+
+F<perldb> now ignores F</dev/tty> on non-Unix systems. [perl #113960];
+
+=item *
+
+Fix assertion failure for C<{}-E<gt>$x> when C<$x> isn't defined. [perl #130496].
+
+=item *
+
+DragonFly BSD now has support for setproctitle(). [perl #130068].
+
+=item *
+
+Fix an assertion error which could be triggered when lookahead string
+in patterns exceeded a minimum length. [perl #130522].
+
+=item *
+
+Only warn once per literal about a misplaced C<_>. [perl #70878].
+
+=item *
+
+Ensure range-start is set after error in C<tr///>. [perl #129342].
+
+=item *
+
+Don't read past start of string for unmatched backref; otherwise,
+we may have heap buffer overflow. [perl #129377].
+
+=item *
+
+Properly recognize mathematical digit ranges starting at U+1D7E.
+C<use re 'strict'> is supposed to warn if you use a range whose start
+and end digit aren't from the same group of 10. It didn't do that
+for five groups of mathematical digits starting at U+1D7E.
+
+=back
+
+
+=head1 Acknowledgements
+
+Perl 5.25.9 represents approximately 4 weeks of development since Perl 5.25.8
+and contains approximately 24,000 lines of changes across 400 files from 23
+authors.
+
+Excluding auto-generated files, documentation and release tools, there were
+approximately 17,000 lines of changes to 220 .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.9:
+
+Aaron Crane, Abigail, Andreas König, Andy Lester, Aristotle Pagaltzis
+Chris 'BinGOs' Williams, Craig A. Berry, Dagfinn Ilmari Mannsåker, Dan Collins,
+David Mitchell, Father Chrysostomos, Hugo van der Sanden, James E Keenan,
+Jerry D. Hedden, John Lightsey, Karl Williamson, Paul Marquess, Peter Avalos,
+Sawyer X, Steve Hay, Tomasz Konojacki, Tony Cook, Zefram.
+
+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.9
+perldelta - what is new for perl v5.25.10
=head1 DESCRIPTION
-This document describes differences between the 5.25.8 release and the 5.25.9
+This document describes differences between the 5.25.9 release and the 5.25.10
release.
-If you are upgrading from an earlier release such as 5.25.7, first read
-L<perl5258delta>, which describes differences between 5.25.7 and 5.25.8.
-
-=head1 Core Enhancements
-
-=head2 New regular expression modifier C</xx>
-
-Specifying two C<x> characters to modify a regular expression pattern
-does everything that a single one does, but additionally TAB and SPACE
-characters within a bracketed character class are generally ignored and
-can be added to improve readability, like
-S<C</[ ^ A-Z d-f p-x ]/xx>>. Details are at
-L<perlre/E<sol>x and E<sol>xx>.
-
-=head1 Deprecations
-
-=head2 String delimiters that aren't stand-alone graphemes are now deprecated
-
-In order for Perl to eventually allow string delimiters to be Unicode
-grapheme clusters (which look like a single character, but may be
-a sequence of several ones), we have to stop allowing a single char
-delimiter that isn't a grapheme by itself. These are unlikely to exist
-in actual code, as they would typically display as attached to the
-character in front of them.
-
-=head1 Performance Enhancements
-
-=over 4
-
-=item *
-
-A hash in boolean context is now sometimes faster, e.g.
-
- if (!%h) { ... }
-
-This was already special-cased, but some cases were missed, and even the
-ones which weren't have been improved.
-
-=item *
-
-Several other ops may now also be faster in boolean context.
-
-=back
+If you are upgrading from an earlier release such as 5.25.8, first read
+L<perl5259delta>, which describes differences between 5.25.8 and 5.25.9.
=head1 Modules and Pragmata
=item *
-L<attributes> has been upgraded from version 0.28 to 0.29.
-
-The deprecation message for the C<:unique> and C<:locked> attributes
-now mention they will disappear in Perl 5.28.
-
-=item *
-
-L<B::Deparse> has been upgraded from version 1.39 to 1.40.
-
-=item *
-
-L<B::Xref> has been upgraded from version 1.05 to 1.06.
-
-It now uses 3-arg C<open()> instead of 2-arg C<open()>. [perl #130122]
-
-=item *
-
-L<Compress::Raw::Bzip2> has been upgraded from version 2.069 to 2.070.
-
-=item *
-
-L<Compress::Raw::Zlib> has been upgraded from version 2.069 to 2.070.
-
-=item *
-
-L<CPAN> has been upgraded from version 2.14_01 to 2.16.
-
-=item *
-
-L<Data::Dumper> was upgraded from version 2.166 to 2.167.
-
-This fixes a stack management bug. [perl #130487].
-
-=item *
-
-L<DB_File> has been upgraded from version 1.838 to 1.840.
-
-=item *
-
-L<Devel::SelfStubber> has been upgraded from version 1.05 to 1.06.
-
-It now uses 3-arg C<open()> instead of 2-arg C<open()>. [perl #130122]
-
-=item *
-
-L<diagnostics> has been upgraded from version 1.35 to 1.36.
-
-It now uses 3-arg C<open()> instead of 2-arg C<open()>. [perl #130122]
-
-=item *
-
-L<DynaLoader> has been upgraded from version 1.40 to 1.41.
-
-=item *
-
-L<Errno> has been upgraded from version 1.27 to 1.28.
-
-It now uses 3-arg C<open()> instead of 2-arg C<open()>. [perl #130122]
-
-=item *
-
-L<ExtUtils::Embed> has been upgraded from version 1.33 to 1.34.
-
-It now uses 3-arg C<open()> instead of 2-arg C<open()>. [perl #130122]
-
-=item *
-
-L<feature> has been upgraded from version 1.45 to 1.46.
-
-Fixes the Unicode Bug in the range operator.
-
-=item *
-
-L<File::Glob> has been upgraded from version 1.27 to 1.28.
-
-Issue a deprecation message for C<File::Glob::glob()>.
-
-=item *
-
-L<I18N::LangTags> has been upgraded from version 0.41 to 0.42.
-
-It now uses 3-arg C<open()> instead of 2-arg C<open()>. [perl #130122]
-
-=item *
-
-L<lib> has been upgraded from version 0.63 to 0.64.
-
-It now uses 3-arg C<open()> instead of 2-arg C<open()>. [perl #130122]
-
-=item *
-
-L<Module::CoreList> has been upgraded from version 5.20161220 to 5.20170120.
-
-=item *
-
-L<OS2::Process> has been upgraded from version 1.11 to 1.12.
-
-It now uses 3-arg C<open()> instead of 2-arg C<open()>. [perl #130122]
-
-=item *
-
-L<overload> has been upgraded from version 1.27 to 1.28.
-
-=item *
-
-L<perl5db.pl> has been upgraded from version 1.50 to 1.51.
-
-Ignore F</dev/tty> on non-Unix systems. [perl #113960]
-
-=item *
-
-L<PerlIO::scalar> has been upgraded from version 0.25 to 0.26.
-
-=item *
-
-L<Pod::Html> has been upgraded from version 1.2201 to 1.2202.
-
-=item *
-
-L<re> has been upgraded from version 0.33 to 0.34
-
-This adds support for the new L<C<E<47>xx>|perlre/E<sol>x and E<sol>xx>
-regular expression pattern modifier, and a change to the L<S<C<use re
-'strict'>>|re/'strict' mode> experimental feature. When S<C<re
-'strict'>> is enabled, a warning now will be generated for all
-unescaped uses of the two characters C<}> and C<]> in regular
-expression patterns (outside bracketed character classes) that are taken
-literally. This brings them more in line with the C<)> character which
-is always a metacharacter unless escaped. Being a metacharacter only
-sometimes, depending on action at a distance, can lead to silently
-having the pattern mean something quite different than was intended,
-which the S<C<re 'strict'>> mode is intended to minimize.
+L<B> has been upgraded from version 1.65 to 1.68.
=item *
-L<Storable> has been upgraded from version 2.59 to 2.61.
-
-Fixes [perl #130098].
+L<CPAN> has been upgraded from version 2.16 to 2.17.
=item *
-L<Symbol> has been upgraded from version 1.07 to 1.08.
+L<feature> has been upgraded from version 1.46 to 1.47.
=item *
-L<Term::ReadLine> has been upgraded from version 1.15 to 1.16.
-
-It now uses 3-arg C<open()> instead of 2-arg C<open()>. [perl #130122]
+L<Getopt::Std> has been upgraded from version 1.11 to 1.12.
=item *
-L<Test> has been upgraded from version 1.29 to 1.30.
-
-It now uses 3-arg C<open()> instead of 2-arg C<open()>. [perl #130122]
+L<Module::CoreList> has been upgraded from version 5.20170120 to 5.20170220.
=item *
-L<threads> has been upgraded from version 2.10 to 2.12.
-
-Fixes [perl #130469].
+L<open> has been upgraded from version 1.10 to 1.11.
=item *
-L<threads::shared> has been upgraded from version 1.52 to 1.54.
-
-This fixes [cpan #119529], [perl #130457]
+L<PerlIO> has been upgraded from version 1.09 to 1.10.
=item *
-L<Unicode::UCD> has been upgraded from version 0.67 to 0.68.
-
-It now uses 3-arg C<open()> instead of 2-arg C<open()>. [perl #130122]
+L<Storable> has been upgraded from version 2.61 to 2.62.
=item *
-L<VMS::DCLsym> has been upgraded from version 1.07 to 1.08.
-
-It now uses 3-arg C<open()> instead of 2-arg C<open()>. [perl #130122]
+L<Thread::Queue> has been upgraded from version 3.11 to 3.12.
=item *
-L<XSLoader> has been upgraded from version 0.24 to 0.26.
-
-It now uses 3-arg C<open()> instead of 2-arg C<open()>. [perl #130122]
+L<threads> has been upgraded from version 2.12 to 2.13.
=back
-=head1 Documentation
-
-=head2 New Documentation
-
-=head3 L<perldeprecation>
-
-This file documents all upcoming deprecations, and some of the deprecations
-which already have been removed. The purpose of this documentation is
-two-fold: document what will disappear, and by which version, and serve
-as a guide for people dealing with code which has features that no longer
-work after an upgrade of their perl.
-
=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 Warnings
-
-=over 4
-
-=item *
-
-L<Use of unassigned code point or non-standalone grapheme for a delimiter will be a fatal error starting in Perl v5.30|perldiag/"Use of unassigned code point or non-standalone grapheme for a delimiter will be a fatal error starting in Perl v5.30">
-
-See L</Deprecations>
-
-=back
-
=head2 Changes to Existing Diagnostics
-As of Perl 5.25.9, all new deprecations will come with a version in
-which the feature will disappear. And with a few exceptions, most
-existing deprecations will state when they'll disappear. As such, most
-deprecation messages have changed.
-
=over 4
=item *
-Attribute "locked" is deprecated, and will disappear in Perl 5.28
-
-=item *
-
-Attribute "unique" is deprecated, and will disappear in Perl 5.28
+Use of unassigned code point or non-standalone grapheme for a delimiter will be a fatal error starting in Perl 5.30
-=item *
-
-"\c%c" is more clearly written simply as "%s". This will be a fatal error
-in Perl 5.28
-
-=item *
-
-Constants from lexical variables potentially modified elsewhere are
-deprecated. This will not be allowed in Perl 5.32
-
-=item *
-
-Deprecated use of my() in false conditional. This will be a fatal error
-in Perl 5.30
-
-=item *
-
-dump() better written as CORE::dump(). dump() will no longer be available
-in Perl 5.30
-
-=item *
-
-${^ENCODING} is no longer supported. Its use will be fatal in Perl 5.28
-
-=item *
-
-File::Glob::glob() will disappear in perl 5.30. Use File::Glob::bsd_glob()
-instead.
-
-=item *
-
-%s() is deprecated on :utf8 handles. This will be a fatal error in Perl 5.30
-
-=item *
-
-$* is no longer supported. Its use will be fatal in Perl 5.30
-
-=item *
-
-$* is no longer supported. Its use will be fatal in Perl 5.30
-
-=item *
-
-Opening dirhandle %s also as a file. This will be a fatal error in Perl 5.28
-
-=item *
-
-Opening filehandle %s also as a directory. This will be a fatal
-error in Perl 5.28
-
-=item *
-
-Setting $/ to a reference to %s as a form of slurp is deprecated,
-treating as undef. This will be fatal in Perl 5.28
-
-=item *
-
-Unescaped left brace in regex is deprecated here (and will be fatal
-in Perl 5.30), passed through in regex; marked by S<< E<lt>-- HERE >> in m/%s/
-
-=item *
-
-Unknown charname '' is deprecated. Its use will be fatal in Perl 5.28
-
-=item *
-
-Use of bare E<lt>E<lt> to mean E<lt>E<lt>"" is deprecated. Its use will be fatal in Perl 5.28
-
-=item *
-
-Use of code point 0x%s is deprecated; the permissible max is 0x%s.
-This will be fatal in Perl 5.28
-
-=item *
-
-Use of comma-less variable list is deprecated. Its use will be fatal
-in Perl 5.28
-
-=item *
-
-Use of inherited AUTOLOAD for non-method %s() is deprecated. This
-will be fatal in Perl 5.28
+This was changed to drop a leading C<v> in C<v5.30>, so it uses the same
+style as other deprecation messages.
=item *
-Use of strings with code points over 0xFF as arguments to %s operator
-is deprecated. This will be a fatal error in Perl 5.28
-
-=back
-
-=head1 Utility Changes
-
-=head2 F<c2ph> and F<pstruct>
-
-=over 4
-
-=item *
-
-These old utilities have long since superceded by L<h2xs>, and are
-now gone from the distribution.
-
-=back
-
-=head2 F<Porting/sync-with-cpan>
-
-=over 4
-
-=item *
+"\c%c" is more clearly written simply as "%s".
-Many improvements
+It was decided to undeprecate the use of "\c%c", see L<http://www.nntp.perl.org/group/perl.perl5.porters/2017/02/msg242944.html>
=back
+=head1 Platform Support
-=head1 Configuration and Compilation
+=head2 Platform-Specific Notes
=over 4
-=item *
-
-The C<dtrace> build process has further changes:
-
-=over
+=item Windows
-=item *
-
-If the C<-xnolibs> is available, use that so a F<dtrace> perl can be
-built within a FreeBSD jail.
+=over 4
=item *
-On systems that build a dtrace object file (FreeBSD, Solaris and
-SystemTap's dtrace emulation), copy the input objects to a separate
-directory and process them there, and use those objects in the link,
-since C<dtrace -G> also modifies these objects.
-
-=item *
+Support for compiling perl on Windows using Microsoft Visual Studio 2015
+(containing Visual C++ 14.0) has been added.
-Add libelf to the build on FreeBSD 10.x, since dtrace adds references
-to libelf symbols.
+This version of VC++ includes a completely rewritten C run-time library, some
+of the changes in which mean that work done to resolve a socket close() bug in
+perl #120091 and perl #118059 is not workable in its current state with this
+version of VC++. Therefore, we have effectively reverted that bug fix for
+VS2015 onwards on the basis that being able to build with VS2015 onwards is
+more important than keeping the bug fix. We may revisit this in the future to
+attempt to fix the bug again in a way that is compatible with VS2015.
-=item *
+These changes do not affect compilation with GCC or with Visual Studio versions
+up to and including VS2013, i.e. the bug fix is retained (unchanged) for those
+compilers.
-Generate a dummy dtrace_main.o if C<dtrace -G> fails to build it. A
-default build on Solaris generates probes from the unused inline
-functions, while they don't on FreeBSD, which causes C<dtrace -G> to
-fail.
+Note that you may experience compatibility problems if you mix a perl built
+with GCC or VS E<lt>= VS2013 with XS modules built with VS2015, or if you mix a
+perl built with VS2015 with XS modules built with GCC or VS E<lt>= VS2013.
+Some incompatibility may arise because of the bug fix that has been reverted
+for VS2015 builds of perl, but there may well be incompatibility anyway because
+of the rewritten CRT in VS2015 (e.g. see discussion at
+http://stackoverflow.com/questions/30412951).
=back
-[perl #130108]
-
-=item *
-
-You can now disable perl's use of the PERL_HASH_SEED and
-PERL_PERTURB_KEYS environment variables by configuring perl with
-C<-Accflags=NO_PERL_HASH_ENV>.
-
-=item *
-
-You can now disable perl's use of the PERL_HASH_SEED_DEBUG environment
-variable by configuring perl with
-C<-Accflags=-DNO_PERL_HASH_SEED_DEBUG>.
-
=back
=head1 Internal Changes
=item *
-New versions of macros like C<isALPHA_utf8> and C<toLOWER_utf8> have
-been added, each with the
-suffix C<_safe>, like C<isSPACE_utf8_safe>. These take an extra
-parameter, giving an upper limit of how far into the string it is safe
-to read. Using the old versions could cause attempts to read beyond the
-end of the input buffer if the UTF-8 is not well-formed, and their use
-now raises a deprecation warning. Details are at
-L<perlapi/Character classification>.
-
-=item *
-
-Calling macros like C<isALPHA_utf8> on malformed UTF-8 have issued a
-deprecation warning since Perl v5.18. They now die.
-Similarly, macros like C<toLOWER_utf8> on malformed UTF-8 now die.
+The C<op_class()> API function has been added. This is like the existing
+C<OP_CLASS()> macro, but can more accurately determine what struct an op
+has been allocated as. For example C<OP_CLASS()> might return
+C<OA_BASEOP_OR_UNOP> indicating that ops of this type are usually
+allocated as an C<OP> or C<UNOP>; while C<op_class()> will return
+C<OPclass_BASEOP> or C<OPclass_UNOP> as appropriate.
=item *
-Calling the functions C<utf8n_to_uvchr> and its derivatives, while
-passing a string length of 0 is now asserted against in DEBUGGING
-builds, and otherwise returns the Unicode REPLACEMENT CHARACTER. If
-you have nothing to decode, you shouldn't call the decode function.
-
-=item *
-
-The functions C<utf8n_to_uvchr> and its derivatives now return the
-Unicode REPLACEMENT CHARACTER if called with UTF-8 that has the overlong
-malformation, and that malformation is allowed by the input parameters.
-This malformation is where the UTF-8 looks valid syntactically, but
-there is a shorter sequence that yields the same code point. This has
-been forbidden since Unicode version 3.1.
-
-=item *
-
-The functions C<utf8n_to_uvchr> and its derivatives now accept an input
-flag to allow the overflow malformation. This malformation is when the
-UTF-8 may be syntactically valid, but the code point it represents is
-not capable of being represented in the word length on the platform.
-What "allowed" means in this case is that the function doesn't return an
-error, and advances the parse pointer to beyond the UTF-8 in question,
-but it returns the Unicode REPLACEMENT CHARACTER as the value of the
-code point (since the real value is not representable).
+The output format of the C<op_dump()> function (as used by C<perl -Dx>)
+has changed: it now displays an "ASCII-art" tree structure, and shows more
+low-level details about each op, such as its address and class.
=back
=item *
-Under C<use utf8>, the entire Perl program is now checked that the UTF-8
-is wellformed. This resolves [perl #126310].
-
-=item *
-
-The range operator C<..> on strings now handles its arguments correctly when in
-the scope of the L<< C<unicode_strings>|feature/"The 'unicode_strings' feature" >>
-feature. The previous behaviour was sufficiently unexpected that we believe no
-correct program could have made use of it.
-
-=item *
-
-The S<split> operator did not ensure enough space was allocated for
-its return value in scalar context. It could then write a single
-pointer immediately beyond the end of the memory block allocated for
-the stack. [perl #130262]
-
-=item *
-
-Using a large code point with the C<W> pack template character with
-the current output position aligned at just the right point could
-cause a write a single zero byte immediately beyond the end of an
-allocated buffer. [perl #129149]
-
-=item *
-
-Supplying the form picture argument as part of the form argument list
-where the picture specifies modifying the argument could cause an
-access to the new freed compiled form. [perl #129125]
-
-=item *
-
-Fix a problem with sort's build-in compare, where it would not sort
-correctly with 64-bit integers, and non-long doubles. [perl #130335]
-
-=item *
-
-Fix issues with /(?{ ... E<lt>E<lt>EOF })/ that broke Method-Signatures. [perl #130398]
-
-=item *
-
-Fix a macro which caused syntax error on an EBCDIC build.
-
-=item *
-
-Prevent tests from getting hung up on 'NonStop' option. [perl #130445]
-
-=item *
-
-Fixed an assertion failure with C<chop> and C<chomp>, which
-could be triggered by C<chop(@x =~ tr/1/1/)>. [perl #130198].
-
-=item *
-
-Fixed a comment skipping error under C</x>; it could stop skipping a
-byte early, which could be in the middle of a UTF-8 character.
-[perl #130495].
+Attempting to use the deprecated variable C<$#> as the object in an
+indirect object method call could cause a heap use after free or
+buffer overflow. [perl #129274]
=item *
-F<perldb> now ignores F</dev/tty> on non-Unix systems. [perl #113960];
+When checking for an indirect object method call in some rare cases
+the parser could reallocate the line buffer but then continue to use
+pointers to the old buffer. [perl #129190]
=item *
-Fix assertion failure for C<{}-E<gt>$x> when C<$x> isn't defined. [perl #130496].
+Supplying a glob as the format argument to L<perlfunc/formline> would
+cause an assertion failure. [perl #130722]
=item *
-DragonFly BSD now has support for setproctitle(). [perl #130068].
+Code like C< $value1 =~ qr/.../ ~~ $value2 > would have the match
+converted into a qr// operator, leaving extra elements on the stack to
+confuse any surrounding expression. [perl #130705]
=item *
-Fix an assertion error which could be triggered when lookahead string
-in patterns exceeded a minimum length. [perl #130522].
+Since 5.24.0 in some obscure cases, a regex which included code blocks
+from multiple sources (e.g. via embedded via qr// objects) could end up
+with the wrong current pad and crash or give weird results. [perl #129881]
=item *
-Only warn once per literal about a misplaced C<_>. [perl #70878].
+Occasionally C<local()>s in a code block within a patterns weren't being
+undone when the pattern matching backtracked over the code block.
+[perl #126697]
=item *
-Ensure range-start is set after error in C<tr///>. [perl #129342].
+Using C<substr()> to modify a magic variable could access freed memory
+in some cases. [perl #129340]
=item *
-Don't read past start of string for unmatched backref; otherwise,
-we may have heap buffer overflow. [perl #129377].
-
-=item *
-
-Properly recognize mathematical digit ranges starting at U+1D7E.
-C<use re 'strict'> is supposed to warn if you use a range whose start
-and end digit aren't from the same group of 10. It didn't do that
-for five groups of mathematical digits starting at U+1D7E.
+Perl 5.25.9 was fixed so that under C<use utf8>, the entire Perl program
+is checked that the UTF-8 is wellformed. It turns out that several edge
+cases were missed, and are now fixed. [perl #126310] was the original
+ticket.
=back
-
=head1 Acknowledgements
-Perl 5.25.9 represents approximately 4 weeks of development since Perl 5.25.8
-and contains approximately 24,000 lines of changes across 400 files from 23
+Perl 5.25.10 represents approximately 4 weeks of development since Perl 5.25.9
+and contains approximately 12,000 lines of changes across 200 files from 25
authors.
Excluding auto-generated files, documentation and release tools, there were
-approximately 17,000 lines of changes to 220 .pm, .t, .c and .h files.
+approximately 6,700 lines of changes to 130 .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.9:
+improvements that became Perl 5.25.10:
-Aaron Crane, Abigail, Andreas König, Andy Lester, Aristotle Pagaltzis
-Chris 'BinGOs' Williams, Craig A. Berry, Dagfinn Ilmari Mannsåker, Dan Collins,
-David Mitchell, Father Chrysostomos, Hugo van der Sanden, James E Keenan,
-Jerry D. Hedden, John Lightsey, Karl Williamson, Paul Marquess, Peter Avalos,
-Sawyer X, Steve Hay, Tomasz Konojacki, Tony Cook, Zefram.
+Aaron Crane, Abigail, Andreas König, Andy Lester, Chris 'BinGOs' Williams,
+Christian Millour, Colin Newell, Dagfinn Ilmari Mannsåker, David Mitchell,
+Hugo van der Sanden, James E Keenan, Jarkko Hietaniemi, Jerry D. Hedden, John
+Lightsey, Karl Williamson, Neil Bowers, Pali, Renee Baecker, Sawyer X, Sergey
+Aleynikov, Steffen Müller, Steve Hay, Tony Cook, Yves Orton, Zefram.
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
This feature was deprecated in Perl 5.004, and will be fatal in Perl 5.28.
-=head3 Use of C<< \cI<X> >> to specify a printable character.
-
-In a double quoted context, Perl has the C<< \c >> construct to write
-control characters in a readable way. For instance, the tab character
-can be written as C<< \cI >> (I<< control-I >>), and the escape
-character can be written as C<< \c[ >>.
-
-Due to implementation details, the C<< \c >> construct can be used
-to create regular, printable, characters as well. For instance,
-C<< \c >> maps a C<< , >> to C<< l >>; that is C<< \c, >> is an
-obscure way of writing C<< l >>. And not only that, it's also not
-portable between ASCII and EBCDIC platforms.
-
-Using the C<< \c >> construct with an argument which maps to a
-printable character was deprecated in Perl 5.14, and will be a fatal
-error in Perl 5.28. You're recommended to just write the intended
-character instead.
-
-
=head3 Use of code points over 0xFF in string bitwise operators
The string bitwise operators, C<&>, C<|>, C<^>, and C<~>, treat
issued on exit from the C<default> block, so you won't get the
error if you use an explicit C<continue>.)
+=item Can't determine class of operator %s, assuming BASEOP
+
+(S) This warning indicates something wrong in the internals of perl.
+Perl was trying to find the class (e.g. LISTOP) of a particular OP,
+and was unable to do so. This is likely to be due to a bug in the perl
+internals, or due to a bug in XS code which manipulates perl optrees.
+
=item Can't do inplace edit: %s is not a regular file
(S inplace) You tried to use the B<-i> switch on a special file, such as
Note that ASCII characters that don't map to control characters are
discouraged, and will generate the warning (when enabled)
-L</""\c%c" is more clearly written simply as "%s". This will be a fatal error in Perl 5.28">.
+L</""\c%c" is more clearly written simply as "%s"">.
=item Character following \%c must be '{' or a single-character Unicode property name in regex; marked by <-- HERE in m/%s/
(W unopened) You tried chdir() on a filehandle that was never opened.
-=item "\c%c" is more clearly written simply as "%s". This will be a fatal error in Perl 5.28
+=item "\c%c" is more clearly written simply as "%s"
-(D deprecated, syntax) The C<\cI<X>> construct is intended to be a
-way to specify non-printable characters. You used it for a printable
-one, which is better written as simply itself, perhaps preceded by
-a backslash for non-word characters. Doing it the way you did is
-not portable between ASCII and EBCDIC platforms.
-
-This usage is going to result in a fatal error in Perl 5.28.
+(W syntax) The C<\cI<X>> construct is intended to be a way to specify
+non-printable characters. You used it for a printable one, which
+is better written as simply itself, perhaps preceded by a backslash
+for non-word characters. Doing it the way you did is not portable
+between ASCII and EBCDIC platforms.
=item Cloning substitution context is unimplemented
(F) The C<exec> function is not implemented on some systems, e.g., Symbian
OS. See L<perlport>.
-=item Execution of %s aborted due to compilation errors.
+=item %sExecution of %s aborted due to compilation errors.
(F) The final summary message when a Perl compilation fails.
In Perl 5.30, it will no longer be possible to use sysread(), recv(),
syswrite() or send() to read or send bytes from/to :utf8 handles.
-=item "%s" is more clearly written simply as "%s" in regex. This will be a fatal error in Perl 5.28; marked by S<<-- HERE> in m/%s/
+=item "%s" is more clearly written simply as "%s" in regex; marked by S<<-- HERE> in m/%s/
-(W deprecated, regexp) (only under C<S<use re 'strict'>> or within C<(?[...])>)
+(W regexp) (only under C<S<use re 'strict'>> or within C<(?[...])>)
You specified a character that has the given plainer way of writing it,
and which is also portable to platforms running with different character
-sets. This usage is deprecated, and will be a fatal error in Perl 5.28.
+sets.
=item $* is no longer supported. Its use will be fatal in Perl 5.30
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
-8-bit data). To guard against this, you can use Encode::decode_utf8.
+8-bit data). To guard against this, you can use C<Encode::decode('UTF-8', ...)>.
If you use the C<:encoding(UTF-8)> PerlIO layer for input, invalid byte
sequences are handled gracefully, but if you use C<:utf8>, the flag is
See also L<Encode/"Handling Malformed Data">.
-=item Malformed UTF-8 character immediately after '%s'
-
-(F) You said C<use utf8>, but the program file doesn't comply with UTF-8
-encoding rules. The message prints out the properly encoded characters
-just before the first bad one. If C<utf8> warnings are enabled, a
-warning is generated that gives more details about the type of
-malformation.
-
=item Malformed UTF-8 returned by \N{%s} immediately after '%s'
(F) The charnames handler returned malformed UTF-8.
(4294967295) and therefore non-portable between systems. See
L<perlport> for more on portability concerns.
-=item Odd name/value argument for subroutine
+=item Odd name/value argument for subroutine '%s'
(F) A subroutine using a slurpy hash parameter in its signature
received an odd number of arguments to populate the hash. It requires
the arguments to be paired, with the same number of keys as values.
-The caller of the subroutine is presumably at fault. Inconveniently,
-this error will be reported at the location of the subroutine, not that
-of the caller.
+The caller of the subroutine is presumably at fault.
+
+The message attempts to include the name of the called subroutine. If the
+subroutine has been aliased, the subroutine's original name will be shown,
+regardless of what name the caller used.
=item Odd number of arguments for overload::constant
(F) There has to be at least one argument to syscall() to specify the
system call to call, silly dilly.
-=item Too few arguments for subroutine
+=item Too few arguments for subroutine '%s'
(F) A subroutine using a signature received too few arguments than
required by the signature. The caller of the subroutine is presumably
at fault.
+The message attempts to include the name of the called subroutine. If the
+subroutine has been aliased, the subroutine's original name will be shown,
+regardless of what name the caller used.
+
=item Too late for "-%s" option
(X) The #! line (or local equivalent) in a Perl script contains the
(F) The function requires fewer arguments than you specified.
-=item Too many arguments for subroutine
+=item Too many arguments for subroutine '%s'
(F) A subroutine using a signature received too many arguments than
required by the signature. The caller of the subroutine is presumably
at fault.
+The message attempts to include the name of the called subroutine. If the
+subroutine has been aliased, the subroutine's original name will be shown,
+regardless of what name the caller used.
=item Too many )'s
arguments. See L<perlsec>.
=item Use of unassigned code point or non-standalone grapheme for a
-delimiter will be a fatal error starting in Perl v5.30
+delimiter will be a fatal error starting in Perl 5.30
(D deprecated)
A grapheme is what appears to a native-speaker of a language to be a
=for Pod::Functions catch exceptions or compile and run code
-In the first form, often referred to as a "string eval", the return
-value of EXPR is parsed and executed as if it
-were a little Perl program. The value of the expression (which is itself
-determined within scalar context) is first parsed, and if there were no
-errors, executed as a block within the lexical context of the current Perl
-program. This means, that in particular, any outer lexical variables are
-visible to it, and any package variable settings or subroutine and format
-definitions remain afterwards.
-
-Note that the value is parsed every time the L<C<eval>|/eval EXPR>
-executes. If EXPR is omitted, evaluates L<C<$_>|perlvar/$_>. This form
-is typically used to delay parsing and subsequent execution of the text
-of EXPR until run time.
-
-If the
-L<C<"unicode_eval"> feature|feature/The 'unicode_eval' and 'evalbytes' features>
-is enabled (which is the default under a
-C<use 5.16> or higher declaration), EXPR or L<C<$_>|perlvar/$_> is
-treated as a string of characters, so L<C<use utf8>|utf8> declarations
-have no effect, and source filters are forbidden. In the absence of the
-L<C<"unicode_eval"> feature|feature/The 'unicode_eval' and 'evalbytes' features>,
-will sometimes be treated as characters and sometimes as bytes,
-depending on the internal encoding, and source filters activated within
-the L<C<eval>|/eval EXPR> exhibit the erratic, but historical, behaviour
-of affecting some outer file scope that is still compiling. See also
-the L<C<evalbytes>|/evalbytes EXPR> operator, which always treats its
-input as a byte stream and works properly with source filters, and the
-L<feature> pragma.
-
-Problems can arise if the string expands a scalar containing a floating
-point number. That scalar can expand to letters, such as C<"NaN"> or
-C<"Infinity">; or, within the scope of a L<C<use locale>|locale>, the
-decimal point character may be something other than a dot (such as a
-comma). None of these are likely to parse as you are likely expecting.
-
-In the second form, the code within the BLOCK is parsed only once--at the
-same time the code surrounding the L<C<eval>|/eval EXPR> itself was
-parsed--and executed
+C<eval> in all its forms is used to execute a little Perl program,
+trapping any errors encountered so they don't crash the calling program.
+
+Plain C<eval> with no argument is just C<eval EXPR>, where the
+expression is understood to be contained in L<C<$_>|perlvar/$_>. Thus
+there are only two real C<eval> forms; the one with an EXPR is often
+called "string eval". In a string eval, the value of the expression
+(which is itself determined within scalar context) is first parsed, and
+if there were no errors, executed as a block within the lexical context
+of the current Perl program. This form is typically used to delay
+parsing and subsequent execution of the text of EXPR until run time.
+Note that the value is parsed every time the C<eval> executes.
+
+The other form is called "block eval". It is less general than string
+eval, but the code within the BLOCK is parsed only once (at the same
+time the code surrounding the C<eval> itself was parsed) and executed
within the context of the current Perl program. This form is typically
-used to trap exceptions more efficiently than the first (see below), while
-also providing the benefit of checking the code within BLOCK at compile
-time.
-
-The final semicolon, if any, may be omitted from the value of EXPR or within
-the BLOCK.
+used to trap exceptions more efficiently than the first, while also
+providing the benefit of checking the code within BLOCK at compile time.
+BLOCK is parsed and compiled just once. Since errors are trapped, it
+often is used to check if a given feature is available.
In both forms, the value returned is the value of the last expression
-evaluated inside the mini-program; a return statement may be also used, just
+evaluated inside the mini-program; a return statement may also be used, just
as with subroutines. The expression providing the return value is evaluated
in void, scalar, or list context, depending on the context of the
-L<C<eval>|/eval EXPR> itself. See L<C<wantarray>|/wantarray> for more
+C<eval> itself. See L<C<wantarray>|/wantarray> for more
on how the evaluation context can be determined.
If there is a syntax error or runtime error, or a L<C<die>|/die LIST>
-statement is executed, L<C<eval>|/eval EXPR> returns
-L<C<undef>|/undef EXPR> in scalar context or an empty list in list
+statement is executed, C<eval> returns
+L<C<undef>|/undef EXPR> in scalar context, or an empty list in list
context, and L<C<$@>|perlvar/$@> is set to the error message. (Prior to
5.16, a bug caused L<C<undef>|/undef EXPR> to be returned in list
context for syntax errors, but not for runtime errors.) If there was no
error, L<C<$@>|perlvar/$@> is set to the empty string. A control flow
operator like L<C<last>|/last LABEL> or L<C<goto>|/goto LABEL> can
bypass the setting of L<C<$@>|perlvar/$@>. Beware that using
-L<C<eval>|/eval EXPR> neither silences Perl from printing warnings to
+C<eval> neither silences Perl from printing warnings to
STDERR, nor does it stuff the text of warning messages into
L<C<$@>|perlvar/$@>. To do either of those, you have to use the
L<C<$SIG{__WARN__}>|perlvar/%SIG> facility, or turn off warnings inside
the BLOCK or EXPR using S<C<no warnings 'all'>>. See
L<C<warn>|/warn LIST>, L<perlvar>, and L<warnings>.
-Note that, because L<C<eval>|/eval EXPR> traps otherwise-fatal errors,
+Note that, because C<eval> traps otherwise-fatal errors,
it is useful for determining whether a particular feature (such as
L<C<socket>|/socket SOCKET,DOMAIN,TYPE,PROTOCOL> or
L<C<symlink>|/symlink OLDFILE,NEWFILE>) is implemented. It is also
Perl's exception-trapping mechanism, where the L<C<die>|/die LIST>
operator is used to raise exceptions.
-If you want to trap errors when loading an XS module, some problems with
-the binary interface (such as Perl version skew) may be fatal even with
-L<C<eval>|/eval EXPR> unless C<$ENV{PERL_DL_NONLAZY}> is set. See
-L<perlrun>.
+Before Perl 5.14, the assignment to L<C<$@>|perlvar/$@> occurred before
+restoration
+of localized variables, which means that for your code to run on older
+versions, a temporary is required if you want to mask some, but not all
+errors:
+
+ # alter $@ on nefarious repugnancy only
+ {
+ my $e;
+ {
+ local $@; # protect existing $@
+ eval { test_repugnancy() };
+ # $@ =~ /nefarious/ and die $@; # Perl 5.14 and higher only
+ $@ =~ /nefarious/ and $e = $@;
+ }
+ die $e if defined $e
+ }
+
+There are some different considerations for each form:
+
+=over 4
+
+=item String eval
+
+Since the return value of EXPR is executed as a block within the lexical
+context of the current Perl program, any outer lexical variables are
+visible to it, and any package variable settings or subroutine and
+format definitions remain afterwards.
+
+=over 4
+
+=item Under the L<C<"unicode_eval"> feature|feature/The 'unicode_eval' and 'evalbytes' features>
+
+If this feature is enabled (which is the default under a C<use 5.16> or
+higher declaration), EXPR is considered to be
+in the same encoding as the surrounding program. Thus if
+S<L<C<use utf8>|utf8>> is in effect, the string will be treated as being
+UTF-8 encoded. Otherwise, the string is considered to be a sequence of
+independent bytes. Bytes that correspond to ASCII-range code points
+will have their normal meanings for operators in the string. The
+treatment of the other bytes depends on if the
+L<C<'unicode_strings"> feature|feature/The 'unicode_strings' feature> is
+in effect.
+
+In a plain C<eval> without an EXPR argument, being in S<C<use utf8>> or
+not is irrelevant; the UTF-8ness of C<$_> itself determines the
+behavior.
+
+Any S<C<use utf8>> or S<C<no utf8>> declarations within the string have
+no effect, and source filters are forbidden. (C<unicode_strings>,
+however, can appear within the string. See also the
+L<C<evalbytes>|/evalbytes EXPR> operator, which works properly with
+source filters.
+
+Variables defined outside the C<eval> and used inside it retain their
+original UTF-8ness. Everything inside the string follows the normal
+rules for a Perl program with the given state of S<C<use utf8>>.
+
+=item Outside the C<"unicode_eval"> feature
+
+In this case, the behavior is problematic and is not so easily
+described. Here are two bugs that cannot easily be fixed without
+breaking existing programs:
+
+=over 4
+
+=item *
+
+It can lose track of whether something should be encoded as UTF-8 or
+not.
+
+=item *
+
+Source filters activated within C<eval> leak out into whichever file
+scope is currently being compiled. To give an example with the CPAN module
+L<Semi::Semicolons>:
+
+ BEGIN { eval "use Semi::Semicolons; # not filtered" }
+ # filtered here!
+
+L<C<evalbytes>|/evalbytes EXPR> fixes that to work the way one would
+expect:
+
+ use feature "evalbytes";
+ BEGIN { evalbytes "use Semi::Semicolons; # filtered" }
+ # not filtered
+
+=back
+
+=back
+
+Problems can arise if the string expands a scalar containing a floating
+point number. That scalar can expand to letters, such as C<"NaN"> or
+C<"Infinity">; or, within the scope of a L<C<use locale>|locale>, the
+decimal point character may be something other than a dot (such as a
+comma). None of these are likely to parse as you are likely expecting.
+
+You should be especially careful to remember what's being looked at
+when:
+
+ eval $x; # CASE 1
+ eval "$x"; # CASE 2
+
+ eval '$x'; # CASE 3
+ eval { $x }; # CASE 4
+
+ eval "\$$x++"; # CASE 5
+ $$x++; # CASE 6
+
+Cases 1 and 2 above behave identically: they run the code contained in
+the variable $x. (Although case 2 has misleading double quotes making
+the reader wonder what else might be happening (nothing is).) Cases 3
+and 4 likewise behave in the same way: they run the code C<'$x'>, which
+does nothing but return the value of $x. (Case 4 is preferred for
+purely visual reasons, but it also has the advantage of compiling at
+compile-time instead of at run-time.) Case 5 is a place where
+normally you I<would> like to use double quotes, except that in this
+particular situation, you can just use symbolic references instead, as
+in case 6.
+
+An C<eval ''> executed within a subroutine defined
+in the C<DB> package doesn't see the usual
+surrounding lexical scope, but rather the scope of the first non-DB piece
+of code that called it. You don't normally need to worry about this unless
+you are writing a Perl debugger.
+
+The final semicolon, if any, may be omitted from the value of EXPR.
+
+=item Block eval
If the code to be executed doesn't vary, you may use the eval-BLOCK
form to trap run-time errors without incurring the penalty of
# a run-time error
eval '$answer ='; # sets $@
+If you want to trap errors when loading an XS module, some problems with
+the binary interface (such as Perl version skew) may be fatal even with
+C<eval> unless C<$ENV{PERL_DL_NONLAZY}> is set. See
+L<perlrun>.
+
Using the C<eval {}> form as an exception trap in libraries does have some
issues. Due to the current arguably broken state of C<__DIE__> hooks, you
may wish not to trigger any C<__DIE__> hooks that user code may have installed.
Because this promotes action at a distance, this counterintuitive behavior
may be fixed in a future release.
-With an L<C<eval>|/eval EXPR>, you should be especially careful to
-remember what's being looked at when:
-
- eval $x; # CASE 1
- eval "$x"; # CASE 2
-
- eval '$x'; # CASE 3
- eval { $x }; # CASE 4
-
- eval "\$$x++"; # CASE 5
- $$x++; # CASE 6
-
-Cases 1 and 2 above behave identically: they run the code contained in
-the variable $x. (Although case 2 has misleading double quotes making
-the reader wonder what else might be happening (nothing is).) Cases 3
-and 4 likewise behave in the same way: they run the code C<'$x'>, which
-does nothing but return the value of $x. (Case 4 is preferred for
-purely visual reasons, but it also has the advantage of compiling at
-compile-time instead of at run-time.) Case 5 is a place where
-normally you I<would> like to use double quotes, except that in this
-particular situation, you can just use symbolic references instead, as
-in case 6.
-
-Before Perl 5.14, the assignment to L<C<$@>|perlvar/$@> occurred before
-restoration
-of localized variables, which means that for your code to run on older
-versions, a temporary is required if you want to mask some but not all
-errors:
-
- # alter $@ on nefarious repugnancy only
- {
- my $e;
- {
- local $@; # protect existing $@
- eval { test_repugnancy() };
- # $@ =~ /nefarious/ and die $@; # Perl 5.14 and higher only
- $@ =~ /nefarious/ and $e = $@;
- }
- die $e if defined $e
- }
-
C<eval BLOCK> does I<not> count as a loop, so the loop control statements
L<C<next>|/next LABEL>, L<C<last>|/last LABEL>, or
L<C<redo>|/redo LABEL> cannot be used to leave or restart the block.
-An C<eval ''> executed within a subroutine defined
-in the C<DB> package doesn't see the usual
-surrounding lexical scope, but rather the scope of the first non-DB piece
-of code that called it. You don't normally need to worry about this unless
-you are writing a Perl debugger.
+The final semicolon, if any, may be omitted from within the BLOCK.
+
+=back
=item evalbytes EXPR
X<evalbytes>
=for Pod::Functions +evalbytes similar to string eval, but intend to parse a bytestream
-This function is like L<C<eval>|/eval EXPR> with a string argument,
-except it always parses its argument, or L<C<$_>|perlvar/$_> if EXPR is
-omitted, as a string of bytes. A string containing characters whose
-ordinal value exceeds 255 results in an error. Source filters activated
-within the evaluated code apply to the code itself.
+This function is similar to a L<string eval|/eval EXPR>, except it
+always parses its argument (or L<C<$_>|perlvar/$_> if EXPR is omitted)
+as a string of independent bytes.
-L<C<evalbytes>|/evalbytes EXPR> is available only if the
-L<C<"evalbytes"> feature|feature/The 'unicode_eval' and 'evalbytes' features>
-is enabled or if it is prefixed with C<CORE::>. The
+If called when S<C<use utf8>> is in effect, the string will be assumed
+to be encoded in UTF-8, and C<evalbytes> will make a temporary
+downgraded to non-UTF-8 copy to work from. If this is not possible
+(because one or more characters in it require UTF-8), the C<evalbytes>
+will fail with the error stored in C<$@>.
+
+Bytes that correspond to ASCII-range code points will have their normal
+meanings for operators in the string. The treatment of the other bytes
+depends on if the L<C<'unicode_strings"> feature|feature/The
+'unicode_strings' feature> is in effect.
+
+Of course, variables that are UTF-8 and are referred to in the string
+retain that:
+
+ my $a = "\x{100}";
+ evalbytes 'print ord $a, "\n"';
+
+prints
+
+ 256
+
+and C<$@> is empty.
+
+Source filters activated within the evaluated code apply to the code
+itself.
+
+L<C<evalbytes>|/evalbytes EXPR> is available starting in Perl v5.16. To
+access it, you must say C<CORE::evalbytes>, but you can omit the
+C<CORE::> if the
L<C<"evalbytes"> feature|feature/The 'unicode_eval' and 'evalbytes' features>
-is enabled automatically with a C<use v5.16> (or higher) declaration in
-the current scope.
+is enabled. This is enabled automatically with a C<use v5.16> (or
+higher) declaration in the current scope.
=item exec LIST
X<exec> X<execute>
Like all Perl character operations, L<C<length>|/length EXPR> normally
deals in logical
characters, not physical bytes. For how many bytes a string encoded as
-UTF-8 would take up, use C<length(Encode::encode_utf8(EXPR))> (you'll have
-to C<use Encode> first). See L<Encode> and L<perlunicode>.
+UTF-8 would take up, use C<length(Encode::encode('UTF-8', EXPR))>
+
(you'll have to C<use Encode> first). See L<Encode> and L<perlunicode>.
=item __LINE__
X<__LINE__>
(8-bit) bytes or characters are received. By default all sockets
operate on bytes, but for example if the socket has been changed using
L<C<binmode>|/binmode FILEHANDLE, LAYER> to operate with the
-C<:encoding(utf8)> I/O layer (see the L<open> pragma), the I/O will
+C<:encoding(UTF-8)> I/O layer (see the L<open> pragma), the I/O will
operate on UTF8-encoded Unicode
characters, not bytes. Similarly for the C<:encoding> layer: in that
case pretty much any characters can be read.
otherwise.
Note the emphasis on bytes: even if the filehandle has been set to operate
-on characters (for example using the C<:encoding(utf8)> I/O layer), the
+on characters (for example using the C<:encoding(UTF-8)> I/O layer), the
L<C<seek>|/seek FILEHANDLE,POSITION,WHENCE>,
L<C<tell>|/tell FILEHANDLE>, and
L<C<sysseek>|/sysseek FILEHANDLE,POSITION,WHENCE>
(8-bit) bytes or characters are sent. By default all sockets operate
on bytes, but for example if the socket has been changed using
L<C<binmode>|/binmode FILEHANDLE, LAYER> to operate with the
-C<:encoding(utf8)> I/O layer (see L<C<open>|/open FILEHANDLE,EXPR>, or
+C<:encoding(UTF-8)> I/O layer (see L<C<open>|/open FILEHANDLE,EXPR>, or
the L<open> pragma), the I/O will operate on UTF-8
encoded Unicode characters, not bytes. Similarly for the C<:encoding>
layer: in that case pretty much any characters can be sent.
passed by reference in L<C<@_>|perlvar/@_>, as for a normal subroutine.
This is slower than unprototyped subroutines, where the elements to be
compared are passed into the subroutine as the package global variables
-C<$a> and C<$b> (see example below). Note that in the latter case, it
-is usually highly counter-productive to declare C<$a> and C<$b> as
-lexicals.
+C<$a> and C<$b> (see example below).
If the subroutine is an XSUB, the elements to be compared are pushed on
to the stack, the way arguments are usually passed to XSUBs. C<$a> and
my @contact = sort(find_records @key);
my @contact = sort(find_records (@key));
-You I<must not> declare C<$a>
-and C<$b> as lexicals. They are package globals. That means
-that if you're in the C<main> package and type
-
- my @articles = sort {$b <=> $a} @files;
-
-then C<$a> and C<$b> are C<$main::a> and C<$main::b> (or C<$::a> and C<$::b>),
-but if you're in the C<FooPack> package, it's the same as typing
-
- my @articles = sort {$FooPack::b <=> $FooPack::a} @files;
+C<$a> and C<$b> are set as package globals in the package the sort() is
+called from. That means C<$main::a> and C<$main::b> (or C<$::a> and
+C<$::b>) in the C<main> package, C<$FooPack::a> and C<$FooPack::b> in the
+C<FooPack> package, etc. If the sort block is in scope of a C<my> or
+C<state> declaration of C<$a> and/or C<$b>, you I<must> spell out the full
+name of the variables in the sort block :
+
+ package main;
+ my $a = "C"; # DANGER, Will Robinson, DANGER !!!
+
+ print sort { $a cmp $b } qw(A C E G B D F H);
+ # WRONG
+ sub badlexi { $a cmp $b }
+ print sort badlexi qw(A C E G B D F H);
+ # WRONG
+ # the above prints BACFEDGH or some other incorrect ordering
+
+ print sort { $::a cmp $::b } qw(A C E G B D F H);
+ # OK
+ print sort { our $a cmp our $b } qw(A C E G B D F H);
+ # also OK
+ print sort { our ($a, $b); $a cmp $b } qw(A C E G B D F H);
+ # also OK
+ sub lexi { our $a cmp our $b }
+ print sort lexi qw(A C E G B D F H);
+ # also OK
+ # the above print ABCDEFGH
+
+With proper care you may mix package and my (or state) C<$a> and/or C<$b>:
+
+ my $a = {
+ tiny => -2,
+ small => -1,
+ normal => 0,
+ big => 1,
+ huge => 2
+ };
+
+ say sort { $a->{our $a} <=> $a->{our $b} }
+ qw{ huge normal tiny small big};
+
+ # prints tinysmallnormalbighuge
+
+C<$a> and C<$b> are implicitely local to the sort() execution and regain their
+former values upon completing the sort.
+
+Sort subroutines written using C<$a> and C<$b> are bound to their calling
+package. It is possible, but of limited interest, to define them in a
+different package, since the subroutine must still refer to the calling
+package's C<$a> and C<$b> :
+
+ package Foo;
+ sub lexi { $Bar::a cmp $Bar::b }
+ package Bar;
+ ... sort Foo::lexi ...
+
+Use the prototyped versions (see above) for a more generic alternative.
The comparison function is required to behave. If it returns
inconsistent results (sometimes saying C<$x[1]> is less than C<$x[2]> and
POSITION, typically negative.
Note the emphasis on bytes: even if the filehandle has been set to operate
-on characters (for example using the C<:encoding(utf8)> I/O layer), the
+on characters (for example using the C<:encoding(UTF-8)> I/O layer), the
L<C<seek>|/seek FILEHANDLE,POSITION,WHENCE>,
L<C<tell>|/tell FILEHANDLE>, and
L<C<sysseek>|/sysseek FILEHANDLE,POSITION,WHENCE>
last read.
Note the emphasis on bytes: even if the filehandle has been set to operate
-on characters (for example using the C<:encoding(utf8)> I/O layer), the
+on characters (for example using the C<:encoding(UTF-8)> I/O layer), the
L<C<seek>|/seek FILEHANDLE,POSITION,WHENCE>,
L<C<tell>|/tell FILEHANDLE>, and
L<C<sysseek>|/sysseek FILEHANDLE,POSITION,WHENCE>
Chris C<BinGOs> Williams, Zefram, Ævar Arnfjörð Bjarmason, Stevan
Little, Dave Rolsky, Max Maischein, Abigail, Jesse Luehrs, Tony Cook,
Dominic Hargreaves, Aaron Crane, Aristotle Pagaltzis, Matthew Horsfall,
-Peter Martini, Sawyer X, and Chad 'Exodist' Granum.
+Peter Martini, Sawyer X, Chad 'Exodist' Granum, and Renee Bäcker.
=head2 PUMPKIN?
Chad 5.25.7 2016-Nov-20
Sawyer X 5.25.8 2016-Dec-20
Abigail 5.25.9 2017-Jan-20
+ Renee 5.25.10 2017-Feb-20
=head2 SELECTED RELEASE SIZES
C<"and">, C<"or">, and C<"not">, which may be used to evaluate calls to list
operators without the need for parentheses:
- open HANDLE, "< :utf8", "filename" or die "Can't open: $!\n";
+ open HANDLE, "< :encoding(UTF-8)", "filename"
+ or die "Can't open: $!\n";
However, some people find that code harder to read than writing
it with parentheses:
- open(HANDLE, "< :utf8", "filename") or die "Can't open: $!\n";
+ open(HANDLE, "< :encoding(UTF-8)", "filename")
+ or die "Can't open: $!\n";
in which case you might as well just use the more customary C<"||"> operator:
- open(HANDLE, "< :utf8", "filename") || die "Can't open: $!\n";
+ open(HANDLE, "< :encoding(UTF-8)", "filename")
+ || die "Can't open: $!\n";
See also discussion of list operators in L</Terms and List Operators (Leftward)>.
my @hebrew = unpack( 'U*', $utf );
Please note: in the general case, you're better off using
-Encode::decode_utf8 to decode a UTF-8 encoded byte string to a Perl
-Unicode string, and Encode::encode_utf8 to encode a Perl Unicode string
-to UTF-8 bytes. These functions provide means of handling invalid byte
+L<C<Encode::decode('UTF-8', $utf)>|Encode/decode> to decode a UTF-8
+encoded byte string to a Perl Unicode string, and
+L<C<Encode::encode('UTF-8', $str)>|Encode/encode> to encode a Perl Unicode
+string to UTF-8 bytes. These functions provide means of handling invalid byte
sequences and generally have a friendlier interface.
=head2 Another Portable Binary Encoding
automatically turned on within this construct.
All the other escapes accepted by normal bracketed character classes are
-accepted here as well; but unrecognized escapes that generate warnings
-in normal classes are fatal errors here.
-
-All warnings from these class elements are fatal, as well as some
-practices that don't currently warn. For example you cannot say
+accepted here as well.
+
+Because this construct compiles under
+L<C<use re 'strict>|re/'strict' mode>, unrecognized escapes that
+generate warnings in normal classes are fatal errors here, as well as
+all other warnings from these class elements, as well as some
+practices that don't currently warn outside C<re 'strict'>. For example
+you cannot say
/(?[ [ \xF ] ])/ # Syntax error!
'C:\WIN32' =~ /C:\\WIN/; # matches
+In situations where it doesn't make sense for a particular metacharacter
+to mean what it normally does, it automatically loses its
+metacharacter-ness and becomes an ordinary character that is to be
+matched literally. For example, the C<'}'> is a metacharacter only when
+it is the mate of a C<'{'> metacharacter. Otherwise it is treated as a
+literal RIGHT CURLY BRACKET. This may lead to unexpected results.
+L<C<use re 'strict'>|re/'strict' mode> can catch some of these.
+
In addition to the metacharacters, there are some ASCII characters
which don't have printable character equivalents and are instead
represented by I<escape sequences>. Common examples are C<\t> for a
that output should be in utf8 and that input should be regarded as
already in valid utf8 form. B<WARNING: It does not check for validity and as such
should be handled with extreme caution for input, because security violations
-can occur with non-shortest UTF-8 encodings, etc.> Generally C<:encoding(utf8)> is
+can occur with non-shortest UTF-8 encodings, etc.> Generally C<:encoding(UTF-8)> is
the best option when reading UTF-8 encoded data.
=item :win32
A filehandle that should read or write UTF-8
if ($] > 5.008) {
- binmode $fh, ":encoding(utf8)";
+ binmode $fh, ":encoding(UTF-8)";
}
=item *
if ($] > 5.008) {
require Encode;
- $val = Encode::encode_utf8($val); # make octets
+ $val = Encode::encode("UTF-8", $val); # make octets
}
=item *
if ($] > 5.008) {
require Encode;
- $val = Encode::decode_utf8($val);
+ $val = Encode::decode("UTF-8", $val);
}
=item *
sub my_escape_html ($) {
my($what) = shift;
return unless defined $what;
- Encode::decode_utf8(Foo::Bar::escape_html(
- Encode::encode_utf8($what)));
+ Encode::decode("UTF-8", Foo::Bar::escape_html(
+ Encode::encode("UTF-8", $what)));
}
Sometimes, when the extension does not convert data but just stores
use strict; # quote strings, declare variables
use warnings; # on by default
use warnings qw(FATAL utf8); # fatalize encoding glitches
- use open qw(:std :utf8); # undeclared streams in UTF-8
+ use open qw(:std :encoding(UTF-8)); # undeclared streams in UTF-8
use charnames qw(:full :short); # unneeded in v5.16
This I<does> make even Unix programmers C<binmode> your binary streams,
or
$ export PERL_UNICODE=A
or
- use Encode qw(decode_utf8);
- @ARGV = map { decode_utf8($_, 1) } @ARGV;
+ use Encode qw(decode);
+ @ARGV = map { decode('UTF-8', $_, 1) } @ARGV;
=head2 ℞ 14: Decode program arguments as locale encoding
or
$ export PERL_UNICODE=S
or
- use open qw(:std :utf8);
+ use open qw(:std :encoding(UTF-8));
or
- binmode(STDIN, ":utf8");
+ binmode(STDIN, ":encoding(UTF-8)");
binmode(STDOUT, ":utf8");
binmode(STDERR, ":utf8");
or
$ export PERL_UNICODE=D
or
- use open qw(:utf8);
+ use open qw(:encoding(UTF-8));
=head2 ℞ 18: Make all I/O and args default to utf8
or
$ export PERL_UNICODE=SDA
or
- use open qw(:std :utf8);
- use Encode qw(decode_utf8);
- @ARGV = map { decode_utf8($_, 1) } @ARGV;
+ use open qw(:std :encoding(UTF-8));
+ use Encode qw(decode);
+ @ARGV = map { decode('UTF-8', $_, 1) } @ARGV;
=head2 ℞ 19: Open file with specific encoding
use strict;
use warnings;
use warnings qw(FATAL utf8); # fatalize encoding faults
- use open qw(:std :utf8); # undeclared streams in UTF-8
+ use open qw(:std :encoding(UTF-8)); # undeclared streams in UTF-8
use charnames qw(:full :short); # unneeded in v5.16
# std modules
=head2 What are C<decode_utf8> and C<encode_utf8>?
These are alternate syntaxes for C<decode('utf8', ...)> and C<encode('utf8',
-...)>.
+...)>. Do not use these functions for data exchange. Instead use
+C<decode('UTF-8', ...)> and C<encode('UTF-8', ...)>; see
+L</What's the difference between UTF-8 and utf8?> below.
=head2 What is a "wide character"?
what it accepts. If you have to communicate with things that aren't so liberal,
you may want to consider using C<UTF-8>. If you have to communicate with things
that are too liberal, you may have to use C<utf8>. The full explanation is in
-L<Encode>.
+L<Encode/"UTF-8 vs. utf8 vs. UTF8">.
C<UTF-8> is internally known as C<utf-8-strict>. The tutorial uses UTF-8
consistently, even where utf8 is actually used internally, because the
for doing conversions between those encodings:
use Encode 'decode';
- $data = decode("iso-8859-3", $data); # convert from legacy to utf-8
+ $data = decode("iso-8859-3", $data); # convert from legacy
=head2 Unicode I/O
must always be specified exactly like that; it is I<not> subject to
the loose matching of encoding names. Also note that currently C<:utf8> is unsafe for
input, because it accepts the data without validating that it is indeed valid
-UTF-8; you should instead use C<:encoding(utf-8)> (with or without a
+UTF-8; you should instead use C<:encoding(UTF-8)> (with or without a
hyphen).
See L<PerlIO> for the C<:utf8> layer, L<PerlIO::encoding> and
Unicode in Perl's eyes. To do that, specify the appropriate
layer when opening files
- open(my $fh,'<:encoding(utf8)', 'anything');
+ open(my $fh,'<:encoding(UTF-8)', 'anything');
my $line_of_unicode = <$fh>;
open(my $fh,'<:encoding(Big5)', 'anything');
The I/O layers can also be specified more flexibly with
the C<open> pragma. See L<open>, or look at the following example.
- use open ':encoding(utf8)'; # input/output default encoding will be
- # UTF-8
+ use open ':encoding(UTF-8)'; # input/output default encoding will be
+ # UTF-8
open X, ">file";
print X chr(0x100), "\n";
close X;
local $/; ## read in the whole file of 8-bit characters
$t = <F>;
close F;
- open F, ">:encoding(utf8)", "file";
+ open F, ">:encoding(UTF-8)", "file";
print F $t; ## convert to UTF-8 on output
close F;
If you run this code twice, the contents of the F<file> will be twice
-UTF-8 encoded. A C<use open ':encoding(utf8)'> would have avoided the
+UTF-8 encoded. A C<use open ':encoding(UTF-8)'> would have avoided the
bug, or explicitly opening also the F<file> for input as UTF-8.
B<NOTE>: the C<:utf8> and C<:encoding> features work only if your
C<$a> will stay byte-encoded.
Sometimes you might really need to know the byte length of a string
-instead of the character length. For that use either the
-C<Encode::encode_utf8()> function or the C<bytes> pragma
+instead of the character length. For that use the C<bytes> pragma
and the C<length()> function:
my $unicode = chr(0x100);
print length($unicode), "\n"; # will print 1
- require Encode;
- print length(Encode::encode_utf8($unicode)),"\n"; # will print 2
use bytes;
- print length($unicode), "\n"; # will also print 2
+ print length($unicode), "\n"; # will print 2
# (the 0xC4 0x80 of the UTF-8)
no bytes;
Use the C<Encode> package to try converting it.
For example,
- use Encode 'decode_utf8';
+ use Encode 'decode';
- if (eval { decode_utf8($string, Encode::FB_CROAK); 1 }) {
- # $string is valid utf8
+ if (eval { decode('UTF-8', $string, Encode::FB_CROAK); 1 }) {
+ # $string is valid UTF-8
} else {
- # $string is not valid utf8
+ # $string is not valid UTF-8
}
Or use C<unpack> to try decoding it:
interpreted via a particular encoding, you can use C<Encode>:
use Encode 'from_to';
- from_to($data, "iso-8859-1", "utf-8"); # from latin-1 to utf-8
+ from_to($data, "iso-8859-1", "UTF-8"); # from latin-1 to UTF-8
The call to C<from_to()> changes the bytes in C<$data>, but nothing
material about the nature of the string has changed as far as Perl is
If you have a sequence of bytes you B<know> is valid UTF-8,
but Perl doesn't know it yet, you can make Perl a believer, too:
- use Encode 'decode_utf8';
- $Unicode = decode_utf8($bytes);
+ $Unicode = $bytes;
+ utf8::decode($Unicode);
or:
const U8 *s = (U8*)SvPV_const(argsv, len);
SETu(DO_UTF8(argsv)
- ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV)
+ ? (len ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV) : 0)
: (UV)(*s));
return NORMAL;
}
else {
char *up;
- char *down;
- I32 tmp;
dTARGET;
STRLEN len;
up = SvPV_force(TARG, len);
if (len > 1) {
+ char *down;
if (DO_UTF8(TARG)) { /* first reverse each character */
U8* s = (U8*)SvPVX(TARG);
const U8* send = (U8*)(s + len);
down = (char*)(s - 1);
/* reverse this character */
while (down > up) {
- tmp = *up;
+ const char tmp = *up;
*up++ = *down;
- *down-- = (char)tmp;
+ *down-- = tmp;
}
}
}
}
down = SvPVX(TARG) + len - 1;
while (down > up) {
- tmp = *up;
+ const char tmp = *up;
*up++ = *down;
- *down-- = (char)tmp;
+ *down-- = tmp;
}
(void)SvPOK_only_UTF8(TARG);
}
}
+static SV *
+S_find_runcv_name(void)
+{
+ dTHX;
+ CV *cv;
+ GV *gv;
+ SV *sv;
+
+ cv = find_runcv(0);
+ if (!cv)
+ return &PL_sv_no;
+
+ gv = CvGV(cv);
+ if (!gv)
+ return &PL_sv_no;
+
+ sv = sv_2mortal(newSV(0));
+ gv_fullname4(sv, gv, NULL, TRUE);
+ return sv;
+}
/* Check a a subs arguments - i.e. that it has the correct number of args
* (and anything else we might think of in future). Typically used with
too_few = (argc < (params - opt_params));
if (UNLIKELY(too_few || (!slurpy && argc > params)))
- /* diag_listed_as: Too few arguments for subroutine */
- /* diag_listed_as: Too many arguments for subroutine */
- Perl_croak_caller("Too %s arguments for subroutine",
- too_few ? "few" : "many");
+ /* diag_listed_as: Too few arguments for subroutine '%s' */
+ /* diag_listed_as: Too many arguments for subroutine '%s' */
+ Perl_croak_caller("Too %s arguments for subroutine '%" SVf "'",
+ too_few ? "few" : "many", S_find_runcv_name());
if (UNLIKELY(slurpy == '%' && argc > params && (argc - params) % 2))
- Perl_croak_caller("Odd name/value argument for subroutine");
-
+ /* diag_listed_as: Odd name/value argument for subroutine '%s' */
+ Perl_croak_caller("Odd name/value argument for subroutine '%" SVf "'",
+ S_find_runcv_name());
return NORMAL;
}
SvTAINTED_on(PL_formtarget);
if (DO_UTF8(PL_formtarget))
targ_is_utf8 = TRUE;
+ /* this is an initial estimate of how much output buffer space
+ * to allocate. It may be exceeded later */
linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
t = SvGROW(PL_formtarget, len + linemax + 1);
/* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
if (targ_is_utf8 && !item_is_utf8) {
source = tmp = bytes_to_utf8(source, &to_copy);
+ grow = to_copy;
} else {
if (item_is_utf8 && !targ_is_utf8) {
U8 *s;
OP *gotoprobe = NULL;
bool leaving_eval = FALSE;
bool in_block = FALSE;
+ bool pseudo_block = FALSE;
PERL_CONTEXT *last_eval_cx = NULL;
/* find label */
gotoprobe = PL_main_root;
break;
case CXt_SUB:
- if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
- gotoprobe = CvROOT(cx->blk_sub.cv);
- break;
- }
- /* FALLTHROUGH */
+ gotoprobe = CvROOT(cx->blk_sub.cv);
+ pseudo_block = cBOOL(CxMULTICALL(cx));
+ break;
case CXt_FORMAT:
case CXt_NULL:
DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
break;
}
}
+ if (pseudo_block)
+ DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
PL_lastgotoprobe = gotoprobe;
}
if (!retop)
SV *old = mg->mg_obj;
if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
&& len == SvCUR(old)
- && strnEQ(SvPVX(old), SvPVX(sv), len)
+ && strnEQ(SvPVX(old), s, len)
) {
DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
return mg;
dSP;
PADOFFSET base = PL_op->op_targ;
int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
- int i;
if (PL_op->op_flags & OPf_SPECIAL) {
/* fake the RHS of my ($x,$y,..) = @_ */
PUSHMARK(SP);
/* note, this is only skipped for compile-time-known void cxt */
if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
+ int i;
+
EXTEND(SP, count);
PUSHMARK(SP);
for (i = 0; i <count; i++)
(base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
| (count << SAVE_TIGHT_SHIFT)
| SAVEt_CLEARPADRANGE);
+ int i;
+
STATIC_ASSERT_STMT(OPpPADRANGE_COUNTMASK + 1 == (1 << OPpPADRANGE_COUNTSHIFT));
assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
== (Size_t)base);
|| ( PL_op->op_private & OPpMAYBE_TRUEBOOL
&& block_gimme() == G_VOID ))
&& (!SvRMAGICAL(sv) || !mg_find(sv, PERL_MAGIC_tied)))
- SETs(HvUSEDKEYS(sv) ? &PL_sv_yes : &PL_sv_no);
+ SETs(HvUSEDKEYS(MUTABLE_HV(sv)) ? &PL_sv_yes : &PL_sv_no);
else if (gimme == G_SCALAR) {
dTARG;
TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
assert(svr);
if (UNLIKELY(SvFLAGS(svr) & (SVf_BREAK|SVs_GMG) || copy_all)) {
+ U32 brk = (SvFLAGS(svr) & SVf_BREAK);
#ifdef DEBUGGING
if (fake) {
/* ... but restore afterwards in case it's needed again,
* e.g. ($a,$b,$c) = (1,$a,$a)
*/
- SvFLAGS(svr) |= SVf_BREAK;
+ SvFLAGS(svr) |= brk;
}
if (!lcount)
utf8_to_byte(pTHX_ const char **s, const char *end, I32 datumtype)
{
STRLEN retlen;
- UV val = utf8n_to_uvchr((U8 *) *s, end-*s, &retlen,
+ UV val;
+
+ if (*s >= end) {
+ goto croak;
+ }
+ val = utf8n_to_uvchr((U8 *) *s, end-*s, &retlen,
ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
- /* We try to process malformed UTF-8 as much as possible (preferably with
- warnings), but these two mean we make no progress in the string and
- might enter an infinite loop */
- if (retlen == (STRLEN) -1 || retlen == 0)
+ if (retlen == (STRLEN) -1)
+ croak:
Perl_croak(aTHX_ "Malformed UTF-8 string in '%c' format in unpack",
(int) TYPE_NO_MODIFIERS(datumtype));
if (val >= 0x100) {
for (;buf_len > 0; buf_len--) {
if (from >= end) return FALSE;
val = utf8n_to_uvchr((U8 *) from, end-from, &retlen, flags);
- if (retlen == (STRLEN) -1 || retlen == 0) {
+ if (retlen == (STRLEN) -1) {
from += UTF8SKIP(from);
bad |= 1;
} else from += retlen;
STRLEN retlen; \
if (str >= end) break; \
val = utf8n_to_uvchr((U8 *) str, end-str, &retlen, utf8_flags); \
- if (retlen == (STRLEN) -1 || retlen == 0) { \
+ if (retlen == (STRLEN) -1) { \
*cur = '\0'; \
Perl_croak(aTHX_ "Malformed UTF-8 string in pack"); \
} \
STRLEN retlen;
aint = utf8n_to_uvchr((U8 *) s, strend-s, &retlen,
ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
- if (retlen == (STRLEN) -1 || retlen == 0)
+ if (retlen == (STRLEN) -1)
Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
s += retlen;
}
STRLEN retlen;
const UV val = utf8n_to_uvchr((U8 *) s, strend-s, &retlen,
ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
- if (retlen == (STRLEN) -1 || retlen == 0)
+ if (retlen == (STRLEN) -1)
Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
s += retlen;
if (!checksum)
strend - s,
&retlen,
UTF8_ALLOW_DEFAULT));
- if (retlen == (STRLEN) -1 || retlen == 0)
+ if (retlen == (STRLEN) -1)
Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
s += retlen;
}
GROWING(0, cat, start, cur, len+UTF8_MAXLEN);
end = start+SvLEN(cat)-UTF8_MAXLEN;
}
- cur = (char *) uvchr_to_utf8_flags((U8 *) cur,
- auv,
- warn_utf8 ?
- 0 : UNICODE_ALLOW_ANY);
+ cur = (char *) uvchr_to_utf8_flags((U8 *) cur, auv, 0);
} else {
if (auv >= 0x100) {
if (!SvUTF8(cat)) {
auv = SvUV_no_inf(fromstr, datumtype);
if (utf8) {
U8 buffer[UTF8_MAXLEN], *endb;
- endb = uvchr_to_utf8_flags(buffer, UNI_TO_NATIVE(auv),
- warn_utf8 ?
- 0 : UNICODE_ALLOW_ANY);
+ endb = uvchr_to_utf8_flags(buffer, UNI_TO_NATIVE(auv), 0);
if (cur+(endb-buffer)*UTF8_EXPAND >= end) {
*cur = '\0';
SvCUR_set(cat, cur - start);
GROWING(0, cat, start, cur, len+UTF8_MAXLEN);
end = start+SvLEN(cat)-UTF8_MAXLEN;
}
- cur = (char *) uvchr_to_utf8_flags((U8 *) cur, UNI_TO_NATIVE(auv),
- warn_utf8 ?
- 0 : UNICODE_ALLOW_ANY);
+ cur = (char *) uvchr_to_utf8_flags((U8 *) cur,
+ UNI_TO_NATIVE(auv),
+ 0);
}
}
break;
=for apidoc sortsv
-Sort an array. Here is an example:
-
- sortsv(AvARRAY(av), av_top_index(av)+1, Perl_sv_cmp_locale);
+In-place sort an array of SV pointers with the given comparison routine.
Currently this always uses mergesort. See C<L</sortsv_flags>> for a more
flexible routine.
/*
=for apidoc sortsv_flags
-Sort an array, with various options.
+In-place sort an array of SV pointers with the given comparison routine,
+with various SORTf_* flag options.
=cut
*/
*/
stash = gv_stashsv(*MARK, 0);
if (!stash) {
- SV *stashname = SvOK(*MARK) ? *MARK : &PL_sv_no;
- if (!SvCUR(*MARK)) {
- stashname = sv_2mortal(newSVpvs("main"));
+ if (SvROK(*MARK))
+ DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\"",
+ methname, SVfARG(*MARK));
+ else if (isGV(*MARK)) {
+ /* If the glob doesn't name an existing package, using
+ * SVfARG(*MARK) would yield "*Foo::Bar" or *main::Foo. So
+ * generate the name for the error message explicitly. */
+ SV *stashname = sv_2mortal(newSV(0));
+ gv_fullname4(stashname, (GV *) *MARK, NULL, FALSE);
+ DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\"",
+ methname, SVfARG(stashname));
+ }
+ else {
+ SV *stashname = !SvPOK(*MARK) ? &PL_sv_no
+ : SvCUR(*MARK) ? *MARK
+ : sv_2mortal(newSVpvs("main"));
+ DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\""
+ " (perhaps you forgot to load \"%" SVf "\"?)",
+ methname, SVfARG(stashname), SVfARG(stashname));
}
- DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\""
- " (perhaps you forgot to load \"%" SVf "\"?)",
- methname, SVfARG(stashname), SVfARG(stashname));
}
else if (!(gv = gv_fetchmethod(stash, methname))) {
/* The effective name can only be NULL for stashes that have
IO *io;
GV *fgv;
CV *cv = NULL;
- SV *tmpsv = NULL;
if (MAXARG == 0) {
EXTEND(SP, 1);
cv = GvFORM(fgv);
if (!cv) {
- tmpsv = sv_newmortal();
+ SV * const tmpsv = sv_newmortal();
gv_efullname4(tmpsv, fgv, NULL, FALSE);
DIE(aTHX_ "Undefined format \"%" SVf "\" called", SVfARG(tmpsv));
}
if (did_pipes) {
int errkid;
unsigned n = 0;
- SSize_t n1;
while (n < sizeof(int)) {
- n1 = PerlLIO_read(pp[0],
+ const SSize_t n1 = PerlLIO_read(pp[0],
(void*)(((char*)&errkid)+n),
(sizeof(int)) - n);
if (n1 <= 0)
PP(pp_sleep)
{
dSP; dTARGET;
- I32 duration;
Time_t lasttime;
Time_t when;
if (MAXARG < 1 || (!TOPs && !POPs))
PerlProc_pause();
else {
- duration = POPi;
+ const I32 duration = POPi;
if (duration < 0) {
/* diag_listed_as: %s() with negative argument */
Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC),
PERL_CALLCONV void Perl_Slab_Free(pTHX_ void *op);
#define PERL_ARGS_ASSERT_SLAB_FREE \
assert(op)
+PERL_CALLCONV char * Perl__byte_dump_string(pTHX_ const U8 * s, const STRLEN len, const bool format);
+#define PERL_ARGS_ASSERT__BYTE_DUMP_STRING \
+ assert(s)
PERL_CALLCONV void Perl__force_out_malformed_utf8_message(pTHX_ const U8 *const p, const U8 * const e, const U32 flags, const bool die_here);
#define PERL_ARGS_ASSERT__FORCE_OUT_MALFORMED_UTF8_MESSAGE \
assert(p); assert(e)
#define PERL_ARGS_ASSERT__TO_UTF8_UPPER_FLAGS \
assert(p); assert(ustrp); assert(file)
PERL_CALLCONV void Perl__warn_problematic_locale(void);
+PERL_CALLCONV void Perl_abort_execution(pTHX_ const char * const msg, const char * const name);
+#define PERL_ARGS_ASSERT_ABORT_EXECUTION \
+ assert(msg); assert(name)
PERL_CALLCONV LOGOP* Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP *other);
PERL_CALLCONV PADOFFSET Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags);
#define PERL_ARGS_ASSERT_ALLOCMY \
PERL_CALLCONV char* Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char *const *const search_ext, I32 flags);
#define PERL_ARGS_ASSERT_FIND_SCRIPT \
assert(scriptname)
-PERL_CALLCONV I32 Perl_foldEQ(const char* a, const char* b, I32 len)
- __attribute__warn_unused_result__
- __attribute__pure__;
+PERL_STATIC_INLINE I32 Perl_foldEQ(const char* a, const char* b, I32 len);
#define PERL_ARGS_ASSERT_FOLDEQ \
assert(a); assert(b)
-
-PERL_CALLCONV I32 Perl_foldEQ_latin1(const char* a, const char* b, I32 len)
- __attribute__warn_unused_result__
- __attribute__pure__;
+PERL_STATIC_INLINE I32 Perl_foldEQ_latin1(const char* a, const char* b, I32 len);
#define PERL_ARGS_ASSERT_FOLDEQ_LATIN1 \
assert(a); assert(b)
-
-PERL_CALLCONV I32 Perl_foldEQ_locale(const char* a, const char* b, I32 len)
- __attribute__warn_unused_result__
- __attribute__pure__;
+PERL_STATIC_INLINE I32 Perl_foldEQ_locale(const char* a, const char* b, I32 len);
#define PERL_ARGS_ASSERT_FOLDEQ_LOCALE \
assert(a); assert(b)
-
/* PERL_CALLCONV I32 foldEQ_utf8(pTHX_ const char *s1, char **pe1, UV l1, bool u1, const char *s2, char **pe2, UV l2, bool u2); */
PERL_CALLCONV I32 Perl_foldEQ_utf8_flags(pTHX_ const char *s1, char **pe1, UV l1, bool u1, const char *s2, char **pe2, UV l2, bool u2, U32 flags);
#define PERL_ARGS_ASSERT_FOLDEQ_UTF8_FLAGS \
assert(pat)
PERL_CALLCONV int Perl_nothreadhook(pTHX);
+PERL_CALLCONV void Perl_notify_parser_that_changed_to_utf8(pTHX);
PERL_CALLCONV OP* Perl_oopsAV(pTHX_ OP* o)
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_OOPSAV \
PERL_CALLCONV OP* Perl_op_append_elem(pTHX_ I32 optype, OP* first, OP* last);
PERL_CALLCONV OP* Perl_op_append_list(pTHX_ I32 optype, OP* first, OP* last);
+PERL_CALLCONV OPclass Perl_op_class(pTHX_ const OP *o);
PERL_CALLCONV void Perl_op_clear(pTHX_ OP* o);
#define PERL_ARGS_ASSERT_OP_CLEAR \
assert(o)
assert(sv); assert(namesv)
PERL_CALLCONV void Perl_sv_dump(pTHX_ SV* sv);
-#define PERL_ARGS_ASSERT_SV_DUMP \
- assert(sv)
/* PERL_CALLCONV I32 sv_eq(pTHX_ SV* sv1, SV* sv2); */
PERL_CALLCONV I32 Perl_sv_eq_flags(pTHX_ SV* sv1, SV* sv2, const U32 flags);
#ifndef NO_MATHOMS
#define PERL_ARGS_ASSERT_SV_INSERT \
assert(bigstr); assert(little)
#endif
-PERL_CALLCONV void Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags);
+PERL_CALLCONV void Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *little, const STRLEN littlelen, const U32 flags);
#define PERL_ARGS_ASSERT_SV_INSERT_FLAGS \
assert(bigstr); assert(little)
PERL_CALLCONV int Perl_sv_isa(pTHX_ SV* sv, const char *const name);
#define PERL_ARGS_ASSERT_UTF8_TO_UVCHR \
assert(s)
-/* PERL_CALLCONV UV utf8_to_uvchr_buf(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen); */
+PERL_CALLCONV UV Perl_utf8_to_uvchr_buf(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen);
+#define PERL_ARGS_ASSERT_UTF8_TO_UVCHR_BUF \
+ assert(s); assert(send)
PERL_CALLCONV UV Perl_utf8_to_uvuni(pTHX_ const U8 *s, STRLEN *retlen)
__attribute__deprecated__;
#define PERL_ARGS_ASSERT_UTF8_TO_UVUNI \
#define PERL_ARGS_ASSERT_YYERROR_PV \
assert(s)
PERL_CALLCONV int Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags);
-#define PERL_ARGS_ASSERT_YYERROR_PVN \
- assert(s)
PERL_CALLCONV int Perl_yylex(pTHX);
PERL_CALLCONV int Perl_yyparse(pTHX_ int gramtype);
+PERL_CALLCONV void Perl_yyquit(pTHX);
PERL_CALLCONV void Perl_yyunlex(pTHX);
#if !(defined(DEBUGGING))
# if !defined(NV_PRESERVES_UV)
STATIC unsigned int S_regex_set_precedence(const U8 my_operator)
__attribute__warn_unused_result__;
-STATIC void S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth);
+STATIC void S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *operand, U32 depth);
#define PERL_ARGS_ASSERT_REGINSERT \
- assert(pRExC_state); assert(opnd)
+ assert(pRExC_state); assert(operand)
STATIC regnode* S_regnode_guts(pTHX_ RExC_state_t *pRExC_state, const U8 op, const STRLEN extra_len, const char* const name);
#define PERL_ARGS_ASSERT_REGNODE_GUTS \
assert(pRExC_state); assert(name)
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)
* 37f6186253da9824bdb27f4ad867bfe8c25d4dc6bdb2f05585e40a034675a348 lib/unicore/extracted/DLineBreak.txt
* ef24061b5a5dc93d7e90c2e34530ec757180ee75d872cba65ffc946e52624ae8 lib/unicore/extracted/DNumType.txt
* a197371fec9a1b517058b440841f60f9378d81682084eef8db22a88cb2f96e90 lib/unicore/extracted/DNumValues.txt
- * 4bcfb4545be21663ca38a2acbfcbf2b0f3252652a34b50f1a56ef76cb959861b lib/unicore/mktables
+ * 79a7216aceb1d291f2857085545fdda289518bc540a09bc0a15cde105d76028d lib/unicore/mktables
* cdecb300baad839a6f62791229f551a4fa33f3cbdca08e378dc976466354e778 lib/unicore/version
* 913d2f93f3cb6cdf1664db888bf840bc4eb074eef824e082fceda24a9445e60c regen/charset_translations.pl
* 1d27ae8b75d81a082b1fc594673e08540280f8169309a7b5047015c8091a2bfb regen/regcharclass.pl
I32 recode_x_to_native;
#endif
I32 in_multi_char_class;
- struct reg_code_block *code_blocks; /* positions of literal (?{})
+ struct reg_code_blocks *code_blocks;/* positions of literal (?{})
within pattern */
- int num_code_blocks; /* size of code_blocks[] */
int code_index; /* next code_blocks[] slot */
SSize_t maxlen; /* mininum possible number of chars in string to match */
scan_frame *frame_head;
REPORT_LOCATION_ARGS(loc)); \
} STMT_END
-#define vWARN4dep(loc, m, a1, a2, a3) STMT_START { \
- __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN2(WARN_REGEXP,WARN_DEPRECATED), \
- m REPORT_LOCATION, \
- a1, a2, a3, \
- REPORT_LOCATION_ARGS(loc)); \
-} STMT_END
-
#define ckWARN4reg(loc, m, a1, a2, a3) STMT_START { \
__ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), \
m REPORT_LOCATION, \
However, this time it's not a subexpression
we care about, but the expression itself. */
&& (maxcount == REG_INFTY)
- && data && ++data->whilem_c < 16) {
+ && data) {
/* This stays as CURLYX, we can put the count/of pair. */
/* Find WHILEM (as in regexec.c) */
regnode *nxt = oscan + NEXT_OFF(oscan);
if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
nxt += ARG(nxt);
- PREVOPER(nxt)->flags = (U8)(data->whilem_c
- | (RExC_whilem_seen << 4)); /* On WHILEM */
+ nxt = PREVOPER(nxt);
+ if (nxt->flags & 0xf) {
+ /* we've already set whilem count on this node */
+ } else if (++data->whilem_c < 16) {
+ assert(data->whilem_c <= RExC_whilem_seen);
+ nxt->flags = (U8)(data->whilem_c
+ | (RExC_whilem_seen << 4)); /* On WHILEM */
+ }
}
if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
pars++;
}
+static void
+S_free_codeblocks(pTHX_ struct reg_code_blocks *cbs)
+{
+ int n;
+
+ if (--cbs->refcnt > 0)
+ return;
+ for (n = 0; n < cbs->count; n++) {
+ REGEXP *rx = cbs->cb[n].src_regex;
+ cbs->cb[n].src_regex = NULL;
+ SvREFCNT_dec(rx);
+ }
+ Safefree(cbs->cb);
+ Safefree(cbs);
+}
+
+
+static struct reg_code_blocks *
+S_alloc_code_blocks(pTHX_ int ncode)
+{
+ struct reg_code_blocks *cbs;
+ Newx(cbs, 1, struct reg_code_blocks);
+ cbs->count = ncode;
+ cbs->refcnt = 1;
+ SAVEDESTRUCTOR_X(S_free_codeblocks, cbs);
+ if (ncode)
+ Newx(cbs->cb, ncode, struct reg_code_block);
+ else
+ cbs->cb = NULL;
+ return cbs;
+}
+
+
/* upgrade pattern pat_p of length plen_p to UTF8, and if there are code
* blocks, recalculate the indices. Update pat_p and plen_p in-place to
* point to the realloced string and length.
while (s < *plen_p) {
append_utf8_from_native_byte(src[s], &d);
+
if (n < num_code_blocks) {
- if (!do_end && pRExC_state->code_blocks[n].start == s) {
- pRExC_state->code_blocks[n].start = d - dst - 1;
+ assert(pRExC_state->code_blocks);
+ if (!do_end && pRExC_state->code_blocks->cb[n].start == s) {
+ pRExC_state->code_blocks->cb[n].start = d - dst - 1;
assert(*(d - 1) == '(');
do_end = 1;
}
- else if (do_end && pRExC_state->code_blocks[n].end == s) {
- pRExC_state->code_blocks[n].end = d - dst - 1;
+ else if (do_end && pRExC_state->code_blocks->cb[n].end == s) {
+ pRExC_state->code_blocks->cb[n].end = d - dst - 1;
assert(*(d - 1) == ')');
do_end = 0;
n++;
if (oplist->op_type == OP_NULL
&& (oplist->op_flags & OPf_SPECIAL))
{
- assert(n < pRExC_state->num_code_blocks);
- pRExC_state->code_blocks[n].start = pat ? SvCUR(pat) : 0;
- pRExC_state->code_blocks[n].block = oplist;
- pRExC_state->code_blocks[n].src_regex = NULL;
+ assert(n < pRExC_state->code_blocks->count);
+ pRExC_state->code_blocks->cb[n].start = pat ? SvCUR(pat) : 0;
+ pRExC_state->code_blocks->cb[n].block = oplist;
+ pRExC_state->code_blocks->cb[n].src_regex = NULL;
n++;
code = 1;
oplist = OpSIBLING(oplist); /* skip CONST */
sv_setsv(pat, sv);
/* overloading involved: all bets are off over literal
* code. Pretend we haven't seen it */
- pRExC_state->num_code_blocks -= n;
+ if (n)
+ pRExC_state->code_blocks->count -= n;
n = 0;
}
else {
}
if (code)
- pRExC_state->code_blocks[n-1].end = SvCUR(pat)-1;
+ pRExC_state->code_blocks->cb[n-1].end = SvCUR(pat)-1;
}
/* extract any code blocks within any embedded qr//'s */
{
RXi_GET_DECL(ReANY((REGEXP *)rx), ri);
- if (ri->num_code_blocks) {
+ if (ri->code_blocks && ri->code_blocks->count) {
int i;
/* the presence of an embedded qr// with code means
* we should always recompile: the text of the
* qr// may not have changed, but it may be a
* different closure than last time */
*recompile_p = 1;
- Renew(pRExC_state->code_blocks,
- pRExC_state->num_code_blocks + ri->num_code_blocks,
- struct reg_code_block);
- pRExC_state->num_code_blocks += ri->num_code_blocks;
+ if (pRExC_state->code_blocks) {
+ pRExC_state->code_blocks->count += ri->code_blocks->count;
+ Renew(pRExC_state->code_blocks->cb,
+ pRExC_state->code_blocks->count,
+ struct reg_code_block);
+ }
+ else
+ pRExC_state->code_blocks = S_alloc_code_blocks(aTHX_
+ ri->code_blocks->count);
- for (i=0; i < ri->num_code_blocks; i++) {
+ for (i=0; i < ri->code_blocks->count; i++) {
struct reg_code_block *src, *dst;
STRLEN offset = orig_patlen
+ ReANY((REGEXP *)rx)->pre_prefix;
- assert(n < pRExC_state->num_code_blocks);
- src = &ri->code_blocks[i];
- dst = &pRExC_state->code_blocks[n];
+ assert(n < pRExC_state->code_blocks->count);
+ src = &ri->code_blocks->cb[i];
+ dst = &pRExC_state->code_blocks->cb[n];
dst->start = src->start + offset;
dst->end = src->end + offset;
dst->block = src->block;
PERL_UNUSED_CONTEXT;
for (s = 0; s < plen; s++) {
- if (n < pRExC_state->num_code_blocks
- && s == pRExC_state->code_blocks[n].start)
+ if ( pRExC_state->code_blocks
+ && n < pRExC_state->code_blocks->count
+ && s == pRExC_state->code_blocks->cb[n].start)
{
- s = pRExC_state->code_blocks[n].end;
+ s = pRExC_state->code_blocks->cb[n].end;
n++;
continue;
}
int n = 0;
STRLEN s;
char *p, *newpat;
- int newlen = plen + 6; /* allow for "qr''x\0" extra chars */
+ int newlen = plen + 7; /* allow for "qr''xx\0" extra chars */
SV *sv, *qr_ref;
dSP;
*p++ = 'q'; *p++ = 'r'; *p++ = '\'';
for (s = 0; s < plen; s++) {
- if (n < pRExC_state->num_code_blocks
- && s == pRExC_state->code_blocks[n].start)
+ if ( pRExC_state->code_blocks
+ && n < pRExC_state->code_blocks->count
+ && s == pRExC_state->code_blocks->cb[n].start)
{
/* blank out literal code block */
assert(pat[s] == '(');
- while (s <= pRExC_state->code_blocks[n].end) {
+ while (s <= pRExC_state->code_blocks->cb[n].end) {
*p++ = '_';
s++;
}
{
SV * const errsv = ERRSV;
if (SvTRUE_NN(errsv))
- {
- Safefree(pRExC_state->code_blocks);
/* use croak_sv ? */
Perl_croak_nocontext("%" SVf, SVfARG(errsv));
- }
}
assert(SvROK(qr_ref));
qr = SvRV(qr_ref);
struct reg_code_block *new_block, *dst;
RExC_state_t * const r1 = pRExC_state; /* convenient alias */
int i1 = 0, i2 = 0;
+ int r1c, r2c;
- if (!r2->num_code_blocks) /* we guessed wrong */
+ if (!r2->code_blocks || !r2->code_blocks->count) /* we guessed wrong */
{
SvREFCNT_dec_NN(qr);
return 1;
}
- Newx(new_block,
- r1->num_code_blocks + r2->num_code_blocks,
- struct reg_code_block);
+ if (!r1->code_blocks)
+ r1->code_blocks = S_alloc_code_blocks(aTHX_ 0);
+
+ r1c = r1->code_blocks->count;
+ r2c = r2->code_blocks->count;
+
+ Newx(new_block, r1c + r2c, struct reg_code_block);
+
dst = new_block;
- while ( i1 < r1->num_code_blocks
- || i2 < r2->num_code_blocks)
- {
+ while (i1 < r1c || i2 < r2c) {
struct reg_code_block *src;
bool is_qr = 0;
- if (i1 == r1->num_code_blocks) {
- src = &r2->code_blocks[i2++];
+ if (i1 == r1c) {
+ src = &r2->code_blocks->cb[i2++];
is_qr = 1;
}
- else if (i2 == r2->num_code_blocks)
- src = &r1->code_blocks[i1++];
- else if ( r1->code_blocks[i1].start
- < r2->code_blocks[i2].start)
+ else if (i2 == r2c)
+ src = &r1->code_blocks->cb[i1++];
+ else if ( r1->code_blocks->cb[i1].start
+ < r2->code_blocks->cb[i2].start)
{
- src = &r1->code_blocks[i1++];
- assert(src->end < r2->code_blocks[i2].start);
+ src = &r1->code_blocks->cb[i1++];
+ assert(src->end < r2->code_blocks->cb[i2].start);
}
else {
- assert( r1->code_blocks[i1].start
- > r2->code_blocks[i2].start);
- src = &r2->code_blocks[i2++];
+ assert( r1->code_blocks->cb[i1].start
+ > r2->code_blocks->cb[i2].start);
+ src = &r2->code_blocks->cb[i2++];
is_qr = 1;
- assert(src->end < r1->code_blocks[i1].start);
+ assert(src->end < r1->code_blocks->cb[i1].start);
}
assert(pat[src->start] == '(');
: src->src_regex;
dst++;
}
- r1->num_code_blocks += r2->num_code_blocks;
- Safefree(r1->code_blocks);
- r1->code_blocks = new_block;
+ r1->code_blocks->count += r2c;
+ Safefree(r1->code_blocks->cb);
+ r1->code_blocks->cb = new_block;
}
SvREFCNT_dec_NN(qr);
SSize_t minlen = 0;
U32 rx_flags;
SV *pat;
- SV *code_blocksv = NULL;
SV** new_patternp = patternp;
/* these are all flags - maybe they should be turned
pRExC_state->warn_text = NULL;
pRExC_state->code_blocks = NULL;
- pRExC_state->num_code_blocks = 0;
if (is_bare_re)
*is_bare_re = FALSE;
for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o))
if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL))
ncode++; /* count of DO blocks */
- if (ncode) {
- pRExC_state->num_code_blocks = ncode;
- Newx(pRExC_state->code_blocks, ncode, struct reg_code_block);
- }
+
+ if (ncode)
+ pRExC_state->code_blocks = S_alloc_code_blocks(aTHX_ ncode);
}
if (!pat_count) {
/* set expr to the first arg op */
- if (pRExC_state->num_code_blocks
+ if (pRExC_state->code_blocks && pRExC_state->code_blocks->count
&& expr->op_type != OP_CONST)
{
expr = cLISTOPx(expr)->op_first;
if (is_bare_re)
*is_bare_re = TRUE;
SvREFCNT_inc(re);
- Safefree(pRExC_state->code_blocks);
DEBUG_PARSE_r(Perl_re_printf( aTHX_
"Precompiled pattern%s\n",
orig_rx_flags & RXf_SPLIT ? " for split" : ""));
pat = newSVpvn_flags(exp, plen, SVs_TEMP |
(IN_BYTES ? 0 : SvUTF8(pat)));
}
- Safefree(pRExC_state->code_blocks);
return CALLREGCOMP_ENG(eng, pat, orig_rx_flags);
}
&& memEQ(RX_PRECOMP(old_re), exp, plen)
&& !runtime_code /* with runtime code, always recompile */ )
{
- Safefree(pRExC_state->code_blocks);
return old_re;
}
/* whoops, we have a non-utf8 pattern, whilst run-time code
* got compiled as utf8. Try again with a utf8 pattern */
S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
- pRExC_state->num_code_blocks);
+ pRExC_state->code_blocks ? pRExC_state->code_blocks->count : 0);
goto redo_first_pass;
}
}
RExC_lastnum=0;
RExC_lastparse=NULL;
);
- /* reg may croak on us, not giving us a chance to free
- pRExC_state->code_blocks. We cannot SAVEFREEPV it now, as we may
- need it to survive as long as the regexp (qr/(?{})/).
- We must check that code_blocksv is not already set, because we may
- have jumped back to restart the sizing pass. */
- if (pRExC_state->code_blocks && !code_blocksv) {
- code_blocksv = newSV_type(SVt_PV);
- SAVEFREESV(code_blocksv);
- SvPV_set(code_blocksv, (char *)pRExC_state->code_blocks);
- SvLEN_set(code_blocksv, 1); /*sufficient to make sv_clear free it*/
- }
+
if (reg(pRExC_state, 0, &flags,1) == NULL) {
/* It's possible to write a regexp in ascii that represents Unicode
codepoints outside of the byte range, such as via \x{100}. If we
if (flags & RESTART_PASS1) {
if (flags & NEED_UTF8) {
S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
- pRExC_state->num_code_blocks);
+ pRExC_state->code_blocks ? pRExC_state->code_blocks->count : 0);
}
else {
DEBUG_PARSE_r(Perl_re_printf( aTHX_
}
Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for sizing pass, flags=%#" UVxf, (UV) flags);
}
- if (code_blocksv)
- SvLEN_set(code_blocksv,0); /* no you can't have it, sv_clear */
DEBUG_PARSE_r({
Perl_re_printf( aTHX_
if (pm_flags & PMf_IS_QR) {
ri->code_blocks = pRExC_state->code_blocks;
- ri->num_code_blocks = pRExC_state->num_code_blocks;
- }
- else
- {
- int n;
- for (n = 0; n < pRExC_state->num_code_blocks; n++)
- if (pRExC_state->code_blocks[n].src_regex)
- SAVEFREESV(pRExC_state->code_blocks[n].src_regex);
- if(pRExC_state->code_blocks)
- SAVEFREEPV(pRExC_state->code_blocks); /* often null */
+ if (ri->code_blocks)
+ ri->code_blocks->refcnt++;
}
{
!sawlookahead &&
(OP(first) == STAR &&
PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
- !(r->intflags & PREGf_ANCH) && !pRExC_state->num_code_blocks)
+ !(r->intflags & PREGf_ANCH) && !pRExC_state->code_blocks)
{
/* turn .* into ^.* with an implied $*=1 */
const int type =
}
if (sawplus && !sawminmod && !sawlookahead
&& (!sawopen || !RExC_sawback)
- && !pRExC_state->num_code_blocks) /* May examine pos and $& */
+ && !pRExC_state->code_blocks) /* May examine pos and $& */
/* x+ must match at the 1st pos of run of x's */
r->intflags |= PREGf_SKIP;
if (RExC_seen & REG_LOOKBEHIND_SEEN)
r->extflags |= RXf_NO_INPLACE_SUBST; /* inplace might break the
lookbehind */
- if (pRExC_state->num_code_blocks)
+ if (pRExC_state->code_blocks)
r->extflags |= RXf_EVAL_SEEN;
if (RExC_seen & REG_VERBARG_SEEN)
{
while ( RExC_recurse_count > 0 ) {
const regnode *scan = RExC_recurse[ --RExC_recurse_count ];
+ /*
+ * This data structure is set up in study_chunk() and is used
+ * to calculate the distance between a GOSUB regopcode and
+ * the OPEN/CURLYM (CURLYM's are special and can act like OPEN's)
+ * it refers to.
+ *
+ * If for some reason someone writes code that optimises
+ * away a GOSUB opcode then the assert should be changed to
+ * an if(scan) to guard the ARG2L_SET() - Yves
+ *
+ */
+ assert(scan && OP(scan) == GOSUB);
ARG2L_SET( scan, RExC_open_parens[ARG(scan)] - scan );
}
{
AV* list = (AV*) *listp;
IV k;
- for (k = 0; k <= av_tindex_nomg(list); k++) {
+ for (k = 0; k <= av_tindex_skip_len_mg(list); k++) {
SV** c_p = av_fetch(list, k, FALSE);
UV c;
assert(c_p);
RExC_seen_zerolen++;
- if ( !pRExC_state->num_code_blocks
- || pRExC_state->code_index >= pRExC_state->num_code_blocks
- || pRExC_state->code_blocks[pRExC_state->code_index].start
+ if ( !pRExC_state->code_blocks
+ || pRExC_state->code_index
+ >= pRExC_state->code_blocks->count
+ || pRExC_state->code_blocks->cb[pRExC_state->code_index].start
!= (STRLEN)((RExC_parse -3 - (is_logical ? 1 : 0))
- RExC_start)
) {
FAIL("Eval-group not allowed at runtime, use re 'eval'");
}
/* this is a pre-compiled code block (?{...}) */
- cb = &pRExC_state->code_blocks[pRExC_state->code_index];
+ cb = &pRExC_state->code_blocks->cb[pRExC_state->code_index];
RExC_parse = RExC_start + cb->end;
if (!SIZE_ONLY) {
OP *o = cb->block;
nextchar(pRExC_state);
if (max < min) { /* If can't match, warn and optimize to fail
unconditionally */
- if (SIZE_ONLY) {
-
- /* We can't back off the size because we have to reserve
- * enough space for all the things we are about to throw
- * away, but we can shrink it by the amount we are about
- * to re-use here */
- RExC_size += PREVOPER(RExC_size) - regarglen[(U8)OPFAIL];
- }
- else {
+ reginsert(pRExC_state, OPFAIL, orig_emit, depth+1);
+ if (PASS2) {
ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match");
- RExC_emit = orig_emit;
+ NEXT_OFF(orig_emit)= regarglen[OPFAIL] + NODE_STEP_REGNODE;
}
- ret = reganode(pRExC_state, OPFAIL, 0);
return ret;
}
else if (min == max && *RExC_parse == '?')
no_close:
/* We output the messages even if warnings are off, because we'll fail
* the very next thing, and these give a likely diagnosis for that */
- if (posix_warnings && av_tindex_nomg(posix_warnings) >= 0) {
+ if (posix_warnings && av_tindex_skip_len_mg(posix_warnings) >= 0) {
output_or_return_posix_warnings(pRExC_state, posix_warnings, NULL);
}
stack, fence, fence_stack));
#endif
- top_index = av_tindex_nomg(stack);
+ top_index = av_tindex_skip_len_mg(stack);
switch (curchar) {
SV** stacked_ptr; /* Ptr to something already on 'stack' */
goto done;
case ')':
- if (av_tindex_nomg(fence_stack) < 0) {
+ if (av_tindex_skip_len_mg(fence_stack) < 0) {
RExC_parse++;
vFAIL("Unexpected ')'");
}
* may have altered the stack in the time since we earlier set
* 'top_index'. */
- top_index = av_tindex_nomg(stack);
+ top_index = av_tindex_skip_len_mg(stack);
if (top_index - fence >= 0) {
/* If the top entry on the stack is an operator, it had better
* be a '!', otherwise the entry below the top operand should
} /* End of loop parsing through the construct */
done:
- if (av_tindex_nomg(fence_stack) >= 0) {
+ if (av_tindex_skip_len_mg(fence_stack) >= 0) {
vFAIL("Unmatched (");
}
- if (av_tindex_nomg(stack) < 0 /* Was empty */
+ if (av_tindex_skip_len_mg(stack) < 0 /* Was empty */
|| ((final = av_pop(stack)) == NULL)
|| ! IS_OPERAND(final)
|| SvTYPE(final) != SVt_INVLIST
- || av_tindex_nomg(stack) >= 0) /* More left on stack */
+ || av_tindex_skip_len_mg(stack) >= 0) /* More left on stack */
{
bad_syntax:
SvREFCNT_dec(final);
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);
+ const SSize_t stack_top = av_tindex_skip_len_mg(stack);
+ const SSize_t fence_stack_top = av_tindex_skip_len_mg(fence_stack);
SSize_t i;
PERL_ARGS_ASSERT_DUMP_REGEX_SETS_STRUCTURES;
while (1) {
if ( posix_warnings
- && av_tindex_nomg(posix_warnings) >= 0
+ && av_tindex_skip_len_mg(posix_warnings) >= 0
&& RExC_parse > not_posix_region_end)
{
/* Warnings about posix class issues are considered tentative until
* posix class, and it failed, it was a false alarm, as this
* successful one proves */
if ( posix_warnings
- && av_tindex_nomg(posix_warnings) >= 0
+ && av_tindex_skip_len_mg(posix_warnings) >= 0
&& not_posix_region_end >= RExC_parse
&& not_posix_region_end <= posix_class_end)
{
literal[d++] = (char) value;
literal[d++] = '\0';
- vWARN4dep(RExC_parse,
- "\"%.*s\" is more clearly written simply as \"%s\". "
- "This will be a fatal error in Perl 5.28",
+ vWARN4(RExC_parse,
+ "\"%.*s\" is more clearly written simply as \"%s\"",
(int) (RExC_parse - rangebegin),
rangebegin,
literal
- );
+ );
}
else if isMNEMONIC_CNTRL(value) {
- vWARN4dep(RExC_parse,
- "\"%.*s\" is more clearly written simply as \"%s\". "
- "This will be a fatal error in Perl 5.28",
+ vWARN4(RExC_parse,
+ "\"%.*s\" is more clearly written simply as \"%s\"",
(int) (RExC_parse - rangebegin),
rangebegin,
cntrl_to_mnemonic((U8) value)
- );
+ );
}
}
}
} /* End of loop through all the text within the brackets */
- if ( posix_warnings && av_tindex_nomg(posix_warnings) >= 0) {
+ if ( posix_warnings && av_tindex_skip_len_mg(posix_warnings) >= 0) {
output_or_return_posix_warnings(pRExC_state, posix_warnings,
return_posix_warnings);
}
#endif
/* Look at the longest folds first */
- for (cp_count = av_tindex_nomg(multi_char_matches);
+ for (cp_count = av_tindex_skip_len_mg(multi_char_matches);
cp_count > 0;
cp_count--)
{
{
AV* list = (AV*) *listp;
IV k;
- for (k = 0; k <= av_tindex_nomg(list); k++) {
+ for (k = 0; k <= av_tindex_skip_len_mg(list); k++) {
SV** c_p = av_fetch(list, k, FALSE);
UV c;
assert(c_p);
si = *ary; /* ary[0] = the string to initialize the swash with */
- if (av_tindex_nomg(av) >= 2) {
+ if (av_tindex_skip_len_mg(av) >= 2) {
if (only_utf8_locale_ptr
&& ary[2]
&& ary[2] != &PL_sv_undef)
* is any inversion list generated at compile time; [4]
* indicates if that inversion list has any user-defined
* properties in it. */
- if (av_tindex_nomg(av) >= 3) {
+ if (av_tindex_skip_len_mg(av) >= 3) {
invlist = ary[3];
if (SvUV(ary[4])) {
swash_init_flags |= _CORE_SWASH_INIT_USER_DEFINED_PROPERTY;
- reginsert - insert an operator in front of already-emitted operand
*
* Means relocating the operand.
+*
+* IMPORTANT NOTE - it is the *callers* responsibility to correctly
+* set up NEXT_OFF() of the inserted node if needed. Something like this:
+*
+* reginsert(pRExC, OPFAIL, orig_emit, depth+1);
+* if (PASS2)
+* NEXT_OFF(orig_emit) = regarglen[OPFAIL] + NODE_STEP_REGNODE;
+*
*/
STATIC void
-S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
+S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *operand, U32 depth)
{
regnode *src;
regnode *dst;
/* note, RExC_open_parens[0] is the start of the
* regex, it can't move. RExC_close_parens[0] is the end
* of the regex, it *can* move. */
- if ( paren && RExC_open_parens[paren] >= opnd ) {
+ if ( paren && RExC_open_parens[paren] >= operand ) {
/*DEBUG_PARSE_FMT("open"," - %d",size);*/
RExC_open_parens[paren] += size;
} else {
/*DEBUG_PARSE_FMT("open"," - %s","ok");*/
}
- if ( RExC_close_parens[paren] >= opnd ) {
+ if ( RExC_close_parens[paren] >= operand ) {
/*DEBUG_PARSE_FMT("close"," - %d",size);*/
RExC_close_parens[paren] += size;
} else {
if (RExC_end_op)
RExC_end_op += size;
- while (src > opnd) {
+ while (src > operand) {
StructCopy(--src, --dst, regnode);
#ifdef RE_TRACK_PATTERN_OFFSETS
if (RExC_offsets) { /* MJD 20010112 */
}
- place = opnd; /* Op node, where operand used to be. */
+ place = operand; /* Op node, where operand used to be. */
#ifdef RE_TRACK_PATTERN_OFFSETS
if (RExC_offsets) { /* MJD */
MJD_OFFSET_DEBUG(
if (ri->u.offsets)
Safefree(ri->u.offsets); /* 20010421 MJD */
#endif
- if (ri->code_blocks) {
- int n;
- for (n = 0; n < ri->num_code_blocks; n++)
- SvREFCNT_dec(ri->code_blocks[n].src_regex);
- Safefree(ri->code_blocks);
- }
+ if (ri->code_blocks)
+ S_free_codeblocks(aTHX_ ri->code_blocks);
if (ri->data) {
int n = ri->data->count;
Copy(ri->program, reti->program, len+1, regnode);
- reti->num_code_blocks = ri->num_code_blocks;
if (ri->code_blocks) {
int n;
- Newxc(reti->code_blocks, ri->num_code_blocks, struct reg_code_block,
- struct reg_code_block);
- Copy(ri->code_blocks, reti->code_blocks, ri->num_code_blocks,
- struct reg_code_block);
- for (n = 0; n < ri->num_code_blocks; n++)
- reti->code_blocks[n].src_regex = (REGEXP*)
- sv_dup_inc((SV*)(ri->code_blocks[n].src_regex), param);
+ Newx(reti->code_blocks, 1, struct reg_code_blocks);
+ Newx(reti->code_blocks->cb, ri->code_blocks->count,
+ struct reg_code_block);
+ Copy(ri->code_blocks->cb, reti->code_blocks->cb,
+ ri->code_blocks->count, struct reg_code_block);
+ for (n = 0; n < ri->code_blocks->count; n++)
+ reti->code_blocks->cb[n].src_regex = (REGEXP*)
+ sv_dup_inc((SV*)(ri->code_blocks->cb[n].src_regex), param);
+ reti->code_blocks->count = ri->code_blocks->count;
+ reti->code_blocks->refcnt = 1;
}
else
reti->code_blocks = NULL;
Used to make it easier to clone and free arbitrary
data that the regops need. Often the ARG field of
a regop is an index into this structure */
- struct reg_code_block *code_blocks;/* positions of literal (?{}) */
- int num_code_blocks; /* size of code_blocks[] */
+ struct reg_code_blocks *code_blocks;/* positions of literal (?{}) */
regnode program[1]; /* Unwarranted chumminess with compiler. */
} regexp_internal;
#
#
TRIE next:FAIL
-EVAL AB:FAIL
+EVAL B,postponed_AB:FAIL
CURLYX end:FAIL
WHILEM A_pre,A_min,A_max,B_min,B_max:FAIL
BRANCH next:FAIL
__END__
package feature;
-our $VERSION = '1.46';
+our $VERSION = '1.47';
FEATURES
=head2 The 'unicode_eval' and 'evalbytes' features
-Under the C<unicode_eval> feature, Perl's C<eval> function, when passed a
-string, will evaluate it as a string of characters, ignoring any
-C<use utf8> declarations. C<use utf8> exists to declare the encoding of
-the script, which only makes sense for a stream of bytes, not a string of
-characters. Source filters are forbidden, as they also really only make
-sense on strings of bytes. Any attempt to activate a source filter will
-result in an error.
-
-The C<evalbytes> feature enables the C<evalbytes> keyword, which evaluates
-the argument passed to it as a string of bytes. It dies if the string
-contains any characters outside the 8-bit range. Source filters work
-within C<evalbytes>: they apply to the contents of the string being
-evaluated.
-
-Together, these two features are intended to replace the historical C<eval>
-function, which has (at least) two bugs in it, that cannot easily be fixed
-without breaking existing programs:
-
-=over
-
-=item *
-
-C<eval> behaves differently depending on the internal encoding of the
-string, sometimes treating its argument as a string of bytes, and sometimes
-as a string of characters.
-
-=item *
-
-Source filters activated within C<eval> leak out into whichever I<file>
-scope is currently being compiled. To give an example with the CPAN module
-L<Semi::Semicolons>:
-
- BEGIN { eval "use Semi::Semicolons; # not filtered here " }
- # filtered here!
-
-C<evalbytes> fixes that to work the way one would expect:
-
- use feature "evalbytes";
- BEGIN { evalbytes "use Semi::Semicolons; # filtered " }
- # not filtered
-
-=back
-
-These two features are available starting with Perl 5.16.
+Together, these two features are intended to replace the legacy string
+C<eval> function, which behaves problematically in some instances. They are
+available starting with Perl 5.16, and are enabled by default by a
+S<C<use 5.16>> or higher declaration.
+
+C<unicode_eval> changes the behavior of plain string C<eval> to work more
+consistently, especially in the Unicode world. Certain (mis)behaviors
+couldn't be changed without breaking some things that had come to rely on
+them, so the feature can be enabled and disabled. Details are at
+L<perlfunc/Under the "unicode_eval" feature>.
+
+C<evalbytes> is like string C<eval>, but operating on a byte stream that is
+not UTF-8 encoded. Details are at L<perlfunc/evalbytes EXPR>. Without a
+S<C<use feature 'evalbytes'>> nor a S<C<use v5.16>> (or higher) declaration in
+the current scope, you can still access it by instead writing
+C<CORE::evalbytes>.
=head2 The 'current_sub' feature
#define unpackWARN4(x) (((x) >>24) & 0xFF)
#define ckDEAD(x) \
- ( ! specialWARN(PL_curcop->cop_warnings) && \
+ (PL_curcop && \
+ !specialWARN(PL_curcop->cop_warnings) && \
( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \
isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) || \
isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) || \
}
else { /* Does participate in folds */
AV* list = (AV*) *listp;
- if (av_tindex_nomg(list) != 1) {
+ if (av_tindex_skip_len_mg(list) != 1) {
/* If there aren't exactly two folds to this, it is
* outside the scope of this function */
U8 gimme = G_SCALAR;
CV *caller_cv = NULL; /* who called us */
CV *last_pushed_cv = NULL; /* most recently called (?{}) CV */
- CHECKPOINT runops_cp; /* savestack position before executing EVAL */
U32 maxopenparen = 0; /* max '(' index seen so far */
int to_complement; /* Invert the result? */
_char_class_number classnum;
bool is_utf8_pat = reginfo->is_utf8_pat;
bool match = FALSE;
+ I32 orig_savestack_ix = PL_savestack_ix;
/* Solaris Studio 12.3 messes up fetching PL_charclass['\n'] */
#if (defined(__SUNPRO_C) && (__SUNPRO_C == 0x5120) && defined(__x86_64) && defined(USE_64_BIT_ALL))
{
U8 *uc;
if ( ST.jump ) {
+ /* undo any captures done in the tail part of a branch,
+ * e.g.
+ * /(?:X(.)(.)|Y(.)).../
+ * where the trie just matches X then calls out to do the
+ * rest of the branch */
REGCP_UNWIND(ST.cp);
UNWIND_PAREN(ST.lastparen, ST.lastcloseparen);
}
goto eval_recurse_doit;
/* NOTREACHED */
- case EVAL: /* /(?{A})B/ /(??{A})B/ and /(?(?{A})X|Y)B/ */
+ case EVAL: /* /(?{...})B/ /(??{A})B/ and /(?(?{...})X|Y)B/ */
if (cur_eval && cur_eval->locinput==locinput) {
if ( ++nochange_depth > max_nochange_depth )
Perl_croak(aTHX_ "EVAL without pos change exceeded limit in regex");
/* save *all* paren positions */
regcppush(rex, 0, maxopenparen);
- REGCP_SET(runops_cp);
+ REGCP_SET(ST.lastcp);
if (!caller_cv)
caller_cv = find_runcv(NULL);
nop = (OP*)rexi->data->data[n];
}
- /* normally if we're about to execute code from the same
- * CV that we used previously, we just use the existing
- * CX stack entry. However, its possible that in the
- * meantime we may have backtracked, popped from the save
- * stack, and undone the SAVECOMPPAD(s) associated with
- * PUSH_MULTICALL; in which case PL_comppad no longer
- * points to newcv's pad. */
+ /* Some notes about MULTICALL and the context and save stacks.
+ *
+ * In something like
+ * /...(?{ my $x)}...(?{ my $y)}...(?{ my $z)}.../
+ * since codeblocks don't introduce a new scope (so that
+ * local() etc accumulate), at the end of a successful
+ * match there will be a SAVEt_CLEARSV on the savestack
+ * for each of $x, $y, $z. If the three code blocks above
+ * happen to have come from different CVs (e.g. via
+ * embedded qr//s), then we must ensure that during any
+ * savestack unwinding, PL_comppad always points to the
+ * right pad at each moment. We achieve this by
+ * interleaving SAVEt_COMPPAD's on the savestack whenever
+ * there is a change of pad.
+ * In theory whenever we call a code block, we should
+ * push a CXt_SUB context, then pop it on return from
+ * that code block. This causes a bit of an issue in that
+ * normally popping a context also clears the savestack
+ * back to cx->blk_oldsaveix, but here we specifically
+ * don't want to clear the save stack on exit from the
+ * code block.
+ * Also for efficiency we don't want to keep pushing and
+ * popping the single SUB context as we backtrack etc.
+ * So instead, we push a single context the first time
+ * we need, it, then hang onto it until the end of this
+ * function. Whenever we encounter a new code block, we
+ * update the CV etc if that's changed. During the times
+ * in this function where we're not executing a code
+ * block, having the SUB context still there is a bit
+ * naughty - but we hope that no-one notices.
+ * When the SUB context is initially pushed, we fake up
+ * cx->blk_oldsaveix to be as if we'd pushed this context
+ * on first entry to S_regmatch rather than at some random
+ * point during the regexe execution. That way if we
+ * croak, popping the context stack will ensure that
+ * *everything* SAVEd by this function is undone and then
+ * the context popped, rather than e.g., popping the
+ * context (and restoring the original PL_comppad) then
+ * popping more of the savestack and restoring a bad
+ * PL_comppad.
+ */
+
+ /* If this is the first EVAL, push a MULTICALL. On
+ * subsequent calls, if we're executing a different CV, or
+ * if PL_comppad has got messed up from backtracking
+ * through SAVECOMPPADs, then refresh the context.
+ */
if (newcv != last_pushed_cv || PL_comppad != last_pad)
{
U8 flags = (CXp_SUB_RE |
((newcv == caller_cv) ? CXp_SUB_RE_FAKE : 0));
+ SAVECOMPPAD();
if (last_pushed_cv) {
- /* PUSH/POP_MULTICALL save and restore the
- * caller's PL_comppad; if we call multiple subs
- * using the same CX block, we have to save and
- * unwind the varying PL_comppad's ourselves,
- * especially restoring the right PL_comppad on
- * backtrack - so save it on the save stack */
- SAVECOMPPAD();
CHANGE_MULTICALL_FLAGS(newcv, flags);
}
else {
PUSH_MULTICALL_FLAGS(newcv, flags);
}
+ /* see notes above */
+ CX_CUR()->blk_oldsaveix = orig_savestack_ix;
+
last_pushed_cv = newcv;
}
else {
* in the regexp code uses the pad ! */
PL_op = oop;
PL_curcop = ocurcop;
- regcp_restore(rex, runops_cp, &maxopenparen);
+ regcp_restore(rex, ST.lastcp, &maxopenparen);
PL_curpm_under = PL_curpm;
PL_curpm = PL_reg_curpm;
- if (logical != 2)
- break;
+ if (logical != 2) {
+ PUSH_STATE_GOTO(EVAL_B, next, locinput);
+ /* NOTREACHED */
+ }
}
/* only /(??{})/ from now on */
ST.prev_eval = cur_eval;
cur_eval = st;
/* now continue from first node in postoned RE */
- PUSH_YES_STATE_GOTO(EVAL_AB, startpoint, locinput);
+ PUSH_YES_STATE_GOTO(EVAL_postponed_AB, startpoint, locinput);
NOT_REACHED; /* NOTREACHED */
}
- case EVAL_AB: /* cleanup after a successful (??{A})B */
+ case EVAL_postponed_AB: /* cleanup after a successful (??{A})B */
/* note: this is called twice; first after popping B, then A */
DEBUG_STACK_r({
Perl_re_exec_indentf( aTHX_ "EVAL_AB cur_eval=%p prev_eval=%p\n",
sayYES;
- case EVAL_AB_fail: /* unsuccessfully ran A or B in (??{A})B */
+ case EVAL_B_fail: /* unsuccessful B in (?{...})B */
+ REGCP_UNWIND(ST.lastcp);
+ sayNO;
+
+ case EVAL_postponed_AB_fail: /* unsuccessfully ran A or B in (??{A})B */
/* note: this is called twice; first after popping B, then A */
DEBUG_STACK_r({
Perl_re_exec_indentf( aTHX_ "EVAL_AB_fail cur_eval=%p prev_eval=%p\n",
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,
- maxopenparen);
- REGCP_SET(ST.lastcp);
PUSH_YES_STATE_GOTO(WHILEM_B_min, ST.save_curlyx->u.curlyx.B,
locinput);
NOT_REACHED; /* NOTREACHED */
CACHEsayNO;
NOT_REACHED; /* NOTREACHED */
- case WHILEM_A_min_fail: /* just failed to match A in a minimal match */
- /* FALLTHROUGH */
case WHILEM_A_pre_fail: /* just failed to match even minimal A */
REGCP_UNWIND(ST.lastcp);
regcppop(rex, &maxopenparen);
+ /* FALLTHROUGH */
+ case WHILEM_A_min_fail: /* just failed to match A in a minimal match */
cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
cur_curlyx->u.curlyx.count--;
CACHEsayNO;
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);
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,
- maxopenparen);
- REGCP_SET(ST.lastcp);
PUSH_STATE_GOTO(WHILEM_A_min,
/*A*/ NEXTOPER(ST.save_curlyx->u.curlyx.me) + EXTRA_STEP_2ARGS,
locinput);
SET_RECURSE_LOCINPUT("FAKE-END[after]", cur_eval->locinput);
- PUSH_YES_STATE_GOTO(EVAL_AB, st->u.eval.prev_eval->u.eval.B,
+ PUSH_YES_STATE_GOTO(EVAL_postponed_AB, st->u.eval.prev_eval->u.eval.B,
locinput); /* match B */
}
assert(!NEXTCHR_IS_EOS);
if (utf8_target) {
locinput += PL_utf8skip[nextchr];
- /* locinput is allowed to go 1 char off the end, but not 2+ */
+ /* locinput is allowed to go 1 char off the end (signifying
+ * EOS), but not 2+ */
if (locinput > reginfo->strend)
sayNO;
}
DEBUG_STACK_r({
regmatch_state *cur = st;
regmatch_state *curyes = yes_state;
- int curd = depth;
+ U32 i;
regmatch_slab *slab = PL_regmatch_slab;
- for (;curd > -1 && (depth-curd < 3);cur--,curd--) {
+ for (i = 0; i < 3 && i <= depth; cur--,i++) {
if (cur < SLAB_FIRST(slab)) {
slab = slab->prev;
cur = SLAB_LAST(slab);
}
- Perl_re_exec_indentf( aTHX_ "#%-3d %-10s %s\n",
+ Perl_re_exec_indentf( aTHX_ "%4s #%-3d %-10s %s\n",
depth,
- curd, PL_reg_name[cur->resume_state],
+ i ? " " : "push",
+ depth - i, PL_reg_name[cur->resume_state],
(curyes == cur) ? "yes" : ""
);
if (curyes == cur)
if (last_pushed_cv) {
dSP;
+ /* see "Some notes about MULTICALL" above */
POP_MULTICALL;
PERL_UNUSED_VAR(SP);
}
+ else
+ LEAVE_SCOPE(orig_savestack_ix);
assert(!result || locinput - reginfo->strbeg >= 0);
return result ? locinput - reginfo->strbeg : -1;
REGEXP *src_regex;
};
+/* array of reg_code_block's plus header info */
+
+struct reg_code_blocks {
+ int refcnt; /* we may be pointed to from a regex and from the savestack */
+ int count; /* how many code blocks */
+ struct reg_code_block *cb; /* array of reg_code_block's */
+};
+
/*
The regexp/REGEXP struct, see L<perlreapi> for further documentation
*/
#define SvRX(sv) (Perl_get_re_arg(aTHX_ sv))
-#define SvRXOK(sv) (Perl_get_re_arg(aTHX_ sv) ? TRUE : FALSE)
+#define SvRXOK(sv) cBOOL(Perl_get_re_arg(aTHX_ sv))
/* Flags stored in regexp->extflags
/* Regops and State definitions */
#define REGNODE_MAX 92
-#define REGMATCH_STATE_MAX 132
+#define REGMATCH_STATE_MAX 134
#define END 0 /* 0000 End of program. */
#define SUCCEED 1 /* 0x01 Return from a subroutine, basically. */
/* ------------ States ------------- */
#define TRIE_next (REGNODE_MAX + 1) /* state for TRIE */
#define TRIE_next_fail (REGNODE_MAX + 2) /* state for TRIE */
-#define EVAL_AB (REGNODE_MAX + 3) /* state for EVAL */
-#define EVAL_AB_fail (REGNODE_MAX + 4) /* state for EVAL */
-#define CURLYX_end (REGNODE_MAX + 5) /* state for CURLYX */
-#define CURLYX_end_fail (REGNODE_MAX + 6) /* state for CURLYX */
-#define WHILEM_A_pre (REGNODE_MAX + 7) /* state for WHILEM */
-#define WHILEM_A_pre_fail (REGNODE_MAX + 8) /* state for WHILEM */
-#define WHILEM_A_min (REGNODE_MAX + 9) /* state for WHILEM */
-#define WHILEM_A_min_fail (REGNODE_MAX + 10) /* state for WHILEM */
-#define WHILEM_A_max (REGNODE_MAX + 11) /* state for WHILEM */
-#define WHILEM_A_max_fail (REGNODE_MAX + 12) /* state for WHILEM */
-#define WHILEM_B_min (REGNODE_MAX + 13) /* state for WHILEM */
-#define WHILEM_B_min_fail (REGNODE_MAX + 14) /* state for WHILEM */
-#define WHILEM_B_max (REGNODE_MAX + 15) /* state for WHILEM */
-#define WHILEM_B_max_fail (REGNODE_MAX + 16) /* state for WHILEM */
-#define BRANCH_next (REGNODE_MAX + 17) /* state for BRANCH */
-#define BRANCH_next_fail (REGNODE_MAX + 18) /* state for BRANCH */
-#define CURLYM_A (REGNODE_MAX + 19) /* state for CURLYM */
-#define CURLYM_A_fail (REGNODE_MAX + 20) /* state for CURLYM */
-#define CURLYM_B (REGNODE_MAX + 21) /* state for CURLYM */
-#define CURLYM_B_fail (REGNODE_MAX + 22) /* state for CURLYM */
-#define IFMATCH_A (REGNODE_MAX + 23) /* state for IFMATCH */
-#define IFMATCH_A_fail (REGNODE_MAX + 24) /* state for IFMATCH */
-#define CURLY_B_min_known (REGNODE_MAX + 25) /* state for CURLY */
-#define CURLY_B_min_known_fail (REGNODE_MAX + 26) /* state for CURLY */
-#define CURLY_B_min (REGNODE_MAX + 27) /* state for CURLY */
-#define CURLY_B_min_fail (REGNODE_MAX + 28) /* state for CURLY */
-#define CURLY_B_max (REGNODE_MAX + 29) /* state for CURLY */
-#define CURLY_B_max_fail (REGNODE_MAX + 30) /* state for CURLY */
-#define COMMIT_next (REGNODE_MAX + 31) /* state for COMMIT */
-#define COMMIT_next_fail (REGNODE_MAX + 32) /* state for COMMIT */
-#define MARKPOINT_next (REGNODE_MAX + 33) /* state for MARKPOINT */
-#define MARKPOINT_next_fail (REGNODE_MAX + 34) /* state for MARKPOINT */
-#define SKIP_next (REGNODE_MAX + 35) /* state for SKIP */
-#define SKIP_next_fail (REGNODE_MAX + 36) /* state for SKIP */
-#define CUTGROUP_next (REGNODE_MAX + 37) /* state for CUTGROUP */
-#define CUTGROUP_next_fail (REGNODE_MAX + 38) /* state for CUTGROUP */
-#define KEEPS_next (REGNODE_MAX + 39) /* state for KEEPS */
-#define KEEPS_next_fail (REGNODE_MAX + 40) /* state for KEEPS */
+#define EVAL_B (REGNODE_MAX + 3) /* state for EVAL */
+#define EVAL_B_fail (REGNODE_MAX + 4) /* state for EVAL */
+#define EVAL_postponed_AB (REGNODE_MAX + 5) /* state for EVAL */
+#define EVAL_postponed_AB_fail (REGNODE_MAX + 6) /* state for EVAL */
+#define CURLYX_end (REGNODE_MAX + 7) /* state for CURLYX */
+#define CURLYX_end_fail (REGNODE_MAX + 8) /* state for CURLYX */
+#define WHILEM_A_pre (REGNODE_MAX + 9) /* state for WHILEM */
+#define WHILEM_A_pre_fail (REGNODE_MAX + 10) /* state for WHILEM */
+#define WHILEM_A_min (REGNODE_MAX + 11) /* state for WHILEM */
+#define WHILEM_A_min_fail (REGNODE_MAX + 12) /* state for WHILEM */
+#define WHILEM_A_max (REGNODE_MAX + 13) /* state for WHILEM */
+#define WHILEM_A_max_fail (REGNODE_MAX + 14) /* state for WHILEM */
+#define WHILEM_B_min (REGNODE_MAX + 15) /* state for WHILEM */
+#define WHILEM_B_min_fail (REGNODE_MAX + 16) /* state for WHILEM */
+#define WHILEM_B_max (REGNODE_MAX + 17) /* state for WHILEM */
+#define WHILEM_B_max_fail (REGNODE_MAX + 18) /* state for WHILEM */
+#define BRANCH_next (REGNODE_MAX + 19) /* state for BRANCH */
+#define BRANCH_next_fail (REGNODE_MAX + 20) /* state for BRANCH */
+#define CURLYM_A (REGNODE_MAX + 21) /* state for CURLYM */
+#define CURLYM_A_fail (REGNODE_MAX + 22) /* state for CURLYM */
+#define CURLYM_B (REGNODE_MAX + 23) /* state for CURLYM */
+#define CURLYM_B_fail (REGNODE_MAX + 24) /* state for CURLYM */
+#define IFMATCH_A (REGNODE_MAX + 25) /* state for IFMATCH */
+#define IFMATCH_A_fail (REGNODE_MAX + 26) /* state for IFMATCH */
+#define CURLY_B_min_known (REGNODE_MAX + 27) /* state for CURLY */
+#define CURLY_B_min_known_fail (REGNODE_MAX + 28) /* state for CURLY */
+#define CURLY_B_min (REGNODE_MAX + 29) /* state for CURLY */
+#define CURLY_B_min_fail (REGNODE_MAX + 30) /* state for CURLY */
+#define CURLY_B_max (REGNODE_MAX + 31) /* state for CURLY */
+#define CURLY_B_max_fail (REGNODE_MAX + 32) /* state for CURLY */
+#define COMMIT_next (REGNODE_MAX + 33) /* state for COMMIT */
+#define COMMIT_next_fail (REGNODE_MAX + 34) /* state for COMMIT */
+#define MARKPOINT_next (REGNODE_MAX + 35) /* state for MARKPOINT */
+#define MARKPOINT_next_fail (REGNODE_MAX + 36) /* state for MARKPOINT */
+#define SKIP_next (REGNODE_MAX + 37) /* state for SKIP */
+#define SKIP_next_fail (REGNODE_MAX + 38) /* state for SKIP */
+#define CUTGROUP_next (REGNODE_MAX + 39) /* state for CUTGROUP */
+#define CUTGROUP_next_fail (REGNODE_MAX + 40) /* state for CUTGROUP */
+#define KEEPS_next (REGNODE_MAX + 41) /* state for KEEPS */
+#define KEEPS_next_fail (REGNODE_MAX + 42) /* state for KEEPS */
/* PL_regkind[] What type of regop or state is this. */
/* ------------ States ------------- */
TRIE, /* TRIE_next */
TRIE, /* TRIE_next_fail */
- EVAL, /* EVAL_AB */
- EVAL, /* EVAL_AB_fail */
+ EVAL, /* EVAL_B */
+ EVAL, /* EVAL_B_fail */
+ EVAL, /* EVAL_postponed_AB */
+ EVAL, /* EVAL_postponed_AB_fail */
CURLYX, /* CURLYX_end */
CURLYX, /* CURLYX_end_fail */
WHILEM, /* WHILEM_A_pre */
/* ------------ States ------------- */
"TRIE_next", /* REGNODE_MAX +0x01 */
"TRIE_next_fail", /* REGNODE_MAX +0x02 */
- "EVAL_AB", /* REGNODE_MAX +0x03 */
- "EVAL_AB_fail", /* REGNODE_MAX +0x04 */
- "CURLYX_end", /* REGNODE_MAX +0x05 */
- "CURLYX_end_fail", /* REGNODE_MAX +0x06 */
- "WHILEM_A_pre", /* REGNODE_MAX +0x07 */
- "WHILEM_A_pre_fail", /* REGNODE_MAX +0x08 */
- "WHILEM_A_min", /* REGNODE_MAX +0x09 */
- "WHILEM_A_min_fail", /* REGNODE_MAX +0x0a */
- "WHILEM_A_max", /* REGNODE_MAX +0x0b */
- "WHILEM_A_max_fail", /* REGNODE_MAX +0x0c */
- "WHILEM_B_min", /* REGNODE_MAX +0x0d */
- "WHILEM_B_min_fail", /* REGNODE_MAX +0x0e */
- "WHILEM_B_max", /* REGNODE_MAX +0x0f */
- "WHILEM_B_max_fail", /* REGNODE_MAX +0x10 */
- "BRANCH_next", /* REGNODE_MAX +0x11 */
- "BRANCH_next_fail", /* REGNODE_MAX +0x12 */
- "CURLYM_A", /* REGNODE_MAX +0x13 */
- "CURLYM_A_fail", /* REGNODE_MAX +0x14 */
- "CURLYM_B", /* REGNODE_MAX +0x15 */
- "CURLYM_B_fail", /* REGNODE_MAX +0x16 */
- "IFMATCH_A", /* REGNODE_MAX +0x17 */
- "IFMATCH_A_fail", /* REGNODE_MAX +0x18 */
- "CURLY_B_min_known", /* REGNODE_MAX +0x19 */
- "CURLY_B_min_known_fail", /* REGNODE_MAX +0x1a */
- "CURLY_B_min", /* REGNODE_MAX +0x1b */
- "CURLY_B_min_fail", /* REGNODE_MAX +0x1c */
- "CURLY_B_max", /* REGNODE_MAX +0x1d */
- "CURLY_B_max_fail", /* REGNODE_MAX +0x1e */
- "COMMIT_next", /* REGNODE_MAX +0x1f */
- "COMMIT_next_fail", /* REGNODE_MAX +0x20 */
- "MARKPOINT_next", /* REGNODE_MAX +0x21 */
- "MARKPOINT_next_fail", /* REGNODE_MAX +0x22 */
- "SKIP_next", /* REGNODE_MAX +0x23 */
- "SKIP_next_fail", /* REGNODE_MAX +0x24 */
- "CUTGROUP_next", /* REGNODE_MAX +0x25 */
- "CUTGROUP_next_fail", /* REGNODE_MAX +0x26 */
- "KEEPS_next", /* REGNODE_MAX +0x27 */
- "KEEPS_next_fail", /* REGNODE_MAX +0x28 */
+ "EVAL_B", /* REGNODE_MAX +0x03 */
+ "EVAL_B_fail", /* REGNODE_MAX +0x04 */
+ "EVAL_postponed_AB", /* REGNODE_MAX +0x05 */
+ "EVAL_postponed_AB_fail", /* REGNODE_MAX +0x06 */
+ "CURLYX_end", /* REGNODE_MAX +0x07 */
+ "CURLYX_end_fail", /* REGNODE_MAX +0x08 */
+ "WHILEM_A_pre", /* REGNODE_MAX +0x09 */
+ "WHILEM_A_pre_fail", /* REGNODE_MAX +0x0a */
+ "WHILEM_A_min", /* REGNODE_MAX +0x0b */
+ "WHILEM_A_min_fail", /* REGNODE_MAX +0x0c */
+ "WHILEM_A_max", /* REGNODE_MAX +0x0d */
+ "WHILEM_A_max_fail", /* REGNODE_MAX +0x0e */
+ "WHILEM_B_min", /* REGNODE_MAX +0x0f */
+ "WHILEM_B_min_fail", /* REGNODE_MAX +0x10 */
+ "WHILEM_B_max", /* REGNODE_MAX +0x11 */
+ "WHILEM_B_max_fail", /* REGNODE_MAX +0x12 */
+ "BRANCH_next", /* REGNODE_MAX +0x13 */
+ "BRANCH_next_fail", /* REGNODE_MAX +0x14 */
+ "CURLYM_A", /* REGNODE_MAX +0x15 */
+ "CURLYM_A_fail", /* REGNODE_MAX +0x16 */
+ "CURLYM_B", /* REGNODE_MAX +0x17 */
+ "CURLYM_B_fail", /* REGNODE_MAX +0x18 */
+ "IFMATCH_A", /* REGNODE_MAX +0x19 */
+ "IFMATCH_A_fail", /* REGNODE_MAX +0x1a */
+ "CURLY_B_min_known", /* REGNODE_MAX +0x1b */
+ "CURLY_B_min_known_fail", /* REGNODE_MAX +0x1c */
+ "CURLY_B_min", /* REGNODE_MAX +0x1d */
+ "CURLY_B_min_fail", /* REGNODE_MAX +0x1e */
+ "CURLY_B_max", /* REGNODE_MAX +0x1f */
+ "CURLY_B_max_fail", /* REGNODE_MAX +0x20 */
+ "COMMIT_next", /* REGNODE_MAX +0x21 */
+ "COMMIT_next_fail", /* REGNODE_MAX +0x22 */
+ "MARKPOINT_next", /* REGNODE_MAX +0x23 */
+ "MARKPOINT_next_fail", /* REGNODE_MAX +0x24 */
+ "SKIP_next", /* REGNODE_MAX +0x25 */
+ "SKIP_next_fail", /* REGNODE_MAX +0x26 */
+ "CUTGROUP_next", /* REGNODE_MAX +0x27 */
+ "CUTGROUP_next_fail", /* REGNODE_MAX +0x28 */
+ "KEEPS_next", /* REGNODE_MAX +0x29 */
+ "KEEPS_next_fail", /* REGNODE_MAX +0x2a */
};
#endif /* DOINIT */
PERL_ARGS_ASSERT_SV_SETPVN;
SV_CHECK_THINKFIRST_COW_DROP(sv);
+ if (isGV_with_GP(sv))
+ Perl_croak_no_modify();
if (!ptr) {
(void)SvOK_off(sv);
return;
*/
void
-Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
+Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *little, const STRLEN littlelen, const U32 flags)
{
char *big;
char *mid;
SvPV_force_flags(bigstr, curlen, flags);
(void)SvPOK_only_UTF8(bigstr);
+
+ if (little >= SvPVX(bigstr) &&
+ little < SvPVX(bigstr) + (SvLEN(bigstr) ? SvLEN(bigstr) : SvCUR(bigstr))) {
+ /* little is a pointer to within bigstr, since we can reallocate bigstr,
+ or little...little+littlelen might overlap offset...offset+len we make a copy
+ */
+ little = savepvn(little, littlelen);
+ SAVEFREEPV(little);
+ }
+
if (offset + len > curlen) {
SvGROW(bigstr, offset+len+1);
Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
C<strlen()>, (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).
-For efficiency, consider using C<newSVpvn> instead.
+This function can cause reliability issues if you are likely to pass in
+empty strings that are not null terminated, because it will run
+strlen on the string and potentially run past valid memory.
+
+Using L</newSVpvn> is a safer alternative for non C<NUL> terminated strings.
+For string literals use L</newSVpvs> instead. This function will work fine for
+C<NUL> terminated strings, but if you want to avoid the if statement on whether
+to call C<strlen> use C<newSVpvn> instead (calling C<strlen> yourself).
=cut
*/
Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", ptr);
elen = quadmath_snprintf(PL_efloatbuf, PL_efloatsize,
qfmt, nv);
- if ((IV)elen == -1)
+ if ((IV)elen == -1) {
+ if (qfmt != ptr)
+ SAVEFREEPV(qfmt);
Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
+ }
if (qfmt != ptr)
Safefree(qfmt);
}
parser->sig_elems = proto->sig_elems;
parser->sig_optelems= proto->sig_optelems;
parser->sig_slurpy = proto->sig_slurpy;
+ parser->recheck_utf8_validity = proto->recheck_utf8_validity;
parser->linestr = sv_dup_inc(proto->linestr, param);
{
/* *** any alterations to the SV types above need to be reflected in
* SVt_MASK and the various PL_valid_types_* tables. As of this writing those
* tables are in perl.h. There are also two affected names tables in dump.c,
- * one in B.xs, and 'bodies_by_type[]' in sv.c */
+ * one in B.xs, and 'bodies_by_type[]' in sv.c.
+ *
+ * The bits that match 0xf0 are CURRENTLY UNUSED, except that 0xFF means a
+ * freed SV. The bits above that are for flags, like SVf_IOK */
#define SVt_MASK 0xf /* smallest bitmask that covers all types */
return $out;
}
+my @i8_to_native = ( # Only code page 1047 so far.
+# _0 _1 _2 _3 _4 _5 _6 _7 _8 _9 _A _B _C _D _E _F
+0x00,0x01,0x02,0x03,0x37,0x2D,0x2E,0x2F,0x16,0x05,0x15,0x0B,0x0C,0x0D,0x0E,0x0F,
+0x10,0x11,0x12,0x13,0x3C,0x3D,0x32,0x26,0x18,0x19,0x3F,0x27,0x1C,0x1D,0x1E,0x1F,
+0x40,0x5A,0x7F,0x7B,0x5B,0x6C,0x50,0x7D,0x4D,0x5D,0x5C,0x4E,0x6B,0x60,0x4B,0x61,
+0xF0,0xF1,0xF2,0xF3,0xF4,0xF5,0xF6,0xF7,0xF8,0xF9,0x7A,0x5E,0x4C,0x7E,0x6E,0x6F,
+0x7C,0xC1,0xC2,0xC3,0xC4,0xC5,0xC6,0xC7,0xC8,0xC9,0xD1,0xD2,0xD3,0xD4,0xD5,0xD6,
+0xD7,0xD8,0xD9,0xE2,0xE3,0xE4,0xE5,0xE6,0xE7,0xE8,0xE9,0xAD,0xE0,0xBD,0x5F,0x6D,
+0x79,0x81,0x82,0x83,0x84,0x85,0x86,0x87,0x88,0x89,0x91,0x92,0x93,0x94,0x95,0x96,
+0x97,0x98,0x99,0xA2,0xA3,0xA4,0xA5,0xA6,0xA7,0xA8,0xA9,0xC0,0x4F,0xD0,0xA1,0x07,
+0x20,0x21,0x22,0x23,0x24,0x25,0x06,0x17,0x28,0x29,0x2A,0x2B,0x2C,0x09,0x0A,0x1B,
+0x30,0x31,0x1A,0x33,0x34,0x35,0x36,0x08,0x38,0x39,0x3A,0x3B,0x04,0x14,0x3E,0xFF,
+0x41,0x42,0x43,0x44,0x45,0x46,0x47,0x48,0x49,0x4A,0x51,0x52,0x53,0x54,0x55,0x56,
+0x57,0x58,0x59,0x62,0x63,0x64,0x65,0x66,0x67,0x68,0x69,0x6A,0x70,0x71,0x72,0x73,
+0x74,0x75,0x76,0x77,0x78,0x80,0x8A,0x8B,0x8C,0x8D,0x8E,0x8F,0x90,0x9A,0x9B,0x9C,
+0x9D,0x9E,0x9F,0xA0,0xAA,0xAB,0xAC,0xAE,0xAF,0xB0,0xB1,0xB2,0xB3,0xB4,0xB5,0xB6,
+0xB7,0xB8,0xB9,0xBA,0xBB,0xBC,0xBE,0xBF,0xCA,0xCB,0xCC,0xCD,0xCE,0xCF,0xDA,0xDB,
+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 = ($::IS_ASCII)
+ ? sub { return shift }
+ : sub { return join "", map { chr $i8_to_native[ord $_] }
+ split "", shift };
+*native_to_I8 = ($::IS_ASCII)
+ ? sub { return shift }
+ : sub { return join "", map { chr $native_to_i8[ord $_] }
+ split "", shift };
+
1
# we've not yet verified that use works.
# use strict;
-print "1..30\n";
+print "1..35\n";
my $test = 0;
# Historically constant folding was performed by evaluating the ops, and if
is $w, 1, '1+undef_constant is not folded outside warninsg scope';
BEGIN { $^W = 1 }
}
+
+$a = eval 'my @z; @z = 0..~0 if 0; 3';
+is ($a, 3, "list constant folding doesn't signal compile-time error");
+is ($@, '', 'no error');
+
+$b = 0;
+$a = eval 'my @z; @z = 0..~0 if $b; 3';
+is ($a, 3, "list constant folding doesn't signal compile-time error");
+is ($@, '', 'no error');
+
+$a = eval 'local $SIG{__WARN__} = sub {}; join("", ":".."~", "z")';
+is ($a, ":z", "aborted list constant folding still executable");
chdir 't' if -d 't';
}
-print "1..187\n";
+print "1..188\n";
sub failed {
my ($got, $expected, $name) = @_;
like $@, qr/Missing right curly or square bracket/, 'RT #130311';
}
+# RT #130815: crash in ck_return for malformed code
+{
+ eval 'm(@{if(0){sub d{]]])}return';
+ like $@, qr/^syntax error at \(eval \d+\) line 1, near "\{\]"/,
+ 'RT #130815: null pointer deref';
+}
# Add new tests HERE (above this line)
glob catfile(curdir(), "lib", $pragma_name, "*");
}
+if ($::IS_EBCDIC) { # Skip Latin1 files
+ @w_files = grep { $_ !~ / _l1 $/x } @w_files
+}
+
my ($tests, @prgs) = setup_multiple_progs(@w_files);
$^X = rel2abs($^X);
# NAME Regexp constant overloading when *^H is undefined
use overload;
BEGIN { overload::constant qr => sub {}; undef *^H }
-/a/, m'a'
+/a/
EXPECT
Constant(qq) unknown at - line 3, within pattern
+Execution of - aborted due to compilation errors.
+########
+# NAME Regexp constant overloading when *^H is undefined
+use overload;
+BEGIN { overload::constant qr => sub {}; undef *^H }
+m'a'
+EXPECT
Constant(q) unknown at - line 3, within pattern
Execution of - aborted due to compilation errors.
########
# NAME Regexp constant overloading returning undef
use overload;
BEGIN { overload::constant qr => sub {} }
-/a/, m'a'
+/a/
EXPECT
Constant(qq): Call to &{$^H{qr}} did not return a defined value at - line 3, within pattern
+Execution of - aborted due to compilation errors.
+########
+# NAME Regexp constant overloading returning undef
+use overload;
+BEGIN { overload::constant qr => sub {} }
+m'a'
+EXPECT
Constant(q): Call to &{$^H{qr}} did not return a defined value at - line 3, within pattern
Execution of - aborted due to compilation errors.
########
--- /dev/null
+# File is encoded in latin-1 so can have malformed-utf8
+__END__
+# NAME [perl #129037]
+BEGIN{{};$^H=-1}0Ã
+EXPECT
+Malformed UTF-8 character: \xc3\x0a (unexpected non-continuation byte 0x0a, immediately after start byte 0xc3; need 2 bytes, got 1) at - line 1.
+Malformed UTF-8 character (fatal) at - line 1.
+########
+# NAME [perl #129157]
+BEGIN {$^H {q} = sub {pop and-t write gmtime getpwuid @p }; $^H =-6**4,0*215}
+"@ust weÃÃÃÃÃÃÃÃÃÃÃtprotobyname"; "9 "Y=n {pop and-p[p };shmr [A
+ G----C
+EXPECT
+Malformed UTF-8 character: \xc3\xc3 (unexpected non-continuation byte 0xc3, immediately after start byte 0xc3; need 2 bytes, got 1) at - line 2.
+Malformed UTF-8 character (fatal) at - line 2.
+########
+# NAME [perl #130675]
+use utf8;y'0Á''
+EXPECT
+Malformed UTF-8 character: \xc1\x27 (unexpected non-continuation byte 0x27, immediately after start byte 0xc1; need 2 bytes, got 1) at - line 1.
+Malformed UTF-8 character: \xc1\x27 (any UTF-8 sequence that starts with "\xc1" is overlong which can and should be represented with a different, shorter sequence) at - line 1.
+Malformed UTF-8 character (fatal) at - line 1.
do xa for my $a;
do xa for my @a;
EXPECT
+########
+# TODO [perl #125493
+use warnings;
+$_="3.14159";
+tr/0-9/\x{6F0}-\x{6F9}/;
+EXPECT
use warnings;
$a = qr/\c,/;
$a = qr/[\c,]/;
-no warnings 'syntax', 'deprecated';
+no warnings 'syntax';
$a = qr/\c,/;
$a = qr/[\c,]/;
EXPECT
-"\c," is more clearly written simply as "l". This will be a fatal error in Perl 5.28 at - line 9.
-"\c," is more clearly written simply as "l". This will be a fatal error in Perl 5.28 at - line 10.
+"\c," is more clearly written simply as "l" at - line 9.
+"\c," is more clearly written simply as "l" at - line 10.
########
# This is because currently a different error is output under
# use re 'strict', so can't go in reg_mesg.t
use warnings;
$a = "\c,";
$a = "\c`";
-no warnings 'syntax', 'deprecated';
+no warnings 'syntax';
$a = "\c,";
$a = "\c`";
EXPECT
-"\c," is more clearly written simply as "l". This will be a fatal error in Perl 5.28 at - line 9.
-"\c`" is more clearly written simply as "\ ". This will be a fatal error in Perl 5.28 at - line 10.
+"\c," is more clearly written simply as "l" at - line 9.
+"\c`" is more clearly written simply as "\ " at - line 10.
########
# toke.c
BEGIN {
use utf8;
my $a = qr ̂foobar̂;
EXPECT
-Use of unassigned code point or non-standalone grapheme for a delimiter will be a fatal error starting in Perl v5.30 at - line 8.
+Use of unassigned code point or non-standalone grapheme for a delimiter will be a fatal error starting in Perl 5.30 at - line 8.
+########
+# NAME [perl #130567] Assertion failure
+BEGIN {
+ if (ord('A') != 65) {
+ print "SKIPPED\n# test is ASCII-specific";
+ exit 0;
+ }
+}
+no warnings "uninitialized";
+$_= "";
+s//\3000/;
+s//"\x{180};;s\221(*$@$`\241\275";/gee;
+s//"s\221\302\302\302\302\302\302\302$@\241\275";/gee;
+EXPECT
+########
+# NAME [perl #130666] Assertion failure
+no warnings "uninitialized";
+BEGIN{$^H=-1};my $l; s\0$0[$l]\0\0
+EXPECT
+########
+# NAME [perl #129036] Assertion failure
+BEGIN{$0="";$^H=hex join""=>A00000}p?
+EXPECT
+OPTION fatal
+syntax error at - line 1, at EOF
+Execution of - aborted due to compilation errors.
+########
+# NAME [perl #130655]
+use utf8;
+qw∘foo ∞ ♥ bar∘
+EXPECT
SKIP: {
use Config;
# debugging builds will detect this failure and panic
- skip "DEBUGGING build" if $::Config{ccflags} =~ /DEBUGGING/
+ skip "DEBUGGING build" if $::Config{ccflags} =~ /(?<!\S)-DDEBUGGING(?!\S)/
or $^O eq 'VMS' && $::Config{usedebugging_perl} eq 'Y';
local $::TODO = 'cheat and optimise my (....) = @_';
local @_ = 1..3;
use warnings;
use strict;
-plan tests => 99;
+plan tests => 100;
our $TODO;
my $deprecated = 0;
}
EOC
}
+
+sub revnumcmp ($$) {
+ goto FOO;
+ die;
+ FOO:
+ return $_[1] <=> $_[0];
+}
+is eval { join(":", sort revnumcmp (9,5,1,3,7)) }, "9:7:5:3:1",
+ "can goto at top level of multicalled sub";
BEGIN { chdir 't' if -d 't'; require './test.pl'; }
-plan(tests => 34);
+plan(tests => 36);
{
no warnings 'deprecated';
'[perl #129000] read before buffer'
);
}
+# probably only failed under ASAN
+fresh_perl_is(
+ "stat\tt\$#0",
+ <<'EOM',
+$# is no longer supported. Its use will be fatal in Perl 5.30 at - line 1.
+Number found where operator expected at - line 1, near "$#0"
+ (Missing operator before 0?)
+Can't call method "t" on an undefined value at - line 1.
+EOM
+ {},
+ "[perl #129273] heap use after free or overflow"
+);
+
+fresh_perl_like('flock _$', qr/Not enough arguments for flock/, {stderr => 1},
+ "[perl #129190] intuit_method() invalidates PL_bufptr");
use warnings;
use strict;
-plan 58;
+plan 62;
# check that strict refs hint is handled
or diag("eval gave: $@");
is($warn, "", "#123609: warn");
}
+
+# RT #130727
+# a [ah]elem op can be both OPpLVAL_INTRO and OPpDEREF. It may not make
+# much sense, but it shouldn't fail an assert.
+
+{
+ my @x;
+ eval { @{local $x[0][0]} = 1; };
+ like $@, qr/Can't use an undefined value as an ARRAY reference/,
+ "RT #130727 error";
+ ok !defined $x[0][0],"RT #130727 array not autovivified";
+
+ eval { @{1, local $x[0][0]} = 1; };
+ like $@, qr/Can't use an undefined value as an ARRAY reference/,
+ "RT #130727 part 2: error";
+ ok !defined $x[0][0],"RT #130727 part 2: array not autovivified";
+
+}
set_up_inc(qw(. ../lib)); # ../lib needed for test.deparse
}
-plan tests => 35;
+plan tests => 38;
# compile time evaluation
is(ord(chr(0x1FFFFF)), 0x1FFFFF, 'last four-byte char in UTF-8');
is(ord(chr(0x200000)), 0x200000, 'first five-byte char in UTF-8');
}
+
+is(ord(""), 0, "ord of literal empty string");
+is(ord(do { my $x = ""; utf8::downgrade($x); $x }), 0,
+ "ord of downgraded empty string");
+is(ord(do { my $x = ""; utf8::upgrade($x); $x }), 0,
+ "ord of upgraded empty string");
is prototype(\&t002), undef;
is eval("t002()"), 123;
is eval("t002(456)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t002' at \(eval \d+\) line 1\.\n\z/;
is eval("t002(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t002' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t003 ( ) { $a || "z" }
is prototype(\&t003), undef;
is eval("t003()"), 123;
is eval("t003(456)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t003' at \(eval \d+\) line 1\.\n\z/;
is eval("t003(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t003' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t006 ($a) { $a || "z" }
is prototype(\&t006), undef;
is eval("t006()"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t006' at \(eval \d+\) line 1\.\n\z/;
is eval("t006(0)"), "z";
is eval("t006(456)"), 456;
is eval("t006(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t006' at \(eval \d+\) line 1\.\n\z/;
is eval("t006(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t006' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t007 ($a, $b) { $a.$b }
is prototype(\&t007), undef;
is eval("t007()"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t007' at \(eval \d+\) line 1\.\n\z/;
is eval("t007(456)"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t007' at \(eval \d+\) line 1\.\n\z/;
is eval("t007(456, 789)"), "456789";
is eval("t007(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t007' at \(eval \d+\) line 1\.\n\z/;
is eval("t007(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t007' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t008 ($a, $b, $c) { $a.$b.$c }
is prototype(\&t008), undef;
is eval("t008()"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t008' at \(eval \d+\) line 1\.\n\z/;
is eval("t008(456)"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t008' at \(eval \d+\) line 1\.\n\z/;
is eval("t008(456, 789)"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t008' at \(eval \d+\) line 1\.\n\z/;
is eval("t008(456, 789, 987)"), "456789987";
is eval("t008(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t008' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t009 ($abc, $def) { $abc.$def }
is prototype(\&t009), undef;
is eval("t009()"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t009' at \(eval \d+\) line 1\.\n\z/;
is eval("t009(456)"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t009' at \(eval \d+\) line 1\.\n\z/;
is eval("t009(456, 789)"), "456789";
is eval("t009(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t009' at \(eval \d+\) line 1\.\n\z/;
is eval("t009(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t009' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t010 ($a, $) { $a || "z" }
is prototype(\&t010), undef;
is eval("t010()"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t010' at \(eval \d+\) line 1\.\n\z/;
is eval("t010(456)"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t010' at \(eval \d+\) line 1\.\n\z/;
is eval("t010(0, 789)"), "z";
is eval("t010(456, 789)"), 456;
is eval("t010(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t010' at \(eval \d+\) line 1\.\n\z/;
is eval("t010(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t010' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t011 ($, $a) { $a || "z" }
is prototype(\&t011), undef;
is eval("t011()"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t011' at \(eval \d+\) line 1\.\n\z/;
is eval("t011(456)"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t011' at \(eval \d+\) line 1\.\n\z/;
is eval("t011(456, 0)"), "z";
is eval("t011(456, 789)"), 789;
is eval("t011(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t011' at \(eval \d+\) line 1\.\n\z/;
is eval("t011(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t011' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t012 ($, $) { $a || "z" }
is prototype(\&t012), undef;
is eval("t012()"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t012' at \(eval \d+\) line 1\.\n\z/;
is eval("t012(456)"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t012' at \(eval \d+\) line 1\.\n\z/;
is eval("t012(0, 789)"), 123;
is eval("t012(456, 789)"), 123;
is eval("t012(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t012' at \(eval \d+\) line 1\.\n\z/;
is eval("t012(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t012' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t013 ($) { $a || "z" }
is prototype(\&t013), undef;
is eval("t013()"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t013' at \(eval \d+\) line 1\.\n\z/;
is eval("t013(0)"), 123;
is eval("t013(456)"), 123;
is eval("t013(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t013' at \(eval \d+\) line 1\.\n\z/;
is eval("t013(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t013' at \(eval \d+\) line 1\.\n\z/;
is eval("t013(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t013' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t014 ($a = 222) { $a // "z" }
is eval("t014(undef)"), "z";
is eval("t014(456)"), 456;
is eval("t014(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t014' at \(eval \d+\) line 1\.\n\z/;
is eval("t014(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t014' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t015 ($a = undef) { $a // "z" }
is eval("t015(undef)"), "z";
is eval("t015(456)"), 456;
is eval("t015(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t015' at \(eval \d+\) line 1\.\n\z/;
is eval("t015(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t015' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t016 ($a = do { $z++; 222 }) { $a // "z" }
is eval("t016(undef)"), "z";
is eval("t016(456)"), 456;
is eval("t016(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t016' at \(eval \d+\) line 1\.\n\z/;
is eval("t016(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t016' at \(eval \d+\) line 1\.\n\z/;
is $z, 1;
is eval("t016()"), 222;
is $z, 2;
is eval("t017(undef)"), "z";
is eval("t017(456)"), 456;
is eval("t017(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t017' at \(eval \d+\) line 1\.\n\z/;
is eval("t017(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t017' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t019 ($p = 222, $a = 333) { "$p/$a" }
is eval("t019(456)"), "456/333";
is eval("t019(456, 789)"), "456/789";
is eval("t019(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t019' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t020 :prototype($) { $_[0]."z" }
is eval("t021(456)"), "456/333";
is eval("t021(456, 789)"), "456/789";
is eval("t021(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t021' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t022 ($p = do { $z += 10; 222 }, $a = do { $z++; 333 }) { "$p/$a" }
is $z, 13;
is eval("t022(456, 789)"), "456/789";
is eval("t022(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t022' at \(eval \d+\) line 1\.\n\z/;
is $z, 13;
is $a, 123;
is eval("t023()"), "azy";
is eval("t023(sub { \"x\".\$_[0].\"x\" })"), "xaxy";
is eval("t023(sub { \"x\".\$_[0].\"x\" }, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t023' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t036 ($a = $a."x") { $a."y" }
is eval("t036(0)"), "0y";
is eval("t036(456)"), "456y";
is eval("t036(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t036' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t120 ($a = $_) { $a // "z" }
is eval("t120(456)"), 456;
$_ = "___";
is eval("t120(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t120' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t121 ($a = caller) { $a // "z" }
is eval("t121(0)"), 0;
is eval("t121(456)"), 456;
is eval("t121(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t121' at \(eval \d+\) line 1\.\n\z/;
is eval("package T121::Z; ::t121()"), "T121::Z";
is eval("package T121::Z; ::t121(undef)"), "z";
is eval("package T121::Z; ::t121(0)"), 0;
is eval("package T121::Z; ::t121(456)"), 456;
is eval("package T121::Z; ::t121(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t121' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t129 ($a = return 222) { $a."x" }
is eval("t129(0)"), "0x";
is eval("t129(456)"), "456x";
is eval("t129(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t129' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
use feature "current_sub";
is eval("t122(5)"), "543210";
is eval("t122(5, 789)"), "5789";
is eval("t122(5, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t122' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t123 ($list = wantarray) { $list ? "list" : "scalar" }
is eval("scalar(t123(1))"), "list";
is eval("(t123(1))[0]"), "list";
is eval("t123(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t123' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t124 ($b = (local $a = $a + 1)) { "$a/$b" }
is eval("t124(456)"), "123/456";
is $a, 123;
is eval("t124(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t124' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t125 ($c = (our $t125_counter)++) { $c }
is eval("t125()"), 3;
is eval("t125()"), 4;
is eval("t125(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t125' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
use feature "state";
is eval("t126()"), 222;
is $z, 223;
is eval("t126(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t126' at \(eval \d+\) line 1\.\n\z/;
is $z, 223;
is $a, 123;
is eval("t127()"), 225;
is eval("t127()"), 226;
is eval("t127(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t127' at \(eval \d+\) line 1\.\n\z/;
is $z, 223;
is $a, 123;
is eval("t037(456)"), "456/456x";
is eval("t037(456, 789)"), "456/789";
is eval("t037(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t037' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t128 ($a = 222, $b = ($a = 333)) { "$a/$b" }
is eval("t128(456)"), "333/333";
is eval("t128(456, 789)"), "456/789";
is eval("t128(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t128' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t130 { join(",", @_).";".scalar(@_) }
is eval("t131(456)"), "456;1";
is eval("t131(456, 789)"), "456/789";
is eval("t131(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t131' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
eval "#line 8 foo\nsub t024 (\$a =) { }";
is eval("t025(0)"), 123;
is eval("t025(456)"), 123;
is eval("t025(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t025' at \(eval \d+\) line 1\.\n\z/;
is eval("t025(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t025' at \(eval \d+\) line 1\.\n\z/;
is eval("t025(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t025' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t026 ($ = 222) { $a // "z" }
is eval("t026(0)"), 123;
is eval("t026(456)"), 123;
is eval("t026(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t026' at \(eval \d+\) line 1\.\n\z/;
is eval("t026(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t026' at \(eval \d+\) line 1\.\n\z/;
is eval("t026(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t026' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t032 ($ = do { $z++; 222 }) { $a // "z" }
is eval("t032(0)"), 123;
is eval("t032(456)"), 123;
is eval("t032(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t032' at \(eval \d+\) line 1\.\n\z/;
is eval("t032(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t032' at \(eval \d+\) line 1\.\n\z/;
is eval("t032(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t032' at \(eval \d+\) line 1\.\n\z/;
is $z, 1;
is $a, 123;
is eval("t027(0)"), 123;
is eval("t027(456)"), 123;
is eval("t027(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t027' at \(eval \d+\) line 1\.\n\z/;
is eval("t027(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t027' at \(eval \d+\) line 1\.\n\z/;
is eval("t027(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t027' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t119 ($ =, $a = 333) { $a // "z" }
is eval("t119(456)"), 333;
is eval("t119(456, 789)"), 789;
is eval("t119(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t119' at \(eval \d+\) line 1\.\n\z/;
is eval("t119(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t119' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t028 ($a, $b = 333) { "$a/$b" }
is prototype(\&t028), undef;
is eval("t028()"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t028' at \(eval \d+\) line 1\.\n\z/;
is eval("t028(0)"), "0/333";
is eval("t028(456)"), "456/333";
is eval("t028(456, 789)"), "456/789";
is eval("t028(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t028' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t045 ($a, $ = 333) { "$a/" }
is prototype(\&t045), undef;
is eval("t045()"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t045' at \(eval \d+\) line 1\.\n\z/;
is eval("t045(0)"), "0/";
is eval("t045(456)"), "456/";
is eval("t045(456, 789)"), "456/";
is eval("t045(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t045' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t046 ($, $b = 333) { "$a/$b" }
is prototype(\&t046), undef;
is eval("t046()"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t046' at \(eval \d+\) line 1\.\n\z/;
is eval("t046(0)"), "123/333";
is eval("t046(456)"), "123/333";
is eval("t046(456, 789)"), "123/789";
is eval("t046(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t046' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t047 ($, $ = 333) { "$a/" }
is prototype(\&t047), undef;
is eval("t047()"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t047' at \(eval \d+\) line 1\.\n\z/;
is eval("t047(0)"), "123/";
is eval("t047(456)"), "123/";
is eval("t047(456, 789)"), "123/";
is eval("t047(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t047' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t029 ($a, $b, $c = 222, $d = 333) { "$a/$b/$c/$d" }
is prototype(\&t029), undef;
is eval("t029()"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t029' at \(eval \d+\) line 1\.\n\z/;
is eval("t029(0)"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t029' at \(eval \d+\) line 1\.\n\z/;
is eval("t029(456)"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t029' at \(eval \d+\) line 1\.\n\z/;
is eval("t029(456, 789)"), "456/789/222/333";
is eval("t029(456, 789, 987)"), "456/789/987/333";
is eval("t029(456, 789, 987, 654)"), "456/789/987/654";
is eval("t029(456, 789, 987, 654, 321)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t029' at \(eval \d+\) line 1\.\n\z/;
is eval("t029(456, 789, 987, 654, 321, 111)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t029' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t038 ($a, $b = $a."x") { "$a/$b" }
is prototype(\&t038), undef;
is eval("t038()"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t038' at \(eval \d+\) line 1\.\n\z/;
is eval("t038(0)"), "0/0x";
is eval("t038(456)"), "456/456x";
is eval("t038(456, 789)"), "456/789";
is eval("t038(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t038' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
eval "#line 8 foo\nsub t030 (\$a = 222, \$b) { }";
is prototype(\&t039), undef;
is eval("t039()"), "";
is eval("t039(0)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
+like $@, qr#\AOdd name/value argument for subroutine 'main::t039' at \(eval \d+\) line 1\.\n\z#;
is eval("t039(456)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
+like $@, qr#\AOdd name/value argument for subroutine 'main::t039' at \(eval \d+\) line 1\.\n\z#;
is eval("t039(456, 789)"), "456=789";
is eval("t039(456, 789, 987)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
+like $@, qr#\AOdd name/value argument for subroutine 'main::t039' at \(eval \d+\) line 1\.\n\z#;
is eval("t039(456, 789, 987, 654)"), "456=789/987=654";
is eval("t039(456, 789, 987, 654, 321)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
+like $@, qr#\AOdd name/value argument for subroutine 'main::t039' at \(eval \d+\) line 1\.\n\z#;
is eval("t039(456, 789, 987, 654, 321, 111)"), "321=111/456=789/987=654";
is $a, 123;
is prototype(\&t040), undef;
is eval("t040()"), 123;
is eval("t040(0)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
+like $@, qr#\AOdd name/value argument for subroutine 'main::t040' at \(eval \d+\) line 1\.\n\z#;
is eval("t040(456)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
+like $@, qr#\AOdd name/value argument for subroutine 'main::t040' at \(eval \d+\) line 1\.\n\z#;
is eval("t040(456, 789)"), 123;
is eval("t040(456, 789, 987)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
+like $@, qr#\AOdd name/value argument for subroutine 'main::t040' at \(eval \d+\) line 1\.\n\z#;
is eval("t040(456, 789, 987, 654)"), 123;
is eval("t040(456, 789, 987, 654, 321)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
+like $@, qr#\AOdd name/value argument for subroutine 'main::t040' at \(eval \d+\) line 1\.\n\z#;
is eval("t040(456, 789, 987, 654, 321, 111)"), 123;
is $a, 123;
sub t041 ($a, @b) { $a.";".join("/", @b) }
is prototype(\&t041), undef;
is eval("t041()"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t041' at \(eval \d+\) line 1\.\n\z/;
is eval("t041(0)"), "0;";
is eval("t041(456)"), "456;";
is eval("t041(456, 789)"), "456;789";
sub t042 ($a, @) { $a.";" }
is prototype(\&t042), undef;
is eval("t042()"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t042' at \(eval \d+\) line 1\.\n\z/;
is eval("t042(0)"), "0;";
is eval("t042(456)"), "456;";
is eval("t042(456, 789)"), "456;";
sub t043 ($, @b) { $a.";".join("/", @b) }
is prototype(\&t043), undef;
is eval("t043()"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t043' at \(eval \d+\) line 1\.\n\z/;
is eval("t043(0)"), "123;";
is eval("t043(456)"), "123;";
is eval("t043(456, 789)"), "123;789";
sub t044 ($, @) { $a.";" }
is prototype(\&t044), undef;
is eval("t044()"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t044' at \(eval \d+\) line 1\.\n\z/;
is eval("t044(0)"), "123;";
is eval("t044(456)"), "123;";
is eval("t044(456, 789)"), "123;";
sub t049 ($a, %b) { $a.";".join("/", map { $_."=".$b{$_} } sort keys %b) }
is prototype(\&t049), undef;
is eval("t049()"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t049' at \(eval \d+\) line 1\.\n\z/;
is eval("t049(222)"), "222;";
is eval("t049(222, 456)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
+like $@, qr#\AOdd name/value argument for subroutine 'main::t049' at \(eval \d+\) line 1\.\n\z#;
is eval("t049(222, 456, 789)"), "222;456=789";
is eval("t049(222, 456, 789, 987)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
+like $@, qr#\AOdd name/value argument for subroutine 'main::t049' at \(eval \d+\) line 1\.\n\z#;
is eval("t049(222, 456, 789, 987, 654)"), "222;456=789/987=654";
is eval("t049(222, 456, 789, 987, 654, 321)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
+like $@, qr#\AOdd name/value argument for subroutine 'main::t049' at \(eval \d+\) line 1\.\n\z#;
is eval("t049(222, 456, 789, 987, 654, 321, 111)"),
"222;321=111/456=789/987=654";
is $a, 123;
sub t051 ($a, $b, $c, @d) { "$a;$b;$c;".join("/", @d).";".scalar(@d) }
is prototype(\&t051), undef;
is eval("t051()"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t051' at \(eval \d+\) line 1\.\n\z/;
is eval("t051(456)"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t051' at \(eval \d+\) line 1\.\n\z/;
is eval("t051(456, 789)"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t051' at \(eval \d+\) line 1\.\n\z/;
is eval("t051(456, 789, 987)"), "456;789;987;;0";
is eval("t051(456, 789, 987, 654)"), "456;789;987;654;1";
is eval("t051(456, 789, 987, 654, 321)"), "456;789;987;654/321;2";
sub t052 ($a, $b, %c) { "$a;$b;".join("/", map { $_."=".$c{$_} } sort keys %c) }
is prototype(\&t052), undef;
is eval("t052()"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t052' at \(eval \d+\) line 1\.\n\z/;
is eval("t052(222)"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t052' at \(eval \d+\) line 1\.\n\z/;
is eval("t052(222, 333)"), "222;333;";
is eval("t052(222, 333, 456)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
+like $@, qr#\AOdd name/value argument for subroutine 'main::t052' at \(eval \d+\) line 1\.\n\z#;
is eval("t052(222, 333, 456, 789)"), "222;333;456=789";
is eval("t052(222, 333, 456, 789, 987)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
+like $@, qr#\AOdd name/value argument for subroutine 'main::t052' at \(eval \d+\) line 1\.\n\z#;
is eval("t052(222, 333, 456, 789, 987, 654)"), "222;333;456=789/987=654";
is eval("t052(222, 333, 456, 789, 987, 654, 321)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
+like $@, qr#\AOdd name/value argument for subroutine 'main::t052' at \(eval \d+\) line 1\.\n\z#;
is eval("t052(222, 333, 456, 789, 987, 654, 321, 111)"),
"222;333;321=111/456=789/987=654";
is $a, 123;
}
is prototype(\&t053), undef;
is eval("t053()"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t053' at \(eval \d+\) line 1\.\n\z/;
is eval("t053(222)"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t053' at \(eval \d+\) line 1\.\n\z/;
is eval("t053(222, 333)"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t053' at \(eval \d+\) line 1\.\n\z/;
is eval("t053(222, 333, 444)"), "222;333;444;";
is eval("t053(222, 333, 444, 456)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
+like $@, qr#\AOdd name/value argument for subroutine 'main::t053' at \(eval \d+\) line 1\.\n\z#;
is eval("t053(222, 333, 444, 456, 789)"), "222;333;444;456=789";
is eval("t053(222, 333, 444, 456, 789, 987)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
+like $@, qr#\AOdd name/value argument for subroutine 'main::t053' at \(eval \d+\) line 1\.\n\z#;
is eval("t053(222, 333, 444, 456, 789, 987, 654)"),
"222;333;444;456=789/987=654";
is eval("t053(222, 333, 444, 456, 789, 987, 654, 321)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
+like $@, qr#\AOdd name/value argument for subroutine 'main::t053' at \(eval \d+\) line 1\.\n\z#;
is eval("t053(222, 333, 444, 456, 789, 987, 654, 321, 111)"),
"222;333;444;321=111/456=789/987=654";
is $a, 123;
is eval("t050()"), "211;";
is eval("t050(222)"), "222;";
is eval("t050(222, 456)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
+like $@, qr#\AOdd name/value argument for subroutine 'main::t050' at \(eval \d+\) line 1\.\n\z#;
is eval("t050(222, 456, 789)"), "222;456=789";
is eval("t050(222, 456, 789, 987)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
+like $@, qr#\AOdd name/value argument for subroutine 'main::t050' at \(eval \d+\) line 1\.\n\z#;
is eval("t050(222, 456, 789, 987, 654)"), "222;456=789/987=654";
is eval("t050(222, 456, 789, 987, 654, 321)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
+like $@, qr#\AOdd name/value argument for subroutine 'main::t050' at \(eval \d+\) line 1\.\n\z#;
is eval("t050(222, 456, 789, 987, 654, 321, 111)"),
"222;321=111/456=789/987=654";
is $a, 123;
is eval("t056(222)"), "222;311;";
is eval("t056(222, 333)"), "222;333;";
is eval("t056(222, 333, 456)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
+like $@, qr#\AOdd name/value argument for subroutine 'main::t056' at \(eval \d+\) line 1\.\n\z#;
is eval("t056(222, 333, 456, 789)"), "222;333;456=789";
is eval("t056(222, 333, 456, 789, 987)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
+like $@, qr#\AOdd name/value argument for subroutine 'main::t056' at \(eval \d+\) line 1\.\n\z#;
is eval("t056(222, 333, 456, 789, 987, 654)"), "222;333;456=789/987=654";
is eval("t056(222, 333, 456, 789, 987, 654, 321)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
+like $@, qr#\AOdd name/value argument for subroutine 'main::t056' at \(eval \d+\) line 1\.\n\z#;
is eval("t056(222, 333, 456, 789, 987, 654, 321, 111)"),
"222;333;321=111/456=789/987=654";
is $a, 123;
is eval("t057(222, 333)"), "222;333;411;";
is eval("t057(222, 333, 444)"), "222;333;444;";
is eval("t057(222, 333, 444, 456)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
+like $@, qr#\AOdd name/value argument for subroutine 'main::t057' at \(eval \d+\) line 1\.\n\z#;
is eval("t057(222, 333, 444, 456, 789)"), "222;333;444;456=789";
is eval("t057(222, 333, 444, 456, 789, 987)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
+like $@, qr#\AOdd name/value argument for subroutine 'main::t057' at \(eval \d+\) line 1\.\n\z#;
is eval("t057(222, 333, 444, 456, 789, 987, 654)"),
"222;333;444;456=789/987=654";
is eval("t057(222, 333, 444, 456, 789, 987, 654, 321)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
+like $@, qr#\AOdd name/value argument for subroutine 'main::t057' at \(eval \d+\) line 1\.\n\z#;
is eval("t057(222, 333, 444, 456, 789, 987, 654, 321, 111)"),
"222;333;444;321=111/456=789/987=654";
is $a, 123;
sub t058 ($a, $b = 333, @c) { "$a;$b;".join("/", @c).";".scalar(@c) }
is prototype(\&t058), undef;
is eval("t058()"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t058' at \(eval \d+\) line 1\.\n\z/;
is eval("t058(456)"), "456;333;;0";
is eval("t058(456, 789)"), "456;789;;0";
is eval("t058(456, 789, 987)"), "456;789;987;1";
sub t080 ($a,,, $b) { $a.$b }
is prototype(\&t080), undef;
is eval("t080()"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t080' at \(eval \d+\) line 1\.\n\z/;
is eval("t080(456)"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t080' at \(eval \d+\) line 1\.\n\z/;
is eval("t080(456, 789)"), "456789";
is eval("t080(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t080' at \(eval \d+\) line 1\.\n\z/;
is eval("t080(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t080' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t081 ($a, $b,,) { $a.$b }
is prototype(\&t081), undef;
is eval("t081()"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t081' at \(eval \d+\) line 1\.\n\z/;
is eval("t081(456)"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t081' at \(eval \d+\) line 1\.\n\z/;
is eval("t081(456, 789)"), "456789";
is eval("t081(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t081' at \(eval \d+\) line 1\.\n\z/;
is eval("t081(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t081' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
eval "#line 8 foo\nsub t082 (, \$a) { }";
sub t084($a,$b){ $a.$b }
is prototype(\&t084), undef;
is eval("t084()"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t084' at \(eval \d+\) line 1\.\n\z/;
is eval("t084(456)"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t084' at \(eval \d+\) line 1\.\n\z/;
is eval("t084(456, 789)"), "456789";
is eval("t084(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t084' at \(eval \d+\) line 1\.\n\z/;
is eval("t084(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t084' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t085
{ $a.$b }
is prototype(\&t085), undef;
is eval("t085()"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t085' at \(eval \d+\) line 1\.\n\z/;
is eval("t085(456)"), "456333";
is eval("t085(456, 789)"), "456789";
is eval("t085(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t085' at \(eval \d+\) line 1\.\n\z/;
is eval("t085(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t085' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t086
{ $a.$b }
is prototype(\&t086), undef;
is eval("t086()"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t086' at \(eval \d+\) line 1\.\n\z/;
is eval("t086(456)"), "456333";
is eval("t086(456, 789)"), "456789";
is eval("t086(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t086' at \(eval \d+\) line 1\.\n\z/;
is eval("t086(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t086' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t087
{ $a.$b }
is prototype(\&t087), undef;
is eval("t087()"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t087' at \(eval \d+\) line 1\.\n\z/;
is eval("t087(456)"), "456333";
is eval("t087(456, 789)"), "456789";
is eval("t087(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t087' at \(eval \d+\) line 1\.\n\z/;
is eval("t087(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t087' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
eval "#line 8 foo\nsub t088 (\$ #foo\na) { }";
my $t103 = sub ($a) { $a || "z" };
is prototype($t103), undef;
is eval("\$t103->()"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::__ANON__' at \(eval \d+\) line 1\.\n\z/;
is eval("\$t103->(0)"), "z";
is eval("\$t103->(456)"), 456;
is eval("\$t103->(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::__ANON__' at \(eval \d+\) line 1\.\n\z/;
is eval("\$t103->(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::__ANON__' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
my $t118 = sub ($a) :prototype($) { $a || "z" };
is prototype($t118), "\$";
is eval("\$t118->()"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::__ANON__' at \(eval \d+\) line 1\.\n\z/;
is eval("\$t118->(0)"), "z";
is eval("\$t118->(456)"), 456;
is eval("\$t118->(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::__ANON__' at \(eval \d+\) line 1\.\n\z/;
is eval("\$t118->(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::__ANON__' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t033 ($a = sub ($a) { $a."z" }) { $a->("a")."y" }
is eval("t033()"), "azy";
is eval("t033(sub { \"x\".\$_[0].\"x\" })"), "xaxy";
is eval("t033(sub { \"x\".\$_[0].\"x\" }, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t033' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t133 ($a = sub ($a = 222) { $a."z" }) { $a->()."/".$a->("a") }
is eval("t133()"), "222z/az";
is eval("t133(sub { \"x\".(\$_[0] // \"u\").\"x\" })"), "xux/xax";
is eval("t133(sub { \"x\".(\$_[0] // \"u\").\"x\" }, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t133' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t134 ($a = sub ($a, $t = sub { $_[0]."p" }) { $t->($a)."z" }) {
"xax/xbqx";
is eval("t134(sub { \"x\".(\$_[1] // sub{\$_[0]})->(\$_[0]).\"x\" }, 789)"),
undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t134' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t135 ($a = sub ($a, $t = sub ($p) { $p."p" }) { $t->($a)."z" }) {
"xax/xbqx";
is eval("t135(sub { \"x\".(\$_[1] // sub{\$_[0]})->(\$_[0]).\"x\" }, 789)"),
undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t135' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t132 (
"xax/xbqx";
is eval("t132(sub { \"x\".(\$_[1] // sub{\$_[0]})->(\$_[0]).\"x\" }, 789)"),
undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t132' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t104($a) :method { $a || "z" }
is prototype(\&t104), undef;
is eval("t104()"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t104' at \(eval \d+\) line 1\.\n\z/;
is eval("t104(0)"), "z";
is eval("t104(456)"), 456;
is eval("t104(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t104' at \(eval \d+\) line 1\.\n\z/;
is eval("t104(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t104' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t105($a) :prototype($) { $a || "z" }
sub t106($a) :prototype(@) { $a || "z" }
is prototype(\&t106), "\@";
is eval("t106()"), undef;
-like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo few arguments for subroutine 'main::t106' at \(eval \d+\) line 1\.\n\z/;
is eval("t106(0)"), "z";
is eval("t106(456)"), 456;
is eval("t106(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t106' at \(eval \d+\) line 1\.\n\z/;
is eval("t106(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
+like $@, qr/\AToo many arguments for subroutine 'main::t106' at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
eval "#line 8 foo\nsub t107 :method (\$a) { }";
"masking warning";
}
+# Reporting subroutine names
+
+package T200 {
+ sub foo ($x) {}
+ *t201 = sub ($x) {}
+}
+*t202 = sub ($x) {};
+my $t203 = sub ($x) {};
+*t204 = *T200::foo;
+*t205 = \&T200::foo;
+
+eval { T200::foo() };
+like($@, qr/^Too few arguments for subroutine 'T200::foo'/);
+eval { T200::t201() };
+like($@, qr/^Too few arguments for subroutine 'T200::__ANON__'/);
+eval { t202() };
+like($@, qr/^Too few arguments for subroutine 'main::__ANON__'/);
+eval { $t203->() };
+like($@, qr/^Too few arguments for subroutine 'main::__ANON__'/);
+eval { t204() };
+like($@, qr/^Too few arguments for subroutine 'T200::foo'/);
+eval { t205() };
+like($@, qr/^Too few arguments for subroutine 'T200::foo'/);
+
+
+# RT #130661 a char >= 0x80 in a signature when a sigil was expected
+# was triggering an assertion
+
+eval "sub (\x80";
+like $@, qr/A signature parameter must start with/, "RT #130661";
+
use File::Spec::Functions;
my %fooormore = map { $_ => 0 } @fooormore;
# Load and run the tests
-plan tests => 349+2;
+plan tests => 349+4;
while (<DATA>) {
SKIP: {
}
+{
+ # [perl #130705]
+ # Perl_ck_smartmatch would turn the match in:
+ # 0 =~ qr/1/ ~~ 0 # parsed as (0 =~ qr/1/) ~~ 0
+ # into a qr, leaving the initial 0 on the stack after execution
+ #
+ # Similarly for: 0 ~~ (0 =~ qr/1/)
+ #
+ # Either caused an assertion failure in the context of warn (or print)
+ # if there was some other operator's arguments left on the stack, as with
+ # the test cases.
+ fresh_perl_is('print(0->[0 =~ qr/1/ ~~ 0])', '',
+ { switches => [ "-M-warnings=experimental::smartmatch" ] },
+ "don't qr-ify left-side match against a stacked argument");
+ fresh_perl_is('print(0->[0 ~~ (0 =~ qr/1/)])', '',
+ { switches => [ "-M-warnings=experimental::smartmatch" ] },
+ "don't qr-ify right-side match against a stacked argument");
+}
+
# Prefix character :
# - expected to match
# ! - expected to not match
set_up_inc( qw(../lib) );
}
-plan( tests => 54 );
+plan( tests => 55 );
# Used to segfault (bug #15479)
fresh_perl_like(
),
"ok\n",
"[perl #128238] non-stashes in stashes";
+
+is runperl(
+ prog => '%:: = (); print *{q|::|}, qq|\n|',
+ stderr => 1,
+ ),
+ "*main::main::\n",
+ "[perl #129869] lookup %:: by name after clearing %::";
}
};
-plan(390);
+plan(391);
run_tests() unless caller;
is($result_3363, "best", "ref-to-substr retains lvalue-ness under recursion [perl #3363]");
}
+
+# failed with ASAN
+fresh_perl_is('$0 = "/usr/bin/perl"; substr($0, 0, 0, $0)', '', {}, "(perl #129340) substr() with source in target");
use Config;
-plan tests => 138;
+plan tests => 140;
# run some code N times. If the number of SVs at the end of loop N is
# greater than (N-1)*delta at the end of loop 1, we've got a leak
sub f { $a =~ /[^.]+$b/; }
::leak(2, 0, \&f, q{use re 'strict' shouldn't leak warning strings});
}
+
+# check that B::RHE->HASH does not leak
+{
+ package BHINT;
+ sub foo {}
+ require B;
+ my $op = B::svref_2object(\&foo)->ROOT->first;
+ sub lk { { my $d = $op->hints_hash->HASH } }
+ ::leak(3, 0, \&lk, q!B::RHE->HASH shoudln't leak!);
+}
+
+
+# dying while compiling a regex with codeblocks imported from an embedded
+# qr// could leak
+
+{
+ my sub codeblocks {
+ my $r = qr/(?{ 1; })/;
+ my $c = '(?{ 2; })';
+ eval { /$r$c/ }
+ }
+ ::leak(2, 0, \&codeblocks, q{leaking embedded qr codeblocks});
+}
EXPECT
Can't locate object method "TIESCALAR" via package "main" at - line 2.
########
+# tie into nonexistent glob [RT#130623 assertion failure]
+tie $foo, *FOO;
+EXPECT
+Can't locate object method "TIESCALAR" via package "FOO" at - line 2.
+########
+# tie into glob when package exists but not method: no "*", no "main::"
+{ package PackageWithoutTIESCALAR }
+tie $foo, *PackageWithoutTIESCALAR;
+EXPECT
+Can't locate object method "TIESCALAR" via package "PackageWithoutTIESCALAR" at - line 3.
+########
+# tie into reference [RT#130623 assertion failure]
+eval { tie $foo, \"nope" };
+my $exn = $@ // "";
+print $exn =~ s/0x\w+/0xNNN/rg;
+EXPECT
+Can't locate object method "TIESCALAR" via package "SCALAR(0xNNN)" at - line 2.
+########
#
# STORE freeing tie'd AV
sub TIEARRAY { bless [] }
use utf8;
-plan tests => 215;
+plan tests => 216;
# Test this first before we extend the stack with other operations.
# This caused an asan failure due to a bad write past the end of the stack.
}
+{ # [perl #130656] This bug happens when the tr is split across lines, so
+ # that the first line causes it to go into UTF-8, and the 2nd is only
+ # things like \x
+ my $x = "\x{E235}";
+ $x =~ tr
+ [\x{E234}-\x{E342}\x{E5B5}-\x{E5DF}]
+ [\x{E5CD}-\x{E5DF}\x{EA80}-\x{EAFA}\x{EB0E}-\x{EB8E}\x{EAFB}-\x{EB0D}\x{E5B5}-\x{E5CC}];
+
+ is $x, "\x{E5CE}", '[perl #130656]';
+}
1;
my $bas_tests = 21;
# number of tests in section 3
-my $bug_tests = 66 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 6 + 2 + 3 + 96 + 11 + 4;
+my $bug_tests = 66 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 6 + 2 + 3 + 96 + 11 + 15;
# number of tests in section 4
my $hmb_tests = 37;
formline $format, $orig, 12345;
is $^A, ("x" x 100) . " 12345\n", "\@* doesn't overflow";
+ # ...nor this (RT #130703).
+ # Under 'use bytes', the two bytes (c2, 80) making up each \x80 char
+ # each get expanded to two bytes (so four in total per \x80 char); the
+ # buffer growth wasn't accounting for this doubling in size
+
+ {
+ local $^A = '';
+ my $format = "X\n\x{100}" . ("\x80" x 200);
+ my $expected = $format;
+ utf8::encode($expected);
+ use bytes;
+ formline($format);
+ is $^A, $expected, "RT #130703";
+ }
+
+ # further buffer overflows with RT #130703
+
+ {
+ local $^A = '';
+ my $n = 200;
+ my $long = 'x' x 300;
+ my $numf = ('@###' x $n);
+ my $expected = $long . "\n" . (" 1" x $n);
+ formline("@*\n$numf", $long, ('1') x $n);
+
+ is $^A, $expected, "RT #130703 part 2";
+ }
+
+
# make sure it can cope with formats > 64k
$format = 'x' x 65537;
{ stderr => 1 },
'#128255 Assert fail in S_sublex_done');
+{
+ $^A = "";
+ my $a = *globcopy;
+ my $r = eval { formline "^<<", $a };
+ is $@, "";
+ ok $r, "^ format with glob copy";
+ is $^A, "*ma", "^ format with glob copy";
+ is $a, "in::globcopy", "^ format with glob copy";
+}
+
+{
+ $^A = "";
+ my $r = eval { formline "^<<", *realglob };
+ like $@, qr/\AModification of a read-only value attempted /;
+ is $r, undef, "^ format with real glob";
+ is $^A, "*ma", "^ format with real glob";
+ is ref(\*realglob), "GLOB";
+}
+
+$^A = "";
+
+# [perl #130722] assertion failure
+fresh_perl_is('for(1..2){formline*0}', '', { stderr => 1 } , "#130722 - assertion failure");
#############################
## Section 4
setup => '$_ = ("0" x 100) . ("a" x 100);',
code => '/[acgt]+/',
},
+
+ 'regex::whilem::min_captures_fail' => {
+ desc => '/WHILEM with anon-greedy match and captures that fails',
+ setup => '$_ = ("a" x 20)',
+ code => '/^(?:(.)(.))*?[XY]/',
+ },
+ 'regex::whilem::max_captures_fail' => {
+ desc => '/WHILEM with a greedy match and captures that fails',
+ setup => '$_ = ("a" x 20)',
+ code => '/^(?:(.)(.))*[XY]/',
+ },
];
$| = 1;
-plan tests => 2;
+plan tests => 4;
watchdog(60);
+my $taint = substr($ENV{PATH}, 0, 0); # and empty tainted string
+
{
- my $in = substr($ENV{PATH}, 0, 0) . ( "ab" x 200_000 );
+ my $in = $taint . ( "ab" x 200_000 );
utf8::upgrade($in);
ok(tainted($in), "performance issue only when tainted");
while ($in =~ /\Ga+b/g) { }
pass("\\G on tainted string");
}
+# RT #130584
+# tainted string caused the utf8 pos cache to be cleared each time
+
+{
+ my $repeat = 30_000;
+ my $in = $taint . ("abcdefghijklmnopqrstuvwxyz" x $repeat);
+ utf8::upgrade($in);
+ ok(tainted($in), "performance issue only when tainted");
+ local ${^UTF8CACHE} = 1; # defeat debugging
+ for my $i (1..$repeat) {
+ $in =~ /abcdefghijklmnopqrstuvwxyz/g or die;
+ my $p = pos($in); # this was slow
+ }
+ pass("RT #130584 pos on tainted utf8 string");
+}
+
1;
-CPAN cpan/CPAN/lib/App/Cpan.pm 3cef68c2a44a4996b432bc25622e3a544a188aa5
-CPAN cpan/CPAN/lib/CPAN.pm 4616a44963045f7bd07bb7f8e5f99bbd789af4e5
-CPAN cpan/CPAN/scripts/cpan 22610ed0301d48a269d1739afd2f7f84359d956f
Digest cpan/Digest/Digest.pm 43f7f544cb11842b2f55c73e28930da50774e081
Encode cpan/Encode/Unicode/Unicode.pm 9749692c67f7d69083034de9184a93f070ab4799
ExtUtils::Constant cpan/ExtUtils-Constant/t/Constant.t a0369c919e216fb02767a637666bb4577ad79b02
Memoize cpan/Memoize/Memoize.pm 902092ff91cdec9c7b4bd06202eb179e1ce26ca2
Net::Ping dist/Net-Ping/t/000_load.t deff5dc2ca54dae28cb19d3631427db127279ac2
Net::Ping dist/Net-Ping/t/001_new.t 90c9d63509b3efc8941449fbd1ca8b807fa42040
-Net::Ping dist/Net-Ping/t/010_pingecho.t 2e7340ee0e9f6119b889016fc8b89e6bcd4a8fe2
+Net::Ping dist/Net-Ping/t/010_pingecho.t fd91db2daf78a994bd0210ab32cca2a46dff4f44
Net::Ping dist/Net-Ping/t/500_ping_icmp.t a003daa5eaf215e58234786bb1fbfbebf669bf44
Pod::Checker cpan/Pod-Checker/t/pod/contains_bad_pod.xr 73538fd80dfe6e19ad561fe034009b44460208f6
Pod::Checker cpan/Pod-Checker/t/pod/selfcheck.t 8ce3cfd38e4b9bcf5bc7fe7f2a14195e49aed7d8
Scalar-List-Utils cpan/Scalar-List-Utils/lib/Scalar/Util.pm 98af8fe390d9c9fa11a1fafebbc68ea663cdce2c
Scalar-List-Utils cpan/Scalar-List-Utils/lib/Sub/Util.pm 188cf0dd95cd7ba60fd6a366f440811fb52c2c79
Scalar-List-Utils cpan/Scalar-List-Utils/t/lln.t b7148c7f1cd9c70fd21d8153542b6d3de2b655ad
+Scalar-List-Utils cpan/Scalar-List-Utils/t/tainted.t 9c52e04687ec8a7d23a1c38a762723858305b1fe
Scalar-List-Utils cpan/Scalar-List-Utils/t/uniq.t 5de01094d2bca9cf8b2bbbca920122f7396bf11e
Socket cpan/Socket/Socket.pm 98e38176d745c38282907f391c077298f5a3d0ba
Socket cpan/Socket/Socket.xs edd4fed212785f11c5c2095a75941dad27d586d9
if ($^O eq 'dec_osf') {
skip_all("$^O cannot handle this test");
}
- watchdog(5 * 60);
+ my $time_out_factor = $ENV{PERL_TEST_TIME_OUT_FACTOR} || 1;
+ $time_out_factor = 1 if $time_out_factor < 1;
+
+ watchdog(5 * 60 * $time_out_factor);
require './loc_tools.pl';
}
skip_all('no re module') unless defined &DynaLoader::boot_DynaLoader;
skip_all_without_unicode_tables();
-plan tests => 835; # Update this when adding/deleting tests.
+plan tests => 837; # Update this when adding/deleting tests.
run_tests() unless caller;
}msx, { stderr => 1 }, "Offsets in debug output are not negative");
}
}
+ {
+ # buffer overflow
+ fresh_perl_is("BEGIN{\$^H=0x200000}\ns/[(?{//xx",
+ "Unmatched [ in regex; marked by <-- HERE in m/[ <-- HERE (?{/ at (eval 1) line 1.\n",
+ {}, "buffer overflow for regexp component");
+ }
+ {
+ # [perl #129281] buffer write overflow, detected by ASAN, valgrind
+ fresh_perl_is('/0(?0)|^*0(?0)|^*(^*())0|/', '', {}, "don't bump whilem_c too much");
+ }
} # End of sub run_tests
1;
+
+#
+# ex: set ts=8 sts=4 sw=4 et:
+#
}
-plan tests => 527; # Update this when adding/deleting tests.
+plan tests => 533; # Update this when adding/deleting tests.
run_tests() unless caller;
'padtmp swiping does not affect "$a$b" =~ /(??{})/'
}
+ {
+ # [perl #129140]
+ # this used to cause a double-free of the code_block struct
+ # when re-running the compilation after spotting utf8.
+ # This test doesn't catch it, but might panic, or fail under
+ # valgrind etc
+
+ my $s = '';
+ /$s(?{})\x{100}/ for '', '';
+ pass "RT #129140";
+ }
+
+ # RT #130650 code blocks could get double-freed during a pattern
+ # compilation croak
+
+ {
+ # this used to panic or give ASAN errors
+ eval 'qr/(?{})\6/';
+ like $@, qr/Reference to nonexistent group/, "RT #130650";
+ }
+
+ # RT #129881
+ # on exit from a pattern with multiple code blocks from different
+ # CVs, PL_comppad wasn't being restored correctly
+
+ sub {
+ # give first few pad slots known values
+ my ($x1, $x2, $x3, $x4, $x5) = 101..105;
+ # these vars are in a separate pad
+ my $r = qr/((?{my ($y1, $y2) = 201..202; 1;})A){2}X/;
+ # the first alt fails, causing a switch to this anon
+ # sub's pad
+ "AAA" =~ /$r|(?{my ($z1, $z2) = 301..302; 1;})A/;
+ is $x1, 101, "RT #129881: x1";
+ is $x2, 102, "RT #129881: x2";
+ is $x3, 103, "RT #129881: x3";
+ }->();
+
+
+ # RT #126697
+ # savestack wasn't always being unwound on EVAL failure
+ {
+ local our $i = 0;
+ my $max = 0;
+
+ 'ABC' =~ m{
+ \A
+ (?:
+ (?: AB | A | BC )
+ (?{
+ local $i = $i + 1;
+ $max = $i if $max < $i;
+ })
+ )*
+ \z
+ }x;
+ is $max, 2, "RT #126697";
+ }
+
+
} # End of sub run_tests
1;
use 5.010;
use Config;
-plan tests => 2502; # Update this when adding/deleting tests.
+plan tests => 2504; # Update this when adding/deleting tests.
run_tests() unless caller;
my $s = "\x{f2}\x{140}\x{fe}\x{ff}\x{ff}\x{ff}";
ok($s !~ /^0000.\34500\376\377\377\377/, "RT #129085");
}
+ {
+ # rt
+ fresh_perl_is(
+ 'no warnings "regexp"; "foo"=~/((?1)){8,0}/; print "ok"',
+ "ok", {}, 'RT #130561 - allowing impossible quantifier should not cause SEGVs');
+ my $s= "foo";
+ no warnings 'regexp';
+ ok($s=~/(foo){1,0}|(?1)/,
+ "RT #130561 - allowing impossible quantifier should not break recursion");
+ }
} # End of sub run_tests
# Verify get errors. For these, we need // or else puts it in single quotes,
# and bypasses the lexer.
/\N{U+}/ - c - Invalid hexadecimal number
-# Below currently gives a misleading message
-/[\N{U+}]/ - Sc - Unmatched
-/[\N{U+}]/ - sc - Syntax error in (?[...])
+/[\N{U+}]/ - c - Invalid hexadecimal number
/abc\N{def/ - c - Missing right brace
/\N{U+4AG3}/ - c - Invalid hexadecimal number
-/[\N{U+4AG3}]/ - Sc - Unmatched
-/[\N{U+4AG3}]/ - sc - Syntax error in (?[...])
+/[\N{U+4AG3}]/ - c - Invalid hexadecimal number
# And verify that in single quotes which bypasses the lexer, the regex compiler
# figures it out.
],
'/a{1,1}?\x{100}/' => 'Useless use of greediness modifier \'?\' {#} m/a{1,1}?{#}\x{100}/',
"/(?[ [ % - % ] ])/" => "",
- "/(?[ [ : - \\x$colon_hex ] ])\\x{100}/" => "\": - \\x$colon_hex \" is more clearly written simply as \":\". This will be a fatal error in Perl 5.28 {#} m/(?[ [ : - \\x$colon_hex {#}] ])\\x{100}/",
- "/(?[ [ \\x$colon_hex - : ] ])\\x{100}/" => "\"\\x$colon_hex\ - : \" is more clearly written simply as \":\". This will be a fatal error in Perl 5.28 {#} m/(?[ [ \\x$colon_hex - : {#}] ])\\x{100}/",
- "/(?[ [ \\t - \\x$tab_hex ] ])\\x{100}/" => "\"\\t - \\x$tab_hex \" is more clearly written simply as \"\\t\". This will be a fatal error in Perl 5.28 {#} m/(?[ [ \\t - \\x$tab_hex {#}] ])\\x{100}/",
- "/(?[ [ \\x$tab_hex - \\t ] ])\\x{100}/" => "\"\\x$tab_hex\ - \\t \" is more clearly written simply as \"\\t\". This will be a fatal error in Perl 5.28 {#} m/(?[ [ \\x$tab_hex - \\t {#}] ])\\x{100}/",
+ "/(?[ [ : - \\x$colon_hex ] ])\\x{100}/" => "\": - \\x$colon_hex \" is more clearly written simply as \":\" {#} m/(?[ [ : - \\x$colon_hex {#}] ])\\x{100}/",
+ "/(?[ [ \\x$colon_hex - : ] ])\\x{100}/" => "\"\\x$colon_hex\ - : \" is more clearly written simply as \":\" {#} m/(?[ [ \\x$colon_hex - : {#}] ])\\x{100}/",
+ "/(?[ [ \\t - \\x$tab_hex ] ])\\x{100}/" => "\"\\t - \\x$tab_hex \" is more clearly written simply as \"\\t\" {#} m/(?[ [ \\t - \\x$tab_hex {#}] ])\\x{100}/",
+ "/(?[ [ \\x$tab_hex - \\t ] ])\\x{100}/" => "\"\\x$tab_hex\ - \\t \" is more clearly written simply as \"\\t\" {#} m/(?[ [ \\x$tab_hex - \\t {#}] ])\\x{100}/",
"/(?[ [ $B_hex - C ] ])/" => "Ranges of ASCII printables should be some subset of \"0-9\", \"A-Z\", or \"a-z\" {#} m/(?[ [ $B_hex - C {#}] ])/",
"/(?[ [ A - $B_hex ] ])/" => "Ranges of ASCII printables should be some subset of \"0-9\", \"A-Z\", or \"a-z\" {#} m/(?[ [ A - $B_hex {#}] ])/",
"/(?[ [ $low_mixed_alpha - $high_mixed_alpha ] ])/" => "Ranges of ASCII printables should be some subset of \"0-9\", \"A-Z\", or \"a-z\" {#} m/(?[ [ $low_mixed_alpha - $high_mixed_alpha {#}] ])/",
'/[\N{U+FF}-\x{100}]/' => 'Both or neither range ends should be Unicode {#} m/[\N{U+FF}-\x{100}{#}]/',
'/[\N{U+100}-\x{101}]/' => "",
"/[%-%]/" => "",
- "/[:-\\x$colon_hex]\\x{100}/" => "\":-\\x$colon_hex\" is more clearly written simply as \":\". This will be a fatal error in Perl 5.28 {#} m/[:-\\x$colon_hex\{#}]\\x{100}/",
- "/[\\x$colon_hex-:]\\x{100}/" => "\"\\x$colon_hex-:\" is more clearly written simply as \":\". This will be a fatal error in Perl 5.28 {#} m/[\\x$colon_hex\-:{#}]\\x{100}/",
- "/[\\t-\\x$tab_hex]\\x{100}/" => "\"\\t-\\x$tab_hex\" is more clearly written simply as \"\\t\". This will be a fatal error in Perl 5.28 {#} m/[\\t-\\x$tab_hex\{#}]\\x{100}/",
- "/[\\x$tab_hex-\\t]\\x{100}/" => "\"\\x$tab_hex-\\t\" is more clearly written simply as \"\\t\". This will be a fatal error in Perl 5.28 {#} m/[\\x$tab_hex\-\\t{#}]\\x{100}/",
+ "/[:-\\x$colon_hex]\\x{100}/" => "\":-\\x$colon_hex\" is more clearly written simply as \":\" {#} m/[:-\\x$colon_hex\{#}]\\x{100}/",
+ "/[\\x$colon_hex-:]\\x{100}/" => "\"\\x$colon_hex-:\" is more clearly written simply as \":\" {#} m/[\\x$colon_hex\-:{#}]\\x{100}/",
+ "/[\\t-\\x$tab_hex]\\x{100}/" => "\"\\t-\\x$tab_hex\" is more clearly written simply as \"\\t\" {#} m/[\\t-\\x$tab_hex\{#}]\\x{100}/",
+ "/[\\x$tab_hex-\\t]\\x{100}/" => "\"\\x$tab_hex-\\t\" is more clearly written simply as \"\\t\" {#} m/[\\x$tab_hex\-\\t{#}]\\x{100}/",
"/[$B_hex-C]/" => "Ranges of ASCII printables should be some subset of \"0-9\", \"A-Z\", or \"a-z\" {#} m/[$B_hex-C{#}]/",
"/[A-$B_hex]/" => "Ranges of ASCII printables should be some subset of \"0-9\", \"A-Z\", or \"a-z\" {#} m/[A-$B_hex\{#}]/",
"/[$low_mixed_alpha-$high_mixed_alpha]/" => "Ranges of ASCII printables should be some subset of \"0-9\", \"A-Z\", or \"a-z\" {#} m/[$low_mixed_alpha-$high_mixed_alpha\{#}]/",
like($@, qr/^Syntax error/, '/(?[(\c]) ]\b/ should be a syntax error');
eval { $_ = '(?[\c[]](])'; qr/$_/ };
like($@, qr/^Syntax error/, '/(?[\c[]](])/ should be a syntax error');
- {
- # This block needs to go after 5.26, as it will be
- # fatal in 5.28. But it's not fatal yet, so we ought
- # to test it.
- no warnings 'deprecated';
- like("\c#", qr/(?[\c#])/, '\c# should match itself');
- }
+ like("\c#", qr/(?[\c#])/, '\c# should match itself');
like("\c[", qr/(?[\c[])/, '\c[ should match itself');
like("\c\ ", qr/(?[\c\])/, '\c\ should match itself');
like("\c]", qr/(?[\c]])/, '\c] should match itself');
my $perlio_log = "perlio$$.txt";
skip_all "DEBUGGING build required"
- unless $::Config{ccflags} =~ /DEBUGGING/
+ unless $::Config{ccflags} =~ /(?<!\S)-DDEBUGGING(?!\S)/
or $^O eq 'VMS' && $::Config{usedebugging_perl} eq 'Y';
plan tests => 8;
? "\x{74}\x{41}"
: "\x{c0}\x{a0}";
CORE::evalbytes "use charnames ':full'; use utf8; my \$x = \"\\N{abc$malformed_to_be}\"";
- like( $@, qr/Malformed UTF-8 character immediately after '\\N\{abc' at .* within string/, 'Malformed UTF-8 input to \N{}');
+ like( $@, qr/Malformed UTF-8 character \(fatal\) at /, 'Malformed UTF-8 input to \N{}');
}
# RT# 124216: Perl_sv_clear: Assertion
Perl_taint_env(pTHX)
{
SV** svp;
- MAGIC* mg;
const char* const *e;
static const char* const misc_env[] = {
"IFS", /* most shells' inter-field separators */
STRLEN len = 8; /* strlen(name) */
while (1) {
+ MAGIC* mg;
if (i)
len = my_sprintf(name,"DCL$PATH;%d", i);
svp = hv_fetch(GvHVn(PL_envgv), name, len, FALSE);
svp = hv_fetchs(GvHVn(PL_envgv),"PATH",FALSE);
if (svp && *svp) {
+ MAGIC* mg;
if (SvTAINTED(*svp)) {
TAINT;
taint_proper("Insecure %s%s", "$ENV{PATH}");
Creates and initialises a new lexer/parser state object, supplying
a context in which to lex and parse from a new source of Perl code.
A pointer to the new state object is placed in L</PL_parser>. An entry
-is made on the save stack so that upon unwinding the new state object
+is made on the save stack so that upon unwinding, the new state object
will be destroyed and the former value of L</PL_parser> will be restored.
Nothing else need be done to clean up the parsing context.
{
const char *s = NULL;
yy_parser *parser, *oparser;
+
if (flags && flags & ~LEX_START_FLAGS)
Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
parser->lex_state = LEX_NORMAL;
parser->expect = XSTATE;
parser->rsfp = rsfp;
+ parser->recheck_utf8_validity = FALSE;
parser->rsfp_filters =
!(flags & LEX_START_SAME_FILTER) || !oparser
? NULL
if (line) {
STRLEN len;
+ const U8* first_bad_char_loc;
+
s = SvPV_const(line, len);
+
+ if ( SvUTF8(line)
+ && UNLIKELY(! is_utf8_string_loc((U8 *) s,
+ SvCUR(line),
+ &first_bad_char_loc)))
+ {
+ _force_out_malformed_utf8_message(first_bad_char_loc,
+ (U8 *) s + SvCUR(line),
+ 0,
+ 1 /* 1 means die */ );
+ NOT_REACHED; /* NOTREACHED */
+ }
+
parser->linestr = flags & LEX_START_COPIED
? SvREFCNT_inc_simple_NN(line)
: newSVpvn_flags(s, len, SvUTF8(line));
} else {
parser->linestr = newSVpvn("\n;", rsfp ? 1 : 2);
}
+
parser->oldoldbufptr =
parser->oldbufptr =
parser->bufptr =
} else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, e)) {
p++;
highhalf++;
- } else if (! UTF8_IS_INVARIANT(c)) {
- _force_out_malformed_utf8_message((U8 *) p, (U8 *) e,
- 0,
- 1 /* 1 means die */ );
- NOT_REACHED; /* NOTREACHED */
- }
+ } else assert(UTF8_IS_INVARIANT(c));
}
if (!highhalf)
goto plain_copy;
PL_parser->last_lop -= discard_len;
}
+void
+Perl_notify_parser_that_changed_to_utf8(pTHX)
+{
+ /* Called when $^H is changed to indicate that HINT_UTF8 has changed from
+ * off to on. At compile time, this has the effect of entering a 'use
+ * utf8' section. This means that any input was not previously checked for
+ * UTF-8 (because it was off), but now we do need to check it, or our
+ * assumptions about the input being sane could be wrong, and we could
+ * segfault. This routine just sets a flag so that the next time we look
+ * at the input we do the well-formed UTF-8 check. If we aren't in the
+ * proper phase, there may not be a parser object, but if there is, setting
+ * the flag is harmless */
+
+ if (PL_parser) {
+ PL_parser->recheck_utf8_validity = TRUE;
+ }
+}
+
/*
=for apidoc Amx|bool|lex_next_chunk|U32 flags
STRLEN linestart_pos, last_uni_pos, last_lop_pos;
bool got_some_for_debugger = 0;
bool got_some;
- const U8* first_bad_char_loc;
if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF|LEX_NO_TERM))
Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
PL_parser->bufend = buf + new_bufend_pos;
PL_parser->bufptr = buf + bufptr_pos;
- if (UTF && ! is_utf8_string_loc((U8 *) PL_parser->bufptr,
- PL_parser->bufend - PL_parser->bufptr,
- &first_bad_char_loc))
- {
- _force_out_malformed_utf8_message(first_bad_char_loc,
- (U8 *) PL_parser->bufend,
- 0,
- 1 /* 1 means die */ );
- NOT_REACHED; /* NOTREACHED */
+ if (UTF) {
+ const U8* first_bad_char_loc;
+ if (UNLIKELY(! is_utf8_string_loc(
+ (U8 *) PL_parser->bufptr,
+ PL_parser->bufend - PL_parser->bufptr,
+ &first_bad_char_loc)))
+ {
+ _force_out_malformed_utf8_message(first_bad_char_loc,
+ (U8 *) PL_parser->bufend,
+ 0,
+ 1 /* 1 means die */ );
+ NOT_REACHED; /* NOTREACHED */
+ }
}
PL_parser->oldbufptr = buf + oldbufptr_pos;
STRLEN len;
const char *start = SvPV_const(sv,len);
const char * const end = start + len;
- const bool utf = SvUTF8(sv) ? TRUE : FALSE;
+ const bool utf = cBOOL(SvUTF8(sv));
PERL_ARGS_ASSERT_STR_TO_VERSION;
/*
* S_tokeq
- * Tokenize a quoted string passed in as an SV. It finds the next
- * chunk, up to end of string or a backslash. It may make a new
- * SV containing that chunk (if HINT_NEW_STRING is on). It also
- * turns \\ into \.
+ * Turns any \\ into \ in a quoted string passed in in 'sv', returning 'sv',
+ * modified as necessary. However, if HINT_NEW_STRING is on, 'sv' is
+ * unchanged, and a new SV containing the modified input is returned.
*/
STATIC SV *
SV *cv;
SV *rv;
HV *stash;
- const U8* first_bad_char_loc;
const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
return res;
}
- if (UTF && ! is_utf8_string_loc((U8 *) backslash_ptr,
- e - backslash_ptr,
- &first_bad_char_loc))
- {
- _force_out_malformed_utf8_message(first_bad_char_loc,
- (U8 *) PL_parser->bufend,
- 0,
- 0 /* 0 means don't die */ );
- yyerror_pv(Perl_form(aTHX_
- "Malformed UTF-8 character immediately after '%.*s'",
- (int) (first_bad_char_loc - (U8 *) backslash_ptr), backslash_ptr),
- SVf_UTF8);
- return NULL;
- }
-
res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
/* include the <}> */
e - backslash_ptr + 1);
const U8* first_bad_char_loc;
STRLEN len;
const char* const str = SvPV_const(res, len);
- if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) {
+ if (UNLIKELY(! is_utf8_string_loc((U8 *) str, len,
+ &first_bad_char_loc)))
+ {
_force_out_malformed_utf8_message(first_bad_char_loc,
(U8 *) PL_parser->bufend,
0,
bool didrange = FALSE; /* did we just finish a range? */
bool in_charclass = FALSE; /* within /[...]/ */
bool has_utf8 = FALSE; /* Output constant is UTF8 */
- bool has_above_latin1 = FALSE; /* does something require special
- handling in tr/// ? */
bool this_utf8 = cBOOL(UTF); /* Is the source string assumed to be
UTF8? But, this can show as true
when the source isn't utf8, as for
STRLEN offset_to_max; /* The offset in the output to where the range
high-end character is temporarily placed */
+ /* Does something require special handling in tr/// ? This avoids extra
+ * work in a less likely case. As such, khw didn't feel it was worth
+ * adding any branches to the more mainline code to handle this, which
+ * means that this doesn't get set in some circumstances when things like
+ * \x{100} get expanded out. As a result there needs to be extra testing
+ * done in the tr code */
+ bool has_above_latin1 = FALSE;
+
/* Note on sizing: The scanned constant is placed into sv, which is
* initialized by newSV() assuming one byte of output for every byte of
* input. This routine expects newSV() to allocate an extra byte for a
/* The tests here for being above Latin1 and similar ones
* in the following 'else' suffice to find all such
* occurences in the constant, except those added by a
- * backslash escape sequence, like \x{100}. And all those
+ * backslash escape sequence, like \x{100}. Mostly, those
* set 'has_above_latin1' as appropriate */
if (this_utf8 && UTF8_IS_ABOVE_LATIN1(*s)) {
has_above_latin1 = TRUE;
bool convert_unicode;
IV real_range_max = 0;
#endif
-
/* Get the code point values of the range ends. */
if (has_utf8) {
/* We know the utf8 is valid, because we just constructed
min_ptr = (char*) utf8_hop( (U8*) max_ptr, -1);
range_min = valid_utf8_to_uvchr( (U8*) min_ptr, NULL);
range_max = valid_utf8_to_uvchr( (U8*) max_ptr, NULL);
+
+ /* This compensates for not all code setting
+ * 'has_above_latin1', so that we don't skip stuff that
+ * should be executed */
+ if (range_max > 255) {
+ has_above_latin1 = TRUE;
+ }
}
else {
min_ptr = max_ptr - 1;
* that code point is already in the output, twice. We can
* just back up over the second instance and avoid all the rest
* of the work. But if it is a variant character, it's been
- * counted twice, so decrement */
+ * counted twice, so decrement. (This unlikely scenario is
+ * special cased, like the one for a range of 2 code points
+ * below, only because the main-line code below needs a range
+ * of 3 or more to work without special casing. Might as well
+ * get it out of the way now.) */
if (UNLIKELY(range_max == range_min)) {
d = max_ptr;
if (! has_utf8 && ! UVCHR_IS_INVARIANT(range_max)) {
#endif
/* Always gets run for ASCII, and sometimes for EBCDIC. */
{
- SSize_t i;
-
/* Here, no conversions are necessary, which means that the
* first character in the range is already in 'd' and
* valid, so we can skip overwriting it */
if (has_utf8) {
+ SSize_t i;
d += UTF8SKIP(d);
for (i = range_min + 1; i <= range_max; i++) {
append_utf8_from_native_byte((U8) i, (U8 **) &d);
}
}
else {
+ SSize_t i;
d++;
assert(range_min + 1 <= range_max);
for (i = range_min + 1; i < range_max; i++) {
s++;
if (*s != '{') {
yyerror("Missing braces on \\N{}");
+ *d++ = '\0';
continue;
}
s++;
} else {
yyerror("Missing right brace on \\N{} or unescaped left brace after \\N");
}
- continue;
+ yyquit(); /* Have exhausted the input. */
}
/* Here it looks like a named character */
"Invalid hexadecimal number in \\N{U+...}"
);
s = e + 1;
+ *d++ = '\0';
continue;
}
while (++s < e) {
" in transliteration operator",
/* +1 to include the "}" */
(int) (e + 1 - start), start));
+ *d++ = '\0';
goto end_backslash_N;
}
case 'c':
s++;
if (s < send) {
- *d++ = grok_bslash_c(*s++, 1);
+ *d++ = grok_bslash_c(*s, 1);
}
else {
yyerror("Missing control char name in \\c");
+ yyquit(); /* Are at end of input, no sense continuing */
}
#ifdef EBCDIC
non_portable_endpoint++;
#endif
- continue;
+ break;
/* printf-style backslashes, formfeeds, newlines, etc */
case 'b':
weight -= seen[un_char] * 10;
if (isWORDCHAR_lazy_if_safe(s+1, PL_bufend, UTF)) {
int len;
- char *tmp = PL_bufend;
- PL_bufend = (char*)send;
- scan_ident(s, tmpbuf, sizeof tmpbuf, FALSE);
- PL_bufend = tmp;
+ scan_ident(s, tmpbuf, sizeof tmpbuf, FALSE);
len = (int)strlen(tmpbuf);
if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
UTF ? SVf_UTF8 : 0, SVt_PV))
}
if (*start == '$') {
+ SSize_t start_off = start - SvPVX(PL_linestr);
if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY
|| isUPPER(*PL_tokenbuf))
return 0;
- s = skipspace(s);
- PL_bufptr = start;
+ /* this could be $# */
+ if (isSPACE(*s))
+ s = skipspace(s);
+ PL_bufptr = SvPVX(PL_linestr) + start_off;
PL_expect = XREF;
return *s == '(' ? FUNCMETH : METHOD;
}
GV *gv = NULL;
GV **gvp = NULL;
+ if (UNLIKELY(PL_parser->recheck_utf8_validity)) {
+ const U8* first_bad_char_loc;
+ if (UTF && UNLIKELY(! is_utf8_string_loc((U8 *) PL_bufptr,
+ PL_bufend - PL_bufptr,
+ &first_bad_char_loc)))
+ {
+ _force_out_malformed_utf8_message(first_bad_char_loc,
+ (U8 *) PL_bufend,
+ 0,
+ 1 /* 1 means die */ );
+ NOT_REACHED; /* NOTREACHED */
+ }
+ PL_parser->recheck_utf8_validity = FALSE;
+ }
DEBUG_T( {
SV* tmp = newSVpvs("");
PerlIO_printf(Perl_debug_log, "### %" IVdf ":LEX_%s/X%s %s\n",
s = PL_bufend;
}
else {
+ int save_error_count = PL_error_count;
+
s = scan_const(PL_bufptr);
+
+ /* Set flag if this was a pattern and there were errors. op.c will
+ * refuse to compile a pattern with this flag set. Otherwise, we
+ * could get segfaults, etc. */
+ if (PL_lex_inpat && PL_error_count > save_error_count) {
+ ((PMOP*)PL_lex_inpat)->op_pmflags |= PMf_HAS_ERROR;
+ }
if (*s == '\\')
PL_lex_state = LEX_INTERPCASEMOD;
else
* as a var; e.g. ($, ...) would be seen as the var '$,'
*/
- char sigil;
+ U8 sigil;
s = skipspace(s);
sigil = *s++;
switch (*s) {
default:
if (UTF) {
- if (! isUTF8_CHAR((U8 *) s, (U8 *) PL_bufend)) {
- _force_out_malformed_utf8_message((U8 *) s, (U8 *) PL_bufend,
- 0,
- 1 /* 1 means die */ );
- NOT_REACHED; /* NOTREACHED */
- }
if (isIDFIRST_utf8_safe(s, PL_bufend)) {
goto keylookup;
}
}
do {
fake_eof = 0;
- bof = PL_rsfp ? TRUE : FALSE;
+ bof = cBOOL(PL_rsfp);
if (0) {
fake_eof:
fake_eof = LEX_FAKE_EOF;
}
else if (PL_expect == XPOSTDEREF) POSTDEREF('%');
PL_tokenbuf[0] = '%';
- s = scan_ident(s, PL_tokenbuf + 1,
- sizeof PL_tokenbuf - 1, FALSE);
+ s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
pl_yylval.ival = 0;
if (!PL_tokenbuf[1]) {
PREREF('%');
}
PL_tokenbuf[0] = '&';
- s = scan_ident(s - 1, PL_tokenbuf + 1,
- sizeof PL_tokenbuf - 1, TRUE);
+ s = scan_ident(s - 1, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
if (PL_tokenbuf[1]) {
force_ident_maybe_lex('&');
}
PL_tokenbuf[0] = '$';
- s = scan_ident(s, PL_tokenbuf + 1,
- sizeof PL_tokenbuf - 1, FALSE);
+ s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
if (PL_expect == XOPERATOR) {
d = s;
if (PL_bufptr > s) {
== OA_FILEREF))
{
bool immediate_paren = *s == '(';
+ SSize_t s_off;
/* (Now we can afford to cross potential line boundary.) */
s = skipspace(s);
+ /* intuit_method() can indirectly call lex_next_chunk(),
+ * invalidating s
+ */
+ s_off = s - SvPVX(PL_linestr);
/* Two barewords in a row may indicate method call. */
if ( ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)
|| *s == '$')
&& (tmp = intuit_method(s, lex ? NULL : sv, cv)))
{
+ /* the code at method: doesn't use s */
goto method;
}
+ s = SvPVX(PL_linestr) + s_off;
/* If not a declared subroutine, it's an indirect object. */
/* (But it's an indir obj regardless for sort.) */
s++;
if (*s == ',') {
GV* gv;
- PADOFFSET off;
if (keyword(w, s - w, 0))
return;
if (gv && GvCVu(gv))
return;
if (s - w <= 254) {
+ PADOFFSET off;
char tmpbuf[256];
Copy(w, tmpbuf+1, s - w, char);
*tmpbuf = '&';
const char * non_grapheme_msg = "Use of unassigned code point or"
" non-standalone grapheme for a delimiter"
" will be a fatal error starting in Perl"
- " v5.30";
+ " 5.30";
/* The only non-UTF character that isn't a stand alone grapheme is
* white-space, hence can't be a delimiter. So can skip for non-UTF-8 */
bool check_grapheme = UTF && ckWARN_d(WARN_DEPRECATED);
}
/* terminate when run out of buffer (the for() condition), or
have found the terminator */
- else if (*s == term) {
- if (termlen == 1)
+ else if (*s == term) { /* First byte of terminator matches */
+ if (termlen == 1) /* If is the only byte, are done */
break;
- if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
+
+ /* If the remainder of the terminator matches, also are
+ * done, after checking that is a separate grapheme */
+ if ( s + termlen <= PL_bufend
+ && memEQ(s + 1, (char*)termstr + 1, termlen - 1))
+ {
if ( check_grapheme
&& UNLIKELY(! _is_grapheme((U8 *) start,
(U8 *) s,
"%s", non_grapheme_msg);
}
break;
+ }
}
- else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
+ else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF) {
has_utf8 = TRUE;
+ }
+
*to = *s;
}
}
STATIC char *
S_scan_formline(pTHX_ char *s)
{
- char *eol;
- char *t;
SV * const stuff = newSVpvs("");
bool needargs = FALSE;
bool eofmt = FALSE;
PERL_ARGS_ASSERT_SCAN_FORMLINE;
while (!needargs) {
+ char *eol;
if (*s == '.') {
- t = s+1;
+ char *t = s+1;
#ifdef PERL_STRICT_CR
while (SPACE_OR_TAB(*t))
t++;
if (!eol++)
eol = PL_bufend;
if (*s != '#') {
+ char *t;
for (t = s; t < eol; t++) {
if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
needargs = FALSE;
return 0;
}
+void
+Perl_abort_execution(pTHX_ const char * const msg, const char * const name)
+{
+ PERL_ARGS_ASSERT_ABORT_EXECUTION;
+
+ if (PL_minus_c)
+ Perl_croak(aTHX_ "%s%s had compilation errors.\n", msg, name);
+ else {
+ Perl_croak(aTHX_
+ "%sExecution of %s aborted due to compilation errors.\n", msg, name);
+ }
+ NOT_REACHED; /* NOTREACHED */
+}
+
+void
+Perl_yyquit(pTHX)
+{
+ /* Called, after at least one error has been found, to abort the parse now,
+ * instead of trying to forge ahead */
+
+ yyerror_pvn(NULL, 0, 0);
+}
+
int
Perl_yyerror(pTHX_ const char *const s)
{
SV * const where_sv = newSVpvs_flags("", SVs_TEMP);
int yychar = PL_parser->yychar;
- PERL_ARGS_ASSERT_YYERROR_PVN;
-
- if (!yychar || (yychar == ';' && !PL_rsfp))
- sv_catpvs(where_sv, "at EOF");
- else if ( PL_oldoldbufptr
- && PL_bufptr > PL_oldoldbufptr
- && PL_bufptr - PL_oldoldbufptr < 200
- && PL_oldoldbufptr != PL_oldbufptr
- && PL_oldbufptr != PL_bufptr)
- {
- /*
- Only for NetWare:
- The code below is removed for NetWare because it abends/crashes on NetWare
- when the script has error such as not having the closing quotes like:
- if ($var eq "value)
- Checking of white spaces is anyway done in NetWare code.
- */
+ /* Output error message 's' with length 'len'. 'flags' are SV flags that
+ * apply. If the number of errors found is large enough, it abandons
+ * parsing. If 's' is NULL, there is no message, and it abandons
+ * processing unconditionally */
+
+ if (s != NULL) {
+ if (!yychar || (yychar == ';' && !PL_rsfp))
+ sv_catpvs(where_sv, "at EOF");
+ else if ( PL_oldoldbufptr
+ && PL_bufptr > PL_oldoldbufptr
+ && PL_bufptr - PL_oldoldbufptr < 200
+ && PL_oldoldbufptr != PL_oldbufptr
+ && PL_oldbufptr != PL_bufptr)
+ {
+ /*
+ Only for NetWare:
+ The code below is removed for NetWare because it
+ abends/crashes on NetWare when the script has error such as
+ not having the closing quotes like:
+ if ($var eq "value)
+ Checking of white spaces is anyway done in NetWare code.
+ */
#ifndef NETWARE
- while (isSPACE(*PL_oldoldbufptr))
- PL_oldoldbufptr++;
+ while (isSPACE(*PL_oldoldbufptr))
+ PL_oldoldbufptr++;
#endif
- context = PL_oldoldbufptr;
- contlen = PL_bufptr - PL_oldoldbufptr;
- }
- else if ( PL_oldbufptr
- && PL_bufptr > PL_oldbufptr
- && PL_bufptr - PL_oldbufptr < 200
- && PL_oldbufptr != PL_bufptr) {
- /*
- Only for NetWare:
- The code below is removed for NetWare because it abends/crashes on NetWare
- when the script has error such as not having the closing quotes like:
- if ($var eq "value)
- Checking of white spaces is anyway done in NetWare code.
- */
+ context = PL_oldoldbufptr;
+ contlen = PL_bufptr - PL_oldoldbufptr;
+ }
+ else if ( PL_oldbufptr
+ && PL_bufptr > PL_oldbufptr
+ && PL_bufptr - PL_oldbufptr < 200
+ && PL_oldbufptr != PL_bufptr) {
+ /*
+ Only for NetWare:
+ The code below is removed for NetWare because it
+ abends/crashes on NetWare when the script has error such as
+ not having the closing quotes like:
+ if ($var eq "value)
+ Checking of white spaces is anyway done in NetWare code.
+ */
#ifndef NETWARE
- while (isSPACE(*PL_oldbufptr))
- PL_oldbufptr++;
+ while (isSPACE(*PL_oldbufptr))
+ PL_oldbufptr++;
#endif
- context = PL_oldbufptr;
- contlen = PL_bufptr - PL_oldbufptr;
- }
- else if (yychar > 255)
- sv_catpvs(where_sv, "next token ???");
- else if (yychar == YYEMPTY) {
- if (PL_lex_state == LEX_NORMAL)
- sv_catpvs(where_sv, "at end of line");
- else if (PL_lex_inpat)
- sv_catpvs(where_sv, "within pattern");
- else
- sv_catpvs(where_sv, "within string");
- }
- else {
- sv_catpvs(where_sv, "next char ");
- if (yychar < 32)
- Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
- else if (isPRINT_LC(yychar)) {
- const char string = yychar;
- sv_catpvn(where_sv, &string, 1);
- }
- else
- Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
- }
- msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP);
- Perl_sv_catpvf(aTHX_ msg, " at %s line %" IVdf ", ",
- OutCopFILE(PL_curcop),
- (IV)(PL_parser->preambling == NOLINE
- ? CopLINE(PL_curcop)
- : PL_parser->preambling));
- if (context)
- Perl_sv_catpvf(aTHX_ msg, "near \"%" UTF8f "\"\n",
- UTF8fARG(UTF, contlen, context));
- else
- Perl_sv_catpvf(aTHX_ msg, "%" SVf "\n", SVfARG(where_sv));
- if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
- Perl_sv_catpvf(aTHX_ msg,
- " (Might be a runaway multi-line %c%c string starting on line %" IVdf ")\n",
- (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
- PL_multi_end = 0;
- }
- if (PL_in_eval & EVAL_WARNONLY) {
- PL_in_eval &= ~EVAL_WARNONLY;
- Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%" SVf, SVfARG(msg));
+ context = PL_oldbufptr;
+ contlen = PL_bufptr - PL_oldbufptr;
+ }
+ else if (yychar > 255)
+ sv_catpvs(where_sv, "next token ???");
+ else if (yychar == YYEMPTY) {
+ if (PL_lex_state == LEX_NORMAL)
+ sv_catpvs(where_sv, "at end of line");
+ else if (PL_lex_inpat)
+ sv_catpvs(where_sv, "within pattern");
+ else
+ sv_catpvs(where_sv, "within string");
+ }
+ else {
+ sv_catpvs(where_sv, "next char ");
+ if (yychar < 32)
+ Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
+ else if (isPRINT_LC(yychar)) {
+ const char string = yychar;
+ sv_catpvn(where_sv, &string, 1);
+ }
+ else
+ Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
+ }
+ msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP);
+ Perl_sv_catpvf(aTHX_ msg, " at %s line %" IVdf ", ",
+ OutCopFILE(PL_curcop),
+ (IV)(PL_parser->preambling == NOLINE
+ ? CopLINE(PL_curcop)
+ : PL_parser->preambling));
+ if (context)
+ Perl_sv_catpvf(aTHX_ msg, "near \"%" UTF8f "\"\n",
+ UTF8fARG(UTF, contlen, context));
+ else
+ Perl_sv_catpvf(aTHX_ msg, "%" SVf "\n", SVfARG(where_sv));
+ if ( PL_multi_start < PL_multi_end
+ && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1)
+ {
+ Perl_sv_catpvf(aTHX_ msg,
+ " (Might be a runaway multi-line %c%c string starting on"
+ " line %" IVdf ")\n",
+ (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
+ PL_multi_end = 0;
+ }
+ if (PL_in_eval & EVAL_WARNONLY) {
+ PL_in_eval &= ~EVAL_WARNONLY;
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%" SVf, SVfARG(msg));
+ }
+ else {
+ qerror(msg);
+ }
}
- else
- qerror(msg);
- if (PL_error_count >= 10) {
- SV * errsv;
- if (PL_in_eval && ((errsv = ERRSV), SvCUR(errsv)))
- Perl_croak(aTHX_ "%" SVf "%s has too many errors.\n",
- SVfARG(errsv), OutCopFILE(PL_curcop));
- else
- Perl_croak(aTHX_ "%s has too many errors.\n",
- OutCopFILE(PL_curcop));
+ if (s == NULL || PL_error_count >= 10) {
+ const char * msg = "";
+ const char * const name = OutCopFILE(PL_curcop);
+
+ if (PL_in_eval) {
+ SV * errsv = ERRSV;
+ if (SvCUR(errsv)) {
+ msg = Perl_form(aTHX_ "%" SVf, SVfARG(errsv));
+ }
+ }
+
+ if (s == NULL) {
+ abort_execution(msg, name);
+ }
+ else {
+ Perl_croak(aTHX_ "%s%s has too many errors.\n", msg, name);
+ }
}
PL_in_my = 0;
PL_in_my_stash = NULL;
return UTF8SKIP(s);
}
-STATIC char *
-S__byte_dump_string(pTHX_ const U8 * s, const STRLEN len)
+char *
+Perl__byte_dump_string(pTHX_ const U8 * s, const STRLEN len, const bool format)
{
/* Returns a mortalized C string that is a displayable copy of the 'len'
- * bytes starting at 's', each in a \xXY format. */
+ * bytes starting at 's'. 'format' gives how to display each byte.
+ * Currently, there are only two formats, so it is currently a bool:
+ * 0 \xab
+ * 1 ab (that is a space between two hex digit bytes)
+ */
const STRLEN output_len = 4 * len + 1; /* 4 bytes per each input, plus a
trailing NUL */
const unsigned high_nibble = (*s & 0xF0) >> 4;
const unsigned low_nibble = (*s & 0x0F);
- *d++ = '\\';
- *d++ = 'x';
+ if (format) {
+ *d++ = ' ';
+ }
+ else {
+ *d++ = '\\';
+ *d++ = 'x';
+ }
if (high_nibble < 10) {
*d++ = high_nibble + '0';
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),
+ _byte_dump_string(s, print_len, 0),
*(s + non_cont_byte_pos),
where,
*s,
/* Save how many bytes were actually in the character */
curlen = s - s0;
- /* 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_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
* 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. */
+ * separate.
+ *
+ * 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_so_far = uv;
+ uv = UNICODE_REPLACEMENT;
+ }
/* Check for overflow */
if (UNLIKELY(does_utf8_overflow(s0, send))) {
if (pack_warn) {
message = Perl_form(aTHX_ "%s: %s (overflows)",
malformed_text,
- _byte_dump_string(s0, send - s0));
+ _byte_dump_string(s0, send - s0, 0));
}
}
}
"%s: %s (unexpected continuation byte 0x%02x,"
" with no preceding start byte)",
malformed_text,
- _byte_dump_string(s0, 1), *s0);
+ _byte_dump_string(s0, 1, 0), *s0);
}
}
}
message = Perl_form(aTHX_
"%s: %s (too short; %d byte%s available, need %d)",
malformed_text,
- _byte_dump_string(s0, send - s0),
+ _byte_dump_string(s0, send - s0, 0),
(int)avail_len,
avail_len == 1 ? "" : "s",
(int)expectlen);
" should be represented with a"
" different, shorter sequence)",
malformed_text,
- _byte_dump_string(s0, send - s0),
- _byte_dump_string(s0, curlen));
+ _byte_dump_string(s0, send - s0, 0),
+ _byte_dump_string(s0, curlen, 0));
}
else {
U8 tmpbuf[UTF8_MAXBYTES+1];
"%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),
+ _byte_dump_string(s0, send - s0, 0),
+ _byte_dump_string(tmpbuf, e - tmpbuf, 0),
((uv < 256) ? 2 : 4), /* Field width of 2 for
small code points */
uv);
message = Perl_form(aTHX_
"UTF-16 surrogate (any UTF-8 sequence that"
" starts with \"%s\" is for a surrogate)",
- _byte_dump_string(s0, curlen));
+ _byte_dump_string(s0, curlen, 0));
}
else {
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));
+ _byte_dump_string(s0, curlen, 0));
}
else {
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));
+ _byte_dump_string(s0, curlen, 0));
}
else {
message = Perl_form(aTHX_
UV
Perl_utf8_to_uvchr_buf(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
{
+ PERL_ARGS_ASSERT_UTF8_TO_UVCHR_BUF;
+
assert(s < send);
return utf8n_to_uvchr(s, send - s, retlen,
while ((from_list = (AV *) hv_iternextsv(specials_inverse,
&char_to, &to_len)))
{
- if (av_tindex_nomg(from_list) > 0) {
+ if (av_tindex_skip_len_mg(from_list) > 0) {
SSize_t i;
/* We iterate over all combinations of i,j to place each code
* point on each list */
- for (i = 0; i <= av_tindex_nomg(from_list); i++) {
+ for (i = 0; i <= av_tindex_skip_len_mg(from_list); i++) {
SSize_t j;
AV* i_list = newAV();
SV** entryp = av_fetch(from_list, i, FALSE);
}
/* For DEBUG_U: UV u = valid_utf8_to_uvchr((U8*) SvPVX(*entryp), 0);*/
- for (j = 0; j <= av_tindex_nomg(from_list); j++) {
+ for (j = 0; j <= av_tindex_skip_len_mg(from_list); j++) {
entryp = av_fetch(from_list, j, FALSE);
if (entryp == NULL) {
Perl_croak(aTHX_ "panic: av_fetch() unexpectedly failed");
/* Look through list to see if this inverse mapping already is
* listed, or if there is a mapping to itself already */
- for (i = 0; i <= av_tindex_nomg(list); i++) {
+ for (i = 0; i <= av_tindex_skip_len_mg(list); i++) {
SV** entryp = av_fetch(list, i, FALSE);
SV* entry;
UV uv;
/* A Unicode character can fold to up to 3 characters */
#define UTF8_MAX_FOLD_CHAR_EXPAND 3
-#define IN_BYTES (CopHINTS_get(PL_curcop) & HINT_BYTES)
+#define IN_BYTES UNLIKELY(CopHINTS_get(PL_curcop) & HINT_BYTES)
/*
* Is so within 'feature unicode_strings' or 'locale :not_characters', and not
* within 'use bytes'. UTF-8 locales are not tested for here, but perhaps
* could be */
-#define IN_UNI_8_BIT \
- (((CopHINTS_get(PL_curcop) & (HINT_UNI_8_BIT)) \
- || (CopHINTS_get(PL_curcop) & HINT_LOCALE_PARTIAL \
- /* -1 below is for :not_characters */ \
- && _is_in_locale_category(FALSE, -1))) \
- && ! IN_BYTES)
+#define IN_UNI_8_BIT \
+ (( ( (CopHINTS_get(PL_curcop) & HINT_UNI_8_BIT)) \
+ || ( CopHINTS_get(PL_curcop) & HINT_LOCALE_PARTIAL \
+ /* -1 below is for :not_characters */ \
+ && _is_in_locale_category(FALSE, -1))) \
+ && (! IN_BYTES))
#define UTF8_ALLOW_EMPTY 0x0001 /* Allow a zero length string */
#define UTF8_WARN_ILLEGAL_INTERCHANGE \
(UTF8_WARN_ILLEGAL_C9_INTERCHANGE|UTF8_WARN_NONCHAR)
-/* This is used typically for code that is willing to accept inputs of
- * illformed UTF-8 sequences, for whatever reason. However, all such sequences
- * evaluate to the REPLACEMENT CHARACTER unless other flags overriding this are
- * also present. */
+/* This is typically used for code that processes UTF-8 input and doesn't want
+ * to have to deal with any malformations that might be present. All such will
+ * be safely replaced by the REPLACEMENT CHARACTER, unless other flags
+ * overriding this are also present. */
#define UTF8_ALLOW_ANY ( UTF8_ALLOW_CONTINUATION \
|UTF8_ALLOW_NON_CONTINUATION \
|UTF8_ALLOW_SHORT \
return (char*)big;
{
const char first = *little;
- const char *s, *x;
bigend -= lend - little++;
OUTER:
while (big <= bigend) {
if (*big++ == first) {
+ const char *s, *x;
for (x=big,s=little; s < lend; x++,s++) {
if (*s != *x)
goto OUTER;
char * const b = ninstr((char*)big,(char*)bigend,
(char*)little, (char*)little + littlelen);
- if (!b && tail) { /* Automatically multiline! */
- /* Chop \n from littlestr: */
- s = bigend - littlelen + 1;
- if (*s == *little
- && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
- {
- return (char*)s;
- }
- return NULL;
- }
+ assert(!tail); /* valid => FBM; tail only set on SvVALID SVs */
return b;
}
}
}
-
-/*
-=for apidoc foldEQ
-
-Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
-same
-case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
-match themselves and their opposite case counterparts. Non-cased and non-ASCII
-range bytes match only themselves.
-
-=cut
-*/
-
-
-I32
-Perl_foldEQ(const char *s1, const char *s2, I32 len)
-{
- const U8 *a = (const U8 *)s1;
- const U8 *b = (const U8 *)s2;
-
- PERL_ARGS_ASSERT_FOLDEQ;
-
- assert(len >= 0);
-
- while (len--) {
- if (*a != *b && *a != PL_fold[*b])
- return 0;
- a++,b++;
- }
- return 1;
-}
-I32
-Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
-{
- /* Compare non-utf8 using Unicode (Latin1) semantics. Does not work on
- * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
- * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these. Nor
- * does it check that the strings each have at least 'len' characters */
-
- const U8 *a = (const U8 *)s1;
- const U8 *b = (const U8 *)s2;
-
- PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
-
- assert(len >= 0);
-
- while (len--) {
- if (*a != *b && *a != PL_fold_latin1[*b]) {
- return 0;
- }
- a++, b++;
- }
- return 1;
-}
-
-/*
-=for apidoc foldEQ_locale
-
-Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
-same case-insensitively in the current locale; false otherwise.
-
-=cut
-*/
-
-I32
-Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
-{
- dVAR;
- const U8 *a = (const U8 *)s1;
- const U8 *b = (const U8 *)s2;
-
- PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
-
- assert(len >= 0);
-
- while (len--) {
- if (*a != *b && *a != PL_fold_locale[*b])
- return 0;
- a++,b++;
- }
- return 1;
-}
-
/* copy a string to a safe spot */
/*
* from the sibling of PL_curcop.
*/
- const COP *cop =
- closest_cop(PL_curcop, OpSIBLING(PL_curcop), PL_op, FALSE);
- if (!cop)
- cop = PL_curcop;
+ if (PL_curcop) {
+ const COP *cop =
+ closest_cop(PL_curcop, OpSIBLING(PL_curcop), PL_op, FALSE);
+ if (!cop)
+ cop = PL_curcop;
+
+ if (CopLINE(cop))
+ Perl_sv_catpvf(aTHX_ sv, " at %s line %" IVdf,
+ OutCopFILE(cop), (IV)CopLINE(cop));
+ }
- if (CopLINE(cop))
- Perl_sv_catpvf(aTHX_ sv, " at %s line %" IVdf,
- OutCopFILE(cop), (IV)CopLINE(cop));
/* Seems that GvIO() can be untrustworthy during global destruction. */
if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
&& IoLINES(GvIOp(PL_last_in_gv)))
if (did_pipes && pid > 0) {
int errkid;
unsigned n = 0;
- SSize_t n1;
while (n < sizeof(int)) {
- n1 = PerlLIO_read(pp[0],
+ const SSize_t n1 = PerlLIO_read(pp[0],
(void*)(((char*)&errkid)+n),
(sizeof(int)) - n);
if (n1 <= 0)
if (did_pipes && pid > 0) {
int errkid;
unsigned n = 0;
- SSize_t n1;
while (n < sizeof(int)) {
- n1 = PerlLIO_read(pp[0],
+ const SSize_t n1 = PerlLIO_read(pp[0],
(void*)(((char*)&errkid)+n),
(sizeof(int)) - n);
if (n1 <= 0)
if (qfmt) {
/* If the format looked promising, use it as quadmath. */
retval = quadmath_snprintf(buffer, len, qfmt, va_arg(ap, NV));
- if (retval == -1)
+ if (retval == -1) {
+ if (qfmt != format) {
+ dTHX;
+ SAVEFREEPV(qfmt);
+ }
Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
+ }
quadmath_valid = TRUE;
if (qfmt != format)
Safefree(qfmt);
extra.pods : miniperl
@ @extra_pods.com
-PERLDELTA_CURRENT = [.pod]perl5259delta.pod
+PERLDELTA_CURRENT = [.pod]perl52510delta.pod
$(PERLDELTA_CURRENT) : [.pod]perldelta.pod
Copy/NoConfirm/Log $(MMS$SOURCE) $(PERLDELTA_CURRENT)
#define unpackWARN4(x) (((x) >>24) & 0xFF)
#define ckDEAD(x) \
- ( ! specialWARN(PL_curcop->cop_warnings) && \
+ (PL_curcop && \
+ !specialWARN(PL_curcop->cop_warnings) && \
( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \
isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) || \
isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) || \
# versioned installation can be obtained by setting INST_TOP above to a
# path that includes an arbitrary version string.
#
-#INST_VER := \5.25.9
+#INST_VER := \5.25.10
#
# Comment this out if you DON'T want your perl installation to have
#CCTYPE := MSVC120
# Visual C++ 2013 Express Edition (aka Visual C++ 12.0) (free version)
#CCTYPE := MSVC120FREE
+# Visual C++ 2015 (aka Visual C++ 14.0) (full version)
+#CCTYPE := MSVC140
+# Visual C++ 2015 Express Edition (aka Visual C++ 14.0) (free version)
+#CCTYPE := MSVC140FREE
# MinGW or mingw-w64 with gcc-3.4.5 or later
#CCTYPE := GCC
LOCDEFS = -DPERLDLL -DPERL_CORE
CXX_FLAG = -TP -EHsc
+ifeq ($(CCTYPE),MSVC140)
+LIBC = ucrt.lib
+else ifeq ($(CCTYPE),MSVC140FREE)
+LIBC = ucrt.lib
+else
LIBC = msvcrt.lib
+endif
ifeq ($(CFG),Debug)
OPTIMIZE = -Od -MD -Zi -DDEBUGGING
OPTIMIZE = -Od -MD -Zi
LINK_DBG = -debug
else ifeq ($(CFG),DebugFull)
+ifeq ($(CCTYPE),MSVC140)
+LIBC = ucrtd.lib
+else ifeq ($(CCTYPE),MSVC140FREE)
+LIBC = ucrtd.lib
+else
LIBC = msvcrtd.lib
+endif
OPTIMIZE = -Od -MDd -Zi -D_DEBUG -DDEBUGGING
LINK_DBG = -debug
else
DEFINES += -D_CRT_SECURE_NO_DEPRECATE -D_CRT_NONSTDC_NO_DEPRECATE
endif
+# Likewise for deprecated Winsock APIs in VC++ 14.0 for now.
+ifeq ($(CCTYPE),MSVC140)
+DEFINES = $(DEFINES) -D_WINSOCK_DEPRECATED_NO_WARNINGS
+else ifeq ($(CCTYPE),MSVC140FREE)
+DEFINES = $(DEFINES) -D_WINSOCK_DEPRECATED_NO_WARNINGS
+endif
+
# In VS 2005 (VC++ 8.0) Microsoft changes time_t from 32-bit to
# 64-bit, even in 32-bit mode. It also provides the _USE_32BIT_TIME_T
# preprocessor option to revert back to the old functionality for
netapi32.lib uuid.lib ws2_32.lib mpr.lib winmm.lib version.lib \
odbc32.lib odbccp32.lib comctl32.lib
+ifeq ($(CCTYPE),MSVC140)
+ifeq ($(CFG),DebugFull)
+LIBBASEFILES += msvcrtd.lib vcruntimed.lib
+else
+LIBBASEFILES += msvcrt.lib vcruntime.lib
+endif
+else ifeq ($(CCTYPE),MSVC140FREE)
+ifeq ($(CFG),DebugFull)
+LIBBASEFILES += msvcrtd.lib vcruntimed.lib
+else
+LIBBASEFILES += msvcrt.lib vcruntime.lib
+endif
+endif
+
# Avoid __intel_new_proc_init link error for libircmt.
# libmmd is /MD equivelent, other variants exist.
# libmmd is Intel C's math addon funcs to MS CRT, contains long doubles, C99,
echo #undef NVff&& \
echo #undef NVgf&& \
echo #undef USE_LONG_DOUBLE)>> config.h
+ifeq ($(CCTYPE),MSVC140)
+ @(echo #undef FILE_ptr&& \
+ echo #undef FILE_cnt&& \
+ echo #undef FILE_base&& \
+ echo #undef FILE_bufsiz&& \
+ echo #define FILE_ptr(fp) PERLIO_FILE_ptr(fp)&& \
+ echo #define FILE_cnt(fp) PERLIO_FILE_cnt(fp)&& \
+ echo #define FILE_base(fp) PERLIO_FILE_base(fp)&& \
+ echo #define FILE_bufsiz(fp) (PERLIO_FILE_cnt(fp) + PERLIO_FILE_ptr(fp) - PERLIO_FILE_base(fp))&& \
+ echo #define I_STDBOOL)>> config.h
+else ifeq ($(CCTYPE),MSVC140FREE)
+ @(echo #undef FILE_ptr&& \
+ echo #undef FILE_cnt&& \
+ echo #undef FILE_base&& \
+ echo #undef FILE_bufsiz&& \
+ echo #define FILE_ptr(fp) PERLIO_FILE_ptr(fp)&& \
+ echo #define FILE_cnt(fp) PERLIO_FILE_cnt(fp)&& \
+ echo #define FILE_base(fp) PERLIO_FILE_base(fp)&& \
+ echo #define FILE_bufsiz(fp) (PERLIO_FILE_cnt(fp) + PERLIO_FILE_ptr(fp) - PERLIO_FILE_base(fp))&& \
+ echo #define I_STDBOOL)>> config.h
+endif
ifeq ($(USE_LARGE_FILES),define)
@(echo #define Off_t $(INT64)&& \
echo #define LSEEKSIZE ^8&& \
copy ..\README.tw ..\pod\perltw.pod
copy ..\README.vos ..\pod\perlvos.pod
copy ..\README.win32 ..\pod\perlwin32.pod
- copy ..\pod\perldelta.pod ..\pod\perl5259delta.pod
+ copy ..\pod\perldelta.pod ..\pod\perl52510delta.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 \
- perl5259delta.pod perlaix.pod perlamiga.pod perlandroid.pod \
+ perl52510delta.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.9
+#INST_VER = \5.25.10
#
# Comment this out if you DON'T want your perl installation to have
#CCTYPE = MSVC120
# Visual C++ 2013 Express Edition (aka Visual C++ 12.0) (free version)
#CCTYPE = MSVC120FREE
+# Visual C++ 2015 (aka Visual C++ 14.0) (full version)
+#CCTYPE = MSVC140
+# Visual C++ 2015 Express Edition (aka Visual C++ 14.0) (free version)
+#CCTYPE = MSVC140FREE
#
# If you are using Intel C++ Compiler uncomment this
LOCDEFS = -DPERLDLL -DPERL_CORE
CXX_FLAG = -TP -EHsc
+!IF "$(CCTYPE)" == "MSVC140" || "$(CCTYPE)" == "MSVC140FREE"
+LIBC = ucrt.lib
+!ELSE
LIBC = msvcrt.lib
+!ENDIF
!IF "$(CFG)" == "Debug"
OPTIMIZE = -Od -MD -Zi -DDEBUGGING
LINK_DBG = -debug
!ELSE
!IF "$(CFG)" == "DebugFull"
+!IF "$(CCTYPE)" == "MSVC140" || "$(CCTYPE)" == "MSVC140FREE"
+LIBC = ucrtd.lib
+!ELSE
LIBC = msvcrtd.lib
+!ENDIF
OPTIMIZE = -Od -MDd -Zi -D_DEBUG -DDEBUGGING
LINK_DBG = -debug
!ELSE
DEFINES = $(DEFINES) -D_CRT_SECURE_NO_DEPRECATE -D_CRT_NONSTDC_NO_DEPRECATE
!ENDIF
+# Likewise for deprecated Winsock APIs in VC++ 14.0 for now.
+!IF "$(CCTYPE)" == "MSVC140" || "$(CCTYPE)" == "MSVC140FREE"
+DEFINES = $(DEFINES) -D_WINSOCK_DEPRECATED_NO_WARNINGS
+!ENDIF
+
# In VS 2005 (VC++ 8.0) Microsoft changes time_t from 32-bit to
# 64-bit, even in 32-bit mode. It also provides the _USE_32BIT_TIME_T
# preprocessor option to revert back to the old functionality for
netapi32.lib uuid.lib ws2_32.lib mpr.lib winmm.lib \
version.lib odbc32.lib odbccp32.lib comctl32.lib
+!IF "$(CCTYPE)" == "MSVC140" || "$(CCTYPE)" == "MSVC140FREE"
+! IF "$(CFG)" == "DebugFull"
+LIBBASEFILES = $(LIBBASEFILES) msvcrtd.lib vcruntimed.lib
+! ELSE
+LIBBASEFILES = $(LIBBASEFILES) msvcrt.lib vcruntime.lib
+! ENDIF
+!ENDIF
+
# Avoid __intel_new_proc_init link error for libircmt.
# libmmd is /MD equivelent, other variants exist.
# libmmd is Intel C's math addon funcs to MS CRT, contains long doubles, C99,
@echo.>>$@
@echo #ifndef _config_h_footer_>>$@
@echo #define _config_h_footer_>>$@
+!IF "$(CCTYPE)" == "MSVC140" || "$(CCTYPE)" == "MSVC140FREE"
+ @echo #undef FILE_ptr>>$@
+ @echo #define FILE_ptr(fp) PERLIO_FILE_ptr(fp)>>$@
+ @echo #undef FILE_cnt>>$@
+ @echo #define FILE_cnt(fp) PERLIO_FILE_cnt(fp)>>$@
+ @echo #undef FILE_base>>$@
+ @echo #define FILE_base(fp) PERLIO_FILE_base(fp)>>$@
+ @echo #undef FILE_bufsiz>>$@
+ @echo #define FILE_bufsiz(fp) (PERLIO_FILE_cnt(fp) + PERLIO_FILE_ptr(fp) - PERLIO_FILE_base(fp))>>$@
+ @echo #define I_STDBOOL>>$@
+!ENDIF
@echo #undef Off_t>>$@
@echo #undef LSEEKSIZE>>$@
@echo #undef Off_t_size>>$@
copy ..\README.tw ..\pod\perltw.pod
copy ..\README.vos ..\pod\perlvos.pod
copy ..\README.win32 ..\pod\perlwin32.pod
- copy ..\pod\perldelta.pod ..\pod\perl5259delta.pod
+ copy ..\pod\perldelta.pod ..\pod\perl52510delta.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 \
- perl5259delta.pod perlaix.pod perlamiga.pod perlandroid.pod \
+ perl52510delta.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 \
if($ccversion < 13) { #VC6
$opt{ar} ='lib';
}
+ if ($ccversion >= 19) { # VC14
+ $opt{stdio_base} = 'PERLIO_FILE_base(fp)';
+ $opt{stdio_bufsiz} = '(PERLIO_FILE_cnt(fp) + PERLIO_FILE_ptr(fp) - PERLIO_FILE_base(fp))';
+ $opt{stdio_cnt} = 'PERLIO_FILE_cnt(fp)';
+ $opt{stdio_ptr} = 'PERLIO_FILE_ptr(fp)';
+ $opt{i_stdbool} = 'define';
+ }
}
#find out which MSVC this ICC is using
elsif ($opt{cc} =~ /\bicl/) {
$opt{sGMTIME_max} = 32535291599;
$opt{sLOCALTIME_max} = 32535244799;
}
+ if ($num_ver =~ /^(\d+)/ && $1 >= 19) { # VC14
+ $opt{stdio_base} = 'PERLIO_FILE_base(fp)';
+ $opt{stdio_bufsiz} = '(PERLIO_FILE_cnt(fp) + PERLIO_FILE_ptr(fp) - PERLIO_FILE_base(fp))';
+ $opt{stdio_cnt} = 'PERLIO_FILE_cnt(fp)';
+ $opt{stdio_ptr} = 'PERLIO_FILE_ptr(fp)';
+ $opt{i_stdbool} = 'define';
+ }
$opt{ar} ='xilib';
}
# versioned installation can be obtained by setting INST_TOP above to a
# path that includes an arbitrary version string.
#
-#INST_VER *= \5.25.9
+#INST_VER *= \5.25.10
#
# Comment this out if you DON'T want your perl installation to have
#CCTYPE = MSVC120
# Visual C++ 2013 Express Edition (aka Visual C++ 12.0) (free version)
#CCTYPE = MSVC120FREE
+# Visual C++ 2015 (aka Visual C++ 14.0) (full version)
+#CCTYPE = MSVC140
+# Visual C++ 2015 Express Edition (aka Visual C++ 14.0) (free version)
+#CCTYPE = MSVC140FREE
# MinGW or mingw-w64 with gcc-3.4.5 or later
#CCTYPE = GCC
LOCDEFS = -DPERLDLL -DPERL_CORE
CXX_FLAG = -TP -EHsc
+.IF "$(CCTYPE)" == "MSVC140" || "$(CCTYPE)" == "MSVC140FREE"
+LIBC = ucrt.lib
+.ELSE
LIBC = msvcrt.lib
+.ENDIF
.IF "$(CFG)" == "Debug"
OPTIMIZE = -Od -MD -Zi -DDEBUGGING
OPTIMIZE = -Od -MD -Zi
LINK_DBG = -debug
.ELIF "$(CFG)" == "DebugFull"
+.IF "$(CCTYPE)" == "MSVC140" || "$(CCTYPE)" == "MSVC140FREE"
+LIBC = ucrtd.lib
+.ELSE
LIBC = msvcrtd.lib
+.ENDIF
OPTIMIZE = -Od -MDd -Zi -D_DEBUG -DDEBUGGING
LINK_DBG = -debug
.ELSE
DEFINES += -D_CRT_SECURE_NO_DEPRECATE -D_CRT_NONSTDC_NO_DEPRECATE
.ENDIF
+# Likewise for deprecated Winsock APIs in VC++ 14.0 for now.
+.IF "$(CCTYPE)" == "MSVC140" || "$(CCTYPE)" == "MSVC140FREE"
+DEFINES = $(DEFINES) -D_WINSOCK_DEPRECATED_NO_WARNINGS
+.ENDIF
+
# In VS 2005 (VC++ 8.0) Microsoft changes time_t from 32-bit to
# 64-bit, even in 32-bit mode. It also provides the _USE_32BIT_TIME_T
# preprocessor option to revert back to the old functionality for
netapi32.lib uuid.lib ws2_32.lib mpr.lib winmm.lib version.lib \
odbc32.lib odbccp32.lib comctl32.lib
+.IF "$(CCTYPE)" == "MSVC140" || "$(CCTYPE)" == "MSVC140FREE"
+.IF "$(CFG)" == "DebugFull"
+LIBBASEFILES += msvcrtd.lib vcruntimed.lib
+.ELSE
+LIBBASEFILES += msvcrt.lib vcruntime.lib
+.ENDIF
+.ENDIF
+
# Avoid __intel_new_proc_init link error for libircmt.
# libmmd is /MD equivelent, other variants exist.
# libmmd is Intel C's math addon funcs to MS CRT, contains long doubles, C99,
echo #undef NVgf&& \
echo #undef USE_LONG_DOUBLE&& \
echo #undef USE_CPLUSPLUS)>> config.h
+.IF "$(CCTYPE)" == "MSVC140" || "$(CCTYPE)" == "MSVC140FREE"
+ @(echo #undef FILE_ptr&& \
+ echo #undef FILE_cnt&& \
+ echo #undef FILE_base&& \
+ echo #undef FILE_bufsiz&& \
+ echo #define FILE_ptr(fp) PERLIO_FILE_ptr(fp)&& \
+ echo #define FILE_cnt(fp) PERLIO_FILE_cnt(fp)&& \
+ echo #define FILE_base(fp) PERLIO_FILE_base(fp)&& \
+ echo #define FILE_bufsiz(fp) (PERLIO_FILE_cnt(fp) + PERLIO_FILE_ptr(fp) - PERLIO_FILE_base(fp))&& \
+ echo #define I_STDBOOL)>> config.h
+.ENDIF
.IF "$(USE_LARGE_FILES)"=="define"
@(echo #define Off_t $(INT64)&& \
echo #define LSEEKSIZE ^8&& \
copy ..\README.tw ..\pod\perltw.pod
copy ..\README.vos ..\pod\perlvos.pod
copy ..\README.win32 ..\pod\perlwin32.pod
- copy ..\pod\perldelta.pod ..\pod\perl5259delta.pod
+ copy ..\pod\perldelta.pod ..\pod\perl52510delta.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 \
- perl5259delta.pod perlaix.pod perlamiga.pod perlandroid.pod \
+ perl52510delta.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 \
int fileno = win32_dup(win32_fileno(pf));
/* open the file in the same mode */
- if((pf)->_flag & _IOREAD) {
+ if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_RD) {
mode[0] = 'r';
mode[1] = 0;
}
- else if((pf)->_flag & _IOWRT) {
+ else if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_WR) {
mode[0] = 'a';
mode[1] = 0;
}
- else if((pf)->_flag & _IORW) {
+ else if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_RW) {
mode[0] = 'r';
mode[1] = '+';
mode[2] = 0;
perl5240delta.pod \
perl5241delta.pod \
perl5250delta.pod \
+ perl52510delta.pod \
perl5251delta.pod \
perl5252delta.pod \
perl5253delta.pod \
perl5240delta.man \
perl5241delta.man \
perl5250delta.man \
+ perl52510delta.man \
perl5251delta.man \
perl5252delta.man \
perl5253delta.man \
perl5240delta.html \
perl5241delta.html \
perl5250delta.html \
+ perl52510delta.html \
perl5251delta.html \
perl5252delta.html \
perl5253delta.html \
perl5240delta.tex \
perl5241delta.tex \
perl5250delta.tex \
+ perl52510delta.tex \
perl5251delta.tex \
perl5252delta.tex \
perl5253delta.tex \
int fileno = win32_dup(win32_fileno(pf));
/* open the file in the same mode */
- if((pf)->_flag & _IOREAD) {
+ if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_RD) {
mode[0] = 'r';
mode[1] = 0;
}
- else if((pf)->_flag & _IOWRT) {
+ else if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_WR) {
mode[0] = 'a';
mode[1] = 0;
}
- else if((pf)->_flag & _IORW) {
+ else if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_RW) {
mode[0] = 'r';
mode[1] = '+';
mode[2] = 0;
#define snprintf _snprintf
#define vsnprintf _vsnprintf
-/* on VC2003, msvcrt.lib is missing these symbols */
+/* on VS2003, msvcrt.lib is missing these symbols */
#if _MSC_VER >= 1300 && _MSC_VER < 1400
# pragma intrinsic(_rotl64,_rotr64)
#endif
-# pragma warning(push)
-# pragma warning(disable:4756;disable:4056)
+#pragma warning(push)
+#pragma warning(disable:4756;disable:4056)
PERL_STATIC_INLINE
double S_Infinity() {
/* this is a real C literal which can get further constant folded
folding INF is creating -INF */
return (DBL_MAX+DBL_MAX);
}
-# pragma warning(pop)
-# define NV_INF S_Infinity()
+#pragma warning(pop)
+#define NV_INF S_Infinity()
/* selectany allows duplicate and unused data symbols to be removed by
VC linker, if this were static, each translation unit will have its own,
that DLL actually uses __PL_nan_u */
extern const __declspec(selectany) union { unsigned __int64 __q; double __d; }
__PL_nan_u = { 0x7FF8000000000000UI64 };
-# define NV_NAN ((NV)__PL_nan_u.__d)
+#define NV_NAN ((NV)__PL_nan_u.__d)
+
+/* The CRT was rewritten in VS2015. */
+#if _MSC_VER >= 1900
+
+/* No longer declared in stdio.h */
+char *gets(char* buffer);
+
+#define tzname _tzname
+
+/* From corecrt_internal_stdio.h: */
+typedef struct
+{
+ union
+ {
+ FILE _public_file;
+ char* _ptr;
+ };
+
+ char* _base;
+ int _cnt;
+ long _flags;
+ long _file;
+ int _charbuf;
+ int _bufsiz;
+ char* _tmpfname;
+ CRITICAL_SECTION _lock;
+} __crt_stdio_stream_data;
+
+#define PERLIO_FILE_flag_RD 0x0001 /* _IOREAD */
+#define PERLIO_FILE_flag_WR 0x0002 /* _IOWRITE */
+#define PERLIO_FILE_flag_RW 0x0004 /* _IOUPDATE */
+#define PERLIO_FILE_ptr(f) (((__crt_stdio_stream_data*)(f))->_ptr)
+#define PERLIO_FILE_base(f) (((__crt_stdio_stream_data*)(f))->_base)
+#define PERLIO_FILE_cnt(f) (((__crt_stdio_stream_data*)(f))->_cnt)
+#define PERLIO_FILE_flag(f) ((int)(((__crt_stdio_stream_data*)(f))->_flags))
+#define PERLIO_FILE_file(f) ((int)(((__crt_stdio_stream_data*)(f))->_file))
+
+#endif
#endif /* _MSC_VER */
+#if (!defined(_MSC_VER)) || (defined(_MSC_VER) && _MSC_VER < 1900)
+
+/* Note: PERLIO_FILE_ptr/base/cnt are not actually used for GCC or <VS2015
+ * since FILE_ptr/base/cnt do the same thing anyway but it doesn't hurt to
+ * define them all here for completeness. */
+#define PERLIO_FILE_flag_RD _IOREAD /* 0x001 */
+#define PERLIO_FILE_flag_WR _IOWRT /* 0x002 */
+#define PERLIO_FILE_flag_RW _IORW /* 0x080 */
+#define PERLIO_FILE_ptr(f) ((f)->_ptr)
+#define PERLIO_FILE_base(f) ((f)->_base)
+#define PERLIO_FILE_cnt(f) ((f)->_cnt)
+#define PERLIO_FILE_flag(f) ((f)->_flag)
+#define PERLIO_FILE_file(f) ((f)->_file)
+
+#endif
+
#ifdef __MINGW32__ /* Minimal Gnu-Win32 */
typedef long uid_t;
# define PERL_WAIT_FOR_CHILDREN win32_wait_for_children(aTHX)
#endif
+/* The following ioinfo struct manipulations had been removed but were
+ * reinstated to fix RT#120091/118059. However, they do not work with
+ * the rewritten CRT in VS2015 so they are removed once again for VS2015
+ * onwards, which will therefore suffer from the reintroduction of the
+ * close socket bug. */
+#if (!defined(_MSC_VER)) || (defined(_MSC_VER) && _MSC_VER < 1900)
+
#ifdef PERL_CORE
+
/* C doesn't like repeat struct definitions */
#if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION>=3)
-#undef _CRTIMP
+# undef _CRTIMP
#endif
#ifndef _CRTIMP
-#define _CRTIMP __declspec(dllimport)
+# define _CRTIMP __declspec(dllimport)
#endif
-/* VV 2005 has multiple ioinfo struct definitions through VC 2005's release life
- * VC 2008-2012 have been stable but do not assume future VCs will have the
+/* VS2005 has multiple ioinfo struct definitions through VS2005's release life
+ * VS2008-2012 have been stable but do not assume future VSs will have the
* same ioinfo struct, just because past struct stability. If research is done
- * on the CRTs of future VS, the version check can be bumped up so the newer
- * VC uses a fixed ioinfo size.
+ * on the CRTs of future VSs, the version check can be bumped up so the newer
+ * VS uses a fixed ioinfo size. (Actually, only VS2013 (_MSC_VER 1800) hasn't
+ * been looked at; after that we cannot use the ioinfo struct anyway (see the
+ * #if above).)
*/
#if ! (_MSC_VER < 1400 || (_MSC_VER >= 1500 && _MSC_VER <= 1700) \
|| defined(__MINGW32__))
# if _MSC_VER >= 1400 && _MSC_VER < 1500
# error "This ioinfo struct is incomplete for Visual C 2005"
# endif
-/* VC 2005 CRT has at least 3 different definitions of this struct based on the
+/* VS2005 CRT has at least 3 different definitions of this struct based on the
* CRT DLL's build number. */
# if _MSC_VER >= 1500
# ifndef _SAFECRT_IMPL
#endif
/* since we are not doing a dup2(), this works fine */
-# define _set_osfhnd(fh, osfh) (void)(_osfhnd(fh) = (intptr_t)osfh)
+#define _set_osfhnd(fh, osfh) (void)(_osfhnd(fh) = (intptr_t)osfh)
+
#endif /* PERL_CORE */
+#endif /* !defined(_MSC_VER) || _MSC_VER<1900 */
+
/* IO.xs and POSIX.xs define PERLIO_NOT_STDIO to 1 */
#if defined(PERL_EXT_IO) || defined(PERL_EXT_POSIX)
#undef PERLIO_NOT_STDIO
int err;
err = closesocket(osf);
if (err == 0) {
+#ifdef _set_osfhnd
assert(_osfhnd(fd) == osf); /* catch a bad ioinfo struct def */
/* don't close freed handle */
_set_osfhnd(fd, INVALID_HANDLE_VALUE);
return close(fd);
+#else
+ (void)close(fd); /* handle already closed, ignore error */
+ return 0;
+#endif
}
else if (err == SOCKET_ERROR) {
int wsaerr = WSAGetLastError();
win32_fflush(pf);
err = closesocket(osf);
if (err == 0) {
+#ifdef _set_osfhnd
assert(_osfhnd(win32_fileno(pf)) == osf); /* catch a bad ioinfo struct def */
/* don't close freed handle */
_set_osfhnd(win32_fileno(pf), INVALID_HANDLE_VALUE);
return fclose(pf);
+#else
+ (void)fclose(pf); /* handle already closed, ignore error */
+ return 0;
+#endif
}
else if (err == SOCKET_ERROR) {
int wsaerr = WSAGetLastError();
projects / platform / upstream / perl.git / commitdiff