John Hughes <john@AtlanTech.COM>
John Kristian <jmk2001@engineer.com>
John L. Allen <allen@grumman.com>
+John Lightsey <jd@cpanel.net>
John Macdonald <jmm@revenge.elegant.com>
John Malmberg <wb8tyw@gmail.com>
John Nolan <jpnolan@Op.Net>
Maurizio Loreti <maurizio.loreti@pd.infn.it>
Max Baker <max@warped.org>
Max Maischein <corion@corion.net>
+Maxwell Carey <maxwellhaydn@gmail.com>
Merijn Broeren <merijnb@iloquent.nl>
Michael A Chase <mchase@ix.netcom.com>
Michael Breen <perl@mbreen.com>
*) echo "Using targetarch $targetarch." >&4 ;;
esac
case "$targethost" in
- '') echo "Targethost not defined." >&4; croak=y ;;
+ '') echo "Targethost not defined." >&4; croak=n ;;
*) echo "Using targethost $targethost." >&4
esac
locincpth=' '
if $contains $tlook $tf >/dev/null 2>&1; then
tval=true;
elif $test "$mistrustnm" = compile -o "$mistrustnm" = run; then
- echo "$extern_C void *$1$tdc; void *(*(p()))$tdc { return &$1; } int main() { if(p() && p() != (void *)main) return(0); else return(1); }"> try.c;
+ echo "$extern_C void *$1$tdc; void *(*(p()))$tdc { return &$1; } int main(int argc, char **argv) { if(p() && p() != (void *)argv[0]) return(0); else return(1); }"> try.c;
$cc -o try $optimize $ccflags $ldflags try.c >/dev/null 2>&1 $libs && tval=true;
$test "$mistrustnm" = run -a -x try && { $run ./try$_exe >/dev/null 2>&1 || tval=false; };
$rm_try;
fi;
else
- echo "$extern_C void *$1$tdc; void *(*(p()))$tdc { return &$1; } int main() { if(p() && p() != (void *)main) return(0); else return(1); }"> try.c;
+ echo "$extern_C void *$1$tdc; void *(*(p()))$tdc { return &$1; } int main(int argc, char **argv) { if(p() && p() != (void *)argv[0]) return(0); else return(1); }"> try.c;
$cc -o try $optimize $ccflags $ldflags try.c $libs >/dev/null 2>&1 && tval=true;
$rm_try;
fi;
ansi2knr=''
aphostname='/bin/hostname'
api_revision='5'
-api_subversion='0'
+api_subversion='1'
api_version='25'
-api_versionstring='5.25.0'
+api_versionstring='5.25.1'
ar='ar'
-archlib='/usr/lib/perl5/5.25.0/armv4l-linux'
-archlibexp='/usr/lib/perl5/5.25.0/armv4l-linux'
+archlib='/usr/lib/perl5/5.25.1/armv4l-linux'
+archlibexp='/usr/lib/perl5/5.25.1/armv4l-linux'
archname64=''
archname='armv4l-linux'
archobjs=''
cat='cat'
cc='cc'
cccdlflags='-fpic'
-ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.25.0/armv4l-linux/CORE'
+ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.25.1/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.0/armv4l-linux'
+installarchlib='./install_me_here/usr/lib/perl5/5.25.1/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.0'
+installprivlib='./install_me_here/usr/lib/perl5/5.25.1'
installscript='./install_me_here/usr/bin'
-installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.25.0/armv4l-linux'
+installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.25.1/armv4l-linux'
installsitebin='./install_me_here/usr/bin'
installsitehtml1dir=''
installsitehtml3dir=''
-installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.25.0'
+installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.25.1'
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.0'
-privlibexp='/usr/lib/perl5/5.25.0'
+privlib='/usr/lib/perl5/5.25.1'
+privlibexp='/usr/lib/perl5/5.25.1'
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.0/armv4l-linux'
-sitearchexp='/usr/lib/perl5/site_perl/5.25.0/armv4l-linux'
+sitearch='/usr/lib/perl5/site_perl/5.25.1/armv4l-linux'
+sitearchexp='/usr/lib/perl5/site_perl/5.25.1/armv4l-linux'
sitebin='/usr/bin'
sitebinexp='/usr/bin'
sitehtml1dir=''
sitehtml1direxp=''
sitehtml3dir=''
sitehtml3direxp=''
-sitelib='/usr/lib/perl5/site_perl/5.25.0'
+sitelib='/usr/lib/perl5/site_perl/5.25.1'
sitelib_stem='/usr/lib/perl5/site_perl'
-sitelibexp='/usr/lib/perl5/site_perl/5.25.0'
+sitelibexp='/usr/lib/perl5/site_perl/5.25.1'
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='0'
+subversion='1'
sysman='/usr/share/man/man1'
tail=''
tar=''
vendorprefixexp=''
vendorscript=''
vendorscriptexp=''
-version='5.25.0'
-version_patchlevel_string='version 25 subversion 0'
+version='5.25.1'
+version_patchlevel_string='version 25 subversion 1'
versiononly='undef'
vi=''
xlibpth='/usr/lib/386 /lib/386'
config_argc=0
PERL_REVISION=5
PERL_VERSION=25
-PERL_SUBVERSION=0
+PERL_SUBVERSION=1
PERL_API_REVISION=5
PERL_API_VERSION=25
-PERL_API_SUBVERSION=0
+PERL_API_SUBVERSION=1
PERL_PATCHLEVEL=
PERL_CONFIG_SH=true
ansi2knr=''
aphostname='/bin/hostname'
api_revision='5'
-api_subversion='0'
+api_subversion='1'
api_version='25'
-api_versionstring='5.25.0'
+api_versionstring='5.25.1'
ar='ar'
-archlib='/usr/lib/perl5/5.25.0/armv4l-linux'
-archlibexp='/usr/lib/perl5/5.25.0/armv4l-linux'
+archlib='/usr/lib/perl5/5.25.1/armv4l-linux'
+archlibexp='/usr/lib/perl5/5.25.1/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.0/armv4l-linux/CORE'
+ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.25.1/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.0/armv4l-linux'
+installarchlib='./install_me_here/usr/lib/perl5/5.25.1/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.0'
+installprivlib='./install_me_here/usr/lib/perl5/5.25.1'
installscript='./install_me_here/usr/bin'
-installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.25.0/armv4l-linux'
+installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.25.1/armv4l-linux'
installsitebin='./install_me_here/usr/bin'
installsitehtml1dir=''
installsitehtml3dir=''
-installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.25.0'
+installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.25.1'
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.0'
-privlibexp='/usr/lib/perl5/5.25.0'
+privlib='/usr/lib/perl5/5.25.1'
+privlibexp='/usr/lib/perl5/5.25.1'
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.0/armv4l-linux'
-sitearchexp='/usr/lib/perl5/site_perl/5.25.0/armv4l-linux'
+sitearch='/usr/lib/perl5/site_perl/5.25.1/armv4l-linux'
+sitearchexp='/usr/lib/perl5/site_perl/5.25.1/armv4l-linux'
sitebin='/usr/bin'
sitebinexp='/usr/bin'
sitehtml1dir=''
sitehtml1direxp=''
sitehtml3dir=''
sitehtml3direxp=''
-sitelib='/usr/lib/perl5/site_perl/5.25.0'
+sitelib='/usr/lib/perl5/site_perl/5.25.1'
sitelib_stem='/usr/lib/perl5/site_perl'
-sitelibexp='/usr/lib/perl5/site_perl/5.25.0'
+sitelibexp='/usr/lib/perl5/site_perl/5.25.1'
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='0'
+subversion='1'
sysman='/usr/share/man/man1'
tail=''
tar=''
vendorprefixexp=''
vendorscript=''
vendorscriptexp=''
-version='5.25.0'
-version_patchlevel_string='version 25 subversion 0'
+version='5.25.1'
+version_patchlevel_string='version 25 subversion 1'
versiononly='undef'
vi=''
xlibpth='/usr/lib/386 /lib/386'
config_argc=0
PERL_REVISION=5
PERL_VERSION=25
-PERL_SUBVERSION=0
+PERL_SUBVERSION=1
PERL_API_REVISION=5
PERL_API_VERSION=25
-PERL_API_SUBVERSION=0
+PERL_API_SUBVERSION=1
PERL_PATCHLEVEL=
PERL_CONFIG_SH=true
=item Directories for the perl distribution
-By default, Configure will use the following directories for 5.25.0.
+By default, Configure will use the following directories for 5.25.1.
$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.0 is not binary compatible with earlier versions of Perl.
+Perl 5.25.1 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.0
+ sh Configure -Dprefix=/opt/perl5.25.1
-and adding /opt/perl5.25.0/bin to the shell PATH variable. Such users
+and adding /opt/perl5.25.1/bin to the shell PATH variable. Such users
may also wish to add a symbolic link /usr/local/bin/perl so that
scripts can still start with #!/usr/local/bin/perl.
=head2 Upgrading from v5.22 or earlier
-B<Perl 5.25.0 may not be binary compatible with Perl v5.22 or
+B<Perl 5.25.1 may not be binary compatible with Perl v5.22 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.0. If you find you do need to rebuild an extension with
-5.25.0, you may safely do so without disturbing the older
+used with 5.25.1. If you find you do need to rebuild an extension with
+5.25.1, 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.0 is as follows (under $Config{prefix}):
+in Linux with perl-5.25.1 is as follows (under $Config{prefix}):
./bin/perl
- ./lib/perl5/5.25.0/strict.pm
- ./lib/perl5/5.25.0/warnings.pm
- ./lib/perl5/5.25.0/i686-linux/File/Glob.pm
- ./lib/perl5/5.25.0/feature.pm
- ./lib/perl5/5.25.0/XSLoader.pm
- ./lib/perl5/5.25.0/i686-linux/auto/File/Glob/Glob.so
+ ./lib/perl5/5.25.1/strict.pm
+ ./lib/perl5/5.25.1/warnings.pm
+ ./lib/perl5/5.25.1/i686-linux/File/Glob.pm
+ ./lib/perl5/5.25.1/feature.pm
+ ./lib/perl5/5.25.1/XSLoader.pm
+ ./lib/perl5/5.25.1/i686-linux/auto/File/Glob/Glob.so
Secondly, for perl-5.10.1, the Debian perl-base package contains 591
files, (of which 510 are for lib/unicore) totaling about 3.5MB in its
cpan/Archive-Tar/t/05_iter.t Archive::Tar tests
cpan/Archive-Tar/t/06_error.t Archive::Tar tests
cpan/Archive-Tar/t/08_ptargrep.t
+cpan/Archive-Tar/t/09_roundtrip.t
cpan/Archive-Tar/t/90_symlink.t Archive::Tar tests
cpan/Archive-Tar/t/99_pod.t Archive::Tar tests
cpan/Archive-Tar/t/src/header/signed.tar Archive::Tar tests
cpan/Config-Perl-V/t/27_plv5202.t Config::Perl::V
cpan/Config-Perl-V/t/28_plv52201w.t Config::Perl::V
cpan/Config-Perl-V/t/28_plv5220.t Config::Perl::V
+cpan/Config-Perl-V/t/29_plv5235w.t Config::Perl::V
+cpan/Config-Perl-V/t/30_plv5240.t Config::Perl::V
cpan/Config-Perl-V/V.pm Config::Perl::V
cpan/CPAN/lib/App/Cpan.pm helper package for CPAN.pm
cpan/CPAN/lib/CPAN/API/HOWTO.pod recipe book for programming with CPAN.pm
cpan/Locale-Codes/lib/Locale/Language.pod Locale::Codes documentation
cpan/Locale-Codes/lib/Locale/Script.pm Locale::Codes
cpan/Locale-Codes/lib/Locale/Script.pod Locale::Codes documentation
-cpan/Locale-Codes/t/code2country_old.t Locale::Codes tests
-cpan/Locale-Codes/t/code2country.t Locale::Codes tests
-cpan/Locale-Codes/t/code2currency.t Locale::Codes tests
-cpan/Locale-Codes/t/code2langext.t Locale::Codes tests
-cpan/Locale-Codes/t/code2langfam.t Locale::Codes tests
-cpan/Locale-Codes/t/code2language.t Locale::Codes tests
-cpan/Locale-Codes/t/code2langvar.t Locale::Codes tests
-cpan/Locale-Codes/t/code2script.t Locale::Codes tests
-cpan/Locale-Codes/t/country2code_old.t Locale::Codes tests
-cpan/Locale-Codes/t/country2code.t Locale::Codes tests
-cpan/Locale-Codes/t/country_code2code_old.t Locale::Codes tests
-cpan/Locale-Codes/t/country_code2code.t Locale::Codes tests
cpan/Locale-Codes/t/country_old.t Locale::Codes tests
cpan/Locale-Codes/t/country.t Locale::Codes tests
-cpan/Locale-Codes/t/currency2code_old.t Locale::Codes tests
-cpan/Locale-Codes/t/currency2code.t Locale::Codes tests
-cpan/Locale-Codes/t/langext2code.t Locale::Codes tests
-cpan/Locale-Codes/t/langfam2code.t Locale::Codes tests
-cpan/Locale-Codes/t/language2code.t Locale::Codes tests
+cpan/Locale-Codes/t/currency_old.t
+cpan/Locale-Codes/t/currency.t
+cpan/Locale-Codes/t/langext.t
+cpan/Locale-Codes/t/langfam.t
cpan/Locale-Codes/t/language_old.t Locale::Codes tests
cpan/Locale-Codes/t/language.t Locale::Codes tests
-cpan/Locale-Codes/t/langvar2code.t Locale::Codes tests
-cpan/Locale-Codes/t/script2code_old.t Locale::Codes tests
-cpan/Locale-Codes/t/script2code.t Locale::Codes tests
+cpan/Locale-Codes/t/langvar.t
+cpan/Locale-Codes/t/script_old.t
+cpan/Locale-Codes/t/script.t
cpan/Locale-Codes/t/testfunc.pl Locale::Codes tests
+cpan/Locale-Codes/t/vals_country.pl
+cpan/Locale-Codes/t/vals_currency.pl
+cpan/Locale-Codes/t/vals_langext.pl
+cpan/Locale-Codes/t/vals_langfam.pl
+cpan/Locale-Codes/t/vals_language.pl
+cpan/Locale-Codes/t/vals_langvar.pl
+cpan/Locale-Codes/t/vals.pl
+cpan/Locale-Codes/t/vals_script.pl
cpan/Locale-Maketext-Simple/lib/Locale/Maketext/Simple.pm Locale::Simple
cpan/Locale-Maketext-Simple/t/0-signature.t Locale::Simple tests
cpan/Locale-Maketext-Simple/t/1-basic.t Locale::Simple tests
cpan/Scalar-List-Utils/t/reduce.t List::Util
cpan/Scalar-List-Utils/t/refaddr.t Scalar::Util
cpan/Scalar-List-Utils/t/reftype.t Scalar::Util
+cpan/Scalar-List-Utils/t/rt-96343.t Scalar::Util
cpan/Scalar-List-Utils/t/scalarutil-proto.t
cpan/Scalar-List-Utils/t/shuffle.t List::Util
cpan/Scalar-List-Utils/t/stack-corruption.t List::Util
cpan/Scalar-List-Utils/t/sum0.t
cpan/Scalar-List-Utils/t/sum.t List::Util
cpan/Scalar-List-Utils/t/tainted.t Scalar::Util
+cpan/Scalar-List-Utils/t/uniq.t Scalar::Util
cpan/Scalar-List-Utils/t/weak.t Scalar::Util
cpan/Socket/Makefile.PL Socket extension makefile writer
cpan/Socket/Socket.pm Socket extension Perl module
cpan/Test-Harness/t/yamlish.t Test::Harness test
cpan/Test-Harness/t/yamlish-writer.t Test::Harness test
cpan/Test-Simple/lib/ok.pm
+cpan/Test-Simple/lib/Test2/API/Breakage.pm
+cpan/Test-Simple/lib/Test2/API/Context.pm
+cpan/Test-Simple/lib/Test2/API/Instance.pm
+cpan/Test-Simple/lib/Test2/API.pm
+cpan/Test-Simple/lib/Test2/API/Stack.pm
+cpan/Test-Simple/lib/Test2/Event/Bail.pm
+cpan/Test-Simple/lib/Test2/Event/Diag.pm
+cpan/Test-Simple/lib/Test2/Event/Exception.pm
+cpan/Test-Simple/lib/Test2/Event/Note.pm
+cpan/Test-Simple/lib/Test2/Event/Ok.pm
+cpan/Test-Simple/lib/Test2/Event/Plan.pm
+cpan/Test-Simple/lib/Test2/Event.pm
+cpan/Test-Simple/lib/Test2/Event/Skip.pm
+cpan/Test-Simple/lib/Test2/Event/Subtest.pm
+cpan/Test-Simple/lib/Test2/Event/Waiting.pm
+cpan/Test-Simple/lib/Test2/Formatter.pm
+cpan/Test-Simple/lib/Test2/Formatter/TAP.pm
+cpan/Test-Simple/lib/Test2/Hub/Interceptor.pm
+cpan/Test-Simple/lib/Test2/Hub/Interceptor/Terminator.pm
+cpan/Test-Simple/lib/Test2/Hub.pm
+cpan/Test-Simple/lib/Test2/Hub/Subtest.pm
+cpan/Test-Simple/lib/Test2/IPC/Driver/Files.pm
+cpan/Test-Simple/lib/Test2/IPC/Driver.pm
+cpan/Test-Simple/lib/Test2/IPC.pm
+cpan/Test-Simple/lib/Test2.pm
+cpan/Test-Simple/lib/Test2/Transition.pod
+cpan/Test-Simple/lib/Test2/Util/ExternalMeta.pm
+cpan/Test-Simple/lib/Test2/Util/HashBase.pm
+cpan/Test-Simple/lib/Test2/Util.pm
+cpan/Test-Simple/lib/Test2/Util/Trace.pm
+cpan/Test-Simple/lib/Test/Builder/Formatter.pm
cpan/Test-Simple/lib/Test/Builder/IO/Scalar.pm
cpan/Test-Simple/lib/Test/Builder/Module.pm
cpan/Test-Simple/lib/Test/Builder.pm
cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm
cpan/Test-Simple/lib/Test/Builder/Tester.pm
+cpan/Test-Simple/lib/Test/Builder/TodoDiag.pm
+cpan/Test-Simple/lib/Test/FAQ.pod
cpan/Test-Simple/lib/Test/More.pm
cpan/Test-Simple/lib/Test/Simple.pm
cpan/Test-Simple/lib/Test/Tester/Capture.pm
cpan/Test-Simple/lib/Test/Tester.pm
cpan/Test-Simple/lib/Test/Tutorial.pod
cpan/Test-Simple/lib/Test/use/ok.pm
-cpan/Test-Simple/t/00test_harness_check.t
-cpan/Test-Simple/t/01-basic.t
-cpan/Test-Simple/t/478-cmp_ok_hash.t
-cpan/Test-Simple/t/auto.t
-cpan/Test-Simple/t/bad_plan.t
-cpan/Test-Simple/t/bail_out.t
-cpan/Test-Simple/t/BEGIN_require_ok.t
-cpan/Test-Simple/t/BEGIN_use_ok.t
-cpan/Test-Simple/t/buffer.t
-cpan/Test-Simple/t/Builder/Builder.t
-cpan/Test-Simple/t/Builder/carp.t
-cpan/Test-Simple/t/Builder/create.t
-cpan/Test-Simple/t/Builder/current_test.t
-cpan/Test-Simple/t/Builder/current_test_without_plan.t
-cpan/Test-Simple/t/Builder/details.t
-cpan/Test-Simple/t/Builder/done_testing_double.t
-cpan/Test-Simple/t/Builder/done_testing_plan_mismatch.t
-cpan/Test-Simple/t/Builder/done_testing.t
-cpan/Test-Simple/t/Builder/done_testing_with_no_plan.t
-cpan/Test-Simple/t/Builder/done_testing_with_number.t
-cpan/Test-Simple/t/Builder/done_testing_with_plan.t
-cpan/Test-Simple/t/Builder/fork_with_new_stdout.t
-cpan/Test-Simple/t/Builder/has_plan2.t
-cpan/Test-Simple/t/Builder/has_plan.t
-cpan/Test-Simple/t/Builder/is_fh.t
-cpan/Test-Simple/t/Builder/is_passing.t
-cpan/Test-Simple/t/Builder/maybe_regex.t
-cpan/Test-Simple/t/Builder/no_diag.t
-cpan/Test-Simple/t/Builder/no_ending.t
-cpan/Test-Simple/t/Builder/no_header.t
-cpan/Test-Simple/t/Builder/no_plan_at_all.t
-cpan/Test-Simple/t/Builder/ok_obj.t
-cpan/Test-Simple/t/Builder/output.t
-cpan/Test-Simple/t/Builder/reset_outputs.t
-cpan/Test-Simple/t/Builder/reset.t
-cpan/Test-Simple/t/Builder/try.t
-cpan/Test-Simple/t/capture.t
-cpan/Test-Simple/t/c_flag.t
-cpan/Test-Simple/t/check_tests.t
-cpan/Test-Simple/t/circular_data.t
-cpan/Test-Simple/t/cmp_ok.t
-cpan/Test-Simple/t/dependents.t
-cpan/Test-Simple/t/depth.t
-cpan/Test-Simple/t/diag.t
-cpan/Test-Simple/t/died.t
-cpan/Test-Simple/t/dont_overwrite_die_handler.t
-cpan/Test-Simple/t/eq_set.t
-cpan/Test-Simple/t/exit.t
-cpan/Test-Simple/t/explain.t
-cpan/Test-Simple/t/extra_one.t
-cpan/Test-Simple/t/extra.t
-cpan/Test-Simple/t/fail-like.t
-cpan/Test-Simple/t/fail-more.t
-cpan/Test-Simple/t/fail_one.t
-cpan/Test-Simple/t/fail.t
-cpan/Test-Simple/t/filehandles.t
-cpan/Test-Simple/t/fork.t
-cpan/Test-Simple/t/harness_active.t
-cpan/Test-Simple/t/import.t
-cpan/Test-Simple/t/is_deeply_dne_bug.t
-cpan/Test-Simple/t/is_deeply_fail.t
-cpan/Test-Simple/t/is_deeply_with_threads.t
+cpan/Test-Simple/t/00compile.t
+cpan/Test-Simple/t/Legacy/00test_harness_check.t
+cpan/Test-Simple/t/Legacy/01-basic.t
+cpan/Test-Simple/t/Legacy/478-cmp_ok_hash.t
+cpan/Test-Simple/t/Legacy_And_Test2/builder_loaded_late.t
+cpan/Test-Simple/t/Legacy/auto.t
+cpan/Test-Simple/t/Legacy/bad_plan.t
+cpan/Test-Simple/t/Legacy/bail_out.t
+cpan/Test-Simple/t/Legacy/BEGIN_require_ok.t
+cpan/Test-Simple/t/Legacy/BEGIN_use_ok.t
+cpan/Test-Simple/t/Legacy/buffer.t
+cpan/Test-Simple/t/Legacy/Bugs/600.t
+cpan/Test-Simple/t/Legacy/Bugs/629.t
+cpan/Test-Simple/t/Legacy/Builder/Builder.t
+cpan/Test-Simple/t/Legacy/Builder/carp.t
+cpan/Test-Simple/t/Legacy/Builder/create.t
+cpan/Test-Simple/t/Legacy/Builder/current_test.t
+cpan/Test-Simple/t/Legacy/Builder/current_test_without_plan.t
+cpan/Test-Simple/t/Legacy/Builder/details.t
+cpan/Test-Simple/t/Legacy/Builder/done_testing_double.t
+cpan/Test-Simple/t/Legacy/Builder/done_testing_plan_mismatch.t
+cpan/Test-Simple/t/Legacy/Builder/done_testing.t
+cpan/Test-Simple/t/Legacy/Builder/done_testing_with_no_plan.t
+cpan/Test-Simple/t/Legacy/Builder/done_testing_with_number.t
+cpan/Test-Simple/t/Legacy/Builder/done_testing_with_plan.t
+cpan/Test-Simple/t/Legacy/Builder/fork_with_new_stdout.t
+cpan/Test-Simple/t/Legacy/Builder/has_plan2.t
+cpan/Test-Simple/t/Legacy/Builder/has_plan.t
+cpan/Test-Simple/t/Legacy/Builder/is_fh.t
+cpan/Test-Simple/t/Legacy/Builder/is_passing.t
+cpan/Test-Simple/t/Legacy/Builder/maybe_regex.t
+cpan/Test-Simple/t/Legacy/Builder/no_diag.t
+cpan/Test-Simple/t/Legacy/Builder/no_ending.t
+cpan/Test-Simple/t/Legacy/Builder/no_header.t
+cpan/Test-Simple/t/Legacy/Builder/no_plan_at_all.t
+cpan/Test-Simple/t/Legacy/Builder/ok_obj.t
+cpan/Test-Simple/t/Legacy/Builder/output.t
+cpan/Test-Simple/t/Legacy/Builder/reset_outputs.t
+cpan/Test-Simple/t/Legacy/Builder/reset.t
+cpan/Test-Simple/t/Legacy/Builder/try.t
+cpan/Test-Simple/t/Legacy/capture.t
+cpan/Test-Simple/t/Legacy/c_flag.t
+cpan/Test-Simple/t/Legacy/check_tests.t
+cpan/Test-Simple/t/Legacy/circular_data.t
+cpan/Test-Simple/t/Legacy/cmp_ok.t
+cpan/Test-Simple/t/Legacy/depth.t
+cpan/Test-Simple/t/Legacy/diag.t
+cpan/Test-Simple/t/Legacy/died.t
+cpan/Test-Simple/t/Legacy/dont_overwrite_die_handler.t
+cpan/Test-Simple/t/Legacy/eq_set.t
+cpan/Test-Simple/t/Legacy/exit.t
+cpan/Test-Simple/t/Legacy/explain_err_vars.t
+cpan/Test-Simple/t/Legacy/explain.t
+cpan/Test-Simple/t/Legacy/extra_one.t
+cpan/Test-Simple/t/Legacy/extra.t
+cpan/Test-Simple/t/Legacy/fail-like.t
+cpan/Test-Simple/t/Legacy/fail-more.t
+cpan/Test-Simple/t/Legacy/fail_one.t
+cpan/Test-Simple/t/Legacy/fail.t
+cpan/Test-Simple/t/Legacy/filehandles.t
+cpan/Test-Simple/t/Legacy/fork.t
+cpan/Test-Simple/t/Legacy/harness_active.t
+cpan/Test-Simple/t/Legacy/import.t
+cpan/Test-Simple/t/Legacy/is_deeply_dne_bug.t
+cpan/Test-Simple/t/Legacy/is_deeply_fail.t
+cpan/Test-Simple/t/Legacy/is_deeply_with_threads.t
+cpan/Test-Simple/t/Legacy/missing.t
+cpan/Test-Simple/t/Legacy/More.t
+cpan/Test-Simple/t/Legacy/new_ok.t
+cpan/Test-Simple/t/Legacy/no_plan.t
+cpan/Test-Simple/t/Legacy/no_tests.t
+cpan/Test-Simple/t/Legacy/note.t
+cpan/Test-Simple/t/Legacy/overload.t
+cpan/Test-Simple/t/Legacy/overload_threads.t
+cpan/Test-Simple/t/Legacy/plan_bad.t
+cpan/Test-Simple/t/Legacy/plan_is_noplan.t
+cpan/Test-Simple/t/Legacy/plan_no_plan.t
+cpan/Test-Simple/t/Legacy/plan_shouldnt_import.t
+cpan/Test-Simple/t/Legacy/plan_skip_all.t
+cpan/Test-Simple/t/Legacy/plan.t
+cpan/Test-Simple/t/Legacy/Regression/637.t
+cpan/Test-Simple/t/Legacy/require_ok.t
+cpan/Test-Simple/t/Legacy/run_test.t
+cpan/Test-Simple/t/Legacy/Simple/load.t
+cpan/Test-Simple/t/Legacy/simple.t
+cpan/Test-Simple/t/Legacy/skipall.t
+cpan/Test-Simple/t/Legacy/skip.t
+cpan/Test-Simple/t/Legacy/strays.t
+cpan/Test-Simple/t/Legacy/subtest/args.t
+cpan/Test-Simple/t/Legacy/subtest/bail_out.t
+cpan/Test-Simple/t/Legacy/subtest/basic.t
+cpan/Test-Simple/t/Legacy/subtest/die.t
+cpan/Test-Simple/t/Legacy/subtest/do.t
+cpan/Test-Simple/t/Legacy/subtest/events.t
+cpan/Test-Simple/t/Legacy/subtest/for_do_t.test
+cpan/Test-Simple/t/Legacy/subtest/fork.t
+cpan/Test-Simple/t/Legacy/subtest/implicit_done.t
+cpan/Test-Simple/t/Legacy/subtest/line_numbers.t
+cpan/Test-Simple/t/Legacy/subtest/plan.t
+cpan/Test-Simple/t/Legacy/subtest/predicate.t
+cpan/Test-Simple/t/Legacy/subtest/singleton.t
+cpan/Test-Simple/t/Legacy/subtest/threads.t
+cpan/Test-Simple/t/Legacy/subtest/todo.t
+cpan/Test-Simple/t/Legacy/subtest/wstat.t
+cpan/Test-Simple/t/Legacy/tbm_doesnt_set_exported_to.t
+cpan/Test-Simple/t/Legacy/Test2/Subtest.t
+cpan/Test-Simple/t/Legacy/Tester/tbt_01basic.t
+cpan/Test-Simple/t/Legacy/Tester/tbt_02fhrestore.t
+cpan/Test-Simple/t/Legacy/Tester/tbt_03die.t
+cpan/Test-Simple/t/Legacy/Tester/tbt_04line_num.t
+cpan/Test-Simple/t/Legacy/Tester/tbt_05faildiag.t
+cpan/Test-Simple/t/Legacy/Tester/tbt_06errormess.t
+cpan/Test-Simple/t/Legacy/Tester/tbt_07args.t
+cpan/Test-Simple/t/Legacy/Tester/tbt_08subtest.t
+cpan/Test-Simple/t/Legacy/Tester/tbt_09do_script.pl
+cpan/Test-Simple/t/Legacy/Tester/tbt_09do.t
+cpan/Test-Simple/t/Legacy/threads.t
+cpan/Test-Simple/t/Legacy/thread_taint.t
+cpan/Test-Simple/t/Legacy/todo.t
+cpan/Test-Simple/t/Legacy/undef.t
+cpan/Test-Simple/t/Legacy/useing.t
+cpan/Test-Simple/t/Legacy/use_ok.t
+cpan/Test-Simple/t/Legacy/utf8.t
+cpan/Test-Simple/t/Legacy/versions.t
cpan/Test-Simple/t/lib/Dev/Null.pm
cpan/Test-Simple/t/lib/Dummy.pm
cpan/Test-Simple/t/lib/MyOverload.pm
+cpan/Test-Simple/t/lib/MyTest.pm
cpan/Test-Simple/t/lib/NoExporter.pm
cpan/Test-Simple/t/lib/SigDie.pm
+cpan/Test-Simple/t/lib/SmallTest.pm
cpan/Test-Simple/t/lib/Test/Builder/NoOutput.pm
cpan/Test-Simple/t/lib/Test/Simple/Catch.pm
cpan/Test-Simple/t/lib/Test/Simple/sample_tests/death_in_eval.plx
cpan/Test-Simple/t/lib/Test/Simple/sample_tests/too_few.plx
cpan/Test-Simple/t/lib/Test/Simple/sample_tests/two_fail.plx
cpan/Test-Simple/t/lib/TieOut.pm
-cpan/Test-Simple/t/missing.t
-cpan/Test-Simple/t/More.t
-cpan/Test-Simple/t/MyTest.pm
-cpan/Test-Simple/t/new_ok.t
-cpan/Test-Simple/t/no_plan.t
-cpan/Test-Simple/t/no_tests.t
-cpan/Test-Simple/t/note.t
-cpan/Test-Simple/t/overload.t
-cpan/Test-Simple/t/overload_threads.t
-cpan/Test-Simple/t/plan_bad.t
-cpan/Test-Simple/t/plan_is_noplan.t
-cpan/Test-Simple/t/plan_no_plan.t
-cpan/Test-Simple/t/plan_shouldnt_import.t
-cpan/Test-Simple/t/plan_skip_all.t
-cpan/Test-Simple/t/plan.t
-cpan/Test-Simple/t/require_ok.t
-cpan/Test-Simple/t/run_test.t
-cpan/Test-Simple/t/Simple/load.t
-cpan/Test-Simple/t/simple.t
-cpan/Test-Simple/t/skipall.t
-cpan/Test-Simple/t/skip.t
-cpan/Test-Simple/t/SmallTest.pm
-cpan/Test-Simple/t/subtest/args.t
-cpan/Test-Simple/t/subtest/bail_out.t
-cpan/Test-Simple/t/subtest/basic.t
-cpan/Test-Simple/t/subtest/die.t
-cpan/Test-Simple/t/subtest/do.t
-cpan/Test-Simple/t/subtest/exceptions.t
-cpan/Test-Simple/t/subtest/for_do_t.test
-cpan/Test-Simple/t/subtest/fork.t
-cpan/Test-Simple/t/subtest/implicit_done.t
-cpan/Test-Simple/t/subtest/line_numbers.t
-cpan/Test-Simple/t/subtest/plan.t
-cpan/Test-Simple/t/subtest/predicate.t
-cpan/Test-Simple/t/subtest/singleton.t
-cpan/Test-Simple/t/subtest/threads.t
-cpan/Test-Simple/t/subtest/todo.t
-cpan/Test-Simple/t/subtest/wstat.t
-cpan/Test-Simple/t/tbm_doesnt_set_exported_to.t
-cpan/Test-Simple/t/Tester/tbt_01basic.t
-cpan/Test-Simple/t/Tester/tbt_02fhrestore.t
-cpan/Test-Simple/t/Tester/tbt_03die.t
-cpan/Test-Simple/t/Tester/tbt_04line_num.t
-cpan/Test-Simple/t/Tester/tbt_05faildiag.t
-cpan/Test-Simple/t/Tester/tbt_06errormess.t
-cpan/Test-Simple/t/Tester/tbt_07args.t
-cpan/Test-Simple/t/Tester/tbt_08subtest.t
-cpan/Test-Simple/t/Tester/tbt_09do_script.pl
-cpan/Test-Simple/t/Tester/tbt_09do.t
-cpan/Test-Simple/t/threads.t
-cpan/Test-Simple/t/thread_taint.t
-cpan/Test-Simple/t/todo.t
-cpan/Test-Simple/t/undef.t
-cpan/Test-Simple/t/useing.t
-cpan/Test-Simple/t/use_ok.t
-cpan/Test-Simple/t/utf8.t
-cpan/Test-Simple/t/versions.t
+cpan/Test-Simple/t/regression/642_persistent_end.t
+cpan/Test-Simple/t/regression/no_name_in_subtest.t
+cpan/Test-Simple/t/Test2/acceptance/try_it_done_testing.t
+cpan/Test-Simple/t/Test2/acceptance/try_it_fork.t
+cpan/Test-Simple/t/Test2/acceptance/try_it_no_plan.t
+cpan/Test-Simple/t/Test2/acceptance/try_it_plan.t
+cpan/Test-Simple/t/Test2/acceptance/try_it_skip.t
+cpan/Test-Simple/t/Test2/acceptance/try_it_threads.t
+cpan/Test-Simple/t/Test2/acceptance/try_it_todo.t
+cpan/Test-Simple/t/Test2/behavior/err_var.t
+cpan/Test-Simple/t/Test2/behavior/init_croak.t
+cpan/Test-Simple/t/Test2/behavior/nested_context_exception.t
+cpan/Test-Simple/t/Test2/behavior/no_load_api.t
+cpan/Test-Simple/t/Test2/behavior/Subtest_buffer_formatter.t
+cpan/Test-Simple/t/Test2/behavior/Subtest_events.t
+cpan/Test-Simple/t/Test2/behavior/Subtest_plan.t
+cpan/Test-Simple/t/Test2/behavior/Taint.t
+cpan/Test-Simple/t/Test2/legacy/TAP.t
+cpan/Test-Simple/t/Test2/modules/API/Breakage.t
+cpan/Test-Simple/t/Test2/modules/API/Context.t
+cpan/Test-Simple/t/Test2/modules/API/Instance.t
+cpan/Test-Simple/t/Test2/modules/API/Stack.t
+cpan/Test-Simple/t/Test2/modules/API.t
+cpan/Test-Simple/t/Test2/modules/Event/Bail.t
+cpan/Test-Simple/t/Test2/modules/Event/Diag.t
+cpan/Test-Simple/t/Test2/modules/Event/Exception.t
+cpan/Test-Simple/t/Test2/modules/Event/Note.t
+cpan/Test-Simple/t/Test2/modules/Event/Ok.t
+cpan/Test-Simple/t/Test2/modules/Event/Plan.t
+cpan/Test-Simple/t/Test2/modules/Event/Skip.t
+cpan/Test-Simple/t/Test2/modules/Event/Subtest.t
+cpan/Test-Simple/t/Test2/modules/Event.t
+cpan/Test-Simple/t/Test2/modules/Event/Waiting.t
+cpan/Test-Simple/t/Test2/modules/Formatter/TAP.t
+cpan/Test-Simple/t/Test2/modules/Hub/Interceptor.t
+cpan/Test-Simple/t/Test2/modules/Hub/Interceptor/Terminator.t
+cpan/Test-Simple/t/Test2/modules/Hub/Subtest.t
+cpan/Test-Simple/t/Test2/modules/Hub.t
+cpan/Test-Simple/t/Test2/modules/IPC/Driver/Files.t
+cpan/Test-Simple/t/Test2/modules/IPC/Driver.t
+cpan/Test-Simple/t/Test2/modules/IPC.t
+cpan/Test-Simple/t/Test2/modules/Util/ExternalMeta.t
+cpan/Test-Simple/t/Test2/modules/Util/HashBase.t
+cpan/Test-Simple/t/Test2/modules/Util.t
+cpan/Test-Simple/t/Test2/modules/Util/Trace.t
+cpan/Test-Simple/t/Test2/regression/gh_16.t
+cpan/Test-Simple/t/Test2/regression/ipc_files_abort_exit.t
+cpan/Test-Simple/t/tools.pl
+cpan/Test-Simple/t/tools.t
cpan/Text-Balanced/lib/Text/Balanced.pm Text::Balanced
cpan/Text-Balanced/t/01_compile.t See if Text::Balanced works
cpan/Text-Balanced/t/02_extbrk.t See if Text::Balanced works
dist/Locale-Maketext/t/70_fail_auto.t See if Locale::Maketext works
dist/Locale-Maketext/t/90_utf8.t See if Locale::Maketext works
dist/Locale-Maketext/t/91_backslash.t See if Locale::Maketext works
+dist/Locale-Maketext/t/92_blacklist.t See if Locale::Maketext works
+dist/Locale-Maketext/t/93_whitelist.t See if Locale::Maketext works
dist/Module-CoreList/Changes Module::CoreList Changes
dist/Module-CoreList/corelist The corelist command-line utility
dist/Module-CoreList/identify-dependencies A usage example for Module::CoreList
ext/XS-APItest/t/labelconst.t test recursive descent label parsing
ext/XS-APItest/t/labelconst_utf8.aux auxiliary file for label test in UTF-8
ext/XS-APItest/t/lexsub.t Test XS registration of lexical subs
+ext/XS-APItest/t/load-module.t test load_module()
ext/XS-APItest/t/locale.t test locale-related things
ext/XS-APItest/t/loopblock.t test recursive descent block parsing
ext/XS-APItest/t/looprest.t test recursive descent statement-sequence parsing
lib/perl5db/t/test-w-statement-1 Tests for the Perl debugger
lib/perl5db/t/uncalled-subroutine Tests for the Perl debugger
lib/perl5db/t/with-subroutine Tests for the Perl debugger
+lib/perlbug.t Tests for the Perl bug reporter
lib/PerlIO.pm PerlIO support module
lib/Pod/t/InputObjects.t See if Pod::InputObjects works
lib/Pod/t/Select.t See if Pod::Select works
pod/perl5221delta.pod Perl changes in version 5.22.1
pod/perl5222delta.pod Perl changes in version 5.22.2
pod/perl5240delta.pod Perl changes in version 5.24.0
+pod/perl5250delta.pod Perl changes in version 5.25.0
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
"url" : "http://perl5.git.perl.org/"
}
},
- "version" : "5.025000",
+ "version" : "5.025001",
"x_serialization_backend" : "JSON::PP version 2.27300"
}
homepage: http://www.perl.org/
license: http://dev.perl.org/licenses/
repository: http://perl5.git.perl.org/
-version: '5.025000'
+version: '5.025001'
x_serialization_backend: 'CPAN::Meta::YAML version 0.018'
perllib_objs = $(perllib_objs_nodt) $(DTRACE_PERLLIB_O)
perlmain_objs = perlmain$(OBJ_EXT) $(DTRACE_MAIN_O)
-perltoc_pod_prereqs = extra.pods pod/perl5250delta.pod pod/perlapi.pod pod/perlintern.pod pod/perlmodlib.pod pod/perluniprops.pod
+perltoc_pod_prereqs = extra.pods pod/perl5251delta.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/perl5250delta.pod: pod/perldelta.pod
- $(RMS) pod/perl5250delta.pod
- $(LNS) perldelta.pod pod/perl5250delta.pod
+pod/perl5251delta.pod: pod/perldelta.pod
+ $(RMS) pod/perl5251delta.pod
+ $(LNS) perldelta.pod pod/perl5251delta.pod
extra.pods: $(MINIPERL_EXE)
-@test ! -f extra.pods || rm -f `cat extra.pods`
-rmdir lib/autodie/exception lib/autodie/Scope lib/autodie lib/XS
-rmdir lib/Win32API lib/VMS lib/Unicode/Collate/Locale
-rmdir lib/Unicode/Collate/CJK lib/Unicode/Collate lib/Tie/Hash
- -rmdir lib/Thread lib/Text lib/Test/use lib/Test/Tester
- -rmdir lib/Test/Builder/Tester lib/Test/Builder/IO lib/Test/Builder
- -rmdir lib/Test lib/Term lib/TAP/Parser/YAMLish
- -rmdir lib/TAP/Parser/SourceHandler lib/TAP/Parser/Scheduler
- -rmdir lib/TAP/Parser/Result lib/TAP/Parser/Iterator lib/TAP/Parser
- -rmdir lib/TAP/Harness lib/TAP/Formatter/File
- -rmdir lib/TAP/Formatter/Console lib/TAP/Formatter lib/TAP
- -rmdir lib/Sys/Syslog lib/Sys lib/Sub lib/Search lib/Scalar
- -rmdir lib/Pod/Text lib/Pod/Simple lib/Pod/Perldoc lib/PerlIO/via
- -rmdir lib/PerlIO lib/Perl lib/Parse/CPAN lib/Parse lib/Params
- -rmdir lib/Net/FTP lib/Module/Load lib/Module/CoreList lib/Module
- -rmdir lib/Memoize lib/Math/BigInt lib/Math/BigFloat lib/Math lib/MIME
- -rmdir lib/Locale/Maketext lib/Locale/Codes lib/Locale lib/List/Util
- -rmdir lib/List lib/JSON/PP lib/JSON lib/IPC lib/IO/Uncompress/Adapter
- -rmdir lib/IO/Uncompress lib/IO/Socket lib/IO/Compress/Zlib
- -rmdir lib/IO/Compress/Zip lib/IO/Compress/Gzip lib/IO/Compress/Base
+ -rmdir lib/Thread lib/Text lib/Test2/Util lib/Test2/IPC/Driver
+ -rmdir lib/Test2/IPC lib/Test2/Hub/Interceptor lib/Test2/Hub
+ -rmdir lib/Test2/Formatter lib/Test2/Event lib/Test2/API lib/Test2
+ -rmdir lib/Test/use lib/Test/Tester lib/Test/Builder/Tester
+ -rmdir lib/Test/Builder/IO lib/Test/Builder lib/Test lib/Term
+ -rmdir lib/TAP/Parser/YAMLish lib/TAP/Parser/SourceHandler
+ -rmdir lib/TAP/Parser/Scheduler lib/TAP/Parser/Result
+ -rmdir lib/TAP/Parser/Iterator lib/TAP/Parser lib/TAP/Harness
+ -rmdir lib/TAP/Formatter/File lib/TAP/Formatter/Console
+ -rmdir lib/TAP/Formatter lib/TAP lib/Sys/Syslog lib/Sys lib/Sub
+ -rmdir lib/Search lib/Scalar lib/Pod/Text lib/Pod/Simple
+ -rmdir lib/Pod/Perldoc lib/PerlIO/via lib/PerlIO lib/Perl
+ -rmdir lib/Parse/CPAN lib/Parse lib/Params lib/Net/FTP lib/Module/Load
+ -rmdir lib/Module/CoreList lib/Module lib/Memoize lib/Math/BigInt
+ -rmdir lib/Math/BigFloat lib/Math lib/MIME lib/Locale/Maketext
+ -rmdir lib/Locale/Codes lib/Locale lib/List/Util lib/List lib/JSON/PP
+ -rmdir lib/JSON lib/IPC lib/IO/Uncompress/Adapter lib/IO/Uncompress
+ -rmdir lib/IO/Socket lib/IO/Compress/Zlib lib/IO/Compress/Zip
+ -rmdir lib/IO/Compress/Gzip lib/IO/Compress/Base
-rmdir lib/IO/Compress/Adapter lib/IO/Compress lib/IO
-rmdir lib/I18N/LangTags lib/I18N lib/Hash/Util lib/Hash lib/HTTP
-rmdir lib/Filter/Util lib/Filter lib/File/Spec lib/ExtUtils/Typemaps
# Here comes the CW tools - TO BE FILLED TO BUILD WITH CW -
-MODULE_DESC = "Perl 5.25.0 for NetWare"
+MODULE_DESC = "Perl 5.25.1 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.0
+INST_VER = \5.25.1
#
# 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.0\\lib\\NetWare-x86-multi-thread" /**/
+#define ARCHLIB "c:\\perl\\5.25.1\\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.0\\bin\\NetWare-x86-multi-thread" /**/
-#define BIN_EXP "c:\\perl\\5.25.0\\bin\\NetWare-x86-multi-thread" /**/
+#define BIN "c:\\perl\\5.25.1\\bin\\NetWare-x86-multi-thread" /**/
+#define BIN_EXP "c:\\perl\\5.25.1\\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.0\\lib\\NetWare-x86-multi-thread" /**/
+#define SITEARCH "c:\\perl\\site\\5.25.1\\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.0\\lib" /**/
+#define SITELIB "c:\\perl\\site\\5.25.1\\lib" /**/
/*#define SITELIB_EXP "" /**/
#define SITELIB_STEM "" /**/
%Modules = (
'Archive::Tar' => {
- 'DISTRIBUTION' => 'BINGOS/Archive-Tar-2.04.tar.gz',
+ 'DISTRIBUTION' => 'BINGOS/Archive-Tar-2.08.tar.gz',
'FILES' => q[cpan/Archive-Tar],
'BUGS' => 'bug-archive-tar@rt.cpan.org',
'EXCLUDED' => [
},
'autouse' => {
- 'DISTRIBUTION' => 'WOLFSAGE/autouse-1.08.tar.gz',
+ 'DISTRIBUTION' => 'RJBS/autouse-1.11.tar.gz',
'FILES' => q[dist/autouse],
'EXCLUDED' => [qr{^t/release-.*\.t}],
},
},
'Config::Perl::V' => {
- 'DISTRIBUTION' => 'HMBRAND/Config-Perl-V-0.25.tgz',
+ 'DISTRIBUTION' => 'HMBRAND/Config-Perl-V-0.26.tgz',
'FILES' => q[cpan/Config-Perl-V],
'EXCLUDED' => [qw(
examples/show-v.pl
},
'DB_File' => {
- 'DISTRIBUTION' => 'PMQS/DB_File-1.835.tar.gz',
+ 'DISTRIBUTION' => 'PMQS/DB_File-1.838.tar.gz',
'FILES' => q[cpan/DB_File],
'EXCLUDED' => [
qr{^patches/},
},
'Digest::MD5' => {
- 'DISTRIBUTION' => 'GAAS/Digest-MD5-2.54.tar.gz',
+ 'DISTRIBUTION' => 'GAAS/Digest-MD5-2.55.tar.gz',
'FILES' => q[cpan/Digest-MD5],
'EXCLUDED' => ['rfc1321.txt'],
},
},
'IPC::Cmd' => {
- 'DISTRIBUTION' => 'BINGOS/IPC-Cmd-0.92.tar.gz',
+ 'DISTRIBUTION' => 'BINGOS/IPC-Cmd-0.94.tar.gz',
'FILES' => q[cpan/IPC-Cmd],
},
'IPC::SysV' => {
- 'DISTRIBUTION' => 'MHX/IPC-SysV-2.04.tar.gz',
+ 'DISTRIBUTION' => 'MHX/IPC-SysV-2.07.tar.gz',
'FILES' => q[cpan/IPC-SysV],
'EXCLUDED' => [
qw( const-c.inc
const-xs.inc
),
],
- 'CUSTOMIZED' => [
- # CPAN #118827
- qw(t/ipcsysv.t
- lib/IPC/Msg.pm
- lib/IPC/Semaphore.pm
- lib/IPC/SharedMem.pm
- lib/IPC/SysV.pm),
- ],
},
'JSON::PP' => {
},
'Locale-Codes' => {
- 'DISTRIBUTION' => 'SBECK/Locale-Codes-3.37.tar.gz',
+ 'DISTRIBUTION' => 'SBECK/Locale-Codes-3.38.tar.gz',
'FILES' => q[cpan/Locale-Codes],
'EXCLUDED' => [
qw( README.first
},
'Module::CoreList' => {
- 'DISTRIBUTION' => 'BINGOS/Module-CoreList-5.20160320.tar.gz',
+ 'DISTRIBUTION' => 'BINGOS/Module-CoreList-5.20160507.tar.gz',
'FILES' => q[dist/Module-CoreList],
},
},
'Module::Metadata' => {
- 'DISTRIBUTION' => 'ETHER/Module-Metadata-1.000031-TRIAL.tar.gz',
+ 'DISTRIBUTION' => 'ETHER/Module-Metadata-1.000032-TRIAL.tar.gz',
'FILES' => q[cpan/Module-Metadata],
'EXCLUDED' => [
qw(t/00-report-prereqs.t),
},
'perlfaq' => {
- 'DISTRIBUTION' => 'LLAP/perlfaq-5.021010.tar.gz',
+ 'DISTRIBUTION' => 'LLAP/perlfaq-5.021011.tar.gz',
'FILES' => q[cpan/perlfaq],
'EXCLUDED' => [
qw( inc/CreateQuestionList.pm
},
'Scalar-List-Utils' => {
- 'DISTRIBUTION' => 'PEVANS/Scalar-List-Utils-1.42.tar.gz',
+ 'DISTRIBUTION' => 'PEVANS/Scalar-List-Utils-1.45.tar.gz',
'FILES' => q[cpan/Scalar-List-Utils],
- # Waiting to be merged upstream:
- # https://github.com/Scalar-List-Utils/Scalar-List-Utils/pull/24
- # https://rt.cpan.org/Public/Bug/Display.html?id=105415
+ # Waiting to be merged upstream
+ # https://github.com/Scalar-List-Utils/Scalar-List-Utils/pull/42
'CUSTOMIZED' => [
qw( ListUtil.xs
lib/List/Util.pm
lib/List/Util/XS.pm
lib/Scalar/Util.pm
lib/Sub/Util.pm
- t/product.t
)
],
},
},
'Sys::Syslog' => {
- 'DISTRIBUTION' => 'SAPER/Sys-Syslog-0.33.tar.gz',
+ 'DISTRIBUTION' => 'SAPER/Sys-Syslog-0.34.tar.gz',
'FILES' => q[cpan/Sys-Syslog],
'EXCLUDED' => [
qr{^eg/},
},
'Term::ANSIColor' => {
- 'DISTRIBUTION' => 'RRA/Term-ANSIColor-4.04.tar.gz',
+ 'DISTRIBUTION' => 'RRA/Term-ANSIColor-4.05.tar.gz',
'FILES' => q[cpan/Term-ANSIColor],
'EXCLUDED' => [
qr{^examples/},
},
'threads' => {
- 'DISTRIBUTION' => 'JDHEDDEN/threads-2.07.tar.gz',
+ 'DISTRIBUTION' => 'JDHEDDEN/threads-2.08.tar.gz',
'FILES' => q[dist/threads],
'EXCLUDED' => [
qr{^examples/},
},
'threads::shared' => {
- 'DISTRIBUTION' => 'JDHEDDEN/threads-shared-1.51.tar.gz',
+ 'DISTRIBUTION' => 'JDHEDDEN/threads-shared-1.52.tar.gz',
'FILES' => q[dist/threads-shared],
'EXCLUDED' => [
qw( examples/class.pl
},
'Time::HiRes' => {
- 'DISTRIBUTION' => 'RJBS/Time-HiRes-1.9728.tar.gz',
+ 'DISTRIBUTION' => 'JHI/Time-HiRes-1.9733.tar.gz',
'FILES' => q[dist/Time-HiRes],
},
lib/overload{.pm,.t,64.t}
lib/perl5db.{pl,t}
lib/perl5db/
+ lib/perlbug.t
lib/sigtrap.{pm,t}
lib/sort.{pm,t}
lib/strict.{pm,t}
while (<$fh>) {
if ($_ =~ $re) {
++$matches;
- if (/[^[:^cntrl:]\h\v]/a) { # Matches non-spacing non-C1 controls
+ if (/[^[:^cntrl:]\h\v]/) { # Matches non-spacing non-C1 controls
print "Binary file $file matches\n";
} else {
$_ .= "\n" unless /\n\z/;
# Emulate noextensions if Configure doesn't support it.
fake_noextensions()
if $major < 10 && $defines{noextensions};
- system_or_die('./Configure -S');
+ if (system './Configure -S') {
+ # See commit v5.23.5-89-g7a4fcb3. Configure may try to run
+ # ./optdef.sh instead of UU/optdef.sh. Copying the file is
+ # easier than patching Configure (which mentions optdef.sh multi-
+ # ple times).
+ require File::Copy;
+ File::Copy::copy("UU/optdef.sh", "./optdef.sh");
+ system_or_die('./Configure -S');
+ }
}
if ($target =~ /config\.s?h/) {
ansi2knr=''
aphostname='/bin/hostname'
api_revision='5'
-api_subversion='0'
+api_subversion='1'
api_version='25'
-api_versionstring='5.25.0'
+api_versionstring='5.25.1'
ar='ar'
-archlib='/tmp/mblead/lib/perl5/5.25.0/darwin-2level'
-archlibexp='/tmp/mblead/lib/perl5/5.25.0/darwin-2level'
+archlib='/tmp/mblead/lib/perl5/5.25.1/darwin-2level'
+archlibexp='/tmp/mblead/lib/perl5/5.25.1/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.0/darwin-2level'
+installarchlib='/tmp/mblead/lib/perl5/5.25.1/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.0'
+installprivlib='/tmp/mblead/lib/perl5/5.25.1'
installscript='/tmp/mblead/bin'
-installsitearch='/tmp/mblead/lib/perl5/site_perl/5.25.0/darwin-2level'
+installsitearch='/tmp/mblead/lib/perl5/site_perl/5.25.1/darwin-2level'
installsitebin='/tmp/mblead/bin'
installsitehtml1dir=''
installsitehtml3dir=''
-installsitelib='/tmp/mblead/lib/perl5/site_perl/5.25.0'
+installsitelib='/tmp/mblead/lib/perl5/site_perl/5.25.1'
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.0'
+perlpath='/tmp/mblead/bin/perl5.25.1'
pg='pg'
phostname='hostname'
pidtype='pid_t'
pr=''
prefix='/tmp/mblead'
prefixexp='/tmp/mblead'
-privlib='/tmp/mblead/lib/perl5/5.25.0'
-privlibexp='/tmp/mblead/lib/perl5/5.25.0'
+privlib='/tmp/mblead/lib/perl5/5.25.1'
+privlibexp='/tmp/mblead/lib/perl5/5.25.1'
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.0/darwin-2level'
-sitearchexp='/tmp/mblead/lib/perl5/site_perl/5.25.0/darwin-2level'
+sitearch='/tmp/mblead/lib/perl5/site_perl/5.25.1/darwin-2level'
+sitearchexp='/tmp/mblead/lib/perl5/site_perl/5.25.1/darwin-2level'
sitebin='/tmp/mblead/bin'
sitebinexp='/tmp/mblead/bin'
sitehtml1dir=''
sitehtml1direxp=''
sitehtml3dir=''
sitehtml3direxp=''
-sitelib='/tmp/mblead/lib/perl5/site_perl/5.25.0'
+sitelib='/tmp/mblead/lib/perl5/site_perl/5.25.1'
sitelib_stem='/tmp/mblead/lib/perl5/site_perl'
-sitelibexp='/tmp/mblead/lib/perl5/site_perl/5.25.0'
+sitelibexp='/tmp/mblead/lib/perl5/site_perl/5.25.1'
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.0'
+startperl='#!/tmp/mblead/bin/perl5.25.1'
startsh='#!/bin/sh'
static_ext=' '
stdchar='char'
strerror_r_proto='0'
strings='/usr/include/string.h'
submit=''
-subversion='0'
+subversion='1'
sysman='/usr/share/man/man1'
sysroot=''
tail=''
vendorprefixexp=''
vendorscript=''
vendorscriptexp=''
-version='5.25.0'
-version_patchlevel_string='version 25 subversion 0'
+version='5.25.1'
+version_patchlevel_string='version 25 subversion 1'
versiononly='define'
vi=''
xlibpth='/usr/lib/386 /lib/386'
zip='zip'
PERL_REVISION=5
PERL_VERSION=25
-PERL_SUBVERSION=0
+PERL_SUBVERSION=1
PERL_API_REVISION=5
PERL_API_VERSION=25
-PERL_API_SUBVERSION=0
+PERL_API_SUBVERSION=1
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.0/i686-linux-64int-ld" /**/
-#define ARCHLIB_EXP "/pro/lib/perl5/5.25.0/i686-linux-64int-ld" /**/
+#define ARCHLIB "/pro/lib/perl5/5.25.1/i686-linux-64int-ld" /**/
+#define ARCHLIB_EXP "/pro/lib/perl5/5.25.1/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.0" /**/
-#define PRIVLIB_EXP "/pro/lib/perl5/5.25.0" /**/
+#define PRIVLIB "/pro/lib/perl5/5.25.1" /**/
+#define PRIVLIB_EXP "/pro/lib/perl5/5.25.1" /**/
/* 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.0/i686-linux-64int-ld" /**/
-#define SITEARCH_EXP "/pro/lib/perl5/site_perl/5.25.0/i686-linux-64int-ld" /**/
+#define SITEARCH "/pro/lib/perl5/site_perl/5.25.1/i686-linux-64int-ld" /**/
+#define SITEARCH_EXP "/pro/lib/perl5/site_perl/5.25.1/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.0" /**/
-#define SITELIB_EXP "/pro/lib/perl5/site_perl/5.25.0" /**/
+#define SITELIB "/pro/lib/perl5/site_perl/5.25.1" /**/
+#define SITELIB_EXP "/pro/lib/perl5/site_perl/5.25.1" /**/
#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.0" /**/
+#define STARTPERL "#!/pro/bin/perl5.25.1" /**/
/* HAS_STDIO_STREAM_ARRAY:
* This symbol, if defined, tells that there is an array
/(\.pm|_pm\.PL)$/ or return;
/PPPort\.pm$/ and return;
my $module = $File::Find::name;
- $module =~ /\b(demo|t|private)\b/ and return; # demo or test modules
+ $module =~ /\b(demo|t|private|corpus)\b/ and return; # demo or test modules
my $version = MM->parse_version($_);
defined $version or $version = 'undef';
$version =~ /\d/ and $version = "'$version'";
=head1 EPIGRAPHS
+=head2 v5.25.0 - Robert Frost, "The Trial by Existence"
+
+L<Announced on 2016-05-09 by Ricardo Signes|http://www.nntp.perl.org/group/perl.perl5.porters/2016/05/msg236244.html>
+
+ Even the bravest that are slain
+ Shall not dissemble their surprise
+ On waking to find valor reign,
+ Even as on earth, in paradise;
+ And where they sought without the sword
+ Wide fields of asphodel fore’er,
+ To find that the utmost reward
+ Of daring should be still to dare.
+
+=head2 v5.24.0 - Robert Frost, "The Black Cottage"
+
+L<Announced on 2016-05-09 by Ricardo Signes|http://www.nntp.perl.org/group/perl.perl5.porters/2016/05/msg236242.html>
+
+ As I sit here, and oftentimes, I wish
+ I could be monarch of a desert land
+ I could devote and dedicate forever
+ To the truths we keep coming back and back to.
+ So desert it would have to be, so walled
+ By mountain ranges half in summer snow,
+ No one would covet it or think it worth
+ The pains of conquering to force change on.
+ Scattered oases where men dwelt, but mostly
+ Sand dunes held loosely in tamarisk
+ Blown over and over themselves in idleness.
+ Sand grains should sugar in the natal dew
+ The babe born to the desert, the sand storm
+ Retard mid-waste my cowering caravans—
+
+ “There are bees in this wall.” He struck the clapboards,
+ Fierce heads looked out; small bodies pivoted.
+ We rose to go. Sunset blazed on the windows.
+
+=head2 v5.24.0-RC5 - The Mountain Goats, "No Children"
+
+L<Announced on 2016-05-04 by Ricardo Signes|http://www.nntp.perl.org/group/perl.perl5.porters/2016/05/msg236198.html>
+
+ And I hope when you think of me years down the line
+ You can't find one good thing to say
+ And I'd hope that if I found the strength to walk out
+ You'd stay the hell out of my way
+
+ I am drowning, there is no sign of land
+ You are coming down with me, hand in unlovable hand
+
+=head2 v5.24.0-RC4 - The Joker in "The Killing Joke"
+
+L<Announced on 2016-05-02 by Ricardo Signes|http://www.nntp.perl.org/group/perl.perl5.porters/2016/05/msg236145.html>
+
+"See, there were these two guys in a lunatic asylum…"
+
+=head2 v5.24.0-RC3 - Jesse Vincent
+
+L<Announced on 2016-04-27 by Ricardo Signes|http://www.nntp.perl.org/group/perl.perl5.porters/2016/04/msg236066.html>
+
+The Great Pumpkin is a Santa-Claus like figure. He does bring toys like
+Santa. But unlike Santa, who gives away toys because it's his job, he
+gives away toys because it's the right thing to do.
+
+=head2 v5.24.0-RC2 - Joseph Heller, "Catch-22"
+
+L<Announced on 2016-04-23 by Ricardo Signes|http://www.nntp.perl.org/group/perl.perl5.porters/2016/04/msg235999.html>
+
+“How do you feel, Yossarian?”
+
+“Fine. No, I’m very frightened.”
+
+“That’s good,” said Major Danby. “It proves you’re still alive. It won’t
+be fun.”
+
+Yossarian started out. “Yes it will.”
+
+“I mean it, Yossarian. You’ll have to keep on your toes every minute of
+every day. They’ll bend heaven and earth to catch you.”
+
+“I’ll keep on my toes every minute.”
+
+“You’ll have to jump.”
+
+“I’ll jump.”
+
+“Jump!” Major Danby cried.
+
+Yossarian jumped.
+
+Nately’s [girl] was hiding just outside the door. The knife came down,
+missing him by inches, and he took off.
+
+=head2 v5.24.0-RC1 - Robert Frost, "The Census-Taker"
+
+L<Announced on 2016-04-14 by Ricardo Signes|http://www.nntp.perl.org/group/perl.perl5.porters/2016/04/msg235807.html>
+
+ Nothing was left to do that I could see
+ Unless to find that there was no one there
+ And declare to the cliffs too far for echo,
+ "The place is desert, and let whoso lurks
+ In silence, if in this he is aggrieved,
+ Break silence now or be forever silent.
+ Let him say why it should not be declared so."
+ The melancholy of having to count souls
+ Where they grow fewer and fewer every year
+ Is extreme where they shrink to none at all.
+ It must be I want life to go on living.
+
=head2 v5.23.9 - Tom Kitchin, "from nature to plate"
L<Announced on 2016-03-20 by Abigail|http://www.nntp.perl.org/group/perl.perl5.porters/2016/03/msg235251.html>
XXX Generate this with:
- perl Porting/acknowledgements.pl v5.25.0..HEAD
+ perl Porting/acknowledgements.pl v5.25.1..HEAD
=head1 Reporting Bugs
and maint are synchronised with a particular CPAN module, but one might
have some extra changes.
-=head3 How to sync a CPAN module with a cpan/ distro
+=head3 How to sync a CPAN module with a cpanE<sol> distro
=over 4
=item *
For any new files in the distro, determine whether they are needed.
-If not, delete them, and list them in either C<EXCLUDED> or C<@INGORE>.
+If not, delete them, and list them in either C<EXCLUDED> or C<@IGNORABLE>.
Otherwise, add them to C<MANIFEST>, and run C<git add> to add the files
to the repository.
release is performing compared to previous releases with regard to building
and testing CPAN modules.
+That page accepts a query parameter, C<pair> that takes a pair of
+colon-delimited versions to use for comparison. For example:
+
+http://analysis.cpantesters.org/beforemaintrelease?pair=5.20.2:5.22.0%20RC1
+
=head3 update perldelta
Get perldelta in a mostly finished state.
of Perl. Dates with two or more question marks will only be releases if
deemed necessary by the Pumpking.
-=head2 Perl 5.24
+=head2 Perl 5.26
+
+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-02-20 5.25.10 Full code freeze
+ 2017-04-20 5.26.0 Stable release!
-Code freezes (which happen in the 5.23.X series)
+=head2 Perl 5.24
- 2016-01-20 5.23.7 ✓ Contentious changes freeze
- 2016-02-20 5.23.8 ✓ User-visible changes freeze
- 2016-03-20 5.23.9 ✓ Full code freeze
- 2016-05-20 5.24.0 Stable release!
+ 2016-05-09 5.24.0 ✓ Ricardo Signes
+ 2016-07-?? 5.24.1 ??
=head2 Perl 5.22
2016-04-29 5.22.2 ✓ Steve Hay
2016-??-?? 5.22.3 ??
-=head2 Perl 5.20
-
- 2014-05-27 5.20.0 ✓ Ricardo Signes
- 2014-09-14 5.20.1 ✓ Steve Hay
- 2015-02-14 5.20.2 ✓ Steve Hay
- 2015-09-12 5.20.3 ✓ Steve Hay
- 2016-??-?? 5.20.4 ??
-
=head1 DEVELOPMENT RELEASE SCHEDULE
This schedule lists the release engineers for at least the next
the next four releases. If a stable version of Perl is released,
you should reset the version numbers to the next blead series.
-=head2 Perl 5.23
-
- 2015-06-20 5.23.0 ✓ Ricardo Signes
- 2015-07-20 5.23.1 ✓ Matthew Horsfall
- 2015-08-20 5.23.2 ✓ Matthew Horsfall
- 2015-09-20 5.23.3 ✓ Peter Martini
- 2015-10-20 5.23.4 ✓ Steve Hay
- 2015-11-20 5.23.5 ✓ Abigail
- 2015-12-20 5.23.6 ✓ David Golden
- 2016-01-20 5.23.7 ✓ Stevan Little
- 2016-02-20 5.23.8 ✓ Sawyer X
- 2016-03-20 5.23.9 ✓ Abigail
-
-(RC0 for 5.24.0 will be released once we think that all the blockers have been
-addressed. This typically means some time in April or May.)
-
=head2 Perl 5.25
- 2016-05-20 5.25.0 Ricardo Signes
- 2016-06-20 5.25.1 Matthew Horsfall
- 2016-07-20 5.25.2 Steve Hay
- 2016-08-20 5.25.3 BinGOs
- 2016-09-20 5.25.4 Stevan Little
- 2016-10-20 5.25.5 Sawyer X
- 2016-11-20 5.25.6 ?
- 2016-12-20 5.25.7 ?
-
-(RC0 for 5.24.0 will be released once we think that all the blockers have been
+ 2016-04-08 5.25.0 ✓ Ricardo Signes
+ 2016-05-20 5.25.1 Sawyer X
+ 2016-06-20 5.25.2 Matthew Horsfall
+ 2016-07-20 5.25.3 Steve Hay
+ 2016-08-20 5.25.4 BinGOs
+ 2016-09-20 5.25.5 Stevan Little
+ 2016-10-20 5.25.6 Sawyer X
+ 2016-11-20 5.25.7 Aaron Crane
+ 2016-12-20 5.25.8 ?
+
+(RC0 for 5.26.0 will be released once we think that all the blockers have been
addressed. This typically means some time in April or May.)
=head1 VICTIMS
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.0.
+options would be nice for perl 5.25.1.
=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.0"
+of 5.25.1"
=head2 make ithreads more robust
(see http://www.freebsd.org/cgi/query-pr.cgi?pr=misc/30631 )
which has been integrated into FreeBSD 4.6.
-=head2 $^X doesn't always contain a full path in FreeBSD
+=head2 C<$^X> doesn't always contain a full path in FreeBSD
perl sets C<$^X> where possible to a full path by asking the operating
system. On FreeBSD the full path of the perl interpreter is found by using
C<sysctl> with C<KERN_PROC_PATHNAME> if that is supported, else by reading
the symlink F</proc/curproc/file>. FreeBSD 7 and earlier has a bug where
either approach sometimes returns an incorrect value
-(see http://www.freebsd.org/cgi/query-pr.cgi?pr=35703 ).
+(see L<http://www.freebsd.org/cgi/query-pr.cgi?pr=35703> ).
In these cases perl will fall back to the old behaviour of using C's
-argv[0] value for C<$^X>.
+C<argv[0]> value for C<$^X>.
=head1 AUTHOR
Nicholas Clark <nick@ccl4.org>, collating wisdom supplied by Slaven Rezic
and Tim Bunce.
-Please report any errors, updates, or suggestions to F<perlbug@perl.org>.
+Please report any errors, updates, or suggestions to L<mailto:perlbug@perl.org>.
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.0/BePC-haiku/CORE/libperl.so .
+ cd /boot/common/lib; ln -s perl5/5.25.1/BePC-haiku/CORE/libperl.so .
-Replace C<5.25.0> with your respective version of Perl.
+Replace C<5.25.1> 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.0.tar.gz
- tar -xzf perl-5.25.0.tar.gz
- cd perl-5.25.0
+ curl -O http://www.cpan.org/src/perl-5.25.1.tar.gz
+ tar -xzf perl-5.25.1.tar.gz
+ cd perl-5.25.1
./Configure -des -Dprefix=/usr/local/
make
make test
=head1 DESCRIPTION
-The latest Perl release (5.25.0 as of this writing) builds without changes
+The latest Perl release (5.25.1 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.0/
+ unzip perl_ste.zip -d f:/perllib/lib/site_perl/5.25.1/
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^.0.tar
+ vmstar -xvf perl-5^.25^.1.tar
Then set default to the top-level source directory like so:
- set default [.perl-5^.25^.0]
+ set default [.perl-5^.25^.1]
and proceed with configuration as described in the next section.
* 1a0687fb9c6c4567e853913549df0944fe40821279a3e9cdaa6ab8679bc286fd lib/unicore/extracted/DLineBreak.txt
* 40bcfed3ca727c19e1331f6c33806231d5f7eeeabd2e6a9e06a3740c85d0c250 lib/unicore/extracted/DNumType.txt
* a18d502bad39d527ac5586d7bc93e29f565859e3bcc24ada627eff606d6f5fed lib/unicore/extracted/DNumValues.txt
- * 285aef7ed2bf69724b1fa9bba177640636f666e1a5dd0ba5e538d4790129bbfe lib/unicore/mktables
+ * 718d6ea8b96ee3d12c9c3a48ceb0f5cebe023634002ac8b2ede12b306273aa52 lib/unicore/mktables
* 462c9aaa608fb2014cd9649af1c5c009485c60b9c8b15b89401fdc10cf6161c6 lib/unicore/version
* 913d2f93f3cb6cdf1664db888bf840bc4eb074eef824e082fceda24a9445e60c regen/charset_translations.pl
* 12bd58cb9d5a99f631ca95e269f7f9c90dacaf81020efa5d95a995f3cdc19200 regen/mk_invlists.pl
$DEBUG = 0;
$WARN = 1;
$FOLLOW_SYMLINK = 0;
-$VERSION = "2.04";
+$VERSION = "2.08";
$CHOWN = 1;
$CHMOD = 1;
$SAME_PERMISSIONS = $> == 0 ? 1 : 0;
BEGIN {
require Exporter;
- $VERSION = '2.04';
+ $VERSION = '2.08';
@ISA = qw[Exporter];
require Time::Local if $^O eq "MacOS";
use constant STRIP_MODE => sub { shift() & 0777 };
use constant CHECK_SUM => " ";
-use constant UNPACK => 'A100 A8 A8 A8 a12 A12 A8 A1 A100 A6 A2 A32 A32 A8 A8 A155 x12'; # cdrake - size must be a12 - not A12 - or else screws up huge file sizes (>8gb)
+use constant UNPACK => 'a100 a8 a8 a8 a12 a12 a8 a1 a100 A6 a2 a32 a32 a8 a8 a155 x12'; # cdrake - size must be a12 - not A12 - or else screws up huge file sizes (>8gb)
use constant PACK => 'a100 a8 a8 a8 a12 a12 A8 a1 a100 a6 a2 a32 a32 a8 a8 a155 x12';
use constant NAME_LENGTH => 100;
use constant PREFIX_LENGTH => 155;
use vars qw[@ISA $VERSION];
#@ISA = qw[Archive::Tar];
-$VERSION = '2.04';
+$VERSION = '2.08';
### set value to 1 to oct() it during the unpack ###
--- /dev/null
+BEGIN { chdir 't' if -d 't' }
+
+use Test::More;
+use strict;
+use lib '../lib';
+
+use File::Spec ();
+use File::Temp qw( tempfile );
+
+use Archive::Tar;
+
+# tarballs available for testing
+my @archives = (
+ [qw( src short bar.tar )],
+ [qw( src long bar.tar )],
+ [qw( src linktest linktest_with_dir.tar )],
+);
+push @archives,
+ [qw( src short foo.tgz )],
+ [qw( src long foo.tgz )]
+ if Archive::Tar->has_zlib_support;
+push @archives,
+ [qw( src short foo.tbz )],
+ [qw( src long foo.tbz )]
+ if Archive::Tar->has_bzip2_support;
+
+@archives = map File::Spec->catfile(@$_), @archives;
+
+plan tests => scalar @archives;
+
+# roundtrip test
+for my $archive (@archives) {
+
+ # create a new tarball with the same content as the old one
+ my $old = Archive::Tar->new($archive);
+ my $new = Archive::Tar->new();
+ $new->add_files( $old->get_files );
+
+ # save differently if compressed
+ my $ext = ( split /\./, $archive )[-1];
+ my @compress =
+ $ext =~ /t?gz$/ ? (COMPRESS_GZIP)
+ : $ext =~ /(tbz|bz2?)$/ ? (COMPRESS_BZIP)
+ : ();
+
+ my ( $fh, $filename ) = tempfile( UNLINK => 1 );
+ $new->write( $filename, @compress );
+
+ # read the archive again from disk
+ $new = Archive::Tar->new($filename);
+
+ TODO: {
+ local $TODO = 'Need to work out why no trailing slash';
+
+ # compare list of files
+ is_deeply(
+ [ $new->list_files ],
+ [ $old->list_files ],
+ "$archive roundtrip on file names"
+ );
+ };
+}
use Config;
use Exporter;
use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS);
-$VERSION = "0.25";
+$VERSION = "0.26";
@ISA = ("Exporter");
@EXPORT_OK = qw( plv2hash summary myconfig signature );
%EXPORT_TAGS = (
PERL_RELOCATABLE_INCPUSH
PERL_USE_DEVEL
PERL_USE_SAFE_PUTENV
+ SILENT_NO_TAINT_SUPPORT
UNLINK_ALL_VERSIONS
USE_ATTRIBUTES_FOR_PERLIO
USE_FAST_STDIO
$config{git_commit_id} = $2;
}
+ # these are always last on line and can have multiple quotation styles
+ for my $k (qw( ccflags ldflags lddlflags )) {
+ $pv =~ s{, \s* $k \s*=\s* (.*) \s*$}{}mx or next;
+ my $v = $1;
+ $v =~ s/\s*,\s*$//;
+ $v =~ s/^(['"])(.*)\1$/$2/;
+ $config{$k} = $v;
+ }
+
if (my %kv = ($pv =~ m{\b
(\w+) # key
\s*= # assign
=head1 COPYRIGHT AND LICENSE
-Copyright (C) 2009-2015 H.Merijn Brand
+Copyright (C) 2009-2016 H.Merijn Brand
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
BEGIN {
use Test::More;
- my $tests = 95;
+ my $tests = 96;
unless ($ENV{PERL_CORE}) {
require Test::NoWarnings;
Test::NoWarnings->import ();
BEGIN {
use Test::More;
- my $tests = 95;
+ my $tests = 96;
unless ($ENV{PERL_CORE}) {
require Test::NoWarnings;
Test::NoWarnings->import ();
BEGIN {
use Test::More;
- my $tests = 94;
+ my $tests = 95;
unless ($ENV{PERL_CORE}) {
require Test::NoWarnings;
Test::NoWarnings->import ();
BEGIN {
use Test::More;
- my $tests = 96;
+ my $tests = 97;
unless ($ENV{PERL_CORE}) {
require Test::NoWarnings;
Test::NoWarnings->import ();
BEGIN {
use Test::More;
- my $tests = 96;
+ my $tests = 97;
unless ($ENV{PERL_CORE}) {
require Test::NoWarnings;
Test::NoWarnings->import ();
BEGIN {
use Test::More;
- my $tests = 95;
+ my $tests = 96;
unless ($ENV{PERL_CORE}) {
require Test::NoWarnings;
Test::NoWarnings->import ();
BEGIN {
use Test::More;
- my $tests = 153;
+ my $tests = 154;
unless ($ENV{PERL_CORE}) {
require Test::NoWarnings;
Test::NoWarnings->import ();
BEGIN {
use Test::More;
- my $tests = 114;
+ my $tests = 115;
unless ($ENV{PERL_CORE}) {
require Test::NoWarnings;
Test::NoWarnings->import ();
BEGIN {
use Test::More;
- my $tests = 114;
+ my $tests = 115;
unless ($ENV{PERL_CORE}) {
require Test::NoWarnings;
Test::NoWarnings->import ();
BEGIN {
use Test::More;
- my $tests = 114;
+ my $tests = 115;
unless ($ENV{PERL_CORE}) {
require Test::NoWarnings;
Test::NoWarnings->import ();
BEGIN {
use Test::More;
- my $tests = 115;
+ my $tests = 116;
unless ($ENV{PERL_CORE}) {
require Test::NoWarnings;
Test::NoWarnings->import ();
BEGIN {
use Test::More;
- my $tests = 115;
+ my $tests = 116;
unless ($ENV{PERL_CORE}) {
require Test::NoWarnings;
Test::NoWarnings->import ();
BEGIN {
use Test::More;
- my $tests = 115;
+ my $tests = 116;
unless ($ENV{PERL_CORE}) {
require Test::NoWarnings;
Test::NoWarnings->import ();
--- /dev/null
+#!/pro/bin/perl
+
+use strict;
+use warnings;
+
+BEGIN {
+ use Test::More;
+ my $tests = 116;
+ unless ($ENV{PERL_CORE}) {
+ require Test::NoWarnings;
+ Test::NoWarnings->import ();
+ $tests++;
+ }
+
+ plan tests => $tests;
+ }
+
+use Config::Perl::V;
+
+ok (my $conf = Config::Perl::V::plv2hash (<DATA>), "Read perl -v block");
+ok (exists $conf->{$_}, "Has $_ entry") for qw( build environment config inc );
+
+is ($conf->{build}{osname}, $conf->{config}{osname}, "osname");
+is ($conf->{build}{stamp}, "Nov 19 2015 00:18:50", "Build time");
+is ($conf->{config}{version}, "5.23.5", "reconstructed \$Config{version}");
+
+my $opt = Config::Perl::V::plv2hash ("")->{build}{options};
+foreach my $o (sort qw(
+ HAS_TIMES HAVE_INTERP_INTERN MULTIPLICITY PERLIO_LAYERS
+ PERL_COPY_ON_WRITE PERL_DONT_CREATE_GVSV
+ PERL_HASH_FUNC_ONE_AT_A_TIME_HARD
+ PERL_IMPLICIT_CONTEXT PERL_IMPLICIT_SYS PERL_MALLOC_WRAP
+ PERL_PRESERVE_IVUV
+ USE_ITHREADS
+ USE_LARGE_FILES USE_LOCALE USE_LOCALE_COLLATE
+ USE_LOCALE_CTYPE USE_LOCALE_NUMERIC USE_LOCALE_TIME
+ USE_PERLIO USE_PERL_ATOF
+ )) {
+ is ($conf->{build}{options}{$o}, 1, "Runtime option $o set");
+ delete $opt->{$o};
+ }
+foreach my $o (sort keys %$opt) {
+ is ($conf->{build}{options}{$o}, 0, "Runtime option $o unset");
+ }
+
+is_deeply ($conf->{build}{patches}, [], "No local patches");
+
+my %check = (
+ alignbytes => 8,
+ api_version => 23,
+ bincompat5005 => "undef",
+ byteorder => 1234,
+ cc => "cl",
+ cccdlflags => "",
+ ccdlflags => "",
+ config_args => "undef",
+ gccversion => "",
+ gnulibc_version => "",
+ ivsize => 4,
+ ivtype => "long",
+ ld => "link",
+ lddlflags => q{-dll -nologo -nodefaultlib -debug -opt:ref,icf -ltcg -libpath:"c:\perl\lib\CORE" -machine:x86 "/manifestdependency:type='Win32' name='Microsoft.Windows.Common-Controls' version='6.0.0.0' processorArchitecture='*' publicKeyToken='6595b64144ccf1df' language='*'" -subsystem:console,"5.01"},
+ ldflags => q{-nologo -nodefaultlib -debug -opt:ref,icf -ltcg -libpath:"c:\perl\lib\CORE" -machine:x86 "/manifestdependency:type='Win32' name='Microsoft.Windows.Common-Controls' version='6.0.0.0' processorArchitecture='*' publicKeyToken='6595b64144ccf1df' language='*'" -subsystem:console,"5.01"},
+ libc => "msvcrt.lib",
+ lseektype => "__int64",
+ osvers => "6.1",
+ use64bitall => "undef",
+ use64bitint => "undef",
+ );
+is ($conf->{config}{$_}, $check{$_}, "reconstructed \$Config{$_}") for sort keys %check;
+
+__END__
+Summary of my perl5 (revision 5 version 23 subversion 5) configuration:
+
+ Platform:
+ osname=MSWin32, osvers=6.1, archname=MSWin32-x86-multi-thread
+ uname=''
+ config_args='undef'
+ hint=recommended, useposix=true, d_sigaction=undef
+ useithreads=define, usemultiplicity=define
+ use64bitint=undef, use64bitall=undef, uselongdouble=undef
+ usemymalloc=n, bincompat5005=undef
+ Compiler:
+ cc='cl', ccflags ='-nologo -GF -W3 -O1 -MD -Zi -DNDEBUG -GL -DWIN32 -D_CONSOLE -DNO_STRICT -D_CRT_SECURE_NO_DEPRECATE -D_CRT_NONSTDC_NO_DEPRECATE -DPERL_TEXTMODE_SCRIPTS -DPERL_IMPLICIT_CONTEXT -DPERL_IMPLICIT_SYS',
+ optimize='-O1 -MD -Zi -DNDEBUG -GL',
+ cppflags='-DWIN32'
+ ccversion='18.00.31101', gccversion='', gccosandvers=''
+ intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=1234, doublekind=3
+ d_longlong=undef, longlongsize=8, d_longdbl=define, longdblsize=8, longdblkind=0
+ ivtype='long', ivsize=4, nvtype='double', nvsize=8, Off_t='__int64', lseeksize=8
+ alignbytes=8, prototype=define
+ Linker and Libraries:
+ ld='link', ldflags ='-nologo -nodefaultlib -debug -opt:ref,icf -ltcg -libpath:"c:\perl\lib\CORE" -machine:x86 "/manifestdependency:type='Win32' name='Microsoft.Windows.Common-Controls' version='6.0.0.0' processorArchitecture='*' publicKeyToken='6595b64144ccf1df' language='*'" -subsystem:console,"5.01"'
+ libpth=\lib
+ libs=oldnames.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib netapi32.lib uuid.lib ws2_32.lib mpr.lib winmm.lib version.lib odbc32.lib odbccp32.lib comctl32.lib msvcrt.lib
+ perllibs=oldnames.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib netapi32.lib uuid.lib ws2_32.lib mpr.lib winmm.lib version.lib odbc32.lib odbccp32.lib comctl32.lib msvcrt.lib
+ libc=msvcrt.lib, so=dll, useshrplib=true, libperl=perl523.lib
+ gnulibc_version=''
+ Dynamic Linking:
+ dlsrc=dl_win32.xs, dlext=dll, d_dlsymun=undef, ccdlflags=' '
+ cccdlflags=' ', lddlflags='-dll -nologo -nodefaultlib -debug -opt:ref,icf -ltcg -libpath:"c:\perl\lib\CORE" -machine:x86 "/manifestdependency:type='Win32' name='Microsoft.Windows.Common-Controls' version='6.0.0.0' processorArchitecture='*' publicKeyToken='6595b64144ccf1df' language='*'" -subsystem:console,"5.01"'
+
+
+Characteristics of this binary (from libperl):
+ Compile-time options: HAS_TIMES HAVE_INTERP_INTERN MULTIPLICITY
+ PERLIO_LAYERS PERL_COPY_ON_WRITE
+ PERL_DONT_CREATE_GVSV
+ PERL_HASH_FUNC_ONE_AT_A_TIME_HARD
+ PERL_IMPLICIT_CONTEXT PERL_IMPLICIT_SYS
+ PERL_MALLOC_WRAP PERL_PRESERVE_IVUV USE_ITHREADS
+ USE_LARGE_FILES USE_LOCALE USE_LOCALE_COLLATE
+ USE_LOCALE_CTYPE USE_LOCALE_NUMERIC USE_LOCALE_TIME
+ USE_PERLIO USE_PERL_ATOF
+ Built under MSWin32
+ Compiled at Nov 19 2015 00:18:50
+ @INC:
+ C:/p523/src/lib
+ .
--- /dev/null
+#!/pro/bin/perl
+
+use strict;
+use warnings;
+
+BEGIN {
+ use Test::More;
+ my $tests = 116;
+ unless ($ENV{PERL_CORE}) {
+ require Test::NoWarnings;
+ Test::NoWarnings->import ();
+ $tests++;
+ }
+
+ plan tests => $tests;
+ }
+
+use Config::Perl::V;
+
+ok (my $conf = Config::Perl::V::plv2hash (<DATA>), "Read perl -v block");
+ok (exists $conf->{$_}, "Has $_ entry") for qw( build environment config inc );
+
+is ($conf->{build}{osname}, $conf->{config}{osname}, "osname");
+is ($conf->{build}{stamp}, "May 10 2016 15:39:18", "Build time");
+is ($conf->{config}{version}, "5.24.0", "reconstructed \$Config{version}");
+
+my $opt = Config::Perl::V::plv2hash ("")->{build}{options};
+foreach my $o (sort qw(
+ DEBUGGING HAS_TIMES MULTIPLICITY PERLIO_LAYERS PERL_COPY_ON_WRITE
+ PERL_DONT_CREATE_GVSV PERL_HASH_FUNC_ONE_AT_A_TIME_HARD
+ PERL_TRACK_MEMPOOL PERL_IMPLICIT_CONTEXT PERL_MALLOC_WRAP
+ PERL_PRESERVE_IVUV USE_64_BIT_ALL USE_64_BIT_INT USE_ITHREADS
+ USE_LARGE_FILES USE_LOCALE USE_LOCALE_COLLATE
+ USE_LOCALE_CTYPE USE_LOCALE_NUMERIC USE_LOCALE_TIME
+ USE_LONG_DOUBLE USE_PERLIO USE_PERL_ATOF USE_REENTRANT_API
+ )) {
+ is ($conf->{build}{options}{$o}, 1, "Runtime option $o set");
+ delete $opt->{$o};
+ }
+foreach my $o (sort keys %$opt) {
+ is ($conf->{build}{options}{$o}, 0, "Runtime option $o unset");
+ }
+
+is_deeply ($conf->{build}{patches}, [], "No local patches");
+
+my %check = (
+ alignbytes => 16,
+ api_version => 24,
+ bincompat5005 => "undef",
+ byteorder => 12345678,
+ cc => "cc",
+ cccdlflags => "-fPIC",
+ ccdlflags => "-Wl,-E",
+ config_args => "-Duse64bitall -Duselongdouble -Dusethreads -Duseithreads -des",
+ gccversion => "5.3.1 20160412 [gcc-5-branch revision 234894]",
+ gnulibc_version => "2.23",
+ ivsize => 8,
+ ivtype => "long",
+ ld => "cc",
+ lddlflags => "-shared -O2 -L/pro/local/lib -fstack-protector-strong",
+ ldflags => "-L/pro/local/lib -fstack-protector-strong",
+ libc => "libc-2.23.so",
+ lseektype => "off_t",
+ osvers => "4.5.2-1-default",
+ use64bitall => "define",
+ use64bitint => "define",
+ );
+is ($conf->{config}{$_}, $check{$_}, "reconstructed \$Config{$_}") for sort keys %check;
+
+__END__
+Summary of my perl5 (revision 5 version 24 subversion 0) configuration:
+
+ Platform:
+ osname=linux, osvers=4.5.2-1-default, archname=x86_64-linux-thread-multi-ld
+ uname='linux lx09 4.5.2-1-default #1 smp preempt thu apr 21 09:07:52 utc 2016 (0454a6e) x86_64 x86_64 x86_64 gnulinux '
+ config_args='-Duse64bitall -Duselongdouble -Dusethreads -Duseithreads -des'
+ hint=recommended, useposix=true, d_sigaction=define
+ useithreads=define, usemultiplicity=define
+ use64bitint=define, use64bitall=define, uselongdouble=define
+ usemymalloc=n, bincompat5005=undef
+ Compiler:
+ cc='cc', ccflags ='-D_REENTRANT -D_GNU_SOURCE -fPIC -DDEBUGGING -fwrapv -fno-strict-aliasing -pipe -fstack-protector-strong -I/pro/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -D_FORTIFY_SOURCE=2',
+ optimize='-O2',
+ cppflags='-D_REENTRANT -D_GNU_SOURCE -fPIC -DDEBUGGING -fwrapv -fno-strict-aliasing -pipe -fstack-protector-strong -I/pro/local/include'
+ ccversion='', gccversion='5.3.1 20160412 [gcc-5-branch revision 234894]', gccosandvers=''
+ intsize=4, longsize=8, ptrsize=8, doublesize=8, byteorder=12345678, doublekind=3
+ d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=16, longdblkind=3
+ ivtype='long', ivsize=8, nvtype='long double', nvsize=16, Off_t='off_t', lseeksize=8
+ alignbytes=16, prototype=define
+ Linker and Libraries:
+ ld='cc', ldflags ='-L/pro/local/lib -fstack-protector-strong'
+ libpth=/usr/local/lib /usr/lib64/gcc/x86_64-suse-linux/5/include-fixed /usr/lib64/gcc/x86_64-suse-linux/5/../../../../x86_64-suse-linux/lib /usr/lib /pro/local/lib /lib/../lib64 /usr/lib/../lib64 /lib /lib64 /usr/lib64 /usr/local/lib64
+ libs=-lpthread -lnsl -lgdbm -ldb -ldl -lm -lcrypt -lutil -lc -lgdbm_compat
+ perllibs=-lpthread -lnsl -ldl -lm -lcrypt -lutil -lc
+ libc=libc-2.23.so, so=so, useshrplib=false, libperl=libperl.a
+ gnulibc_version='2.23'
+ Dynamic Linking:
+ dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-Wl,-E'
+ cccdlflags='-fPIC', lddlflags='-shared -O2 -L/pro/local/lib -fstack-protector-strong'
+
+
+Characteristics of this binary (from libperl):
+ Compile-time options: DEBUGGING HAS_TIMES MULTIPLICITY PERLIO_LAYERS
+ PERL_COPY_ON_WRITE PERL_DONT_CREATE_GVSV
+ PERL_HASH_FUNC_ONE_AT_A_TIME_HARD
+ PERL_IMPLICIT_CONTEXT PERL_MALLOC_WRAP
+ PERL_PRESERVE_IVUV PERL_TRACK_MEMPOOL USE_64_BIT_ALL
+ USE_64_BIT_INT USE_ITHREADS USE_LARGE_FILES
+ USE_LOCALE USE_LOCALE_COLLATE USE_LOCALE_CTYPE
+ USE_LOCALE_NUMERIC USE_LOCALE_TIME USE_LONG_DOUBLE
+ USE_PERLIO USE_PERL_ATOF USE_REENTRANT_API
+ Built under linux
+ Compiled at May 10 2016 15:39:18
+ @INC:
+ lib
+ /pro/lib/perl5/site_perl/5.24.0/x86_64-linux-thread-multi-ld
+ /pro/lib/perl5/site_perl/5.24.0
+ /pro/lib/perl5/5.24.0/x86_64-linux-thread-multi-ld
+ /pro/lib/perl5/5.24.0
+ .
#
# Written by Paul Marquess (pmqs@cpan.org)
#
-# Copyright (c) 1995-2014 Paul Marquess. All rights reserved.
+# Copyright (c) 1995-2016 Paul Marquess. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
use Carp;
-$VERSION = "1.835" ;
+$VERSION = "1.838" ;
$VERSION = eval $VERSION; # needed for dev releases
{
=head1 DBM FILTERS
-A DBM Filter is a piece of code that is be used when you I<always>
-want to make the same transformation to all keys and/or values in a
-DBM database.
+A DBM Filter is a piece of code that is be used when you I<always> want to
+make the same transformation to all keys and/or values in a DBM database.
+An example is when you need to encode your data in UTF-8 before writing to
+the database and then decode the UTF-8 when reading from the database file.
+
+There are two ways to use a DBM Filter.
+
+=over 5
+
+=item 1.
+
+Using the low-level API defined below.
+
+=item 2.
+
+Using the L<DBM_Filter> module.
+This module hides the complexity of the API defined below and comes
+with a number of "canned" filters that cover some of the common use-cases.
+
+=back
+
+Use of the L<DBM_Filter> module is recommended.
+
+=head2 DBM Filter Low-level API
There are four methods associated with DBM Filters. All work identically,
and each is used to install (or uninstall) a single DBM Filter. Each
Check out the MLDBM module, available on CPAN in the directory
F<modules/by-module/MLDBM>.
+=head2 What does "wide character in subroutine entry" mean?
+
+You will usually get this message if you are working with UTF-8 data and
+want to read/write it from/to a Berkeley DB database file.
+
+The easist way to deal with this issue is to use the pre-defined "utf8"
+B<DBM_Filter> (see L<DBM_Filter>) that was designed to deal with this
+situation.
+
+The example below shows what you need if I<both> the key and value are
+expected to be in UTF-8.
+
+ use DB_File;
+ use DBM_Filter;
+
+ my $db = tie %h, 'DB_File', '/tmp/try.db', O_CREAT|O_RDWR, 0666, $DB_BTREE;
+ $db->Filter_Key_Push('utf8');
+ $db->Filter_Value_Push('utf8');
+
+ my $key = "\N{LATIN SMALL LETTER A WITH ACUTE}";
+ my $value = "\N{LATIN SMALL LETTER E WITH ACUTE}";
+ $h{ $key } = $value;
+
=head2 What does "Invalid Argument" mean?
You will get this error message when one of the parameters in the
=head1 COPYRIGHT
-Copyright (c) 1995-2012 Paul Marquess. All rights reserved. This program
+Copyright (c) 1995-2016 Paul Marquess. All rights reserved. This program
is free software; you can redistribute it and/or modify it under the
same terms as Perl itself.
=head1 SEE ALSO
L<perl>, L<dbopen(3)>, L<hash(3)>, L<recno(3)>, L<btree(3)>,
-L<perldbmfilter>
+L<perldbmfilter>, L<DBM_Filter>
=head1 AUTHOR
All comments/suggestions/problems are welcome
- Copyright (c) 1995-2014 Paul Marquess. All rights reserved.
+ Copyright (c) 1995-2016 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5
# define R_SETCURSOR 0x800000
#else
-# define R_SETCURSOR (-100)
+# define R_SETCURSOR (DB_OPFLAGS_MASK)
#endif
#define R_RECNOSYNC 0
if (flagSet(flags, R_CURSOR)) {
return ((db->cursor)->c_put)(db->cursor, &key, &value, DB_CURRENT);
}
-
if (flagSet(flags, R_SETCURSOR)) {
if ((db->dbp)->put(db->dbp, NULL, &key, &value, 0) != 0)
return -1 ;
value = (int)SvIV(*svp) ;
if (fixed) {
- status = dbp->set_re_pad(dbp, value) ;
+ (void)dbp->set_re_pad(dbp, value) ;
}
else {
- status = dbp->set_re_delim(dbp, value) ;
+ (void)dbp->set_re_delim(dbp, value) ;
}
}
svp = hv_fetch(action, "reclen", 6, FALSE);
if (svp) {
u_int32_t len = my_SvUV32(*svp) ;
- status = dbp->set_re_len(dbp, len) ;
+ (void)dbp->set_re_len(dbp, len) ;
}
}
if (name != NULL) {
- status = dbp->set_re_source(dbp, name) ;
+ (void)dbp->set_re_source(dbp, name) ;
name = NULL ;
}
name = NULL ;
- status = dbp->set_flags(dbp, (u_int32_t)DB_RENUMBER) ;
+ (void)dbp->set_flags(dbp, (u_int32_t)DB_RENUMBER) ;
if (flags){
(void)dbp->set_flags(dbp, (u_int32_t)flags) ;
}
-#{
-# # R_SETCURSOR
-# use strict ;
-# my (%h, $db) ;
-# unlink $Dfile;
-#
-# ok(156, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
-#
-# $h{abc} = 33 ;
-# my $k = "newest" ;
-# my $v = 44 ;
-# my $status = $db->put($k, $v, R_SETCURSOR) ;
-# print "status = [$status]\n" ;
-# ok(157, $status == 0) ;
-# $status = $db->del($k, R_CURSOR) ;
-# print "status = [$status]\n" ;
-# ok(158, $status == 0) ;
-# $k = "newest" ;
-# ok(159, $db->get($k, $v, R_CURSOR)) ;
-#
-# ok(160, keys %h == 1) ;
-#
-# undef $db ;
-# untie %h;
-# unlink $Dfile;
-#}
-
{
# Bug ID 20001013.009
#
untie %h;
unlink $Dfile;
}
+
+#{
+# # R_SETCURSOR
+# use strict ;
+# my (%h, $db) ;
+# unlink $Dfile;
+#
+# ok 198, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ;
+#
+# $h{abc} = 33 ;
+# my $k = "newest" ;
+# my $v = 44 ;
+# my $status = $db->put($k, $v, R_SETCURSOR) ;
+# print "status = [$status]\n" ;
+# ok 199, $status == 0 ;
+# $k = $v = '';
+# $status = $db->get($k, $v, R_CURSOR) ;
+# ok 200, $status == 0 ;
+# ok 201, $k eq 'newest';
+# ok 202, $v == 44;
+# $status = $db->del($k, R_CURSOR) ;
+# print "status = [$status]\n" ;
+# ok(203, $status == 0) ;
+# $k = "newest" ;
+# ok(204, $db->get($k, $v, R_CURSOR)) ;
+#
+# ok(205, keys %h == 1) ;
+#
+# undef $db ;
+# untie %h;
+# unlink $Dfile;
+#}
+
exit ;
use strict;
use vars qw($VERSION @ISA @EXPORT_OK);
-$VERSION = '2.54';
+$VERSION = '2.55';
require Exporter;
*import = \&Exporter::import;
#endif
#if defined(MGf_DUP) && defined(USE_ITHREADS)
-const STATIC MGVTBL vtbl_md5 = {
+STATIC const MGVTBL vtbl_md5 = {
NULL, /* get */
NULL, /* set */
NULL, /* len */
};
#else
/* declare as 5 member, not normal 8 to save image space*/
-const STATIC struct {
+STATIC const struct {
int (*svt_get)(SV* sv, MAGIC* mg);
int (*svt_set)(SV* sv, MAGIC* mg);
U32 (*svt_len)(SV* sv, MAGIC* mg);
PPCODE:
MD5Init(&ctx);
- if (PL_dowarn & G_WARN_ON) {
+ if ((PL_dowarn & G_WARN_ON) || ckWARN(WARN_SYNTAX)) {
const char *msg = 0;
if (items == 1) {
if (SvROK(ST(0))) {
if (ord "A" == 193) { # EBCDIC
$EXPECT = <<EOT;
0956ffb4f6416082b27d6680b4cf73fc README
-2a61dd5022b11faa35eed27d1c6c98c2 MD5.xs
+60a80f534f0017745eb755f36a946fe7 MD5.xs
276da0aa4e9a08b7fe09430c9c5690aa rfc1321.txt
EOT
} else {
# This is the output of: 'md5sum README MD5.xs rfc1321.txt'
$EXPECT = <<EOT;
2f93400875dbb56f36691d5f69f3eba5 README
-0a0cf2512d18d24c6881d7d755e2b609 MD5.xs
+9572832f3628e3bebcdd54f47c43dc5a MD5.xs
754b9db19f79dbc4992f7166eb0f37ce rfc1321.txt
EOT
}
$HAVE_MONOTONIC
];
- $VERSION = '0.92';
+ $VERSION = '0.94';
$VERBOSE = 0;
$DEBUG = 0;
$WARN = 1;
}
}
+sub uninstall_signals {
+ return unless defined($IPC::Cmd::{'__old_signals'});
+
+ foreach my $sig_name (keys %{$IPC::Cmd::{'__old_signals'}}) {
+ $SIG{$sig_name} = $IPC::Cmd::{'__old_signals'}->{$sig_name};
+ }
+}
+
# incompatible with POSIX::SigAction
#
sub install_layered_signal {
Carp::confess("install_layered_signal expects coderef")
if !ref($handler_code) || ref($handler_code) ne 'CODE';
+ $IPC::Cmd::{'__old_signals'} = {}
+ unless defined($IPC::Cmd::{'__old_signals'});
+ $IPC::Cmd::{'__old_signals'}->{$s} = $SIG{$s};
+
my $previous_handler = $SIG{$s};
my $sig_handler = sub {
# it will terminate only after child
# has terminated (except for SIGKILL,
# which is specially handled)
- foreach my $s (keys %SIG) {
+ SIGNAL: foreach my $s (keys %SIG) {
+ next SIGNAL if $s eq '__WARN__' or $s eq '__DIE__'; # Skip and don't clobber __DIE__ & __WARN__
my $sig_handler;
$sig_handler = sub {
kill("$s", $pid);
# prepare sockets to read from child
- $flags = 0;
- fcntl($child_stdout_socket, POSIX::F_GETFL, $flags) || Carp::confess "can't fnctl F_GETFL: $!";
+ $flags = fcntl($child_stdout_socket, POSIX::F_GETFL, 0) || Carp::confess "can't fnctl F_GETFL: $!";
$flags |= POSIX::O_NONBLOCK;
fcntl($child_stdout_socket, POSIX::F_SETFL, $flags) || Carp::confess "can't fnctl F_SETFL: $!";
- $flags = 0;
- fcntl($child_stderr_socket, POSIX::F_GETFL, $flags) || Carp::confess "can't fnctl F_GETFL: $!";
+ $flags = fcntl($child_stderr_socket, POSIX::F_GETFL, 0) || Carp::confess "can't fnctl F_GETFL: $!";
$flags |= POSIX::O_NONBLOCK;
fcntl($child_stderr_socket, POSIX::F_SETFL, $flags) || Carp::confess "can't fnctl F_SETFL: $!";
- $flags = 0;
- fcntl($child_info_socket, POSIX::F_GETFL, $flags) || Carp::confess "can't fnctl F_GETFL: $!";
+ $flags = fcntl($child_info_socket, POSIX::F_GETFL, 0) || Carp::confess "can't fnctl F_GETFL: $!";
$flags |= POSIX::O_NONBLOCK;
fcntl($child_info_socket, POSIX::F_SETFL, $flags) || Carp::confess "can't fnctl F_SETFL: $!";
delete($SIG{'CHLD'});
}
+ uninstall_signals();
+
return $o;
}
else {
1;
+__END__
+
=head2 $q = QUOTE
Returns the character used for quoting strings on this platform. This is
This makes sure that C<foo bar> is treated as a string, rather than two
separate arguments to the C<echo> function.
-__END__
-
=head1 HOW IT WORKS
C<run> will try to execute your command using the following logic:
use vars qw($VERSION);
use Carp;
-$VERSION = '2.06_01';
+$VERSION = '2.07';
# Figure out if we have support for native sized types
my $N = do { my $foo = eval { pack "L!", 0 }; $@ ? '' : '!' };
use vars qw($VERSION);
use Carp;
-$VERSION = '2.06_01';
+$VERSION = '2.07';
# Figure out if we have support for native sized types
my $N = do { my $foo = eval { pack "L!", 0 }; $@ ? '' : '!' };
use vars qw($VERSION);
use Carp;
-$VERSION = '2.06_01';
+$VERSION = '2.07';
# Figure out if we have support for native sized types
my $N = do { my $foo = eval { pack "L!", 0 }; $@ ? '' : '!' };
require Exporter;
@ISA = qw(Exporter);
-$VERSION = '2.06_01';
+$VERSION = '2.07';
# To support new constants, just add them to @EXPORT_OK
# and the C/XS code will be generated automagically.
package Locale::Codes;
# Copyright (C) 2001 Canon Research Centre Europe (CRE).
# Copyright (C) 2002-2009 Neil Bowers
-# Copyright (c) 2010-2015 Sullivan Beck
+# Copyright (c) 2010-2016 Sullivan Beck
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
# $Retired{ TYPE }{ CODESET }{ code }{ CODE } = NAME
# { name }{ NAME } = [CODE,NAME] (the key is lowercase)
-$VERSION='3.37';
+$VERSION='3.38';
#=======================================================================
#
#=======================================================================
sub _code {
- return 1 if (@_ > 3);
+ return (1) if (@_ > 3);
my($type,$code,$codeset) = @_;
$code = '' if (! defined $code);
if (! defined($codeset) || $codeset eq '');
$codeset = lc($codeset);
return (1) if (! exists $ALL_CODESETS{$type}{'codesets'}{$codeset});
- return (0,$code,$codeset) if (! $code);
+ return (0,$code,$codeset) if ($code eq '');
# Determine the properties of the codeset
$code = $Data{$type}{'codealias'}{$codeset}{$code}
if (exists $Data{$type}{'codealias'}{$codeset}{$code});
- if (exists $Data{$type}{'code2id'}{$codeset} &&
- exists $Data{$type}{'code2id'}{$codeset}{$code}) {
+ if (exists $Data{$type}{'code2id'}{$codeset}{$code}) {
my ($id,$i) = @{ $Data{$type}{'code2id'}{$codeset}{$code} };
my $name = $Data{$type}{'id2names'}{$id}[$i];
return $name;
$name = lc($name);
my $retired = 0;
- if (@args > 0 && $args[$#args] && $args[$#args] eq 'retired') {
+ if (@args > 0 && $args[$#args] eq 'retired') {
pop(@args);
$retired = 1;
}
sub _code2code {
my($type,@args) = @_;
- (@args == 3) or croak "${type}_code2code() takes 3 arguments!";
+
+ # For tests, we'll ALWAYS have $nowarn
+ my $nowarn = 0;
+ if (@args) { # uncoverable branch false
+ if ($args[$#args] eq "nowarn") { # uncoverable branch false
+ $nowarn = 1;
+ pop(@args);
+ }
+ }
+
+ if (@args != 3) {
+ if (! $nowarn) { # uncoverable branch true
+ croak "${type}_code2code() takes 3 arguments!"; # uncoverable statement
+ }
+ return undef;
+ }
my($code,$inset,$outset) = @args;
my($err,$tmp);
sub _all_codes {
my($type,@args) = @_;
my $retired = 0;
- if (@args > 0 && $args[$#args] && $args[$#args] eq 'retired') {
+ if (@args > 0 && $args[$#args] eq 'retired') {
pop(@args);
$retired = 1;
}
my ($err,$tmp,$codeset) = _code($type,'',@args);
return () if ($err);
- if (! exists $Data{$type}{'code2id'}{$codeset}) {
- return ();
- }
my @codes = keys %{ $Data{$type}{'code2id'}{$codeset} };
push(@codes,keys %{ $Retired{$type}{$codeset}{'code'} }) if ($retired);
return (sort @codes);
sub _all_names {
my($type,@args) = @_;
my $retired = 0;
- if (@args > 0 && $args[$#args] && $args[$#args] eq 'retired') {
+ if (@args > 0 && $args[$#args] eq 'retired') {
pop(@args);
$retired = 1;
}
sub _rename {
my($type,$code,$new_name,@args) = @_;
+ # For tests, we'll ALWAYS have $nowarn
my $nowarn = 0;
- $nowarn = 1, pop(@args) if (@args && $args[$#args] eq "nowarn");
+ if (@args) { # uncoverable branch false
+ if ($args[$#args] eq "nowarn") { # uncoverable branch false
+ $nowarn = 1;
+ pop(@args);
+ }
+ }
my $codeset = shift(@args);
my $err;
($err,$code,$codeset) = _code($type,$code,$codeset);
if (! $codeset) {
- carp "rename_$type(): unknown codeset\n" unless ($nowarn);
+ if (! $nowarn) { # uncoverable branch true
+ carp "rename_$type(): unknown codeset\n"; # uncoverable statement
+ }
return 0;
}
- $code = $Data{$type}{'codealias'}{$codeset}{$code}
- if (exists $Data{$type}{'codealias'}{$codeset}{$code});
-
# Check that $code exists in the codeset.
my $id;
if (exists $Data{$type}{'code2id'}{$codeset}{$code}) {
$id = $Data{$type}{'code2id'}{$codeset}{$code}[0];
} else {
- carp "rename_$type(): unknown code: $code\n" unless ($nowarn);
+ if (! $nowarn) { # uncoverable branch true
+ carp "rename_$type(): unknown code: $code\n"; # uncoverable statement
+ }
return 0;
}
my ($new_id,$i) = @{ $Data{$type}{'alias2id'}{lc($new_name)} };
if ($new_id != $id) {
# Case 1
- carp "rename_$type(): rename to an existing $type not allowed\n"
- unless ($nowarn);
+ if (! $nowarn) { # uncoverable branch true
+ # uncoverable statement
+ carp "rename_$type(): rename to an existing $type not allowed\n";
+ }
+
return 0;
}
sub _add_code {
my($type,$code,$name,@args) = @_;
+ # For tests, we'll ALWAYS have $nowarn
my $nowarn = 0;
- $nowarn = 1, pop(@args) if (@args && $args[$#args] eq "nowarn");
+ if (@args) { # uncoverable branch false
+ if ($args[$#args] eq "nowarn") { # uncoverable branch false
+ $nowarn = 1;
+ pop(@args);
+ }
+ }
my $codeset = shift(@args);
my $err;
($err,$code,$codeset) = _code($type,$code,$codeset);
if (! $codeset) {
- carp "add_$type(): unknown codeset\n" unless ($nowarn);
+ if (! $nowarn) { # uncoverable branch true
+ carp "add_$type(): unknown codeset\n"; # uncoverable statement
+ }
return 0;
}
if (exists $Data{$type}{'code2id'}{$codeset}{$code} ||
exists $Data{$type}{'codealias'}{$codeset}{$code}) {
- carp "add_$type(): code already in use: $code\n" unless ($nowarn);
+ if (! $nowarn) { # uncoverable branch true
+ carp "add_$type(): code already in use: $code\n";# uncoverable statement
+ }
return 0;
}
if (exists $Data{$type}{'alias2id'}{lc($name)}) {
($id,$i) = @{ $Data{$type}{'alias2id'}{lc($name)} };
if (exists $Data{$type}{'id2code'}{$codeset}{$id}) {
- carp "add_$type(): name already in use: $name\n" unless ($nowarn);
+ if (! $nowarn) { # uncoverable branch true
+ # uncoverable statement
+ carp "add_$type(): name already in use: $name\n";
+ }
return 0;
}
sub _delete_code {
my($type,$code,@args) = @_;
+ # For tests, we'll ALWAYS have $nowarn
my $nowarn = 0;
- $nowarn = 1, pop(@args) if (@args && $args[$#args] eq "nowarn");
+ if (@args) { # uncoverable branch false
+ if ($args[$#args] eq "nowarn") { # uncoverable branch false
+ $nowarn = 1;
+ pop(@args);
+ }
+ }
my $codeset = shift(@args);
my $err;
($err,$code,$codeset) = _code($type,$code,$codeset);
if (! $codeset) {
- carp "delete_$type(): unknown codeset\n" unless ($nowarn);
+ if (! $nowarn) { # uncoverable branch true
+ carp "delete_$type(): unknown codeset\n"; # uncoverable statement
+ }
return 0;
}
- $code = $Data{$type}{'codealias'}{$codeset}{$code}
- if (exists $Data{$type}{'codealias'}{$codeset}{$code});
-
# Check that $code is valid.
if (! exists $Data{$type}{'code2id'}{$codeset}{$code}) {
- carp "delete_$type(): code does not exist: $code\n" unless ($nowarn);
+ if (! $nowarn) { # uncoverable branch true
+ # uncoverable statement
+ carp "delete_$type(): code does not exist: $code\n";
+ }
return 0;
}
#=======================================================================
sub _add_alias {
- my($type,$name,$new_name,$nowarn) = @_;
+ my($type,$name,$new_name,@args) = @_;
- $nowarn = (defined($nowarn) && $nowarn eq "nowarn" ? 1 : 0);
+ # For tests, we'll ALWAYS have $nowarn
+ my $nowarn = 0;
+ if (@args) { # uncoverable branch false
+ if ($args[$#args] eq "nowarn") { # uncoverable branch false
+ $nowarn = 1;
+ pop(@args);
+ }
+ }
# Check that $name is used and $new_name is new.
if (exists $Data{$type}{'alias2id'}{lc($name)}) {
$id = $Data{$type}{'alias2id'}{lc($name)}[0];
} else {
- carp "add_${type}_alias(): name does not exist: $name\n" unless ($nowarn);
+ if (! $nowarn) { # uncoverable branch true
+ # uncoverable statement
+ carp "add_${type}_alias(): name does not exist: $name\n";
+ }
return 0;
}
if (exists $Data{$type}{'alias2id'}{lc($new_name)}) {
- carp "add_${type}_alias(): alias already in use: $new_name\n" unless ($nowarn);
+ if (! $nowarn) { # uncoverable branch true
+ # uncoverable statement
+ carp "add_${type}_alias(): alias already in use: $new_name\n";
+ }
return 0;
}
#=======================================================================
sub _delete_alias {
- my($type,$name,$nowarn) = @_;
+ my($type,$name,@args) = @_;
- $nowarn = (defined($nowarn) && $nowarn eq "nowarn" ? 1 : 0);
+ # For tests, we'll ALWAYS have $nowarn
+ my $nowarn = 0;
+ if (@args) { # uncoverable branch false
+ if ($args[$#args] eq "nowarn") { # uncoverable branch false
+ $nowarn = 1;
+ pop(@args);
+ }
+ }
# Check that $name is used.
if (exists $Data{$type}{'alias2id'}{lc($name)}) {
($id,$i) = @{ $Data{$type}{'alias2id'}{lc($name)} };
} else {
- carp "delete_${type}_alias(): name does not exist: $name\n" unless ($nowarn);
+ if (! $nowarn) { # uncoverable branch true
+ # uncoverable statement
+ carp "delete_${type}_alias(): name does not exist: $name\n";
+ }
return 0;
}
my $n = $#{ $Data{$type}{'id2names'}{$id} } + 1;
if ($n == 1) {
- carp "delete_${type}_alias(): only one name defined (use _delete_${type} instead)\n"
- unless ($nowarn);
+ if (! $nowarn) { # uncoverable branch true
+ # uncoverable statement
+ carp "delete_${type}_alias(): only one name defined (use _delete_${type} instead)\n";
+ }
return 0;
}
# Set to 0 if I = $i
# Decrement if I > $i
- foreach my $codeset (keys %{ $Data{'code2id'} }) {
- foreach my $code (keys %{ $Data{'code2id'}{$codeset} }) {
- my($jd,$j) = @{ $Data{'code2id'}{$codeset}{$code} };
+ foreach my $codeset (keys %{ $Data{$type}{'code2id'} }) {
+ foreach my $code (keys %{ $Data{$type}{'code2id'}{$codeset} }) {
+ my($jd,$j) = @{ $Data{$type}{'code2id'}{$codeset}{$code} };
next if ($jd ne $id ||
$j < $i);
if ($i == $j) {
- $Data{'code2id'}{$codeset}{$code}[1] = 0;
+ $Data{$type}{'code2id'}{$codeset}{$code}[1] = 0;
} else {
- $Data{'code2id'}{$codeset}{$code}[1]--;
+ $Data{$type}{'code2id'}{$codeset}{$code}[1]--;
}
}
}
sub _rename_code {
my($type,$code,$new_code,@args) = @_;
+ # For tests, we'll ALWAYS have $nowarn
my $nowarn = 0;
- $nowarn = 1, pop(@args) if (@args && $args[$#args] eq "nowarn");
+ if (@args) { # uncoverable branch false
+ if ($args[$#args] eq "nowarn") { # uncoverable branch false
+ $nowarn = 1;
+ pop(@args);
+ }
+ }
my $codeset = shift(@args);
my $err;
($err,$code,$codeset) = _code($type,$code,$codeset);
- ($err,$new_code,$codeset) = _code($type,$new_code,$codeset)
- if (! $err);
if (! $codeset) {
- carp "rename_$type(): unknown codeset\n" unless ($nowarn);
+ if (! $nowarn) { # uncoverable branch true
+ carp "rename_${type}_code(): unknown codeset\n"; # uncoverable statement
+ }
return 0;
}
- $code = $Data{$type}{'codealias'}{$codeset}{$code}
- if (exists $Data{$type}{'codealias'}{$codeset}{$code});
+ ($err,$new_code,$codeset) = _code($type,$new_code,$codeset);
# Check that $code exists in the codeset.
if (! exists $Data{$type}{'code2id'}{$codeset}{$code}) {
- carp "rename_$type(): unknown code: $code\n" unless ($nowarn);
+ if (! $nowarn) { # uncoverable branch true
+ # uncoverable statement
+ carp "rename_${type}_code(): unknown code: $code\n";
+ }
return 0;
}
} else {
# Case 2
- carp "rename_$type(): new code already in use: $new_code\n" unless ($nowarn);
+ if (! $nowarn) { # uncoverable branch true
+ # uncoverable statement
+ carp "rename_${type}_code(): new code already in use: $new_code\n";
+ }
return 0;
}
} elsif (exists $Data{$type}{'code2id'}{$codeset}{$new_code}) {
# Case 3
- carp "rename_$type(): new code already in use: $new_code\n" unless ($nowarn);
+ if (! $nowarn) { # uncoverable branch true
+ # uncoverable statement
+ carp "rename_${type}_code(): new code already in use: $new_code\n";
+ }
return 0;
}
sub _add_code_alias {
my($type,$code,$new_code,@args) = @_;
+ # For tests, we'll ALWAYS have $nowarn
my $nowarn = 0;
- $nowarn = 1, pop(@args) if (@args && $args[$#args] eq "nowarn");
+ if (@args) { # uncoverable branch false
+ if ($args[$#args] eq "nowarn") { # uncoverable branch false
+ $nowarn = 1;
+ pop(@args);
+ }
+ }
my $codeset = shift(@args);
my $err;
($err,$code,$codeset) = _code($type,$code,$codeset);
- ($err,$new_code,$codeset) = _code($type,$new_code,$codeset)
- if (! $err);
if (! $codeset) {
- carp "add_${type}_code_alias(): unknown codeset\n" unless ($nowarn);
+ if (! $nowarn) { # uncoverable branch true
+ # uncoverable statement
+ carp "add_${type}_code_alias(): unknown codeset\n";
+ }
return 0;
}
- $code = $Data{$type}{'codealias'}{$codeset}{$code}
- if (exists $Data{$type}{'codealias'}{$codeset}{$code});
+ ($err,$new_code,$codeset) = _code($type,$new_code,$codeset);
# Check that $code exists in the codeset and that $new_code
# does not exist.
if (! exists $Data{$type}{'code2id'}{$codeset}{$code}) {
- carp "add_${type}_code_alias(): unknown code: $code\n" unless ($nowarn);
+ if (! $nowarn) { # uncoverable branch true
+ # uncoverable statement
+ carp "add_${type}_code_alias(): unknown code: $code\n";
+ }
return 0;
}
if (exists $Data{$type}{'code2id'}{$codeset}{$new_code} ||
exists $Data{$type}{'codealias'}{$codeset}{$new_code}) {
- carp "add_${type}_code_alias(): code already in use: $new_code\n" unless ($nowarn);
+ if (! $nowarn) { # uncoverable branch true
+ # uncoverable statement
+ carp "add_${type}_code_alias(): code already in use: $new_code\n";
+ }
return 0;
}
#=======================================================================
#
-# _delete_code_alias ( TYPE,CODE,CODESET )
+# _delete_code_alias ( TYPE,ALIAS,CODESET )
#
# Deletes an alias for the code.
#
sub _delete_code_alias {
my($type,$code,@args) = @_;
+ # For tests, we'll ALWAYS have $nowarn
my $nowarn = 0;
- $nowarn = 1, pop(@args) if (@args && $args[$#args] eq "nowarn");
+ if (@args) { # uncoverable branch false
+ if ($args[$#args] eq "nowarn") { # uncoverable branch false
+ $nowarn = 1;
+ pop(@args);
+ }
+ }
my $codeset = shift(@args);
my $err;
($err,$code,$codeset) = Locale::Codes::_code($type,$code,$codeset);
if (! $codeset) {
- carp "delete_${type}_code_alias(): unknown codeset\n" unless ($nowarn);
+ if (! $nowarn) { # uncoverable branch true
+ # uncoverable statement
+ carp "delete_${type}_code_alias(): unknown codeset\n";
+ }
return 0;
}
# Check that $code exists in the codeset as an alias.
if (! exists $Data{$type}{'codealias'}{$codeset}{$code}) {
- carp "delete_${type}_code_alias(): no alias defined: $code\n" unless ($nowarn);
+ if (! $nowarn) { # uncoverable branch true
+ # uncoverable statement
+ carp "delete_${type}_code_alias(): no alias defined: $code\n";
+ }
return 0;
}
# cperl-continued-brace-offset: 0
# cperl-brace-offset: 0
# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
+# cperl-label-offset: 0
# End:
Copyright (c) 1997-2001 Canon Research Centre Europe (CRE).
Copyright (c) 2001 Michael Hennecke (Locale::Currency)
Copyright (c) 2001-2010 Neil Bowers
- Copyright (c) 2010-2015 Sullivan Beck
+ Copyright (c) 2010-2016 Sullivan Beck
This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
Copyright (c) 1997-2001 Canon Research Centre Europe (CRE).
Copyright (c) 2001-2010 Neil Bowers
- Copyright (c) 2010-2015 Sullivan Beck
+ Copyright (c) 2010-2016 Sullivan Beck
This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=head1 VERSION 3.39 (planned 2016-06-01; sbeck)
-=head1 VERSION 3.38 (planned 2016-03-01; sbeck)
+=head1 VERSION 3.38 (2016-03-02; sbeck)
+
+NEW CODE(s)
+
+=over 4
+
+=item B<Tests reworked>
+
+Improved test suite (and made some changes to Codes.pm) based on Devel::Cover.
+Test suite now has 100% coverage.
+
+=back
=head1 VERSION 3.37 (2015-12-01; sbeck)
=head1 COPYRIGHT
Copyright (c) 2001-2010 Neil Bowers
- Copyright (c) 2010-2015 Sullivan Beck
+ Copyright (c) 2010-2016 Sullivan Beck
This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
package Locale::Codes::Constants;
# Copyright (C) 2001 Canon Research Centre Europe (CRE).
# Copyright (C) 2002-2009 Neil Bowers
-# Copyright (c) 2010-2015 Sullivan Beck
+# Copyright (c) 2010-2016 Sullivan Beck
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
our($VERSION,@ISA,@EXPORT);
our(%ALL_CODESETS);
-$VERSION='3.37';
+$VERSION='3.38';
@ISA = qw(Exporter);
@EXPORT = qw(LOCALE_CODE_ALPHA_2
LOCALE_CODE_ALPHA_3
# cperl-continued-brace-offset: 0
# cperl-brace-offset: 0
# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
+# cperl-label-offset: 0
# End:
package Locale::Codes::Country;
# Copyright (C) 2001 Canon Research Centre Europe (CRE).
# Copyright (C) 2002-2009 Neil Bowers
-# Copyright (c) 2010-2015 Sullivan Beck
+# Copyright (c) 2010-2016 Sullivan Beck
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
our($VERSION,@ISA,@EXPORT,@EXPORT_OK);
-$VERSION='3.37';
+$VERSION='3.38';
@ISA = qw(Exporter);
@EXPORT = qw(code2country
country2code
# cperl-continued-brace-offset: 0
# cperl-brace-offset: 0
# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
+# cperl-label-offset: 0
# End:
Copyright (c) 1997-2001 Canon Research Centre Europe (CRE).
Copyright (c) 2001-2010 Neil Bowers
- Copyright (c) 2010-2015 Sullivan Beck
+ Copyright (c) 2010-2016 Sullivan Beck
This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
# This file was automatically generated. Any changes to this file will
# be lost the next time 'harvest_data' is run.
-# Generated on: Tue Dec 1 14:41:05 EST 2015
+# Generated on: Wed Mar 2 08:57:53 EST 2016
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.37';
+$VERSION='3.38';
$Locale::Codes::Data{'country'}{'id'} = '0250';
# This file was automatically generated. Any changes to this file will
# be lost the next time 'deprecate_codes' is run.
-# Generated on: Tue Dec 1 14:45:28 EST 2015
+# Generated on: Wed Mar 2 09:26:23 EST 2016
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.37';
+$VERSION='3.38';
$Locale::Codes::Retired{'country'}{'alpha-2'}{'code'} = {
q(an) => q(Netherlands Antilles),
package Locale::Codes::Currency;
# Copyright (C) 2001 Canon Research Centre Europe (CRE).
# Copyright (C) 2002-2009 Neil Bowers
-# Copyright (c) 2010-2015 Sullivan Beck
+# Copyright (c) 2010-2016 Sullivan Beck
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
our($VERSION,@ISA,@EXPORT,@EXPORT_OK);
-$VERSION='3.37';
+$VERSION='3.38';
@ISA = qw(Exporter);
@EXPORT = qw(code2currency
currency2code
# cperl-continued-brace-offset: 0
# cperl-brace-offset: 0
# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
+# cperl-label-offset: 0
# End:
=item B<Locale::Codes::Currency::add_currency_code_alias(CODE ,NEW_CODE [,CODESET])>
-=item B<Locale::Codes::Currency::delete_currency_code_alias( ODE [,CODESET])>
+=item B<Locale::Codes::Currency::delete_currency_code_alias( CODE [,CODESET])>
These routines are all documented in the L<Locale::Codes::API> man page.
Copyright (c) 1997-2001 Canon Research Centre Europe (CRE).
Copyright (c) 2001 Michael Hennecke
Copyright (c) 2001-2010 Neil Bowers
- Copyright (c) 2010-2015 Sullivan Beck
+ Copyright (c) 2010-2016 Sullivan Beck
This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
# This file was automatically generated. Any changes to this file will
# be lost the next time 'harvest_data' is run.
-# Generated on: Tue Dec 1 14:44:02 EST 2015
+# Generated on: Wed Mar 2 09:20:52 EST 2016
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.37';
+$VERSION='3.38';
$Locale::Codes::Data{'currency'}{'id'} = '0177';
q(Barbados Dollar),
],
q(0017) => [
- q(Belarussian Ruble),
+ q(Belarusian Ruble),
],
q(0018) => [
q(Belize Dollar),
q(Bermudian Dollar),
],
q(0021) => [
- q(Ngultrum),
+ q(Indian Rupee),
],
q(0022) => [
- q(Indian Rupee),
+ q(Ngultrum),
],
q(0023) => [
q(Boliviano),
q(Cayman Islands Dollar),
],
q(0037) => [
- q(Unidad de Fomento),
+ q(Chilean Peso),
],
q(0038) => [
- q(Chilean Peso),
+ q(Unidad de Fomento),
],
q(0039) => [
q(Yuan Renminbi),
q(Kuna),
],
q(0047) => [
- q(Peso Convertible),
+ q(Cuban Peso),
],
q(0048) => [
- q(Cuban Peso),
+ q(Peso Convertible),
],
q(0049) => [
q(Netherlands Antillean Guilder),
q(Malagasy Ariary),
],
q(0098) => [
- q(Kwacha),
+ q(Malawi Kwacha),
],
q(0099) => [
q(Malaysian Ringgit),
q(Guarani),
],
q(0120) => [
- q(Nuevo Sol),
+ q(Sol),
],
q(0121) => [
q(Philippine Peso),
q(US Dollar (Next day)),
],
q(0160) => [
- q(Uruguay Peso en Unidades Indexadas (URUIURUI)),
+ q(Peso Uruguayo),
],
q(0161) => [
- q(Peso Uruguayo),
+ q(Uruguay Peso en Unidades Indexadas (URUIURUI)),
],
q(0162) => [
q(Uzbekistan Sum),
q(0016),
q(0),
],
- q(belarussian ruble) => [
+ q(belarusian ruble) => [
q(0017),
q(0),
],
q(0),
],
q(chilean peso) => [
- q(0038),
+ q(0037),
q(0),
],
q(colombian peso) => [
q(0),
],
q(cuban peso) => [
- q(0048),
+ q(0047),
q(0),
],
q(czech koruna) => [
q(0),
],
q(indian rupee) => [
- q(0022),
+ q(0021),
q(0),
],
q(iranian rial) => [
q(0086),
q(0),
],
- q(kwacha) => [
- q(0098),
- q(0),
- ],
q(kwanza) => [
q(0006),
q(0),
q(0097),
q(0),
],
+ q(malawi kwacha) => [
+ q(0098),
+ q(0),
+ ],
q(malaysian ringgit) => [
q(0099),
q(0),
q(0),
],
q(ngultrum) => [
- q(0021),
+ q(0022),
q(0),
],
q(north korean won) => [
q(0027),
q(0),
],
- q(nuevo sol) => [
- q(0120),
- q(0),
- ],
q(ouguiya) => [
q(0101),
q(0),
q(0),
],
q(peso convertible) => [
- q(0047),
+ q(0048),
q(0),
],
q(peso uruguayo) => [
- q(0161),
+ q(0160),
q(0),
],
q(philippine peso) => [
q(0134),
q(0),
],
+ q(sol) => [
+ q(0120),
+ q(0),
+ ],
q(solomon islands dollar) => [
q(0136),
q(0),
q(0),
],
q(unidad de fomento) => [
- q(0037),
+ q(0038),
q(0),
],
q(unidad de valor real) => [
q(0),
],
q(uruguay peso en unidades indexadas (uruiurui)) => [
- q(0160),
+ q(0161),
q(0),
],
q(us dollar) => [
q(0),
],
q(BTN) => [
- q(0021),
+ q(0022),
q(0),
],
q(BWP) => [
q(0),
],
q(CLF) => [
- q(0037),
+ q(0038),
q(0),
],
q(CLP) => [
- q(0038),
+ q(0037),
q(0),
],
q(CNY) => [
q(0),
],
q(CUC) => [
- q(0047),
+ q(0048),
q(0),
],
q(CUP) => [
- q(0048),
+ q(0047),
q(0),
],
q(CVE) => [
q(0),
],
q(INR) => [
- q(0022),
+ q(0021),
q(0),
],
q(IQD) => [
q(0),
],
q(UYI) => [
- q(0160),
+ q(0161),
q(0),
],
q(UYU) => [
- q(0161),
+ q(0160),
q(0),
],
q(UZS) => [
q(0),
],
q(064) => [
- q(0021),
+ q(0022),
q(0),
],
q(068) => [
q(0),
],
q(152) => [
- q(0038),
+ q(0037),
q(0),
],
q(156) => [
q(0),
],
q(192) => [
- q(0048),
+ q(0047),
q(0),
],
q(203) => [
q(0),
],
q(356) => [
- q(0022),
+ q(0021),
q(0),
],
q(360) => [
q(0),
],
q(858) => [
- q(0161),
+ q(0160),
q(0),
],
q(860) => [
q(0),
],
q(931) => [
- q(0047),
+ q(0048),
q(0),
],
q(932) => [
q(0),
],
q(940) => [
- q(0160),
+ q(0161),
q(0),
],
q(941) => [
q(0),
],
q(990) => [
- q(0037),
+ q(0038),
q(0),
],
q(994) => [
q(0018) => q(BZD),
q(0019) => q(XOF),
q(0020) => q(BMD),
- q(0021) => q(BTN),
- q(0022) => q(INR),
+ q(0021) => q(INR),
+ q(0022) => q(BTN),
q(0023) => q(BOB),
q(0024) => q(BOV),
q(0025) => q(BAM),
q(0034) => q(XAF),
q(0035) => q(CAD),
q(0036) => q(KYD),
- q(0037) => q(CLF),
- q(0038) => q(CLP),
+ q(0037) => q(CLP),
+ q(0038) => q(CLF),
q(0039) => q(CNY),
q(0040) => q(COP),
q(0041) => q(COU),
q(0044) => q(NZD),
q(0045) => q(CRC),
q(0046) => q(HRK),
- q(0047) => q(CUC),
- q(0048) => q(CUP),
+ q(0047) => q(CUP),
+ q(0048) => q(CUC),
q(0049) => q(ANG),
q(0050) => q(CZK),
q(0051) => q(DKK),
q(0157) => q(UAH),
q(0158) => q(AED),
q(0159) => q(USN),
- q(0160) => q(UYI),
- q(0161) => q(UYU),
+ q(0160) => q(UYU),
+ q(0161) => q(UYI),
q(0162) => q(UZS),
q(0163) => q(VUV),
q(0164) => q(VEF),
q(0018) => q(084),
q(0019) => q(952),
q(0020) => q(060),
- q(0021) => q(064),
- q(0022) => q(356),
+ q(0021) => q(356),
+ q(0022) => q(064),
q(0023) => q(068),
q(0024) => q(984),
q(0025) => q(977),
q(0034) => q(950),
q(0035) => q(124),
q(0036) => q(136),
- q(0037) => q(990),
- q(0038) => q(152),
+ q(0037) => q(152),
+ q(0038) => q(990),
q(0039) => q(156),
q(0040) => q(170),
q(0041) => q(970),
q(0044) => q(554),
q(0045) => q(188),
q(0046) => q(191),
- q(0047) => q(931),
- q(0048) => q(192),
+ q(0047) => q(192),
+ q(0048) => q(931),
q(0049) => q(532),
q(0050) => q(203),
q(0051) => q(208),
q(0157) => q(980),
q(0158) => q(784),
q(0159) => q(997),
- q(0160) => q(940),
- q(0161) => q(858),
+ q(0160) => q(858),
+ q(0161) => q(940),
q(0162) => q(860),
q(0163) => q(548),
q(0164) => q(937),
# This file was automatically generated. Any changes to this file will
# be lost the next time 'deprecate_codes' is run.
-# Generated on: Tue Dec 1 14:45:28 EST 2015
+# Generated on: Wed Mar 2 09:26:23 EST 2016
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.37';
+$VERSION='3.38';
$Locale::Codes::Retired{'currency'}{'alpha'}{'code'} = {
q(ADP) => q(Andorran Peseta),
$Locale::Codes::Retired{'currency'}{'alpha'}{'name'} = {
q(andorran peseta) => [ q(ADP), q(Andorran Peseta) ],
q(aruban guilder) => [ q(AWG), q(Aruban Guilder) ],
+ q(belarussian ruble) => [ q(BYR), q(Belarussian Ruble) ],
q(belgian franc) => [ q(BEF), q(Belgian Franc) ],
q(bermudian dollar (customarily known as bermuda dollar)) => [ q(BMD), q(Bermudian Dollar (customarily known as Bermuda Dollar)) ],
q(bolivar) => [ q(VEB), q(Bolivar) ],
q(karbovanets) => [ q(UAK), q(Karbovanets) ],
q(kroon) => [ q(EEK), q(Kroon) ],
q(kuna) => [ q(HRK), q(Kuna) ],
+ q(kwacha) => [ q(MWK), q(Kwacha) ],
q(kwanza reajustado) => [ q(AOR), q(Kwanza Reajustado) ],
q(latvian lats) => [ q(LVL), q(Latvian Lats) ],
q(leu) => [ q(RON), q(Leu) ],
q(new manat) => [ q(TMT), q(New Manat) ],
q(new romanian leu) => [ q(RON), q(New Romanian Leu) ],
q(new zaire) => [ q(ZRN), q(New Zaire) ],
+ q(nuevo sol) => [ q(PEN), q(Nuevo Sol) ],
q(portuguese escudo) => [ q(PTE), q(Portuguese Escudo) ],
q(saint helena pound) => [ q(SHP), q(Saint Helena Pound) ],
q(schilling) => [ q(ATS), q(Schilling) ],
};
$Locale::Codes::Retired{'currency'}{'num'}{'name'} = {
+ q(belarussian ruble) => [ q(974), q(Belarussian Ruble) ],
q(bolivar fuerte) => [ q(937), q(Bolivar Fuerte) ],
q(cape verde escudo) => [ q(132), q(Cape Verde Escudo) ],
q(cedi) => [ q(936), q(Cedi) ],
q(croatian kuna) => [ q(191), q(Croatian Kuna) ],
+ q(kwacha) => [ q(454), q(Kwacha) ],
q(latvian lats) => [ q(428), q(Latvian Lats) ],
q(leu) => [ q(946), q(Leu) ],
q(lithuanian litas) => [ q(440), q(Lithuanian Litas) ],
q(metical) => [ q(943), q(Metical) ],
q(new manat) => [ q(934), q(New Manat) ],
q(new romanian leu) => [ q(946), q(New Romanian Leu) ],
+ q(nuevo sol) => [ q(604), q(Nuevo Sol) ],
q(saint helena pound) => [ q(654), q(Saint Helena Pound) ],
q(unidades de fomento) => [ q(990), q(Unidades de fomento) ],
q(us dollar (same day)) => [ q(998), q(US Dollar (Same day)) ],
package Locale::Codes::LangExt;
-# Copyright (c) 2011-2015 Sullivan Beck
+# Copyright (c) 2011-2016 Sullivan Beck
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
our($VERSION,@ISA,@EXPORT,@EXPORT_OK);
-$VERSION='3.37';
+$VERSION='3.38';
@ISA = qw(Exporter);
@EXPORT = qw(code2langext
langext2code
# cperl-continued-brace-offset: 0
# cperl-brace-offset: 0
# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
+# cperl-label-offset: 0
# End:
=head1 COPYRIGHT
- Copyright (c) 2011-2015 Sullivan Beck
+ Copyright (c) 2011-2016 Sullivan Beck
This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
# This file was automatically generated. Any changes to this file will
# be lost the next time 'harvest_data' is run.
-# Generated on: Tue Dec 1 14:44:16 EST 2015
+# Generated on: Wed Mar 2 09:24:09 EST 2016
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.37';
+$VERSION='3.38';
$Locale::Codes::Data{'langext'}{'id'} = '0230';
# This file was automatically generated. Any changes to this file will
# be lost the next time 'deprecate_codes' is run.
-# Generated on: Tue Dec 1 14:45:28 EST 2015
+# Generated on: Wed Mar 2 09:26:23 EST 2016
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.37';
+$VERSION='3.38';
$Locale::Codes::Retired{'langext'}{'alpha'}{'code'} = {
q(yds) => q(Yiddish Sign Language),
package Locale::Codes::LangFam;
-# Copyright (c) 2011-2015 Sullivan Beck
+# Copyright (c) 2011-2016 Sullivan Beck
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
our($VERSION,@ISA,@EXPORT,@EXPORT_OK);
-$VERSION='3.37';
+$VERSION='3.38';
@ISA = qw(Exporter);
@EXPORT = qw(code2langfam
langfam2code
# cperl-continued-brace-offset: 0
# cperl-brace-offset: 0
# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
+# cperl-label-offset: 0
# End:
=head1 COPYRIGHT
- Copyright (c) 2011-2015 Sullivan Beck
+ Copyright (c) 2011-2016 Sullivan Beck
This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
# This file was automatically generated. Any changes to this file will
# be lost the next time 'harvest_data' is run.
-# Generated on: Tue Dec 1 14:44:25 EST 2015
+# Generated on: Wed Mar 2 09:24:18 EST 2016
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.37';
+$VERSION='3.38';
$Locale::Codes::Data{'langfam'}{'id'} = '0116';
require 5.002;
our($VERSION);
-$VERSION='3.37';
+$VERSION='3.38';
$Locale::Codes::Retired{'langfam'}{'alpha'}{'code'} = {
};
package Locale::Codes::LangVar;
-# Copyright (c) 2011-2015 Sullivan Beck
+# Copyright (c) 2011-2016 Sullivan Beck
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
our($VERSION,@ISA,@EXPORT,@EXPORT_OK);
-$VERSION='3.37';
+$VERSION='3.38';
@ISA = qw(Exporter);
@EXPORT = qw(code2langvar
langvar2code
# cperl-continued-brace-offset: 0
# cperl-brace-offset: 0
# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
+# cperl-label-offset: 0
# End:
=head1 COPYRIGHT
- Copyright (c) 2011-2015 Sullivan Beck
+ Copyright (c) 2011-2016 Sullivan Beck
This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
# This file was automatically generated. Any changes to this file will
# be lost the next time 'harvest_data' is run.
-# Generated on: Tue Dec 1 14:44:22 EST 2015
+# Generated on: Wed Mar 2 09:24:14 EST 2016
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.37';
+$VERSION='3.38';
-$Locale::Codes::Data{'langvar'}{'id'} = '0073';
+$Locale::Codes::Data{'langvar'}{'id'} = '0076';
$Locale::Codes::Data{'langvar'}{'id2names'} = {
q(0001) => [
q(The Barlavento dialect group of Kabuverdianu),
],
q(0016) => [
- q(Buddhist Hybrid Sanskrit),
+ q(Basic English),
],
q(0017) => [
- q(Biscayan dialect of Basque),
+ q(Buddhist Hybrid Sanskrit),
],
q(0018) => [
+ q(Biscayan dialect of Basque),
+ ],
+ q(0019) => [
q(The San Giorgio dialect of Resian),
q(The Bila dialect of Resian),
],
- q(0019) => [
+ q(0020) => [
q(Slovene in Bohoric alphabet),
],
- q(0020) => [
+ q(0021) => [
q(Boontling),
],
- q(0021) => [
+ q(0022) => [
q(Portuguese-Brazilian Orthographic Convention of 1945 (Convencao Ortografica Luso-Brasileira de 1945)),
],
- q(0022) => [
+ q(0023) => [
+ q(Cornu-English),
+ q(Cornish English),
+ q(Anglo-Cornish),
+ ],
+ q(0024) => [
q(Slovene in Dajnko alphabet),
],
- q(0023) => [
+ q(0025) => [
q(Serbian with Ekavian pronunciation),
],
- q(0024) => [
+ q(0026) => [
q(Early Modern English (1500-1700)),
],
- q(0025) => [
+ q(0027) => [
q(International Phonetic Alphabet),
],
- q(0026) => [
+ q(0028) => [
q(Uralic Phonetic Alphabet),
],
- q(0027) => [
+ q(0029) => [
q(X-SAMPA transcription),
],
- q(0028) => [
+ q(0030) => [
q(Hepburn romanization),
],
- q(0029) => [
+ q(0031) => [
q(Norwegian in Hognorsk (High Norwegian) orthography),
],
- q(0030) => [
+ q(0032) => [
q(Serbian with Ijekavian pronunciation),
],
- q(0031) => [
+ q(0033) => [
q(Epic Sanskrit),
],
- q(0032) => [
+ q(0034) => [
q(Jauer dialect of Romansh),
],
- q(0033) => [
+ q(0035) => [
q(Jyutping Cantonese Romanization),
],
- q(0034) => [
+ q(0036) => [
q(Common Cornish orthography of Revived Cornish),
],
- q(0035) => [
+ q(0037) => [
q(The Kociewie dialect of Polish),
],
- q(0036) => [
+ q(0038) => [
q(Standard Cornish orthography of Revived Cornish),
q(Kernowek Standard),
],
- q(0037) => [
+ q(0039) => [
q(Classical Sanskrit),
],
- q(0038) => [
+ q(0040) => [
q(The Lipovaz dialect of Resian),
q(The Lipovec dialect of Resian),
],
- q(0039) => [
+ q(0041) => [
q(Post-1917 Russian orthography),
],
- q(0040) => [
+ q(0042) => [
q(Slovene in Metelko alphabet),
],
- q(0041) => [
+ q(0043) => [
q(Monotonic Greek),
],
- q(0042) => [
+ q(0044) => [
q(Ndyuka dialect),
q(Aukan dialect),
],
- q(0043) => [
+ q(0045) => [
q(Natisone dialect),
q(Nadiza dialect),
],
- q(0044) => [
+ q(0046) => [
q(Newfoundland English),
],
- q(0045) => [
+ q(0047) => [
q(The Gniva dialect of Resian),
q(The Njiva dialect of Resian),
],
- q(0046) => [
+ q(0048) => [
q(Volapuk nulik),
q(Volapuk perevidol),
q(Volapuk nuladik),
q(Revised Volapuk),
q(Modern Volapuk),
],
- q(0047) => [
+ q(0049) => [
q(The Oseacco dialect of Resian),
q(The Osojane dialect of Resian),
],
- q(0048) => [
+ q(0050) => [
q(Oxford English Dictionary spelling),
],
- q(0049) => [
+ q(0051) => [
q(Pamaka dialect),
],
- q(0050) => [
+ q(0052) => [
q(Petrine orthography),
],
- q(0051) => [
+ q(0053) => [
q(Pinyin romanization),
],
- q(0052) => [
+ q(0054) => [
q(Polytonic Greek),
],
- q(0053) => [
+ q(0055) => [
q(Puter idiom of Romansh),
],
- q(0054) => [
+ q(0056) => [
q(Volapuk rigik),
q(Schleyer's Volapuk),
q(Original Volapuk),
q(Classic Volapuk),
],
- q(0055) => [
+ q(0057) => [
q(Resian),
q(Resianic),
q(Rezijan),
],
- q(0056) => [
+ q(0058) => [
q(Rumantsch Grischun),
],
- q(0057) => [
+ q(0059) => [
q(Scottish Standard English),
],
- q(0058) => [
+ q(0060) => [
q(Scouse),
],
- q(0059) => [
+ q(0061) => [
+ q(Simplified form),
+ ],
+ q(0062) => [
q(The Stolvizza dialect of Resian),
q(The Solbica dialect of Resian),
],
- q(0060) => [
+ q(0063) => [
q(The Sotavento dialect group of Kabuverdianu),
],
- q(0061) => [
+ q(0064) => [
q(Surmiran idiom of Romansh),
],
- q(0062) => [
+ q(0065) => [
q(Sursilvan idiom of Romansh),
],
- q(0063) => [
+ q(0066) => [
q(Sutsilvan idiom of Romansh),
],
- q(0064) => [
+ q(0067) => [
q(Belarusian in Taraskievica orthography),
],
- q(0065) => [
+ q(0068) => [
q(Unified Cornish orthography of Revived Cornish),
],
- q(0066) => [
+ q(0069) => [
q(Unified Cornish Revised orthography of Revived Cornish),
],
- q(0067) => [
+ q(0070) => [
q(Ulster dialect of Scots),
],
- q(0068) => [
+ q(0071) => [
q(Unifon phonetic alphabet),
],
- q(0069) => [
+ q(0072) => [
q(Vedic Sanskrit),
],
- q(0070) => [
+ q(0073) => [
q(Valencian),
],
- q(0071) => [
+ q(0074) => [
q(Vallader idiom of Romansh),
],
- q(0072) => [
+ q(0075) => [
q(Wade-Giles romanization),
],
};
q(0009),
q(0),
],
+ q(anglo-cornish) => [
+ q(0023),
+ q(2),
+ ],
q(aukan dialect) => [
- q(0042),
+ q(0044),
q(1),
],
+ q(basic english) => [
+ q(0016),
+ q(0),
+ ],
q(belarusian in taraskievica orthography) => [
- q(0064),
+ q(0067),
q(0),
],
q(biscayan dialect of basque) => [
- q(0017),
+ q(0018),
q(0),
],
q(boni dialect) => [
q(1),
],
q(boontling) => [
- q(0020),
+ q(0021),
q(0),
],
q(buddhist hybrid sanskrit) => [
- q(0016),
+ q(0017),
q(0),
],
q(classic volapuk) => [
- q(0054),
+ q(0056),
q(3),
],
q(classical sanskrit) => [
- q(0037),
+ q(0039),
q(0),
],
q(common cornish orthography of revived cornish) => [
- q(0034),
+ q(0036),
+ q(0),
+ ],
+ q(cornish english) => [
+ q(0023),
+ q(1),
+ ],
+ q(cornu-english) => [
+ q(0023),
q(0),
],
q(de jong's volapuk) => [
- q(0046),
+ q(0048),
q(3),
],
q(early modern english (1500-1700)) => [
- q(0024),
+ q(0026),
q(0),
],
q(early modern french) => [
q(0),
],
q(epic sanskrit) => [
- q(0031),
+ q(0033),
q(0),
],
q(german orthography of 1996) => [
q(0),
],
q(hepburn romanization) => [
- q(0028),
+ q(0030),
q(0),
],
q(international phonetic alphabet) => [
- q(0025),
+ q(0027),
q(0),
],
q(jauer dialect of romansh) => [
- q(0032),
+ q(0034),
q(0),
],
q(jyutping cantonese romanization) => [
- q(0033),
+ q(0035),
q(0),
],
q(kernowek standard) => [
- q(0036),
+ q(0038),
q(1),
],
q(late middle french (to 1606)) => [
q(0),
],
q(modern volapuk) => [
- q(0046),
+ q(0048),
q(6),
],
q(monotonic greek) => [
- q(0041),
+ q(0043),
q(0),
],
q(nadiza dialect) => [
- q(0043),
+ q(0045),
q(1),
],
q(natisone dialect) => [
- q(0043),
+ q(0045),
q(0),
],
q(ndyuka dialect) => [
- q(0042),
+ q(0044),
q(0),
],
q(new volapuk) => [
- q(0046),
+ q(0048),
q(4),
],
q(newfoundland english) => [
- q(0044),
+ q(0046),
q(0),
],
q(norwegian in hognorsk (high norwegian) orthography) => [
- q(0029),
+ q(0031),
q(0),
],
q(original volapuk) => [
- q(0054),
+ q(0056),
q(2),
],
q(orthographic formulation of 1943 - official in brazil (formulario ortografico de 1943 - oficial no brasil)) => [
q(0),
],
q(oxford english dictionary spelling) => [
- q(0048),
+ q(0050),
q(0),
],
q(pamaka dialect) => [
- q(0049),
+ q(0051),
q(0),
],
q(petrine orthography) => [
- q(0050),
+ q(0052),
q(0),
],
q(pinyin romanization) => [
- q(0051),
+ q(0053),
q(0),
],
q(polytonic greek) => [
- q(0052),
+ q(0054),
q(0),
],
q(portuguese language orthographic agreement of 1990 (acordo ortografico da lingua portuguesa de 1990)) => [
q(0),
],
q(portuguese-brazilian orthographic convention of 1945 (convencao ortografica luso-brasileira de 1945)) => [
- q(0021),
+ q(0022),
q(0),
],
q(post-1917 russian orthography) => [
- q(0039),
+ q(0041),
q(0),
],
q(puter idiom of romansh) => [
- q(0053),
+ q(0055),
q(0),
],
q(resian) => [
- q(0055),
+ q(0057),
q(0),
],
q(resianic) => [
- q(0055),
+ q(0057),
q(1),
],
q(revised volapuk) => [
- q(0046),
+ q(0048),
q(5),
],
q(rezijan) => [
- q(0055),
+ q(0057),
q(2),
],
q(rumantsch grischun) => [
- q(0056),
+ q(0058),
q(0),
],
q(schleyer's volapuk) => [
- q(0054),
+ q(0056),
q(1),
],
q(scottish standard english) => [
- q(0057),
+ q(0059),
q(0),
],
q(scouse) => [
- q(0058),
+ q(0060),
q(0),
],
q(serbian with ekavian pronunciation) => [
- q(0023),
+ q(0025),
q(0),
],
q(serbian with ijekavian pronunciation) => [
- q(0030),
+ q(0032),
+ q(0),
+ ],
+ q(simplified form) => [
+ q(0061),
q(0),
],
q(slovene in bohoric alphabet) => [
- q(0019),
+ q(0020),
q(0),
],
q(slovene in dajnko alphabet) => [
- q(0022),
+ q(0024),
q(0),
],
q(slovene in metelko alphabet) => [
- q(0040),
+ q(0042),
q(0),
],
q(standard cornish orthography of revived cornish) => [
- q(0036),
+ q(0038),
q(0),
],
q(standardized resian orthography) => [
q(0),
],
q(surmiran idiom of romansh) => [
- q(0061),
+ q(0064),
q(0),
],
q(sursilvan idiom of romansh) => [
- q(0062),
+ q(0065),
q(0),
],
q(sutsilvan idiom of romansh) => [
- q(0063),
+ q(0066),
q(0),
],
q(the balanka dialect of anii) => [
q(0),
],
q(the bila dialect of resian) => [
- q(0018),
+ q(0019),
q(1),
],
q(the gniva dialect of resian) => [
- q(0045),
+ q(0047),
q(0),
],
q(the kociewie dialect of polish) => [
- q(0035),
+ q(0037),
q(0),
],
q(the lipovaz dialect of resian) => [
- q(0038),
+ q(0040),
q(0),
],
q(the lipovec dialect of resian) => [
- q(0038),
+ q(0040),
q(1),
],
q(the njiva dialect of resian) => [
- q(0045),
+ q(0047),
q(1),
],
q(the oseacco dialect of resian) => [
- q(0047),
+ q(0049),
q(0),
],
q(the osojane dialect of resian) => [
- q(0047),
+ q(0049),
q(1),
],
q(the san giorgio dialect of resian) => [
- q(0018),
+ q(0019),
q(0),
],
q(the solbica dialect of resian) => [
- q(0059),
+ q(0062),
q(1),
],
q(the sotavento dialect group of kabuverdianu) => [
- q(0060),
+ q(0063),
q(0),
],
q(the stolvizza dialect of resian) => [
- q(0059),
+ q(0062),
q(0),
],
q(traditional german orthography) => [
q(0),
],
q(ulster dialect of scots) => [
- q(0067),
+ q(0070),
q(0),
],
q(unified cornish orthography of revived cornish) => [
- q(0065),
+ q(0068),
q(0),
],
q(unified cornish revised orthography of revived cornish) => [
- q(0066),
+ q(0069),
q(0),
],
q(unified turkic latin alphabet (historical)) => [
q(0),
],
q(unifon phonetic alphabet) => [
- q(0068),
+ q(0071),
q(0),
],
q(uralic phonetic alphabet) => [
- q(0026),
+ q(0028),
q(0),
],
q(valencian) => [
- q(0070),
+ q(0073),
q(0),
],
q(vallader idiom of romansh) => [
- q(0071),
+ q(0074),
q(0),
],
q(vedic sanskrit) => [
- q(0069),
+ q(0072),
q(0),
],
q(volapuk nuladik) => [
- q(0046),
+ q(0048),
q(2),
],
q(volapuk nulik) => [
- q(0046),
+ q(0048),
q(0),
],
q(volapuk perevidol) => [
- q(0046),
+ q(0048),
q(1),
],
q(volapuk rigik) => [
- q(0054),
+ q(0056),
q(0),
],
q(wade-giles romanization) => [
- q(0072),
+ q(0075),
q(0),
],
q(western armenian) => [
q(0),
],
q(x-sampa transcription) => [
- q(0027),
+ q(0029),
q(0),
],
};
q(0015),
q(0),
],
- q(bauddha) => [
+ q(basiceng) => [
q(0016),
q(0),
],
- q(biscayan) => [
+ q(bauddha) => [
q(0017),
q(0),
],
- q(biske) => [
+ q(biscayan) => [
q(0018),
q(0),
],
- q(bohoric) => [
+ q(biske) => [
q(0019),
q(0),
],
- q(boont) => [
+ q(bohoric) => [
q(0020),
q(0),
],
- q(colb1945) => [
+ q(boont) => [
q(0021),
q(0),
],
- q(dajnko) => [
+ q(colb1945) => [
q(0022),
q(0),
],
- q(ekavsk) => [
+ q(cornu) => [
q(0023),
q(0),
],
- q(emodeng) => [
+ q(dajnko) => [
q(0024),
q(0),
],
- q(fonipa) => [
+ q(ekavsk) => [
q(0025),
q(0),
],
- q(fonupa) => [
+ q(emodeng) => [
q(0026),
q(0),
],
- q(fonxsamp) => [
+ q(fonipa) => [
q(0027),
q(0),
],
- q(hepburn) => [
+ q(fonupa) => [
q(0028),
q(0),
],
- q(hognorsk) => [
+ q(fonxsamp) => [
q(0029),
q(0),
],
- q(ijekavsk) => [
+ q(hepburn) => [
q(0030),
q(0),
],
- q(itihasa) => [
+ q(hognorsk) => [
q(0031),
q(0),
],
- q(jauer) => [
+ q(ijekavsk) => [
q(0032),
q(0),
],
- q(jyutping) => [
+ q(itihasa) => [
q(0033),
q(0),
],
- q(kkcor) => [
+ q(jauer) => [
q(0034),
q(0),
],
- q(kociewie) => [
+ q(jyutping) => [
q(0035),
q(0),
],
- q(kscor) => [
+ q(kkcor) => [
q(0036),
q(0),
],
- q(laukika) => [
+ q(kociewie) => [
q(0037),
q(0),
],
- q(lipaw) => [
+ q(kscor) => [
q(0038),
q(0),
],
- q(luna1918) => [
+ q(laukika) => [
q(0039),
q(0),
],
- q(metelko) => [
+ q(lipaw) => [
q(0040),
q(0),
],
- q(monoton) => [
+ q(luna1918) => [
q(0041),
q(0),
],
- q(ndyuka) => [
+ q(metelko) => [
q(0042),
q(0),
],
- q(nedis) => [
+ q(monoton) => [
q(0043),
q(0),
],
- q(newfound) => [
+ q(ndyuka) => [
q(0044),
q(0),
],
- q(njiva) => [
+ q(nedis) => [
q(0045),
q(0),
],
- q(nulik) => [
+ q(newfound) => [
q(0046),
q(0),
],
- q(osojs) => [
+ q(njiva) => [
q(0047),
q(0),
],
- q(oxendict) => [
+ q(nulik) => [
q(0048),
q(0),
],
- q(pamaka) => [
+ q(osojs) => [
q(0049),
q(0),
],
- q(petr1708) => [
+ q(oxendict) => [
q(0050),
q(0),
],
- q(pinyin) => [
+ q(pamaka) => [
q(0051),
q(0),
],
- q(polyton) => [
+ q(petr1708) => [
q(0052),
q(0),
],
- q(puter) => [
+ q(pinyin) => [
q(0053),
q(0),
],
- q(rigik) => [
+ q(polyton) => [
q(0054),
q(0),
],
- q(rozaj) => [
+ q(puter) => [
q(0055),
q(0),
],
- q(rumgr) => [
+ q(rigik) => [
q(0056),
q(0),
],
- q(scotland) => [
+ q(rozaj) => [
q(0057),
q(0),
],
- q(scouse) => [
+ q(rumgr) => [
q(0058),
q(0),
],
- q(solba) => [
+ q(scotland) => [
q(0059),
q(0),
],
- q(sotav) => [
+ q(scouse) => [
q(0060),
q(0),
],
- q(surmiran) => [
+ q(simple) => [
q(0061),
q(0),
],
- q(sursilv) => [
+ q(solba) => [
q(0062),
q(0),
],
- q(sutsilv) => [
+ q(sotav) => [
q(0063),
q(0),
],
- q(tarask) => [
+ q(surmiran) => [
q(0064),
q(0),
],
- q(uccor) => [
+ q(sursilv) => [
q(0065),
q(0),
],
- q(ucrcor) => [
+ q(sutsilv) => [
q(0066),
q(0),
],
- q(ulster) => [
+ q(tarask) => [
q(0067),
q(0),
],
- q(unifon) => [
+ q(uccor) => [
q(0068),
q(0),
],
- q(vaidika) => [
+ q(ucrcor) => [
q(0069),
q(0),
],
- q(valencia) => [
+ q(ulster) => [
q(0070),
q(0),
],
- q(vallader) => [
+ q(unifon) => [
q(0071),
q(0),
],
- q(wadegile) => [
+ q(vaidika) => [
q(0072),
q(0),
],
+ q(valencia) => [
+ q(0073),
+ q(0),
+ ],
+ q(vallader) => [
+ q(0074),
+ q(0),
+ ],
+ q(wadegile) => [
+ q(0075),
+ q(0),
+ ],
},
};
q(0013) => q(baku1926),
q(0014) => q(balanka),
q(0015) => q(barla),
- q(0016) => q(bauddha),
- q(0017) => q(biscayan),
- q(0018) => q(biske),
- q(0019) => q(bohoric),
- q(0020) => q(boont),
- q(0021) => q(colb1945),
- q(0022) => q(dajnko),
- q(0023) => q(ekavsk),
- q(0024) => q(emodeng),
- q(0025) => q(fonipa),
- q(0026) => q(fonupa),
- q(0027) => q(fonxsamp),
- q(0028) => q(hepburn),
- q(0029) => q(hognorsk),
- q(0030) => q(ijekavsk),
- q(0031) => q(itihasa),
- q(0032) => q(jauer),
- q(0033) => q(jyutping),
- q(0034) => q(kkcor),
- q(0035) => q(kociewie),
- q(0036) => q(kscor),
- q(0037) => q(laukika),
- q(0038) => q(lipaw),
- q(0039) => q(luna1918),
- q(0040) => q(metelko),
- q(0041) => q(monoton),
- q(0042) => q(ndyuka),
- q(0043) => q(nedis),
- q(0044) => q(newfound),
- q(0045) => q(njiva),
- q(0046) => q(nulik),
- q(0047) => q(osojs),
- q(0048) => q(oxendict),
- q(0049) => q(pamaka),
- q(0050) => q(petr1708),
- q(0051) => q(pinyin),
- q(0052) => q(polyton),
- q(0053) => q(puter),
- q(0054) => q(rigik),
- q(0055) => q(rozaj),
- q(0056) => q(rumgr),
- q(0057) => q(scotland),
- q(0058) => q(scouse),
- q(0059) => q(solba),
- q(0060) => q(sotav),
- q(0061) => q(surmiran),
- q(0062) => q(sursilv),
- q(0063) => q(sutsilv),
- q(0064) => q(tarask),
- q(0065) => q(uccor),
- q(0066) => q(ucrcor),
- q(0067) => q(ulster),
- q(0068) => q(unifon),
- q(0069) => q(vaidika),
- q(0070) => q(valencia),
- q(0071) => q(vallader),
- q(0072) => q(wadegile),
+ q(0016) => q(basiceng),
+ q(0017) => q(bauddha),
+ q(0018) => q(biscayan),
+ q(0019) => q(biske),
+ q(0020) => q(bohoric),
+ q(0021) => q(boont),
+ q(0022) => q(colb1945),
+ q(0023) => q(cornu),
+ q(0024) => q(dajnko),
+ q(0025) => q(ekavsk),
+ q(0026) => q(emodeng),
+ q(0027) => q(fonipa),
+ q(0028) => q(fonupa),
+ q(0029) => q(fonxsamp),
+ q(0030) => q(hepburn),
+ q(0031) => q(hognorsk),
+ q(0032) => q(ijekavsk),
+ q(0033) => q(itihasa),
+ q(0034) => q(jauer),
+ q(0035) => q(jyutping),
+ q(0036) => q(kkcor),
+ q(0037) => q(kociewie),
+ q(0038) => q(kscor),
+ q(0039) => q(laukika),
+ q(0040) => q(lipaw),
+ q(0041) => q(luna1918),
+ q(0042) => q(metelko),
+ q(0043) => q(monoton),
+ q(0044) => q(ndyuka),
+ q(0045) => q(nedis),
+ q(0046) => q(newfound),
+ q(0047) => q(njiva),
+ q(0048) => q(nulik),
+ q(0049) => q(osojs),
+ q(0050) => q(oxendict),
+ q(0051) => q(pamaka),
+ q(0052) => q(petr1708),
+ q(0053) => q(pinyin),
+ q(0054) => q(polyton),
+ q(0055) => q(puter),
+ q(0056) => q(rigik),
+ q(0057) => q(rozaj),
+ q(0058) => q(rumgr),
+ q(0059) => q(scotland),
+ q(0060) => q(scouse),
+ q(0061) => q(simple),
+ q(0062) => q(solba),
+ q(0063) => q(sotav),
+ q(0064) => q(surmiran),
+ q(0065) => q(sursilv),
+ q(0066) => q(sutsilv),
+ q(0067) => q(tarask),
+ q(0068) => q(uccor),
+ q(0069) => q(ucrcor),
+ q(0070) => q(ulster),
+ q(0071) => q(unifon),
+ q(0072) => q(vaidika),
+ q(0073) => q(valencia),
+ q(0074) => q(vallader),
+ q(0075) => q(wadegile),
},
};
# This file was automatically generated. Any changes to this file will
# be lost the next time 'deprecate_codes' is run.
-# Generated on: Tue Dec 1 14:45:28 EST 2015
+# Generated on: Wed Mar 2 09:26:23 EST 2016
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.37';
+$VERSION='3.38';
$Locale::Codes::Retired{'langvar'}{'alpha'}{'code'} = {
};
package Locale::Codes::Language;
# Copyright (C) 2001 Canon Research Centre Europe (CRE).
# Copyright (C) 2002-2009 Neil Bowers
-# Copyright (c) 2010-2015 Sullivan Beck
+# Copyright (c) 2010-2016 Sullivan Beck
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
our($VERSION,@ISA,@EXPORT,@EXPORT_OK);
-$VERSION='3.37';
+$VERSION='3.38';
@ISA = qw(Exporter);
@EXPORT = qw(code2language
language2code
# cperl-continued-brace-offset: 0
# cperl-brace-offset: 0
# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
+# cperl-label-offset: 0
# End:
Copyright (c) 1997-2001 Canon Research Centre Europe (CRE).
Copyright (c) 2001-2010 Neil Bowers
- Copyright (c) 2010-2015 Sullivan Beck
+ Copyright (c) 2010-2016 Sullivan Beck
This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
# This file was automatically generated. Any changes to this file will
# be lost the next time 'harvest_data' is run.
-# Generated on: Tue Dec 1 14:41:14 EST 2015
+# Generated on: Wed Mar 2 08:58:07 EST 2016
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.37';
+$VERSION='3.38';
$Locale::Codes::Data{'language'}{'id'} = '7976';
# This file was automatically generated. Any changes to this file will
# be lost the next time 'deprecate_codes' is run.
-# Generated on: Tue Dec 1 14:45:28 EST 2015
+# Generated on: Wed Mar 2 09:26:23 EST 2016
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.37';
+$VERSION='3.38';
$Locale::Codes::Retired{'language'}{'alpha-2'}{'code'} = {
q(in) => q(Indonesian),
package Locale::Codes::Script;
# Copyright (C) 2001 Canon Research Centre Europe (CRE).
# Copyright (C) 2002-2009 Neil Bowers
-# Copyright (c) 2010-2015 Sullivan Beck
+# Copyright (c) 2010-2016 Sullivan Beck
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
our($VERSION,@ISA,@EXPORT,@EXPORT_OK);
-$VERSION='3.37';
+$VERSION='3.38';
@ISA = qw(Exporter);
@EXPORT = qw(code2script
script2code
# cperl-continued-brace-offset: 0
# cperl-brace-offset: 0
# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
+# cperl-label-offset: 0
# End:
Copyright (c) 1997-2001 Canon Research Centre Europe (CRE).
Copyright (c) 2001-2010 Neil Bowers
- Copyright (c) 2010-2015 Sullivan Beck
+ Copyright (c) 2010-2016 Sullivan Beck
This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
# This file was automatically generated. Any changes to this file will
# be lost the next time 'harvest_data' is run.
-# Generated on: Tue Dec 1 14:44:11 EST 2015
+# Generated on: Wed Mar 2 09:24:01 EST 2016
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.37';
+$VERSION='3.38';
-$Locale::Codes::Data{'script'}{'id'} = '0175';
+$Locale::Codes::Data{'script'}{'id'} = '0180';
$Locale::Codes::Data{'script'}{'id2names'} = {
q(0001) => [
q(Gurmukhi),
],
q(0048) => [
+ q(Han with Bopomofo (alias for Han + Bopomofo)),
+ ],
+ q(0049) => [
q(Hangul (Hangul, Hangeul)),
q(Hangul),
q(Hangeul),
],
- q(0049) => [
+ q(0050) => [
q(Han (Hanzi, Kanji, Hanja)),
q(Han),
q(Hanzi),
q(Kanji),
q(Hanja),
],
- q(0050) => [
+ q(0051) => [
q(Hanunoo (Hanunoo)),
q(Hanunoo),
],
- q(0051) => [
+ q(0052) => [
q(Han (Simplified variant)),
],
- q(0052) => [
+ q(0053) => [
q(Han (Traditional variant)),
],
- q(0053) => [
+ q(0054) => [
q(Hatran),
],
- q(0054) => [
+ q(0055) => [
q(Hebrew),
],
- q(0055) => [
+ q(0056) => [
q(Hiragana),
],
- q(0056) => [
+ q(0057) => [
q(Anatolian Hieroglyphs (Luwian Hieroglyphs, Hittite Hieroglyphs)),
q(Anatolian Hieroglyphs),
q(Luwian Hieroglyphs),
q(Hittite Hieroglyphs),
],
- q(0057) => [
+ q(0058) => [
q(Pahawh Hmong),
],
- q(0058) => [
+ q(0059) => [
q(Japanese syllabaries (alias for Hiragana + Katakana)),
],
- q(0059) => [
+ q(0060) => [
q(Old Hungarian (Hungarian Runic)),
q(Old Hungarian),
q(Hungarian Runic),
],
- q(0060) => [
+ q(0061) => [
q(Indus (Harappan)),
q(Indus),
q(Harappan),
],
- q(0061) => [
+ q(0062) => [
q(Old Italic (Etruscan, Oscan, etc.)),
],
- q(0062) => [
+ q(0063) => [
+ q(Jamo (alias for Jamo subset of Hangul)),
+ ],
+ q(0064) => [
q(Javanese),
],
- q(0063) => [
+ q(0065) => [
q(Japanese (alias for Han + Hiragana + Katakana)),
],
- q(0064) => [
+ q(0066) => [
q(Jurchen),
],
- q(0065) => [
+ q(0067) => [
q(Kayah Li),
],
- q(0066) => [
+ q(0068) => [
q(Katakana),
],
- q(0067) => [
+ q(0069) => [
q(Kharoshthi),
],
- q(0068) => [
+ q(0070) => [
q(Khmer),
],
- q(0069) => [
+ q(0071) => [
q(Khojki),
],
- q(0070) => [
+ q(0072) => [
q(Khitan large script),
],
- q(0071) => [
+ q(0073) => [
q(Khitan small script),
],
- q(0072) => [
+ q(0074) => [
q(Kannada),
],
- q(0073) => [
+ q(0075) => [
q(Korean (alias for Hangul + Han)),
],
- q(0074) => [
+ q(0076) => [
q(Kpelle),
],
- q(0075) => [
+ q(0077) => [
q(Kaithi),
],
- q(0076) => [
+ q(0078) => [
q(Tai Tham (Lanna)),
q(Tai Tham),
q(Lanna),
],
- q(0077) => [
+ q(0079) => [
q(Lao),
],
- q(0078) => [
+ q(0080) => [
q(Latin (Fraktur variant)),
],
- q(0079) => [
+ q(0081) => [
q(Latin (Gaelic variant)),
],
- q(0080) => [
+ q(0082) => [
q(Latin),
],
- q(0081) => [
+ q(0083) => [
q(Leke),
],
- q(0082) => [
+ q(0084) => [
q(Lepcha (Rong)),
q(Lepcha),
q(Rong),
],
- q(0083) => [
+ q(0085) => [
q(Limbu),
],
- q(0084) => [
+ q(0086) => [
q(Linear A),
],
- q(0085) => [
+ q(0087) => [
q(Linear B),
],
- q(0086) => [
+ q(0088) => [
q(Lisu (Fraser)),
q(Lisu),
q(Fraser),
],
- q(0087) => [
+ q(0089) => [
q(Loma),
],
- q(0088) => [
+ q(0090) => [
q(Lycian),
],
- q(0089) => [
+ q(0091) => [
q(Lydian),
],
- q(0090) => [
+ q(0092) => [
q(Mahajani),
],
- q(0091) => [
+ q(0093) => [
q(Mandaic, Mandaean),
q(Mandaic),
q(Mandaean),
],
- q(0092) => [
+ q(0094) => [
q(Manichaean),
],
- q(0093) => [
+ q(0095) => [
q(Marchen),
],
- q(0094) => [
+ q(0096) => [
q(Mayan hieroglyphs),
],
- q(0095) => [
+ q(0097) => [
q(Mende Kikakui),
],
- q(0096) => [
+ q(0098) => [
q(Meroitic Cursive),
],
- q(0097) => [
+ q(0099) => [
q(Meroitic Hieroglyphs),
],
- q(0098) => [
+ q(0100) => [
q(Malayalam),
],
- q(0099) => [
+ q(0101) => [
q(Modi, Modi),
q(Modi),
],
- q(0100) => [
+ q(0102) => [
q(Mongolian),
],
- q(0101) => [
+ q(0103) => [
q(Moon (Moon code, Moon script, Moon type)),
q(Moon),
q(Moon code),
q(Moon script),
q(Moon type),
],
- q(0102) => [
+ q(0104) => [
q(Mro, Mru),
q(Mro),
q(Mru),
],
- q(0103) => [
+ q(0105) => [
q(Meitei Mayek (Meithei, Meetei)),
q(Meitei Mayek),
q(Meithei),
q(Meetei),
],
- q(0104) => [
+ q(0106) => [
q(Multani),
],
- q(0105) => [
+ q(0107) => [
q(Myanmar (Burmese)),
q(Myanmar),
q(Burmese),
],
- q(0106) => [
+ q(0108) => [
q(Old North Arabian (Ancient North Arabian)),
q(Old North Arabian),
q(Ancient North Arabian),
],
- q(0107) => [
+ q(0109) => [
q(Nabataean),
],
- q(0108) => [
+ q(0110) => [
+ q(Newa, Newar, Newari, Nepala lipi),
+ q(Newa),
+ q(Newar),
+ q(Newari),
+ q(Nepala lipi),
+ ],
+ q(0111) => [
q(Nakhi Geba ('Na-'Khi Ggo-baw, Naxi Geba)),
q(Nakhi Geba),
q('Na-'Khi Ggo-baw),
q(Naxi Geba),
],
- q(0109) => [
+ q(0112) => [
q(N'Ko),
],
- q(0110) => [
+ q(0113) => [
q(Nushu),
],
- q(0111) => [
+ q(0114) => [
q(Ogham),
],
- q(0112) => [
+ q(0115) => [
q(Ol Chiki (Ol Cemet, Ol, Santali)),
q(Ol Chiki),
q(Ol Cemet'),
q(Ol),
q(Santali),
],
- q(0113) => [
+ q(0116) => [
q(Old Turkic, Orkhon Runic),
q(Old Turkic),
q(Orkhon Runic),
],
- q(0114) => [
+ q(0117) => [
q(Oriya),
],
- q(0115) => [
+ q(0118) => [
q(Osage),
],
- q(0116) => [
+ q(0119) => [
q(Osmanya),
],
- q(0117) => [
+ q(0120) => [
q(Palmyrene),
],
- q(0118) => [
+ q(0121) => [
q(Pau Cin Hau),
],
- q(0119) => [
+ q(0122) => [
q(Old Permic),
],
- q(0120) => [
+ q(0123) => [
q(Phags-pa),
],
- q(0121) => [
+ q(0124) => [
q(Inscriptional Pahlavi),
],
- q(0122) => [
+ q(0125) => [
q(Psalter Pahlavi),
],
- q(0123) => [
+ q(0126) => [
q(Book Pahlavi),
],
- q(0124) => [
+ q(0127) => [
q(Phoenician),
],
- q(0125) => [
+ q(0128) => [
q(Miao (Pollard)),
q(Miao),
q(Pollard),
],
- q(0126) => [
+ q(0129) => [
+ q(Klingon (KLI pIqaD)),
+ ],
+ q(0130) => [
q(Inscriptional Parthian),
],
- q(0127) => [
+ q(0131) => [
q(Reserved for private use (start)),
],
- q(0128) => [
+ q(0132) => [
q(Reserved for private use (end)),
],
- q(0129) => [
+ q(0133) => [
q(Rejang (Redjang, Kaganga)),
q(Rejang),
q(Redjang),
q(Kaganga),
],
- q(0130) => [
+ q(0134) => [
q(Rongorongo),
],
- q(0131) => [
+ q(0135) => [
q(Runic),
],
- q(0132) => [
+ q(0136) => [
q(Samaritan),
],
- q(0133) => [
+ q(0137) => [
q(Sarati),
],
- q(0134) => [
+ q(0138) => [
q(Old South Arabian),
],
- q(0135) => [
+ q(0139) => [
q(Saurashtra),
],
- q(0136) => [
+ q(0140) => [
q(SignWriting),
],
- q(0137) => [
+ q(0141) => [
q(Shavian (Shaw)),
q(Shavian),
q(Shaw),
],
- q(0138) => [
+ q(0142) => [
q(Sharada, Sarada),
q(Sharada),
q(Sarada),
],
- q(0139) => [
+ q(0143) => [
q(Siddham, Siddham, Siddhamatrka),
q(Siddham),
q(Siddhamatrka),
],
- q(0140) => [
+ q(0144) => [
q(Khudawadi, Sindhi),
q(Khudawadi),
q(Sindhi),
],
- q(0141) => [
+ q(0145) => [
q(Sinhala),
],
- q(0142) => [
+ q(0146) => [
q(Sora Sompeng),
],
- q(0143) => [
+ q(0147) => [
q(Sundanese),
],
- q(0144) => [
+ q(0148) => [
q(Syloti Nagri),
],
- q(0145) => [
+ q(0149) => [
q(Syriac),
],
- q(0146) => [
+ q(0150) => [
q(Syriac (Estrangelo variant)),
],
- q(0147) => [
+ q(0151) => [
q(Syriac (Western variant)),
],
- q(0148) => [
+ q(0152) => [
q(Syriac (Eastern variant)),
],
- q(0149) => [
+ q(0153) => [
q(Tagbanwa),
],
- q(0150) => [
+ q(0154) => [
q(Takri, Takri, Tankri),
q(Takri),
q(Tankri),
],
- q(0151) => [
+ q(0155) => [
q(Tai Le),
],
- q(0152) => [
+ q(0156) => [
q(New Tai Lue),
],
- q(0153) => [
+ q(0157) => [
q(Tamil),
],
- q(0154) => [
+ q(0158) => [
q(Tangut),
],
- q(0155) => [
+ q(0159) => [
q(Tai Viet),
],
- q(0156) => [
+ q(0160) => [
q(Telugu),
],
- q(0157) => [
+ q(0161) => [
q(Tengwar),
],
- q(0158) => [
+ q(0162) => [
q(Tifinagh (Berber)),
q(Tifinagh),
q(Berber),
],
- q(0159) => [
+ q(0163) => [
q(Tagalog (Baybayin, Alibata)),
q(Tagalog),
q(Baybayin),
q(Alibata),
],
- q(0160) => [
+ q(0164) => [
q(Thaana),
],
- q(0161) => [
+ q(0165) => [
q(Thai),
],
- q(0162) => [
+ q(0166) => [
q(Tibetan),
],
- q(0163) => [
+ q(0167) => [
q(Tirhuta),
],
- q(0164) => [
+ q(0168) => [
q(Ugaritic),
],
- q(0165) => [
+ q(0169) => [
q(Vai),
],
- q(0166) => [
+ q(0170) => [
q(Visible Speech),
],
- q(0167) => [
+ q(0171) => [
q(Warang Citi (Varang Kshiti)),
q(Warang Citi),
q(Varang Kshiti),
],
- q(0168) => [
+ q(0172) => [
q(Woleai),
],
- q(0169) => [
+ q(0173) => [
q(Old Persian),
],
- q(0170) => [
+ q(0174) => [
q(Cuneiform, Sumero-Akkadian),
q(Sumero-Akkadian cuneiform),
],
- q(0171) => [
+ q(0175) => [
q(Yi),
],
- q(0172) => [
+ q(0176) => [
q(Code for inherited script),
],
- q(0173) => [
+ q(0177) => [
q(Mathematical notation),
],
- q(0174) => [
+ q(0178) => [
+ q(Symbols (Emoji variant)),
+ ],
+ q(0179) => [
q(Symbols),
],
};
$Locale::Codes::Data{'script'}{'alias2id'} = {
q('na-'khi ggo-baw) => [
- q(0108),
+ q(0111),
q(2),
],
q(adlam) => [
q(0),
],
q(alibata) => [
- q(0159),
+ q(0163),
q(3),
],
q(anatolian hieroglyphs) => [
- q(0056),
+ q(0057),
q(1),
],
q(anatolian hieroglyphs (luwian hieroglyphs, hittite hieroglyphs)) => [
- q(0056),
+ q(0057),
q(0),
],
q(ancient north arabian) => [
- q(0106),
+ q(0108),
q(2),
],
q(arabic) => [
q(0),
],
q(baybayin) => [
- q(0159),
+ q(0163),
q(2),
],
q(bengali) => [
q(0),
],
q(berber) => [
- q(0158),
+ q(0162),
q(2),
],
q(bhaiksuki) => [
q(0),
],
q(book pahlavi) => [
- q(0123),
+ q(0126),
q(0),
],
q(bopomofo) => [
q(0),
],
q(burmese) => [
- q(0105),
+ q(0107),
q(2),
],
q(carian) => [
q(0),
],
q(code for inherited script) => [
- q(0172),
+ q(0176),
q(0),
],
q(coptic) => [
q(0),
],
q(cuneiform, sumero-akkadian) => [
- q(0170),
+ q(0174),
q(0),
],
q(cypriot) => [
q(0),
],
q(fraser) => [
- q(0086),
+ q(0088),
q(2),
],
q(ge'ez) => [
q(0),
],
q(han) => [
- q(0049),
+ q(0050),
q(1),
],
q(han (hanzi, kanji, hanja)) => [
- q(0049),
+ q(0050),
q(0),
],
q(han (simplified variant)) => [
- q(0051),
+ q(0052),
q(0),
],
q(han (traditional variant)) => [
- q(0052),
+ q(0053),
q(0),
],
- q(hangeul) => [
+ q(han with bopomofo (alias for han + bopomofo)) => [
q(0048),
+ q(0),
+ ],
+ q(hangeul) => [
+ q(0049),
q(2),
],
q(hangul) => [
- q(0048),
+ q(0049),
q(1),
],
q(hangul (hangul, hangeul)) => [
- q(0048),
+ q(0049),
q(0),
],
q(hanja) => [
- q(0049),
+ q(0050),
q(4),
],
q(hanunoo) => [
- q(0050),
+ q(0051),
q(1),
],
q(hanunoo (hanunoo)) => [
- q(0050),
+ q(0051),
q(0),
],
q(hanzi) => [
- q(0049),
+ q(0050),
q(2),
],
q(harappan) => [
- q(0060),
+ q(0061),
q(2),
],
q(hatran) => [
- q(0053),
+ q(0054),
q(0),
],
q(hebrew) => [
- q(0054),
+ q(0055),
q(0),
],
q(hiragana) => [
- q(0055),
+ q(0056),
q(0),
],
q(hittite hieroglyphs) => [
- q(0056),
+ q(0057),
q(3),
],
q(hungarian runic) => [
- q(0059),
+ q(0060),
q(2),
],
q(imperial aramaic) => [
q(0),
],
q(indus) => [
- q(0060),
+ q(0061),
q(1),
],
q(indus (harappan)) => [
- q(0060),
+ q(0061),
q(0),
],
q(inscriptional pahlavi) => [
- q(0121),
+ q(0124),
q(0),
],
q(inscriptional parthian) => [
- q(0126),
+ q(0130),
q(0),
],
- q(japanese (alias for han + hiragana + katakana)) => [
+ q(jamo (alias for jamo subset of hangul)) => [
q(0063),
q(0),
],
+ q(japanese (alias for han + hiragana + katakana)) => [
+ q(0065),
+ q(0),
+ ],
q(japanese syllabaries (alias for hiragana + katakana)) => [
- q(0058),
+ q(0059),
q(0),
],
q(javanese) => [
- q(0062),
+ q(0064),
q(0),
],
q(jurchen) => [
- q(0064),
+ q(0066),
q(0),
],
q(kaganga) => [
- q(0129),
+ q(0133),
q(3),
],
q(kaithi) => [
- q(0075),
+ q(0077),
q(0),
],
q(kanji) => [
- q(0049),
+ q(0050),
q(3),
],
q(kannada) => [
- q(0072),
+ q(0074),
q(0),
],
q(katakana) => [
- q(0066),
+ q(0068),
q(0),
],
q(kayah li) => [
- q(0065),
+ q(0067),
q(0),
],
q(kharoshthi) => [
- q(0067),
+ q(0069),
q(0),
],
q(khitan large script) => [
- q(0070),
+ q(0072),
q(0),
],
q(khitan small script) => [
- q(0071),
+ q(0073),
q(0),
],
q(khmer) => [
- q(0068),
+ q(0070),
q(0),
],
q(khojki) => [
- q(0069),
+ q(0071),
q(0),
],
q(khudawadi) => [
- q(0140),
+ q(0144),
q(1),
],
q(khudawadi, sindhi) => [
- q(0140),
+ q(0144),
q(0),
],
q(khutsuri (asomtavruli and nuskhuri)) => [
q(0040),
q(0),
],
+ q(klingon (kli piqad)) => [
+ q(0129),
+ q(0),
+ ],
q(korean (alias for hangul + han)) => [
- q(0073),
+ q(0075),
q(0),
],
q(kpelle) => [
- q(0074),
+ q(0076),
q(0),
],
q(lanna) => [
- q(0076),
+ q(0078),
q(2),
],
q(lao) => [
- q(0077),
+ q(0079),
q(0),
],
q(latin) => [
- q(0080),
+ q(0082),
q(0),
],
q(latin (fraktur variant)) => [
- q(0078),
+ q(0080),
q(0),
],
q(latin (gaelic variant)) => [
- q(0079),
+ q(0081),
q(0),
],
q(leke) => [
- q(0081),
+ q(0083),
q(0),
],
q(lepcha) => [
- q(0082),
+ q(0084),
q(1),
],
q(lepcha (rong)) => [
- q(0082),
+ q(0084),
q(0),
],
q(limbu) => [
- q(0083),
+ q(0085),
q(0),
],
q(linear a) => [
- q(0084),
+ q(0086),
q(0),
],
q(linear b) => [
- q(0085),
+ q(0087),
q(0),
],
q(lisu) => [
- q(0086),
+ q(0088),
q(1),
],
q(lisu (fraser)) => [
- q(0086),
+ q(0088),
q(0),
],
q(loma) => [
- q(0087),
+ q(0089),
q(0),
],
q(luwian hieroglyphs) => [
- q(0056),
+ q(0057),
q(2),
],
q(lycian) => [
- q(0088),
+ q(0090),
q(0),
],
q(lydian) => [
- q(0089),
+ q(0091),
q(0),
],
q(mahajani) => [
- q(0090),
+ q(0092),
q(0),
],
q(malayalam) => [
- q(0098),
+ q(0100),
q(0),
],
q(mandaean) => [
- q(0091),
+ q(0093),
q(2),
],
q(mandaic) => [
- q(0091),
+ q(0093),
q(1),
],
q(mandaic, mandaean) => [
- q(0091),
+ q(0093),
q(0),
],
q(manichaean) => [
- q(0092),
+ q(0094),
q(0),
],
q(marchen) => [
- q(0093),
+ q(0095),
q(0),
],
q(mathematical notation) => [
- q(0173),
+ q(0177),
q(0),
],
q(mayan hieroglyphs) => [
- q(0094),
+ q(0096),
q(0),
],
q(meetei) => [
- q(0103),
+ q(0105),
q(3),
],
q(meitei mayek) => [
- q(0103),
+ q(0105),
q(1),
],
q(meitei mayek (meithei, meetei)) => [
- q(0103),
+ q(0105),
q(0),
],
q(meithei) => [
- q(0103),
+ q(0105),
q(2),
],
q(mende kikakui) => [
- q(0095),
+ q(0097),
q(0),
],
q(meroitic cursive) => [
- q(0096),
+ q(0098),
q(0),
],
q(meroitic hieroglyphs) => [
- q(0097),
+ q(0099),
q(0),
],
q(miao) => [
- q(0125),
+ q(0128),
q(1),
],
q(miao (pollard)) => [
- q(0125),
+ q(0128),
q(0),
],
q(modi) => [
- q(0099),
+ q(0101),
q(1),
],
q(modi, modi) => [
- q(0099),
+ q(0101),
q(0),
],
q(mongolian) => [
- q(0100),
+ q(0102),
q(0),
],
q(moon) => [
- q(0101),
+ q(0103),
q(1),
],
q(moon (moon code, moon script, moon type)) => [
- q(0101),
+ q(0103),
q(0),
],
q(moon code) => [
- q(0101),
+ q(0103),
q(2),
],
q(moon script) => [
- q(0101),
+ q(0103),
q(3),
],
q(moon type) => [
- q(0101),
+ q(0103),
q(4),
],
q(mormon) => [
q(2),
],
q(mro) => [
- q(0102),
+ q(0104),
q(1),
],
q(mro, mru) => [
- q(0102),
+ q(0104),
q(0),
],
q(mru) => [
- q(0102),
+ q(0104),
q(2),
],
q(multani) => [
- q(0104),
+ q(0106),
q(0),
],
q(myanmar) => [
- q(0105),
+ q(0107),
q(1),
],
q(myanmar (burmese)) => [
- q(0105),
+ q(0107),
q(0),
],
q(n'ko) => [
- q(0109),
+ q(0112),
q(0),
],
q(nabataean) => [
- q(0107),
+ q(0109),
q(0),
],
q(nagari) => [
q(2),
],
q(nakhi geba) => [
- q(0108),
+ q(0111),
q(1),
],
q(nakhi geba ('na-'khi ggo-baw, naxi geba)) => [
- q(0108),
+ q(0111),
q(0),
],
q(naxi geba) => [
- q(0108),
+ q(0111),
q(3),
],
+ q(nepala lipi) => [
+ q(0110),
+ q(4),
+ ],
q(new tai lue) => [
- q(0152),
+ q(0156),
q(0),
],
- q(nushu) => [
+ q(newa) => [
+ q(0110),
+ q(1),
+ ],
+ q(newa, newar, newari, nepala lipi) => [
q(0110),
q(0),
],
+ q(newar) => [
+ q(0110),
+ q(2),
+ ],
+ q(newari) => [
+ q(0110),
+ q(3),
+ ],
+ q(nushu) => [
+ q(0113),
+ q(0),
+ ],
q(ogham) => [
- q(0111),
+ q(0114),
q(0),
],
q(ol) => [
- q(0112),
+ q(0115),
q(3),
],
q(ol cemet') => [
- q(0112),
+ q(0115),
q(2),
],
q(ol chiki) => [
- q(0112),
+ q(0115),
q(1),
],
q(ol chiki (ol cemet, ol, santali)) => [
- q(0112),
+ q(0115),
q(0),
],
q(old hungarian) => [
- q(0059),
+ q(0060),
q(1),
],
q(old hungarian (hungarian runic)) => [
- q(0059),
+ q(0060),
q(0),
],
q(old italic (etruscan, oscan, etc.)) => [
- q(0061),
+ q(0062),
q(0),
],
q(old north arabian) => [
- q(0106),
+ q(0108),
q(1),
],
q(old north arabian (ancient north arabian)) => [
- q(0106),
+ q(0108),
q(0),
],
q(old permic) => [
- q(0119),
+ q(0122),
q(0),
],
q(old persian) => [
- q(0169),
+ q(0173),
q(0),
],
q(old south arabian) => [
- q(0134),
+ q(0138),
q(0),
],
q(old turkic) => [
- q(0113),
+ q(0116),
q(1),
],
q(old turkic, orkhon runic) => [
- q(0113),
+ q(0116),
q(0),
],
q(oriya) => [
- q(0114),
+ q(0117),
q(0),
],
q(orkhon runic) => [
- q(0113),
+ q(0116),
q(2),
],
q(osage) => [
- q(0115),
+ q(0118),
q(0),
],
q(osmanya) => [
- q(0116),
+ q(0119),
q(0),
],
q(pahawh hmong) => [
- q(0057),
+ q(0058),
q(0),
],
q(palmyrene) => [
- q(0117),
+ q(0120),
q(0),
],
q(pau cin hau) => [
- q(0118),
+ q(0121),
q(0),
],
q(phags-pa) => [
- q(0120),
+ q(0123),
q(0),
],
q(phoenician) => [
- q(0124),
+ q(0127),
q(0),
],
q(pollard) => [
- q(0125),
+ q(0128),
q(2),
],
q(psalter pahlavi) => [
- q(0122),
+ q(0125),
q(0),
],
q(redjang) => [
- q(0129),
+ q(0133),
q(2),
],
q(rejang) => [
- q(0129),
+ q(0133),
q(1),
],
q(rejang (redjang, kaganga)) => [
- q(0129),
+ q(0133),
q(0),
],
q(reserved for private use (end)) => [
- q(0128),
+ q(0132),
q(0),
],
q(reserved for private use (start)) => [
- q(0127),
+ q(0131),
q(0),
],
q(rong) => [
- q(0082),
+ q(0084),
q(2),
],
q(rongorongo) => [
- q(0130),
+ q(0134),
q(0),
],
q(runic) => [
- q(0131),
+ q(0135),
q(0),
],
q(samaritan) => [
- q(0132),
+ q(0136),
q(0),
],
q(santali) => [
- q(0112),
+ q(0115),
q(4),
],
q(sarada) => [
- q(0138),
+ q(0142),
q(2),
],
q(sarati) => [
- q(0133),
+ q(0137),
q(0),
],
q(saurashtra) => [
- q(0135),
+ q(0139),
q(0),
],
q(sharada) => [
- q(0138),
+ q(0142),
q(1),
],
q(sharada, sarada) => [
- q(0138),
+ q(0142),
q(0),
],
q(shavian) => [
- q(0137),
+ q(0141),
q(1),
],
q(shavian (shaw)) => [
- q(0137),
+ q(0141),
q(0),
],
q(shaw) => [
- q(0137),
+ q(0141),
q(2),
],
q(siddham) => [
- q(0139),
+ q(0143),
q(1),
],
q(siddham, siddham, siddhamatrka) => [
- q(0139),
+ q(0143),
q(0),
],
q(siddhamatrka) => [
- q(0139),
+ q(0143),
q(2),
],
q(signwriting) => [
- q(0136),
+ q(0140),
q(0),
],
q(sindhi) => [
- q(0140),
+ q(0144),
q(2),
],
q(sinhala) => [
- q(0141),
+ q(0145),
q(0),
],
q(sora sompeng) => [
- q(0142),
+ q(0146),
q(0),
],
q(sumero-akkadian cuneiform) => [
- q(0170),
+ q(0174),
q(1),
],
q(sundanese) => [
- q(0143),
+ q(0147),
q(0),
],
q(syloti nagri) => [
- q(0144),
+ q(0148),
q(0),
],
q(symbols) => [
- q(0174),
+ q(0179),
+ q(0),
+ ],
+ q(symbols (emoji variant)) => [
+ q(0178),
q(0),
],
q(syriac) => [
- q(0145),
+ q(0149),
q(0),
],
q(syriac (eastern variant)) => [
- q(0148),
+ q(0152),
q(0),
],
q(syriac (estrangelo variant)) => [
- q(0146),
+ q(0150),
q(0),
],
q(syriac (western variant)) => [
- q(0147),
+ q(0151),
q(0),
],
q(tagalog) => [
- q(0159),
+ q(0163),
q(1),
],
q(tagalog (baybayin, alibata)) => [
- q(0159),
+ q(0163),
q(0),
],
q(tagbanwa) => [
- q(0149),
+ q(0153),
q(0),
],
q(tai ahom) => [
q(2),
],
q(tai le) => [
- q(0151),
+ q(0155),
q(0),
],
q(tai tham) => [
- q(0076),
+ q(0078),
q(1),
],
q(tai tham (lanna)) => [
- q(0076),
+ q(0078),
q(0),
],
q(tai viet) => [
- q(0155),
+ q(0159),
q(0),
],
q(takri) => [
- q(0150),
+ q(0154),
q(1),
],
q(takri, takri, tankri) => [
- q(0150),
+ q(0154),
q(0),
],
q(tamil) => [
- q(0153),
+ q(0157),
q(0),
],
q(tangut) => [
- q(0154),
+ q(0158),
q(0),
],
q(tankri) => [
- q(0150),
+ q(0154),
q(2),
],
q(telugu) => [
- q(0156),
+ q(0160),
q(0),
],
q(tengwar) => [
- q(0157),
+ q(0161),
q(0),
],
q(thaana) => [
- q(0160),
+ q(0164),
q(0),
],
q(thai) => [
- q(0161),
+ q(0165),
q(0),
],
q(tibetan) => [
- q(0162),
+ q(0166),
q(0),
],
q(tifinagh) => [
- q(0158),
+ q(0162),
q(1),
],
q(tifinagh (berber)) => [
- q(0158),
+ q(0162),
q(0),
],
q(tirhuta) => [
- q(0163),
+ q(0167),
q(0),
],
q(ugaritic) => [
- q(0164),
+ q(0168),
q(0),
],
q(unified canadian aboriginal syllabics) => [
q(0),
],
q(vai) => [
- q(0165),
+ q(0169),
q(0),
],
q(varang kshiti) => [
- q(0167),
+ q(0171),
q(2),
],
q(visible speech) => [
- q(0166),
+ q(0170),
q(0),
],
q(warang citi) => [
- q(0167),
+ q(0171),
q(1),
],
q(warang citi (varang kshiti)) => [
- q(0167),
+ q(0171),
q(0),
],
q(woleai) => [
- q(0168),
+ q(0172),
q(0),
],
q(yi) => [
- q(0171),
+ q(0175),
q(0),
],
};
q(0047),
q(0),
],
- q(Hang) => [
+ q(Hanb) => [
q(0048),
+ q(0),
+ ],
+ q(Hang) => [
+ q(0049),
q(1),
],
q(Hani) => [
- q(0049),
+ q(0050),
q(1),
],
q(Hano) => [
- q(0050),
+ q(0051),
q(1),
],
q(Hans) => [
- q(0051),
+ q(0052),
q(0),
],
q(Hant) => [
- q(0052),
+ q(0053),
q(0),
],
q(Hatr) => [
- q(0053),
+ q(0054),
q(0),
],
q(Hebr) => [
- q(0054),
+ q(0055),
q(0),
],
q(Hira) => [
- q(0055),
+ q(0056),
q(0),
],
q(Hluw) => [
- q(0056),
+ q(0057),
q(1),
],
q(Hmng) => [
- q(0057),
+ q(0058),
q(0),
],
q(Hrkt) => [
- q(0058),
+ q(0059),
q(0),
],
q(Hung) => [
- q(0059),
+ q(0060),
q(1),
],
q(Inds) => [
- q(0060),
+ q(0061),
q(1),
],
q(Ital) => [
- q(0061),
+ q(0062),
+ q(0),
+ ],
+ q(Jamo) => [
+ q(0063),
q(0),
],
q(Java) => [
- q(0062),
+ q(0064),
q(0),
],
q(Jpan) => [
- q(0063),
+ q(0065),
q(0),
],
q(Jurc) => [
- q(0064),
+ q(0066),
q(0),
],
q(Kali) => [
- q(0065),
+ q(0067),
q(0),
],
q(Kana) => [
- q(0066),
+ q(0068),
q(0),
],
q(Khar) => [
- q(0067),
+ q(0069),
q(0),
],
q(Khmr) => [
- q(0068),
+ q(0070),
q(0),
],
q(Khoj) => [
- q(0069),
+ q(0071),
q(0),
],
q(Kitl) => [
- q(0070),
+ q(0072),
q(0),
],
q(Kits) => [
- q(0071),
+ q(0073),
q(0),
],
q(Knda) => [
- q(0072),
+ q(0074),
q(0),
],
q(Kore) => [
- q(0073),
+ q(0075),
q(0),
],
q(Kpel) => [
- q(0074),
+ q(0076),
q(0),
],
q(Kthi) => [
- q(0075),
+ q(0077),
q(0),
],
q(Lana) => [
- q(0076),
+ q(0078),
q(1),
],
q(Laoo) => [
- q(0077),
+ q(0079),
q(0),
],
q(Latf) => [
- q(0078),
+ q(0080),
q(0),
],
q(Latg) => [
- q(0079),
+ q(0081),
q(0),
],
q(Latn) => [
- q(0080),
+ q(0082),
q(0),
],
q(Leke) => [
- q(0081),
+ q(0083),
q(0),
],
q(Lepc) => [
- q(0082),
+ q(0084),
q(1),
],
q(Limb) => [
- q(0083),
+ q(0085),
q(0),
],
q(Lina) => [
- q(0084),
+ q(0086),
q(0),
],
q(Linb) => [
- q(0085),
+ q(0087),
q(0),
],
q(Lisu) => [
- q(0086),
+ q(0088),
q(1),
],
q(Loma) => [
- q(0087),
+ q(0089),
q(0),
],
q(Lyci) => [
- q(0088),
+ q(0090),
q(0),
],
q(Lydi) => [
- q(0089),
+ q(0091),
q(0),
],
q(Mahj) => [
- q(0090),
+ q(0092),
q(0),
],
q(Mand) => [
- q(0091),
+ q(0093),
q(1),
],
q(Mani) => [
- q(0092),
+ q(0094),
q(0),
],
q(Marc) => [
- q(0093),
+ q(0095),
q(0),
],
q(Maya) => [
- q(0094),
+ q(0096),
q(0),
],
q(Mend) => [
- q(0095),
+ q(0097),
q(0),
],
q(Merc) => [
- q(0096),
+ q(0098),
q(0),
],
q(Mero) => [
- q(0097),
+ q(0099),
q(0),
],
q(Mlym) => [
- q(0098),
+ q(0100),
q(0),
],
q(Modi) => [
- q(0099),
+ q(0101),
q(1),
],
q(Mong) => [
- q(0100),
+ q(0102),
q(0),
],
q(Moon) => [
- q(0101),
+ q(0103),
q(1),
],
q(Mroo) => [
- q(0102),
+ q(0104),
q(1),
],
q(Mtei) => [
- q(0103),
+ q(0105),
q(1),
],
q(Mult) => [
- q(0104),
+ q(0106),
q(0),
],
q(Mymr) => [
- q(0105),
+ q(0107),
q(1),
],
q(Narb) => [
- q(0106),
+ q(0108),
q(1),
],
q(Nbat) => [
- q(0107),
+ q(0109),
q(0),
],
+ q(Newa) => [
+ q(0110),
+ q(1),
+ ],
q(Nkgb) => [
- q(0108),
+ q(0111),
q(1),
],
q(Nkoo) => [
- q(0109),
+ q(0112),
q(0),
],
q(Nshu) => [
- q(0110),
+ q(0113),
q(0),
],
q(Ogam) => [
- q(0111),
+ q(0114),
q(0),
],
q(Olck) => [
- q(0112),
+ q(0115),
q(1),
],
q(Orkh) => [
- q(0113),
+ q(0116),
q(1),
],
q(Orya) => [
- q(0114),
+ q(0117),
q(0),
],
q(Osge) => [
- q(0115),
+ q(0118),
q(0),
],
q(Osma) => [
- q(0116),
+ q(0119),
q(0),
],
q(Palm) => [
- q(0117),
+ q(0120),
q(0),
],
q(Pauc) => [
- q(0118),
+ q(0121),
q(0),
],
q(Perm) => [
- q(0119),
+ q(0122),
q(0),
],
q(Phag) => [
- q(0120),
+ q(0123),
q(0),
],
q(Phli) => [
- q(0121),
+ q(0124),
q(0),
],
q(Phlp) => [
- q(0122),
+ q(0125),
q(0),
],
q(Phlv) => [
- q(0123),
+ q(0126),
q(0),
],
q(Phnx) => [
- q(0124),
+ q(0127),
+ q(0),
+ ],
+ q(Piqd) => [
+ q(0129),
q(0),
],
q(Plrd) => [
- q(0125),
+ q(0128),
q(1),
],
q(Prti) => [
- q(0126),
+ q(0130),
q(0),
],
q(Qaaa) => [
- q(0127),
+ q(0131),
q(0),
],
q(Qabx) => [
- q(0128),
+ q(0132),
q(0),
],
q(Rjng) => [
- q(0129),
+ q(0133),
q(1),
],
q(Roro) => [
- q(0130),
+ q(0134),
q(0),
],
q(Runr) => [
- q(0131),
+ q(0135),
q(0),
],
q(Samr) => [
- q(0132),
+ q(0136),
q(0),
],
q(Sara) => [
- q(0133),
+ q(0137),
q(0),
],
q(Sarb) => [
- q(0134),
+ q(0138),
q(0),
],
q(Saur) => [
- q(0135),
+ q(0139),
q(0),
],
q(Sgnw) => [
- q(0136),
+ q(0140),
q(0),
],
q(Shaw) => [
- q(0137),
+ q(0141),
q(1),
],
q(Shrd) => [
- q(0138),
+ q(0142),
q(1),
],
q(Sidd) => [
- q(0139),
+ q(0143),
q(1),
],
q(Sind) => [
- q(0140),
+ q(0144),
q(1),
],
q(Sinh) => [
- q(0141),
+ q(0145),
q(0),
],
q(Sora) => [
- q(0142),
+ q(0146),
q(0),
],
q(Sund) => [
- q(0143),
+ q(0147),
q(0),
],
q(Sylo) => [
- q(0144),
+ q(0148),
q(0),
],
q(Syrc) => [
- q(0145),
+ q(0149),
q(0),
],
q(Syre) => [
- q(0146),
+ q(0150),
q(0),
],
q(Syrj) => [
- q(0147),
+ q(0151),
q(0),
],
q(Syrn) => [
- q(0148),
+ q(0152),
q(0),
],
q(Tagb) => [
- q(0149),
+ q(0153),
q(0),
],
q(Takr) => [
- q(0150),
+ q(0154),
q(1),
],
q(Tale) => [
- q(0151),
+ q(0155),
q(0),
],
q(Talu) => [
- q(0152),
+ q(0156),
q(0),
],
q(Taml) => [
- q(0153),
+ q(0157),
q(0),
],
q(Tang) => [
- q(0154),
+ q(0158),
q(0),
],
q(Tavt) => [
- q(0155),
+ q(0159),
q(0),
],
q(Telu) => [
- q(0156),
+ q(0160),
q(0),
],
q(Teng) => [
- q(0157),
+ q(0161),
q(0),
],
q(Tfng) => [
- q(0158),
+ q(0162),
q(1),
],
q(Tglg) => [
- q(0159),
+ q(0163),
q(1),
],
q(Thaa) => [
- q(0160),
+ q(0164),
q(0),
],
q(Thai) => [
- q(0161),
+ q(0165),
q(0),
],
q(Tibt) => [
- q(0162),
+ q(0166),
q(0),
],
q(Tirh) => [
- q(0163),
+ q(0167),
q(0),
],
q(Ugar) => [
- q(0164),
+ q(0168),
q(0),
],
q(Vaii) => [
- q(0165),
+ q(0169),
q(0),
],
q(Visp) => [
- q(0166),
+ q(0170),
q(0),
],
q(Wara) => [
- q(0167),
+ q(0171),
q(1),
],
q(Wole) => [
- q(0168),
+ q(0172),
q(0),
],
q(Xpeo) => [
- q(0169),
+ q(0173),
q(0),
],
q(Xsux) => [
- q(0170),
+ q(0174),
q(1),
],
q(Yiii) => [
- q(0171),
+ q(0175),
q(0),
],
q(Zinh) => [
- q(0172),
+ q(0176),
q(0),
],
q(Zmth) => [
- q(0173),
+ q(0177),
+ q(0),
+ ],
+ q(Zsye) => [
+ q(0178),
q(0),
],
q(Zsym) => [
- q(0174),
+ q(0179),
q(0),
],
},
q(num) => {
q(020) => [
- q(0170),
+ q(0174),
q(0),
],
q(030) => [
- q(0169),
+ q(0173),
q(0),
],
q(040) => [
- q(0164),
+ q(0168),
q(0),
],
q(050) => [
q(0),
],
q(080) => [
- q(0056),
+ q(0057),
q(0),
],
q(090) => [
- q(0094),
+ q(0096),
q(0),
],
q(095) => [
- q(0136),
+ q(0140),
q(0),
],
q(100) => [
- q(0097),
+ q(0099),
q(0),
],
q(101) => [
- q(0096),
+ q(0098),
q(0),
],
q(105) => [
- q(0134),
+ q(0138),
q(0),
],
q(106) => [
- q(0106),
+ q(0108),
q(0),
],
q(115) => [
- q(0124),
+ q(0127),
q(0),
],
q(116) => [
- q(0089),
+ q(0091),
q(0),
],
q(120) => [
- q(0158),
+ q(0162),
q(0),
],
q(123) => [
- q(0132),
+ q(0136),
q(0),
],
q(124) => [
q(0),
],
q(125) => [
- q(0054),
+ q(0055),
q(0),
],
q(126) => [
- q(0117),
+ q(0120),
q(0),
],
q(127) => [
- q(0053),
+ q(0054),
q(0),
],
q(130) => [
- q(0126),
+ q(0130),
q(0),
],
q(131) => [
- q(0121),
+ q(0124),
q(0),
],
q(132) => [
- q(0122),
+ q(0125),
q(0),
],
q(133) => [
- q(0123),
+ q(0126),
q(0),
],
q(134) => [
q(0),
],
q(135) => [
- q(0145),
+ q(0149),
q(0),
],
q(136) => [
- q(0148),
+ q(0152),
q(0),
],
q(137) => [
- q(0147),
+ q(0151),
q(0),
],
q(138) => [
- q(0146),
+ q(0150),
q(0),
],
q(139) => [
- q(0092),
+ q(0094),
q(0),
],
q(140) => [
- q(0091),
+ q(0093),
q(0),
],
q(145) => [
- q(0100),
+ q(0102),
q(0),
],
q(159) => [
- q(0107),
+ q(0109),
q(0),
],
q(160) => [
q(0),
],
q(165) => [
- q(0109),
+ q(0112),
q(0),
],
q(166) => [
q(0),
],
q(170) => [
- q(0160),
+ q(0164),
q(0),
],
q(175) => [
- q(0113),
+ q(0116),
q(0),
],
q(176) => [
- q(0059),
+ q(0060),
q(0),
],
q(199) => [
- q(0102),
+ q(0104),
q(0),
],
q(200) => [
q(0),
],
q(202) => [
- q(0088),
+ q(0090),
q(0),
],
q(204) => [
q(0),
],
q(210) => [
- q(0061),
+ q(0062),
q(0),
],
q(211) => [
- q(0131),
+ q(0135),
q(0),
],
q(212) => [
- q(0111),
+ q(0114),
q(0),
],
q(215) => [
- q(0080),
+ q(0082),
q(0),
],
q(216) => [
- q(0079),
+ q(0081),
q(0),
],
q(217) => [
- q(0078),
+ q(0080),
q(0),
],
q(218) => [
- q(0101),
+ q(0103),
q(0),
],
q(219) => [
- q(0115),
+ q(0118),
q(0),
],
q(220) => [
q(0),
],
q(227) => [
- q(0119),
+ q(0122),
q(0),
],
q(230) => [
q(0),
],
q(260) => [
- q(0116),
+ q(0119),
q(0),
],
q(261) => [
- q(0112),
+ q(0115),
q(0),
],
q(262) => [
- q(0167),
+ q(0171),
q(0),
],
q(263) => [
- q(0118),
+ q(0121),
q(0),
],
q(280) => [
- q(0166),
+ q(0170),
q(0),
],
q(281) => [
- q(0137),
+ q(0141),
q(0),
],
q(282) => [
- q(0125),
+ q(0128),
+ q(0),
+ ],
+ q(284) => [
+ q(0063),
q(0),
],
q(285) => [
q(0),
],
q(286) => [
- q(0048),
+ q(0049),
q(0),
],
q(287) => [
- q(0073),
+ q(0075),
q(0),
],
q(288) => [
- q(0071),
+ q(0073),
q(0),
],
q(290) => [
- q(0157),
+ q(0161),
q(0),
],
q(291) => [
q(0),
],
q(292) => [
- q(0133),
+ q(0137),
+ q(0),
+ ],
+ q(293) => [
+ q(0129),
q(0),
],
q(300) => [
q(0),
],
q(302) => [
- q(0139),
+ q(0143),
q(0),
],
q(305) => [
- q(0067),
+ q(0069),
q(0),
],
q(310) => [
q(0),
],
q(314) => [
- q(0090),
+ q(0092),
q(0),
],
q(315) => [
q(0),
],
q(316) => [
- q(0144),
+ q(0148),
q(0),
],
q(317) => [
- q(0075),
+ q(0077),
q(0),
],
q(318) => [
- q(0140),
+ q(0144),
q(0),
],
q(319) => [
- q(0138),
+ q(0142),
q(0),
],
q(320) => [
q(0),
],
q(321) => [
- q(0150),
+ q(0154),
q(0),
],
q(322) => [
- q(0069),
+ q(0071),
q(0),
],
q(323) => [
- q(0104),
+ q(0106),
q(0),
],
q(324) => [
- q(0099),
+ q(0101),
q(0),
],
q(325) => [
q(0),
],
q(326) => [
- q(0163),
+ q(0167),
q(0),
],
q(327) => [
- q(0114),
+ q(0117),
q(0),
],
q(330) => [
- q(0162),
+ q(0166),
q(0),
],
q(331) => [
- q(0120),
+ q(0123),
q(0),
],
q(332) => [
- q(0093),
+ q(0095),
+ q(0),
+ ],
+ q(333) => [
+ q(0110),
q(0),
],
q(334) => [
q(0),
],
q(335) => [
- q(0082),
+ q(0084),
q(0),
],
q(336) => [
- q(0083),
+ q(0085),
q(0),
],
q(337) => [
- q(0103),
+ q(0105),
q(0),
],
q(338) => [
q(0),
],
q(340) => [
- q(0156),
+ q(0160),
q(0),
],
q(343) => [
q(0),
],
q(344) => [
- q(0135),
+ q(0139),
q(0),
],
q(345) => [
- q(0072),
+ q(0074),
q(0),
],
q(346) => [
- q(0153),
+ q(0157),
q(0),
],
q(347) => [
- q(0098),
+ q(0100),
q(0),
],
q(348) => [
- q(0141),
+ q(0145),
q(0),
],
q(349) => [
q(0),
],
q(350) => [
- q(0105),
+ q(0107),
q(0),
],
q(351) => [
- q(0076),
+ q(0078),
q(0),
],
q(352) => [
- q(0161),
+ q(0165),
q(0),
],
q(353) => [
- q(0151),
+ q(0155),
q(0),
],
q(354) => [
- q(0152),
+ q(0156),
q(0),
],
q(355) => [
- q(0068),
+ q(0070),
q(0),
],
q(356) => [
- q(0077),
+ q(0079),
q(0),
],
q(357) => [
- q(0065),
+ q(0067),
q(0),
],
q(358) => [
q(0),
],
q(359) => [
- q(0155),
+ q(0159),
q(0),
],
q(360) => [
q(0),
],
q(361) => [
- q(0062),
+ q(0064),
q(0),
],
q(362) => [
- q(0143),
+ q(0147),
q(0),
],
q(363) => [
- q(0129),
+ q(0133),
q(0),
],
q(364) => [
- q(0081),
+ q(0083),
q(0),
],
q(365) => [
q(0),
],
q(370) => [
- q(0159),
+ q(0163),
q(0),
],
q(371) => [
- q(0050),
+ q(0051),
q(0),
],
q(372) => [
q(0),
],
q(373) => [
- q(0149),
+ q(0153),
q(0),
],
q(398) => [
- q(0142),
+ q(0146),
q(0),
],
q(399) => [
- q(0086),
+ q(0088),
q(0),
],
q(400) => [
- q(0084),
+ q(0086),
q(0),
],
q(401) => [
- q(0085),
+ q(0087),
q(0),
],
q(403) => [
q(0),
],
q(410) => [
- q(0055),
+ q(0056),
q(0),
],
q(411) => [
- q(0066),
+ q(0068),
q(0),
],
q(412) => [
- q(0058),
+ q(0059),
q(0),
],
q(413) => [
- q(0063),
+ q(0065),
q(0),
],
q(420) => [
- q(0108),
+ q(0111),
q(0),
],
q(430) => [
q(0),
],
q(436) => [
- q(0074),
+ q(0076),
q(0),
],
q(437) => [
- q(0087),
+ q(0089),
q(0),
],
q(438) => [
- q(0095),
+ q(0097),
q(0),
],
q(439) => [
q(0),
],
q(450) => [
- q(0057),
+ q(0058),
q(0),
],
q(460) => [
- q(0171),
+ q(0175),
q(0),
],
q(470) => [
- q(0165),
+ q(0169),
q(0),
],
q(480) => [
- q(0168),
+ q(0172),
q(0),
],
q(499) => [
- q(0110),
+ q(0113),
q(0),
],
q(500) => [
- q(0049),
+ q(0050),
q(0),
],
q(501) => [
- q(0051),
+ q(0052),
q(0),
],
q(502) => [
- q(0052),
+ q(0053),
+ q(0),
+ ],
+ q(503) => [
+ q(0048),
q(0),
],
q(505) => [
- q(0070),
+ q(0072),
q(0),
],
q(510) => [
- q(0064),
+ q(0066),
q(0),
],
q(520) => [
- q(0154),
+ q(0158),
q(0),
],
q(550) => [
q(0),
],
q(610) => [
- q(0060),
+ q(0061),
q(0),
],
q(620) => [
- q(0130),
+ q(0134),
q(0),
],
q(755) => [
q(0),
],
q(900) => [
- q(0127),
+ q(0131),
q(0),
],
q(949) => [
- q(0128),
+ q(0132),
+ q(0),
+ ],
+ q(993) => [
+ q(0178),
q(0),
],
q(994) => [
- q(0172),
+ q(0176),
q(0),
],
q(995) => [
- q(0173),
+ q(0177),
q(0),
],
q(996) => [
- q(0174),
+ q(0179),
q(0),
],
},
q(0045) => q(Grek),
q(0046) => q(Gujr),
q(0047) => q(Guru),
- q(0048) => q(Hang),
- q(0049) => q(Hani),
- q(0050) => q(Hano),
- q(0051) => q(Hans),
- q(0052) => q(Hant),
- q(0053) => q(Hatr),
- q(0054) => q(Hebr),
- q(0055) => q(Hira),
- q(0056) => q(Hluw),
- q(0057) => q(Hmng),
- q(0058) => q(Hrkt),
- q(0059) => q(Hung),
- q(0060) => q(Inds),
- q(0061) => q(Ital),
- q(0062) => q(Java),
- q(0063) => q(Jpan),
- q(0064) => q(Jurc),
- q(0065) => q(Kali),
- q(0066) => q(Kana),
- q(0067) => q(Khar),
- q(0068) => q(Khmr),
- q(0069) => q(Khoj),
- q(0070) => q(Kitl),
- q(0071) => q(Kits),
- q(0072) => q(Knda),
- q(0073) => q(Kore),
- q(0074) => q(Kpel),
- q(0075) => q(Kthi),
- q(0076) => q(Lana),
- q(0077) => q(Laoo),
- q(0078) => q(Latf),
- q(0079) => q(Latg),
- q(0080) => q(Latn),
- q(0081) => q(Leke),
- q(0082) => q(Lepc),
- q(0083) => q(Limb),
- q(0084) => q(Lina),
- q(0085) => q(Linb),
- q(0086) => q(Lisu),
- q(0087) => q(Loma),
- q(0088) => q(Lyci),
- q(0089) => q(Lydi),
- q(0090) => q(Mahj),
- q(0091) => q(Mand),
- q(0092) => q(Mani),
- q(0093) => q(Marc),
- q(0094) => q(Maya),
- q(0095) => q(Mend),
- q(0096) => q(Merc),
- q(0097) => q(Mero),
- q(0098) => q(Mlym),
- q(0099) => q(Modi),
- q(0100) => q(Mong),
- q(0101) => q(Moon),
- q(0102) => q(Mroo),
- q(0103) => q(Mtei),
- q(0104) => q(Mult),
- q(0105) => q(Mymr),
- q(0106) => q(Narb),
- q(0107) => q(Nbat),
- q(0108) => q(Nkgb),
- q(0109) => q(Nkoo),
- q(0110) => q(Nshu),
- q(0111) => q(Ogam),
- q(0112) => q(Olck),
- q(0113) => q(Orkh),
- q(0114) => q(Orya),
- q(0115) => q(Osge),
- q(0116) => q(Osma),
- q(0117) => q(Palm),
- q(0118) => q(Pauc),
- q(0119) => q(Perm),
- q(0120) => q(Phag),
- q(0121) => q(Phli),
- q(0122) => q(Phlp),
- q(0123) => q(Phlv),
- q(0124) => q(Phnx),
- q(0125) => q(Plrd),
- q(0126) => q(Prti),
- q(0127) => q(Qaaa),
- q(0128) => q(Qabx),
- q(0129) => q(Rjng),
- q(0130) => q(Roro),
- q(0131) => q(Runr),
- q(0132) => q(Samr),
- q(0133) => q(Sara),
- q(0134) => q(Sarb),
- q(0135) => q(Saur),
- q(0136) => q(Sgnw),
- q(0137) => q(Shaw),
- q(0138) => q(Shrd),
- q(0139) => q(Sidd),
- q(0140) => q(Sind),
- q(0141) => q(Sinh),
- q(0142) => q(Sora),
- q(0143) => q(Sund),
- q(0144) => q(Sylo),
- q(0145) => q(Syrc),
- q(0146) => q(Syre),
- q(0147) => q(Syrj),
- q(0148) => q(Syrn),
- q(0149) => q(Tagb),
- q(0150) => q(Takr),
- q(0151) => q(Tale),
- q(0152) => q(Talu),
- q(0153) => q(Taml),
- q(0154) => q(Tang),
- q(0155) => q(Tavt),
- q(0156) => q(Telu),
- q(0157) => q(Teng),
- q(0158) => q(Tfng),
- q(0159) => q(Tglg),
- q(0160) => q(Thaa),
- q(0161) => q(Thai),
- q(0162) => q(Tibt),
- q(0163) => q(Tirh),
- q(0164) => q(Ugar),
- q(0165) => q(Vaii),
- q(0166) => q(Visp),
- q(0167) => q(Wara),
- q(0168) => q(Wole),
- q(0169) => q(Xpeo),
- q(0170) => q(Xsux),
- q(0171) => q(Yiii),
- q(0172) => q(Zinh),
- q(0173) => q(Zmth),
- q(0174) => q(Zsym),
+ q(0048) => q(Hanb),
+ q(0049) => q(Hang),
+ q(0050) => q(Hani),
+ q(0051) => q(Hano),
+ q(0052) => q(Hans),
+ q(0053) => q(Hant),
+ q(0054) => q(Hatr),
+ q(0055) => q(Hebr),
+ q(0056) => q(Hira),
+ q(0057) => q(Hluw),
+ q(0058) => q(Hmng),
+ q(0059) => q(Hrkt),
+ q(0060) => q(Hung),
+ q(0061) => q(Inds),
+ q(0062) => q(Ital),
+ q(0063) => q(Jamo),
+ q(0064) => q(Java),
+ q(0065) => q(Jpan),
+ q(0066) => q(Jurc),
+ q(0067) => q(Kali),
+ q(0068) => q(Kana),
+ q(0069) => q(Khar),
+ q(0070) => q(Khmr),
+ q(0071) => q(Khoj),
+ q(0072) => q(Kitl),
+ q(0073) => q(Kits),
+ q(0074) => q(Knda),
+ q(0075) => q(Kore),
+ q(0076) => q(Kpel),
+ q(0077) => q(Kthi),
+ q(0078) => q(Lana),
+ q(0079) => q(Laoo),
+ q(0080) => q(Latf),
+ q(0081) => q(Latg),
+ q(0082) => q(Latn),
+ q(0083) => q(Leke),
+ q(0084) => q(Lepc),
+ q(0085) => q(Limb),
+ q(0086) => q(Lina),
+ q(0087) => q(Linb),
+ q(0088) => q(Lisu),
+ q(0089) => q(Loma),
+ q(0090) => q(Lyci),
+ q(0091) => q(Lydi),
+ q(0092) => q(Mahj),
+ q(0093) => q(Mand),
+ q(0094) => q(Mani),
+ q(0095) => q(Marc),
+ q(0096) => q(Maya),
+ q(0097) => q(Mend),
+ q(0098) => q(Merc),
+ q(0099) => q(Mero),
+ q(0100) => q(Mlym),
+ q(0101) => q(Modi),
+ q(0102) => q(Mong),
+ q(0103) => q(Moon),
+ q(0104) => q(Mroo),
+ q(0105) => q(Mtei),
+ q(0106) => q(Mult),
+ q(0107) => q(Mymr),
+ q(0108) => q(Narb),
+ q(0109) => q(Nbat),
+ q(0110) => q(Newa),
+ q(0111) => q(Nkgb),
+ q(0112) => q(Nkoo),
+ q(0113) => q(Nshu),
+ q(0114) => q(Ogam),
+ q(0115) => q(Olck),
+ q(0116) => q(Orkh),
+ q(0117) => q(Orya),
+ q(0118) => q(Osge),
+ q(0119) => q(Osma),
+ q(0120) => q(Palm),
+ q(0121) => q(Pauc),
+ q(0122) => q(Perm),
+ q(0123) => q(Phag),
+ q(0124) => q(Phli),
+ q(0125) => q(Phlp),
+ q(0126) => q(Phlv),
+ q(0127) => q(Phnx),
+ q(0128) => q(Plrd),
+ q(0129) => q(Piqd),
+ q(0130) => q(Prti),
+ q(0131) => q(Qaaa),
+ q(0132) => q(Qabx),
+ q(0133) => q(Rjng),
+ q(0134) => q(Roro),
+ q(0135) => q(Runr),
+ q(0136) => q(Samr),
+ q(0137) => q(Sara),
+ q(0138) => q(Sarb),
+ q(0139) => q(Saur),
+ q(0140) => q(Sgnw),
+ q(0141) => q(Shaw),
+ q(0142) => q(Shrd),
+ q(0143) => q(Sidd),
+ q(0144) => q(Sind),
+ q(0145) => q(Sinh),
+ q(0146) => q(Sora),
+ q(0147) => q(Sund),
+ q(0148) => q(Sylo),
+ q(0149) => q(Syrc),
+ q(0150) => q(Syre),
+ q(0151) => q(Syrj),
+ q(0152) => q(Syrn),
+ q(0153) => q(Tagb),
+ q(0154) => q(Takr),
+ q(0155) => q(Tale),
+ q(0156) => q(Talu),
+ q(0157) => q(Taml),
+ q(0158) => q(Tang),
+ q(0159) => q(Tavt),
+ q(0160) => q(Telu),
+ q(0161) => q(Teng),
+ q(0162) => q(Tfng),
+ q(0163) => q(Tglg),
+ q(0164) => q(Thaa),
+ q(0165) => q(Thai),
+ q(0166) => q(Tibt),
+ q(0167) => q(Tirh),
+ q(0168) => q(Ugar),
+ q(0169) => q(Vaii),
+ q(0170) => q(Visp),
+ q(0171) => q(Wara),
+ q(0172) => q(Wole),
+ q(0173) => q(Xpeo),
+ q(0174) => q(Xsux),
+ q(0175) => q(Yiii),
+ q(0176) => q(Zinh),
+ q(0177) => q(Zmth),
+ q(0178) => q(Zsye),
+ q(0179) => q(Zsym),
},
q(num) => {
q(0001) => q(166),
q(0045) => q(200),
q(0046) => q(320),
q(0047) => q(310),
- q(0048) => q(286),
- q(0049) => q(500),
- q(0050) => q(371),
- q(0051) => q(501),
- q(0052) => q(502),
- q(0053) => q(127),
- q(0054) => q(125),
- q(0055) => q(410),
- q(0056) => q(080),
- q(0057) => q(450),
- q(0058) => q(412),
- q(0059) => q(176),
- q(0060) => q(610),
- q(0061) => q(210),
- q(0062) => q(361),
- q(0063) => q(413),
- q(0064) => q(510),
- q(0065) => q(357),
- q(0066) => q(411),
- q(0067) => q(305),
- q(0068) => q(355),
- q(0069) => q(322),
- q(0070) => q(505),
- q(0071) => q(288),
- q(0072) => q(345),
- q(0073) => q(287),
- q(0074) => q(436),
- q(0075) => q(317),
- q(0076) => q(351),
- q(0077) => q(356),
- q(0078) => q(217),
- q(0079) => q(216),
- q(0080) => q(215),
- q(0081) => q(364),
- q(0082) => q(335),
- q(0083) => q(336),
- q(0084) => q(400),
- q(0085) => q(401),
- q(0086) => q(399),
- q(0087) => q(437),
- q(0088) => q(202),
- q(0089) => q(116),
- q(0090) => q(314),
- q(0091) => q(140),
- q(0092) => q(139),
- q(0093) => q(332),
- q(0094) => q(090),
- q(0095) => q(438),
- q(0096) => q(101),
- q(0097) => q(100),
- q(0098) => q(347),
- q(0099) => q(324),
- q(0100) => q(145),
- q(0101) => q(218),
- q(0102) => q(199),
- q(0103) => q(337),
- q(0104) => q(323),
- q(0105) => q(350),
- q(0106) => q(106),
- q(0107) => q(159),
- q(0108) => q(420),
- q(0109) => q(165),
- q(0110) => q(499),
- q(0111) => q(212),
- q(0112) => q(261),
- q(0113) => q(175),
- q(0114) => q(327),
- q(0115) => q(219),
- q(0116) => q(260),
- q(0117) => q(126),
- q(0118) => q(263),
- q(0119) => q(227),
- q(0120) => q(331),
- q(0121) => q(131),
- q(0122) => q(132),
- q(0123) => q(133),
- q(0124) => q(115),
- q(0125) => q(282),
- q(0126) => q(130),
- q(0127) => q(900),
- q(0128) => q(949),
- q(0129) => q(363),
- q(0130) => q(620),
- q(0131) => q(211),
- q(0132) => q(123),
- q(0133) => q(292),
- q(0134) => q(105),
- q(0135) => q(344),
- q(0136) => q(095),
- q(0137) => q(281),
- q(0138) => q(319),
- q(0139) => q(302),
- q(0140) => q(318),
- q(0141) => q(348),
- q(0142) => q(398),
- q(0143) => q(362),
- q(0144) => q(316),
- q(0145) => q(135),
- q(0146) => q(138),
- q(0147) => q(137),
- q(0148) => q(136),
- q(0149) => q(373),
- q(0150) => q(321),
- q(0151) => q(353),
- q(0152) => q(354),
- q(0153) => q(346),
- q(0154) => q(520),
- q(0155) => q(359),
- q(0156) => q(340),
- q(0157) => q(290),
- q(0158) => q(120),
- q(0159) => q(370),
- q(0160) => q(170),
- q(0161) => q(352),
- q(0162) => q(330),
- q(0163) => q(326),
- q(0164) => q(040),
- q(0165) => q(470),
- q(0166) => q(280),
- q(0167) => q(262),
- q(0168) => q(480),
- q(0169) => q(030),
- q(0170) => q(020),
- q(0171) => q(460),
- q(0172) => q(994),
- q(0173) => q(995),
- q(0174) => q(996),
+ q(0048) => q(503),
+ q(0049) => q(286),
+ q(0050) => q(500),
+ q(0051) => q(371),
+ q(0052) => q(501),
+ q(0053) => q(502),
+ q(0054) => q(127),
+ q(0055) => q(125),
+ q(0056) => q(410),
+ q(0057) => q(080),
+ q(0058) => q(450),
+ q(0059) => q(412),
+ q(0060) => q(176),
+ q(0061) => q(610),
+ q(0062) => q(210),
+ q(0063) => q(284),
+ q(0064) => q(361),
+ q(0065) => q(413),
+ q(0066) => q(510),
+ q(0067) => q(357),
+ q(0068) => q(411),
+ q(0069) => q(305),
+ q(0070) => q(355),
+ q(0071) => q(322),
+ q(0072) => q(505),
+ q(0073) => q(288),
+ q(0074) => q(345),
+ q(0075) => q(287),
+ q(0076) => q(436),
+ q(0077) => q(317),
+ q(0078) => q(351),
+ q(0079) => q(356),
+ q(0080) => q(217),
+ q(0081) => q(216),
+ q(0082) => q(215),
+ q(0083) => q(364),
+ q(0084) => q(335),
+ q(0085) => q(336),
+ q(0086) => q(400),
+ q(0087) => q(401),
+ q(0088) => q(399),
+ q(0089) => q(437),
+ q(0090) => q(202),
+ q(0091) => q(116),
+ q(0092) => q(314),
+ q(0093) => q(140),
+ q(0094) => q(139),
+ q(0095) => q(332),
+ q(0096) => q(090),
+ q(0097) => q(438),
+ q(0098) => q(101),
+ q(0099) => q(100),
+ q(0100) => q(347),
+ q(0101) => q(324),
+ q(0102) => q(145),
+ q(0103) => q(218),
+ q(0104) => q(199),
+ q(0105) => q(337),
+ q(0106) => q(323),
+ q(0107) => q(350),
+ q(0108) => q(106),
+ q(0109) => q(159),
+ q(0110) => q(333),
+ q(0111) => q(420),
+ q(0112) => q(165),
+ q(0113) => q(499),
+ q(0114) => q(212),
+ q(0115) => q(261),
+ q(0116) => q(175),
+ q(0117) => q(327),
+ q(0118) => q(219),
+ q(0119) => q(260),
+ q(0120) => q(126),
+ q(0121) => q(263),
+ q(0122) => q(227),
+ q(0123) => q(331),
+ q(0124) => q(131),
+ q(0125) => q(132),
+ q(0126) => q(133),
+ q(0127) => q(115),
+ q(0128) => q(282),
+ q(0129) => q(293),
+ q(0130) => q(130),
+ q(0131) => q(900),
+ q(0132) => q(949),
+ q(0133) => q(363),
+ q(0134) => q(620),
+ q(0135) => q(211),
+ q(0136) => q(123),
+ q(0137) => q(292),
+ q(0138) => q(105),
+ q(0139) => q(344),
+ q(0140) => q(095),
+ q(0141) => q(281),
+ q(0142) => q(319),
+ q(0143) => q(302),
+ q(0144) => q(318),
+ q(0145) => q(348),
+ q(0146) => q(398),
+ q(0147) => q(362),
+ q(0148) => q(316),
+ q(0149) => q(135),
+ q(0150) => q(138),
+ q(0151) => q(137),
+ q(0152) => q(136),
+ q(0153) => q(373),
+ q(0154) => q(321),
+ q(0155) => q(353),
+ q(0156) => q(354),
+ q(0157) => q(346),
+ q(0158) => q(520),
+ q(0159) => q(359),
+ q(0160) => q(340),
+ q(0161) => q(290),
+ q(0162) => q(120),
+ q(0163) => q(370),
+ q(0164) => q(170),
+ q(0165) => q(352),
+ q(0166) => q(330),
+ q(0167) => q(326),
+ q(0168) => q(040),
+ q(0169) => q(470),
+ q(0170) => q(280),
+ q(0171) => q(262),
+ q(0172) => q(480),
+ q(0173) => q(030),
+ q(0174) => q(020),
+ q(0175) => q(460),
+ q(0176) => q(994),
+ q(0177) => q(995),
+ q(0178) => q(993),
+ q(0179) => q(996),
},
};
# This file was automatically generated. Any changes to this file will
# be lost the next time 'deprecate_codes' is run.
-# Generated on: Tue Dec 1 14:45:28 EST 2015
+# Generated on: Wed Mar 2 09:26:23 EST 2016
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.37';
+$VERSION='3.38';
$Locale::Codes::Retired{'script'}{'alpha'}{'code'} = {
};
package Locale::Country;
# Copyright (C) 2001 Canon Research Centre Europe (CRE).
# Copyright (C) 2002-2009 Neil Bowers
-# Copyright (c) 2010-2015 Sullivan Beck
+# Copyright (c) 2010-2016 Sullivan Beck
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
use Exporter;
our $VERSION;
-$VERSION='3.37';
+$VERSION='3.38';
our (@ISA,@EXPORT);
# cperl-continued-brace-offset: 0
# cperl-brace-offset: 0
# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
+# cperl-label-offset: 0
# End:
Copyright (c) 1997-2001 Canon Research Centre Europe (CRE).
Copyright (c) 2001-2010 Neil Bowers
- Copyright (c) 2010-2015 Sullivan Beck
+ Copyright (c) 2010-2016 Sullivan Beck
This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
package Locale::Currency;
# Copyright (C) 2001 Canon Research Centre Europe (CRE).
# Copyright (C) 2002-2009 Neil Bowers
-# Copyright (c) 2010-2015 Sullivan Beck
+# Copyright (c) 2010-2016 Sullivan Beck
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
use Exporter;
our $VERSION;
-$VERSION='3.37';
+$VERSION='3.38';
our (@ISA,@EXPORT);
# cperl-continued-brace-offset: 0
# cperl-brace-offset: 0
# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
+# cperl-label-offset: 0
# End:
=item B<Locale::Currency::add_currency_code_alias(CODE ,NEW_CODE [,CODESET])>
-=item B<Locale::Currency::delete_currency_code_alias( ODE [,CODESET])>
+=item B<Locale::Currency::delete_currency_code_alias( CODE [,CODESET])>
These routines are all documented in the L<Locale::Codes::API> man page.
Copyright (c) 1997-2001 Canon Research Centre Europe (CRE).
Copyright (c) 2001 Michael Hennecke
Copyright (c) 2001-2010 Neil Bowers
- Copyright (c) 2010-2015 Sullivan Beck
+ Copyright (c) 2010-2016 Sullivan Beck
This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
package Locale::Language;
# Copyright (C) 2001 Canon Research Centre Europe (CRE).
# Copyright (C) 2002-2009 Neil Bowers
-# Copyright (c) 2010-2015 Sullivan Beck
+# Copyright (c) 2010-2016 Sullivan Beck
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
use Exporter;
our $VERSION;
-$VERSION='3.37';
+$VERSION='3.38';
our (@ISA,@EXPORT);
# cperl-continued-brace-offset: 0
# cperl-brace-offset: 0
# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
+# cperl-label-offset: 0
# End:
Copyright (c) 1997-2001 Canon Research Centre Europe (CRE).
Copyright (c) 2001-2010 Neil Bowers
- Copyright (c) 2010-2015 Sullivan Beck
+ Copyright (c) 2010-2016 Sullivan Beck
This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
package Locale::Script;
# Copyright (C) 2001 Canon Research Centre Europe (CRE).
# Copyright (C) 2002-2009 Neil Bowers
-# Copyright (c) 2010-2015 Sullivan Beck
+# Copyright (c) 2010-2016 Sullivan Beck
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
use Exporter;
our $VERSION;
-$VERSION='3.37';
+$VERSION='3.38';
our (@ISA,@EXPORT);
# cperl-continued-brace-offset: 0
# cperl-brace-offset: 0
# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
+# cperl-label-offset: 0
# End:
Copyright (c) 1997-2001 Canon Research Centre Europe (CRE).
Copyright (c) 2001-2010 Neil Bowers
- Copyright (c) 2010-2015 Sullivan Beck
+ Copyright (c) 2010-2016 Sullivan Beck
This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
+++ /dev/null
-#!/usr/bin/perl -w
-
-require 5.002;
-
-$runtests=shift(@ARGV);
-if ( -f "t/testfunc.pl" ) {
- require "t/testfunc.pl";
- $dir="./lib";
- $tdir="t";
-} elsif ( -f "testfunc.pl" ) {
- require "testfunc.pl";
- $dir="../lib";
- $tdir=".";
-} else {
- die "ERROR: cannot find testfunc.pl\n";
-}
-
-unshift(@INC,$dir);
-use Locale::Codes::Country;
-
-%type = ( "LOCALE_CODE_ALPHA_2" => LOCALE_CODE_ALPHA_2,
- "LOCALE_CODE_ALPHA_3" => LOCALE_CODE_ALPHA_3,
- "LOCALE_CODE_NUMERIC" => LOCALE_CODE_NUMERIC,
- );
-
-sub test {
- my(@test) = @_;
- $test[1] = $type{$test[1]} if (@test == 2 && $test[1] && exists $type{$test[1]});
- return code2country(@test);
-}
-
-$tests = "
-
-~ _undef_
-
-_undef_ ~ _undef_
-
-zz ~ _undef_
-
-zz LOCALE_CODE_ALPHA_2 ~ _undef_
-
-zz LOCALE_CODE_ALPHA_3 ~ _undef_
-
-zz LOCALE_CODE_NUMERIC ~ _undef_
-
-ja ~ _undef_
-
-uk ~ _undef_
-
-BO
- ~
- Bolivia (Plurinational State of)
-
-BO
-LOCALE_CODE_ALPHA_2
- ~
- Bolivia (Plurinational State of)
-
-bol
-LOCALE_CODE_ALPHA_3
- ~
- Bolivia (Plurinational State of)
-
-pk ~ Pakistan
-
-sn ~ Senegal
-
-us
- ~
- United States of America
-
-ad ~ Andorra
-
-ad LOCALE_CODE_ALPHA_2 ~ Andorra
-
-and LOCALE_CODE_ALPHA_3 ~ Andorra
-
-020 LOCALE_CODE_NUMERIC ~ Andorra
-
-48 LOCALE_CODE_NUMERIC ~ Bahrain
-
-zw ~ Zimbabwe
-
-gb
- ~
- United Kingdom of Great Britain and Northern Ireland
-
-kz ~ Kazakhstan
-
-mo ~ Macao
-
-tl LOCALE_CODE_ALPHA_2 ~ Timor-Leste
-
-tls LOCALE_CODE_ALPHA_3 ~ Timor-Leste
-
-626 LOCALE_CODE_NUMERIC ~ Timor-Leste
-
-BO LOCALE_CODE_ALPHA_3 ~ _undef_
-
-BO LOCALE_CODE_NUMERIC ~ _undef_
-
-ax
- ~
- Aland Islands
-
-ala
-LOCALE_CODE_ALPHA_3
- ~
- Aland Islands
-
-248
-LOCALE_CODE_NUMERIC
- ~
- Aland Islands
-
-scg
-LOCALE_CODE_ALPHA_3
- ~
- _undef_
-
-891
-LOCALE_CODE_NUMERIC
- ~
- _undef_
-
-rou LOCALE_CODE_ALPHA_3 ~ Romania
-
-zr ~ _undef_
-
-zr retired ~ Zaire
-
-jp alpha-2 not_retired other_arg ~ _undef_
-
-jp _blank_ ~ Japan
-
-jp alpha-15 ~ _undef_
-
-jp alpha-2 retired ~ Japan
-
-";
-
-print "code2country...\n";
-test_Func(\&test,$tests,$runtests);
-
-1;
-# Local Variables:
-# mode: cperl
-# indent-tabs-mode: nil
-# cperl-indent-level: 3
-# cperl-continued-statement-offset: 2
-# cperl-continued-brace-offset: 0
-# cperl-brace-offset: 0
-# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
-# End:
-
+++ /dev/null
-#!/usr/bin/perl -w
-
-require 5.002;
-
-$runtests=shift(@ARGV);
-if ( -f "t/testfunc.pl" ) {
- require "t/testfunc.pl";
- $dir="./lib";
- $tdir="t";
-} elsif ( -f "testfunc.pl" ) {
- require "testfunc.pl";
- $dir="../lib";
- $tdir=".";
-} else {
- die "ERROR: cannot find testfunc.pl\n";
-}
-
-unshift(@INC,$dir);
-use Locale::Country;
-
-%type = ( "LOCALE_CODE_ALPHA_2" => LOCALE_CODE_ALPHA_2,
- "LOCALE_CODE_ALPHA_3" => LOCALE_CODE_ALPHA_3,
- "LOCALE_CODE_NUMERIC" => LOCALE_CODE_NUMERIC,
- );
-
-sub test {
- my(@test) = @_;
- $test[1] = $type{$test[1]} if (@test == 2 && $test[1] && exists $type{$test[1]});
- return code2country(@test);
-}
-
-$tests = "
-
-~ _undef_
-
-_undef_ ~ _undef_
-
-zz ~ _undef_
-
-zz LOCALE_CODE_ALPHA_2 ~ _undef_
-
-zz LOCALE_CODE_ALPHA_3 ~ _undef_
-
-zz LOCALE_CODE_NUMERIC ~ _undef_
-
-ja ~ _undef_
-
-uk ~ _undef_
-
-BO
- ~
- Bolivia (Plurinational State of)
-
-BO
-LOCALE_CODE_ALPHA_2
- ~
- Bolivia (Plurinational State of)
-
-bol
-LOCALE_CODE_ALPHA_3
- ~
- Bolivia (Plurinational State of)
-
-pk ~ Pakistan
-
-sn ~ Senegal
-
-us
- ~
- United States of America
-
-ad ~ Andorra
-
-ad LOCALE_CODE_ALPHA_2 ~ Andorra
-
-and LOCALE_CODE_ALPHA_3 ~ Andorra
-
-020 LOCALE_CODE_NUMERIC ~ Andorra
-
-48 LOCALE_CODE_NUMERIC ~ Bahrain
-
-zw ~ Zimbabwe
-
-gb
- ~
- United Kingdom of Great Britain and Northern Ireland
-
-kz ~ Kazakhstan
-
-mo ~ Macao
-
-tl LOCALE_CODE_ALPHA_2 ~ Timor-Leste
-
-tls LOCALE_CODE_ALPHA_3 ~ Timor-Leste
-
-626 LOCALE_CODE_NUMERIC ~ Timor-Leste
-
-BO LOCALE_CODE_ALPHA_3 ~ _undef_
-
-BO LOCALE_CODE_NUMERIC ~ _undef_
-
-ax
- ~
- Aland Islands
-
-ala
-LOCALE_CODE_ALPHA_3
- ~
- Aland Islands
-
-248
-LOCALE_CODE_NUMERIC
- ~
- Aland Islands
-
-scg
-LOCALE_CODE_ALPHA_3
- ~
- _undef_
-
-891
-LOCALE_CODE_NUMERIC
- ~
- _undef_
-
-rou LOCALE_CODE_ALPHA_3 ~ Romania
-
-";
-
-print "code2country (old)...\n";
-test_Func(\&test,$tests,$runtests);
-
-1;
-# Local Variables:
-# mode: cperl
-# indent-tabs-mode: nil
-# cperl-indent-level: 3
-# cperl-continued-statement-offset: 2
-# cperl-continued-brace-offset: 0
-# cperl-brace-offset: 0
-# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
-# End:
-
+++ /dev/null
-#!/usr/bin/perl -w
-
-require 5.002;
-
-$runtests=shift(@ARGV);
-if ( -f "t/testfunc.pl" ) {
- require "t/testfunc.pl";
- $dir="./lib";
- $tdir="t";
-} elsif ( -f "testfunc.pl" ) {
- require "testfunc.pl";
- $dir="../lib";
- $tdir=".";
-} else {
- die "ERROR: cannot find testfunc.pl\n";
-}
-
-unshift(@INC,$dir);
-use Locale::Codes::Currency;
-
-%type = ( "LOCALE_CURR_ALPHA" => LOCALE_CURR_ALPHA,
- "LOCALE_CURR_NUMERIC" => LOCALE_CURR_NUMERIC,
- );
-
-sub test {
- my(@test) = @_;
- $test[1] = $type{$test[1]}
- if (@test == 2 && $test[1] && exists $type{$test[1]});
- return code2currency(@test);
-}
-
-$tests = "
-
-ukp ~ _undef_
-
-zz ~ _undef_
-
-zzz ~ _undef_
-
-zzzz ~ _undef_
-
-~ _undef_
-
-_undef_ ~ _undef_
-
-BOB
- ~
- Boliviano
-
-all
- ~
- Lek
-
-bnd
- ~
- Brunei Dollar
-
-bob
- ~
- Boliviano
-
-byr
- ~
- Belarussian Ruble
-
-chf
- ~
- Swiss Franc
-
-cop
- ~
- Colombian Peso
-
-dkk
- ~
- Danish Krone
-
-fjd
- ~
- Fiji Dollar
-
-idr
- ~
- Rupiah
-
-mmk
- ~
- Kyat
-
-mvr
- ~
- Rufiyaa
-
-mwk
- ~
- Kwacha
-
-rub
- ~
- Russian Ruble
-
-zmw
- ~
- Zambian Kwacha
-
-zwl
- ~
- Zimbabwe Dollar
-
-";
-
-print "code2currency...\n";
-test_Func(\&test,$tests,$runtests);
-
-1;
-# Local Variables:
-# mode: cperl
-# indent-tabs-mode: nil
-# cperl-indent-level: 3
-# cperl-continued-statement-offset: 2
-# cperl-continued-brace-offset: 0
-# cperl-brace-offset: 0
-# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
-# End:
+++ /dev/null
-#!/usr/bin/perl -w
-
-require 5.002;
-
-$runtests=shift(@ARGV);
-if ( -f "t/testfunc.pl" ) {
- require "t/testfunc.pl";
- $dir="./lib";
- $tdir="t";
-} elsif ( -f "testfunc.pl" ) {
- require "testfunc.pl";
- $dir="../lib";
- $tdir=".";
-} else {
- die "ERROR: cannot find testfunc.pl\n";
-}
-
-unshift(@INC,$dir);
-use Locale::Codes::Language;
-
-%type = ( "LOCALE_LANG_ALPHA_2" => LOCALE_LANG_ALPHA_2,
- "LOCALE_LANG_ALPHA_3" => LOCALE_LANG_ALPHA_3,
- "LOCALE_LANG_TERM" => LOCALE_LANG_TERM,
- );
-
-sub test {
- my(@test) = @_;
- $test[1] = $type{$test[1]}
- if (@test == 2 && $test[1] && exists $type{$test[1]});
- return code2language(@test);
-}
-
-$tests = "
-
-in ~ _undef_
-
-iw ~ _undef_
-
-ji ~ _undef_
-
-jp ~ _undef_
-
-zz ~ _undef_
-
-~ _undef_
-
-_undef_ ~ _undef_
-
-DA
- ~
- Danish
-
-aa
- ~
- Afar
-
-ae
- ~
- Avestan
-
-bs
- ~
- Bosnian
-
-ce
- ~
- Chechen
-
-ch
- ~
- Chamorro
-
-cu
- ~
- Church Slavic
-
-cv
- ~
- Chuvash
-
-en
- ~
- English
-
-eo
- ~
- Esperanto
-
-fi
- ~
- Finnish
-
-gv
- ~
- Manx
-
-he
- ~
- Hebrew
-
-ho
- ~
- Hiri Motu
-
-hz
- ~
- Herero
-
-id
- ~
- Indonesian
-
-iu
- ~
- Inuktitut
-
-ki
- ~
- Kikuyu
-
-kj
- ~
- Kuanyama
-
-kv
- ~
- Komi
-
-kw
- ~
- Cornish
-
-lb
- ~
- Luxembourgish
-
-mh
- ~
- Marshallese
-
-nb
- ~
- Norwegian Bokmal
-
-nd
- ~
- North Ndebele
-
-ng
- ~
- Ndonga
-
-nn
- ~
- Norwegian Nynorsk
-
-nr
- ~
- South Ndebele
-
-nv
- ~
- Navajo
-
-ny
- ~
- Nyanja
-
-oc
- ~
- Occitan (post 1500)
-
-os
- ~
- Ossetian
-
-pi
- ~
- Pali
-
-sc
- ~
- Sardinian
-
-se
- ~
- Northern Sami
-
-ug
- ~
- Uighur
-
-yi
- ~
- Yiddish
-
-za
- ~
- Zhuang
-
-zu
- ~
- Zulu
-
-";
-
-print "code2language...\n";
-test_Func(\&test,$tests,$runtests);
-
-1;
-# Local Variables:
-# mode: cperl
-# indent-tabs-mode: nil
-# cperl-indent-level: 3
-# cperl-continued-statement-offset: 2
-# cperl-continued-brace-offset: 0
-# cperl-brace-offset: 0
-# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
-# End:
+++ /dev/null
-#!/usr/bin/perl -w
-
-require 5.002;
-
-$runtests=shift(@ARGV);
-if ( -f "t/testfunc.pl" ) {
- require "t/testfunc.pl";
- $dir="./lib";
- $tdir="t";
-} elsif ( -f "testfunc.pl" ) {
- require "testfunc.pl";
- $dir="../lib";
- $tdir=".";
-} else {
- die "ERROR: cannot find testfunc.pl\n";
-}
-
-unshift(@INC,$dir);
-use Locale::Codes::Script;
-
-%type = ( "LOCALE_SCRIPT_ALPHA" => LOCALE_SCRIPT_ALPHA,
- "LOCALE_SCRIPT_NUMERIC" => LOCALE_SCRIPT_NUMERIC,
- );
-
-sub test {
- my(@test) = @_;
- $test[1] = $type{$test[1]}
- if (@test == 2 && $test[1] && exists $type{$test[1]});
- return code2script(@test);
-}
-
-$tests = "
-
-~ _undef_
-
-Phnx ~ Phoenician
-
-phnx ~ Phoenician
-
-115 LOCALE_SCRIPT_NUMERIC ~ Phoenician
-
-";
-
-print "code2script...\n";
-test_Func(\&test,$tests,$runtests);
-
-1;
-# Local Variables:
-# mode: cperl
-# indent-tabs-mode: nil
-# cperl-indent-level: 3
-# cperl-continued-statement-offset: 2
-# cperl-continued-brace-offset: 0
-# cperl-brace-offset: 0
-# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
-# End:
-#!/usr/bin/perl -w
+#!/usr/bin/perl
+use warnings;
+use strict;
require 5.002;
+my($runtests,$dir,$tdir);
+$::type = '';
+$::module = '';
+$::tests = '';
+
+$::type = 'country';
+$::module = 'Locale::Codes::Country';
+
$runtests=shift(@ARGV);
if ( -f "t/testfunc.pl" ) {
require "t/testfunc.pl";
+ require "t/vals.pl";
+ require "t/vals_country.pl";
$dir="./lib";
$tdir="t";
} elsif ( -f "testfunc.pl" ) {
require "testfunc.pl";
+ require "vals.pl";
+ require "vals_country.pl";
$dir="../lib";
$tdir=".";
} else {
}
unshift(@INC,$dir);
-use Locale::Codes::Country;
-
-%type = ( "LOCALE_CODE_ALPHA_2" => LOCALE_CODE_ALPHA_2,
- "LOCALE_CODE_ALPHA_3" => LOCALE_CODE_ALPHA_3,
- "LOCALE_CODE_NUMERIC" => LOCALE_CODE_NUMERIC,
- );
-
-sub test {
- my(@test) = @_;
-
- if ($test[0] eq "rename_country") {
- shift(@test);
- $test[2] = $type{$test[2]}
- if (@test == 3 && $test[2] && exists $type{$test[2]});
- return Locale::Codes::Country::rename_country(@test,"nowarn");
-
- } elsif ($test[0] eq "add_country") {
- shift(@test);
- $test[2] = $type{$test[2]}
- if (@test == 3 && $test[2] && exists $type{$test[2]});
- return Locale::Codes::Country::add_country(@test,"nowarn");
-
- } elsif ($test[0] eq "delete_country") {
- shift(@test);
- $test[1] = $type{$test[1]}
- if (@test == 2 && $test[1] && exists $type{$test[1]});
- return Locale::Codes::Country::delete_country(@test,"nowarn");
-
- } elsif ($test[0] eq "add_country_alias") {
- shift(@test);
- return Locale::Codes::Country::add_country_alias(@test,"nowarn");
-
- } elsif ($test[0] eq "delete_country_alias") {
- shift(@test);
- return Locale::Codes::Country::delete_country_alias(@test,"nowarn");
-
- } elsif ($test[0] eq "rename_country_code") {
- shift(@test);
- $test[2] = $type{$test[2]}
- if (@test == 3 && $test[2] && exists $type{$test[2]});
- return Locale::Codes::Country::rename_country_code(@test,"nowarn");
-
- } elsif ($test[0] eq "add_country_code_alias") {
- shift(@test);
- $test[2] = $type{$test[2]}
- if (@test == 3 && $test[2] && exists $type{$test[2]});
- return Locale::Codes::Country::add_country_code_alias(@test,"nowarn");
-
- } elsif ($test[0] eq "delete_country_code_alias") {
- shift(@test);
- $test[1] = $type{$test[1]}
- if (@test == 2 && $test[1] && exists $type{$test[1]});
- return Locale::Codes::Country::delete_country_code_alias(@test,"nowarn");
-
- } elsif ($test[0] eq "country2code") {
- shift(@test);
- $test[1] = $type{$test[1]}
- if (@test == 2 && $test[1] && exists $type{$test[1]});
- return country2code(@test);
-
- } else {
- shift(@test) if ($test[0] eq "code2country");
- $test[1] = $type{$test[1]}
- if (@test == 2 && $test[1] && exists $type{$test[1]});
- return code2country(@test);
- }
-}
-
-$tests = "
-
-###################################
-# Test rename_country
-
-gb
- ~
- United Kingdom of Great Britain and Northern Ireland
-
-rename_country x1 NewName ~ 0
-
-rename_country gb NewName LOCALE_CODE_FOO ~ 0
-
-rename_country gb Macao ~ 0
-
-rename_country gb NewName LOCALE_CODE_ALPHA_3 ~ 0
-
-gb
- ~
- United Kingdom of Great Britain and Northern Ireland
-
-rename_country gb NewName ~ 1
-
-gb
- ~
- NewName
-
-us
- ~
- United States of America
-
-rename_country
-us
-The United States
- ~
- 1
-
-us
- ~
- The United States
-
-###################################
-# Test add_country
-
-xx ~ _undef_
-
-add_country xx Bolivia ~ 0
-
-add_country fi Xxxxx ~ 0
-
-add_country xx Xxxxx ~ 1
-
-xx ~ Xxxxx
-
-###################################
-# Test add_country_alias
-
-add_country_alias FooBar NewName ~ 0
-
-add_country_alias Australia Angola ~ 0
-
-country2code Australia ~ au
-
-country2code DownUnder ~ _undef_
-
-add_country_alias Australia DownUnder ~ 1
-
-country2code DownUnder ~ au
-
-###################################
-# Test delete_country_alias
-
-country2code uk ~ gb
-
-delete_country_alias Foobar ~ 0
-
-delete_country_alias UK ~ 1
-
-country2code uk ~ _undef_
-
-delete_country_alias Angola ~ 0
-
-###################################
-# Test delete_country
-
-country2code Angola ~ ao
-
-country2code Angola LOCALE_CODE_ALPHA_3 ~ ago
-
-delete_country ao ~ 1
-
-country2code Angola ~ _undef_
-
-country2code Angola LOCALE_CODE_ALPHA_3 ~ ago
-
-###################################
-# Test rename_country_code
-
-code2country zz ~ _undef_
-
-code2country ar ~ Argentina
-
-country2code Argentina ~ ar
-
-rename_country_code ar us ~ 0
-
-rename_country_code ar zz ~ 1
-
-rename_country_code us ar ~ 0
-
-code2country zz ~ Argentina
-
-code2country ar ~ Argentina
-
-country2code Argentina ~ zz
-
-rename_country_code zz ar ~ 1
-
-code2country zz ~ Argentina
-
-code2country ar ~ Argentina
-
-country2code Argentina ~ ar
-
-###################################
-# Test add_country_code_alias and
-# delete_country_code_alias
-
-code2country bm ~ Bermuda
-
-code2country yy ~ _undef_
-
-country2code Bermuda ~ bm
-
-add_country_code_alias bm us ~ 0
-
-add_country_code_alias bm zz ~ 0
-
-add_country_code_alias bm yy ~ 1
-
-code2country bm ~ Bermuda
-
-code2country yy ~ Bermuda
-
-country2code Bermuda ~ bm
-
-delete_country_code_alias us ~ 0
-
-delete_country_code_alias ww ~ 0
-
-delete_country_code_alias yy ~ 1
-
-code2country bm ~ Bermuda
-
-code2country yy ~ _undef_
-
-country2code Bermuda ~ bm
-
-";
-print "country (semi-private)...\n";
-test_Func(\&test,$tests,$runtests);
+print "country...\n";
+test_Func(\&test,$::tests,$runtests);
1;
# Local Variables:
# cperl-continued-brace-offset: 0
# cperl-brace-offset: 0
# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
+# cperl-label-offset: 0
# End:
+++ /dev/null
-#!/usr/bin/perl -w
-
-require 5.002;
-
-$runtests=shift(@ARGV);
-if ( -f "t/testfunc.pl" ) {
- require "t/testfunc.pl";
- $dir="./lib";
- $tdir="t";
-} elsif ( -f "testfunc.pl" ) {
- require "testfunc.pl";
- $dir="../lib";
- $tdir=".";
-} else {
- die "ERROR: cannot find testfunc.pl\n";
-}
-
-unshift(@INC,$dir);
-use Locale::Codes::Country;
-
-%type = ( "LOCALE_CODE_ALPHA_2" => LOCALE_CODE_ALPHA_2,
- "LOCALE_CODE_ALPHA_3" => LOCALE_CODE_ALPHA_3,
- "LOCALE_CODE_NUMERIC" => LOCALE_CODE_NUMERIC,
- "LOCALE_CODE_DOM" => LOCALE_CODE_DOM,
- );
-
-sub test {
- my(@test) = @_;
- $test[1] = $type{$test[1]} if (@test == 2 && $test[1] && exists $type{$test[1]});
- return country2code(@test);
-}
-
-$tests = "
-
-kazakhstan
- ~
- kz
-
-kazakstan
- ~
- kz
-
-macao
- ~
- mo
-
-macau
- ~
- mo
-
-
-~ _undef_
-
-_undef_
- ~
- _undef_
-
-Banana
- ~
- _undef_
-
-japan
- ~
- jp
-
-Japan
- ~
- jp
-
-United States
- ~
- us
-
-United Kingdom
- ~
- gb
-
-Andorra
- ~
- ad
-
-Zimbabwe
- ~
- zw
-
-Iran
- ~
- ir
-
-North Korea
- ~
- kp
-
-South Korea
- ~
- kr
-
-Libya
- ~
- ly
-
-Syrian Arab Republic
- ~
- sy
-
-Svalbard
- ~
- _undef_
-
-Jan Mayen
- ~
- _undef_
-
-USA
- ~
- us
-
-United States of America
- ~
- us
-
-Great Britain
- ~
- gb
-
-Burma
- ~
- mm
-
-French Southern and Antarctic Lands
- ~
- tf
-
-Aland Islands
- ~
- ax
-
-Yugoslavia
- ~
- _undef_
-
-Serbia and Montenegro
- ~
- _undef_
-
-East Timor
- ~
- tl
-
-Zaire
- ~
- _undef_
-
-Zaire
-retired
- ~
- zr
-
-Congo, The Democratic Republic of the
- ~
- cd
-
-Congo, The Democratic Republic of the
-LOCALE_CODE_ALPHA_3
- ~
- cod
-
-Congo, The Democratic Republic of the
-LOCALE_CODE_NUMERIC
- ~
- 180
-
-Syria
- ~
- sy
-
-# Last codes in each set (we'll assume that if we got these, there's a good
-# possiblity that we got all the others).
-
-Zimbabwe
-LOCALE_CODE_ALPHA_2
- ~
- zw
-
-Zimbabwe
-LOCALE_CODE_ALPHA_3
- ~
- zwe
-
-Zimbabwe
-LOCALE_CODE_NUMERIC
- ~
- 716
-
-Zimbabwe
-LOCALE_CODE_DOM
- ~
- zw
-
-";
-
-print "country2code...\n";
-test_Func(\&test,$tests,$runtests);
-
-1;
-# Local Variables:
-# mode: cperl
-# indent-tabs-mode: nil
-# cperl-indent-level: 3
-# cperl-continued-statement-offset: 2
-# cperl-continued-brace-offset: 0
-# cperl-brace-offset: 0
-# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
-# End:
-
+++ /dev/null
-#!/usr/bin/perl -w
-
-require 5.002;
-
-$runtests=shift(@ARGV);
-if ( -f "t/testfunc.pl" ) {
- require "t/testfunc.pl";
- $dir="./lib";
- $tdir="t";
-} elsif ( -f "testfunc.pl" ) {
- require "testfunc.pl";
- $dir="../lib";
- $tdir=".";
-} else {
- die "ERROR: cannot find testfunc.pl\n";
-}
-
-unshift(@INC,$dir);
-use Locale::Country;
-
-%type = ( "LOCALE_CODE_ALPHA_2" => LOCALE_CODE_ALPHA_2,
- "LOCALE_CODE_ALPHA_3" => LOCALE_CODE_ALPHA_3,
- "LOCALE_CODE_NUMERIC" => LOCALE_CODE_NUMERIC,
- );
-
-sub test {
- my(@test) = @_;
- $test[1] = $type{$test[1]} if (@test == 2 && $test[1] && exists $type{$test[1]});
- return country2code(@test);
-}
-
-$tests = "
-
-kazakhstan
- ~
- kz
-
-kazakstan
- ~
- kz
-
-macao
- ~
- mo
-
-macau
- ~
- mo
-
-
-~ _undef_
-
-_undef_
- ~
- _undef_
-
-Banana
- ~
- _undef_
-
-japan
- ~
- jp
-
-Japan
- ~
- jp
-
-United States
- ~
- us
-
-United Kingdom
- ~
- gb
-
-Andorra
- ~
- ad
-
-Zimbabwe
- ~
- zw
-
-Iran
- ~
- ir
-
-North Korea
- ~
- kp
-
-South Korea
- ~
- kr
-
-Libya
- ~
- ly
-
-Syrian Arab Republic
- ~
- sy
-
-Svalbard
- ~
- _undef_
-
-Jan Mayen
- ~
- _undef_
-
-USA
- ~
- us
-
-United States of America
- ~
- us
-
-Great Britain
- ~
- gb
-
-Burma
- ~
- mm
-
-French Southern and Antarctic Lands
- ~
- tf
-
-Aland Islands
- ~
- ax
-
-Yugoslavia
- ~
- _undef_
-
-Serbia and Montenegro
- ~
- _undef_
-
-East Timor
- ~
- tl
-
-Zaire
- ~
- _undef_
-
-Congo, The Democratic Republic of the
- ~
- cd
-
-Congo, The Democratic Republic of the
-LOCALE_CODE_ALPHA_3
- ~
- cod
-
-Congo, The Democratic Republic of the
-LOCALE_CODE_NUMERIC
- ~
- 180
-
-";
-
-print "country2code (old)...\n";
-test_Func(\&test,$tests,$runtests);
-
-1;
-# Local Variables:
-# mode: cperl
-# indent-tabs-mode: nil
-# cperl-indent-level: 3
-# cperl-continued-statement-offset: 2
-# cperl-continued-brace-offset: 0
-# cperl-brace-offset: 0
-# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
-# End:
-
+++ /dev/null
-#!/usr/bin/perl -w
-
-require 5.002;
-
-$runtests=shift(@ARGV);
-if ( -f "t/testfunc.pl" ) {
- require "t/testfunc.pl";
- $dir="./lib";
- $tdir="t";
-} elsif ( -f "testfunc.pl" ) {
- require "testfunc.pl";
- $dir="../lib";
- $tdir=".";
-} else {
- die "ERROR: cannot find testfunc.pl\n";
-}
-
-unshift(@INC,$dir);
-use Locale::Codes::Country;
-use Locale::Codes::Constants;
-
-%type = ( "LOCALE_CODE_ALPHA_2" => LOCALE_CODE_ALPHA_2,
- "LOCALE_CODE_ALPHA_3" => LOCALE_CODE_ALPHA_3,
- "LOCALE_CODE_NUMERIC" => LOCALE_CODE_NUMERIC,
- );
-
-sub test {
- my($code,$type_in,$type_out) = @_;
- $type_in = $type{$type_in} if ($type_in && exists $type{$type_in});
- $type_out = $type{$type_out} if ($type_out && exists $type{$type_out});
-
- return country_code2code($code,$type_in,$type_out);
-}
-
-$tests = "
-
-bo LOCALE_CODE_ALPHA_2 LOCALE_CODE_ALPHA_2 ~ bo
-
-bo LOCALE_CODE_ALPHA_3 LOCALE_CODE_ALPHA_3 ~ _undef_
-
-zz LOCALE_CODE_ALPHA_2 LOCALE_CODE_ALPHA_3 ~ _undef_
-
-zz LOCALE_CODE_ALPHA_3 LOCALE_CODE_ALPHA_3 ~ _undef_
-
-zz LOCALE_CODE_ALPHA_2 0 ~ _undef_
-
-bo LOCALE_CODE_ALPHA_2 0 ~ _undef_
-
-_blank_ 0 0 ~ _undef_
-
-BO LOCALE_CODE_ALPHA_2 LOCALE_CODE_ALPHA_3 ~ bol
-
-bol LOCALE_CODE_ALPHA_3 LOCALE_CODE_ALPHA_2 ~ bo
-
-zwe LOCALE_CODE_ALPHA_3 LOCALE_CODE_ALPHA_2 ~ zw
-
-858 LOCALE_CODE_NUMERIC LOCALE_CODE_ALPHA_3 ~ ury
-
-858 LOCALE_CODE_NUMERIC LOCALE_CODE_ALPHA_3 ~ ury
-
-tr LOCALE_CODE_ALPHA_2 LOCALE_CODE_NUMERIC ~ 792
-
-";
-
-print "country_code2code...\n";
-test_Func(\&test,$tests,$runtests);
-
-1;
-# Local Variables:
-# mode: cperl
-# indent-tabs-mode: nil
-# cperl-indent-level: 3
-# cperl-continued-statement-offset: 2
-# cperl-continued-brace-offset: 0
-# cperl-brace-offset: 0
-# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
-# End:
+++ /dev/null
-#!/usr/bin/perl -w
-
-require 5.002;
-
-$runtests=shift(@ARGV);
-if ( -f "t/testfunc.pl" ) {
- require "t/testfunc.pl";
- $dir="./lib";
- $tdir="t";
-} elsif ( -f "testfunc.pl" ) {
- require "testfunc.pl";
- $dir="../lib";
- $tdir=".";
-} else {
- die "ERROR: cannot find testfunc.pl\n";
-}
-
-unshift(@INC,$dir);
-use Locale::Country;
-use Locale::Codes::Constants;
-
-%type = ( "LOCALE_CODE_ALPHA_2" => LOCALE_CODE_ALPHA_2,
- "LOCALE_CODE_ALPHA_3" => LOCALE_CODE_ALPHA_3,
- "LOCALE_CODE_NUMERIC" => LOCALE_CODE_NUMERIC,
- );
-
-sub test {
- my($code,$type_in,$type_out) = @_;
- $type_in = $type{$type_in} if ($type_in && exists $type{$type_in});
- $type_out = $type{$type_out} if ($type_out && exists $type{$type_out});
-
- return country_code2code($code,$type_in,$type_out);
-}
-
-$tests = "
-
-bo LOCALE_CODE_ALPHA_2 LOCALE_CODE_ALPHA_2 ~ bo
-
-bo LOCALE_CODE_ALPHA_3 LOCALE_CODE_ALPHA_3 ~ _undef_
-
-zz LOCALE_CODE_ALPHA_2 LOCALE_CODE_ALPHA_3 ~ _undef_
-
-zz LOCALE_CODE_ALPHA_3 LOCALE_CODE_ALPHA_3 ~ _undef_
-
-zz LOCALE_CODE_ALPHA_2 0 ~ _undef_
-
-bo LOCALE_CODE_ALPHA_2 0 ~ _undef_
-
-_blank_ 0 0 ~ _undef_
-
-BO LOCALE_CODE_ALPHA_2 LOCALE_CODE_ALPHA_3 ~ bol
-
-bol LOCALE_CODE_ALPHA_3 LOCALE_CODE_ALPHA_2 ~ bo
-
-zwe LOCALE_CODE_ALPHA_3 LOCALE_CODE_ALPHA_2 ~ zw
-
-858 LOCALE_CODE_NUMERIC LOCALE_CODE_ALPHA_3 ~ ury
-
-858 LOCALE_CODE_NUMERIC LOCALE_CODE_ALPHA_3 ~ ury
-
-tr LOCALE_CODE_ALPHA_2 LOCALE_CODE_NUMERIC ~ 792
-
-";
-
-print "country_code2code (old)...\n";
-test_Func(\&test,$tests,$runtests);
-
-1;
-# Local Variables:
-# mode: cperl
-# indent-tabs-mode: nil
-# cperl-indent-level: 3
-# cperl-continued-statement-offset: 2
-# cperl-continued-brace-offset: 0
-# cperl-brace-offset: 0
-# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
-# End:
-#!/usr/bin/perl -w
+#!/usr/bin/perl
+use warnings;
+use strict;
require 5.002;
+my($runtests,$dir,$tdir);
+$::type = '';
+$::module = '';
+$::tests = '';
+
+$::type = 'country';
+$::module = 'Locale::Country';
+
$runtests=shift(@ARGV);
if ( -f "t/testfunc.pl" ) {
require "t/testfunc.pl";
+ require "t/vals.pl";
+ require "t/vals_country.pl";
$dir="./lib";
$tdir="t";
} elsif ( -f "testfunc.pl" ) {
require "testfunc.pl";
+ require "vals.pl";
+ require "vals_country.pl";
$dir="../lib";
$tdir=".";
} else {
}
unshift(@INC,$dir);
-use Locale::Country;
-
-%type = ( "LOCALE_CODE_ALPHA_2" => LOCALE_CODE_ALPHA_2,
- "LOCALE_CODE_ALPHA_3" => LOCALE_CODE_ALPHA_3,
- "LOCALE_CODE_NUMERIC" => LOCALE_CODE_NUMERIC,
- );
-
-sub test {
- my(@test) = @_;
-
- if ($test[0] eq "rename_country") {
- shift(@test);
- $test[2] = $type{$test[2]}
- if (@test == 3 && $test[2] && exists $type{$test[2]});
- return Locale::Country::rename_country(@test,"nowarn");
-
- } elsif ($test[0] eq "add_country") {
- shift(@test);
- $test[2] = $type{$test[2]}
- if (@test == 3 && $test[2] && exists $type{$test[2]});
- return Locale::Country::add_country(@test,"nowarn");
-
- } elsif ($test[0] eq "delete_country") {
- shift(@test);
- $test[1] = $type{$test[1]}
- if (@test == 2 && $test[1] && exists $type{$test[1]});
- return Locale::Country::delete_country(@test,"nowarn");
-
- } elsif ($test[0] eq "add_country_alias") {
- shift(@test);
- return Locale::Country::add_country_alias(@test,"nowarn");
-
- } elsif ($test[0] eq "delete_country_alias") {
- shift(@test);
- return Locale::Country::delete_country_alias(@test,"nowarn");
-
- } elsif ($test[0] eq "rename_country_code") {
- shift(@test);
- $test[2] = $type{$test[2]}
- if (@test == 3 && $test[2] && exists $type{$test[2]});
- return Locale::Country::rename_country_code(@test,"nowarn");
-
- } elsif ($test[0] eq "add_country_code_alias") {
- shift(@test);
- $test[2] = $type{$test[2]}
- if (@test == 3 && $test[2] && exists $type{$test[2]});
- return Locale::Country::add_country_code_alias(@test,"nowarn");
-
- } elsif ($test[0] eq "delete_country_code_alias") {
- shift(@test);
- $test[1] = $type{$test[1]}
- if (@test == 2 && $test[1] && exists $type{$test[1]});
- return Locale::Country::delete_country_code_alias(@test,"nowarn");
-
- } elsif ($test[0] eq "country2code") {
- shift(@test);
- $test[1] = $type{$test[1]}
- if (@test == 2 && $test[1] && exists $type{$test[1]});
- return country2code(@test);
-
- } else {
- shift(@test) if ($test[0] eq "code2country");
- $test[1] = $type{$test[1]}
- if (@test == 2 && $test[1] && exists $type{$test[1]});
- return code2country(@test);
- }
-}
-
-$tests = "
-
-###################################
-# Test rename_country
-
-gb
- ~
- United Kingdom of Great Britain and Northern Ireland
-
-rename_country x1 NewName ~ 0
-
-rename_country gb NewName LOCALE_CODE_FOO ~ 0
-
-rename_country gb Macao ~ 0
-
-rename_country gb NewName LOCALE_CODE_ALPHA_3 ~ 0
-
-gb
- ~
- United Kingdom of Great Britain and Northern Ireland
-
-rename_country gb NewName ~ 1
-
-gb
- ~
- NewName
-
-###################################
-# Test add_country
-
-xx ~ _undef_
-
-add_country xx Bolivia ~ 0
-
-add_country fi Xxxxx ~ 0
-
-add_country xx Xxxxx ~ 1
-
-xx ~ Xxxxx
-
-###################################
-# Test add_country_alias
-
-add_country_alias FooBar NewName ~ 0
-
-add_country_alias Australia Angola ~ 0
-
-country2code Australia ~ au
-
-country2code DownUnder ~ _undef_
-
-add_country_alias Australia DownUnder ~ 1
-
-country2code DownUnder ~ au
-
-###################################
-# Test delete_country_alias
-
-country2code uk ~ gb
-
-delete_country_alias Foobar ~ 0
-
-delete_country_alias UK ~ 1
-
-country2code uk ~ _undef_
-
-delete_country_alias Angola ~ 0
-
-###################################
-# Test delete_country
-
-country2code Angola ~ ao
-
-country2code Angola LOCALE_CODE_ALPHA_3 ~ ago
-
-delete_country ao ~ 1
-
-country2code Angola ~ _undef_
-
-country2code Angola LOCALE_CODE_ALPHA_3 ~ ago
-
-###################################
-# Test rename_country_code
-
-code2country zz ~ _undef_
-
-code2country ar ~ Argentina
-
-country2code Argentina ~ ar
-
-rename_country_code ar us ~ 0
-
-rename_country_code ar zz ~ 1
-
-rename_country_code us ar ~ 0
-
-code2country zz ~ Argentina
-
-code2country ar ~ Argentina
-
-country2code Argentina ~ zz
-
-rename_country_code zz ar ~ 1
-
-code2country zz ~ Argentina
-
-code2country ar ~ Argentina
-
-country2code Argentina ~ ar
-
-###################################
-# Test add_country_code_alias and
-# delete_country_code_alias
-
-code2country bm ~ Bermuda
-
-code2country yy ~ _undef_
-
-country2code Bermuda ~ bm
-
-add_country_code_alias bm us ~ 0
-
-add_country_code_alias bm zz ~ 0
-
-add_country_code_alias bm yy ~ 1
-
-code2country bm ~ Bermuda
-
-code2country yy ~ Bermuda
-
-country2code Bermuda ~ bm
-
-delete_country_code_alias us ~ 0
-
-delete_country_code_alias ww ~ 0
-
-delete_country_code_alias yy ~ 1
-
-code2country bm ~ Bermuda
-
-code2country yy ~ _undef_
-
-country2code Bermuda ~ bm
-
-";
-print "country (old; semi-private)...\n";
-test_Func(\&test,$tests,$runtests);
+print "country (old)...\n";
+test_Func(\&test,$::tests,$runtests);
1;
# Local Variables:
# cperl-continued-brace-offset: 0
# cperl-brace-offset: 0
# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
+# cperl-label-offset: 0
# End:
-#!/usr/bin/perl -w
+#!/usr/bin/perl
+use warnings;
+use strict;
require 5.002;
+my($runtests,$dir,$tdir);
+$::type = '';
+$::module = '';
+$::tests = '';
+
+$::type = 'currency';
+$::module = 'Locale::Codes::Currency';
+
$runtests=shift(@ARGV);
if ( -f "t/testfunc.pl" ) {
require "t/testfunc.pl";
+ require "t/vals.pl";
+ require "t/vals_currency.pl";
$dir="./lib";
$tdir="t";
} elsif ( -f "testfunc.pl" ) {
require "testfunc.pl";
+ require "vals.pl";
+ require "vals_currency.pl";
$dir="../lib";
$tdir=".";
} else {
}
unshift(@INC,$dir);
-use Locale::Codes::LangFam;
-
-%type = ( "LOCALE_LANGFAM_ALPHA" => LOCALE_LANGFAM_ALPHA,
- );
-
-sub test {
- my(@test) = @_;
- $test[1] = $type{$test[1]}
- if (@test == 2 && $test[1] && exists $type{$test[1]});
- return code2langfam(@test);
-}
-
-$tests = "
-
-zzz ~ _undef_
-
-apa
- ~
- Apache languages
-
-";
-print "code2langfam...\n";
-test_Func(\&test,$tests,$runtests);
+print "currency...\n";
+test_Func(\&test,$::tests,$runtests);
1;
# Local Variables:
# cperl-continued-brace-offset: 0
# cperl-brace-offset: 0
# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
+# cperl-label-offset: 0
# End:
+++ /dev/null
-#!/usr/bin/perl -w
-
-require 5.002;
-
-$runtests=shift(@ARGV);
-if ( -f "t/testfunc.pl" ) {
- require "t/testfunc.pl";
- $dir="./lib";
- $tdir="t";
-} elsif ( -f "testfunc.pl" ) {
- require "testfunc.pl";
- $dir="../lib";
- $tdir=".";
-} else {
- die "ERROR: cannot find testfunc.pl\n";
-}
-
-unshift(@INC,$dir);
-use Locale::Codes::Currency;
-
-%type = ( "LOCALE_CURR_ALPHA" => LOCALE_CURR_ALPHA,
- "LOCALE_CURR_NUMERIC" => LOCALE_CURR_NUMERIC,
- );
-
-sub test {
- my(@test) = @_;
- $test[1] = $type{$test[1]}
- if (@test == 2 && $test[1] && exists $type{$test[1]});
- return currency2code(@test);
-}
-
-$tests = "
-
-_blank_ ~ _undef_
-
-Banana ~ _undef_
-
-~ _undef_
-
-_undef_ ~ _undef_
-
-
-Canadian Dollar
- ~
- CAD
-
-Belize Dollar
- ~
- BZD
-
-PULA
- ~
- BWP
-
-Riel
- ~
- KHR
-
-Zimbabwe Dollar
- ~
- ZWL
-
-";
-
-print "currency2code...\n";
-test_Func(\&test,$tests,$runtests);
-
-1;
-# Local Variables:
-# mode: cperl
-# indent-tabs-mode: nil
-# cperl-indent-level: 3
-# cperl-continued-statement-offset: 2
-# cperl-continued-brace-offset: 0
-# cperl-brace-offset: 0
-# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
-# End:
+++ /dev/null
-#!/usr/bin/perl -w
-
-require 5.002;
-
-$runtests=shift(@ARGV);
-if ( -f "t/testfunc.pl" ) {
- require "t/testfunc.pl";
- $dir="./lib";
- $tdir="t";
-} elsif ( -f "testfunc.pl" ) {
- require "testfunc.pl";
- $dir="../lib";
- $tdir=".";
-} else {
- die "ERROR: cannot find testfunc.pl\n";
-}
-
-unshift(@INC,$dir);
-use Locale::Currency;
-
-%type = ( "LOCALE_CURR_ALPHA" => LOCALE_CURR_ALPHA,
- "LOCALE_CURR_NUMERIC" => LOCALE_CURR_NUMERIC,
- );
-
-sub test {
- my(@test) = @_;
- $test[1] = $type{$test[1]}
- if (@test == 2 && $test[1] && exists $type{$test[1]});
- return currency2code(@test);
-}
-
-$tests = "
-
-_blank_ ~ _undef_
-
-Banana ~ _undef_
-
-~ _undef_
-
-_undef_ ~ _undef_
-
-
-Canadian Dollar
- ~
- CAD
-
-Belize Dollar
- ~
- BZD
-
-PULA
- ~
- BWP
-
-Riel
- ~
- KHR
-
-Zimbabwe Dollar
- ~
- ZWL
-
-";
-
-print "currency2code (old)...\n";
-test_Func(\&test,$tests,$runtests);
-
-1;
-# Local Variables:
-# mode: cperl
-# indent-tabs-mode: nil
-# cperl-indent-level: 3
-# cperl-continued-statement-offset: 2
-# cperl-continued-brace-offset: 0
-# cperl-brace-offset: 0
-# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
-# End:
-#!/usr/bin/perl -w
+#!/usr/bin/perl
+use warnings;
+use strict;
require 5.002;
+my($runtests,$dir,$tdir);
+$::type = '';
+$::module = '';
+$::tests = '';
+
+$::type = 'currency';
+$::module = 'Locale::Currency';
+
$runtests=shift(@ARGV);
if ( -f "t/testfunc.pl" ) {
require "t/testfunc.pl";
+ require "t/vals.pl";
+ require "t/vals_currency.pl";
$dir="./lib";
$tdir="t";
} elsif ( -f "testfunc.pl" ) {
require "testfunc.pl";
+ require "vals.pl";
+ require "vals_currency.pl";
$dir="../lib";
$tdir=".";
} else {
}
unshift(@INC,$dir);
-use Locale::Codes::LangExt;
-
-%type = ( "LOCALE_LANGEXT_ALPHA" => LOCALE_LANGEXT_ALPHA,
- );
-
-sub test {
- my(@test) = @_;
- $test[1] = $type{$test[1]}
- if (@test == 2 && $test[1] && exists $type{$test[1]});
- return code2langext(@test);
-}
-
-$tests = "
-
-zzz ~ _undef_
-
-acm
- ~
- Mesopotamian Arabic
-
-";
-print "code2langext...\n";
-test_Func(\&test,$tests,$runtests);
+print "currency (old)...\n";
+test_Func(\&test,$::tests,$runtests);
1;
# Local Variables:
# cperl-continued-brace-offset: 0
# cperl-brace-offset: 0
# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
+# cperl-label-offset: 0
# End:
-#!/usr/bin/perl -w
+#!/usr/bin/perl
+use warnings;
+use strict;
require 5.002;
+my($runtests,$dir,$tdir);
+$::type = '';
+$::module = '';
+$::tests = '';
+
+$::type = 'langext';
+$::module = 'Locale::Codes::LangExt';
+
$runtests=shift(@ARGV);
if ( -f "t/testfunc.pl" ) {
require "t/testfunc.pl";
+ require "t/vals.pl";
+ require "t/vals_langext.pl";
$dir="./lib";
$tdir="t";
} elsif ( -f "testfunc.pl" ) {
require "testfunc.pl";
+ require "vals.pl";
+ require "vals_langext.pl";
$dir="../lib";
$tdir=".";
} else {
}
unshift(@INC,$dir);
-use Locale::Codes::LangVar;
-
-%type = ( "LOCALE_LANGVAR_ALPHA" => LOCALE_LANGVAR_ALPHA,
- );
-
-sub test {
- my(@test) = @_;
- $test[1] = $type{$test[1]}
- if (@test == 2 && $test[1] && exists $type{$test[1]});
- return code2langvar(@test);
-}
-
-$tests = "
-
-zzz ~ _undef_
-
-arevela
- ~
- Eastern Armenian
-
-";
-print "code2langvar...\n";
-test_Func(\&test,$tests,$runtests);
+print "langext...\n";
+test_Func(\&test,$::tests,$runtests);
1;
# Local Variables:
# cperl-continued-brace-offset: 0
# cperl-brace-offset: 0
# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
+# cperl-label-offset: 0
# End:
+++ /dev/null
-#!/usr/bin/perl -w
-
-require 5.002;
-
-$runtests=shift(@ARGV);
-if ( -f "t/testfunc.pl" ) {
- require "t/testfunc.pl";
- $dir="./lib";
- $tdir="t";
-} elsif ( -f "testfunc.pl" ) {
- require "testfunc.pl";
- $dir="../lib";
- $tdir=".";
-} else {
- die "ERROR: cannot find testfunc.pl\n";
-}
-
-unshift(@INC,$dir);
-use Locale::Codes::LangExt;
-
-%type = ( "LOCALE_LANGEXT_ALPHA" => LOCALE_LANGEXT_ALPHA,
- );
-
-sub test {
- my(@test) = @_;
- $test[1] = $type{$test[1]}
- if (@test == 2 && $test[1] && exists $type{$test[1]});
- return langext2code(@test);
-}
-
-$tests = "
-
-_blank_ ~ _undef_
-
-Mesopotamian Arabic
- ~
- acm
-
-";
-
-print "langext2code...\n";
-test_Func(\&test,$tests,$runtests);
-
-1;
-# Local Variables:
-# mode: cperl
-# indent-tabs-mode: nil
-# cperl-indent-level: 3
-# cperl-continued-statement-offset: 2
-# cperl-continued-brace-offset: 0
-# cperl-brace-offset: 0
-# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
-# End:
-#!/usr/bin/perl -w
+#!/usr/bin/perl
+use warnings;
+use strict;
require 5.002;
+my($runtests,$dir,$tdir);
+$::type = '';
+$::module = '';
+$::tests = '';
+
+$::type = 'langfam';
+$::module = 'Locale::Codes::LangFam';
+
$runtests=shift(@ARGV);
if ( -f "t/testfunc.pl" ) {
require "t/testfunc.pl";
+ require "t/vals.pl";
+ require "t/vals_langfam.pl";
$dir="./lib";
$tdir="t";
} elsif ( -f "testfunc.pl" ) {
require "testfunc.pl";
+ require "vals.pl";
+ require "vals_langfam.pl";
$dir="../lib";
$tdir=".";
} else {
}
unshift(@INC,$dir);
-use Locale::Codes::LangFam;
-
-%type = ( "LOCALE_LANGFAM_ALPHA" => LOCALE_LANGFAM_ALPHA,
- );
-
-sub test {
- my(@test) = @_;
- $test[1] = $type{$test[1]}
- if (@test == 2 && $test[1] && exists $type{$test[1]});
- return langfam2code(@test);
-}
-
-$tests = "
-
-_blank_ ~ _undef_
-
-Apache languages
- ~
- apa
-
-";
-print "langfam2code...\n";
-test_Func(\&test,$tests,$runtests);
+print "langfam...\n";
+test_Func(\&test,$::tests,$runtests);
1;
# Local Variables:
# cperl-continued-brace-offset: 0
# cperl-brace-offset: 0
# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
+# cperl-label-offset: 0
# End:
-#!/usr/bin/perl -w
+#!/usr/bin/perl
+use warnings;
+use strict;
require 5.002;
+my($runtests,$dir,$tdir);
+$::type = '';
+$::module = '';
+$::tests = '';
+
+$::type = 'language';
+$::module = 'Locale::Codes::Language';
+
$runtests=shift(@ARGV);
if ( -f "t/testfunc.pl" ) {
require "t/testfunc.pl";
+ require "t/vals.pl";
+ require "t/vals_language.pl";
$dir="./lib";
$tdir="t";
} elsif ( -f "testfunc.pl" ) {
require "testfunc.pl";
+ require "vals.pl";
+ require "vals_language.pl";
$dir="../lib";
$tdir=".";
} else {
}
unshift(@INC,$dir);
-use Locale::Codes::Language;
-
-%type = ( "LOCALE_LANG_ALPHA_2" => LOCALE_LANG_ALPHA_2,
- "LOCALE_LANG_ALPHA_3" => LOCALE_LANG_ALPHA_3,
- "LOCALE_LANG_TERM" => LOCALE_LANG_TERM,
- );
-
-sub test {
- my(@test) = @_;
-
- if ($test[0] eq "rename_language") {
- shift(@test);
- $test[2] = $type{$test[2]}
- if (@test == 3 && $test[2] && exists $type{$test[2]});
- return Locale::Codes::Language::rename_language(@test,"nowarn");
-
- } elsif ($test[0] eq "add_language") {
- shift(@test);
- $test[2] = $type{$test[2]}
- if (@test == 3 && $test[2] && exists $type{$test[2]});
- return Locale::Codes::Language::add_language(@test,"nowarn");
-
- } elsif ($test[0] eq "delete_language") {
- shift(@test);
- $test[1] = $type{$test[1]}
- if (@test == 2 && $test[1] && exists $type{$test[1]});
- return Locale::Codes::Language::delete_language(@test,"nowarn");
-
- } elsif ($test[0] eq "add_language_alias") {
- shift(@test);
- return Locale::Codes::Language::add_language_alias(@test,"nowarn");
-
- } elsif ($test[0] eq "delete_language_alias") {
- shift(@test);
- return Locale::Codes::Language::delete_language_alias(@test,"nowarn");
-
- } elsif ($test[0] eq "language2code") {
- shift(@test);
- $test[1] = $type{$test[1]}
- if (@test == 2 && $test[1] && exists $type{$test[1]});
- return language2code(@test);
-
- } else {
- $test[1] = $type{$test[1]}
- if (@test == 2 && $test[1] && exists $type{$test[1]});
- return code2language(@test);
- }
-}
-
-$tests = "
-
-zu ~ Zulu
-
-rename_language zu NewName LOCALE_LANG_FOO ~ 0
-
-rename_language zu English LOCALE_LANG_ALPHA_2 ~ 0
-
-rename_language zu NewName LOCALE_LANG_ALPHA_3 ~ 0
-
-zu ~ Zulu
-
-rename_language zu NewName LOCALE_LANG_ALPHA_2 ~ 1
-
-zu ~ NewName
-
-";
-print "language (semi-private)...\n";
-test_Func(\&test,$tests,$runtests);
+print "language...\n";
+test_Func(\&test,$::tests,$runtests);
1;
# Local Variables:
# cperl-continued-brace-offset: 0
# cperl-brace-offset: 0
# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
+# cperl-label-offset: 0
# End:
+++ /dev/null
-#!/usr/bin/perl -w
-
-require 5.002;
-
-$runtests=shift(@ARGV);
-if ( -f "t/testfunc.pl" ) {
- require "t/testfunc.pl";
- $dir="./lib";
- $tdir="t";
-} elsif ( -f "testfunc.pl" ) {
- require "testfunc.pl";
- $dir="../lib";
- $tdir=".";
-} else {
- die "ERROR: cannot find testfunc.pl\n";
-}
-
-unshift(@INC,$dir);
-use Locale::Codes::Language;
-
-%type = ( "LOCALE_LANG_ALPHA_2" => LOCALE_LANG_ALPHA_2,
- "LOCALE_LANG_ALPHA_3" => LOCALE_LANG_ALPHA_3,
- "LOCALE_LANG_TERM" => LOCALE_LANG_TERM,
- );
-
-sub test {
- my(@test) = @_;
- $test[1] = $type{$test[1]}
- if (@test == 2 && $test[1] && exists $type{$test[1]});
- return language2code(@test);
-}
-
-$tests = "
-
-Banana ~ _undef_
-
-~ _undef_
-
-_undef_ ~ _undef_
-
-Afar
- ~
- aa
-
-ESTONIAN
- ~
- et
-
-French
- ~
- fr
-
-Greek
- ~
- el
-
-Japanese
- ~
- ja
-
-Zulu
- ~
- zu
-
-english
- ~
- en
-
-japanese
- ~
- ja
-
-# Last ones in the list
-
-Zulu
-LOCALE_LANG_ALPHA_2
- ~
- zu
-
-Zaza
-LOCALE_LANG_ALPHA_3
- ~
- zza
-
-Welsh
-LOCALE_LANG_TERM
- ~
- cym
-
-Zande languages
-LOCALE_LANG_ALPHA_3
- ~
- znd
-
-Zuojiang Zhuang
-LOCALE_LANG_ALPHA_3
- ~
- zzj
-
-";
-
-print "language2code...\n";
-test_Func(\&test,$tests,$runtests);
-
-1;
-# Local Variables:
-# mode: cperl
-# indent-tabs-mode: nil
-# cperl-indent-level: 3
-# cperl-continued-statement-offset: 2
-# cperl-continued-brace-offset: 0
-# cperl-brace-offset: 0
-# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
-# End:
-#!/usr/bin/perl -w
+#!/usr/bin/perl
+use warnings;
+use strict;
require 5.002;
+my($runtests,$dir,$tdir);
+$::type = '';
+$::module = '';
+$::tests = '';
+
+$::type = 'language';
+$::module = 'Locale::Language';
+
$runtests=shift(@ARGV);
if ( -f "t/testfunc.pl" ) {
require "t/testfunc.pl";
+ require "t/vals.pl";
+ require "t/vals_language.pl";
$dir="./lib";
$tdir="t";
} elsif ( -f "testfunc.pl" ) {
require "testfunc.pl";
+ require "vals.pl";
+ require "vals_language.pl";
$dir="../lib";
$tdir=".";
} else {
}
unshift(@INC,$dir);
-use Locale::Language;
-
-%type = ( "LOCALE_LANG_ALPHA_2" => LOCALE_LANG_ALPHA_2,
- "LOCALE_LANG_ALPHA_3" => LOCALE_LANG_ALPHA_3,
- "LOCALE_LANG_TERM" => LOCALE_LANG_TERM,
- );
-
-sub test {
- my(@test) = @_;
-
- if ($test[0] eq "rename_language") {
- shift(@test);
- $test[2] = $type{$test[2]}
- if (@test == 3 && $test[2] && exists $type{$test[2]});
- return Locale::Language::rename_language(@test,"nowarn");
-
- } elsif ($test[0] eq "add_language") {
- shift(@test);
- $test[2] = $type{$test[2]}
- if (@test == 3 && $test[2] && exists $type{$test[2]});
- return Locale::Language::add_language(@test,"nowarn");
-
- } elsif ($test[0] eq "delete_language") {
- shift(@test);
- $test[1] = $type{$test[1]}
- if (@test == 2 && $test[1] && exists $type{$test[1]});
- return Locale::Language::delete_language(@test,"nowarn");
-
- } elsif ($test[0] eq "add_language_alias") {
- shift(@test);
- return Locale::Language::add_language_alias(@test,"nowarn");
-
- } elsif ($test[0] eq "delete_language_alias") {
- shift(@test);
- return Locale::Language::delete_language_alias(@test,"nowarn");
-
- } elsif ($test[0] eq "language2code") {
- shift(@test);
- $test[1] = $type{$test[1]}
- if (@test == 2 && $test[1] && exists $type{$test[1]});
- return language2code(@test);
-
- } else {
- $test[1] = $type{$test[1]}
- if (@test == 2 && $test[1] && exists $type{$test[1]});
- return code2language(@test);
- }
-}
-
-$tests = "
-
-zu ~ Zulu
-
-rename_language zu NewName LOCALE_LANG_FOO ~ 0
-
-rename_language zu English LOCALE_LANG_ALPHA_2 ~ 0
-
-rename_language zu NewName LOCALE_LANG_ALPHA_3 ~ 0
-
-zu ~ Zulu
-
-rename_language zu NewName LOCALE_LANG_ALPHA_2 ~ 1
-
-zu ~ NewName
-
-";
-print "language (old; semi-private)...\n";
-test_Func(\&test,$tests,$runtests);
+print "language (old)...\n";
+test_Func(\&test,$::tests,$runtests);
1;
# Local Variables:
# cperl-continued-brace-offset: 0
# cperl-brace-offset: 0
# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
+# cperl-label-offset: 0
# End:
--- /dev/null
+#!/usr/bin/perl
+
+use warnings;
+use strict;
+require 5.002;
+
+my($runtests,$dir,$tdir);
+$::type = '';
+$::module = '';
+$::tests = '';
+
+$::type = 'langvar';
+$::module = 'Locale::Codes::LangVar';
+
+$runtests=shift(@ARGV);
+if ( -f "t/testfunc.pl" ) {
+ require "t/testfunc.pl";
+ require "t/vals.pl";
+ require "t/vals_langvar.pl";
+ $dir="./lib";
+ $tdir="t";
+} elsif ( -f "testfunc.pl" ) {
+ require "testfunc.pl";
+ require "vals.pl";
+ require "vals_langvar.pl";
+ $dir="../lib";
+ $tdir=".";
+} else {
+ die "ERROR: cannot find testfunc.pl\n";
+}
+
+unshift(@INC,$dir);
+
+print "langvar...\n";
+test_Func(\&test,$::tests,$runtests);
+
+1;
+# Local Variables:
+# mode: cperl
+# indent-tabs-mode: nil
+# cperl-indent-level: 3
+# cperl-continued-statement-offset: 2
+# cperl-continued-brace-offset: 0
+# cperl-brace-offset: 0
+# cperl-brace-imaginary-offset: 0
+# cperl-label-offset: 0
+# End:
+++ /dev/null
-#!/usr/bin/perl -w
-
-require 5.002;
-
-$runtests=shift(@ARGV);
-if ( -f "t/testfunc.pl" ) {
- require "t/testfunc.pl";
- $dir="./lib";
- $tdir="t";
-} elsif ( -f "testfunc.pl" ) {
- require "testfunc.pl";
- $dir="../lib";
- $tdir=".";
-} else {
- die "ERROR: cannot find testfunc.pl\n";
-}
-
-unshift(@INC,$dir);
-use Locale::Codes::LangVar;
-
-%type = ( "LOCALE_LANGVAR_ALPHA" => LOCALE_LANGVAR_ALPHA,
- );
-
-sub test {
- my(@test) = @_;
- $test[1] = $type{$test[1]}
- if (@test == 2 && $test[1] && exists $type{$test[1]});
- return langvar2code(@test);
-}
-
-$tests = "
-
-_blank_ ~ _undef_
-
-Eastern Armenian
- ~
- arevela
-
-";
-
-print "langvar2code...\n";
-test_Func(\&test,$tests,$runtests);
-
-1;
-# Local Variables:
-# mode: cperl
-# indent-tabs-mode: nil
-# cperl-indent-level: 3
-# cperl-continued-statement-offset: 2
-# cperl-continued-brace-offset: 0
-# cperl-brace-offset: 0
-# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
-# End:
--- /dev/null
+#!/usr/bin/perl
+
+use warnings;
+use strict;
+require 5.002;
+
+my($runtests,$dir,$tdir);
+$::type = '';
+$::module = '';
+$::tests = '';
+
+$::type = 'script';
+$::module = 'Locale::Codes::Script';
+
+$runtests=shift(@ARGV);
+if ( -f "t/testfunc.pl" ) {
+ require "t/testfunc.pl";
+ require "t/vals.pl";
+ require "t/vals_script.pl";
+ $dir="./lib";
+ $tdir="t";
+} elsif ( -f "testfunc.pl" ) {
+ require "testfunc.pl";
+ require "vals.pl";
+ require "vals_script.pl";
+ $dir="../lib";
+ $tdir=".";
+} else {
+ die "ERROR: cannot find testfunc.pl\n";
+}
+
+unshift(@INC,$dir);
+
+print "script...\n";
+test_Func(\&test,$::tests,$runtests);
+
+1;
+# Local Variables:
+# mode: cperl
+# indent-tabs-mode: nil
+# cperl-indent-level: 3
+# cperl-continued-statement-offset: 2
+# cperl-continued-brace-offset: 0
+# cperl-brace-offset: 0
+# cperl-brace-imaginary-offset: 0
+# cperl-label-offset: 0
+# End:
+++ /dev/null
-#!/usr/bin/perl -w
-
-require 5.002;
-
-$runtests=shift(@ARGV);
-if ( -f "t/testfunc.pl" ) {
- require "t/testfunc.pl";
- $dir="./lib";
- $tdir="t";
-} elsif ( -f "testfunc.pl" ) {
- require "testfunc.pl";
- $dir="../lib";
- $tdir=".";
-} else {
- die "ERROR: cannot find testfunc.pl\n";
-}
-
-unshift(@INC,$dir);
-use Locale::Codes::Script;
-
-%type = ( "LOCALE_SCRIPT_ALPHA" => LOCALE_SCRIPT_ALPHA,
- "LOCALE_SCRIPT_NUMERIC" => LOCALE_SCRIPT_NUMERIC,
- );
-
-sub test {
- my(@test) = @_;
- $test[1] = $type{$test[1]}
- if (@test == 2 && $test[1] && exists $type{$test[1]});
- return script2code(@test);
-}
-
-$tests = "
-
-~ _undef_
-
-Phoenician ~ Phnx
-
-Phoenician LOCALE_SCRIPT_NUMERIC ~ 115
-
-";
-
-print "script2code...\n";
-test_Func(\&test,$tests,$runtests);
-
-1;
-# Local Variables:
-# mode: cperl
-# indent-tabs-mode: nil
-# cperl-indent-level: 3
-# cperl-continued-statement-offset: 2
-# cperl-continued-brace-offset: 0
-# cperl-brace-offset: 0
-# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
-# End:
+++ /dev/null
-#!/usr/bin/perl -w
-
-require 5.002;
-
-$runtests=shift(@ARGV);
-if ( -f "t/testfunc.pl" ) {
- require "t/testfunc.pl";
- $dir="./lib";
- $tdir="t";
-} elsif ( -f "testfunc.pl" ) {
- require "testfunc.pl";
- $dir="../lib";
- $tdir=".";
-} else {
- die "ERROR: cannot find testfunc.pl\n";
-}
-
-unshift(@INC,$dir);
-use Locale::Script;
-
-%type = ( "LOCALE_SCRIPT_ALPHA" => LOCALE_SCRIPT_ALPHA,
- "LOCALE_SCRIPT_NUMERIC" => LOCALE_SCRIPT_NUMERIC,
- );
-
-sub test {
- my(@test) = @_;
- $test[1] = $type{$test[1]}
- if (@test == 2 && $test[1] && exists $type{$test[1]});
- return script2code(@test);
-}
-
-$tests = "
-
-~ _undef_
-
-Phoenician ~ Phnx
-
-Phoenician LOCALE_SCRIPT_NUMERIC ~ 115
-
-";
-
-print "script2code (old)...\n";
-test_Func(\&test,$tests,$runtests);
-
-1;
-# Local Variables:
-# mode: cperl
-# indent-tabs-mode: nil
-# cperl-indent-level: 3
-# cperl-continued-statement-offset: 2
-# cperl-continued-brace-offset: 0
-# cperl-brace-offset: 0
-# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
-# End:
--- /dev/null
+#!/usr/bin/perl
+
+use warnings;
+use strict;
+require 5.002;
+
+my($runtests,$dir,$tdir);
+$::type = '';
+$::module = '';
+$::tests = '';
+
+$::type = 'script';
+$::module = 'Locale::Script';
+
+$runtests=shift(@ARGV);
+if ( -f "t/testfunc.pl" ) {
+ require "t/testfunc.pl";
+ require "t/vals.pl";
+ require "t/vals_script.pl";
+ $dir="./lib";
+ $tdir="t";
+} elsif ( -f "testfunc.pl" ) {
+ require "testfunc.pl";
+ require "vals.pl";
+ require "vals_script.pl";
+ $dir="../lib";
+ $tdir=".";
+} else {
+ die "ERROR: cannot find testfunc.pl\n";
+}
+
+unshift(@INC,$dir);
+
+print "script (old)...\n";
+test_Func(\&test,$::tests,$runtests);
+
+1;
+# Local Variables:
+# mode: cperl
+# indent-tabs-mode: nil
+# cperl-indent-level: 3
+# cperl-continued-statement-offset: 2
+# cperl-continued-brace-offset: 0
+# cperl-brace-offset: 0
+# cperl-brace-imaginary-offset: 0
+# cperl-label-offset: 0
+# End:
#!/usr/bin/perl -w
-# Copyright (c) 1996-2015 Sullivan Beck. All rights reserved.
+# Copyright (c) 1996-2016 Sullivan Beck. All rights reserved.
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
# cperl-continued-brace-offset: 0
# cperl-brace-offset: 0
# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
+# cperl-label-offset: 0
# End:
--- /dev/null
+#!/usr/bin/perl
+# Copyright (c) 2016-2016 Sullivan Beck. All rights reserved.
+# This program is free software; you can redistribute it and/or modify it
+# under the same terms as Perl itself.
+
+use warnings;
+use strict;
+no strict 'subs';
+no strict 'refs';
+
+$::generic_tests = '';
+
+eval "use $::module";
+
+sub test {
+ my ($op,@test) = @_;
+
+ if ($op eq '2code') {
+ my $code = &{ "${::type}2code" }(@test);
+ return ($code ? lc($code) : $code);
+ } elsif ($op eq '2name') {
+ return &{ "code2${::type}" }(@test)
+ } elsif ($op eq '_code2code') {
+ my $code = &{ "${::type}_code2code" }(@test,"nowarn");
+ return ($code ? lc($code) : $code);
+
+ } elsif ($op eq 'all_codes') {
+ my $n;
+ if ($test[$#test] =~ /^\d+$/) {
+ $n = pop(@test);
+ }
+
+ my @tmp = &{ "all_${::type}_codes" }(@test);
+ if ($n && @tmp > $n) {
+ return @tmp[0..($n-1)];
+ } else {
+ return @tmp;
+ }
+ } elsif ($op eq 'all_names') {
+ my $n;
+ if ($test[$#test] =~ /^\d+$/) {
+ $n = pop(@test);
+ }
+
+ my @tmp = &{ "all_${::type}_names" }(@test);
+ if ($n && @tmp > $n) {
+ return @tmp[0..($n-1)];
+ } else {
+ return @tmp;
+ }
+
+ } elsif ($op eq 'rename') {
+ return &{ "${::module}::rename_${::type}" }(@test,"nowarn")
+ } elsif ($op eq 'add') {
+ return &{ "${::module}::add_${::type}" }(@test,"nowarn")
+ } elsif ($op eq 'delete') {
+ return &{ "${::module}::delete_${::type}" }(@test,"nowarn")
+ } elsif ($op eq 'add_alias') {
+ return &{ "${::module}::add_${::type}_alias" }(@test,"nowarn")
+ } elsif ($op eq 'delete_alias') {
+ return &{ "${::module}::delete_${::type}_alias" }(@test,"nowarn")
+ } elsif ($op eq 'rename_code') {
+ return &{ "${::module}::rename_${::type}_code" }(@test,"nowarn")
+ } elsif ($op eq 'add_code_alias') {
+ return &{ "${::module}::add_${::type}_code_alias" }(@test,"nowarn")
+ } elsif ($op eq 'delete_code_alias') {
+ return &{ "${::module}::delete_${::type}_code_alias" }(@test,"nowarn")
+ }
+}
+
+$::generic_tests = "
+#################
+
+2code
+_undef_
+ _undef_
+
+2code
+ _undef_
+
+2code
+_blank_
+ _undef_
+
+2code
+UnusedName
+ _undef_
+
+2code
+ _undef_
+
+2code
+_undef_
+ _undef_
+
+2name
+_undef
+ _undef_
+
+2name
+ _undef_
+
+###
+
+add
+AAA
+newCode
+ 1
+
+2code
+newCode
+ aaa
+
+delete
+AAA
+ 1
+
+2code
+newCode
+ _undef_
+
+###
+
+add
+AAA
+newCode
+ 1
+
+rename
+AAA
+newCode2
+ 1
+
+2code
+newCode
+ aaa
+
+2code
+newCode2
+ aaa
+
+###
+
+add_alias
+newCode2
+newAlias
+ 1
+
+2code
+newAlias
+ aaa
+
+delete_alias
+newAlias
+ 1
+
+2code
+newAlias
+ _undef_
+
+###
+
+rename_code
+AAA
+BBB
+ 1
+
+2name
+AAA
+ newCode2
+
+2name
+BBB
+ newCode2
+
+###
+
+add_code_alias
+BBB
+CCC
+ 1
+
+2name
+BBB
+ newCode2
+
+2name
+CCC
+ newCode2
+
+delete_code_alias
+CCC
+ 1
+
+2name
+CCC
+ _undef_
+
+";
+
+1;
+# Local Variables:
+# mode: cperl
+# indent-tabs-mode: nil
+# cperl-indent-level: 3
+# cperl-continued-statement-offset: 2
+# cperl-continued-brace-offset: 0
+# cperl-brace-offset: 0
+# cperl-brace-imaginary-offset: 0
+# cperl-label-offset: 0
+# End:
+
--- /dev/null
+#!/usr/bin/perl
+# Copyright (c) 2016-2016 Sullivan Beck. All rights reserved.
+# This program is free software; you can redistribute it and/or modify it
+# under the same terms as Perl itself.
+
+use warnings;
+use strict;
+
+$::tests = $::generic_tests;
+
+$::tests = "
+##################
+# code2country
+
+all_names
+2
+ ~
+ Afghanistan
+ Aland Islands
+
+all_codes
+2
+ ~
+ ad
+ ae
+
+all_names
+retired
+2
+ ~
+ Afghanistan
+ Aland Islands
+
+all_codes
+retired
+2
+ ~
+ ad
+ ae
+
+all_names
+foo
+2
+ ~
+
+all_codes
+foo
+2
+ ~
+
+2name
+zz
+ _undef_
+
+2name
+zz
+alpha-2
+ _undef_
+
+2name
+zz
+alpha-3
+ _undef_
+
+2name
+zz
+numeric
+ _undef_
+
+2name
+ja
+ _undef_
+
+2name
+uk
+ _undef_
+
+2name
+BO
+ Bolivia (Plurinational State of)
+
+2name
+BO
+alpha-2
+ Bolivia (Plurinational State of)
+
+2name
+bol
+alpha-3
+ Bolivia (Plurinational State of)
+
+2name
+pk
+ Pakistan
+
+2name
+sn
+ Senegal
+
+2name
+us
+ United States of America
+
+2name
+ad
+ Andorra
+
+2name
+ad
+alpha-2
+ Andorra
+
+2name
+and
+alpha-3
+ Andorra
+
+2name
+020
+numeric
+ Andorra
+
+2name
+48
+numeric
+ Bahrain
+
+2name
+zw
+ Zimbabwe
+
+2name
+gb
+ United Kingdom of Great Britain and Northern Ireland
+
+2name
+kz
+ Kazakhstan
+
+2name
+mo
+ Macao
+
+2name
+tl
+alpha-2
+ Timor-Leste
+
+2name
+tls
+alpha-3
+ Timor-Leste
+
+2name
+626
+numeric
+ Timor-Leste
+
+2name
+BO
+alpha-3
+ _undef_
+
+2name
+BO
+numeric
+ _undef_
+
+2name
+ax
+ Aland Islands
+
+2name
+ala
+alpha-3
+ Aland Islands
+
+2name
+248
+numeric
+ Aland Islands
+
+2name
+scg
+alpha-3
+ _undef_
+
+2name
+891
+numeric
+ _undef_
+
+2name
+rou
+alpha-3
+ Romania
+
+2name
+zr
+ _undef_
+
+2name
+zr
+retired
+ Zaire
+
+2name
+jp
+alpha-2
+not_retired
+other_arg
+ _undef_
+
+2name
+jp
+_blank_
+ Japan
+
+2name
+jp
+alpha-15
+ _undef_
+
+2name
+jp
+alpha-2
+retired
+ Japan
+
+2name
+z0
+alpha-2
+retired
+ _undef_
+
+##################
+# country2code
+
+2code
+kazakhstan
+ kz
+
+2code
+kazakstan
+ kz
+
+2code
+macao
+ mo
+
+2code
+macau
+ mo
+
+2code
+japan
+ jp
+
+2code
+Japan
+ jp
+
+2code
+United States
+ us
+
+2code
+United Kingdom
+ gb
+
+2code
+Andorra
+ ad
+
+2code
+Zimbabwe
+ zw
+
+2code
+Iran
+ ir
+
+2code
+North Korea
+ kp
+
+2code
+South Korea
+ kr
+
+2code
+Libya
+ ly
+
+2code
+Syrian Arab Republic
+ sy
+
+2code
+Svalbard
+ _undef_
+
+2code
+Jan Mayen
+ _undef_
+
+2code
+USA
+ us
+
+2code
+United States of America
+ us
+
+2code
+Great Britain
+ gb
+
+2code
+Burma
+ mm
+
+2code
+French Southern and Antarctic Lands
+ tf
+
+2code
+Aland Islands
+ ax
+
+2code
+Yugoslavia
+ _undef_
+
+2code
+Serbia and Montenegro
+ _undef_
+
+2code
+East Timor
+ tl
+
+2code
+Zaire
+ _undef_
+
+2code
+Zaire
+retired
+ zr
+
+2code
+Congo, The Democratic Republic of the
+ cd
+
+2code
+Congo, The Democratic Republic of the
+alpha-3
+ cod
+
+2code
+Congo, The Democratic Republic of the
+numeric
+ 180
+
+2code
+Syria
+ sy
+
+# Last codes in each set (we'll assume that if we got these, there's a good
+# possiblity that we got all the others).
+
+2code
+Zimbabwe
+alpha-2
+ zw
+
+2code
+Zimbabwe
+alpha-3
+ zwe
+
+2code
+Zimbabwe
+numeric
+ 716
+
+2code
+Zimbabwe
+dom
+ zw
+
+2code
+Zimbabwe
+dom
+ zw
+
+2code
+Zimbabwe
+foo
+ _undef_
+
+2code
+Zipper
+dom
+retired
+ _undef_
+
+##################
+# country_code2code
+
+_code2code
+bo
+alpha-2
+alpha-2
+ bo
+
+_code2code
+bo
+alpha-3
+alpha-3
+ _undef_
+
+_code2code
+zz
+alpha-2
+alpha-3
+ _undef_
+
+_code2code
+zz
+alpha-3
+alpha-3
+ _undef_
+
+_code2code
+zz
+alpha-2
+0
+ _undef_
+
+_code2code
+bo
+alpha-2
+0
+ _undef_
+
+_code2code
+_blank_
+0
+0
+ _undef_
+
+_code2code
+BO
+alpha-2
+alpha-3
+ bol
+
+_code2code
+bol
+alpha-3
+alpha-2
+ bo
+
+_code2code
+zwe
+alpha-3
+alpha-2
+ zw
+
+_code2code
+858
+numeric
+alpha-3
+ ury
+
+_code2code
+858
+numeric
+alpha-3
+ ury
+
+_code2code
+tr
+alpha-2
+numeric
+ 792
+
+_code2code
+tr
+alpha-2
+ _undef_
+
+_code2code
+ _undef_
+
+###################################
+# Test rename_country
+
+2name
+gb
+ United Kingdom of Great Britain and Northern Ireland
+
+rename
+x1
+NewName
+ 0
+
+rename
+gb
+NewName
+foo
+ 0
+
+rename
+gb
+Macao
+ 0
+
+rename
+gb
+NewName
+alpha3
+ 0
+
+2name
+gb
+ United Kingdom of Great Britain and Northern Ireland
+
+rename
+gb
+NewName
+ 1
+
+2name
+gb
+ NewName
+
+2name
+us
+ United States of America
+
+rename
+us
+The United States
+ 1
+
+2name
+us
+ The United States
+
+###################################
+# Test add
+
+2name
+xx
+ _undef_
+
+add
+xx
+Bolivia
+ 0
+
+add
+fi
+Xxxxx
+ 0
+
+add
+xx
+Xxxxx
+ 1
+
+2name
+xx
+ Xxxxx
+
+add
+xx
+Xxxxx
+foo
+ 0
+
+add
+xy
+New Country
+alpha-2
+ 1
+
+add
+xyy
+New Country
+alpha-3
+ 1
+
+###################################
+# Test add_alias
+
+add_alias
+FooBar
+NewName
+ 0
+
+add_alias
+Australia
+Angola
+ 0
+
+2code
+Australia
+ au
+
+2code
+DownUnder
+ _undef_
+
+add_alias
+Australia
+DownUnder
+ 1
+
+2code
+DownUnder
+ au
+
+###################################
+# Test delete_alias
+
+2code
+uk
+ gb
+
+delete_alias
+Foobar
+ 0
+
+delete_alias
+UK
+ 1
+
+2code
+uk
+ _undef_
+
+delete_alias
+Angola
+ 0
+
+# Complicated example
+
+add
+z1
+NameA1
+alpha-2
+ 1
+
+add_alias
+NameA1
+NameA2
+alpha-2
+ 1
+
+add
+zz1
+NameA2
+alpha-3
+ 1
+
+2name
+z1
+ NameA1
+
+2name
+zz1
+alpha-3
+ NameA2
+
+_code2code
+z1
+alpha-2
+alpha-3
+ zz1
+
+delete_alias
+NameA2
+ 1
+
+2name
+z1
+ NameA1
+
+2name
+zz1
+alpha-3
+ NameA1
+
+# Complicated example
+
+add
+z2
+NameB1
+alpha-2
+ 1
+
+add_alias
+NameB1
+NameB2
+alpha-2
+ 1
+
+add
+zz2
+NameB2
+alpha-3
+ 1
+
+2name
+z2
+ NameB1
+
+2name
+zz2
+alpha-3
+ NameB2
+
+_code2code
+z2
+alpha-2
+alpha-3
+ zz2
+
+delete_alias
+NameB1
+ 1
+
+2name
+z2
+ NameB2
+
+2name
+zz2
+alpha-3
+ NameB2
+
+###################################
+# Test delete
+
+2code
+Angola
+ ao
+
+2code
+Angola
+alpha-3
+ ago
+
+delete
+ao
+ 1
+
+2code
+Angola
+ _undef_
+
+2code
+Angola
+alpha-3
+ ago
+
+delete
+ago
+foo
+ 0
+
+delete
+zz
+ 0
+
+###################################
+# Test rename_code
+
+2name
+zz
+ _undef_
+
+2name
+ar
+ Argentina
+
+2code
+Argentina
+ ar
+
+rename_code
+ar
+us
+ 0
+
+rename_code
+ar
+zz
+ 1
+
+rename_code
+us
+ar
+ 0
+
+2name
+zz
+ Argentina
+
+2name
+ar
+ Argentina
+
+2code
+Argentina
+ zz
+
+rename_code
+zz
+ar
+ 1
+
+2name
+zz
+ Argentina
+
+2name
+ar
+ Argentina
+
+2code
+Argentina
+ ar
+
+rename_code
+ar
+z2
+foo
+ 0
+
+rename_code
+ar
+z2
+alpha-3
+ 0
+
+###################################
+# Test add_code_alias and
+# delete_code_alias
+
+2name
+bm
+ Bermuda
+
+2name
+yy
+ _undef_
+
+2code
+Bermuda
+ bm
+
+add_code_alias
+bm
+us
+ 0
+
+add_code_alias
+bm
+zz
+ 0
+
+add_code_alias
+bm
+yy
+ 1
+
+2name
+bm
+ Bermuda
+
+2name
+yy
+ Bermuda
+
+2code
+Bermuda
+ bm
+
+delete_code_alias
+us
+ 0
+
+delete_code_alias
+ww
+ 0
+
+delete_code_alias
+yy
+ 1
+
+2name
+bm
+ Bermuda
+
+2name
+yy
+ _undef_
+
+2code
+Bermuda
+ bm
+
+add_code_alias
+bm
+yy
+ 1
+
+2name
+yy
+ Bermuda
+
+add
+yy
+Foo
+ 0
+
+delete
+bm
+ 1
+
+2name
+bm
+ _undef_
+
+add_code_alias
+bm
+y2
+foo
+ 0
+
+add_code_alias
+bm
+y2
+alpha-3
+ 0
+
+delete_code_alias
+bm
+foo
+ 0
+
+$::generic_tests
+";
+
+1;
+# Local Variables:
+# mode: cperl
+# indent-tabs-mode: nil
+# cperl-indent-level: 3
+# cperl-continued-statement-offset: 2
+# cperl-continued-brace-offset: 0
+# cperl-brace-offset: 0
+# cperl-brace-imaginary-offset: 0
+# cperl-label-offset: 0
+# End:
+
--- /dev/null
+#!/usr/bin/perl
+# Copyright (c) 2016-2016 Sullivan Beck. All rights reserved.
+# This program is free software; you can redistribute it and/or modify it
+# under the same terms as Perl itself.
+
+use warnings;
+use strict;
+
+$::tests = $::generic_tests;
+
+$::tests = "
+
+
+2code
+Canadian Dollar
+ cad
+
+2code
+Belize Dollar
+ bzd
+
+2code
+PULA
+ bwp
+
+2code
+Riel
+ khr
+
+2code
+Zimbabwe Dollar
+ zwl
+
+2name
+KHR
+ Riel
+
+_code2code
+BZD
+alpha
+num
+ 084
+
+2name
+BOB
+ Boliviano
+
+2name
+all
+ Lek
+
+2name
+bnd
+ Brunei Dollar
+
+2name
+bob
+ Boliviano
+
+2name
+byr
+ Belarusian Ruble
+
+2name
+chf
+ Swiss Franc
+
+2name
+cop
+ Colombian Peso
+
+2name
+dkk
+ Danish Krone
+
+2name
+fjd
+ Fiji Dollar
+
+2name
+idr
+ Rupiah
+
+2name
+mmk
+ Kyat
+
+2name
+mvr
+ Rufiyaa
+
+2name
+mwk
+ Malawi Kwacha
+
+2name
+rub
+ Russian Ruble
+
+2name
+zmw
+ Zambian Kwacha
+
+2name
+zwl
+ Zimbabwe Dollar
+
+all_codes
+2
+ ~
+ AED
+ AFN
+
+all_names
+2
+ ~
+ ADB Unit of Account
+ Afghani
+
+$::generic_tests
+";
+
+1;
+# Local Variables:
+# mode: cperl
+# indent-tabs-mode: nil
+# cperl-indent-level: 3
+# cperl-continued-statement-offset: 2
+# cperl-continued-brace-offset: 0
+# cperl-brace-offset: 0
+# cperl-brace-imaginary-offset: 0
+# cperl-label-offset: 0
+# End:
+
--- /dev/null
+#!/usr/bin/perl
+# Copyright (c) 2016-2016 Sullivan Beck. All rights reserved.
+# This program is free software; you can redistribute it and/or modify it
+# under the same terms as Perl itself.
+
+use warnings;
+use strict;
+
+$::tests = $::generic_tests;
+
+$::tests = "
+
+2code
+Mesopotamian Arabic
+ acm
+
+2name
+acm
+ Mesopotamian Arabic
+
+_code2code
+ACM
+alpha
+alpha
+ acm
+
+all_codes
+2
+ ~
+ aao
+ abh
+
+all_names
+2
+ ~
+ Adamorobe Sign Language
+ Afghan Sign Language
+
+$::generic_tests
+";
+
+1;
+# Local Variables:
+# mode: cperl
+# indent-tabs-mode: nil
+# cperl-indent-level: 3
+# cperl-continued-statement-offset: 2
+# cperl-continued-brace-offset: 0
+# cperl-brace-offset: 0
+# cperl-brace-imaginary-offset: 0
+# cperl-label-offset: 0
+# End:
+
--- /dev/null
+#!/usr/bin/perl
+# Copyright (c) 2016-2016 Sullivan Beck. All rights reserved.
+# This program is free software; you can redistribute it and/or modify it
+# under the same terms as Perl itself.
+
+use warnings;
+use strict;
+
+$::tests = $::generic_tests;
+
+$::tests = "
+
+2code
+Apache languages
+ ~
+ apa
+
+2name
+apa
+ Apache languages
+
+_code2code
+apa
+alpha
+alpha
+ apa
+
+all_codes
+2
+ ~
+ aav
+ afa
+
+all_names
+2
+ ~
+ Afro-Asiatic languages
+ Alacalufan languages
+
+$::generic_tests
+";
+
+1;
+# Local Variables:
+# mode: cperl
+# indent-tabs-mode: nil
+# cperl-indent-level: 3
+# cperl-continued-statement-offset: 2
+# cperl-continued-brace-offset: 0
+# cperl-brace-offset: 0
+# cperl-brace-imaginary-offset: 0
+# cperl-label-offset: 0
+# End:
+
--- /dev/null
+#!/usr/bin/perl
+# Copyright (c) 2016-2016 Sullivan Beck. All rights reserved.
+# This program is free software; you can redistribute it and/or modify it
+# under the same terms as Perl itself.
+
+use warnings;
+use strict;
+
+$::tests = $::generic_tests;
+
+$::tests = "
+
+all_names
+2
+ ~
+ Abkhazian
+ Afar
+
+all_codes
+2
+ ~
+ aa
+ ab
+
+2name
+zu
+ Zulu
+
+rename
+zu
+NewName
+foo
+ 0
+
+rename
+zu
+English
+alpha-2
+ 0
+
+rename
+zu
+NewName
+alpha-3
+ 0
+
+2name
+zu
+ Zulu
+
+rename
+zu
+NewName
+alpha-2
+ 1
+
+2name
+zu
+ NewName
+
+2code
+Afar
+ aa
+
+2code
+ESTONIAN
+ et
+
+2code
+French
+ fr
+
+2code
+Greek
+ el
+
+2code
+Japanese
+ ja
+
+2code
+Zulu
+ zu
+
+2code
+english
+ en
+
+2code
+japanese
+ ja
+
+# Last ones in the list
+
+2code
+Zulu
+alpha-2
+ zu
+
+2code
+Zaza
+alpha-3
+ zza
+
+2code
+Welsh
+term
+ cym
+
+2code
+Zande languages
+alpha-3
+ znd
+
+2code
+Zuojiang Zhuang
+alpha-3
+ zzj
+
+2name
+in
+ _undef_
+
+2name
+iw
+ _undef_
+
+2name
+ji
+ _undef_
+
+2name
+jp
+ _undef_
+
+2name
+zz
+ _undef_
+
+2name
+DA
+ Danish
+
+2name
+aa
+ Afar
+
+2name
+ae
+ Avestan
+
+2name
+bs
+ Bosnian
+
+2name
+ce
+ Chechen
+
+2name
+ch
+ Chamorro
+
+2name
+cu
+ Church Slavic
+
+2name
+cv
+ Chuvash
+
+2name
+en
+ English
+
+2name
+eo
+ Esperanto
+
+2name
+fi
+ Finnish
+
+2name
+gv
+ Manx
+
+2name
+he
+ Hebrew
+
+2name
+ho
+ Hiri Motu
+
+2name
+hz
+ Herero
+
+2name
+id
+ Indonesian
+
+2name
+iu
+ Inuktitut
+
+2name
+ki
+ Kikuyu
+
+2name
+kj
+ Kuanyama
+
+2name
+kv
+ Komi
+
+2name
+kw
+ Cornish
+
+2name
+lb
+ Luxembourgish
+
+2name
+mh
+ Marshallese
+
+2name
+nb
+ Norwegian Bokmal
+
+2name
+nd
+ North Ndebele
+
+2name
+ng
+ Ndonga
+
+2name
+nn
+ Norwegian Nynorsk
+
+2name
+nr
+ South Ndebele
+
+2name
+nv
+ Navajo
+
+2name
+ny
+ Nyanja
+
+2name
+oc
+ Occitan (post 1500)
+
+2name
+os
+ Ossetian
+
+2name
+pi
+ Pali
+
+2name
+sc
+ Sardinian
+
+2name
+se
+ Northern Sami
+
+2name
+ug
+ Uighur
+
+2name
+yi
+ Yiddish
+
+2name
+za
+ Zhuang
+
+_code2code
+zu
+alpha-2
+alpha-3
+ zul
+
+
+$::generic_tests
+";
+
+1;
+# Local Variables:
+# mode: cperl
+# indent-tabs-mode: nil
+# cperl-indent-level: 3
+# cperl-continued-statement-offset: 2
+# cperl-continued-brace-offset: 0
+# cperl-brace-offset: 0
+# cperl-brace-imaginary-offset: 0
+# cperl-label-offset: 0
+# End:
+
--- /dev/null
+#!/usr/bin/perl
+# Copyright (c) 2016-2016 Sullivan Beck. All rights reserved.
+# This program is free software; you can redistribute it and/or modify it
+# under the same terms as Perl itself.
+
+use warnings;
+use strict;
+
+$::tests = $::generic_tests;
+
+$::tests = "
+
+2code
+Eastern Armenian
+ arevela
+
+2name
+arevela
+ Eastern Armenian
+
+_code2code
+arevela
+alpha
+alpha
+ arevela
+
+all_codes
+2
+ ~
+ 1606nict
+ 1694acad
+
+all_names
+2
+ ~
+ \"Academic\" (\"governmental\") variant of Belarusian as codified in 1959
+ ALA-LC Romanization, 1997 edition
+
+$::generic_tests
+";
+
+1;
+# Local Variables:
+# mode: cperl
+# indent-tabs-mode: nil
+# cperl-indent-level: 3
+# cperl-continued-statement-offset: 2
+# cperl-continued-brace-offset: 0
+# cperl-brace-offset: 0
+# cperl-brace-imaginary-offset: 0
+# cperl-label-offset: 0
+# End:
+
--- /dev/null
+#!/usr/bin/perl
+# Copyright (c) 2016-2016 Sullivan Beck. All rights reserved.
+# This program is free software; you can redistribute it and/or modify it
+# under the same terms as Perl itself.
+
+use warnings;
+use strict;
+
+$::tests = $::generic_tests;
+
+$::tests = "
+
+2code
+Phoenician
+ phnx
+
+2code
+Phoenician
+num
+ 115
+
+2name
+Phnx
+ Phoenician
+
+2name
+phnx
+ Phoenician
+
+2name
+115
+num
+ Phoenician
+
+_code2code
+Phnx
+alpha
+num
+ 115
+
+all_codes
+2
+ ~
+ Adlm
+ Afak
+
+all_names
+2
+ ~
+ Adlam
+ Afaka
+
+
+$::generic_tests
+";
+
+1;
+# Local Variables:
+# mode: cperl
+# indent-tabs-mode: nil
+# cperl-indent-level: 3
+# cperl-continued-statement-offset: 2
+# cperl-continued-brace-offset: 0
+# cperl-brace-offset: 0
+# cperl-brace-imaginary-offset: 0
+# cperl-label-offset: 0
+# End:
+
# -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*-
-# vim:ts=8:sw=2:et:sta:sts=2
-package Module::Metadata; # git description: v1.000030-2-g52f466c
+# vim:ts=8:sw=2:et:sta:sts=2:tw=78
+package Module::Metadata; # git description: v1.000031-13-g7c061c9
# ABSTRACT: Gather package and POD information from perl module files
# Adapted from Perl-licensed code originally distributed with
use strict;
use warnings;
-our $VERSION = '1.000031'; # TRIAL
+our $VERSION = '1.000032'; # TRIAL
use Carp qw/croak/;
use File::Spec;
}
$self->_parse_fh($handle);
+ @{$self->{packages}} = __uniq(@{$self->{packages}});
+
unless($self->{module} and length($self->{module})) {
- my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
- if($f =~ /\.pm$/) {
+ # CAVEAT (possible TODO): .pmc files not treated the same as .pm
+ if ($self->{filename} =~ /\.pm$/) {
+ my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
$f =~ s/\..+$//;
- my @candidates = grep /$f$/, @{$self->{packages}};
- $self->{module} = shift(@candidates); # punt
+ my @candidates = grep /(^|::)$f$/, @{$self->{packages}};
+ $self->{module} = shift(@candidates); # this may be undef
}
else {
- $self->{module} = 'main';
+ # this seems like an atrocious heuristic, albeit marginally better than
+ # what was here before. It should be rewritten entirely to be more like
+ # "if it's not a .pm file, it's not require()able as a name, therefore
+ # name() should be undef."
+ if ((grep /main/, @{$self->{packages}})
+ or (grep /main/, keys %{$self->{versions}})) {
+ $self->{module} = 'main';
+ }
+ else {
+ # TODO: this should maybe default to undef instead
+ $self->{module} = $self->{packages}[0] || '';
+ }
}
}
my $testfile = File::Spec->catfile($dir, $file);
return [ File::Spec->rel2abs( $testfile ), $dir ]
if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp
+ # CAVEAT (possible TODO): .pmc files are not discoverable here
$testfile .= '.pm';
return [ File::Spec->rel2abs( $testfile ), $dir ]
if -e $testfile;
$self->{pod_headings} = \@pod;
}
+sub __uniq (@)
+{
+ my (%seen, $key);
+ grep { not $seen{ $key = $_ }++ } @_;
+}
+
{
my $pn = 0;
sub _evaluate_version_line {
=head1 VERSION
-version 1.000031
+version 1.000032
=head1 SYNOPSIS
L<http://lists.perl.org/list/cpan-workers.html>.
There is also an irc channel available for users of this distribution, at
-L<irc://irc.perl.org/#toolchain>.
+L<C<#toolchain> on C<irc.perl.org>|irc://irc.perl.org/#toolchain>.
=head1 AUTHOR
$Foo::Bar::VERSION = '1.23';
---
},
+{
+ name => 'script 7 from t/metadata.t', # TODO merge these
+ package => [ '_private', 'main' ],
+ TODO => '$::VERSION indicates main namespace is referenced',
+ code => <<'---',
+package _private;
+$::VERSION = 0.01;
+$VERSION = '999';
+---
+},
+{
+ name => 'script 8 from t/metadata.t', # TODO merge these
+ package => [ '_private', 'main' ],
+ TODO => '$::VERSION indicates main namespace is referenced',
+ code => <<'---',
+package _private;
+$VERSION = '999';
+$::VERSION = 0.01;
+---
+},
);
my $test_num = 0;
note $test_case->{name};
my $code = $test_case->{code};
my $expected_name = $test_case->{package};
- local $TODO = $test_case->{TODO};
my $warnings = '';
local $SIG{__WARN__} = sub { $warnings .= $_ for @_ };
# Test::Builder will prematurely numify objects, so use this form
my $errs;
my @got = $pm_info->packages_inside();
+ {
+ local $TODO = $test_case->{TODO};
is_deeply( \@got, $expected_name,
"case $test_case->{name}: correct package names (expected '" . join(', ', @$expected_name) . "')" )
or $errs++;
+ }
is( $warnings, '', "case $test_case->{name}: no warnings from parsing" ) or $errs++;
- diag "Got: '" . join(', ', @got) . "'\nModule contents:\n$code" if $errs;
+ diag "Got: '" . join(', ', @got) . "'\nModule contents:\n$code" if !$ENV{PERL_CORE} && $errs;
}
continue {
++$test_num;
# vim:ts=8:sw=2:et:sta:sts=2
use Test::More 0.82;
-use Data::Dumper;
use Module::Metadata;
use lib 't/lib';
vers => undef,
all_versions => { 'Foo::Bar' => '1.23' },
},
+{
+ name => 'package statement that does not quite match the filename',
+ filename => 'Simple.pm',
+ code => <<'---',
+package ThisIsNotSimple;
+our $VERSION = '1.23';
+---
+ vers => $undef,
+ all_versions => { 'ThisIsNotSimple' => '1.23' },
+},
);
my $test_num = 0;
# We want to ensure we preserve the original, as long as it's legal, so we
# explicitly check the stringified form.
{
- local $TODO = $test_case->{TODO_got_version};
- isa_ok($got, 'version') if defined $expected_version;
+ local $TODO = !defined($got) && ($test_case->{TODO_code_sub} || $test_case->{TODO_scalar});
+ isa_ok($got, 'version') or $errs++ if defined $expected_version;
}
if (ref($expected_version) eq 'CODE') {
ok(
$test_case->{all_versions}->($pm_info->{versions}),
"case '$test_case->{name}': all extracted versions passes match sub"
- );
+ ) or $errs++;
}
else {
is_deeply(
$pm_info->{versions},
$test_case->{all_versions},
'correctly found all $VERSIONs',
- );
+ ) or $errs++;
}
}
is( $warnings, '', "case '$test_case->{name}': no warnings from parsing" ) or $errs++;
- diag 'extracted versions: ', explain({ got => $pm_info->{versions}, module_contents => $code }) if !$ENV{PERL_CORE} && $errs;
+ diag 'parsed module: ', explain($pm_info) if !$ENV{PERL_CORE} && $errs;
}
}
continue {
use File::Basename;
use Cwd ();
use File::Path;
-use Data::Dumper;
-plan tests => 61;
+plan tests => 70;
require_ok('Module::Metadata');
my ( $i, $n ) = ( 1, scalar( @scripts ) );
foreach my $script ( @scripts ) {
+ note '-------';
+ my $errs;
my $file = File::Spec->catfile('bin', 'simple.plx');
my ($dist_name, $dist_dir) = new_dist(files => { $file => $script } );
my $pm_info = Module::Metadata->new_from_file( $file );
- is( $pm_info->version, '0.01', "correct script version ($i of $n)" );
+ is( $pm_info->name, 'main', 'name for script is always main');
+ is( $pm_info->version, '0.01', "correct script version ($i of $n)" ) or $errs++;
$i++;
+
+ diag 'parsed module: ', explain($pm_info) if !$ENV{PERL_CORE} && $errs;
}
{
is( $pm_info->version, '1.23', 'version for default package' );
}
+my $tmpdir = GeneratePackage::tmpdir();
+my $undef;
+my $test_num = 0;
+use lib 't/lib';
+use GeneratePackage;
+
+{
+ # and now a real pod file
+ # (this test case is ready to be rolled into a corpus loop, later)
+ my $test_case = {
+ name => 'file only contains pod',
+ filename => 'Simple/Documentation.pod',
+ code => <<'---',
+# PODNAME: Simple::Documentation
+# ABSTRACT: My documentation
+
+=pod
+
+Hello, this is pod.
+
+=cut
+---
+ module => '', # TODO: should probably be $undef actually
+ all_versions => { },
+ };
+
+ note $test_case->{name};
+ my $code = $test_case->{code};
+ my $expected_name = $test_case->{module};
+ local $TODO = $test_case->{TODO};
+
+ my $errs;
+
+ my ($vol, $dir, $basename) = File::Spec->splitpath(File::Spec->catdir($tmpdir, "Simple${test_num}", ($test_case->{filename} || 'Simple.pm')));
+ my $pm_info = Module::Metadata->new_from_file(generate_file($dir, $basename, $code));
+
+ my $got_name = $pm_info->name;
+ is(
+ $got_name,
+ $expected_name,
+ "case '$test_case->{name}': module name matches",
+ )
+ or $errs++;
+
+ diag 'parsed module: ', explain($pm_info) if !$ENV{PERL_CORE} && $errs;
+}
+
{
# Make sure processing stops after __DATA__
my $file = File::Spec->catfile('lib', 'Simple.pm');
# include "multicall.h"
#endif
+#if PERL_BCDVERSION < 0x5023008
+# define UNUSED_VAR_newsp PERL_UNUSED_VAR(newsp)
+#else
+# define UNUSED_VAR_newsp NOOP
+#endif
+
#ifndef CvISXSUB
# define CvISXSUB(cv) CvXSUB(cv)
#endif
# define croak_no_modify() croak("%s", PL_no_modify)
#endif
+#ifndef SvNV_nomg
+# define SvNV_nomg SvNV
+#endif
+
enum slu_accum {
ACC_IV,
ACC_NV,
CODE:
{
int index;
- NV retval;
+ NV retval = 0.0; /* avoid 'uninit var' warning */
SV *retsv;
int magic;
break;
case ACC_IV:
if(is_product) {
- if(retiv == 0 ||
- (!SvNOK(sv) && SvIOK(sv) && (SvIV(sv) < IV_MAX / retiv))) {
- retiv *= SvIV(sv);
- break;
+ /* TODO: Consider if product() should shortcircuit the moment its
+ * accumulator becomes zero
+ */
+ /* XXX testing flags before running get_magic may
+ * cause some valid tied values to fallback to the NV path
+ * - DAPM */
+ if(!SvNOK(sv) && SvIOK(sv)) {
+ IV i = SvIV(sv);
+ if (retiv == 0) /* avoid later division by zero */
+ break;
+ if (retiv < 0) {
+ if (i < 0) {
+ if (i >= IV_MAX / retiv) {
+ retiv *= i;
+ break;
+ }
+ }
+ else {
+ if (i <= IV_MIN / retiv) {
+ retiv *= i;
+ break;
+ }
+ }
+ }
+ else {
+ if (i < 0) {
+ if (i >= IV_MIN / retiv) {
+ retiv *= i;
+ break;
+ }
+ }
+ else {
+ if (i <= IV_MAX / retiv) {
+ retiv *= i;
+ break;
+ }
+ }
+ }
}
/* else fallthrough */
}
else {
- if(!SvNOK(sv) && SvIOK(sv) && (SvIV(sv) < IV_MAX - retiv)) {
- retiv += SvIV(sv);
- break;
+ /* XXX testing flags before running get_magic may
+ * cause some valid tied values to fallback to the NV path
+ * - DAPM */
+ if(!SvNOK(sv) && SvIOK(sv)) {
+ IV i = SvIV(sv);
+ if (retiv >= 0 && i >= 0) {
+ if (retiv <= IV_MAX - i) {
+ retiv += i;
+ break;
+ }
+ /* else fallthrough */
+ }
+ else if (retiv < 0 && i < 0) {
+ if (retiv >= IV_MIN - i) {
+ retiv += i;
+ break;
+ }
+ /* else fallthrough */
+ }
+ else {
+ /* mixed signs can't overflow */
+ retiv += i;
+ break;
+ }
}
/* else fallthrough */
}
dMULTICALL;
I32 gimme = G_SCALAR;
+ UNUSED_VAR_newsp;
PUSH_MULTICALL(cv);
for(index = 2 ; index < items ; index++) {
GvSV(bgv) = args[index];
if(!CvISXSUB(cv)) {
dMULTICALL;
I32 gimme = G_SCALAR;
+
+ UNUSED_VAR_newsp;
PUSH_MULTICALL(cv);
for(index = 1 ; index < items ; index++) {
- GvSV(PL_defgv) = args[index];
+ SV *def_sv = GvSV(PL_defgv) = args[index];
+# ifdef SvTEMP_off
+ SvTEMP_off(def_sv);
+# endif
MULTICALL;
if(SvTRUEx(*PL_stack_sp)) {
# ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT
I32 gimme = G_SCALAR;
int index;
+ UNUSED_VAR_newsp;
PUSH_MULTICALL(cv);
for(index = 1; index < items; index++) {
- GvSV(PL_defgv) = args[index];
+ SV *def_sv = GvSV(PL_defgv) = args[index];
+# ifdef SvTEMP_off
+ SvTEMP_off(def_sv);
+# endif
MULTICALL;
if(SvTRUEx(*PL_stack_sp) ^ invert) {
if(SvTYPE(SvRV(pair)) != SVt_PVAV)
croak("Not an ARRAY reference at List::Util::unpack() argument %d", i);
- // TODO: assert pair is an ARRAY ref
+ /* TODO: assert pair is an ARRAY ref */
pairav = (AV *)SvRV(pair);
EXTEND(SP, 2);
dMULTICALL;
I32 gimme = G_SCALAR;
+ UNUSED_VAR_newsp;
PUSH_MULTICALL(cv);
for(; argi < items; argi += 2) {
SV *a = GvSV(agv) = stack[argi];
dMULTICALL;
I32 gimme = G_SCALAR;
+ UNUSED_VAR_newsp;
PUSH_MULTICALL(cv);
for(; argi < items; argi += 2) {
SV *a = GvSV(agv) = stack[argi];
dMULTICALL;
I32 gimme = G_ARRAY;
+ UNUSED_VAR_newsp;
PUSH_MULTICALL(cv);
for(; argi < items; argi += 2) {
- SV *a = GvSV(agv) = args_copy ? args_copy[argi] : stack[argi];
- SV *b = GvSV(bgv) = argi < items-1 ?
+ int count;
+
+ GvSV(agv) = args_copy ? args_copy[argi] : stack[argi];
+ GvSV(bgv) = argi < items-1 ?
(args_copy ? args_copy[argi+1] : stack[argi+1]) :
&PL_sv_undef;
- int count;
MULTICALL;
count = PL_stack_sp - PL_stack_base;
{
for(; argi < items; argi += 2) {
dSP;
- SV *a = GvSV(agv) = args_copy ? args_copy[argi] : ST(argi);
- SV *b = GvSV(bgv) = argi < items-1 ?
- (args_copy ? args_copy[argi+1] : ST(argi+1)) :
- &PL_sv_undef;
int count;
int i;
+ GvSV(agv) = args_copy ? args_copy[argi] : ST(argi);
+ GvSV(bgv) = argi < items-1 ?
+ (args_copy ? args_copy[argi+1] : ST(argi+1)) :
+ &PL_sv_undef;
+
PUSHMARK(SP);
count = call_sv((SV*)cv, G_ARRAY);
}
+void
+uniq(...)
+PROTOTYPE: @
+ALIAS:
+ uniqnum = 0
+ uniqstr = 1
+ uniq = 2
+CODE:
+{
+ int retcount = 0;
+ int index;
+ SV **args = &PL_stack_base[ax];
+ HV *seen;
+
+ if(items == 0 || (items == 1 && !SvGAMAGIC(args[0]) && SvOK(args[0]))) {
+ /* Optimise for the case of the empty list or a defined nonmagic
+ * singleton. Leave a singleton magical||undef for the regular case */
+ retcount = items;
+ goto finish;
+ }
+
+ sv_2mortal((SV *)(seen = newHV()));
+
+ if(ix == 0) {
+ /* uniqnum */
+ /* A temporary buffer for number stringification */
+ SV *keysv = sv_newmortal();
+
+ for(index = 0 ; index < items ; index++) {
+ SV *arg = args[index];
+#ifdef HV_FETCH_EMPTY_HE
+ HE* he;
+#endif
+
+ if(SvGAMAGIC(arg))
+ /* clone the value so we don't invoke magic again */
+ arg = sv_mortalcopy(arg);
+
+ if(SvUOK(arg))
+ sv_setpvf(keysv, "%"UVuf, SvUV(arg));
+ else if(SvIOK(arg))
+ sv_setpvf(keysv, "%"IVdf, SvIV(arg));
+ else
+ sv_setpvf(keysv, "%"NVgf, SvNV(arg));
+#ifdef HV_FETCH_EMPTY_HE
+ he = (HE*) hv_common(seen, NULL, SvPVX(keysv), SvCUR(keysv), 0, HV_FETCH_LVALUE | HV_FETCH_EMPTY_HE, NULL, 0);
+ if (HeVAL(he))
+ continue;
+
+ HeVAL(he) = &PL_sv_undef;
+#else
+ if(hv_exists(seen, SvPVX(keysv), SvCUR(keysv)))
+ continue;
+
+ hv_store(seen, SvPVX(keysv), SvCUR(keysv), &PL_sv_undef, 0);
+#endif
+
+ if(GIMME_V == G_ARRAY)
+ ST(retcount) = SvOK(arg) ? arg : sv_2mortal(newSViv(0));
+ retcount++;
+ }
+ }
+ else {
+ /* uniqstr or uniq */
+ int seen_undef = 0;
+
+ for(index = 0 ; index < items ; index++) {
+ SV *arg = args[index];
+#ifdef HV_FETCH_EMPTY_HE
+ HE *he;
+#endif
+
+ if(SvGAMAGIC(arg))
+ /* clone the value so we don't invoke magic again */
+ arg = sv_mortalcopy(arg);
+
+ if(ix == 2 && !SvOK(arg)) {
+ /* special handling of undef for uniq() */
+ if(seen_undef)
+ continue;
+
+ seen_undef++;
+
+ if(GIMME_V == G_ARRAY)
+ ST(retcount) = arg;
+ retcount++;
+ continue;
+ }
+#ifdef HV_FETCH_EMPTY_HE
+ he = (HE*) hv_common(seen, arg, NULL, 0, 0, HV_FETCH_LVALUE | HV_FETCH_EMPTY_HE, NULL, 0);
+ if (HeVAL(he))
+ continue;
+
+ HeVAL(he) = &PL_sv_undef;
+#else
+ if (hv_exists_ent(seen, arg, 0))
+ continue;
+
+ hv_store_ent(seen, arg, &PL_sv_undef, 0);
+#endif
+
+ if(GIMME_V == G_ARRAY)
+ ST(retcount) = SvOK(arg) ? arg : sv_2mortal(newSVpvn("", 0));
+ retcount++;
+ }
+ }
+
+ finish:
+ if(GIMME_V == G_ARRAY)
+ XSRETURN(retcount);
+ else
+ ST(0) = sv_2mortal(newSViv(retcount));
+}
+
MODULE=List::Util PACKAGE=Scalar::Util
void
( $PERL_CORE
? ()
: (
- INSTALLDIRS => ($] < 5.011 ? q[perl] : q[site]),
- PREREQ_PM => {'Test::More' => 0,},
+ INSTALLDIRS => ($] < 5.011 ? q[perl] : q[site]),
+ PREREQ_PM => {'Test::More' => 0,},
(eval { ExtUtils::MakeMaker->VERSION(6.31) } ? (LICENSE => 'perl') : ()),
+ (eval { ExtUtils::MakeMaker->VERSION(6.48) } ? (MIN_PERL_VERSION => '5.006') : ()),
( eval { ExtUtils::MakeMaker->VERSION(6.46) } ? (
META_MERGE => {
+ 'meta-spec' => { version => 2 },
+ dynamic_config => 0,
resources => { ##
- repository => 'https://github.com/Scalar-List-Utils/Scalar-List-Utils',
+ repository => {
+ url => 'https://github.com/Scalar-List-Utils/Scalar-List-Utils.git',
+ web => 'https://github.com/Scalar-List-Utils/Scalar-List-Utils',
+ type => 'git',
+ },
+ bugtracker => {
+ mailto => 'bug-Scalar-List-Utils@rt.cpan.org',
+ web => 'https://rt.cpan.org/Public/Dist/Display.html?Name=Scalar-List-Utils',
+ },
},
}
)
package List::Util;
use strict;
+use warnings;
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(
- all any first min max minstr maxstr none notall product reduce sum sum0 shuffle
+ all any first min max minstr maxstr none notall product reduce sum sum0 shuffle uniq uniqnum uniqstr
pairs unpairs pairkeys pairvalues pairmap pairgrep pairfirst
);
-our $VERSION = "1.42_02";
+our $VERSION = "1.45_01";
our $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
sub List::Util::_Pair::key { shift->[0] }
sub List::Util::_Pair::value { shift->[1] }
-1;
-
-__END__
-
=head1 NAME
List::Util - A selection of general-utility list subroutines
=head1 SYNOPSIS
- use List::Util qw(first max maxstr min minstr reduce shuffle sum);
+ use List::Util qw(
+ reduce any all none notall first
+
+ max maxstr min minstr product sum sum0
+
+ pairs pairkeys pairvalues pairfirst pairgrep pairmap
+
+ shuffle uniqnum uniqstr
+ );
=head1 DESCRIPTION
=cut
-=head2 $result = reduce { BLOCK } @list
+=head2 reduce
+
+ $result = reduce { BLOCK } @list
Reduces C<@list> by calling C<BLOCK> in a scalar context multiple times,
setting C<$a> and C<$b> each time. The first call will be with C<$a> and C<$b>
$foo = reduce { $a + $b } 0, @values; # sum with 0 identity value
+The above example code blocks also suggest how to use C<reduce> to build a
+more efficient combined version of one of these basic functions and a C<map>
+block. For example, to find the total length of the all the strings in a list,
+we could use
+
+ $total = sum map { length } @strings;
+
+However, this produces a list of temporary integer values as long as the
+original list of strings, only to reduce it down to a single value again. We
+can compute the same result more efficiently by using C<reduce> with a code
+block that accumulates lengths by writing this instead as:
+
+ $total = reduce { $a + length $b } 0, @strings
+
The remaining list-reduction functions are all specialisations of this generic
idea.
I<Since version 1.29.>
A convenient shortcut to operating on even-sized lists of pairs, this function
-returns a list of ARRAY references, each containing two items from the given
-list. It is a more efficient version of
+returns a list of C<ARRAY> references, each containing two items from the
+given list. It is a more efficient version of
@pairs = pairmap { [ $a, $b ] } @kvlist
It is most convenient to use in a C<foreach> loop, for example:
- foreach my $pair ( pairs @KVLIST ) {
+ foreach my $pair ( pairs @kvlist ) {
my ( $key, $value ) = @$pair;
...
}
-Since version C<1.39> these ARRAY references are blessed objects, recognising
-the two methods C<key> and C<value>. The following code is equivalent:
+Since version C<1.39> these C<ARRAY> references are blessed objects,
+recognising the two methods C<key> and C<value>. The following code is
+equivalent:
- foreach my $pair ( pairs @KVLIST ) {
+ foreach my $pair ( pairs @kvlist ) {
my $key = $pair->key;
my $value = $pair->value;
...
I<Since version 1.42.>
-The inverse function to C<pairs>; this function takes a list of ARRAY
+The inverse function to C<pairs>; this function takes a list of C<ARRAY>
references containing two elements each, and returns a flattened list of the
two values from each of the pairs, in order. This is notionally equivalent to
@cards = shuffle 0..51 # 0..51 in a random order
+=head2 uniq
+
+ my @subset = uniq @values
+
+I<Since version 1.45.>
+
+Filters a list of values to remove subsequent duplicates, as judged by a
+DWIM-ish string equality or C<undef> test. Preserves the order of unique
+elements, and retains the first value of any duplicate set.
+
+ my $count = uniq @values
+
+In scalar context, returns the number of elements that would have been
+returned as a list.
+
+The C<undef> value is treated by this function as distinct from the empty
+string, and no warning will be produced. It is left as-is in the returned
+list. Subsequent C<undef> values are still considered identical to the first,
+and will be removed.
+
+=head2 uniqnum
+
+ my @subset = uniqnum @values
+
+I<Since version 1.44.>
+
+Filters a list of values to remove subsequent duplicates, as judged by a
+numerical equality test. Preserves the order of unique elements, and retains
+the first value of any duplicate set.
+
+ my $count = uniqnum @values
+
+In scalar context, returns the number of elements that would have been
+returned as a list.
+
+Note that C<undef> is treated much as other numerical operations treat it; it
+compares equal to zero but additionally produces a warning if such warnings
+are enabled (C<use warnings 'uninitialized';>). In addition, an C<undef> in
+the returned list is coerced into a numerical zero, so that the entire list of
+values returned by C<uniqnum> are well-behaved as numbers.
+
+=head2 uniqstr
+
+ my @subset = uniqstr @values
+
+I<Since version 1.45.>
+
+Filters a list of values to remove subsequent duplicates, as judged by a
+string equality test. Preserves the order of unique elements, and retains the
+first value of any duplicate set.
+
+ my $count = uniqstr @values
+
+In scalar context, returns the number of elements that would have been
+returned as a list.
+
+Note that C<undef> is treated much as other string operations treat it; it
+compares equal to the empty string but additionally produces a warning if such
+warnings are enabled (C<use warnings 'uninitialized';>). In addition, an
+C<undef> in the returned list is coerced into an empty string, so that the
+entire list of values returned by C<uniqstr> are well-behaved as strings.
+
=cut
=head1 KNOWN BUGS
block's execution will take their individual values for each invocation, as
normal.
+=head2 uniqnum() on oversized bignums
+
+Due to the way that C<uniqnum()> compares numbers, it cannot distinguish
+differences between bignums (especially bigints) that are too large to fit in
+the native platform types. For example,
+
+ my $x = Math::BigInt->new( "1" x 100 );
+ my $y = $x + 1;
+
+ say for uniqnum( $x, $y );
+
+Will print just the value of C<$x>, believing that C<$y> is a numerically-
+equivalent value. This bug does not affect C<uniqstr()>, which will correctly
+observe that the two values stringify to different strings.
+
=head1 SUGGESTED ADDITIONS
The following are additions that have been requested, but I have been reluctant
Paul Evans, <leonerd@leonerd.org.uk>.
=cut
+
+1;
package List::Util::XS;
use strict;
+use warnings;
use List::Util;
-our $VERSION = "1.42_02"; # FIXUP
+our $VERSION = "1.45_01"; # FIXUP
$VERSION = eval $VERSION; # FIXUP
1;
package Scalar::Util;
use strict;
+use warnings;
require Exporter;
our @ISA = qw(Exporter);
dualvar isdual isvstring looks_like_number openhandle readonly set_prototype
tainted
);
-our $VERSION = "1.42_02";
+our $VERSION = "1.45_01";
$VERSION = eval $VERSION;
require List::Util; # List::Util loads the XS
C<Scalar::Util> contains a selection of subroutines that people have expressed
would be nice to have in the perl core, but the usage would not really be high
-enough to warrant the use of a keyword, and the size so small such that being
-individual extensions would be wasteful.
+enough to warrant the use of a keyword, and the size would be so small that
+being individual extensions would be wasteful.
By default C<Scalar::Util> does not export any subroutines.
my $pkg = blessed( $ref );
-If C<$ref> is a blessed reference the name of the package that it is blessed
+If C<$ref> is a blessed reference, the name of the package that it is blessed
into is returned. Otherwise C<undef> is returned.
$scalar = "foo";
my $addr = refaddr( $ref );
-If C<$ref> is reference the internal memory address of the referenced value is
+If C<$ref> is reference, the internal memory address of the referenced value is
returned as a plain integer. Otherwise C<undef> is returned.
$addr = refaddr "string"; # undef
my $type = reftype( $ref );
-If C<$ref> is a reference the basic Perl type of the variable referenced is
+If C<$ref> is a reference, the basic Perl type of the variable referenced is
returned as a plain string (such as C<ARRAY> or C<HASH>). Otherwise C<undef>
is returned.
weaken( $ref );
The lvalue C<$ref> will be turned into a weak reference. This means that it
-will not hold a reference count on the object it references. Also when the
+will not hold a reference count on the object it references. Also, when the
reference count on that object reaches zero, the reference will be set to
undef. This function mutates the lvalue passed as its argument and returns no
value.
$bar = $foo + 0;
$dual = isdual($foo); # true
-Note that although C<$!> appears to be dual-valued variable, it is actually
-implemented using a tied scalar:
+Note that although C<$!> appears to be a dual-valued variable, it is
+actually implemented as a magical variable inside the interpreter:
$! = 1;
print("$!\n"); # "Operation not permitted"
my $vstring = isvstring( $var );
-If C<$var> is a scalar which was coded as a vstring the result is true.
+If C<$var> is a scalar which was coded as a vstring, the result is true.
$vs = v49.46.48;
$fmt = isvstring($vs) ? "%vd" : "%s"; #true
The version of perl that you are using does not implement Vstrings, to use
L</isvstring> you will need to use a newer release of perl.
-=item C<NAME> is only available with the XS version of Scalar::Util
-
-C<Scalar::Util> contains both perl and C implementations of many of its
-functions so that those without access to a C compiler may still use it.
-However some of the functions are only available when a C compiler was
-available to compile the XS version of the extension.
-
-At present that list is: weaken, isweak, dualvar, isvstring, set_prototype
-
=back
=head1 KNOWN BUGS
subname set_subname
);
-our $VERSION = "1.42_02";
+our $VERSION = "1.45_01";
$VERSION = eval $VERSION;
require List::Util; # as it has the XS
use strict;
use warnings;
-use Test::More tests => 14;
+use Test::More tests => 25;
+use Config;
use List::Util qw(product);
my $v = product;
$v = product(0, 1, 2);
is( $v, 0, 'first factor zero' );
+$v = product(0, 1);
+is( $v, 0, '0 * 1');
+
+$v = product(1, 0);
+is( $v, 0, '1 * 0');
+
+$v = product(0, 0);
+is( $v, 0, 'two 0');
+
my $x = -3;
$v = product($x, 3);
is($t, 567, 'overload returning non-overload');
}
+SKIP: {
+ skip "IV is not at least 64bit", 8 unless $Config{ivsize} >= 8;
+
+ my $t;
+ my $min = -(1<<31);
+ my $max = (1<<31)-1;
+
+ $t = product($min, $min);
+ is($t, 1<<62, 'min * min');
+ $t = product($min, $max);
+ is($t, (1<<31) - (1<<62), 'min * max');
+ $t = product($max, $min);
+ is($t, (1<<31) - (1<<62), 'max * min');
+ $t = product($max, $max);
+ is($t, (1<<62)-(1<<32)+1, 'max * max');
+
+ $t = product($min*8, $min);
+ cmp_ok($t, '>', (1<<61), 'min*8*min'); # may be an NV
+ $t = product($min*8, $max);
+ cmp_ok($t, '<', -(1<<61), 'min*8*max'); # may be an NV
+ $t = product($max, $min*8);
+ cmp_ok($t, '<', -(1<<61), 'min*max*8'); # may be an NV
+ $t = product($max, $max*8);
+ cmp_ok($t, '>', (1<<61), 'max*max*8'); # may be an NV
+
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+{
+ use List::Util qw( first );
+
+ my $hash = {
+ 'HellO WorlD' => 1,
+ };
+
+ is( ( first { 'hello world' eq lc($_) } keys %$hash ), "HellO WorlD",
+ 'first (lc$_) perserves value' );
+}
+
+{
+ use List::Util qw( any );
+
+ my $hash = {
+ 'HellO WorlD' => 1,
+ };
+
+ my $var;
+
+ no warnings 'void';
+ any { lc($_); $var = $_; } keys %$hash;
+
+ is( $var, 'HellO WorlD',
+ 'any (lc$_) leaves value undisturbed' );
+}
+
+done_testing;
use strict;
use warnings;
-use Test::More tests => 15;
+use Test::More tests => 17;
use Config;
use List::Util qw(sum);
}
SKIP: {
- skip "IV is not at least 64bit", 1 unless $Config{ivsize} >= 8;
+ skip "IV is not at least 64bit", 3 unless $Config{ivsize} >= 8;
# Sum using NV will only preserve 53 bits of integer precision
my $t = sum(1<<60, 1);
cmp_ok($t, '>', 1<<60, 'sum uses IV where it can');
+
+ my $min = -(1<<63);
+ my $max = (1<<63)-1;
+
+ $t = sum($min, $max);
+ is($t, -1, 'min + max');
+ $t = sum($max, $min);
+ is($t, -1, 'max + min');
}
--- /dev/null
+#!./perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 30;
+use List::Util qw( uniqnum uniqstr uniq );
+
+use Tie::Array;
+
+is_deeply( [ uniqstr ],
+ [],
+ 'uniqstr of empty list' );
+
+is_deeply( [ uniqstr qw( abc ) ],
+ [qw( abc )],
+ 'uniqstr of singleton list' );
+
+is_deeply( [ uniqstr qw( x x x ) ],
+ [qw( x )],
+ 'uniqstr of repeated-element list' );
+
+is_deeply( [ uniqstr qw( a b a c ) ],
+ [qw( a b c )],
+ 'uniqstr removes subsequent duplicates' );
+
+is_deeply( [ uniqstr qw( 1 1.0 1E0 ) ],
+ [qw( 1 1.0 1E0 )],
+ 'uniqstr compares strings' );
+
+{
+ my $warnings = "";
+ local $SIG{__WARN__} = sub { $warnings .= join "", @_ };
+
+ is_deeply( [ uniqstr "", undef ],
+ [ "" ],
+ 'uniqstr considers undef and empty-string equivalent' );
+
+ ok( length $warnings, 'uniqstr on undef yields a warning' );
+
+ is_deeply( [ uniqstr undef ],
+ [ "" ],
+ 'uniqstr on undef coerces to empty-string' );
+}
+
+{
+ my $warnings = "";
+ local $SIG{__WARN__} = sub { $warnings .= join "", @_ };
+
+ my $cafe = "cafe\x{301}";
+
+ is_deeply( [ uniqstr $cafe ],
+ [ $cafe ],
+ 'uniqstr is happy with Unicode strings' );
+
+ utf8::encode( my $cafebytes = $cafe );
+
+ is_deeply( [ uniqstr $cafe, $cafebytes ],
+ [ $cafe, $cafebytes ],
+ 'uniqstr does not squash bytewise-equal but differently-encoded strings' );
+
+ is( $warnings, "", 'No warnings are printed when handling Unicode strings' );
+}
+
+is_deeply( [ uniqnum qw( 1 1.0 1E0 2 3 ) ],
+ [ 1, 2, 3 ],
+ 'uniqnum compares numbers' );
+
+is_deeply( [ uniqnum qw( 1 1.1 1.2 1.3 ) ],
+ [ 1, 1.1, 1.2, 1.3 ],
+ 'uniqnum distinguishes floats' );
+
+# Hard to know for sure what an Inf is going to be. Lets make one
+my $Inf = 0 + 1E1000;
+my $NaN;
+$Inf **= 1000 while ( $NaN = $Inf - $Inf ) == $NaN;
+
+is_deeply( [ uniqnum 0, 1, 12345, $Inf, -$Inf, $NaN, 0, $Inf, $NaN ],
+ [ 0, 1, 12345, $Inf, -$Inf, $NaN ],
+ 'uniqnum preserves the special values of +-Inf and Nan' );
+
+{
+ my $maxint = ~0;
+
+ is_deeply( [ uniqnum $maxint, $maxint-1, -1 ],
+ [ $maxint, $maxint-1, -1 ],
+ 'uniqnum preserves uniqness of full integer range' );
+}
+
+{
+ my $warnings = "";
+ local $SIG{__WARN__} = sub { $warnings .= join "", @_ };
+
+ is_deeply( [ uniqnum 0, undef ],
+ [ 0 ],
+ 'uniqnum considers undef and zero equivalent' );
+
+ ok( length $warnings, 'uniqnum on undef yields a warning' );
+
+ is_deeply( [ uniqnum undef ],
+ [ 0 ],
+ 'uniqnum on undef coerces to zero' );
+}
+
+is_deeply( [ uniq () ],
+ [],
+ 'uniq of empty list' );
+
+{
+ my $warnings = "";
+ local $SIG{__WARN__} = sub { $warnings .= join "", @_ };
+
+ is_deeply( [ uniq "", undef ],
+ [ "", undef ],
+ 'uniq distintinguishes empty-string from undef' );
+
+ is_deeply( [ uniq undef, undef ],
+ [ undef ],
+ 'uniq considers duplicate undefs as identical' );
+
+ ok( !length $warnings, 'uniq on undef does not warn' );
+}
+
+is( scalar( uniqstr qw( a b c d a b e ) ), 5, 'uniqstr() in scalar context' );
+
+{
+ package Stringify;
+
+ use overload '""' => sub { return $_[0]->{str} };
+
+ sub new { bless { str => $_[1] }, $_[0] }
+
+ package main;
+
+ my @strs = map { Stringify->new( $_ ) } qw( foo foo bar );
+
+ is_deeply( [ uniqstr @strs ],
+ [ $strs[0], $strs[2] ],
+ 'uniqstr respects stringify overload' );
+}
+
+{
+ package Numify;
+
+ use overload '0+' => sub { return $_[0]->{num} };
+
+ sub new { bless { num => $_[1] }, $_[0] }
+
+ package main;
+ use Scalar::Util qw( refaddr );
+
+ my @nums = map { Numify->new( $_ ) } qw( 2 2 5 );
+
+ # is_deeply wants to use eq overloading
+ my @ret = uniqnum @nums;
+ ok( scalar @ret == 2 &&
+ refaddr $ret[0] == refaddr $nums[0] &&
+ refaddr $ret[1] == refaddr $nums[2],
+ 'uniqnum respects numify overload' );
+}
+
+{
+ package DestroyNotifier;
+
+ use overload '""' => sub { "SAME" };
+
+ sub new { bless { var => $_[1] }, $_[0] }
+
+ sub DESTROY { ${ $_[0]->{var} }++ }
+
+ package main;
+
+ my @destroyed = (0) x 3;
+ my @notifiers = map { DestroyNotifier->new( \$destroyed[$_] ) } 0 .. 2;
+
+ my @uniqstr = uniqstr @notifiers;
+ undef @notifiers;
+
+ is_deeply( \@destroyed, [ 0, 1, 1 ],
+ 'values filtered by uniqstr() are destroyed' );
+
+ undef @uniqstr;
+ is_deeply( \@destroyed, [ 1, 1, 1 ],
+ 'all values destroyed' );
+}
+
+{
+ "a a b" =~ m/(.) (.) (.)/;
+ is_deeply( [ uniqstr $1, $2, $3 ],
+ [qw( a b )],
+ 'uniqstr handles magic' );
+
+ "1 1 2" =~ m/(.) (.) (.)/;
+ is_deeply( [ uniqnum $1, $2, $3 ],
+ [ 1, 2 ],
+ 'uniqnum handles magic' );
+}
+
+{
+ my @array;
+ tie @array, 'Tie::StdArray';
+ @array = (
+ ( map { ( 1 .. 10 ) } 0 .. 1 ),
+ ( map { ( 'a' .. 'z' ) } 0 .. 1 )
+ );
+
+ my @u = uniq @array;
+ is_deeply(
+ \@u,
+ [ 1 .. 10, 'a' .. 'z' ],
+ 'uniq uniquifies mixed numbers and strings correctly in a tied array'
+ );
+}
use ExtUtils::MakeMaker;
use File::Copy;
use File::Spec;
+use Config;
# create a typemap for Perl 5.6
$virtual_path{'win32/Win32.pm' } = '$(INST_LIBDIR)/Syslog/Win32.pm';
$virtual_path{'win32/PerlLog.dll'} = '$(INST_ARCHAUTODIR)/PerlLog.dll';
- push @extra_params, CCFLAGS => "-Ifallback";
+ push @extra_params, CCFLAGS => "$Config{ccflags} -Ifallback";
# recreate the DLL from its uuencoded form if it's not here
if (! -f File::Spec->catfile("win32", "$name.dll")) {
use warnings;
use warnings::register;
use Carp;
-use Exporter qw< import >;
+use Config;
+use Exporter ();
use File::Basename;
use POSIX qw< strftime setlocale LC_TIME >;
use Socket qw< :all >;
require 5.005;
+*import = \&Exporter::import;
+
+
{ no strict 'vars';
- $VERSION = '0.33';
+ $VERSION = '0.34';
%EXPORT_TAGS = (
standard => [qw(openlog syslog closelog setlogmask)],
}
+#
+# Constants
+#
+use constant HAVE_GETPROTOBYNAME => $Config::Config{d_getpbyname};
+use constant HAVE_GETPROTOBYNUMBER => $Config::Config{d_getpbynumber};
+use constant HAVE_SETLOCALE => $Config::Config{d_setlocale};
+use constant HAVE_IPPROTO_TCP => defined &Socket::IPPROTO_TCP ? 1 : 0;
+use constant HAVE_IPPROTO_UDP => defined &Socket::IPPROTO_UDP ? 1 : 0;
+use constant HAVE_TCP_NODELAY => defined &Socket::TCP_NODELAY ? 1 : 0;
+
+use constant SOCKET_IPPROTO_TCP =>
+ HAVE_IPPROTO_TCP ? Socket::IPPROTO_TCP
+ : HAVE_GETPROTOBYNAME ? scalar getprotobyname("tcp")
+ : 6;
+
+use constant SOCKET_IPPROTO_UDP =>
+ HAVE_IPPROTO_UDP ? Socket::IPPROTO_UDP
+ : HAVE_GETPROTOBYNAME ? scalar getprotobyname("udp")
+ : 17;
+
+use constant SOCKET_TCP_NODELAY => HAVE_TCP_NODELAY ? Socket::TCP_NODELAY : 1;
+
+
#
# Public variables
#
check => sub {
return 1 if defined $sock_port;
- if (getservbyname('syslog', 'tcp') || getservbyname('syslogng', 'tcp')) {
+ if (eval { local $SIG{__DIE__};
+ getservbyname('syslog','tcp') || getservbyname('syslogng','tcp')
+ }) {
$host = $syslog_path;
return 1
}
check => sub {
return 1 if defined $sock_port;
- if (getservbyname('syslog', 'udp')) {
+ if (eval { local $SIG{__DIE__}; getservbyname('syslog', 'udp') }) {
$host = $syslog_path;
return 1
}
if ($priority =~ /^\d+$/) {
$numpri = LOG_PRI($priority);
$numfac = LOG_FAC($priority) << 3;
+ undef $numfac if $numfac == 0; # no facility given => use default
}
elsif ($priority =~ /^\w+/) {
# Allow "level" or "level|facility".
$mask =~ s/(?<!%)((?:%%)*)%m/$1$error/g;
}
- $mask .= "\n" unless $mask =~ /\n$/;
+ # add (or not) a newline
+ $mask .= "\n" if !$options{noeol} and rindex($mask, "\n") == -1;
$message = @args ? sprintf($mask, @args) : $mask;
if ($current_proto eq 'native') {
$whoami .= "[$$]" if $options{pid};
$sum = $numpri + $numfac;
- my $oldlocale = setlocale(LC_TIME);
- setlocale(LC_TIME, 'C');
- my $timestamp = strftime "%b %d %H:%M:%S", localtime;
- setlocale(LC_TIME, $oldlocale);
+
+ my $oldlocale;
+ if (HAVE_SETLOCALE) {
+ $oldlocale = setlocale(LC_TIME);
+ setlocale(LC_TIME, 'C');
+ }
+
+ # %e format isn't available on all systems (Win32, cf. CPAN RT #69310)
+ my $day = strftime "%e", localtime;
+
+ if (index($day, "%") == 0) {
+ $day = strftime "%d", localtime;
+ $day =~ s/^0/ /;
+ }
+
+ my $timestamp = strftime "%b $day %H:%M:%S", localtime;
+ setlocale(LC_TIME, $oldlocale) if HAVE_SETLOCALE;
# construct the stream that will be transmitted
$buf = "<$sum>$timestamp $whoami: $message";
- # add (or not) a newline
- $buf .= "\n" if !$options{noeol} and rindex($buf, "\n") == -1;
-
# add (or not) a NUL character
$buf .= "\0" if !$options{nonul};
}
if ($options{perror} and $current_proto ne 'native') {
my $whoami = $ident;
$whoami .= "[$$]" if $options{pid};
- print STDERR "$whoami: $message\n";
+ print STDERR "$whoami: $message";
+ print STDERR "\n" if rindex($message, "\n") == -1;
}
# it's possible that we'll get an error from sending
sub connect_tcp {
my ($errs) = @_;
- my $proto = getprotobyname('tcp');
- if (!defined $proto) {
- push @$errs, "getprotobyname failed for tcp";
- return 0;
- }
-
- my $port = $sock_port || getservbyname('syslog', 'tcp');
- $port = getservbyname('syslogng', 'tcp') unless defined $port;
+ my $port = $sock_port
+ || eval { local $SIG{__DIE__}; getservbyname('syslog', 'tcp') }
+ || eval { local $SIG{__DIE__}; getservbyname('syslogng', 'tcp') };
if (!defined $port) {
push @$errs, "getservbyname failed for syslog/tcp and syslogng/tcp";
return 0;
}
$addr = sockaddr_in($port, $addr);
- if (!socket(SYSLOG, AF_INET, SOCK_STREAM, $proto)) {
+ if (!socket(SYSLOG, AF_INET, SOCK_STREAM, SOCKET_IPPROTO_TCP)) {
push @$errs, "tcp socket: $!";
return 0;
}
setsockopt(SYSLOG, SOL_SOCKET, SO_KEEPALIVE, 1);
- if (silent_eval { IPPROTO_TCP() }) {
- # These constants don't exist in 5.005. They were added in 1999
- setsockopt(SYSLOG, IPPROTO_TCP(), TCP_NODELAY(), 1);
- }
+ setsockopt(SYSLOG, SOCKET_IPPROTO_TCP, SOCKET_TCP_NODELAY, 1);
+
if (!connect(SYSLOG, $addr)) {
push @$errs, "tcp connect: $!";
return 0;
sub connect_udp {
my ($errs) = @_;
- my $proto = getprotobyname('udp');
- if (!defined $proto) {
- push @$errs, "getprotobyname failed for udp";
- return 0;
- }
-
- my $port = $sock_port || getservbyname('syslog', 'udp');
+ my $port = $sock_port
+ || eval { local $SIG{__DIE__}; getservbyname('syslog', 'udp') };
if (!defined $port) {
push @$errs, "getservbyname failed for syslog/udp";
return 0;
}
$addr = sockaddr_in($port, $addr);
- if (!socket(SYSLOG, AF_INET, SOCK_DGRAM, $proto)) {
+ if (!socket(SYSLOG, AF_INET, SOCK_DGRAM, SOCKET_IPPROTO_UDP)) {
push @$errs, "udp socket: $!";
return 0;
}
=head1 VERSION
-This is the documentation of version 0.33
+This is the documentation of version 0.34
=head1 SYNOPSIS
You can also look for information at:
-=over 4
-
-=item * AnnoCPAN: Annotated CPAN documentation
-
-L<http://annocpan.org/dist/Sys-Syslog>
+=over
-=item * CPAN Ratings
+=item * Perl Documentation
-L<http://cpanratings.perl.org/d/Sys-Syslog>
+L<http://perldoc.perl.org/Sys/Syslog.html>
-=item * RT: CPAN's request tracker
+=item * MetaCPAN
-L<http://rt.cpan.org/Dist/Display.html?Queue=Sys-Syslog>
+L<https://metacpan.org/module/Sys::Syslog>
=item * Search CPAN
L<http://search.cpan.org/dist/Sys-Syslog/>
-=item * MetaCPAN
+=item * AnnoCPAN: Annotated CPAN documentation
-L<https://metacpan.org/module/Sys::Syslog>
+L<http://annocpan.org/dist/Sys-Syslog>
-=item * Perl Documentation
+=item * CPAN Ratings
-L<http://perldoc.perl.org/Sys/Syslog.html>
+L<http://cpanratings.perl.org/d/Sys-Syslog>
+
+=item * RT: CPAN's request tracker
+
+L<http://rt.cpan.org/Dist/Display.html?Queue=Sys-Syslog>
=back
+The source code is available on Git Hub:
+L<https://github.com/maddingue/Sys-Syslog/>
+
=head1 COPYRIGHT
#else
# if defined(I_SYSLOG) || PATCHLEVEL < 6
# include <syslog.h>
+# else
+# undef HAVE_SYSLOG
+# include "fallback/syslog.h"
# endif
#endif
-# Term::ANSIColor -- Color screen output using ANSI escape sequences.
+# Color screen output using ANSI escape sequences.
#
# Copyright 1996, 1997, 1998, 2000, 2001, 2002, 2005, 2006, 2008, 2009, 2010,
-# 2011, 2012, 2013, 2014, 2015 Russ Allbery <rra@cpan.org>
+# 2011, 2012, 2013, 2014, 2015, 2016 Russ Allbery <rra@cpan.org>
# Copyright 1996 Zenin
# Copyright 2012 Kurt Starsinic <kstarsinic@gmail.com>
#
use strict;
use warnings;
-use Carp qw(croak);
+# Also uses Carp but loads it on demand to reduce memory usage.
+
use Exporter ();
# use Exporter plus @ISA instead of use base for 5.6 compatibility.
# against circular module loading (not that we load any modules, but
# consistency is good).
BEGIN {
- $VERSION = '4.04';
+ $VERSION = '4.05';
# All of the basic supported constants, used in %EXPORT_TAGS.
my @colorlist = qw(
our @COLORSTACK;
##############################################################################
+# Helper functions
+##############################################################################
+
+# Stub to load the Carp module on demand.
+sub croak {
+ my (@args) = @_;
+ require Carp;
+ Carp::croak(@args);
+}
+
+##############################################################################
# Implementation (constant form)
##############################################################################
# make it easier to write scripts that also work on systems without any ANSI
# support, like Windows consoles.
#
+# Avoid using character classes like [:upper:] and \w here, since they load
+# Unicode character tables and consume a ton of memory. All of our constants
+# only use ASCII characters.
+#
## no critic (ClassHierarchies::ProhibitAutoloading)
## no critic (Subroutines::RequireArgUnpacking)
+## no critic (RegularExpressions::ProhibitEnumeratedClasses)
sub AUTOLOAD {
- my ($sub, $attr) = $AUTOLOAD =~ m{ \A ([\w:]*::([[:upper:]\d_]+)) \z }xms;
+ my ($sub, $attr) = $AUTOLOAD =~ m{
+ \A ( [a-zA-Z0-9:]* :: ([A-Z0-9_]+) ) \z
+ }xms;
# Check if we were called with something that doesn't look like an
# attribute.
## no critic (References::ProhibitDoubleSigils)
goto &$AUTOLOAD;
}
-## use critic (Subroutines::RequireArgUnpacking)
+## use critic
# Append a new color to the top of the color stack and return the top of
# the stack.
return $ATTRIBUTES_R{ $ALIASES{$alias} };
}
}
- if ($alias !~ m{ \A [\w._-]+ \z }xms) {
+
+ # Avoid \w here to not load Unicode character tables, which increases the
+ # memory footprint of this module considerably.
+ #
+ ## no critic (RegularExpressions::ProhibitEnumeratedClasses)
+ if ($alias !~ m{ \A [a-zA-Z0-9._-]+ \z }xms) {
croak(qq{Invalid alias name "$alias"});
} elsif ($ATTRIBUTES{$alias}) {
croak(qq{Cannot alias standard color "$alias"});
} elsif (!exists $ATTRIBUTES{$color}) {
croak(qq{Invalid attribute name "$color"});
}
+ ## use critic
+
+ # Set the alias and return.
$ALIASES{$alias} = $ATTRIBUTES{$color};
return $color;
}
standard color ATTR. From that point forward, ALIAS can be passed into
color(), colored(), and colorvalid() and will have the same meaning as
ATTR. One possible use of this facility is to give more meaningful names
-to the 256-color RGB colors. Only alphanumerics, C<.>, C<_>, and C<-> are
-allowed in alias names.
+to the 256-color RGB colors. Only ASCII alphanumerics, C<.>, C<_>, and
+C<-> are allowed in alias names.
If ATTR is not specified, coloralias() returns the standard color name to
which ALIAS is aliased, if any, or undef if ALIAS does not exist.
Copyright 1996 Zenin
Copyright 1996, 1997, 1998, 2000, 2001, 2002, 2005, 2006, 2008, 2009, 2010,
-2011, 2012, 2013, 2014, 2015 Russ Allbery <rra@cpan.org>
+2011, 2012, 2013, 2014, 2015, 2016 Russ Allbery <rra@cpan.org>
Copyright 2012 Kurt Starsinic <kstarsinic@gmail.com>
# by both C packages with Automake and by stand-alone Perl modules. See
# Test::RRA::Automake for additional functions specifically for C Automake
# distributions.
-#
-# The canonical version of this file is maintained in the rra-c-util package,
-# which can be found at <http://www.eyrie.org/~eagle/software/rra-c-util/>.
-#
-# Written by Russ Allbery <eagle@eyrie.org>
-# Copyright 2013, 2014
-# The Board of Trustees of the Leland Stanford Junior University
-#
-# Permission is hereby granted, free of charge, to any person obtaining a
-# copy of this software and associated documentation files (the "Software"),
-# to deal in the Software without restriction, including without limitation
-# the rights to use, copy, modify, merge, publish, distribute, sublicense,
-# and/or sell copies of the Software, and to permit persons to whom the
-# Software is furnished to do so, subject to the following conditions:
-#
-# The above copyright notice and this permission notice shall be included in
-# all copies or substantial portions of the Software.
-#
-# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
-# THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
-# DEALINGS IN THE SOFTWARE.
package Test::RRA;
# This version should match the corresponding rra-c-util release, but with
# two digits for the minor version, including a leading zero if necessary,
# so that it will sort properly.
- $VERSION = '5.04';
+ $VERSION = '5.11';
}
# Skip this test unless author tests are requested. Takes a short description
=for stopwords
Allbery Allbery's DESC bareword sublicense MERCHANTABILITY NONINFRINGEMENT
-rra-c-util
+rra-c-util CPAN
=head1 NAME
=head1 DESCRIPTION
-This module collects utility functions that are useful for Perl test
-scripts. It assumes Russ Allbery's Perl module layout and test
-conventions and will only be useful for other people if they use the
-same conventions.
+This module collects utility functions that are useful for Perl test scripts.
+It assumes Russ Allbery's Perl module layout and test conventions and will
+only be useful for other people if they use the same conventions.
=head1 FUNCTIONS
-None of these functions are imported by default. The ones used by a
-script should be explicitly imported.
+None of these functions are imported by default. The ones used by a script
+should be explicitly imported.
=over 4
=item skip_unless_author(DESC)
-Checks whether AUTHOR_TESTING is set in the environment and skips the
-whole test (by calling C<plan skip_all> from Test::More) if it is not.
-DESC is a description of the tests being skipped. A space and C<only run
-for author> will be appended to it and used as the skip reason.
+Checks whether AUTHOR_TESTING is set in the environment and skips the whole
+test (by calling C<plan skip_all> from Test::More) if it is not. DESC is a
+description of the tests being skipped. A space and C<only run for author>
+will be appended to it and used as the skip reason.
=item skip_unless_automated(DESC)
-Checks whether AUTHOR_TESTING, AUTOMATED_TESTING, or RELEASE_TESTING are
-set in the environment and skips the whole test (by calling C<plan
-skip_all> from Test::More) if they are not. This should be used by tests
-that should not run during end-user installs of the module, but which
-should run as part of CPAN smoke testing and release testing.
+Checks whether AUTHOR_TESTING, AUTOMATED_TESTING, or RELEASE_TESTING are set
+in the environment and skips the whole test (by calling C<plan skip_all> from
+Test::More) if they are not. This should be used by tests that should not run
+during end-user installs of the module, but which should run as part of CPAN
+smoke testing and release testing.
DESC is a description of the tests being skipped. A space and C<normally
skipped> will be appended to it and used as the skip reason.
=item use_prereq(MODULE[, VERSION][, IMPORT ...])
-Attempts to load MODULE with the given VERSION and import arguments. If
-this fails for any reason, the test will be skipped (by calling C<plan
-skip_all> from Test::More) with a skip reason saying that MODULE is
-required for the test.
+Attempts to load MODULE with the given VERSION and import arguments. If this
+fails for any reason, the test will be skipped (by calling C<plan skip_all>
+from Test::More) with a skip reason saying that MODULE is required for the
+test.
VERSION will be passed to C<use> as a version bareword if it looks like a
-version number. The remaining IMPORT arguments will be passed as the
-value of an array.
+version number. The remaining IMPORT arguments will be passed as the value of
+an array.
=back
Copyright 2013, 2014 The Board of Trustees of the Leland Stanford Junior
University
-Permission is hereby granted, free of charge, to any person obtaining a
-copy of this software and associated documentation files (the "Software"),
-to deal in the Software without restriction, including without limitation
-the rights to use, copy, modify, merge, publish, distribute, sublicense,
-and/or sell copies of the Software, and to permit persons to whom the
-Software is furnished to do so, subject to the following conditions:
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
-The above copyright notice and this permission notice shall be included in
-all copies or substantial portions of the Software.
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
-THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
-DEALINGS IN THE SOFTWARE.
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
=head1 SEE ALSO
Test::More(3), Test::RRA::Automake(3), Test::RRA::Config(3)
-This module is maintained in the rra-c-util package. The current version
-is available from L<http://www.eyrie.org/~eagle/software/rra-c-util/>.
+This module is maintained in the rra-c-util package. The current version is
+available from L<http://www.eyrie.org/~eagle/software/rra-c-util/>.
-The functions to control when tests are run use environment variables
-defined by the L<Lancaster
+The functions to control when tests are run use environment variables defined
+by the L<Lancaster
Consensus|https://github.com/Perl-Toolchain-Gang/toolchain-site/blob/master/lancaster-consensus.md>.
=cut
# configuration file to store some package-specific data. This module loads
# that configuration and provides the namespace for the configuration
# settings.
-#
-# The canonical version of this file is maintained in the rra-c-util package,
-# which can be found at <http://www.eyrie.org/~eagle/software/rra-c-util/>.
package Test::RRA::Config;
@ISA = qw(Exporter);
@EXPORT_OK = qw(
$COVERAGE_LEVEL @COVERAGE_SKIP_TESTS @CRITIC_IGNORE $LIBRARY_PATH
- $MINIMUM_VERSION %MINIMUM_VERSION @POD_COVERAGE_EXCLUDE @STRICT_IGNORE
- @STRICT_PREREQ
+ $MINIMUM_VERSION %MINIMUM_VERSION @MODULE_VERSION_IGNORE
+ @POD_COVERAGE_EXCLUDE @STRICT_IGNORE @STRICT_PREREQ
);
# This version should match the corresponding rra-c-util release, but with
# two digits for the minor version, including a leading zero if necessary,
# so that it will sort properly.
- $VERSION = '5.04';
+ $VERSION = '5.11';
}
# If BUILD or SOURCE are set in the environment, look for data/perl.conf under
# those paths for a C Automake package. Otherwise, look in t/data/perl.conf
-# for a standalone Perl module. Don't use Test::RRA::Automake since it may
-# not exist.
+# for a standalone Perl module or tests/data/perl.conf for Perl tests embedded
+# in a larger distribution. Don't use Test::RRA::Automake since it may not
+# exist.
our $PATH;
-for my $base ($ENV{BUILD}, $ENV{SOURCE}, 't') {
+for my $base ($ENV{BUILD}, $ENV{SOURCE}, 't', 'tests') {
next if !defined($base);
my $path = "$base/data/perl.conf";
if (-r $path) {
our $LIBRARY_PATH;
our $MINIMUM_VERSION = '5.008';
our %MINIMUM_VERSION;
+our @MODULE_VERSION_IGNORE;
our @POD_COVERAGE_EXCLUDE;
our @STRICT_IGNORE;
our @STRICT_PREREQ;
__END__
=for stopwords
-Allbery rra-c-util Automake perlcritic .libs namespace subdirectory
-sublicense MERCHANTABILITY NONINFRINGEMENT
+Allbery rra-c-util Automake perlcritic .libs namespace subdirectory sublicense
+MERCHANTABILITY NONINFRINGEMENT regexes
=head1 NAME
=head1 DESCRIPTION
-Test::RRA::Config encapsulates per-package configuration for generic Perl
-test programs that are shared between multiple packages using the
-rra-c-util infrastructure. It handles locating and loading the test
-configuration file for both C Automake packages and stand-alone Perl
-modules.
+Test::RRA::Config encapsulates per-package configuration for generic Perl test
+programs that are shared between multiple packages using the rra-c-util
+infrastructure. It handles locating and loading the test configuration file
+for both C Automake packages and stand-alone Perl modules.
Test::RRA::Config looks for a file named F<data/perl.conf> relative to the
-root of the test directory. That root is taken from the environment
-variables BUILD or SOURCE (in that order) if set, which will be the case
-for C Automake packages using C TAP Harness. If neither is set, it
-expects the root of the test directory to be a directory named F<t>
-relative to the current directory, which will be the case for stand-alone
-Perl modules.
+root of the test directory. That root is taken from the environment variables
+BUILD or SOURCE (in that order) if set, which will be the case for C Automake
+packages using C TAP Harness. If neither is set, it expects the root of the
+test directory to be a directory named F<t> relative to the current directory,
+which will be the case for stand-alone Perl modules.
The following variables are supported:
=item $COVERAGE_LEVEL
-The coverage level achieved by the test suite for Perl test coverage
-testing using Test::Strict, as a percentage. The test will fail if test
-coverage less than this percentage is achieved. If not given, defaults
-to 100.
+The coverage level achieved by the test suite for Perl test coverage testing
+using Test::Strict, as a percentage. The test will fail if test coverage less
+than this percentage is achieved. If not given, defaults to 100.
=item @COVERAGE_SKIP_TESTS
Directories under F<t> whose tests should be skipped when doing coverage
-testing. This can be tests that won't contribute to coverage or tests
-that don't run properly under Devel::Cover for some reason (such as ones
-that use taint checking). F<docs> and F<style> will always be skipped
-regardless of this setting.
+testing. This can be tests that won't contribute to coverage or tests that
+don't run properly under Devel::Cover for some reason (such as ones that use
+taint checking). F<docs> and F<style> will always be skipped regardless of
+this setting.
=item @CRITIC_IGNORE
-Additional directories to ignore when doing recursive perlcritic testing.
-The contents of this directory must be either top-level directory names or
+Additional directories to ignore when doing recursive perlcritic testing. The
+contents of this directory must be either top-level directory names or
directory names starting with F<tests/>.
=item $LIBRARY_PATH
Add this directory (or a F<.libs> subdirectory) relative to the top of the
-source tree to LD_LIBRARY_PATH when checking the syntax of Perl modules.
-This may be required to pick up libraries that are used by in-tree Perl
-modules so that Perl scripts can pass a syntax check.
+source tree to LD_LIBRARY_PATH when checking the syntax of Perl modules. This
+may be required to pick up libraries that are used by in-tree Perl modules so
+that Perl scripts can pass a syntax check.
=item $MINIMUM_VERSION
-Default minimum version requirement for included Perl scripts. If not
-given, defaults to 5.008.
+Default minimum version requirement for included Perl scripts. If not given,
+defaults to 5.008.
=item %MINIMUM_VERSION
Minimum version exceptions for specific directories. The keys should be
minimum versions of Perl to enforce. The value for each key should be a
-reference to an array of either top-level directory names or directory
-names starting with F<tests/>. All files in those directories will have
-that minimum Perl version constraint imposed instead of $MINIMUM_VERSION.
+reference to an array of either top-level directory names or directory names
+starting with F<tests/>. All files in those directories will have that
+minimum Perl version constraint imposed instead of $MINIMUM_VERSION.
+
+=item @MODULE_VERSION_IGNORE
+
+File names to ignore when checking that all modules in a distribution have the
+same version. Sometimes, some specific modules need separate, special version
+handling, such as modules defining database schemata for DBIx::Class, and
+can't follow the version of the larger package.
=item @POD_COVERAGE_EXCLUDE
Regexes that match method names that should be excluded from POD coverage
-testing. Normally, all methods have to be documented in the POD for a
-Perl module, but methods matching any of these regexes will be considered
-private and won't require documentation.
+testing. Normally, all methods have to be documented in the POD for a Perl
+module, but methods matching any of these regexes will be considered private
+and won't require documentation.
=item @STRICT_IGNORE
-Additional directories to ignore when doing recursive Test::Strict testing
-for C<use strict> and C<use warnings>. The contents of this directory
-must be either top-level directory names or directory names starting with
-F<tests/>.
+Additional directories to ignore when doing recursive Test::Strict testing for
+C<use strict> and C<use warnings>. The contents of this directory must be
+either top-level directory names or directory names starting with F<tests/>.
=item @STRICT_PREREQ
A list of Perl modules that have to be available in order to do meaningful
Test::Strict testing. If any of the modules cannot be loaded via C<use>,
-Test::Strict checking will be skipped. There is currently no way to
-require specific versions of the modules.
+Test::Strict checking will be skipped. There is currently no way to require
+specific versions of the modules.
=back
-No variables are exported by default, but the variables can be imported
-into the local namespace to avoid long variable names.
+No variables are exported by default, but the variables can be imported into
+the local namespace to avoid long variable names.
=head1 AUTHOR
Copyright 2013, 2014 The Board of Trustees of the Leland Stanford Junior
University
-Permission is hereby granted, free of charge, to any person obtaining a
-copy of this software and associated documentation files (the "Software"),
-to deal in the Software without restriction, including without limitation
-the rights to use, copy, modify, merge, publish, distribute, sublicense,
-and/or sell copies of the Software, and to permit persons to whom the
-Software is furnished to do so, subject to the following conditions:
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
-The above copyright notice and this permission notice shall be included in
-all copies or substantial portions of the Software.
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
-THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
-DEALINGS IN THE SOFTWARE.
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
=head1 SEE ALSO
-perlcritic(1), Test::MinimumVersion(3), Test::RRA(3),
-Test::RRA::Automake(3), Test::Strict(3)
+perlcritic(1), Test::MinimumVersion(3), Test::RRA(3), Test::RRA::Automake(3),
+Test::Strict(3)
-This module is maintained in the rra-c-util package. The current version
-is available from L<http://www.eyrie.org/~eagle/software/rra-c-util/>.
+This module is maintained in the rra-c-util package. The current version is
+available from L<http://www.eyrie.org/~eagle/software/rra-c-util/>.
The C TAP Harness test driver and libraries for TAP-based C testing are
available from L<http://www.eyrie.org/~eagle/software/c-tap-harness/>.
use strict;
use warnings;
-our $VERSION = '1.001014';
-$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
+our $VERSION = '1.302015';
BEGIN {
if( $] < 5.008 ) {
}
}
+use overload();
+use Scalar::Util qw/blessed reftype weaken/;
+
+use Test2::Util qw/USE_THREADS try get_tid/;
+use Test2::API qw/context release/;
# Make Test::Builder thread-safe for ithreads.
BEGIN {
- use Config;
- # Load threads::shared when threads are turned on.
- # 5.8.0's threads are so busted we no longer support them.
- if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) {
- require threads::shared;
-
- # Hack around YET ANOTHER threads::shared bug. It would
- # occasionally forget the contents of the variable when sharing it.
- # So we first copy the data, then share, then put our copy back.
- *share = sub (\[$@%]) {
- my $type = ref $_[0];
- my $data;
-
- if( $type eq 'HASH' ) {
- %$data = %{ $_[0] };
- }
- elsif( $type eq 'ARRAY' ) {
- @$data = @{ $_[0] };
- }
- elsif( $type eq 'SCALAR' ) {
- $$data = ${ $_[0] };
- }
- else {
- die( "Unknown type: " . $type );
- }
-
- $_[0] = &threads::shared::share( $_[0] );
-
- if( $type eq 'HASH' ) {
- %{ $_[0] } = %$data;
- }
- elsif( $type eq 'ARRAY' ) {
- @{ $_[0] } = @$data;
- }
- elsif( $type eq 'SCALAR' ) {
- ${ $_[0] } = $$data;
- }
- else {
- die( "Unknown type: " . $type );
- }
+ warn "Test::Builder was loaded after Test2 initialization, this is not recommended."
+ if Test2::API::test2_init_done() || Test2::API::test2_load_done();
- return $_[0];
- };
- }
- # 5.8.0's threads::shared is busted when threads are off
- # and earlier Perls just don't have that module at all.
- else {
- *share = sub { return $_[0] };
- *lock = sub { 0 };
+ if (USE_THREADS) {
+ require Test2::IPC;
+ require Test2::IPC::Driver::Files;
+ Test2::IPC::Driver::Files->import;
+ Test2::API::test2_ipc_enable_polling();
+ Test2::API::test2_no_wait(1);
+ Test2::API::test2_ipc_enable_shm();
}
}
-=head1 NAME
-
-Test::Builder - Backend for building test libraries
+use Test2::Event::Subtest;
+use Test2::Hub::Subtest;
-=head1 SYNOPSIS
+use Test::Builder::Formatter;
+use Test::Builder::TodoDiag;
- package My::Test::Module;
- use base 'Test::Builder::Module';
+our $Level = 1;
+our $Test = Test::Builder->new;
- my $CLASS = __PACKAGE__;
+# Non-TB tools normally expect 0 added to the level. $Level is normally 1. So
+# we only want the level to change if $Level != 1.
+# TB->ctx compensates for this later.
+Test2::API::test2_add_callback_context_aquire(sub {$_[0]->{level} += $Level - 1});
- sub ok {
- my($test, $name) = @_;
- my $tb = $CLASS->builder;
+Test2::API::test2_add_callback_exit(sub { $Test->_ending(@_) });
- $tb->ok($test, $name);
- }
+Test2::API::test2_ipc()->set_no_fatal(1) if USE_THREADS;
+sub _add_ts_hooks {
+ my $self = shift;
+ my $hub = $self->{Stack}->top;
-=head1 DESCRIPTION
+ # Take a reference to the hash key, we do this to avoid closing over $self
+ # which is the singleton. We use a reference because the value could change
+ # in rare cases.
+ my $epkgr = \$self->{Exported_To};
-L<Test::Simple> and L<Test::More> have proven to be popular testing modules,
-but they're not always flexible enough. Test::Builder provides a
-building block upon which to write your own test libraries I<which can
-work together>.
+ #$hub->add_context_aquire(sub {$_[0]->{level} += $Level - 1});
-=head2 Construction
+ $hub->filter(sub {
+ my ($active_hub, $e) = @_;
-=over 4
+ my $epkg = $$epkgr;
+ my $cpkg = $e->{trace} ? $e->{trace}->{frame}->[0] : undef;
-=item B<new>
+ no strict 'refs';
+ no warnings 'once';
+ my $todo;
+ $todo = ${"$cpkg\::TODO"} if $cpkg;
+ $todo = ${"$epkg\::TODO"} if $epkg && !$todo;
- my $Test = Test::Builder->new;
+ return $e unless $todo;
-Returns a Test::Builder object representing the current state of the
-test.
-Since you only run one test per program C<new> always returns the same
-Test::Builder object. No matter how many times you call C<new()>, you're
-getting the same object. This is called a singleton. This is done so that
-multiple modules share such global information as the test counter and
-where test output is going.
+ # Turn a diag into a todo diag
+ return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag';
-If you want a completely new Test::Builder object different from the
-singleton, use C<create>.
+ # Set todo on ok's
+ if ($hub == $active_hub && $e->isa('Test2::Event::Ok')) {
+ $e->set_todo($todo);
+ $e->set_effective_pass(1);
-=cut
+ if (my $result = $e->get_meta(__PACKAGE__)) {
+ $result->{reason} ||= $todo;
+ $result->{type} ||= 'todo';
+ $result->{ok} = 1;
+ }
+ }
-our $Test = Test::Builder->new;
+ return $e;
+ });
+}
sub new {
my($class) = shift;
- $Test ||= $class->create;
+ unless($Test) {
+ my $ctx = context();
+ $Test = $class->create(singleton => 1);
+ $ctx->release;
+ }
return $Test;
}
-=item B<create>
-
- my $Test = Test::Builder->create;
-
-Ok, so there can be more than one Test::Builder object and this is how
-you get it. You might use this instead of C<new()> if you're testing
-a Test::Builder based module, but otherwise you probably want C<new>.
-
-B<NOTE>: the implementation is not complete. C<level>, for example, is
-still shared amongst B<all> Test::Builder objects, even ones created using
-this method. Also, the method name may change in the future.
-
-=cut
-
sub create {
my $class = shift;
+ my %params = @_;
my $self = bless {}, $class;
- $self->reset;
+ if ($params{singleton}) {
+ $self->{Stack} = Test2::API::test2_stack();
+ }
+ else {
+ $self->{Stack} = Test2::API::Stack->new;
+ $self->{Stack}->new_hub(
+ formatter => Test::Builder::Formatter->new,
+ ipc => Test2::API::test2_ipc(),
+ );
+ }
+ $self->reset(%params);
+ $self->_add_ts_hooks;
return $self;
}
-
-# Copy an object, currently a shallow.
-# This does *not* bless the destination. This keeps the destructor from
-# firing when we're just storing a copy of the object to restore later.
-sub _copy {
- my($src, $dest) = @_;
-
- %$dest = %$src;
- _share_keys($dest);
-
- return;
+sub ctx {
+ my $self = shift;
+ context(
+ # 1 for our frame, another for the -1 off of $Level in our hook at the top.
+ level => 2,
+ fudge => 1,
+ stack => $self->{Stack},
+ hub => $self->{Hub},
+ wrapped => 1,
+ @_
+ );
}
+sub parent {
+ my $self = shift;
+ my $ctx = $self->ctx;
+ my $chub = $self->{Hub} || $ctx->hub;
+ $ctx->release;
-=item B<child>
-
- my $child = $builder->child($name_of_child);
- $child->plan( tests => 4 );
- $child->ok(some_code());
- ...
- $child->finalize;
-
-Returns a new instance of C<Test::Builder>. Any output from this child will
-be indented four spaces more than the parent's indentation. When done, the
-C<finalize> method I<must> be called explicitly.
-
-Trying to create a new child with a previous child still active (i.e.,
-C<finalize> not called) will C<croak>.
+ my $parent = $chub->meta(__PACKAGE__, {})->{parent};
-Trying to run a test when you have an open child will also C<croak> and cause
-the test suite to fail.
+ return undef unless $parent;
-=cut
+ return bless {
+ Original_Pid => $$,
+ Stack => $self->{Stack},
+ Hub => $parent,
+ }, blessed($self);
+}
sub child {
my( $self, $name ) = @_;
- if( $self->{Child_Name} ) {
- $self->croak("You already have a child named ($self->{Child_Name}) running");
- }
+ $name ||= "Child of " . $self->name;
+ my $ctx = $self->ctx;
- my $parent_in_todo = $self->in_todo;
+ my $parent = $ctx->hub;
+ my $pmeta = $parent->meta(__PACKAGE__, {});
+ $self->croak("You already have a child named ($pmeta->{child}) running")
+ if $pmeta->{child};
+
+ $pmeta->{child} = $name;
# Clear $TODO for the child.
my $orig_TODO = $self->find_TODO(undef, 1, undef);
- my $class = ref $self;
- my $child = $class->create;
-
- # Add to our indentation
- $child->_indent( $self->_indent . ' ' );
+ my $subevents = [];
- # Make the child use the same outputs as the parent
- for my $method (qw(output failure_output todo_output)) {
- $child->$method( $self->$method );
- }
+ my $hub = $ctx->stack->new_hub(
+ class => 'Test2::Hub::Subtest',
+ );
- # Ensure the child understands if they're inside a TODO
- if( $parent_in_todo ) {
- $child->failure_output( $self->todo_output );
- }
+ $hub->filter(sub {
+ my ($active_hub, $e) = @_;
- # This will be reset in finalize. We do this here lest one child failure
- # cause all children to fail.
- $child->{Child_Error} = $?;
- $? = 0;
- $child->{Parent} = $self;
- $child->{Parent_TODO} = $orig_TODO;
- $child->{Name} = $name || "Child of " . $self->name;
- $self->{Child_Name} = $child->name;
- return $child;
-}
+ # Turn a diag into a todo diag
+ return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag';
+ return $e;
+ }) if $orig_TODO;
-=item B<subtest>
+ $hub->listen(sub { push @$subevents => $_[1] });
- $builder->subtest($name, \&subtests, @args);
+ $hub->set_nested( $parent->isa('Test2::Hub::Subtest') ? $parent->nested + 1 : 1 );
-See documentation of C<subtest> in Test::More.
+ my $meta = $hub->meta(__PACKAGE__, {});
+ $meta->{Name} = $name;
+ $meta->{TODO} = $orig_TODO;
+ $meta->{TODO_PKG} = $ctx->trace->package;
+ $meta->{parent} = $parent;
+ $meta->{Test_Results} = [];
+ $meta->{subevents} = $subevents;
+ $meta->{subtest_id} = $hub->id;
-C<subtest> also, and optionally, accepts arguments which will be passed to the
-subtests reference.
+ $self->_add_ts_hooks;
-=cut
+ $ctx->release;
+ return bless { Original_Pid => $$, Stack => $self->{Stack}, Hub => $hub }, blessed($self);
+}
-sub subtest {
+sub finalize {
my $self = shift;
- my($name, $subtests, @args) = @_;
-
- if ('CODE' ne ref $subtests) {
- $self->croak("subtest()'s second argument must be a code ref");
- }
-
- # Turn the child into the parent so anyone who has stored a copy of
- # the Test::Builder singleton will get the child.
- my $error;
- my $child;
- my $parent = {};
- {
- # child() calls reset() which sets $Level to 1, so we localize
- # $Level first to limit the scope of the reset to the subtest.
- local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my $ok = 1;
+ ($ok) = @_ if @_;
- # Store the guts of $self as $parent and turn $child into $self.
- $child = $self->child($name);
- _copy($self, $parent);
- _copy($child, $self);
-
- my $run_the_subtests = sub {
- # Add subtest name for clarification of starting point
- $self->note("Subtest: $name");
- $subtests->(@args);
- $self->done_testing unless $self->_plan_handled;
- 1;
- };
+ my $st_ctx = $self->ctx;
+ my $chub = $self->{Hub} || return $st_ctx->release;
- if( !eval { $run_the_subtests->() } ) {
- $error = $@;
- }
+ my $meta = $chub->meta(__PACKAGE__, {});
+ if ($meta->{child}) {
+ $self->croak("Can't call finalize() with child ($meta->{child}) active");
}
- # Restore the parent and the copied child.
- _copy($self, $child);
- _copy($parent, $self);
-
- # Restore the parent's $TODO
- $self->find_TODO(undef, 1, $child->{Parent_TODO});
-
- # Die *after* we restore the parent.
- die $error if $error and !eval { $error->isa('Test::Builder::Exception') };
-
- local $Test::Builder::Level = $Test::Builder::Level + 1;
- my $finalize = $child->finalize;
-
- $self->BAIL_OUT($child->{Bailed_Out_Reason}) if $child->{Bailed_Out};
-
- return $finalize;
-}
-
-=begin _private
-
-=item B<_plan_handled>
-
- if ( $Test->_plan_handled ) { ... }
-
-Returns true if the developer has explicitly handled the plan via:
-
-=over 4
-
-=item * Explicitly setting the number of tests
-
-=item * Setting 'no_plan'
-
-=item * Set 'skip_all'.
-
-=back
-
-This is currently used in subtests when we implicitly call C<< $Test->done_testing >>
-if the developer has not set a plan.
-
-=end _private
-
-=cut
-
-sub _plan_handled {
- my $self = shift;
- return $self->{Have_Plan} || $self->{No_Plan} || $self->{Skip_All};
-}
-
-
-=item B<finalize>
+ local $? = 0; # don't fail if $subtests happened to set $? nonzero
- my $ok = $child->finalize;
+ $self->{Stack}->pop($chub);
-When your child is done running tests, you must call C<finalize> to clean up
-and tell the parent your pass/fail status.
+ $self->find_TODO($meta->{TODO_PKG}, 1, $meta->{TODO});
-Calling C<finalize> on a child with open children will C<croak>.
+ my $parent = $self->parent;
+ my $ctx = $parent->ctx;
+ my $trace = $ctx->trace;
+ delete $ctx->hub->meta(__PACKAGE__, {})->{child};
-If the child falls out of scope before C<finalize> is called, a failure
-diagnostic will be issued and the child is considered to have failed.
+ $chub->finalize($trace, 1)
+ if $ok
+ && $chub->count
+ && !$chub->no_ending
+ && !$chub->ended;
-No attempt to call methods on a child after C<finalize> is called is
-guaranteed to succeed.
+ my $plan = $chub->plan || 0;
+ my $count = $chub->count;
+ my $failed = $chub->failed;
-Calling this on the root builder is a no-op.
+ my $num_extra = $plan =~ m/\D/ ? 0 : $count - $plan;
+ if ($count && $num_extra != 0) {
+ my $s = $plan == 1 ? '' : 's';
+ $st_ctx->diag(<<"FAIL");
+Looks like you planned $plan test$s but ran $count.
+FAIL
+ }
-=cut
+ if ($failed) {
+ my $s = $failed == 1 ? '' : 's';
-sub finalize {
- my $self = shift;
+ my $qualifier = $num_extra == 0 ? '' : ' run';
- return unless $self->parent;
- if( $self->{Child_Name} ) {
- $self->croak("Can't call finalize() with child ($self->{Child_Name}) active");
+ $st_ctx->diag(<<"FAIL");
+Looks like you failed $failed test$s of $count$qualifier.
+FAIL
}
- local $? = 0; # don't fail if $subtests happened to set $? nonzero
- $self->_ending;
-
- # XXX This will only be necessary for TAP envelopes (we think)
- #$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" );
+ $st_ctx->release;
- local $Test::Builder::Level = $Test::Builder::Level + 1;
- my $ok = 1;
- $self->parent->{Child_Name} = undef;
- unless ($self->{Bailed_Out}) {
- if ( $self->{Skip_All} ) {
- $self->parent->skip($self->{Skip_All}, $self->name);
+ unless ($chub->bailed_out) {
+ my $plan = $chub->plan;
+ if ( $plan && $plan eq 'SKIP' ) {
+ $parent->skip($chub->skip_reason, $meta->{Name});
}
- elsif ( not @{ $self->{Test_Results} } ) {
- $self->parent->ok( 0, sprintf q[No tests run for subtest "%s"], $self->name );
+ elsif ( !$chub->count ) {
+ $parent->ok( 0, sprintf q[No tests run for subtest "%s"], $meta->{Name} );
}
else {
- $self->parent->ok( $self->is_passing, $self->name );
+ $parent->{subevents} = $meta->{subevents};
+ $parent->{subtest_id} = $meta->{subtest_id};
+ $parent->ok( $chub->is_passing, $meta->{Name} );
}
}
- $? = $self->{Child_Error};
- delete $self->{Parent};
- return $self->is_passing;
+ $ctx->release;
+ return $chub->is_passing;
}
-sub _indent {
+sub subtest {
my $self = shift;
-
- if( @_ ) {
- $self->{Indent} = shift;
+ my ($name, $code, @args) = @_;
+ my $ctx = $self->ctx;
+ $ctx->throw("subtest()'s second argument must be a code ref")
+ unless $code && reftype($code) eq 'CODE';
+
+ $name ||= "Child of " . $self->name;
+
+ $ctx->note("Subtest: $name");
+
+ my $child = $self->child($name);
+
+ my $start_pid = $$;
+ my $st_ctx;
+ my ($ok, $err, $finished, $child_error);
+ T2_SUBTEST_WRAPPER: {
+ my $ctx = $self->ctx;
+ $st_ctx = $ctx->snapshot;
+ $ctx->release;
+ $ok = eval { local $Level = 1; $code->(@args); 1 };
+ ($err, $child_error) = ($@, $?);
+
+ # They might have done 'BEGIN { skip_all => "whatever" }'
+ if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/) {
+ $ok = undef;
+ $err = undef;
+ }
+ else {
+ $finished = 1;
+ }
}
- return $self->{Indent};
-}
-
-=item B<parent>
+ if ($start_pid != $$ && !$INC{'Test/Sync/IPC.pm'}) {
+ warn $ok ? "Forked inside subtest, but subtest never finished!\n" : $err;
+ exit 255;
+ }
- if ( my $parent = $builder->parent ) {
- ...
- }
+ my $trace = $ctx->trace;
-Returns the parent C<Test::Builder> instance, if any. Only used with child
-builders for nested TAP.
+ if (!$finished) {
+ if(my $bailed = $st_ctx->hub->bailed_out) {
+ my $chub = $child->{Hub};
+ $self->{Stack}->pop($chub);
+ $ctx->bail($bailed->reason);
+ }
+ my $code = $st_ctx->hub->exit_code;
+ $ok = !$code;
+ $err = "Subtest ended with exit code $code" if $code;
+ }
-=cut
+ my $st_hub = $st_ctx->hub;
+ my $plan = $st_hub->plan;
+ my $count = $st_hub->count;
-sub parent { shift->{Parent} }
+ if (!$count && (!defined($plan) || "$plan" ne 'SKIP')) {
+ $st_ctx->plan(0) unless defined $plan;
+ $st_ctx->diag('No tests run!');
+ }
-=item B<name>
+ $child->finalize($ok);
- diag $builder->name;
+ $ctx->release;
-Returns the name of the current builder. Top level builders default to C<$0>
-(the name of the executable). Child builders are named via the C<child>
-method. If no name is supplied, will be named "Child of $parent->name".
+ die $err unless $ok;
-=cut
+ $? = $child_error if defined $child_error;
-sub name { shift->{Name} }
+ return $st_hub->is_passing;
+}
-sub DESTROY {
+sub name {
my $self = shift;
- if ( $self->parent and $$ == $self->{Original_Pid} ) {
- my $name = $self->name;
- $self->diag(<<"FAIL");
-Child ($name) exited without calling finalize()
-FAIL
- $self->parent->{In_Destroy} = 1;
- $self->parent->ok(0, $name);
- }
+ my $ctx = $self->ctx;
+ release $ctx, $ctx->hub->meta(__PACKAGE__, {})->{Name};
}
-=item B<reset>
-
- $Test->reset;
-
-Reinitializes the Test::Builder singleton to its original state.
-Mostly useful for tests run in persistent environments where the same
-test might be run multiple times in the same process.
-
-=cut
-
-our $Level;
-
sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
- my($self) = @_;
+ my ($self, %params) = @_;
+
+ Test2::API::test2_set_is_end(0);
# We leave this a global because it has to be localized and localizing
# hash keys is just asking for pain. Also, it was documented.
$Level = 1;
- $self->{Name} = $0;
- $self->is_passing(1);
- $self->{Ending} = 0;
- $self->{Have_Plan} = 0;
- $self->{No_Plan} = 0;
- $self->{Have_Output_Plan} = 0;
- $self->{Done_Testing} = 0;
-
$self->{Original_Pid} = $$;
- $self->{Child_Name} = undef;
- $self->{Indent} ||= '';
-
- $self->{Curr_Test} = 0;
- $self->{Test_Results} = &share( [] );
-
- $self->{Exported_To} = undef;
- $self->{Expected_Tests} = 0;
- $self->{Skip_All} = 0;
-
- $self->{Use_Nums} = 1;
-
- $self->{No_Header} = 0;
- $self->{No_Ending} = 0;
-
- $self->{Todo} = undef;
- $self->{Todo_Stack} = [];
- $self->{Start_Todo} = 0;
- $self->{Opened_Testhandles} = 0;
+ my $ctx = $self->ctx;
+ unless ($params{singleton}) {
+ $ctx->hub->reset_state();
+ $ctx->hub->set_pid($$);
+ $ctx->hub->set_tid(get_tid);
+ }
- $self->_share_keys;
- $self->_dup_stdhandles;
+ my $meta = $ctx->hub->meta(__PACKAGE__, {});
+ %$meta = (
+ Name => $0,
+ Ending => 0,
+ Done_Testing => undef,
+ Skip_All => 0,
+ Test_Results => [],
+ );
- return;
-}
+ $self->{Exported_To} = undef;
+ $self->{Orig_Handles} ||= do {
+ my $format = $ctx->hub->format;
+ my $out;
+ if ($format && $format->isa('Test2::Formatter::TAP')) {
+ $out = $format->handles;
+ }
+ $out ? [@$out] : [];
+ };
-# Shared scalar values are lost when a hash is copied, so we have
-# a separate method to restore them.
-# Shared references are retained across copies.
-sub _share_keys {
- my $self = shift;
+ $self->use_numbers(1);
+ $self->no_header(0);
+ $self->no_ending(0);
+ $self->reset_outputs;
- share( $self->{Curr_Test} );
+ $ctx->release;
return;
}
-=back
-
-=head2 Setting up tests
-
-These methods are for setting up tests and declaring how many there
-are. You usually only want to call one of these methods.
-
-=over 4
-
-=item B<plan>
-
- $Test->plan('no_plan');
- $Test->plan( skip_all => $reason );
- $Test->plan( tests => $num_tests );
-
-A convenient way to set up your tests. Call this and Test::Builder
-will print the appropriate headers and take the appropriate actions.
-
-If you call C<plan()>, don't call any of the other methods below.
-
-If a child calls "skip_all" in the plan, a C<Test::Builder::Exception> is
-thrown. Trap this error, call C<finalize()> and don't run any more tests on
-the child.
-
- my $child = $Test->child('some child');
- eval { $child->plan( $condition ? ( skip_all => $reason ) : ( tests => 3 ) ) };
- if ( eval { $@->isa('Test::Builder::Exception') } ) {
- $child->finalize;
- return;
- }
- # run your tests
-
-=cut
-
my %plan_cmds = (
- no_plan => \&no_plan,
- skip_all => \&skip_all,
- tests => \&_plan_tests,
+ no_plan => \&no_plan,
+ skip_all => \&skip_all,
+ tests => \&_plan_tests,
);
sub plan {
return unless $cmd;
- local $Level = $Level + 1;
+ my $ctx = $self->ctx;
+ my $hub = $ctx->hub;
- $self->croak("You tried to plan twice") if $self->{Have_Plan};
+ $ctx->throw("You tried to plan twice") if $hub->plan;
+
+ local $Level = $Level + 1;
if( my $method = $plan_cmds{$cmd} ) {
local $Level = $Level + 1;
}
else {
my @args = grep { defined } ( $cmd, $arg );
- $self->croak("plan() doesn't understand @args");
+ $ctx->throw("plan() doesn't understand @args");
}
- return 1;
+ release $ctx, 1;
}
sub _plan_tests {
my($self, $arg) = @_;
+ my $ctx = $self->ctx;
+
if($arg) {
local $Level = $Level + 1;
- return $self->expected_tests($arg);
+ $self->expected_tests($arg);
}
elsif( !defined $arg ) {
- $self->croak("Got an undefined number of tests");
+ $ctx->throw("Got an undefined number of tests");
}
else {
- $self->croak("You said to run 0 tests");
+ $ctx->throw("You said to run 0 tests");
}
- return;
+ $ctx->release;
}
-=item B<expected_tests>
-
- my $max = $Test->expected_tests;
- $Test->expected_tests($max);
-
-Gets/sets the number of tests we expect this test to run and prints out
-the appropriate headers.
-
-=cut
sub expected_tests {
my $self = shift;
my($max) = @_;
+ my $ctx = $self->ctx;
+
if(@_) {
$self->croak("Number of tests must be a positive integer. You gave it '$max'")
unless $max =~ /^\+?\d+$/;
- $self->{Expected_Tests} = $max;
- $self->{Have_Plan} = 1;
-
- $self->_output_plan($max) unless $self->no_header;
+ $ctx->plan($max);
}
- return $self->{Expected_Tests};
-}
-=item B<no_plan>
+ my $hub = $ctx->hub;
- $Test->no_plan;
+ $ctx->release;
-Declares that this test will run an indeterminate number of tests.
+ my $plan = $hub->plan;
+ return 0 unless $plan;
+ return 0 if $plan =~ m/\D/;
+ return $plan;
+}
-=cut
sub no_plan {
my($self, $arg) = @_;
- $self->carp("no_plan takes no arguments") if $arg;
+ my $ctx = $self->ctx;
- $self->{No_Plan} = 1;
- $self->{Have_Plan} = 1;
+ $ctx->alert("no_plan takes no arguments") if $arg;
- return 1;
-}
+ $ctx->hub->plan('NO PLAN');
-=begin private
+ release $ctx, 1;
+}
-=item B<_output_plan>
- $tb->_output_plan($max);
- $tb->_output_plan($max, $directive);
- $tb->_output_plan($max, $directive => $reason);
+sub done_testing {
+ my($self, $num_tests) = @_;
-Handles displaying the test plan.
+ my $ctx = $self->ctx;
-If a C<$directive> and/or C<$reason> are given they will be output with the
-plan. So here's what skipping all tests looks like:
+ my $meta = $ctx->hub->meta(__PACKAGE__, {});
- $tb->_output_plan(0, "SKIP", "Because I said so");
+ if ($meta->{Done_Testing}) {
+ my ($file, $line) = @{$meta->{Done_Testing}}[1,2];
+ local $ctx->hub->{ended}; # OMG This is awful.
+ $self->ok(0, "done_testing() was already called at $file line $line");
+ $ctx->release;
+ return;
+ }
+ $meta->{Done_Testing} = [$ctx->trace->call];
-It sets C<< $tb->{Have_Output_Plan} >> and will croak if the plan was already
-output.
+ my $plan = $ctx->hub->plan;
+ my $count = $ctx->hub->count;
-=end private
-
-=cut
-
-sub _output_plan {
- my($self, $max, $directive, $reason) = @_;
-
- $self->carp("The plan was already output") if $self->{Have_Output_Plan};
-
- my $plan = "1..$max";
- $plan .= " # $directive" if defined $directive;
- $plan .= " $reason" if defined $reason;
-
- $self->_print("$plan\n");
-
- $self->{Have_Output_Plan} = 1;
-
- return;
-}
-
-
-=item B<done_testing>
-
- $Test->done_testing();
- $Test->done_testing($num_tests);
-
-Declares that you are done testing, no more tests will be run after this point.
-
-If a plan has not yet been output, it will do so.
-
-$num_tests is the number of tests you planned to run. If a numbered
-plan was already declared, and if this contradicts, a failing test
-will be run to reflect the planning mistake. If C<no_plan> was declared,
-this will override.
-
-If C<done_testing()> is called twice, the second call will issue a
-failing test.
-
-If C<$num_tests> is omitted, the number of tests run will be used, like
-no_plan.
-
-C<done_testing()> is, in effect, used when you'd want to use C<no_plan>, but
-safer. You'd use it like so:
-
- $Test->ok($a == $b);
- $Test->done_testing();
-
-Or to plan a variable number of tests:
-
- for my $test (@tests) {
- $Test->ok($test);
- }
- $Test->done_testing(scalar @tests);
-
-=cut
-
-sub done_testing {
- my($self, $num_tests) = @_;
-
- # If done_testing() specified the number of tests, shut off no_plan.
+ # If done_testing() specified the number of tests, shut off no_plan
if( defined $num_tests ) {
- $self->{No_Plan} = 0;
+ $ctx->plan($num_tests) if !$plan || $plan eq 'NO PLAN';
+ }
+ elsif ($count && defined $num_tests && $count != $num_tests) {
+ $self->ok(0, "planned to run @{[ $self->expected_tests ]} but done_testing() expects $num_tests");
}
else {
$num_tests = $self->current_test;
}
- if( $self->{Done_Testing} ) {
- my($file, $line) = @{$self->{Done_Testing}}[1,2];
- $self->ok(0, "done_testing() was already called at $file line $line");
- return;
- }
-
- $self->{Done_Testing} = [caller];
-
if( $self->expected_tests && $num_tests != $self->expected_tests ) {
$self->ok(0, "planned to run @{[ $self->expected_tests ]} ".
"but done_testing() expects $num_tests");
}
- else {
- $self->{Expected_Tests} = $num_tests;
- }
-
- $self->_output_plan($num_tests) unless $self->{Have_Output_Plan};
-
- $self->{Have_Plan} = 1;
- # The wrong number of tests were run
- $self->is_passing(0) if $self->{Expected_Tests} != $self->{Curr_Test};
+ $ctx->plan($num_tests) if $ctx->hub->plan && $ctx->hub->plan eq 'NO PLAN';
- # No tests were run
- $self->is_passing(0) if $self->{Curr_Test} == 0;
+ $ctx->hub->finalize($ctx->trace, 1);
- return 1;
+ release $ctx, 1;
}
-=item B<has_plan>
-
- $plan = $Test->has_plan
-
-Find out whether a plan has been defined. C<$plan> is either C<undef> (no plan
-has been set), C<no_plan> (indeterminate # of tests) or an integer (the number
-of expected tests).
-
-=cut
-
sub has_plan {
my $self = shift;
- return( $self->{Expected_Tests} ) if $self->{Expected_Tests};
- return('no_plan') if $self->{No_Plan};
+ my $ctx = $self->ctx;
+ my $plan = $ctx->hub->plan;
+ $ctx->release;
+
+ return( $plan ) if $plan && $plan !~ m/\D/;
+ return('no_plan') if $plan && $plan eq 'NO PLAN';
return(undef);
}
-=item B<skip_all>
-
- $Test->skip_all;
- $Test->skip_all($reason);
-
-Skips all the tests, using the given C<$reason>. Exits immediately with 0.
-
-=cut
sub skip_all {
my( $self, $reason ) = @_;
- $self->{Skip_All} = $self->parent ? $reason : 1;
+ my $ctx = $self->ctx;
- $self->_output_plan(0, "SKIP", $reason) unless $self->no_header;
- if ( $self->parent ) {
- die bless {} => 'Test::Builder::Exception';
- }
- exit(0);
-}
-
-=item B<exported_to>
+ $ctx->hub->meta(__PACKAGE__, {})->{Skip_All} = $reason || 1;
- my $pack = $Test->exported_to;
- $Test->exported_to($pack);
-
-Tells Test::Builder what package you exported your functions to.
+ # Work around old perl bug
+ if ($] < 5.020000) {
+ my $begin = 0;
+ my $level = 0;
+ while (my @call = caller($level++)) {
+ last unless @call && $call[0];
+ next unless $call[3] =~ m/::BEGIN$/;
+ $begin++;
+ last;
+ }
+ # HACK!
+ die 'Label not found for "last T2_SUBTEST_WRAPPER"' if $begin && $ctx->hub->meta(__PACKAGE__, {})->{parent};
+ }
-This method isn't terribly useful since modules which share the same
-Test::Builder object might get exported to different packages and only
-the last one will be honored.
+ $ctx->plan(0, SKIP => $reason);
+}
-=cut
sub exported_to {
my( $self, $pack ) = @_;
return $self->{Exported_To};
}
-=back
-
-=head2 Running tests
-
-These actually run the tests, analogous to the functions in Test::More.
-
-They all return true if the test passed, false if the test failed.
-
-C<$name> is always optional.
-
-=over 4
-
-=item B<ok>
-
- $Test->ok($test, $name);
-
-Your basic test. Pass if C<$test> is true, fail if $test is false. Just
-like Test::Simple's C<ok()>.
-
-=cut
sub ok {
my( $self, $test, $name ) = @_;
- if ( $self->{Child_Name} and not $self->{In_Destroy} ) {
- $name = 'unnamed test' unless defined $name;
- $self->is_passing(0);
- $self->croak("Cannot run test ($name) with active children");
- }
+ my $ctx = $self->ctx;
+
# $test might contain an object which we don't want to accidentally
# store, so we turn it into a boolean.
$test = $test ? 1 : 0;
- lock $self->{Curr_Test};
- $self->{Curr_Test}++;
-
# In case $name is a string overloaded object, force it to stringify.
- $self->_unoverload_str( \$name );
+ no warnings qw/uninitialized numeric/;
+ $name = "$name" if defined $name;
- $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/;
+ # Profiling showed that the regex here was a huge time waster, doing the
+ # numeric addition first cuts our profile time from ~300ms to ~50ms
+ $self->diag(<<" ERR") if 0 + $name && $name =~ /^[\d\s]+$/;
You named your test '$name'. You shouldn't use numbers for your test names.
Very confusing.
-ERR
-
- # Capture the value of $TODO for the rest of this ok() call
- # so it can more easily be found by other routines.
- my $todo = $self->todo();
- my $in_todo = $self->in_todo;
- local $self->{Todo} = $todo if $in_todo;
-
- $self->_unoverload_str( \$todo );
-
- my $out;
- my $result = &share( {} );
-
- unless($test) {
- $out .= "not ";
- @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 );
- }
- else {
- @$result{ 'ok', 'actual_ok' } = ( 1, $test );
- }
-
- $out .= "ok";
- $out .= " $self->{Curr_Test}" if $self->use_numbers;
-
- if( defined $name ) {
- $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
- $out .= " - $name";
- $result->{name} = $name;
- }
- else {
- $result->{name} = '';
- }
-
- if( $self->in_todo ) {
- $out .= " # TODO $todo";
- $result->{reason} = $todo;
- $result->{type} = 'todo';
- }
- else {
- $result->{reason} = '';
- $result->{type} = '';
- }
+ ERR
+ use warnings qw/uninitialized numeric/;
+
+ my $trace = $ctx->{trace};
+ my $hub = $ctx->{hub};
+
+ my $result = {
+ ok => $test,
+ actual_ok => $test,
+ reason => '',
+ type => '',
+ (name => defined($name) ? $name : ''),
+ };
- $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
- $out .= "\n";
+ $hub->{_meta}->{+__PACKAGE__}->{Test_Results}[ $hub->{count} ] = $result;
- $self->_print($out);
+ my $orig_name = $name;
- unless($test) {
- my $msg = $self->in_todo ? "Failed (TODO)" : "Failed";
- $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE};
+ # The regex form is ~250ms, the index form is ~50ms
+ #$name && $name =~ m/(?:#|\n)/ && ($name =~ s|#|\\#|g, $name =~ s{\n}{\n# }sg);
+ $name && (
+ (index($name, "#" ) >= 0 && $name =~ s|#|\\#|g),
+ (index($name, "\n") >= 0 && $name =~ s{\n}{\n# }sg)
+ );
- my( undef, $file, $line ) = $self->caller;
- if( defined $name ) {
- $self->diag(qq[ $msg test '$name'\n]);
- $self->diag(qq[ at $file line $line.\n]);
- }
- else {
- $self->diag(qq[ $msg test at $file line $line.\n]);
- }
+ my @attrs;
+ my $subevents = delete $self->{subevents};
+ my $subtest_id = delete $self->{subtest_id};
+ my $epkg = 'Test2::Event::Ok';
+ if ($subevents) {
+ $epkg = 'Test2::Event::Subtest';
+ push @attrs => (subevents => $subevents, subtest_id => $subtest_id);
}
- $self->is_passing(0) unless $test || $self->in_todo;
+ my $e = bless {
+ trace => bless( {%$trace}, 'Test2::Util::Trace'),
+ pass => $test,
+ name => $name,
+ _meta => {'Test::Builder' => $result},
+ effective_pass => $test,
+ @attrs,
+ }, $epkg;
+ $hub->send($e);
- # Check that we haven't violated the plan
- $self->_check_is_passing_plan();
+ $self->_ok_debug($trace, $orig_name) unless($test);
- return $test ? 1 : 0;
+ $ctx->release;
+ return $test;
}
-
-# Check that we haven't yet violated the plan and set
-# is_passing() accordingly
-sub _check_is_passing_plan {
+sub _ok_debug {
my $self = shift;
+ my ($trace, $orig_name) = @_;
- my $plan = $self->has_plan;
- return unless defined $plan; # no plan yet defined
- return unless $plan !~ /\D/; # no numeric plan
- $self->is_passing(0) if $plan < $self->{Curr_Test};
-}
-
+ my $is_todo = defined($self->todo);
-sub _unoverload {
- my $self = shift;
- my $type = shift;
+ my $msg = $is_todo ? "Failed (TODO)" : "Failed";
- $self->_try(sub { require overload; }, die_on_fail => 1);
+ my $dfh = $self->_diag_fh;
+ print $dfh "\n" if $ENV{HARNESS_ACTIVE} && $dfh;
- foreach my $thing (@_) {
- if( $self->_is_object($$thing) ) {
- if( my $string_meth = overload::Method( $$thing, $type ) ) {
- $$thing = $$thing->$string_meth();
- }
- }
+ my (undef, $file, $line) = $trace->call;
+ if (defined $orig_name) {
+ $self->diag(qq[ $msg test '$orig_name'\n]);
+ $self->diag(qq[ at $file line $line.\n]);
+ }
+ else {
+ $self->diag(qq[ $msg test at $file line $line.\n]);
}
+}
- return;
+sub _diag_fh {
+ my $self = shift;
+ local $Level = $Level + 1;
+ return $self->in_todo ? $self->todo_output : $self->failure_output;
}
-sub _is_object {
- my( $self, $thing ) = @_;
+sub _unoverload {
+ my ($self, $type, $thing) = @_;
- return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0;
+ return unless ref $$thing;
+ return unless blessed($$thing) || scalar $self->_try(sub{ $$thing->isa('UNIVERSAL') });
+ my $string_meth = overload::Method( $$thing, $type ) || return;
+ $$thing = $$thing->$string_meth();
}
sub _unoverload_str {
my $self = shift;
- return $self->_unoverload( q[""], @_ );
+ $self->_unoverload( q[""], $_ ) for @_;
}
sub _unoverload_num {
my $self = shift;
- $self->_unoverload( '0+', @_ );
+ $self->_unoverload( '0+', $_ ) for @_;
for my $val (@_) {
next unless $self->_is_dualvar($$val);
$$val = $$val + 0;
}
-
- return;
}
# This is a hack to detect a dualvar such as $!
return ($numval != 0 and $numval ne $val ? 1 : 0);
}
-=item B<is_eq>
-
- $Test->is_eq($got, $expected, $name);
-
-Like Test::More's C<is()>. Checks if C<$got eq $expected>. This is the
-string version.
-
-C<undef> only ever matches another C<undef>.
-
-=item B<is_num>
-
- $Test->is_num($got, $expected, $name);
-
-Like Test::More's C<is()>. Checks if C<$got == $expected>. This is the
-numeric version.
-
-C<undef> only ever matches another C<undef>.
-
-=cut
sub is_eq {
my( $self, $got, $expect, $name ) = @_;
+
+ my $ctx = $self->ctx;
+
local $Level = $Level + 1;
if( !defined $got || !defined $expect ) {
$self->ok( $test, $name );
$self->_is_diag( $got, 'eq', $expect ) unless $test;
+ $ctx->release;
return $test;
}
- return $self->cmp_ok( $got, 'eq', $expect, $name );
+ release $ctx, $self->cmp_ok( $got, 'eq', $expect, $name );
}
+
sub is_num {
my( $self, $got, $expect, $name ) = @_;
+ my $ctx = $self->ctx;
local $Level = $Level + 1;
if( !defined $got || !defined $expect ) {
$self->ok( $test, $name );
$self->_is_diag( $got, '==', $expect ) unless $test;
+ $ctx->release;
return $test;
}
- return $self->cmp_ok( $got, '==', $expect, $name );
+ release $ctx, $self->cmp_ok( $got, '==', $expect, $name );
}
+
sub _diag_fmt {
my( $self, $type, $val ) = @_;
return;
}
+
sub _is_diag {
my( $self, $got, $type, $expect ) = @_;
DIAGNOSTIC
}
-=item B<isnt_eq>
-
- $Test->isnt_eq($got, $dont_expect, $name);
-
-Like L<Test::More>'s C<isnt()>. Checks if C<$got ne $dont_expect>. This is
-the string version.
-
-=item B<isnt_num>
-
- $Test->isnt_num($got, $dont_expect, $name);
-
-Like L<Test::More>'s C<isnt()>. Checks if C<$got ne $dont_expect>. This is
-the numeric version.
-
-=cut
sub isnt_eq {
my( $self, $got, $dont_expect, $name ) = @_;
+ my $ctx = $self->ctx;
local $Level = $Level + 1;
if( !defined $got || !defined $dont_expect ) {
$self->ok( $test, $name );
$self->_isnt_diag( $got, 'ne' ) unless $test;
+ $ctx->release;
return $test;
}
- return $self->cmp_ok( $got, 'ne', $dont_expect, $name );
+ release $ctx, $self->cmp_ok( $got, 'ne', $dont_expect, $name );
}
sub isnt_num {
my( $self, $got, $dont_expect, $name ) = @_;
+ my $ctx = $self->ctx;
local $Level = $Level + 1;
if( !defined $got || !defined $dont_expect ) {
$self->ok( $test, $name );
$self->_isnt_diag( $got, '!=' ) unless $test;
+ $ctx->release;
return $test;
}
- return $self->cmp_ok( $got, '!=', $dont_expect, $name );
+ release $ctx, $self->cmp_ok( $got, '!=', $dont_expect, $name );
}
-=item B<like>
-
- $Test->like($thing, qr/$regex/, $name);
- $Test->like($thing, '/$regex/', $name);
-
-Like L<Test::More>'s C<like()>. Checks if $thing matches the given C<$regex>.
-
-=item B<unlike>
-
- $Test->unlike($thing, qr/$regex/, $name);
- $Test->unlike($thing, '/$regex/', $name);
-
-Like L<Test::More>'s C<unlike()>. Checks if $thing B<does not match> the
-given C<$regex>.
-
-=cut
sub like {
my( $self, $thing, $regex, $name ) = @_;
+ my $ctx = $self->ctx;
local $Level = $Level + 1;
- return $self->_regex_ok( $thing, $regex, '=~', $name );
+
+ release $ctx, $self->_regex_ok( $thing, $regex, '=~', $name );
}
sub unlike {
my( $self, $thing, $regex, $name ) = @_;
+ my $ctx = $self->ctx;
local $Level = $Level + 1;
- return $self->_regex_ok( $thing, $regex, '!~', $name );
-}
-
-=item B<cmp_ok>
- $Test->cmp_ok($thing, $type, $that, $name);
-
-Works just like L<Test::More>'s C<cmp_ok()>.
-
- $Test->cmp_ok($big_num, '!=', $other_big_num);
+ release $ctx, $self->_regex_ok( $thing, $regex, '!~', $name );
+}
-=cut
my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
sub cmp_ok {
my( $self, $got, $type, $expect, $name ) = @_;
+ my $ctx = $self->ctx;
if ($cmp_ok_bl{$type}) {
- $self->croak("$type is not a valid comparison operator in cmp_ok()");
+ $ctx->throw("$type is not a valid comparison operator in cmp_ok()");
}
my ($test, $succ);
local( $@, $!, $SIG{__DIE__} ); # isolate eval
- my($pack, $file, $line) = $self->caller();
+ my($pack, $file, $line) = $ctx->trace->call();
# This is so that warnings come out at the caller's level
$succ = eval qq[
$self->_cmp_diag( $got, $type, $expect );
}
}
- return $ok;
+ return release $ctx, $ok;
}
sub _cmp_diag {
return $code;
}
-=back
-
-=head2 Other Testing Methods
+sub BAIL_OUT {
+ my( $self, $reason ) = @_;
-These are methods which are used in the course of writing a test but are not themselves tests.
+ my $ctx = $self->ctx;
-=over 4
+ $self->{Bailed_Out} = 1;
-=item B<BAIL_OUT>
+ $ctx->bail($reason);
+}
- $Test->BAIL_OUT($reason);
-Indicates to the L<Test::Harness> that things are going so badly all
-testing should terminate. This includes running any additional test
-scripts.
+{
+ no warnings 'once';
+ *BAILOUT = \&BAIL_OUT;
+}
-It will exit with 255.
+sub skip {
+ my( $self, $why, $name ) = @_;
+ $why ||= '';
+ $name = '' unless defined $name;
+ $self->_unoverload_str( \$why );
-=cut
+ my $ctx = $self->ctx;
-sub BAIL_OUT {
- my( $self, $reason ) = @_;
+ $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}[ $ctx->hub->count ] = {
+ 'ok' => 1,
+ actual_ok => 1,
+ name => $name,
+ type => 'skip',
+ reason => $why,
+ };
- $self->{Bailed_Out} = 1;
+ $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
+ $name =~ s{\n}{\n# }sg;
+ $why =~ s{\n}{\n# }sg;
- if ($self->parent) {
- $self->{Bailed_Out_Reason} = $reason;
- $self->no_ending(1);
- die bless {} => 'Test::Builder::Exception';
- }
+ my $tctx = $ctx->snapshot;
+ $tctx->skip('', $why);
- $self->_print("Bail out! $reason");
- exit 255;
+ return release $ctx, 1;
}
-=for deprecated
-BAIL_OUT() used to be BAILOUT()
-
-=cut
-
-{
- no warnings 'once';
- *BAILOUT = \&BAIL_OUT;
-}
-
-=item B<skip>
-
- $Test->skip;
- $Test->skip($why);
-
-Skips the current test, reporting C<$why>.
-
-=cut
-
-sub skip {
- my( $self, $why, $name ) = @_;
- $why ||= '';
- $name = '' unless defined $name;
- $self->_unoverload_str( \$why );
-
- lock( $self->{Curr_Test} );
- $self->{Curr_Test}++;
-
- $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
- {
- 'ok' => 1,
- actual_ok => 1,
- name => $name,
- type => 'skip',
- reason => $why,
- }
- );
-
- my $out = "ok";
- $out .= " $self->{Curr_Test}" if $self->use_numbers;
- $out .= " # skip";
- $out .= " $why" if length $why;
- $out .= "\n";
-
- $self->_print($out);
-
- return 1;
-}
-
-=item B<todo_skip>
-
- $Test->todo_skip;
- $Test->todo_skip($why);
-
-Like C<skip()>, only it will declare the test as failing and TODO. Similar
-to
-
- print "not ok $tnum # TODO $why\n";
-
-=cut
sub todo_skip {
my( $self, $why ) = @_;
$why ||= '';
- lock( $self->{Curr_Test} );
- $self->{Curr_Test}++;
-
- $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
- {
- 'ok' => 1,
- actual_ok => 0,
- name => '',
- type => 'todo_skip',
- reason => $why,
- }
- );
+ my $ctx = $self->ctx;
- my $out = "not ok";
- $out .= " $self->{Curr_Test}" if $self->use_numbers;
- $out .= " # TODO & SKIP $why\n";
+ $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}[ $ctx->hub->count ] = {
+ 'ok' => 1,
+ actual_ok => 0,
+ name => '',
+ type => 'todo_skip',
+ reason => $why,
+ };
- $self->_print($out);
+ $why =~ s{\n}{\n# }sg;
+ my $tctx = $ctx->snapshot;
+ $tctx->send_event( 'Skip', todo => $why, todo_diag => 1, reason => $why, pass => 0);
- return 1;
+ return release $ctx, 1;
}
-=begin _unimplemented
-
-=item B<skip_rest>
-
- $Test->skip_rest;
- $Test->skip_rest($reason);
-
-Like C<skip()>, only it skips all the rest of the tests you plan to run
-and terminates the test.
-
-If you're running under C<no_plan>, it skips once and terminates the
-test.
-
-=end _unimplemented
-
-=back
-
-
-=head2 Test building utility methods
-
-These methods are useful when writing your own test methods.
-
-=over 4
-
-=item B<maybe_regex>
-
- $Test->maybe_regex(qr/$regex/);
- $Test->maybe_regex('/$regex/');
-
-This method used to be useful back when Test::Builder worked on Perls
-before 5.6 which didn't have qr//. Now its pretty useless.
-
-Convenience method for building testing functions that take regular
-expressions as arguments.
-
-Takes a quoted regular expression produced by C<qr//>, or a string
-representing a regular expression.
-
-Returns a Perl value which may be used instead of the corresponding
-regular expression, or C<undef> if its argument is not recognised.
-
-For example, a version of C<like()>, sans the useful diagnostic messages,
-could be written as:
-
- sub laconic_like {
- my ($self, $thing, $regex, $name) = @_;
- my $usable_regex = $self->maybe_regex($regex);
- die "expecting regex, found '$regex'\n"
- unless $usable_regex;
- $self->ok($thing =~ m/$usable_regex/, $name);
- }
-
-=cut
sub maybe_regex {
my( $self, $regex ) = @_;
return $ok;
}
-# I'm not ready to publish this. It doesn't deal with array return
-# values from the code or context.
-=begin private
+sub is_fh {
+ my $self = shift;
+ my $maybe_fh = shift;
+ return 0 unless defined $maybe_fh;
+
+ return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
+ return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
+
+ return eval { $maybe_fh->isa("IO::Handle") } ||
+ eval { tied($maybe_fh)->can('TIEHANDLE') };
+}
+
+
+sub level {
+ my( $self, $level ) = @_;
+
+ if( defined $level ) {
+ $Level = $level;
+ }
+ return $Level;
+}
+
+
+sub use_numbers {
+ my( $self, $use_nums ) = @_;
+
+ my $ctx = $self->ctx;
+ my $format = $ctx->hub->format;
+ unless ($format && $format->can('no_numbers') && $format->can('set_no_numbers')) {
+ warn "The current formatter does not support 'use_numbers'" if $format;
+ return release $ctx, 0;
+ }
+
+ $format->set_no_numbers(!$use_nums) if defined $use_nums;
+
+ return release $ctx, $format->no_numbers ? 0 : 1;
+}
+
+BEGIN {
+ for my $method (qw(no_header no_diag)) {
+ my $set = "set_$method";
+ my $code = sub {
+ my( $self, $no ) = @_;
+
+ my $ctx = $self->ctx;
+ my $format = $ctx->hub->format;
+ unless ($format && $format->isa('Test2::Formatter::TAP') && $format->can($set)) {
+ warn "The current formatter does not support '$method'" if $format;
+ $ctx->release;
+ return
+ }
+
+ $format->$set($no) if defined $no;
+
+ return release $ctx, $format->$method ? 1 : 0;
+ };
+
+ no strict 'refs'; ## no critic
+ *$method = $code;
+ }
+}
+
+sub no_ending {
+ my( $self, $no ) = @_;
+
+ my $ctx = $self->ctx;
+
+ $ctx->hub->set_no_ending($no) if defined $no;
+
+ return release $ctx, $ctx->hub->no_ending;
+}
+
+sub diag {
+ my $self = shift;
+ return unless @_;
+
+ my $ctx = $self->ctx;
+ $ctx->diag(join '' => map {defined($_) ? $_ : 'undef'} @_);
+ $ctx->release;
+}
+
+
+sub note {
+ my $self = shift;
+ return unless @_;
+
+ my $ctx = $self->ctx;
+ $ctx->note(join '' => map {defined($_) ? $_ : 'undef'} @_);
+ $ctx->release;
+}
+
+
+sub explain {
+ my $self = shift;
+
+ local ($@, $!);
+ require Data::Dumper;
+
+ return map {
+ ref $_
+ ? do {
+ my $dumper = Data::Dumper->new( [$_] );
+ $dumper->Indent(1)->Terse(1);
+ $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
+ $dumper->Dump;
+ }
+ : $_
+ } @_;
+}
+
+
+sub output {
+ my( $self, $fh ) = @_;
+
+ my $ctx = $self->ctx;
+ my $format = $ctx->hub->format;
+ $ctx->release;
+ return unless $format && $format->isa('Test2::Formatter::TAP');
+
+ $format->handles->[Test2::Formatter::TAP::OUT_STD()] = $self->_new_fh($fh)
+ if defined $fh;
+
+ return $format->handles->[Test2::Formatter::TAP::OUT_STD()];
+}
+
+sub failure_output {
+ my( $self, $fh ) = @_;
+
+ my $ctx = $self->ctx;
+ my $format = $ctx->hub->format;
+ $ctx->release;
+ return unless $format && $format->isa('Test2::Formatter::TAP');
+
+ $format->handles->[Test2::Formatter::TAP::OUT_ERR()] = $self->_new_fh($fh)
+ if defined $fh;
+
+ return $format->handles->[Test2::Formatter::TAP::OUT_ERR()];
+}
+
+sub todo_output {
+ my( $self, $fh ) = @_;
+
+ my $ctx = $self->ctx;
+ my $format = $ctx->hub->format;
+ $ctx->release;
+ return unless $format && $format->isa('Test::Builder::Formatter');
+
+ $format->handles->[Test::Builder::Formatter::OUT_TODO()] = $self->_new_fh($fh)
+ if defined $fh;
+
+ return $format->handles->[Test::Builder::Formatter::OUT_TODO()];
+}
+
+sub _new_fh {
+ my $self = shift;
+ my($file_or_fh) = shift;
+
+ my $fh;
+ if( $self->is_fh($file_or_fh) ) {
+ $fh = $file_or_fh;
+ }
+ elsif( ref $file_or_fh eq 'SCALAR' ) {
+ # Scalar refs as filehandles was added in 5.8.
+ if( $] >= 5.008 ) {
+ open $fh, ">>", $file_or_fh
+ or $self->croak("Can't open scalar ref $file_or_fh: $!");
+ }
+ # Emulate scalar ref filehandles with a tie.
+ else {
+ $fh = Test::Builder::IO::Scalar->new($file_or_fh)
+ or $self->croak("Can't tie scalar ref $file_or_fh");
+ }
+ }
+ else {
+ open $fh, ">", $file_or_fh
+ or $self->croak("Can't open test output log $file_or_fh: $!");
+ _autoflush($fh);
+ }
+
+ return $fh;
+}
+
+sub _autoflush {
+ my($fh) = shift;
+ my $old_fh = select $fh;
+ $| = 1;
+ select $old_fh;
+
+ return;
+}
+
+
+sub reset_outputs {
+ my $self = shift;
+
+ my $ctx = $self->ctx;
+ my $format = $ctx->hub->format;
+ $ctx->release;
+ return unless $format && $format->isa('Test2::Formatter::TAP');
+ $format->set_handles([@{$self->{Orig_Handles}}]) if $self->{Orig_Handles};
+
+ return;
+}
+
+
+sub carp {
+ my $self = shift;
+ my $ctx = $self->ctx;
+ $ctx->alert(join "", @_);
+ $ctx->release;
+}
+
+sub croak {
+ my $self = shift;
+ my $ctx = $self->ctx;
+ $ctx->throw(join "", @_);
+ $ctx->release;
+}
+
+
+sub current_test {
+ my( $self, $num ) = @_;
+
+ my $ctx = $self->ctx;
+ my $hub = $ctx->hub;
+
+ if( defined $num ) {
+ $hub->set_count($num);
+
+ # If the test counter is being pushed forward fill in the details.
+ my $test_results = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results};
+ if( $num > @$test_results ) {
+ my $start = @$test_results ? @$test_results : 0;
+ for( $start .. $num - 1 ) {
+ $test_results->[$_] = {
+ 'ok' => 1,
+ actual_ok => undef,
+ reason => 'incrementing test number',
+ type => 'unknown',
+ name => undef
+ };
+ }
+ }
+ # If backward, wipe history. Its their funeral.
+ elsif( $num < @$test_results ) {
+ $#{$test_results} = $num - 1;
+ }
+ }
+ return release $ctx, $hub->count;
+}
+
+
+sub is_passing {
+ my $self = shift;
+
+ my $ctx = $self->ctx;
+ my $hub = $ctx->hub;
+
+ if( @_ ) {
+ my ($bool) = @_;
+ $hub->set_failed(0) if $bool;
+ $hub->is_passing($bool);
+ }
+
+ return release $ctx, $hub->is_passing;
+}
+
+
+sub summary {
+ my($self) = shift;
+
+ my $ctx = $self->ctx;
+ my $data = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results};
+ $ctx->release;
+ return map { $_->{'ok'} } @$data;
+}
+
+
+sub details {
+ my $self = shift;
+ my $ctx = $self->ctx;
+ my $data = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results};
+ $ctx->release;
+ return @$data;
+}
+
+
+sub find_TODO {
+ my( $self, $pack, $set, $new_value ) = @_;
+
+ my $ctx = $self->ctx;
+
+ $pack ||= $ctx->trace->package || $self->exported_to;
+ $ctx->release;
+
+ return unless $pack;
+
+ no strict 'refs'; ## no critic
+ no warnings 'once';
+ my $old_value = ${ $pack . '::TODO' };
+ $set and ${ $pack . '::TODO' } = $new_value;
+ return $old_value;
+}
+
+sub todo {
+ my( $self, $pack ) = @_;
+
+ local $Level = $Level + 1;
+ my $ctx = $self->ctx;
+ $ctx->release;
+
+ my $meta = $ctx->hub->meta(__PACKAGE__, {todo => []})->{todo};
+ return $meta->[-1]->[1] if $meta && @$meta;
+
+ $pack ||= $ctx->trace->package;
+
+ return unless $pack;
+
+ no strict 'refs'; ## no critic
+ no warnings 'once';
+ return ${ $pack . '::TODO' };
+}
+
+sub in_todo {
+ my $self = shift;
+
+ local $Level = $Level + 1;
+ my $ctx = $self->ctx;
+ $ctx->release;
+
+ my $meta = $ctx->hub->meta(__PACKAGE__, {todo => []})->{todo};
+ return 1 if $meta && @$meta;
+
+ my $pack = $ctx->trace->package || return 0;
+
+ no strict 'refs'; ## no critic
+ no warnings 'once';
+ my $todo = ${ $pack . '::TODO' };
+
+ return 0 unless defined $todo;
+ return 0 if "$todo" eq '';
+ return 1;
+}
+
+sub todo_start {
+ my $self = shift;
+ my $message = @_ ? shift : '';
+
+ my $ctx = $self->ctx;
+
+ my $hub = $ctx->hub;
+ my $filter = $hub->filter(sub {
+ my ($active_hub, $e) = @_;
+
+ # Turn a diag into a todo diag
+ return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag';
+
+ # Set todo on ok's
+ if ($hub == $active_hub && $e->isa('Test2::Event::Ok')) {
+ $e->set_todo($message);
+ $e->set_effective_pass(1);
+
+ if (my $result = $e->get_meta(__PACKAGE__)) {
+ $result->{reason} ||= $message;
+ $result->{type} ||= 'todo';
+ $result->{ok} = 1;
+ }
+ }
+
+ return $e;
+ }, inherit => 1);
+
+ push @{$ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}} => [$filter, $message];
+
+ $ctx->release;
+
+ return;
+}
+
+sub todo_end {
+ my $self = shift;
+
+ my $ctx = $self->ctx;
+
+ my $set = pop @{$ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}};
+
+ $ctx->throw('todo_end() called without todo_start()') unless $set;
+
+ $ctx->hub->unfilter($set->[0]);
+
+ $ctx->release;
+
+ return;
+}
+
+
+sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
+ my( $self ) = @_;
+
+ my $ctx = $self->ctx;
+
+ my $trace = $ctx->trace;
+ $ctx->release;
+ return wantarray ? $trace->call : $trace->package;
+}
+
+
+sub _try {
+ my( $self, $code, %opts ) = @_;
+
+ my $error;
+ my $return;
+ {
+ local $!; # eval can mess up $!
+ local $@; # don't set $@ in the test
+ local $SIG{__DIE__}; # don't trip an outside DIE handler.
+ $return = eval { $code->() };
+ $error = $@;
+ }
+
+ die $error if $error and $opts{die_on_fail};
+
+ return wantarray ? ( $return, $error ) : $return;
+}
+
+sub _ending {
+ my $self = shift;
+ my ($ctx, $real_exit_code, $new) = @_;
+
+ unless ($ctx) {
+ my $octx = $self->ctx;
+ $ctx = $octx->snapshot;
+ $octx->release;
+ }
+
+ return if $ctx->hub->no_ending;
+ return if $ctx->hub->meta(__PACKAGE__, {})->{Ending}++;
+
+ # Don't bother with an ending if this is a forked copy. Only the parent
+ # should do the ending.
+ return unless $self->{Original_Pid} == $$;
+
+ my $hub = $ctx->hub;
+ return if $hub->bailed_out;
+
+ my $plan = $hub->plan;
+ my $count = $hub->count;
+ my $failed = $hub->failed;
+ return unless $plan || $count || $failed;
+
+ # Ran tests but never declared a plan or hit done_testing
+ if( !$hub->plan and $hub->count ) {
+ $self->diag("Tests were run but no plan was declared and done_testing() was not seen.");
+
+ if($real_exit_code) {
+ $self->diag(<<"FAIL");
+Looks like your test exited with $real_exit_code just after $count.
+FAIL
+ $$new ||= $real_exit_code;
+ return;
+ }
+
+ # But if the tests ran, handle exit code.
+ if($failed > 0) {
+ my $exit_code = $failed <= 254 ? $failed : 254;
+ $$new ||= $exit_code;
+ return;
+ }
+
+ $$new ||= 254;
+ return;
+ }
+
+ if ($real_exit_code && !$count) {
+ $self->diag("Looks like your test exited with $real_exit_code before it could output anything.");
+ $$new ||= $real_exit_code;
+ return;
+ }
+
+ return if $plan && "$plan" eq 'SKIP';
+
+ if (!$count) {
+ $self->diag('No tests run!');
+ $$new ||= 255;
+ return;
+ }
+
+ if ($real_exit_code) {
+ $self->diag(<<"FAIL");
+Looks like your test exited with $real_exit_code just after $count.
+FAIL
+ $$new ||= $real_exit_code;
+ return;
+ }
+
+ if ($plan eq 'NO PLAN') {
+ $ctx->plan( $count );
+ $plan = $hub->plan;
+ }
+
+ # Figure out if we passed or failed and print helpful messages.
+ my $num_extra = $count - $plan;
+
+ if ($num_extra != 0) {
+ my $s = $plan == 1 ? '' : 's';
+ $self->diag(<<"FAIL");
+Looks like you planned $plan test$s but ran $count.
+FAIL
+ }
+
+ if ($failed) {
+ my $s = $failed == 1 ? '' : 's';
+
+ my $qualifier = $num_extra == 0 ? '' : ' run';
+
+ $self->diag(<<"FAIL");
+Looks like you failed $failed test$s of $count$qualifier.
+FAIL
+ }
+
+ my $exit_code = 0;
+ if ($failed) {
+ $exit_code = $failed <= 254 ? $failed : 254;
+ }
+ elsif ($num_extra != 0) {
+ $exit_code = 255;
+ }
+
+ $$new ||= $exit_code;
+ return;
+}
+
+# Some things used this even though it was private... I am looking at you
+# Test::Builder::Prefix...
+sub _print_comment {
+ my( $self, $fh, @msgs ) = @_;
+
+ return if $self->no_diag;
+ return unless @msgs;
+
+ # Prevent printing headers when compiling (i.e. -c)
+ return if $^C;
+
+ # Smash args together like print does.
+ # Convert undef to 'undef' so its readable.
+ my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
+
+ # Escape the beginning, _print will take care of the rest.
+ $msg =~ s/^/# /;
+
+ local( $\, $", $, ) = ( undef, ' ', '' );
+ print $fh $msg;
+
+ return 0;
+}
+
+# This is used by Test::SharedFork to turn on IPC after the fact. Not
+# documenting because I do not want it used. The method name is borrowed from
+# Test::Builder 2
+# Once Test2 stuff goes stable this method will be removed and Test::SharedFork
+# will be made smarter.
+sub coordinate_forks {
+ my $self = shift;
+
+ {
+ local ($@, $!);
+ require Test2::IPC;
+ }
+ Test2::IPC->import;
+ Test2::API::test2_ipc_enable_polling();
+ my $ipc = Test2::IPC::apply_ipc($self->{Stack});
+ $ipc->set_no_fatal(1);
+ Test2::API::test2_no_wait(1);
+ Test2::API::test2_ipc_enable_shm();
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::Builder - Backend for building test libraries
+
+=head1 SYNOPSIS
+
+ package My::Test::Module;
+ use base 'Test::Builder::Module';
+
+ my $CLASS = __PACKAGE__;
+
+ sub ok {
+ my($test, $name) = @_;
+ my $tb = $CLASS->builder;
+
+ $tb->ok($test, $name);
+ }
+
+
+=head1 DESCRIPTION
+
+L<Test::Simple> and L<Test::More> have proven to be popular testing modules,
+but they're not always flexible enough. Test::Builder provides a
+building block upon which to write your own test libraries I<which can
+work together>.
+
+=head2 Construction
+
+=over 4
+
+=item B<new>
+
+ my $Test = Test::Builder->new;
+
+Returns a Test::Builder object representing the current state of the
+test.
+
+Since you only run one test per program C<new> always returns the same
+Test::Builder object. No matter how many times you call C<new()>, you're
+getting the same object. This is called a singleton. This is done so that
+multiple modules share such global information as the test counter and
+where test output is going.
+
+If you want a completely new Test::Builder object different from the
+singleton, use C<create>.
+
+=item B<create>
+
+ my $Test = Test::Builder->create;
+
+Ok, so there can be more than one Test::Builder object and this is how
+you get it. You might use this instead of C<new()> if you're testing
+a Test::Builder based module, but otherwise you probably want C<new>.
+
+B<NOTE>: the implementation is not complete. C<level>, for example, is
+still shared amongst B<all> Test::Builder objects, even ones created using
+this method. Also, the method name may change in the future.
+
+=item B<subtest>
+
+ $builder->subtest($name, \&subtests, @args);
+
+See documentation of C<subtest> in Test::More.
+
+C<subtest> also, and optionally, accepts arguments which will be passed to the
+subtests reference.
+
+=item B<name>
+
+ diag $builder->name;
+
+Returns the name of the current builder. Top level builders default to C<$0>
+(the name of the executable). Child builders are named via the C<child>
+method. If no name is supplied, will be named "Child of $parent->name".
+
+=item B<reset>
+
+ $Test->reset;
+
+Reinitializes the Test::Builder singleton to its original state.
+Mostly useful for tests run in persistent environments where the same
+test might be run multiple times in the same process.
+
+=back
+
+=head2 Setting up tests
+
+These methods are for setting up tests and declaring how many there
+are. You usually only want to call one of these methods.
+
+=over 4
+
+=item B<plan>
+
+ $Test->plan('no_plan');
+ $Test->plan( skip_all => $reason );
+ $Test->plan( tests => $num_tests );
+
+A convenient way to set up your tests. Call this and Test::Builder
+will print the appropriate headers and take the appropriate actions.
+
+If you call C<plan()>, don't call any of the other methods below.
+
+If a child calls "skip_all" in the plan, a C<Test::Builder::Exception> is
+thrown. Trap this error, call C<finalize()> and don't run any more tests on
+the child.
+
+ my $child = $Test->child('some child');
+ eval { $child->plan( $condition ? ( skip_all => $reason ) : ( tests => 3 ) ) };
+ if ( eval { $@->isa('Test::Builder::Exception') } ) {
+ $child->finalize;
+ return;
+ }
+ # run your tests
+
+
+=item B<expected_tests>
+
+ my $max = $Test->expected_tests;
+ $Test->expected_tests($max);
+
+Gets/sets the number of tests we expect this test to run and prints out
+the appropriate headers.
+
+
+=item B<no_plan>
+
+ $Test->no_plan;
+
+Declares that this test will run an indeterminate number of tests.
+
+
+=item B<done_testing>
+
+ $Test->done_testing();
+ $Test->done_testing($num_tests);
+
+Declares that you are done testing, no more tests will be run after this point.
+
+If a plan has not yet been output, it will do so.
+
+$num_tests is the number of tests you planned to run. If a numbered
+plan was already declared, and if this contradicts, a failing test
+will be run to reflect the planning mistake. If C<no_plan> was declared,
+this will override.
+
+If C<done_testing()> is called twice, the second call will issue a
+failing test.
+
+If C<$num_tests> is omitted, the number of tests run will be used, like
+no_plan.
+
+C<done_testing()> is, in effect, used when you'd want to use C<no_plan>, but
+safer. You'd use it like so:
+
+ $Test->ok($a == $b);
+ $Test->done_testing();
+
+Or to plan a variable number of tests:
+
+ for my $test (@tests) {
+ $Test->ok($test);
+ }
+ $Test->done_testing(scalar @tests);
+
+
+=item B<has_plan>
+
+ $plan = $Test->has_plan
+
+Find out whether a plan has been defined. C<$plan> is either C<undef> (no plan
+has been set), C<no_plan> (indeterminate # of tests) or an integer (the number
+of expected tests).
+
+=item B<skip_all>
+
+ $Test->skip_all;
+ $Test->skip_all($reason);
+
+Skips all the tests, using the given C<$reason>. Exits immediately with 0.
+
+=item B<exported_to>
+
+ my $pack = $Test->exported_to;
+ $Test->exported_to($pack);
+
+Tells Test::Builder what package you exported your functions to.
+
+This method isn't terribly useful since modules which share the same
+Test::Builder object might get exported to different packages and only
+the last one will be honored.
+
+=back
+
+=head2 Running tests
+
+These actually run the tests, analogous to the functions in Test::More.
+
+They all return true if the test passed, false if the test failed.
+
+C<$name> is always optional.
+
+=over 4
+
+=item B<ok>
+
+ $Test->ok($test, $name);
+
+Your basic test. Pass if C<$test> is true, fail if $test is false. Just
+like Test::Simple's C<ok()>.
+
+=item B<is_eq>
+
+ $Test->is_eq($got, $expected, $name);
+
+Like Test::More's C<is()>. Checks if C<$got eq $expected>. This is the
+string version.
+
+C<undef> only ever matches another C<undef>.
+
+=item B<is_num>
+
+ $Test->is_num($got, $expected, $name);
+
+Like Test::More's C<is()>. Checks if C<$got == $expected>. This is the
+numeric version.
+
+C<undef> only ever matches another C<undef>.
+
+=item B<isnt_eq>
+
+ $Test->isnt_eq($got, $dont_expect, $name);
+
+Like L<Test::More>'s C<isnt()>. Checks if C<$got ne $dont_expect>. This is
+the string version.
+
+=item B<isnt_num>
+
+ $Test->isnt_num($got, $dont_expect, $name);
+
+Like L<Test::More>'s C<isnt()>. Checks if C<$got ne $dont_expect>. This is
+the numeric version.
+
+=item B<like>
+
+ $Test->like($thing, qr/$regex/, $name);
+ $Test->like($thing, '/$regex/', $name);
+
+Like L<Test::More>'s C<like()>. Checks if $thing matches the given C<$regex>.
+
+=item B<unlike>
+
+ $Test->unlike($thing, qr/$regex/, $name);
+ $Test->unlike($thing, '/$regex/', $name);
+
+Like L<Test::More>'s C<unlike()>. Checks if $thing B<does not match> the
+given C<$regex>.
+
+=item B<cmp_ok>
+
+ $Test->cmp_ok($thing, $type, $that, $name);
+
+Works just like L<Test::More>'s C<cmp_ok()>.
+
+ $Test->cmp_ok($big_num, '!=', $other_big_num);
+
+=back
+
+=head2 Other Testing Methods
+
+These are methods which are used in the course of writing a test but are not themselves tests.
+
+=over 4
+
+=item B<BAIL_OUT>
+
+ $Test->BAIL_OUT($reason);
+
+Indicates to the L<Test::Harness> that things are going so badly all
+testing should terminate. This includes running any additional test
+scripts.
+
+It will exit with 255.
+
+=for deprecated
+BAIL_OUT() used to be BAILOUT()
+
+=item B<skip>
+
+ $Test->skip;
+ $Test->skip($why);
+
+Skips the current test, reporting C<$why>.
+
+=item B<todo_skip>
+
+ $Test->todo_skip;
+ $Test->todo_skip($why);
+
+Like C<skip()>, only it will declare the test as failing and TODO. Similar
+to
+
+ print "not ok $tnum # TODO $why\n";
+
+=begin _unimplemented
+
+=item B<skip_rest>
+
+ $Test->skip_rest;
+ $Test->skip_rest($reason);
+
+Like C<skip()>, only it skips all the rest of the tests you plan to run
+and terminates the test.
+
+If you're running under C<no_plan>, it skips once and terminates the
+test.
+
+=end _unimplemented
+
+=back
+
-=item B<_try>
+=head2 Test building utility methods
- my $return_from_code = $Test->try(sub { code });
- my($return_from_code, $error) = $Test->try(sub { code });
+These methods are useful when writing your own test methods.
-Works like eval BLOCK except it ensures it has no effect on the rest
-of the test (ie. C<$@> is not set) nor is effected by outside
-interference (ie. C<$SIG{__DIE__}>) and works around some quirks in older
-Perls.
+=over 4
-C<$error> is what would normally be in C<$@>.
+=item B<maybe_regex>
-It is suggested you use this in place of eval BLOCK.
+ $Test->maybe_regex(qr/$regex/);
+ $Test->maybe_regex('/$regex/');
-=cut
+This method used to be useful back when Test::Builder worked on Perls
+before 5.6 which didn't have qr//. Now its pretty useless.
-sub _try {
- my( $self, $code, %opts ) = @_;
+Convenience method for building testing functions that take regular
+expressions as arguments.
- my $error;
- my $return;
- {
- local $!; # eval can mess up $!
- local $@; # don't set $@ in the test
- local $SIG{__DIE__}; # don't trip an outside DIE handler.
- $return = eval { $code->() };
- $error = $@;
- }
+Takes a quoted regular expression produced by C<qr//>, or a string
+representing a regular expression.
- die $error if $error and $opts{die_on_fail};
+Returns a Perl value which may be used instead of the corresponding
+regular expression, or C<undef> if its argument is not recognised.
- return wantarray ? ( $return, $error ) : $return;
-}
+For example, a version of C<like()>, sans the useful diagnostic messages,
+could be written as:
-=end private
+ sub laconic_like {
+ my ($self, $thing, $regex, $name) = @_;
+ my $usable_regex = $self->maybe_regex($regex);
+ die "expecting regex, found '$regex'\n"
+ unless $usable_regex;
+ $self->ok($thing =~ m/$usable_regex/, $name);
+ }
=item B<is_fh>
=cut
-sub is_fh {
- my $self = shift;
- my $maybe_fh = shift;
- return 0 unless defined $maybe_fh;
-
- return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
- return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
-
- return eval { $maybe_fh->isa("IO::Handle") } ||
- eval { tied($maybe_fh)->can('TIEHANDLE') };
-}
=back
To be polite to other functions wrapping your own you usually want to increment C<$Level> rather than set it to a constant.
-=cut
-
-sub level {
- my( $self, $level ) = @_;
-
- if( defined $level ) {
- $Level = $level;
- }
- return $Level;
-}
-
=item B<use_numbers>
$Test->use_numbers($on_or_off);
Defaults to on.
-=cut
-
-sub use_numbers {
- my( $self, $use_nums ) = @_;
-
- if( defined $use_nums ) {
- $self->{Use_Nums} = $use_nums;
- }
- return $self->{Use_Nums};
-}
-
=item B<no_diag>
$Test->no_diag($no_diag);
If set to true, no "1..N" header will be printed.
-=cut
-
-foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
- my $method = lc $attribute;
-
- my $code = sub {
- my( $self, $no ) = @_;
-
- if( defined $no ) {
- $self->{$attribute} = $no;
- }
- return $self->{$attribute};
- };
-
- no strict 'refs'; ## no critic
- *{ __PACKAGE__ . '::' . $method } = $code;
-}
-
=back
=head2 Output
=for blame transfer
Mark Fowler <mark@twoshortplanks.com>
-=cut
-
-sub diag {
- my $self = shift;
-
- $self->_print_comment( $self->_diag_fh, @_ );
-}
-
=item B<note>
$Test->note(@msgs);
Like C<diag()>, but it prints to the C<output()> handle so it will not
normally be seen by the user except in verbose mode.
-=cut
-
-sub note {
- my $self = shift;
-
- $self->_print_comment( $self->output, @_ );
-}
-
-sub _diag_fh {
- my $self = shift;
-
- local $Level = $Level + 1;
- return $self->in_todo ? $self->todo_output : $self->failure_output;
-}
-
-sub _print_comment {
- my( $self, $fh, @msgs ) = @_;
-
- return if $self->no_diag;
- return unless @msgs;
-
- # Prevent printing headers when compiling (i.e. -c)
- return if $^C;
-
- # Smash args together like print does.
- # Convert undef to 'undef' so its readable.
- my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
-
- # Escape the beginning, _print will take care of the rest.
- $msg =~ s/^/# /;
-
- local $Level = $Level + 1;
- $self->_print_to_fh( $fh, $msg );
-
- return 0;
-}
-
=item B<explain>
my @dump = $Test->explain(@msgs);
is_deeply($have, $want) || note explain $have;
-=cut
-
-sub explain {
- my $self = shift;
-
- return map {
- ref $_
- ? do {
- $self->_try(sub { require Data::Dumper }, die_on_fail => 1);
-
- my $dumper = Data::Dumper->new( [$_] );
- $dumper->Indent(1)->Terse(1);
- $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
- $dumper->Dump;
- }
- : $_
- } @_;
-}
-
-=begin _private
-
-=item B<_print>
-
- $Test->_print(@msgs);
-
-Prints to the C<output()> filehandle.
-
-=end _private
-
-=cut
-
-sub _print {
- my $self = shift;
- return $self->_print_to_fh( $self->output, @_ );
-}
-
-sub _print_to_fh {
- my( $self, $fh, @msgs ) = @_;
-
- # Prevent printing headers when only compiling. Mostly for when
- # tests are deparsed with B::Deparse
- return if $^C;
-
- my $msg = join '', @msgs;
- my $indent = $self->_indent;
-
- local( $\, $", $, ) = ( undef, ' ', '' );
-
- # Escape each line after the first with a # so we don't
- # confuse Test::Harness.
- $msg =~ s{\n(?!\z)}{\n$indent# }sg;
-
- # Stick a newline on the end if it needs it.
- $msg .= "\n" unless $msg =~ /\n\z/;
-
- return print $fh $indent, $msg;
-}
-
=item B<output>
=item B<failure_output>
$Test->output(\$scalar);
These methods control where Test::Builder will print its output.
-They take either an open C<$filehandle>, a C<$filename> to open and write to
-or a C<$scalar> reference to append to. It will always return a C<$filehandle>.
-
-B<output> is where normal "ok/not ok" test output goes.
-
-Defaults to STDOUT.
-
-B<failure_output> is where diagnostic output on test failures and
-C<diag()> goes. It is normally not read by Test::Harness and instead is
-displayed to the user.
-
-Defaults to STDERR.
-
-C<todo_output> is used instead of C<failure_output()> for the
-diagnostics of a failing TODO test. These will not be seen by the
-user.
-
-Defaults to STDOUT.
-
-=cut
-
-sub output {
- my( $self, $fh ) = @_;
-
- if( defined $fh ) {
- $self->{Out_FH} = $self->_new_fh($fh);
- }
- return $self->{Out_FH};
-}
-
-sub failure_output {
- my( $self, $fh ) = @_;
-
- if( defined $fh ) {
- $self->{Fail_FH} = $self->_new_fh($fh);
- }
- return $self->{Fail_FH};
-}
-
-sub todo_output {
- my( $self, $fh ) = @_;
-
- if( defined $fh ) {
- $self->{Todo_FH} = $self->_new_fh($fh);
- }
- return $self->{Todo_FH};
-}
-
-sub _new_fh {
- my $self = shift;
- my($file_or_fh) = shift;
-
- my $fh;
- if( $self->is_fh($file_or_fh) ) {
- $fh = $file_or_fh;
- }
- elsif( ref $file_or_fh eq 'SCALAR' ) {
- # Scalar refs as filehandles was added in 5.8.
- if( $] >= 5.008 ) {
- open $fh, ">>", $file_or_fh
- or $self->croak("Can't open scalar ref $file_or_fh: $!");
- }
- # Emulate scalar ref filehandles with a tie.
- else {
- $fh = Test::Builder::IO::Scalar->new($file_or_fh)
- or $self->croak("Can't tie scalar ref $file_or_fh");
- }
- }
- else {
- open $fh, ">", $file_or_fh
- or $self->croak("Can't open test output log $file_or_fh: $!");
- _autoflush($fh);
- }
-
- return $fh;
-}
-
-sub _autoflush {
- my($fh) = shift;
- my $old_fh = select $fh;
- $| = 1;
- select $old_fh;
-
- return;
-}
-
-my( $Testout, $Testerr );
-
-sub _dup_stdhandles {
- my $self = shift;
-
- $self->_open_testhandles;
-
- # Set everything to unbuffered else plain prints to STDOUT will
- # come out in the wrong order from our own prints.
- _autoflush($Testout);
- _autoflush( \*STDOUT );
- _autoflush($Testerr);
- _autoflush( \*STDERR );
-
- $self->reset_outputs;
-
- return;
-}
-
-sub _open_testhandles {
- my $self = shift;
-
- return if $self->{Opened_Testhandles};
-
- # We dup STDOUT and STDERR so people can change them in their
- # test suites while still getting normal test output.
- open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!";
- open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!";
-
- $self->_copy_io_layers( \*STDOUT, $Testout );
- $self->_copy_io_layers( \*STDERR, $Testerr );
-
- $self->{Opened_Testhandles} = 1;
-
- return;
-}
+They take either an open C<$filehandle>, a C<$filename> to open and write to
+or a C<$scalar> reference to append to. It will always return a C<$filehandle>.
-sub _copy_io_layers {
- my( $self, $src, $dst ) = @_;
+B<output> is where normal "ok/not ok" test output goes.
- $self->_try(
- sub {
- require PerlIO;
- my @src_layers = PerlIO::get_layers($src);
+Defaults to STDOUT.
- _apply_layers($dst, @src_layers) if @src_layers;
- }
- );
+B<failure_output> is where diagnostic output on test failures and
+C<diag()> goes. It is normally not read by Test::Harness and instead is
+displayed to the user.
- return;
-}
+Defaults to STDERR.
-sub _apply_layers {
- my ($fh, @layers) = @_;
- my %seen;
- my @unique = grep { $_ ne 'unix' and !$seen{$_}++ } @layers;
- binmode($fh, join(":", "", "raw", @unique));
-}
+C<todo_output> is used instead of C<failure_output()> for the
+diagnostics of a failing TODO test. These will not be seen by the
+user.
+Defaults to STDOUT.
=item reset_outputs
Resets all the output filehandles back to their defaults.
-=cut
-
-sub reset_outputs {
- my $self = shift;
-
- $self->output ($Testout);
- $self->failure_output($Testerr);
- $self->todo_output ($Testout);
-
- return;
-}
-
=item carp
$tb->carp(@message);
Dies with C<@message> but the message will appear to come from the
point where the original test function was called (C<< $tb->caller >>).
-=cut
-
-sub _message_at_caller {
- my $self = shift;
-
- local $Level = $Level + 1;
- my( $pack, $file, $line ) = $self->caller;
- return join( "", @_ ) . " at $file line $line.\n";
-}
-
-sub carp {
- my $self = shift;
- return warn $self->_message_at_caller(@_);
-}
-
-sub croak {
- my $self = shift;
- return die $self->_message_at_caller(@_);
-}
-
=back
if set backward, the details of the intervening tests are deleted. You
can erase history if you really want to.
-=cut
-
-sub current_test {
- my( $self, $num ) = @_;
-
- lock( $self->{Curr_Test} );
- if( defined $num ) {
- $self->{Curr_Test} = $num;
-
- # If the test counter is being pushed forward fill in the details.
- my $test_results = $self->{Test_Results};
- if( $num > @$test_results ) {
- my $start = @$test_results ? @$test_results : 0;
- for( $start .. $num - 1 ) {
- $test_results->[$_] = &share(
- {
- 'ok' => 1,
- actual_ok => undef,
- reason => 'incrementing test number',
- type => 'unknown',
- name => undef
- }
- );
- }
- }
- # If backward, wipe history. Its their funeral.
- elsif( $num < @$test_results ) {
- $#{$test_results} = $num - 1;
- }
- }
- return $self->{Curr_Test};
-}
=item B<is_passing>
Don't think about it too much.
-=cut
-
-sub is_passing {
- my $self = shift;
-
- if( @_ ) {
- $self->{Is_Passing} = shift;
- }
-
- return $self->{Is_Passing};
-}
-
=item B<summary>
Of course, test #1 is $tests[0], etc...
-=cut
-
-sub summary {
- my($self) = shift;
-
- return map { $_->{'ok'} } @{ $self->{Test_Results} };
-}
=item B<details>
Like C<summary()>, but with a lot more detail.
- $tests[$test_num - 1] =
+ $tests[$test_num - 1] =
{ 'ok' => is the test considered a pass?
actual_ok => did it literally say 'ok'?
name => name of the test (if any)
reason => 'insufficient donuts'
};
-=cut
-
-sub details {
- my $self = shift;
- return @{ $self->{Test_Results} };
-}
=item B<todo>
for the C<$TODO> variable. If you want to be sure, tell it explicitly
what $pack to use.
-=cut
-
-sub todo {
- my( $self, $pack ) = @_;
-
- return $self->{Todo} if defined $self->{Todo};
-
- local $Level = $Level + 1;
- my $todo = $self->find_TODO($pack);
- return $todo if defined $todo;
-
- return '';
-}
-
=item B<find_TODO>
my $todo_reason = $Test->find_TODO();
my $old_reason = $Test->find_TODO($pack, 1, $new_reason);
-=cut
-
-sub find_TODO {
- my( $self, $pack, $set, $new_value ) = @_;
-
- $pack = $pack || $self->caller(1) || $self->exported_to;
- return unless $pack;
-
- no strict 'refs'; ## no critic
- my $old_value = ${ $pack . '::TODO' };
- $set and ${ $pack . '::TODO' } = $new_value;
- return $old_value;
-}
-
=item B<in_todo>
my $in_todo = $Test->in_todo;
Returns true if the test is currently inside a TODO block.
-=cut
-
-sub in_todo {
- my $self = shift;
-
- local $Level = $Level + 1;
- return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0;
-}
-
=item B<todo_start>
$Test->todo_start();
Pick one style or another of "TODO" to be on the safe side.
-=cut
-
-sub todo_start {
- my $self = shift;
- my $message = @_ ? shift : '';
-
- $self->{Start_Todo}++;
- if( $self->in_todo ) {
- push @{ $self->{Todo_Stack} } => $self->todo;
- }
- $self->{Todo} = $message;
-
- return;
-}
=item C<todo_end>
Stops running tests as "TODO" tests. This method is fatal if called without a
preceding C<todo_start> method call.
-=cut
-
-sub todo_end {
- my $self = shift;
-
- if( !$self->{Start_Todo} ) {
- $self->croak('todo_end() called without todo_start()');
- }
-
- $self->{Start_Todo}--;
-
- if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) {
- $self->{Todo} = pop @{ $self->{Todo_Stack} };
- }
- else {
- delete $self->{Todo};
- }
-
- return;
-}
-
=item B<caller>
my $package = $Test->caller;
If C<caller()> winds up off the top of the stack it report the highest context.
-=cut
-
-sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
- my( $self, $height ) = @_;
- $height ||= 0;
-
- my $level = $self->level + $height + 1;
- my @caller;
- do {
- @caller = CORE::caller( $level );
- $level--;
- } until @caller;
- return wantarray ? @caller : $caller[0];
-}
-
-=back
-
-=cut
-
-=begin _private
-
-=over 4
-
-=item B<_sanity_check>
-
- $self->_sanity_check();
-
-Runs a bunch of end of test sanity checks to make sure reality came
-through ok. If anything is wrong it will die with a fairly friendly
-error message.
-
-=cut
-
-#'#
-sub _sanity_check {
- my $self = shift;
-
- $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' );
- $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} },
- 'Somehow you got a different number of results than tests ran!' );
-
- return;
-}
-
-=item B<_whoa>
-
- $self->_whoa($check, $description);
-
-A sanity check, similar to C<assert()>. If the C<$check> is true, something
-has gone horribly wrong. It will die with the given C<$description> and
-a note to contact the author.
-
-=cut
-
-sub _whoa {
- my( $self, $check, $desc ) = @_;
- if($check) {
- local $Level = $Level + 1;
- $self->croak(<<"WHOA");
-WHOA! $desc
-This should never happen! Please contact the author immediately!
-WHOA
- }
-
- return;
-}
-
-=item B<_my_exit>
-
- _my_exit($exit_num);
-
-Perl seems to have some trouble with exiting inside an C<END> block.
-5.6.1 does some odd things. Instead, this function edits C<$?>
-directly. It should B<only> be called from inside an C<END> block.
-It doesn't actually exit, that's your job.
-
-=cut
-
-sub _my_exit {
- $? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars)
-
- return 1;
-}
-
=back
-=end _private
-
-=cut
-
-sub _ending {
- my $self = shift;
- return if $self->no_ending;
- return if $self->{Ending}++;
-
- my $real_exit_code = $?;
-
- # Don't bother with an ending if this is a forked copy. Only the parent
- # should do the ending.
- if( $self->{Original_Pid} != $$ ) {
- return;
- }
-
- # Ran tests but never declared a plan or hit done_testing
- if( !$self->{Have_Plan} and $self->{Curr_Test} ) {
- $self->is_passing(0);
- $self->diag("Tests were run but no plan was declared and done_testing() was not seen.");
-
- if($real_exit_code) {
- $self->diag(<<"FAIL");
-Looks like your test exited with $real_exit_code just after $self->{Curr_Test}.
-FAIL
- $self->is_passing(0);
- _my_exit($real_exit_code) && return;
- }
-
- # But if the tests ran, handle exit code.
- my $test_results = $self->{Test_Results};
- if(@$test_results) {
- my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ];
- if ($num_failed > 0) {
-
- my $exit_code = $num_failed <= 254 ? $num_failed : 254;
- _my_exit($exit_code) && return;
- }
- }
- _my_exit(254) && return;
- }
-
- # Exit if plan() was never called. This is so "require Test::Simple"
- # doesn't puke.
- if( !$self->{Have_Plan} ) {
- return;
- }
-
- # Don't do an ending if we bailed out.
- if( $self->{Bailed_Out} ) {
- $self->is_passing(0);
- return;
- }
- # Figure out if we passed or failed and print helpful messages.
- my $test_results = $self->{Test_Results};
- if(@$test_results) {
- # The plan? We have no plan.
- if( $self->{No_Plan} ) {
- $self->_output_plan($self->{Curr_Test}) unless $self->no_header;
- $self->{Expected_Tests} = $self->{Curr_Test};
- }
-
- # Auto-extended arrays and elements which aren't explicitly
- # filled in with a shared reference will puke under 5.8.0
- # ithreads. So we have to fill them in by hand. :(
- my $empty_result = &share( {} );
- for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) {
- $test_results->[$idx] = $empty_result
- unless defined $test_results->[$idx];
- }
-
- my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ];
-
- my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
-
- if( $num_extra != 0 ) {
- my $s = $self->{Expected_Tests} == 1 ? '' : 's';
- $self->diag(<<"FAIL");
-Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}.
-FAIL
- $self->is_passing(0);
- }
-
- if($num_failed) {
- my $num_tests = $self->{Curr_Test};
- my $s = $num_failed == 1 ? '' : 's';
-
- my $qualifier = $num_extra == 0 ? '' : ' run';
-
- $self->diag(<<"FAIL");
-Looks like you failed $num_failed test$s of $num_tests$qualifier.
-FAIL
- $self->is_passing(0);
- }
-
- if($real_exit_code) {
- $self->diag(<<"FAIL");
-Looks like your test exited with $real_exit_code just after $self->{Curr_Test}.
-FAIL
- $self->is_passing(0);
- _my_exit($real_exit_code) && return;
- }
-
- my $exit_code;
- if($num_failed) {
- $exit_code = $num_failed <= 254 ? $num_failed : 254;
- }
- elsif( $num_extra != 0 ) {
- $exit_code = 255;
- }
- else {
- $exit_code = 0;
- }
-
- _my_exit($exit_code) && return;
- }
- elsif( $self->{Skip_All} ) {
- _my_exit(0) && return;
- }
- elsif($real_exit_code) {
- $self->diag(<<"FAIL");
-Looks like your test exited with $real_exit_code before it could output anything.
-FAIL
- $self->is_passing(0);
- _my_exit($real_exit_code) && return;
- }
- else {
- $self->diag("No tests run!\n");
- $self->is_passing(0);
- _my_exit(255) && return;
- }
-
- $self->is_passing(0);
- $self->_whoa( 1, "We fell off the end of _ending()" );
-}
-
-END {
- $Test->_ending if defined $Test;
-}
-
=head1 EXIT CODES
If all your tests passed, Test::Builder will exit with zero (which is
modify it under the same terms as Perl itself.
See F<http://www.perl.com/perl/misc/Artistic.html>
-
-=cut
-
-1;
-
--- /dev/null
+package Test::Builder::Formatter;
+use strict;
+use warnings;
+
+our $VERSION = '1.302015';
+
+use base 'Test2::Formatter::TAP';
+
+use Test2::Util::HashBase qw/no_header no_diag/;
+
+BEGIN {
+ *OUT_STD = Test2::Formatter::TAP->can('OUT_STD');
+ *OUT_ERR = Test2::Formatter::TAP->can('OUT_ERR');
+
+ my $todo = OUT_ERR() + 1;
+ *OUT_TODO = sub() { $todo };
+}
+
+__PACKAGE__->register_event('Test::Builder::TodoDiag', 'event_todo_diag');
+
+sub init {
+ my $self = shift;
+ $self->SUPER::init(@_);
+ $self->{+HANDLES}->[OUT_TODO] = $self->{+HANDLES}->[OUT_STD];
+}
+
+sub event_todo_diag {
+ my $self = shift;
+ my @out = $self->event_diag(@_);
+ $out[0]->[0] = OUT_TODO();
+ return @out;
+}
+
+sub event_diag {
+ my $self = shift;
+ return if $self->{+NO_DIAG};
+ return $self->SUPER::event_diag(@_);
+}
+
+sub event_plan {
+ my $self = shift;
+ return if $self->{+NO_HEADER};
+ return $self->SUPER::event_plan(@_);
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test::Builder::Formatter - Test::Builder subclass of Test2::Formatter::TAP
+
+=head1 DESCRIPTION
+
+This is what takes events and turns them into TAP.
+
+=head1 SYNOPSIS
+
+ use Test::Builder; # Loads Test::Builder::Formatter for you
+
+=head1 METHODS
+
+=over 4
+
+=item $f->event_todo_diag
+
+Additional method used to process L<Test::Builder::TodoDiag> events.
+
+=item $f->event_diag
+
+=item $f->event_plan
+
+These override the parent class methods to do nothing if C<no_header> is set.
+
+=back
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut
require Exporter;
our @ISA = qw(Exporter);
-our $VERSION = '1.001014';
-$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
+our $VERSION = '1.302015';
=head1 NAME
my $CLASS = __PACKAGE__;
- use base 'Test::Builder::Module';
+ use parent 'Test::Builder::Module';
@EXPORT = qw(ok);
sub ok ($;$) {
package Test::Builder::Tester;
use strict;
-our $VERSION = "1.28";
+our $VERSION = '1.302015';
use Test::Builder 0.99;
use Symbol;
my $original_output_handle;
my $original_failure_handle;
my $original_todo_handle;
+my $original_formatter;
my $original_harness_env;
# function that starts testing and redirects the filehandles for now
sub _start_testing {
+ # Hack for things that conditioned on Test-Stream being loaded
+ $INC{'Test/Stream.pm'} ||= 'fake' if $INC{'Test/Moose/More.pm'};
# even if we're running under Test::Harness pretend we're not
# for now. This needed so Test::Builder doesn't add extra spaces
$original_harness_env = $ENV{HARNESS_ACTIVE} || 0;
$ENV{HARNESS_ACTIVE} = 0;
+ my $hub = $t->{Hub} || Test2::API::test2_stack->top;
+ $original_formatter = $hub->format;
+ unless ($original_formatter && $original_formatter->isa('Test::Builder::Formatter')) {
+ my $fmt = Test::Builder::Formatter->new;
+ $hub->format($fmt);
+ }
+
# remember what the handles were set to
$original_output_handle = $t->output();
$original_failure_handle = $t->failure_output();
=cut
sub test_test {
+ # END the hack
+ delete $INC{'Test/Stream.pm'} if $INC{'Test/Stream.pm'} && $INC{'Test/Stream.pm'} eq 'fake';
# decode the arguments as described in the pod
my $mess;
my %args;
croak "Not testing. You must declare output with a test function first."
unless $testing;
+
+ my $hub = $t->{Hub} || Test2::API::test2_stack->top;
+ $hub->format($original_formatter);
+
# okay, reconnect the test suite back to the saved handles
$t->output($original_output_handle);
$t->failure_output($original_failure_handle);
sub _account_for_subtest {
my( $self, $check ) = @_;
- # Since we ship with Test::Builder, calling a private method is safe...ish.
- return ref($check) ? $check : $t->_indent . $check;
+ my $hub = $t->{Stack}->top;
+ my $nesting = $hub->isa('Test2::Hub::Subtest') ? $hub->nested : 0;
+ return ref($check) ? $check : (' ' x $nesting) . $check;
}
sub _translate_Failed_check {
}
}
+ my @got = split "\n", $got;
+ my @wanted = split "\n", $wanted;
+
+ $got = "";
+ $wanted = "";
+
+ while (@got || @wanted) {
+ my $g = shift @got || "";
+ my $w = shift @wanted || "";
+ if ($g ne $w) {
+ if($g =~ s/(\s+)$/ |> /g) {
+ $g .= ($_ eq ' ' ? '_' : '\t') for split '', $1;
+ }
+ if($w =~ s/(\s+)$/ |> /g) {
+ $w .= ($_ eq ' ' ? '_' : '\t') for split '', $1;
+ }
+ $g = "> $g";
+ $w = "> $w";
+ }
+ else {
+ $g = " $g";
+ $w = " $w";
+ }
+ $got = $got ? "$got\n$g" : $g;
+ $wanted = $wanted ? "$wanted\n$w" : $w;
+ }
+
return "$type is:\n" . "$got\nnot:\n$wanted\nas expected";
}
package Test::Builder::Tester::Color;
use strict;
-our $VERSION = "1.290001";
+our $VERSION = '1.302015';
require Test::Builder::Tester;
--- /dev/null
+package Test::Builder::TodoDiag;
+use strict;
+use warnings;
+
+our $VERSION = '1.302015';
+
+use base 'Test2::Event::Diag';
+
+sub diagnostics { 0 }
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test::Builder::TodoDiag - Test::Builder subclass of Test2::Event::Diag
+
+=head1 DESCRIPTION
+
+This is used to encapsulate diag messages created inside TODO.
+
+=head1 SYNOPSIS
+
+You do not need to use this directly.
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut
--- /dev/null
+=pod
+
+=head1 NAME
+
+Test::FAQ - Frequently Asked Questions about testing with Perl
+
+=head1 DESCRIPTION
+
+Frequently Asked Questions about testing in general and specific
+issues with Perl.
+
+=head2 Is there any tutorial on testing?
+
+L<Test::Tutorial>
+
+=head2 Are there any modules for testing?
+
+A whole bunch. Start with L<Test::Simple> then move onto Test::More.
+
+Then go onto L<http://search.cpan.org> and search for "Test".
+
+=head2 Are there any modules for testing web pages/CGI programs?
+
+L<Test::WWW::Mechanize>, L<Test::WWW::Selenium>
+
+=head2 Are there any modules for testing external programs?
+
+L<Test::Cmd>
+
+=head2 Can you do xUnit/JUnit style testing in Perl?
+
+Yes, L<Test::Class> allows you to write test methods while continuing to
+use all the usual CPAN testing modules. It is the best and most
+perlish way to do xUnit style testing.
+
+L<Test::Unit> is a more direct port of XUnit to Perl, but it does not use
+the Perl conventions and does not play well with other CPAN testing
+modules. As of this writing, it is abandoned. B<Do not use>.
+
+The L<Test::Inline> (aka L<Pod::Tests>) is worth mentioning as it allows you to
+put tests into the POD in the same file as the code.
+
+
+=head2 How do I test my module is backwards/forwards compatible?
+
+First, install a bunch of perls of commonly used versions. At the
+moment, you could try these
+
+ 5.7.2
+ 5.6.1
+ 5.005_03
+ 5.004_05
+
+if you're feeling brave, you might want to have on hand these
+
+ bleadperl
+ 5.6.0
+ 5.004_04
+ 5.004
+
+going back beyond 5.003 is probably beyond the call of duty.
+
+You can then add something like this to your F<Makefile.PL>. It
+overrides the L<ExtUtils::MakeMaker> C<test_via_harness()> method to run the tests
+against several different versions of Perl.
+
+ # If PERL_TEST_ALL is set, run "make test" against
+ # other perls as well as the current perl.
+ {
+ package MY;
+
+ sub test_via_harness {
+ my($self, $orig_perl, $tests) = @_;
+
+ # names of your other perl binaries.
+ my @other_perls = qw(perl5.004_05 perl5.005_03 perl5.7.2);
+
+ my @perls = ($orig_perl);
+ push @perls, @other_perls if $ENV{PERL_TEST_ALL};
+
+ my $out;
+ foreach my $perl (@perls) {
+ $out .= $self->SUPER::test_via_harness($perl, $tests);
+ }
+
+ return $out;
+ }
+ }
+
+and re-run your F<Makefile.PL> with the C<PERL_TEST_ALL> environment
+variable set
+
+ PERL_TEST_ALL=1 perl Makefile.PL
+
+now C<make test> will run against each of your other perls.
+
+
+=head2 If I'm testing Foo::Bar, where do I put tests for Foo::Bar::Baz?
+
+=head2 How do I know when my tests are good enough?
+
+A: Use tools for measuring the code coverage of your tests, e.g. how many of
+your source code lines/subs/expressions/paths are executed (aka covered) by
+the test suite. The more, the better, of course, although you may not
+be able achieve 100%. If your testsuite covers under 100%, then
+the rest of your code is, basically, untested. Which means it may work in
+surprising ways (e.g. doesn't do things like they are intended or
+documented), have bugs (e.g. return wrong results) or it may not work at
+all.
+
+=head2 How do I measure the coverage of my test suite?
+
+L<Devel::Cover>
+
+=head2 How do I get tests to run in a certain order?
+
+Tests run in alphabetical order, so simply name your test files in the order
+you want them to run. Numbering your test files works, too.
+
+ t/00_compile.t
+ t/01_config.t
+ t/zz_teardown.t
+
+0 runs first, z runs last.
+
+To achieve a specific order, try L<Test::Manifest>.
+
+Typically you do B<not> want your tests to require being run in a
+certain order, but it can be useful to do a compile check first or to
+run the tests on a very basic module before everything else. This
+gives you early information if a basic module fails which will bring
+everything else down.
+
+Another use is if you have a suite wide setup/teardown, such as
+creating and delete a large test database, which may be too
+expensive to do for every test.
+
+We recommend B<against> numbering every test file. For most files
+this ordering will be arbitrary and the leading number obscures the
+real name of the file. See L<What should I name my test files?> for
+more information.
+
+
+=head2 What should I name my tests?
+
+=head2 What should I name my test files?
+
+A test filename serves three purposes:
+
+Most importantly, it serves to identify what is being tested. Each
+test file should test a clear piece of functionality. This could be
+at single class, a single method, even a single bug.
+
+The order in which tests are run is usually dictated by the filename.
+See L<How do I get tests to run in a certain order?> for details.
+
+Finally, the grouping of tests into common bits of functionality can
+be achieved by directory and filenames. For example, all the tests
+for L<Test::Builder> are in the F<t/Builder/> directory.
+
+As an example, F<t/Builder/reset.t> contains the tests for
+C<< Test::Builder->reset >>. F<t/00compile.t> checks that everything
+compiles, and it will run first. F<t/dont_overwrite_die_handler.t>
+checks that we don't overwrite the C<< $SIG{__DIE__} >> handler.
+
+
+=head2 How do I deal with tests that sometimes pass and sometimes fail?
+
+=head2 How do I test with a database/network/server that the user may or may not have?
+
+=head2 What's a good way to test lists?
+
+C<is_deeply()> from L<Test::More> as well as L<Test::Deep>.
+
+=head2 Is there such a thing as untestable code?
+
+There's always compile/export checks.
+
+Code must be written with testability in mind. Separation of form and
+functionality.
+
+=head2 What do I do when I can't make the code do the same thing twice?
+
+Force it to do the same thing twice.
+
+Even a random number generator can be tested.
+
+=head2 How do I test a GUI?
+
+=head2 How do I test an image generator?
+
+=head2 How do I test that my code handles failures gracefully?
+
+=head2 How do I check the right warnings are issued?
+
+L<Test::Warn>
+
+=head2 How do I test code that prints?
+
+L<Test::Output>
+
+=head2 I want to test that my code dies when I do X
+
+L<Test::Exception>
+
+=head2 I want to print out more diagnostic info on failure.
+
+C<ok(...) || diag "...";>
+
+=head2 How can I simulate failures to make sure that my code does the Right Thing in the face of them?
+
+
+=head2 Why use an ok() function?
+
+On Tue, Aug 28, 2001 at 02:12:46PM +0100, Robin Houston wrote:
+> Michael Schwern wrote:
+> > Ah HA! I've been wondering why nobody ever thinks to write a simple
+> > ok() function for their tests! perlhack has bad testing advice.
+>
+> Could you explain the advantage of having a "simple ok() function"?
+
+Because writing:
+
+ print "not " unless some thing worked;
+ print "ok $test\n"; $test++;
+
+gets rapidly annoying. This is why we made up subroutines in the
+first place. It also looks like hell and obscures the real purpose.
+
+Besides, that will cause problems on VMS.
+
+
+> As somebody who has spent many painful hours debugging test failures,
+> I'm intimately familiar with the _disadvantages_. When you run the
+> test, you know that "test 113 failed". That's all you know, in general.
+
+Second advantage is you can easily upgrade the C<ok()> function to fix
+this, either by slapping this line in:
+
+ printf "# Failed test at line %d\n", (caller)[2];
+
+or simply junking the whole thing and switching to L<Test::Simple> or
+L<Test::More>, which does all sorts of nice diagnostics-on-failure for
+you. Its C<ok()> function is backwards compatible with the above.
+
+There's some issues with using L<Test::Simple> to test really basic Perl
+functionality, you have to choose on a per test basis. Since
+L<Test::Simple> doesn't use C<pack()> it's safe for F<t/op/pack.t> to use
+L<Test::Simple>. I just didn't want to make the perlhack patching
+example too complicated.
+
+
+=head2 Dummy Mode
+
+> One compromise would be to use a test-generating script, which allows
+> the tests to be structured simply and _generates_ the actual test
+> code. One could then grep the generated test script to locate the
+> failing code.
+
+This is a very interesting, and very common, response to the problem.
+I'm going to make some observations about reactions to testing,
+they're not specific to you.
+
+If you've ever read the Bastard Operator From Hell series, you'll
+recall the Dummy Mode.
+
+ The words "power surging" and "drivers" have got her. People hear
+ words like that and go into Dummy Mode and do ANYTHING you say. I
+ could tell her to run naked across campus with a powercord rammed
+ up her backside and she'd probably do it... Hmmm...
+
+There seems to be a Dummy Mode WRT testing. An otherwise competent
+person goes to write a test and they suddenly forget all basic
+programming practice.
+
+
+The reasons for using an C<ok()> function above are the same reasons to
+use functions in general, we should all know them. We'd laugh our
+heads off at code that repeated as much as your average test does.
+These are newbie mistakes.
+
+And the normal 'can do' flair seems to disappear. I know Robin. I
+*know* that in any other situation he would have come up with the
+C<caller()> trick in about 15 seconds flat. Instead weird, elaborate,
+inelegant hacks are thought up to solve the simplest problems.
+
+
+I guess there are certain programming idioms that are foreign enough
+to throw your brain into reverse if you're not ready for them. Like
+trying to think in Lisp, for example. Or being presented with OO for
+the first time. I guess writing test is one of those.
+
+
+=head2 How do I use Test::More without depending on it?
+
+Install L<Test::More> into F<t/lib> under your source directory. Then in your tests
+say C<use lib 't/lib'>.
+
+=head2 How do I deal with threads and forking?
+
+=head2 Why do I need more than ok?
+
+Since every test can be reduced to checking if a statement is true,
+C<ok()> can test everything. But C<ok()> doesn't tell you why the test
+failed. For that you need to tell the test more... which is why
+you need L<Test::More>.
+
+ ok $pirate->name eq "Roberts", "person's name";
+
+ not ok 1 - person's name
+ # Failed test at pirates.t line 23.
+
+If the above fails, you don't know what C<< $person->name >> returned.
+You have to go in and add a C<diag> call. This is time consuming. If
+it's a heisenbug, it might not fail again! If it's a user reporting a
+test failure, they might not be bothered to hack the tests to give you
+more information.
+
+ is $person->name, "Roberts", "person's name";
+
+ not ok 1 - person's name
+ # Failed test at pirates.t line 23.
+ # got: 'Wesley'
+ # expected: 'Roberts'
+
+Using C<is> from L<Test::More> you now know what value you got and
+what value you expected.
+
+The most useful functions in L<Test::More> are C<is()>, C<like()> and C<is_deeply()>.
+
+
+=head2 What's wrong with C<print $test ? "ok" : "not ok">?
+
+=head2 How do I check for an infinite loop?
+
+On Mon, Mar 18, 2002 at 03:57:55AM -0500, Mark-Jason Dominus wrote:
+>
+> Michael The Schwern <schwern@pobox.com> says:
+> > Use alarm and skip the test if $Config{d_alarm} is false (see
+> > t/op/alarm.t for an example). If you think the infinite loop is due
+> > to a programming glitch, as opposed to a cross-platform issue, this
+> > will be enough.
+>
+> Thanks very much!
+>
+
+=head2 How can I check that flock works?
+
+=head2 How do I use the comparison functions of a testing module without it being a test?
+
+Any testing function based on L<Test::Builder>, most are, can be quieted so it does
+not do any testing. It simply returns true or false. Use the following code...
+
+ use Test::More; # or any testing module
+
+ use Test::Builder;
+ use File::Spec;
+
+ # Get the internal Test::Builder object
+ my $tb = Test::Builder->new;
+
+ $tb->plan("no_plan");
+
+ # Keep Test::Builder from displaying anything
+ $tb->no_diag(1);
+ $tb->no_ending(1);
+ $tb->no_header(1);
+ $tb->output( File::Spec->devnull );
+
+ # Now you can use the testing function.
+ print is_deeply( "foo", "bar" ) ? "Yes" : "No";
return warn @_, " at $file line $line\n";
}
-our $VERSION = '1.001014';
-$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
+our $VERSION = '1.302015';
use Test::Builder::Module 0.99;
our @ISA = qw(Test::Builder::Module);
my( $why, $how_many ) = @_;
my $tb = Test::More->builder;
- unless( defined $how_many ) {
- # $how_many can only be avoided when no_plan is in use.
+ # If the plan is set, and is static, then skip needs a count. If the plan
+ # is 'no_plan' we are fine. As well if plan is undefined then we are
+ # waiting for done_testing.
+ unless (defined $how_many) {
+ my $plan = $tb->has_plan;
_carp "skip() needs to know \$how_many tests are in the block"
- unless $tb->has_plan eq 'no_plan';
+ if $plan && $plan =~ m/^\d+$/;
$how_many = 1;
}
=head2 BUNDLES
-L<Bundle::Test> installs a whole bunch of useful test modules.
-
L<Test::Most> Most commonly needed test functions and features.
=head1 AUTHORS
use strict;
-our $VERSION = '1.001014';
-$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
+our $VERSION = '1.302015';
use Test::Builder::Module 0.99;
our @ISA = qw(Test::Builder::Module);
require Exporter;
-use vars qw( @ISA @EXPORT $VERSION );
+use vars qw( @ISA @EXPORT );
+
+our $VERSION = '1.302015';
-$VERSION = "0.114";
@EXPORT = qw( run_tests check_tests check_test cmp_results show_space );
@ISA = qw( Exporter );
package Test::Tester::Capture;
+our $VERSION = '1.302015';
+
+
use Test::Builder;
use vars qw( @ISA );
sub ok {
my($self, $test, $name) = @_;
+ my $ctx = $self->ctx;
+
# $test might contain an object which we don't want to accidentally
# store, so we turn it into a boolean.
$test = $test ? 1 : 0;
my($pack, $file, $line) = $self->caller;
- my $todo = $self->todo($pack);
+ my $todo = $self->todo();
my $result = {};
share($result);
$result->{_level} = $Test::Builder::Level;
$result->{_depth} = Test::Tester::find_run_tests();
+ $ctx->release;
+
return $test ? 1 : 0;
}
my($self, $why) = @_;
$why ||= '';
+ my $ctx = $self->ctx;
+
lock($Curr_Test);
$Curr_Test++;
);
$Test_Results[$Curr_Test-1] = \%result;
+ $ctx->release;
return 1;
}
my($self, $why) = @_;
$why ||= '';
+ my $ctx = $self->ctx;
+
lock($Curr_Test);
$Curr_Test++;
$Test_Results[$Curr_Test-1] = \%result;
+ $ctx->release;
return 1;
}
# Prevent printing headers when compiling (i.e. -c)
return if $^C;
+ my $ctx = $self->ctx;
+
# Escape each line with a #.
foreach (@msgs) {
$_ = 'undef' unless defined;
$result->{diag} .= join("", @msgs);
+ $ctx->release;
return 0;
}
package Test::Tester::CaptureRunner;
+our $VERSION = '1.302015';
+
+
use Test::Tester::Capture;
require Exporter;
package Test::Tester::Delegate;
+our $VERSION = '1.302015';
+
+
use vars '$AUTOLOAD';
sub new
package Test::use::ok;
use 5.005;
-$Test::use::ok::VERSION = '0.16';
+
+our $VERSION = '1.302015';
+
__END__
--- /dev/null
+package Test2;
+use strict;
+use warnings;
+
+our $VERSION = '1.302015';
+
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2 - Framework for writing test tools that all work together.
+
+=head1 DESCRIPTION
+
+Test2 is a new testing framework produced by forking L<Test::Builder>,
+completely refactoring it, adding many new features and capabilities.
+
+=head1 GETTING STARTED
+
+If you are interested in writing tests using new tools then you should look at
+L<Test2::Suite>. L<Test::Suite> is a seperate cpan distribution that contains
+many tools implemented on Test2.
+
+If you are interested in writing new tools you should take a look at
+L<Test2::API> first.
+
+=head1 NAMESPACE LAYOUT
+
+This describes the namespace layout for the Test2 ecosystem. Not all the
+namespaces listed here are part of the Test2 distribution, some are implemented
+in L<Test2::Suite>.
+
+=head2 Test2::Tools::
+
+This namespace is for sets of tools. Modules in this namespace should export
+tools like C<ok()> and C<is()>. Most things written for Test2 should go here.
+Modules in this namespace B<MUST NOT> export subs from other tools. See the
+L</Test2::Bundle::> namespace if you want to do that.
+
+=head2 Test2::Plugin::
+
+This namespace is for plugins. Plugins are modules that change or enhance the
+behavior of Test2. An example of a plugin is a module that sets the encoding to
+utf8 globally. Another example is a module that causes a bail-out event after
+the first test failure.
+
+=head2 Test2::Bundle::
+
+This namespace is for bundles of tools and plugins. Loading one of these may
+load multiple tools and plugins. Modules in this namespace should not implement
+tools directly. In general modules in this namespace should load tools and
+plugins, then re-export things into the consumers namespace.
+
+=head2 Test2::Require::
+
+This namespace is for modules that cause a test to be skipped when conditions
+do not allow it to run. Examples would be modules that skip the test on older
+perls, or when non-essential modules have not been installed.
+
+=head2 Test2::Formatter::
+
+Formatters live under this namespace. L<Test2::Formatter::TAP> is the only
+formatter currently. It is acceptible for third party distributions to create
+new formatters under this namespace.
+
+=head2 Test2::Event::
+
+Events live under this namespace. It is considered acceptible for third party
+distributions to add new event types in this namespace.
+
+=head2 Test2::Hub::
+
+Hub subclasses (and some hub utility objects) live under this namespace. It is
+perfectly reasonable for third party distributions to add new hub subclasses in
+this namespace.
+
+=head2 Test2::IPC::
+
+The IPC subsystem lives in this namespace. There are not many good reasons to
+add anything to this namespace, with exception of IPC drivers.
+
+=head3 Test2::IPC::Driver::
+
+IPC drivers live in this namespace. It is fine to create new IPC drivers and to
+put them in this namespace.
+
+=head2 Test2::Util::
+
+This namespace is for general utilities used by testing tools. Please be
+considerate when adding new modules to this namespace.
+
+=head2 Test2::API::
+
+This is for Test2 API and related packages.
+
+=head2 Test2::
+
+The Test2:: namespace is intended for extentions and frameworks. Tools,
+Plugins, etc should not go directly into this namespace. However extentions
+that are used to build tools and plugins may go here.
+
+In short: If the module exports anything that should be run directly by a test
+script it should probably NOT go directly into C<Test2::XXX>.
+
+=head1 SEE ALSO
+
+L<Test2::API> - Primary API functions.
+
+L<Test2::API::Context> - Detailed documentation of the context object.
+
+L<Test2::IPC> - The IPC system used for threading/fork support.
+
+L<Test2::Formatter> - Formatters such as TAP live here.
+
+L<Test2::Event> - Events live in this namespace.
+
+L<Test2::Hub> - All events eventually funnel through a hub. Custom hubs are how
+C<intercept()> and C<run_subtest()> are implemented.
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut
--- /dev/null
+package Test2::API;
+use strict;
+use warnings;
+
+our $VERSION = '1.302015';
+
+
+my $INST;
+my $ENDING = 0;
+sub test2_set_is_end { ($ENDING) = @_ ? @_ : (1) }
+sub test2_get_is_end { $ENDING }
+
+use Test2::API::Instance(\$INST);
+# Set the exit status
+END {
+ test2_set_is_end(); # See gh #16
+ $INST->set_exit();
+}
+
+# See gh #16
+{
+ no warnings;
+ INIT { eval 'END { test2_set_is_end() }; 1' or die $@ }
+}
+
+BEGIN {
+ no warnings 'once';
+ if($] ge '5.014' || $ENV{T2_CHECK_DEPTH} || $Test2::API::DO_DEPTH_CHECK) {
+ *DO_DEPTH_CHECK = sub() { 1 };
+ }
+ else {
+ *DO_DEPTH_CHECK = sub() { 0 };
+ }
+}
+
+use Test2::Util::Trace();
+
+use Test2::Hub::Subtest();
+use Test2::Hub::Interceptor();
+use Test2::Hub::Interceptor::Terminator();
+
+use Test2::Event::Ok();
+use Test2::Event::Diag();
+use Test2::Event::Note();
+use Test2::Event::Plan();
+use Test2::Event::Bail();
+use Test2::Event::Exception();
+use Test2::Event::Waiting();
+use Test2::Event::Skip();
+use Test2::Event::Subtest();
+
+use Carp qw/carp croak confess longmess/;
+use Scalar::Util qw/blessed weaken/;
+use Test2::Util qw/get_tid/;
+
+our @EXPORT_OK = qw{
+ context release
+ context_do
+ no_context
+ intercept
+ run_subtest
+
+ test2_init_done
+ test2_load_done
+
+ test2_set_is_end
+ test2_get_is_end
+
+ test2_pid
+ test2_tid
+ test2_stack
+ test2_no_wait
+
+ test2_add_callback_context_aquire
+ test2_add_callback_context_acquire
+ test2_add_callback_context_init
+ test2_add_callback_context_release
+ test2_add_callback_exit
+ test2_add_callback_post_load
+ test2_list_context_aquire_callbacks
+ test2_list_context_acquire_callbacks
+ test2_list_context_init_callbacks
+ test2_list_context_release_callbacks
+ test2_list_exit_callbacks
+ test2_list_post_load_callbacks
+
+ test2_ipc
+ test2_ipc_drivers
+ test2_ipc_add_driver
+ test2_ipc_polling
+ test2_ipc_disable_polling
+ test2_ipc_enable_polling
+ test2_ipc_get_pending
+ test2_ipc_set_pending
+ test2_ipc_enable_shm
+
+ test2_formatter
+ test2_formatters
+ test2_formatter_add
+ test2_formatter_set
+};
+use base 'Exporter';
+
+# There is a use-cycle between API and API/Context. Context needs to use some
+# API functions as the package is compiling. Test2::API::context() needs
+# Test2::API::Context to be loaded, but we cannot 'require' the module there as
+# it causes a very noticable performance impact with how often context() is
+# called.
+#
+# This will make sure that Context.pm is loaded the first time this module is
+# imported, then the regular import method is swapped into place.
+sub import {
+ require Test2::API::Context unless $INC{'Test2/API/Context.pm'};
+
+ {
+ no warnings 'redefine';
+ *import = \&Exporter::import;
+ }
+
+ goto &import;
+}
+
+my $STACK = $INST->stack;
+my $CONTEXTS = $INST->contexts;
+my $INIT_CBS = $INST->context_init_callbacks;
+my $ACQUIRE_CBS = $INST->context_acquire_callbacks;
+
+sub test2_init_done { $INST->finalized }
+sub test2_load_done { $INST->loaded }
+
+sub test2_pid { $INST->pid }
+sub test2_tid { $INST->tid }
+sub test2_stack { $INST->stack }
+sub test2_no_wait {
+ $INST->set_no_wait(@_) if @_;
+ $INST->no_wait;
+}
+
+sub test2_add_callback_context_acquire { $INST->add_context_acquire_callback(@_) }
+sub test2_add_callback_context_aquire { $INST->add_context_acquire_callback(@_) }
+sub test2_add_callback_context_init { $INST->add_context_init_callback(@_) }
+sub test2_add_callback_context_release { $INST->add_context_release_callback(@_) }
+sub test2_add_callback_exit { $INST->add_exit_callback(@_) }
+sub test2_add_callback_post_load { $INST->add_post_load_callback(@_) }
+sub test2_list_context_aquire_callbacks { @{$INST->context_acquire_callbacks} }
+sub test2_list_context_acquire_callbacks { @{$INST->context_acquire_callbacks} }
+sub test2_list_context_init_callbacks { @{$INST->context_init_callbacks} }
+sub test2_list_context_release_callbacks { @{$INST->context_release_callbacks} }
+sub test2_list_exit_callbacks { @{$INST->exit_callbacks} }
+sub test2_list_post_load_callbacks { @{$INST->post_load_callbacks} }
+
+sub test2_ipc { $INST->ipc }
+sub test2_ipc_add_driver { $INST->add_ipc_driver(@_) }
+sub test2_ipc_drivers { @{$INST->ipc_drivers} }
+sub test2_ipc_polling { $INST->ipc_polling }
+sub test2_ipc_enable_polling { $INST->enable_ipc_polling }
+sub test2_ipc_disable_polling { $INST->disable_ipc_polling }
+sub test2_ipc_get_pending { $INST->get_ipc_pending }
+sub test2_ipc_set_pending { $INST->set_ipc_pending(@_) }
+sub test2_ipc_enable_shm { $INST->ipc_enable_shm }
+
+sub test2_formatter { $INST->formatter }
+sub test2_formatters { @{$INST->formatters} }
+sub test2_formatter_add { $INST->add_formatter(@_) }
+sub test2_formatter_set {
+ my ($formatter) = @_;
+ croak "No formatter specified" unless $formatter;
+ croak "Global Formatter already set" if $INST->formatter_set;
+ $INST->set_formatter($formatter);
+}
+
+# Private, for use in Test2::API::Context
+sub _contexts_ref { $INST->contexts }
+sub _context_acquire_callbacks_ref { $INST->context_acquire_callbacks }
+sub _context_init_callbacks_ref { $INST->context_init_callbacks }
+sub _context_release_callbacks_ref { $INST->context_release_callbacks }
+
+# Private, for use in Test2::IPC
+sub _set_ipc { $INST->set_ipc(@_) }
+
+sub context_do(&;@) {
+ my $code = shift;
+ my @args = @_;
+
+ my $ctx = context(level => 1);
+
+ my $want = wantarray;
+
+ my @out;
+ my $ok = eval {
+ $want ? @out = $code->($ctx, @args) :
+ defined($want) ? $out[0] = $code->($ctx, @args) :
+ $code->($ctx, @args) ;
+ 1;
+ };
+ my $err = $@;
+
+ $ctx->release;
+
+ die $err unless $ok;
+
+ return @out if $want;
+ return $out[0] if defined $want;
+ return;
+}
+
+sub no_context(&;$) {
+ my ($code, $hid) = @_;
+ $hid ||= $STACK->top->hid;
+
+ my $ctx = $CONTEXTS->{$hid};
+ delete $CONTEXTS->{$hid};
+ my $ok = eval { $code->(); 1 };
+ my $err = $@;
+
+ $CONTEXTS->{$hid} = $ctx;
+ weaken($CONTEXTS->{$hid});
+
+ die $err unless $ok;
+
+ return;
+};
+
+sub context {
+ # We need to grab these before anything else to ensure they are not
+ # changed.
+ my ($errno, $eval_error, $child_error) = (0 + $!, $@, $?);
+
+ my %params = (level => 0, wrapped => 0, @_);
+
+ # If something is getting a context then the sync system needs to be
+ # considered loaded...
+ $INST->load unless $INST->{loaded};
+
+ croak "context() called, but return value is ignored"
+ unless defined wantarray;
+
+ my $stack = $params{stack} || $STACK;
+ my $hub = $params{hub} || @$stack ? $stack->[-1] : $stack->top;
+ my $hid = $hub->{hid};
+ my $current = $CONTEXTS->{$hid};
+
+ $_->(\%params) for @$ACQUIRE_CBS;
+ map $_->(\%params), @{$hub->{_context_acquire}} if $hub->{_context_acquire};
+
+ # This is for https://github.com/Test-More/test-more/issues/16
+ # and https://rt.perl.org/Public/Bug/Display.html?id=127774
+ my $phase = ${^GLOBAL_PHASE} || 'NA';
+ my $end_phase = $ENDING || $phase eq 'END' || $phase eq 'DESTRUCT';
+
+ my $level = 1 + $params{level};
+ my ($pkg, $file, $line, $sub) = $end_phase ? caller(0) : caller($level);
+ unless ($pkg || $end_phase) {
+ confess "Could not find context at depth $level" unless $params{fudge};
+ ($pkg, $file, $line, $sub) = caller(--$level) while ($level >= 0 && !$pkg);
+ }
+
+ my $depth = $level;
+ $depth++ while DO_DEPTH_CHECK && !$end_phase && (!$current || $depth <= $current->{_depth} + $params{wrapped}) && caller($depth + 1);
+ $depth -= $params{wrapped};
+ my $depth_ok = !DO_DEPTH_CHECK || $end_phase || !$current || $current->{_depth} < $depth;
+
+ if ($current && $params{on_release} && $depth_ok) {
+ $current->{_on_release} ||= [];
+ push @{$current->{_on_release}} => $params{on_release};
+ }
+
+ # I know this is ugly....
+ ($!, $@, $?) = ($errno, $eval_error, $child_error) and return bless(
+ {
+ %$current,
+ _is_canon => undef,
+ errno => $errno,
+ eval_error => $eval_error,
+ child_error => $child_error,
+ _is_spawn => [$pkg, $file, $line, $sub],
+ },
+ 'Test2::API::Context'
+ ) if $current && $depth_ok;
+
+ # Handle error condition of bad level
+ if ($current) {
+ unless (${$current->{_aborted}}) {
+ _canon_error($current, [$pkg, $file, $line, $sub, $depth])
+ unless $current->{_is_canon};
+
+ _depth_error($current, [$pkg, $file, $line, $sub, $depth])
+ unless $depth_ok;
+ }
+
+ $current->release if $current->{_is_canon};
+
+ delete $CONTEXTS->{$hid};
+ }
+
+ # Directly bless the object here, calling new is a noticable performance
+ # hit with how often this needs to be called.
+ my $trace = bless(
+ {
+ frame => [$pkg, $file, $line, $sub],
+ pid => $$,
+ tid => get_tid(),
+ },
+ 'Test2::Util::Trace'
+ );
+
+ # Directly bless the object here, calling new is a noticable performance
+ # hit with how often this needs to be called.
+ my $aborted = 0;
+ $current = bless(
+ {
+ _aborted => \$aborted,
+ stack => $stack,
+ hub => $hub,
+ trace => $trace,
+ _is_canon => 1,
+ _depth => $depth,
+ errno => $errno,
+ eval_error => $eval_error,
+ child_error => $child_error,
+ $params{on_release} ? (_on_release => [$params{on_release}]) : (),
+ },
+ 'Test2::API::Context'
+ );
+
+ $CONTEXTS->{$hid} = $current;
+ weaken($CONTEXTS->{$hid});
+
+ $_->($current) for @$INIT_CBS;
+ map $_->($current), @{$hub->{_context_init}} if $hub->{_context_init};
+
+ $params{on_init}->($current) if $params{on_init};
+
+ ($!, $@, $?) = ($errno, $eval_error, $child_error);
+
+ return $current;
+}
+
+sub _depth_error {
+ _existing_error(@_, <<" EOT");
+context() was called to retrieve an existing context, however the existing
+context was created in a stack frame at the same, or deeper level. This usually
+means that a tool failed to release the context when it was finished.
+ EOT
+}
+
+sub _canon_error {
+ _existing_error(@_, <<" EOT");
+context() was called to retrieve an existing context, however the existing
+context has an invalid internal state (!_canon_count). This should not normally
+happen unless something is mucking about with internals...
+ EOT
+}
+
+sub _existing_error {
+ my ($ctx, $details, $msg) = @_;
+ my ($pkg, $file, $line, $sub, $depth) = @$details;
+
+ my $oldframe = $ctx->{trace}->frame;
+ my $olddepth = $ctx->{_depth};
+
+ my $mess = longmess();
+
+ warn <<" EOT";
+$msg
+Old context details:
+ File: $oldframe->[1]
+ Line: $oldframe->[2]
+ Tool: $oldframe->[3]
+ Depth: $olddepth
+
+New context details:
+ File: $file
+ Line: $line
+ Tool: $sub
+ Depth: $depth
+
+Trace: $mess
+
+Removing the old context and creating a new one...
+ EOT
+}
+
+sub release($;$) {
+ $_[0]->release;
+ return $_[1];
+}
+
+sub intercept(&) {
+ my $code = shift;
+
+ my $ctx = context();
+
+ my $ipc;
+ if (my $global_ipc = test2_ipc()) {
+ my $driver = blessed($global_ipc);
+ $ipc = $driver->new;
+ }
+
+ my $hub = Test2::Hub::Interceptor->new(
+ ipc => $ipc,
+ no_ending => 1,
+ );
+
+ my @events;
+ $hub->listen(sub { push @events => $_[1] });
+
+ $ctx->stack->top; # Make sure there is a top hub before we begin.
+ $ctx->stack->push($hub);
+
+ # Do not use 'try' cause it localizes __DIE__
+ my ($ok, $err);
+ {
+ $ok = eval { $code->(hub => $hub, context => $ctx->snapshot); 1 };
+ $err = $@;
+ }
+
+ $hub->cull;
+ $ctx->stack->pop($hub);
+
+ my $trace = $ctx->trace;
+ $ctx->release;
+
+ die $err unless $ok
+ || (blessed($err) && $err->isa('Test2::Hub::Interceptor::Terminator'));
+
+ $hub->finalize($trace, 1)
+ if $ok
+ && !$hub->no_ending
+ && !$hub->ended;
+
+ return \@events;
+}
+
+sub run_subtest {
+ my ($name, $code, $params, @args) = @_;
+
+ $params = { buffered => $params } unless ref $params;
+ my $buffered = delete $params->{buffered};
+
+ my $ctx = context();
+
+ $ctx->note($name) unless $buffered;
+
+ my $parent = $ctx->hub;
+
+ my $stack = $ctx->stack || $STACK;
+ my $hub = $stack->new_hub(
+ class => 'Test2::Hub::Subtest',
+ %$params,
+ );
+
+ my @events;
+ $hub->set_nested( $parent->isa('Test2::Hub::Subtest') ? $parent->nested + 1 : 1 );
+ $hub->listen(sub { push @events => $_[1] });
+
+ if ($buffered) {
+ if (my $format = $hub->format) {
+ my $hide = $format->can('hide_buffered') ? $format->hide_buffered : 1;
+ $hub->format(undef) if $hide;
+ }
+ }
+
+ my ($ok, $err, $finished);
+ T2_SUBTEST_WRAPPER: {
+ # Do not use 'try' cause it localizes __DIE__
+ $ok = eval { $code->(@args); 1 };
+ $err = $@;
+
+ # They might have done 'BEGIN { skip_all => "whatever" }'
+ if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/) {
+ $ok = undef;
+ $err = undef;
+ }
+ else {
+ $finished = 1;
+ }
+ }
+ $stack->pop($hub);
+
+ my $trace = $ctx->trace;
+
+ if (!$finished) {
+ if(my $bailed = $hub->bailed_out) {
+ $ctx->bail($bailed->reason);
+ }
+ my $code = $hub->exit_code;
+ $ok = !$code;
+ $err = "Subtest ended with exit code $code" if $code;
+ }
+
+ $hub->finalize($trace, 1)
+ if $ok
+ && !$hub->no_ending
+ && !$hub->ended;
+
+ my $pass = $ok && $hub->is_passing;
+ my $e = $ctx->build_event(
+ 'Subtest',
+ pass => $pass,
+ name => $name,
+ subtest_id => $hub->id,
+ buffered => $buffered,
+ subevents => \@events,
+ );
+
+ my $plan_ok = $hub->check_plan;
+
+ $ctx->hub->send($e);
+
+ $ctx->failure_diag($e) unless $e->pass;
+
+ $ctx->diag("Caught exception in subtest: $err") unless $ok;
+
+ $ctx->diag("Bad subtest plan, expected " . $hub->plan . " but ran " . $hub->count)
+ if defined($plan_ok) && !$plan_ok;
+
+ $ctx->release;
+ return $pass;
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2::API - Primary interface for writing Test2 based testing tools.
+
+=head1 ***INTERNALS NOTE***
+
+B<The internals of this package are subject to change at any time!> The public
+methods provided will not change in backwords incompatible ways (once there is
+a stable release), but the underlying implementation details might.
+B<Do not break encapsulation here!>
+
+Currently the implementation is to create a single instance of the
+L<Test2::API::Instance> Object. All class methods defer to the single
+instance. There is no public access to the singleton, and that is intentional.
+The class methods provided by this package provide the only functionality
+publicly exposed.
+
+This is done primarily to avoid the problems Test::Builder had by exposing its
+singleton. We do not want anyone to replace this singleton, rebless it, or
+directly muck with its internals. If you need to do something, and cannot
+because of the restrictions placed here then please report it as an issue. If
+possible we will create a way for you to implement your functionality without
+exposing things that should not be exposed.
+
+=head1 DESCRIPTION
+
+This package exports all the functions necessary to write and/or verify testing
+tools. Using these building blocks you can begin writing test tools very
+quickly. You are also provided with tools that help you to test the tools you
+write.
+
+=head1 SYNOPSYS
+
+=head2 WRITING A TOOL
+
+The C<context()> method is your primary interface into the Test2 framework.
+
+ package My::Ok;
+ use Test2::API qw/context/;
+
+ our @EXPORT = qw/my_ok/;
+ use base 'Exporter';
+
+ # Just like ok() from Test::More
+ sub my_ok($;$) {
+ my ($bool, $name) = @_;
+ my $ctx = context(); # Get a context
+ $ctx->ok($bool, $name);
+ $ctx->release; # Release the context
+ return $bool;
+ }
+
+See L<Test2::API::Context> for a list of methods avabilable on the context object.
+
+=head2 TESTING YOUR TOOLS
+
+The C<intercept { ... }> tool lets you temporarily intercept all events
+generated by the test system:
+
+ use Test2::API qw/intercept/;
+
+ use My::Ok qw/my_ok/;
+
+ my $events = intercept {
+ # These events are not displayed
+ my_ok(1, "pass");
+ my_ok(0, "fail");
+ };
+
+ my_ok(@$events == 2, "got 2 events, the pass and the fail");
+ my_ok($events->[0]->pass, "first event passed");
+ my_ok(!$events->[1]->pass, "second event failed");
+
+=head2 OTHER API FUNCTIONS
+
+ use Test2::API qw{
+ test2_init_done
+ test2_stack
+ test2_set_is_end
+ test2_get_is_end
+ test2_ipc
+ test2_formatter_set
+ test2_formatter
+ };
+
+ my $init = test2_init_done();
+ my $stack = test2_stack();
+ my $ipc = test2_ipc();
+
+ test2_formatter_set($FORMATTER)
+ my $formatter = test2_formatter();
+
+ ... And others ...
+
+=head1 MAIN API EXPORTS
+
+All exports are optional, you must specify subs to import.
+
+ use Test2::API qw/context intercept run_subtest/;
+
+This is the list of exports that are most commonly needed. If you are simply
+writing a tool then this is probably all you need. If you need something and
+you cannot find it here then you can also look at L</OTHER API EXPORTS>.
+
+These exports lack the 'test2_' prefix because of how important/common they
+are. Exports in the L</OTHER API EXPORTS> section have the 'test2_' prefix to
+ensure they stand out.
+
+=head2 context(...)
+
+Usage:
+
+=over 4
+
+=item $ctx = context()
+
+=item $ctx = context(%params)
+
+=back
+
+The C<context()> function will always return the current context to you. If
+there is already a context active it will be returned. If there is not an
+active context one will be generated. When a context is generated it will
+default to using the file and line number where the currently running sub was
+called from.
+
+Please see L<Test2::API::Context/"CRITICAL DETAILS"> for important rules about
+what you can and cannot do with a context once it is obtained.
+
+B<Note> This function will throw an exception if you ignore the context object
+it returns.
+
+B<Note> On perls 5.14+ a depth check is used to insure there are no context
+leaks. This cannot be safely done on older perls due to
+L<https://rt.perl.org/Public/Bug/Display.html?id=127774>
+You can forcefully enable it either by setting C<$ENV{T2_CHECK_DEPTH} = 1> or
+C<$Test2::API::DO_DEPTH_CHECK = 1> B<BEFORE> loading L<Test2::API>.
+
+=head3 OPTIONAL PARAMETERS
+
+All parameters to C<context> are optional.
+
+=over 4
+
+=item level => $int
+
+If you must obtain a context in a sub deper than your entry point you can use
+this to tell it how many EXTRA stack frames to look back. If this option is not
+provided the default of C<0> is used.
+
+ sub third_party_tool {
+ my $sub = shift;
+ ... # Does not obtain a context
+ $sub->();
+ ...
+ }
+
+ third_party_tool(sub {
+ my $ctx = context(level => 1);
+ ...
+ $ctx->release;
+ });
+
+=item wrapped => $int
+
+Use this if you need to write your own tool that wraps a call to C<context()>
+with the intent that it should return a context object.
+
+ sub my_context {
+ my %params = ( wrapped => 0, @_ );
+ $params{wrapped}++;
+ my $ctx = context(%params);
+ ...
+ return $ctx;
+ }
+
+ sub my_tool {
+ my $ctx = my_context();
+ ...
+ $ctx->release;
+ }
+
+If you do not do this than tools you call that also check for a context will
+notice that the context they grabbed was created at the same stack depth, which
+will trigger protective measures that warn you and destroy the existing
+context.
+
+=item stack => $stack
+
+Normally C<context()> looks at the global hub stack. If you are maintaining
+your own L<Test2::API::Stack> instance you may pass it in to be used
+instead of the global one.
+
+=item hub => $hub
+
+Use this parameter if you want to obtain the context for a specific hub instead
+of whatever one happens to be at the top of the stack.
+
+=item on_init => sub { ... }
+
+This lets you provide a callback sub that will be called B<ONLY> if your call
+to C<context()> generated a new context. The callback B<WILL NOT> be called if
+C<context()> is returning an existing context. The only argument passed into
+the callback will be the context object itself.
+
+ sub foo {
+ my $ctx = context(on_init => sub { 'will run' });
+
+ my $inner = sub {
+ # This callback is not run since we are getting the existing
+ # context from our parent sub.
+ my $ctx = context(on_init => sub { 'will NOT run' });
+ $ctx->release;
+ }
+ $inner->();
+
+ $ctx->release;
+ }
+
+=item on_release => sub { ... }
+
+This lets you provide a callback sub that will be called when the context
+instance is released. This callback will be added to the returned context even
+if an existing context is returned. If multiple calls to context add callbacks
+then all will be called in reverse order when the context is finally released.
+
+ sub foo {
+ my $ctx = context(on_release => sub { 'will run second' });
+
+ my $inner = sub {
+ my $ctx = context(on_release => sub { 'will run first' });
+
+ # Neither callback runs on this release
+ $ctx->release;
+ }
+ $inner->();
+
+ # Both callbacks run here.
+ $ctx->release;
+ }
+
+=back
+
+=head2 release($;$)
+
+Usage:
+
+=over 4
+
+=item release $ctx;
+
+=item release $ctx, ...;
+
+=back
+
+This is intended as a shortcut that lets you release your context and return a
+value in one statement. This function will get your context, and an optional
+return value. It will release your context, then return your value. Scalar
+context is always assumed.
+
+ sub tool {
+ my $ctx = context();
+ ...
+
+ return release $ctx, 1;
+ }
+
+This tool is most useful when you want to return the value you get from calling
+a function that needs to see the current context:
+
+ my $ctx = context();
+ my $out = some_tool(...);
+ $ctx->release;
+ return $out;
+
+We can combine the last 3 lines of the above like so:
+
+ my $ctx = context();
+ release $ctx, some_tool(...);
+
+=head2 context_do(&;@)
+
+Usage:
+
+ sub my_tool {
+ context_do {
+ my $ctx = shift;
+
+ my (@args) = @_;
+
+ $ctx->ok(1, "pass");
+
+ ...
+
+ # No need to call $ctx->release, done for you on scope exit.
+ } @_;
+ }
+
+Using this inside your test tool takes care of a lot of boilerplate for you. It
+will ensure a context is acquired. It will capture and rethrow any exception. It
+will insure the context is released when you are done. It preserves the
+subroutine call context (array, scalar, void).
+
+This is the safest way to write a test tool. The only 2 downsides to this are a
+slight performance decrease, and some extra indentation in your source. If the
+indentation is a problem for you then you can take a peek at the next section.
+
+=head2 no_context(&;$)
+
+Usage:
+
+=over 4
+
+=item no_context { ... };
+
+=item no_context { ... } $hid;
+
+ sub my_tool(&) {
+ my $code = shift;
+ my $ctx = context();
+ ...
+
+ no_context {
+ # Things in here will not see our current context, they get a new
+ # one.
+
+ $code->();
+ };
+
+ ...
+ $ctx->release;
+ };
+
+=back
+
+This tool will hide a context for the provided block of code. This means any
+tools run inside the block will get a completely new context if they acquire
+one. The new context will be inherited by tools nested below the one that
+acquired it.
+
+This will normally hide the current context for the top hub. If you need to
+hide the context for a different hub you can pass in the optional C<$hid>
+parameter.
+
+=head2 intercept(&)
+
+Usage:
+
+ my $events = intercept {
+ ok(1, "pass");
+ ok(0, "fail");
+ ...
+ };
+
+This function takes a codeblock as its only argument, and it has a prototype.
+It will execute the codeblock, intercepting any generated events in the
+process. It will return an array reference with all the generated event
+objects. All events should be subclasses of L<Test2::Event>.
+
+This is a very low-level subtest tool. This is useful for writing tools which
+produce subtests. This is not intended for people simply writing tests.
+
+=head2 run_subtest(...)
+
+Usage:
+
+ run_subtest($NAME, \&CODE, $BUFFERED, @ARGS)
+
+ # or
+
+ run_subtest($NAME, \&CODE, \%PARAMS, @ARGS)
+
+This will run the provided codeblock with the args in C<@args>. This codeblock
+will be run as a subtest. A subtest is an isolated test state that is condensed
+into a single L<Test2::Event::Subtest> event, which contains all events
+generated inside the subtest.
+
+=head3 ARGUMENTS:
+
+=over 4
+
+=item $NAME
+
+The name of the subtest.
+
+=item \&CODE
+
+The code to run inside the subtest.
+
+=item $BUFFERED or \%PARAMS
+
+If this is a simple scalar then it will be treated as a boolean for the
+'buffered' setting. If this is a hash reference then it wil be used as a
+parameters hash. The param hash will be used for hub construction (with the
+'buffered' key removed).
+
+If this is true, or a hashref with a true value for the 'buffered' key, then
+the subtest will be buffered.
+
+=item @ARGS
+
+Any extra arguments you want passed into the subtest code.
+
+=back
+
+=head3 BUFFERED VS UNBUFFERED (OR STREAMED)
+
+Normally all events inside and outside a subtest are sent to the formatter
+immedietly by the hub. Sometimes it is desirable to hold off sending events
+within a subtest until the subtest is complete. This usually depends on the
+formatter being used.
+
+=over 4
+
+=item Things not effected by this flag
+
+In both cases events are generated and stored in an array. This array is
+eventually used to populate the C<subevents> attribute on the
+L<Test2::Event::Subtest> event that is generated at the end of the subtest.
+This flag has no effect on this part, it always happens.
+
+At the end of the subtest the final L<Test2::Event::Subtest> event is sent to
+the formatter.
+
+=item Things that are effected by this flag
+
+The C<buffered> attribute of the L<Test2::Event::Subtest> event will be set to
+the value of this flag. This means any formatter, listener, etc which looks at
+the event will know if it was buffered.
+
+=item Things that are formatter dependant
+
+Events within a buffered subtest may or may not be sent to the formatter as
+they happen. If a formatter fails to specify then the default is to B<NOT SEND>
+the events as they are generated, instead the formatter can pull them from the
+C<subevents> attribute.
+
+A formatter can specify by implementing the C<hide_buffered()> method. If this
+method returns true then events generated inside a buffered subtest will not be
+sent independantly of the final subtest event.
+
+=back
+
+An example of how this is used is the L<Test2::Formatter::TAP> formatter. For
+unbuffered subtests the events are rendered as they are generated. At the end
+of the subtest the final subtest event is rendered, but the C<subevents>
+attribute is ignored. For buffered subtests the opposite occurs, the events are
+NOT rendered as they are generated, instead the C<subevents> attribute is used
+to render them all at once. This is useful when running subtests tests in
+parallel, without it the subtests would be garbled.
+
+=head1 OTHER API EXPORTS
+
+Exports in this section are not commonly needed. These all have the 'test2_'
+prefix to help ensure they stand out. You should look at the L</MAIN API
+EXPORTS> section before looking here. This section is one where "Great power
+comes with great responsiblity". It is possible to break things badly if you
+are not careful with these.
+
+All exports are optional, you need to list which ones you want at import time:
+
+ use Test2::API qw/test2_init_done .../;
+
+=head2 STATUS AND INITIALIZATION STATE
+
+These provide access to internal state and object instances.
+
+=over 4
+
+=item $bool = test2_init_done()
+
+This will return true if the stack and ipc instances have already been
+initialized. It will return false if they have not. Init happens as late as
+possible, it happens as soon as a tool requests the ipc instance, the
+formatter, or the stack.
+
+=item $bool = test2_load_done()
+
+This will simply return the boolean value of the loaded flag. If Test2 has
+finished loading this will be true, otherwise false. Loading is considered
+complete the first time a tool requests a context.
+
+=item test2_set_is_end()
+
+=item test2_set_is_end($bool)
+
+This is used to toggle Test2's belief that the END phase has already started.
+With no arguments this will set it to true. With arguments it will set it to
+the first argument's value.
+
+This is used to prevent the use of C<caller()> in END blocks which can cause
+segfaults. This is only necessary in some persistent environments that may have
+multiple END phases.
+
+=item $bool = test2_get_is_end()
+
+Check if test2 believes it is the END phase.
+
+=item $stack = test2_stack()
+
+This will return the global L<Test2::API::Stack> instance. If this has not
+yet been initialized it will be initialized now.
+
+=item $bool = test2_no_wait()
+
+=item test2_no_wait($bool)
+
+This can be used to get/set the no_wait status. Waiting is turned on by
+default. Waiting will cause the parent process/thread to wait until all child
+processes and threads are finished before exiting. You will almost never want
+to turn this off.
+
+=back
+
+=head2 BEHAVIOR HOOKS
+
+These are hooks that allow you to add custom behavior to actions taken by Test2
+and tools built on top of it.
+
+=over 4
+
+=item test2_add_callback_exit(sub { ... })
+
+This can be used to add a callback that is called after all testing is done. This
+is too late to add additional results, the main use of this callback is to set the
+exit code.
+
+ test2_add_callback_exit(
+ sub {
+ my ($context, $exit, \$new_exit) = @_;
+ ...
+ }
+ );
+
+The C<$context> passed in will be an instance of L<Test2::API::Context>. The
+C<$exit> argument will be the original exit code before anything modified it.
+C<$$new_exit> is a reference to the new exit code. You may modify this to
+change the exit code. Please note that C<$$new_exit> may already be different
+from C<$exit>
+
+=item test2_add_callback_post_load(sub { ... })
+
+Add a callback that will be called when Test2 is finished loading. This
+means the callback will be run once, the first time a context is obtained.
+If Test2 has already finished loading then the callback will be run immedietly.
+
+=item test2_add_callback_context_acquire(sub { ... })
+
+Add a callback that will be called every time someone tries to acquire a
+context. This will be called on EVERY call to C<context()>. It gets a single
+argument, a reference the the hash of parameters being used the construct the
+context. This is your chance to change the parameters by directly altering the
+hash.
+
+ test2_add_callback_context_acquire(sub {
+ my $params = shift;
+ $params->{level}++;
+ });
+
+This is a very scary API function. Please do not use this unless you need to.
+This is here for L<Test::Builder> and backwards compatibility. This has you
+directly manipulate the hash instead of returning a new one for performance
+reasons.
+
+=item test2_add_callback_context_init(sub { ... })
+
+Add a callback that will be called every time a new context is created. The
+callback will receive the newly created context as its only argument.
+
+=item test2_add_callback_context_release(sub { ... })
+
+Add a callback that will be called every time a context is released. The
+callback will receive the released context as its only argument.
+
+=item @list = test2_list_context_acquire_callbacks()
+
+Return all the context acquire callback references.
+
+=item @list = test2_list_context_init_callbacks()
+
+Returns all the context init callback references.
+
+=item @list = test2_list_context_release_callbacks()
+
+Returns all the context release callback references.
+
+=item @list = test2_list_exit_callbacks()
+
+Returns all the exit callback references.
+
+=item @list = test2_list_post_load_callbacks()
+
+Returns all the post load callback references.
+
+=back
+
+=head2 IPC AND CONCURRENCY
+
+These let you access, or specify, the IPC system internals.
+
+=over 4
+
+=item $ipc = test2_ipc()
+
+This will return the global L<Test2::IPC::Driver> instance. If this has not yet
+been initialized it will be initialized now.
+
+=item test2_ipc_add_driver($DRIVER)
+
+Add an IPC driver to the list. This will add the driver to the start of the
+list.
+
+=item @drivers = test2_ipc_drivers()
+
+Get the list of IPC drivers.
+
+=item $bool = test2_ipc_polling()
+
+Check if polling is enabled.
+
+=item test2_ipc_enable_polling()
+
+Turn on polling. This will cull events from other processes and threads every
+time a context is created.
+
+=item test2_ipc_disable_polling()
+
+Turn off IPC polling.
+
+=item test2_ipc_enable_shm()
+
+Turn on IPC shm. Only some IPC drivers use this, and most will turn it on
+themselves.
+
+=item test2_ipc_set_pending($uniq_val)
+
+Tell other processes and events that an event is pending. C<$uniq_val> should
+be a unique value no other thread/process will generate.
+
+B<Note:> After calling this C<test2_ipc_get_pending()> will return 1. This is
+intentional, and not avoidable.
+
+=item $pending = test2_ipc_get_pending()
+
+This returns -1 if there is no way to check (assume yes)
+
+This returns 0 if there are (most likely) no pending events.
+
+This returns 1 if there are (likely) pending events. Upon return it will reset,
+nothing else will be able to see that there were pending events.
+
+=back
+
+=head2 MANAGING FORMATTERS
+
+These let you access, or specify, the formatters that can/should be used.
+
+=over 4
+
+=item $formatter = test2_formatter
+
+This will return the global formatter class. This is not an instance. By
+default the formatter is set to L<Test2::Formatter::TAP>.
+
+You can override this default using the C<T2_FORMATTER> environment variable.
+
+Normally 'Test2::Formatter::' is prefixed to the value in the
+environment variable:
+
+ $ T2_FORMATTER='TAP' perl test.t # Use the Test2::Formatter::TAP formatter
+ $ T2_FORMATTER='Foo' perl test.t # Use the Test2::Formatter::Foo formatter
+
+If you want to specify a full module name you use the '+' prefix:
+
+ $ T2_FORMATTER='+Foo::Bar' perl test.t # Use the Foo::Bar formatter
+
+=item test2_formatter_set($class_or_instance)
+
+Set the global formatter class. This can only be set once. B<Note:> This will
+override anything specified in the 'T2_FORMATTER' environment variable.
+
+=item @formatters = test2_formatters()
+
+Get a list of all loaded formatters.
+
+=item test2_formatter_add($class_or_instance)
+
+Add a formatter to the list. Last formatter added is used at initialization. If
+this is called after initialization a warning will be issued.
+
+=back
+
+=head1 OTHER EXAMPLES
+
+See the C</Examples/> directory included in this distribution.
+
+=head1 SEE ALSO
+
+L<Test2::API::Context> - Detailed documentation of the context object.
+
+L<Test2::IPC> - The IPC system used for threading/fork support.
+
+L<Test2::Formatter> - Formatters such as TAP live here.
+
+L<Test2::Event> - Events live in this namespace.
+
+L<Test2::Hub> - All events eventually funnel through a hub. Custom hubs are how
+C<intercept()> and C<run_subtest()> are implemented.
+
+=head1 MAGIC
+
+This package has an END block. This END block is responsible for setting the
+exit code based on the test results. This end block also calls the callbacks that
+can be added to this package.
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut
--- /dev/null
+package Test2::API::Breakage;
+use strict;
+use warnings;
+
+our $VERSION = '1.302015';
+
+
+use Test2::Util qw/pkg_to_file/;
+
+our @EXPORT_OK = qw{
+ upgrade_suggested
+ upgrade_required
+ known_broken
+};
+use base 'Exporter';
+
+sub upgrade_suggested {
+ return (
+ 'Test::Exception' => '0.42',
+ 'Test::FITesque' => '0.04',
+ 'Test::Module::Used' => '0.2.5',
+ 'Test::Moose::More' => '0.025',
+ );
+}
+
+sub upgrade_required {
+ return (
+ 'Test::Builder::Clutch' => '0.07',
+ 'Test::Dist::VersionSync' => '1.1.4',
+ 'Test::Modern' => '0.012',
+ 'Test::SharedFork' => '0.34',
+ 'Test::Alien' => '0.04',
+
+ 'Test::Clustericious::Cluster' => '0.30',
+ );
+}
+
+sub known_broken {
+ return (
+ 'Net::BitTorrent' => '0.052',
+ 'Test::Able' => '0.11',
+ 'Test::Aggregate' => '0.373',
+ 'Test::Flatten' => '0.11',
+ 'Test::Group' => '0.20',
+ 'Test::More::Prefix' => '0.005',
+ 'Test::ParallelSubtest' => '0.05',
+ 'Test::Pretty' => '0.32',
+ 'Test::Wrapper' => '0.3.0',
+
+ 'Test::DBIx::Class::Schema' => '1.0.9',
+ 'Log::Dispatch::Config::TestLog' => '0.02',
+ );
+}
+
+# Not reportable:
+# Device::Chip => 0.07 - Tests will not pass, but not broken if already installed, also no fixed version we can upgrade to.
+
+sub report {
+ my $class = shift;
+ my ($require) = @_;
+
+ my %suggest = __PACKAGE__->upgrade_suggested();
+ my %required = __PACKAGE__->upgrade_required();
+ my %broken = __PACKAGE__->known_broken();
+
+ my @warn;
+ for my $mod (keys %suggest) {
+ my $file = pkg_to_file($mod);
+ next unless $INC{$file} || ($require && eval { require $file; 1 });
+ my $want = $suggest{$mod};
+ next if eval { $mod->VERSION($want); 1 };
+ push @warn => " * Module '$mod' is outdated, we recommed updating above $want.";
+ }
+
+ for my $mod (keys %required) {
+ my $file = pkg_to_file($mod);
+ next unless $INC{$file} || ($require && eval { require $file; 1 });
+ my $want = $required{$mod};
+ next if eval { $mod->VERSION($want); 1 };
+ push @warn => " * Module '$mod' is outdated and known to be broken, please update to $want or higher.";
+ }
+
+ for my $mod (keys %broken) {
+ my $file = pkg_to_file($mod);
+ next unless $INC{$file} || ($require && eval { require $file; 1 });
+ my $tested = $broken{$mod};
+ push @warn => " * Module '$mod' is known to be broken in version $tested and below, newer versions have not been tested. You have: " . $mod->VERSION;
+ }
+
+ return @warn;
+}
+
+1;
+
+__END__
+
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2::API::Breakage - What breaks at what version
+
+=head1 DESCRIPTION
+
+This module provides lists of modules that are broken, or have been broken in
+the past, when upgrading L<Test::Builder> to use L<Test2>.
+
+=head1 FUNCTIONS
+
+These can be imported, or called as methods on the class.
+
+=over 4
+
+=item %mod_ver = upgrade_suggested()
+
+=item %mod_ver = Test2::API::Breakage->upgrade_suggested()
+
+This returns key/value pairs. The key is the module name, the value is the
+version number. If the installed version of the module is at or below the
+specified one then an upgrade would be a good idea, but not strictly necessary.
+
+=item %mod_ver = upgrade_required()
+
+=item %mod_ver = Test2::API::Breakage->upgrade_required()
+
+This returns key/value pairs. The key is the module name, the value is the
+version number. If the installed version of the module is at or below the
+specified one then an upgrade is required for the module to work properly.
+
+=item %mod_ver = known_broken()
+
+=item %mod_ver = Test2::API::Breakage->known_broken()
+
+This returns key/value pairs. The key is the module name, the value is the
+version number. If the installed version of the module is at or below the
+specified one then the module will not work. A newer version may work, but is
+not tested or verified.
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut
--- /dev/null
+package Test2::API::Context;
+use strict;
+use warnings;
+
+our $VERSION = '1.302015';
+
+
+use Carp qw/confess croak longmess/;
+use Scalar::Util qw/weaken/;
+use Test2::Util qw/get_tid try pkg_to_file get_tid/;
+
+use Test2::Util::Trace();
+use Test2::API();
+
+# Preload some key event types
+my %LOADED = (
+ map {
+ my $pkg = "Test2::Event::$_";
+ my $file = "Test2/Event/$_.pm";
+ require $file unless $INC{$file};
+ ( $pkg => $pkg, $_ => $pkg )
+ } qw/Ok Diag Note Plan Bail Exception Waiting Skip Subtest/
+);
+
+use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/;
+use Test2::Util::HashBase qw{
+ stack hub trace _on_release _depth _is_canon _is_spawn _aborted
+ errno eval_error child_error
+};
+
+# Private, not package vars
+# It is safe to cache these.
+my $ON_RELEASE = Test2::API::_context_release_callbacks_ref();
+my $CONTEXTS = Test2::API::_contexts_ref();
+
+sub init {
+ my $self = shift;
+
+ confess "The 'trace' attribute is required"
+ unless $self->{+TRACE};
+
+ confess "The 'hub' attribute is required"
+ unless $self->{+HUB};
+
+ $self->{+_DEPTH} = 0 unless defined $self->{+_DEPTH};
+
+ $self->{+ERRNO} = $! unless exists $self->{+ERRNO};
+ $self->{+EVAL_ERROR} = $@ unless exists $self->{+EVAL_ERROR};
+ $self->{+CHILD_ERROR} = $? unless exists $self->{+CHILD_ERROR};
+}
+
+sub snapshot { bless {%{$_[0]}, _is_canon => undef, _is_spawn => undef, _aborted => undef}, __PACKAGE__ }
+
+sub restore_error_vars {
+ my $self = shift;
+ ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR};
+}
+
+sub DESTROY {
+ return unless $_[0]->{+_IS_CANON} || $_[0]->{+_IS_SPAWN};
+ return if $_[0]->{+_ABORTED} && ${$_[0]->{+_ABORTED}};
+ my ($self) = @_;
+
+ my $hub = $self->{+HUB};
+ my $hid = $hub->{hid};
+
+ # Do not show the warning if it looks like an exception has been thrown, or
+ # if the context is not local to this process or thread.
+ if($self->{+EVAL_ERROR} eq $@ && $hub->is_local) {
+ my $frame = $self->{+_IS_SPAWN} || $self->{+TRACE}->frame;
+ warn <<" EOT";
+A context appears to have been destroyed without first calling release().
+Based on \$@ it does not look like an exception was thrown (this is not always
+a reliable test)
+
+This is a problem because the global error variables (\$!, \$@, and \$?) will
+not be restored. In addition some release callbacks will not work properly from
+inside a DESTROY method.
+
+Here are the context creation details, just in case a tool forgot to call
+release():
+ File: $frame->[1]
+ Line: $frame->[2]
+ Tool: $frame->[3]
+
+Cleaning up the CONTEXT stack...
+ EOT
+ }
+
+ return if $self->{+_IS_SPAWN};
+
+ # Remove the key itself to avoid a slow memory leak
+ delete $CONTEXTS->{$hid};
+ $self->{+_IS_CANON} = undef;
+
+ if (my $cbk = $self->{+_ON_RELEASE}) {
+ $_->($self) for reverse @$cbk;
+ }
+ if (my $hcbk = $hub->{_context_release}) {
+ $_->($self) for reverse @$hcbk;
+ }
+ $_->($self) for reverse @$ON_RELEASE;
+}
+
+# release exists to implement behaviors like die-on-fail. In die-on-fail you
+# want to die after a failure, but only after diagnostics have been reported.
+# The ideal time for the die to happen is when the context is released.
+# Unfortunately die does not work in a DESTROY block.
+sub release {
+ my ($self) = @_;
+
+ ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} and return $self->{+_IS_SPAWN} = undef
+ if $self->{+_IS_SPAWN};
+
+ croak "release() should not be called on context that is neither canon nor a child"
+ unless $self->{+_IS_CANON};
+
+ my $hub = $self->{+HUB};
+ my $hid = $hub->{hid};
+
+ croak "context thinks it is canon, but it is not"
+ unless $CONTEXTS->{$hid} && $CONTEXTS->{$hid} == $self;
+
+ # Remove the key itself to avoid a slow memory leak
+ $self->{+_IS_CANON} = undef;
+ delete $CONTEXTS->{$hid};
+
+ if (my $cbk = $self->{+_ON_RELEASE}) {
+ $_->($self) for reverse @$cbk;
+ }
+ if (my $hcbk = $hub->{_context_release}) {
+ $_->($self) for reverse @$hcbk;
+ }
+ $_->($self) for reverse @$ON_RELEASE;
+
+ # Do this last so that nothing else changes them.
+ # If one of the hooks dies then these do not get restored, this is
+ # intentional
+ ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR};
+
+ return;
+}
+
+sub do_in_context {
+ my $self = shift;
+ my ($sub, @args) = @_;
+
+ # We need to update the pid/tid and error vars.
+ my $clone = $self->snapshot;
+ @$clone{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} = ($!, $@, $?);
+ $clone->{+TRACE} = $clone->{+TRACE}->snapshot;
+ $clone->{+TRACE}->set_pid($$);
+ $clone->{+TRACE}->set_tid(get_tid());
+
+ my $hub = $clone->{+HUB};
+ my $hid = $hub->hid;
+
+ my $old = $CONTEXTS->{$hid};
+
+ $clone->{+_IS_CANON} = 1;
+ $CONTEXTS->{$hid} = $clone;
+ weaken($CONTEXTS->{$hid});
+ my ($ok, $err) = &try($sub, @args);
+ my ($rok, $rerr) = try { $clone->release };
+ delete $clone->{+_IS_CANON};
+
+ if ($old) {
+ $CONTEXTS->{$hid} = $old;
+ weaken($CONTEXTS->{$hid});
+ }
+ else {
+ delete $CONTEXTS->{$hid};
+ }
+
+ die $err unless $ok;
+ die $rerr unless $rok;
+}
+
+sub done_testing {
+ my $self = shift;
+ $self->hub->finalize($self->trace, 1);
+ return;
+}
+
+sub throw {
+ my ($self, $msg) = @_;
+ ${$self->{+_ABORTED}}++ if $self->{+_ABORTED};
+ $self->release if $self->{+_IS_CANON} || $self->{+_IS_SPAWN};
+ $self->trace->throw($msg);
+}
+
+sub alert {
+ my ($self, $msg) = @_;
+ $self->trace->alert($msg);
+}
+
+sub send_event {
+ my $self = shift;
+ my $event = shift;
+ my %args = @_;
+
+ my $pkg = $LOADED{$event} || $self->_parse_event($event);
+
+ $self->{+HUB}->send(
+ $pkg->new(
+ trace => $self->{+TRACE}->snapshot,
+ %args,
+ )
+ );
+}
+
+sub build_event {
+ my $self = shift;
+ my $event = shift;
+ my %args = @_;
+
+ my $pkg = $LOADED{$event} || $self->_parse_event($event);
+
+ $pkg->new(
+ trace => $self->{+TRACE}->snapshot,
+ %args,
+ );
+}
+
+sub ok {
+ my $self = shift;
+ my ($pass, $name, $diag) = @_;
+
+ my $hub = $self->{+HUB};
+
+ my $e = bless {
+ trace => bless( {%{$self->{+TRACE}}}, 'Test2::Util::Trace'),
+ pass => $pass,
+ name => $name,
+ }, 'Test2::Event::Ok';
+ $e->init;
+
+ $hub->send($e);
+ return $e if $pass;
+
+ $self->failure_diag($e);
+
+ if ($diag && @$diag) {
+ $self->diag($_) for @$diag
+ }
+
+ return $e;
+}
+
+sub failure_diag {
+ my $self = shift;
+ my ($e) = @_;
+
+ # This behavior is inherited from Test::Builder which injected a newline at
+ # the start of the first diagnostics when the harness is active, but not
+ # verbose. This is important to keep the diagnostics from showing up
+ # appended to the existing line, which is hard to read. In a verbose
+ # harness there is no need for this.
+ my $prefix = $ENV{HARNESS_ACTIVE} && !$ENV{HARNESS_IS_VERBOSE} ? "\n" : "";
+
+ # Figure out the debug info, this is typically the file name and line
+ # number, but can also be a custom message. If no trace object is provided
+ # then we have nothing useful to display.
+ my $name = $e->name;
+ my $trace = $e->trace;
+ my $debug = $trace ? $trace->debug : "[No trace info available]";
+
+ # Create the initial diagnostics. If the test has a name we put the debug
+ # info on a second line, this behavior is inherited from Test::Builder.
+ my $msg = defined($name)
+ ? qq[${prefix}Failed test '$name'\n$debug.\n]
+ : qq[${prefix}Failed test $debug.\n];
+
+ $self->diag($msg);
+}
+
+sub skip {
+ my $self = shift;
+ my ($name, $reason, @extra) = @_;
+ $self->send_event(
+ 'Skip',
+ name => $name,
+ reason => $reason,
+ pass => 1,
+ @extra,
+ );
+}
+
+sub note {
+ my $self = shift;
+ my ($message) = @_;
+ $self->send_event('Note', message => $message);
+}
+
+sub diag {
+ my $self = shift;
+ my ($message) = @_;
+ my $hub = $self->{+HUB};
+ $self->send_event(
+ 'Diag',
+ message => $message,
+ );
+}
+
+sub plan {
+ my ($self, $max, $directive, $reason) = @_;
+ ${$self->{+_ABORTED}}++ if $self->{+_ABORTED} && $directive && $directive =~ m/^(SKIP|skip_all)$/;
+ $self->send_event('Plan', max => $max, directive => $directive, reason => $reason);
+}
+
+sub bail {
+ my ($self, $reason) = @_;
+ ${$self->{+_ABORTED}}++ if $self->{+_ABORTED};
+ $self->send_event('Bail', reason => $reason);
+}
+
+sub _parse_event {
+ my $self = shift;
+ my $event = shift;
+
+ my $pkg;
+ if ($event =~ m/^\+(.*)/) {
+ $pkg = $1;
+ }
+ else {
+ $pkg = "Test2::Event::$event";
+ }
+
+ unless ($LOADED{$pkg}) {
+ my $file = pkg_to_file($pkg);
+ my ($ok, $err) = try { require $file };
+ $self->throw("Could not load event module '$pkg': $err")
+ unless $ok;
+
+ $LOADED{$pkg} = $pkg;
+ }
+
+ confess "'$pkg' is not a subclass of 'Test2::Event'"
+ unless $pkg->isa('Test2::Event');
+
+ $LOADED{$event} = $pkg;
+
+ return $pkg;
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2::API::Context - Object to represent a testing context.
+
+=head1 DESCRIPTION
+
+The context object is the primary interface for authors of testing tools
+written with L<Test2>. The context object represents the context in
+which a test takes place (File and Line Number), and provides a quick way to
+generate events from that context. The context object also takes care of
+sending events to the correct L<Test2::Hub> instance.
+
+=head1 SYNOPSIS
+
+In general you will not be creating contexts directly. To obtain a context you
+should always use C<context()> which is exported by the L<Test2::API> module.
+
+ use Test2::API qw/context/;
+
+ sub my_ok {
+ my ($bool, $name) = @_;
+ my $ctx = context();
+ $ctx->ok($bool, $name);
+ $ctx->release; # You MUST do this!
+ return $bool;
+ }
+
+Context objects make it easy to wrap other tools that also use context. Once
+you grab a context, any tool you call before releasing your context will
+inherit it:
+
+ sub wrapper {
+ my ($bool, $name) = @_;
+ my $ctx = context();
+ $ctx->diag("wrapping my_ok");
+
+ my $out = my_ok($bool, $name);
+ $ctx->release; # You MUST do this!
+ return $out;
+ }
+
+=head1 CRITICAL DETAILS
+
+=over 4
+
+=item you MUST always use the context() sub from Test2::API
+
+Creating your own context via C<< Test2::API::Context->new() >> will almost never
+produce a desirable result. Use C<context()> which is exported by L<Test2>.
+
+There are a handful of cases where a tool author may want to create a new
+context by hand, which is why the C<new> method exists. Unless you really know
+what you are doing you should avoid this.
+
+=item You MUST always release the context when done with it
+
+Releasing the context tells the system you are done with it. This gives it a
+chance to run any necessary callbacks or cleanup tasks. If you forget to
+release the context it will try to detect the problem and warn you about it.
+
+=item You MUST NOT pass context objects around
+
+When you obtain a context object it is made specifically for your tool and any
+tools nested within. If you pass a context around you run the risk of polluting
+other tools with incorrect context information.
+
+If you are certain that you want a different tool to use the same context you
+may pass it a snapshot. C<< $ctx->snapshot >> will give you a shallow clone of
+the context that is safe to pass around or store.
+
+=item You MUST NOT store or cache a context for later
+
+As long as a context exists for a given hub, all tools that try to get a
+context will get the existing instance. If you try to store the context you
+will pollute other tools with incorrect context information.
+
+If you are certain that you want to save the context for later, you can use a
+snapshot. C<< $ctx->snapshot >> will give you a shallow clone of the context
+that is safe to pass around or store.
+
+C<context()> has some mechanisms to protect you if you do cause a context to
+persist beyond the scope in which it was obtained. In practice you should not
+rely on these protections, and they are fairly noisy with warnings.
+
+=item You SHOULD obtain your context as soon as possible in a given tool
+
+You never know what tools you call from within your own tool will need a
+context. Obtaining the context early ensures that nested tools can find the
+context you want them to find.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item $ctx->done_testing;
+
+Note that testing is finished. If no plan has been set this will generate a
+Plan event.
+
+=item $clone = $ctx->snapshot()
+
+This will return a shallow clone of the context. The shallow clone is safe to
+store for later.
+
+=item $ctx->release()
+
+This will release the context. This runs cleanup tasks, and several important
+hooks. It will also restore C<$!>, C<$?>, and C<$@> to what they were when the
+context was created.
+
+B<Note:> If a context is acquired more than once an internal refcount is kept.
+C<release()> decrements the ref count, none of the other actions of
+C<release()> will occur unless the refcount hits 0. This means only the last
+call to C<release()> will reset C<$?>, C<$!>, C<$@>,and run the cleanup tasks.
+
+=item $ctx->throw($message)
+
+This will throw an exception reporting to the file and line number of the
+context. This will also release the context for you.
+
+=item $ctx->alert($message)
+
+This will issue a warning from the file and line number of the context.
+
+=item $stack = $ctx->stack()
+
+This will return the L<Test2::API::Stack> instance the context used to find
+the current hub.
+
+=item $hub = $ctx->hub()
+
+This will return the L<Test2::Hub> instance the context recognises as
+the current one to which all events should be sent.
+
+=item $dbg = $ctx->trace()
+
+This will return the L<Test2::Util::Trace> instance used by the context.
+
+=item $ctx->do_in_context(\&code, @args);
+
+Sometimes you have a context that is not current, and you want things to use it
+as the current one. In these cases you can call
+C<< $ctx->do_in_context(sub { ... }) >>. The codeblock will be run, and
+anything inside of it that looks for a context will find the one on which the
+method was called.
+
+This B<DOES NOT> affect context on other hubs, only the hub used by the context
+will be affected.
+
+ my $ctx = ...;
+ $ctx->do_in_context(sub {
+ my $ctx = context(); # returns the $ctx the sub is called on
+ });
+
+B<Note:> The context will actually be cloned, the clone will be used instead of
+the original. This allows the TID, PID, and error vars to be correct without
+modifying the original context.
+
+=item $ctx->restore_error_vars()
+
+This will set C<$!>, C<$?>, and C<$@> to what they were when the context was
+created. There is no localization or anything done here, calling this method
+will actually set these vars.
+
+=item $! = $ctx->errno()
+
+The (numeric) value of C<$!> when the context was created.
+
+=item $? = $ctx->child_error()
+
+The value of C<$?> when the context was created.
+
+=item $@ = $ctx->eval_error()
+
+The value of C<$@> when the context was created.
+
+=back
+
+=head2 EVENT PRODUCTION METHODS
+
+=over 4
+
+=item $event = $ctx->ok($bool, $name)
+
+=item $event = $ctx->ok($bool, $name, \@diag)
+
+This will create an L<Test2::Event::Ok> object for you. If C<$bool> is false
+then an L<Test2::Event::Diag> event will be sent as well with details about the
+failure. If you do not want automatic diagnostics you should use the
+C<send_event()> method directly.
+
+The C<\@diag> can contain diagnostics messages you wish to have displayed in the
+event of a failure. For a passing test the diagnostics array will be ignored.
+
+=item $event = $ctx->note($message)
+
+Send an L<Test2::Event::Note>. This event prints a message to STDOUT.
+
+=item $event = $ctx->diag($message)
+
+Send an L<Test2::Event::Diag>. This event prints a message to STDERR.
+
+=item $event = $ctx->plan($max)
+
+=item $event = $ctx->plan(0, 'SKIP', $reason)
+
+This can be used to send an L<Test2::Event::Plan> event. This event
+usually takes either a number of tests you expect to run. Optionally you can
+set the expected count to 0 and give the 'SKIP' directive with a reason to
+cause all tests to be skipped.
+
+=item $event = $ctx->skip($name, $reason);
+
+Send an L<Test2::Event::Skip> event.
+
+=item $event = $ctx->bail($reason)
+
+This sends an L<Test2::Event::Bail> event. This event will completely
+terminate all testing.
+
+=item $event = $ctx->send_event($Type, %parameters)
+
+This lets you build and send an event of any type. The C<$Type> argument should
+be the event package name with C<Test2::Event::> left off, or a fully
+qualified package name prefixed with a '+'. The event is returned after it is
+sent.
+
+ my $event = $ctx->send_event('Ok', ...);
+
+or
+
+ my $event = $ctx->send_event('+Test2::Event::Ok', ...);
+
+=item $event = $ctx->build_event($Type, %parameters)
+
+This is the same as C<send_event()>, except it builds and returns the event
+without sending it.
+
+=back
+
+=head1 HOOKS
+
+There are 2 types of hooks, init hooks, and release hooks. As the names
+suggest, these hooks are triggered when contexts are created or released.
+
+=head2 INIT HOOKS
+
+These are called whenever a context is initialized. That means when a new
+instance is created. These hooks are B<NOT> called every time something
+requests a context, just when a new one is created.
+
+=head3 GLOBAL
+
+This is how you add a global init callback. Global callbacks happen for every
+context for any hub or stack.
+
+ Test2::API::test2_add_callback_context_init(sub {
+ my $ctx = shift;
+ ...
+ });
+
+=head3 PER HUB
+
+This is how you add an init callback for all contexts created for a given hub.
+These callbacks will not run for other hubs.
+
+ $hub->add_context_init(sub {
+ my $ctx = shift;
+ ...
+ });
+
+=head3 PER CONTEXT
+
+This is how you specify an init hook that will only run if your call to
+C<context()> generates a new context. The callback will be ignored if
+C<context()> is returning an existing context.
+
+ my $ctx = context(on_init => sub {
+ my $ctx = shift;
+ ...
+ });
+
+=head2 RELEASE HOOKS
+
+These are called whenever a context is released. That means when the last
+reference to the instance is about to be destroyed. These hooks are B<NOT>
+called every time C<< $ctx->release >> is called.
+
+=head3 GLOBAL
+
+This is how you add a global release callback. Global callbacks happen for every
+context for any hub or stack.
+
+ Test2::API::test2_add_callback_context_release(sub {
+ my $ctx = shift;
+ ...
+ });
+
+=head3 PER HUB
+
+This is how you add a release callback for all contexts created for a given
+hub. These callbacks will not run for other hubs.
+
+ $hub->add_context_release(sub {
+ my $ctx = shift;
+ ...
+ });
+
+=head3 PER CONTEXT
+
+This is how you add release callbacks directly to a context. The callback will
+B<ALWAYS> be added to the context that gets returned, it does not matter if a
+new one is generated, or if an existing one is returned.
+
+ my $ctx = context(on_release => sub {
+ my $ctx = shift;
+ ...
+ });
+
+=head1 THIRD PARTY META-DATA
+
+This object consumes L<Test2::Util::ExternalMeta> which provides a consistent
+way for you to attach meta-data to instances of this class. This is useful for
+tools, plugins, and other extentions.
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Kent Fredric E<lt>kentnl@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut
--- /dev/null
+package Test2::API::Instance;
+use strict;
+use warnings;
+
+our $VERSION = '1.302015';
+
+
+our @CARP_NOT = qw/Test2::API Test2::API::Instance Test2::IPC::Driver Test2::Formatter/;
+use Carp qw/confess carp/;
+use Scalar::Util qw/reftype/;
+
+use Test2::Util qw/get_tid USE_THREADS CAN_FORK pkg_to_file try/;
+
+use Test2::Util::Trace();
+use Test2::API::Stack();
+
+use Test2::Util::HashBase qw{
+ pid tid
+ no_wait
+ finalized loaded
+ ipc stack formatter
+ contexts
+
+ ipc_shm_size
+ ipc_shm_last
+ ipc_shm_id
+ ipc_polling
+ ipc_drivers
+ formatters
+
+ exit_callbacks
+ post_load_callbacks
+ context_acquire_callbacks
+ context_init_callbacks
+ context_release_callbacks
+};
+
+# Wrap around the getters that should call _finalize.
+BEGIN {
+ for my $finalizer (IPC, FORMATTER) {
+ my $orig = __PACKAGE__->can($finalizer);
+ my $new = sub {
+ my $self = shift;
+ $self->_finalize unless $self->{+FINALIZED};
+ $self->$orig;
+ };
+
+ no strict 'refs';
+ no warnings 'redefine';
+ *{$finalizer} = $new;
+ }
+}
+
+sub import {
+ my $class = shift;
+ return unless @_;
+ my ($ref) = @_;
+ $$ref = $class->new;
+}
+
+sub init { $_[0]->reset }
+
+sub reset {
+ my $self = shift;
+
+ $self->{+PID} = $$;
+ $self->{+TID} = get_tid();
+ $self->{+CONTEXTS} = {};
+
+ $self->{+IPC_DRIVERS} = [];
+ $self->{+IPC_POLLING} = undef;
+
+ $self->{+FORMATTERS} = [];
+ $self->{+FORMATTER} = undef;
+
+ $self->{+FINALIZED} = undef;
+ $self->{+IPC} = undef;
+
+ $self->{+NO_WAIT} = 0;
+ $self->{+LOADED} = 0;
+
+ $self->{+EXIT_CALLBACKS} = [];
+ $self->{+POST_LOAD_CALLBACKS} = [];
+ $self->{+CONTEXT_ACQUIRE_CALLBACKS} = [];
+ $self->{+CONTEXT_INIT_CALLBACKS} = [];
+ $self->{+CONTEXT_RELEASE_CALLBACKS} = [];
+
+ $self->{+STACK} = Test2::API::Stack->new;
+}
+
+sub _finalize {
+ my $self = shift;
+ my ($caller) = @_;
+ $caller ||= [caller(1)];
+
+ $self->{+FINALIZED} = $caller;
+
+ unless ($self->{+FORMATTER}) {
+ my ($formatter, $source);
+ if ($ENV{T2_FORMATTER}) {
+ $source = "set by the 'T2_FORMATTER' environment variable";
+
+ if ($ENV{T2_FORMATTER} =~ m/^(\+)?(.*)$/) {
+ $formatter = $1 ? $2 : "Test2::Formatter::$2"
+ }
+ else {
+ $formatter = '';
+ }
+ }
+ elsif (@{$self->{+FORMATTERS}}) {
+ ($formatter) = @{$self->{+FORMATTERS}};
+ $source = "Most recently added";
+ }
+ else {
+ $formatter = 'Test2::Formatter::TAP';
+ $source = 'default formatter';
+ }
+
+ unless (ref($formatter) || $formatter->can('write')) {
+ my $file = pkg_to_file($formatter);
+ my ($ok, $err) = try { require $file };
+ unless ($ok) {
+ my $line = "* COULD NOT LOAD FORMATTER '$formatter' ($source) *";
+ my $border = '*' x length($line);
+ die "\n\n $border\n $line\n $border\n\n$err";
+ }
+ }
+
+ $self->{+FORMATTER} = $formatter;
+ }
+
+ # Turn on IPC if threads are on, drivers are reigstered, or the Test2::IPC
+ # module is loaded.
+ return unless USE_THREADS || $INC{'Test2/IPC.pm'} || @{$self->{+IPC_DRIVERS}};
+
+ # Turn on polling by default, people expect it.
+ $self->enable_ipc_polling;
+
+ unless (@{$self->{+IPC_DRIVERS}}) {
+ my ($ok, $error) = try { require Test2::IPC::Driver::Files };
+ die $error unless $ok;
+ push @{$self->{+IPC_DRIVERS}} => 'Test2::IPC::Driver::Files';
+ }
+
+ for my $driver (@{$self->{+IPC_DRIVERS}}) {
+ next unless $driver->can('is_viable') && $driver->is_viable;
+ $self->{+IPC} = $driver->new or next;
+ $self->ipc_enable_shm if $self->{+IPC}->use_shm;
+ return;
+ }
+
+ die "IPC has been requested, but no viable drivers were found. Aborting...\n";
+}
+
+sub formatter_set { $_[0]->{+FORMATTER} ? 1 : 0 }
+
+sub add_formatter {
+ my $self = shift;
+ my ($formatter) = @_;
+ unshift @{$self->{+FORMATTERS}} => $formatter;
+
+ return unless $self->{+FINALIZED};
+
+ # Why is the @CARP_NOT entry not enough?
+ local %Carp::Internal = %Carp::Internal;
+ $Carp::Internal{'Test2::Formatter'} = 1;
+
+ carp "Formatter $formatter loaded too late to be used as the global formatter";
+}
+
+sub add_context_acquire_callback {
+ my $self = shift;
+ my ($code) = @_;
+
+ my $rtype = reftype($code) || "";
+
+ confess "Context-acquire callbacks must be coderefs"
+ unless $code && $rtype eq 'CODE';
+
+ push @{$self->{+CONTEXT_ACQUIRE_CALLBACKS}} => $code;
+}
+
+sub add_context_init_callback {
+ my $self = shift;
+ my ($code) = @_;
+
+ my $rtype = reftype($code) || "";
+
+ confess "Context-init callbacks must be coderefs"
+ unless $code && $rtype eq 'CODE';
+
+ push @{$self->{+CONTEXT_INIT_CALLBACKS}} => $code;
+}
+
+sub add_context_release_callback {
+ my $self = shift;
+ my ($code) = @_;
+
+ my $rtype = reftype($code) || "";
+
+ confess "Context-release callbacks must be coderefs"
+ unless $code && $rtype eq 'CODE';
+
+ push @{$self->{+CONTEXT_RELEASE_CALLBACKS}} => $code;
+}
+
+sub add_post_load_callback {
+ my $self = shift;
+ my ($code) = @_;
+
+ my $rtype = reftype($code) || "";
+
+ confess "Post-load callbacks must be coderefs"
+ unless $code && $rtype eq 'CODE';
+
+ push @{$self->{+POST_LOAD_CALLBACKS}} => $code;
+ $code->() if $self->{+LOADED};
+}
+
+sub load {
+ my $self = shift;
+ unless ($self->{+LOADED}) {
+ # This is for https://github.com/Test-More/test-more/issues/16
+ # and https://rt.perl.org/Public/Bug/Display.html?id=127774
+ # END blocks run in reverse order. This insures the END block is loaded
+ # as late as possible. It will not solve all cases, but it helps.
+ eval "END { Test2::API::test2_set_is_end() }; 1" or die $@;
+
+ $self->{+LOADED} = 1;
+ $_->() for @{$self->{+POST_LOAD_CALLBACKS}};
+ }
+ return $self->{+LOADED};
+}
+
+sub add_exit_callback {
+ my $self = shift;
+ my ($code) = @_;
+ my $rtype = reftype($code) || "";
+
+ confess "End callbacks must be coderefs"
+ unless $code && $rtype eq 'CODE';
+
+ push @{$self->{+EXIT_CALLBACKS}} => $code;
+}
+
+sub add_ipc_driver {
+ my $self = shift;
+ my ($driver) = @_;
+ unshift @{$self->{+IPC_DRIVERS}} => $driver;
+
+ return unless $self->{+FINALIZED};
+
+ # Why is the @CARP_NOT entry not enough?
+ local %Carp::Internal = %Carp::Internal;
+ $Carp::Internal{'Test2::IPC::Driver'} = 1;
+
+ carp "IPC driver $driver loaded too late to be used as the global ipc driver";
+}
+
+sub enable_ipc_polling {
+ my $self = shift;
+
+ $self->add_context_init_callback(
+ # This is called every time a context is created, it needs to be fast.
+ # $_[0] is a context object
+ sub {
+ return unless $self->{+IPC_POLLING};
+ return $_[0]->{hub}->cull unless $self->{+IPC_SHM_ID};
+
+ my $val;
+ {
+ shmread($self->{+IPC_SHM_ID}, $val, 0, $self->{+IPC_SHM_SIZE}) or return;
+
+ return if $val eq $self->{+IPC_SHM_LAST};
+ $self->{+IPC_SHM_LAST} = $val;
+ }
+
+ $_[0]->{hub}->cull;
+ }
+ ) unless defined $self->ipc_polling;
+
+ $self->set_ipc_polling(1);
+}
+
+sub ipc_enable_shm {
+ my $self = shift;
+
+ return 1 if defined $self->{+IPC_SHM_ID};
+
+ my ($ok, $err) = try {
+ require IPC::SysV;
+
+ my $ipc_key = IPC::SysV::IPC_PRIVATE();
+ my $shm_size = $self->{+IPC}->can('shm_size') ? $self->{+IPC}->shm_size : 64;
+ my $shm_id = shmget($ipc_key, $shm_size, 0666) or die;
+
+ my $initial = 'a' x $shm_size;
+ shmwrite($shm_id, $initial, 0, $shm_size) or die;
+
+ $self->{+IPC_SHM_SIZE} = $shm_size;
+ $self->{+IPC_SHM_ID} = $shm_id;
+ $self->{+IPC_SHM_LAST} = $initial;
+ };
+
+ return $ok;
+}
+
+sub ipc_free_shm {
+ my $self = shift;
+
+ my $id = delete $self->{+IPC_SHM_ID};
+ return unless defined $id;
+
+ shmctl($id, IPC::SysV::IPC_RMID(), 0);
+}
+
+sub get_ipc_pending {
+ my $self = shift;
+ return -1 unless defined $self->{+IPC_SHM_ID};
+ my $val;
+ shmread($self->{+IPC_SHM_ID}, $val, 0, $self->{+IPC_SHM_SIZE}) or return -1;
+ return 0 if $val eq $self->{+IPC_SHM_LAST};
+ $self->{+IPC_SHM_LAST} = $val;
+ return 1;
+}
+
+sub set_ipc_pending {
+ my $self = shift;
+
+ return undef unless defined $self->{+IPC_SHM_ID};
+
+ my ($val) = @_;
+
+ confess "value is required for set_ipc_pending"
+ unless $val;
+
+ shmwrite($self->{+IPC_SHM_ID}, $val, 0, $self->{+IPC_SHM_SIZE});
+}
+
+sub disable_ipc_polling {
+ my $self = shift;
+ return unless defined $self->{+IPC_POLLING};
+ $self->{+IPC_POLLING} = 0;
+}
+
+sub _ipc_wait {
+ my $fail = 0;
+
+ while (CAN_FORK) {
+ my $pid = CORE::wait();
+ my $err = $?;
+ last if $pid == -1;
+ next unless $err;
+ $fail++;
+ $err = $err >> 8;
+ warn "Process $pid did not exit cleanly (status: $err)\n";
+ }
+
+ if (USE_THREADS) {
+ for my $t (threads->list()) {
+ $t->join;
+ # In older threads we cannot check if a thread had an error unless
+ # we control it and its return.
+ my $err = $t->can('error') ? $t->error : undef;
+ next unless $err;
+ my $tid = $t->tid();
+ $fail++;
+ chomp($err);
+ warn "Thread $tid did not end cleanly: $err\n";
+ }
+ }
+
+ return 0 unless $fail;
+ return 255;
+}
+
+sub DESTROY {
+ my $self = shift;
+
+ return unless $self->{+PID} == $$;
+ return unless $self->{+TID} == get_tid();
+
+ shmctl($self->{+IPC_SHM_ID}, IPC::SysV::IPC_RMID(), 0)
+ if defined $self->{+IPC_SHM_ID};
+}
+
+sub set_exit {
+ my $self = shift;
+
+ my $exit = $?;
+ my $new_exit = $exit;
+
+ if ($INC{'Test/Builder.pm'} && $Test::Builder::VERSION ne $Test2::API::VERSION) {
+ print STDERR <<" EOT";
+
+********************************************************************************
+* *
+* Test::Builder -- Test2::API version mismatch detected *
+* *
+********************************************************************************
+ Test2::API Version: $Test2::API::VERSION
+Test::Builder Version: $Test::Builder::VERSION
+
+This is not a supported configuration, you will have problems.
+
+ EOT
+ }
+
+ for my $ctx (values %{$self->{+CONTEXTS}}) {
+ next unless $ctx;
+
+ next if $ctx->_aborted && ${$ctx->_aborted};
+
+ # Only worry about contexts in this PID
+ my $trace = $ctx->trace || next;
+ next unless $trace->pid == $$;
+
+ # Do not worry about contexts that have no hub
+ my $hub = $ctx->hub || next;
+
+ # Do not worry if the state came to a sudden end.
+ next if $hub->bailed_out;
+ next if defined $hub->skip_reason;
+
+ # now we worry
+ $trace->alert("context object was never released! This means a testing tool is behaving very badly");
+
+ $exit = 255;
+ $new_exit = 255;
+ }
+
+ if ($self->{+PID} != $$ or $self->{+TID} != get_tid()) {
+ $? = $exit;
+ return;
+ }
+
+ my @hubs = $self->{+STACK} ? $self->{+STACK}->all : ();
+
+ if (@hubs and $self->{+IPC} and !$self->{+NO_WAIT}) {
+ local $?;
+ my %seen;
+ for my $hub (reverse @hubs) {
+ my $ipc = $hub->ipc or next;
+ next if $seen{$ipc}++;
+ $ipc->waiting();
+ }
+
+ my $ipc_exit = _ipc_wait();
+ $new_exit ||= $ipc_exit;
+ }
+
+ # None of this is necessary if we never got a root hub
+ if(my $root = shift @hubs) {
+ my $trace = Test2::Util::Trace->new(
+ frame => [__PACKAGE__, __FILE__, 0, __PACKAGE__ . '::END'],
+ detail => __PACKAGE__ . ' END Block finalization',
+ );
+ my $ctx = Test2::API::Context->new(
+ trace => $trace,
+ hub => $root,
+ );
+
+ if (@hubs) {
+ $ctx->diag("Test ended with extra hubs on the stack!");
+ $new_exit = 255;
+ }
+
+ unless ($root->no_ending) {
+ local $?;
+ $root->finalize($trace) unless $root->ended;
+ $_->($ctx, $exit, \$new_exit) for @{$self->{+EXIT_CALLBACKS}};
+ $new_exit ||= $root->failed;
+ }
+ }
+
+ $new_exit = 255 if $new_exit > 255;
+
+ if ($new_exit) {
+ require Test2::API::Breakage;
+ my @warn = Test2::API::Breakage->report();
+
+ if (@warn) {
+ print STDERR "\nYou have loaded versions of test modules known to have problems with Test2.\nThis could explain some test failures.\n";
+ print STDERR "$_\n" for @warn;
+ print STDERR "\n";
+ }
+ }
+
+ $? = $new_exit;
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2::API::Instance - Object used by Test2::API under the hood
+
+=head1 DESCRIPTION
+
+This object encapsulates the global shared state tracked by
+L<Test2>. A single global instance of this package is stored (and
+obscured) by the L<Test2::API> package.
+
+There is no reason to directly use this package. This package is documented for
+completeness. This package can change, or go away completely at any time.
+Directly using, or monkeypatching this package is not supported in any way
+shape or form.
+
+=head1 SYNOPSIS
+
+ use Test2::API::Instance;
+
+ my $obj = Test2::API::Instance->new;
+
+=over 4
+
+=item $pid = $obj->pid
+
+PID of this instance.
+
+=item $obj->tid
+
+Thread ID of this instance.
+
+=item $obj->reset()
+
+Reset the object to defaults.
+
+=item $obj->load()
+
+Set the internal state to loaded, and run and stored post-load callbacks.
+
+=item $bool = $obj->loaded
+
+Check if the state is set to loaded.
+
+=item $arrayref = $obj->post_load_callbacks
+
+Get the post-load callbacks.
+
+=item $obj->add_post_load_callback(sub { ... })
+
+Add a post-load callback. If C<load()> has already been called then the callback will
+be immedietly executed. If C<load()> has not been called then the callback will be
+stored and executed later when C<load()> is called.
+
+=item $hashref = $obj->contexts()
+
+Get a hashref of all active contexts keyed by hub id.
+
+=item $arrayref = $obj->context_acquire_callbacks
+
+Get all context acquire callbacks.
+
+=item $arrayref = $obj->context_init_callbacks
+
+Get all context init callbacks.
+
+=item $arrayref = $obj->context_release_callbacks
+
+Get all context release callbacks.
+
+=item $obj->add_context_init_callback(sub { ... })
+
+Add a context init callback. Subs are called every time a context is created. Subs
+get the newly created context as their only argument.
+
+=item $obj->add_context_release_callback(sub { ... })
+
+Add a context release callback. Subs are called every time a context is released. Subs
+get the released context as their only argument. These callbacks should not
+call release on the context.
+
+=item $obj->set_exit()
+
+This is intended to be called in an C<END { ... }> block. This will look at
+test state and set $?. This will also call any end callbacks, and wait on child
+processes/threads.
+
+=item $obj->ipc_enable_shm()
+
+Turn on SHM for IPC (if possible)
+
+=item $shm_id = $obj->ipc_shm_id()
+
+If SHM is enabled for IPC this will be the shm_id for it.
+
+=item $shm_size = $obj->ipc_shm_size()
+
+If SHM is enabled for IPC this will be the size of it.
+
+=item $shm_last_val = $obj->ipc_shm_last()
+
+If SHM is enabled for IPC this will return the last SHM value seen.
+
+=item $obj->set_ipc_pending($val)
+
+use the IPC SHM to tell other processes and threads there is a pending event.
+C<$val> should be a unique value no other thread/process will generate.
+
+B<Note:> This will also make the current process see a pending event. It does
+not set C<ipc_shm_last()>, this is important because doing so could hide a
+previous change.
+
+=item $pending = $obj->get_ipc_pending()
+
+This returns -1 if SHM is not enabled for IPC.
+
+This returns 0 if the SHM value matches the last known value, which means there
+are no pending events.
+
+This returns 1 if the SHM value has changed, which means there are probably
+pending events.
+
+When 1 is returned this will set C<< $obj->ipc_shm_last() >>.
+
+=item $drivers = $obj->ipc_drivers
+
+Get the list of IPC drivers.
+
+=item $obj->add_ipc_driver($DRIVER_CLASS)
+
+Add an IPC driver to the list. The most recently added IPC driver will become
+the global one during initialization. If a driver is added after initialization
+has occurred a warning will be generated:
+
+ "IPC driver $driver loaded too late to be used as the global ipc driver"
+
+=item $bool = $obj->ipc_polling
+
+Check if polling is enabled.
+
+=item $obj->enable_ipc_polling
+
+Turn on polling. This will cull events from other processes and threads every
+time a context is created.
+
+=item $obj->disable_ipc_polling
+
+Turn off IPC polling.
+
+=item $bool = $obj->no_wait
+
+=item $bool = $obj->set_no_wait($bool)
+
+Get/Set no_wait. This option is used to turn off process/thread waiting at exit.
+
+=item $arrayref = $obj->exit_callbacks
+
+Get the exit callbacks.
+
+=item $obj->add_exit_callback(sub { ... })
+
+Add an exit callback. This callback will be called by C<set_exit()>.
+
+=item $bool = $obj->finalized
+
+Check if the object is finalized. Finalization happens when either C<ipc()>,
+C<stack()>, or C<format()> are called on the object. Once finalization happens
+these fields are considered unchangeable (not enforced here, enforced by
+L<Test2>).
+
+=item $ipc = $obj->ipc
+
+Get the one true IPC instance.
+
+=item $stack = $obj->stack
+
+Get the one true hub stack.
+
+=item $formatter = $obj->formatter
+
+Get the global formatter. By default this is the C<'Test2::Formatter::TAP'>
+package. This could be any package that implements the C<write()> method. This
+can also be an instantiated object.
+
+=item $bool = $obj->formatter_set()
+
+Check if a formatter has been set.
+
+=item $obj->add_formatter($class)
+
+=item $obj->add_formatter($obj)
+
+Add a formatter. The most recently added formatter will become the global one
+during initialization. If a formatter is added after initialization has occurred
+a warning will be generated:
+
+ "Formatter $formatter loaded too late to be used as the global formatter"
+
+=back
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut
--- /dev/null
+package Test2::API::Stack;
+use strict;
+use warnings;
+
+our $VERSION = '1.302015';
+
+
+use Test2::Hub();
+
+use Carp qw/confess/;
+
+sub new {
+ my $class = shift;
+ return bless [], $class;
+}
+
+sub new_hub {
+ my $self = shift;
+ my %params = @_;
+
+ my $class = delete $params{class} || 'Test2::Hub';
+
+ my $hub = $class->new(%params);
+
+ if (@$self) {
+ $hub->inherit($self->[-1], %params);
+ }
+ else {
+ require Test2::API;
+ $hub->format(Test2::API::test2_formatter()->new)
+ unless $hub->format || exists($params{formatter});
+
+ my $ipc = Test2::API::test2_ipc();
+ if ($ipc && !$hub->ipc && !exists($params{ipc})) {
+ $hub->set_ipc($ipc);
+ $ipc->add_hub($hub->hid);
+ }
+ }
+
+ push @$self => $hub;
+
+ $hub;
+}
+
+sub top {
+ my $self = shift;
+ return $self->new_hub unless @$self;
+ return $self->[-1];
+}
+
+sub peek {
+ my $self = shift;
+ return @$self ? $self->[-1] : undef;
+}
+
+sub cull {
+ my $self = shift;
+ $_->cull for reverse @$self;
+}
+
+sub all {
+ my $self = shift;
+ return @$self;
+}
+
+sub clear {
+ my $self = shift;
+ @$self = ();
+}
+
+# Do these last without keywords in order to prevent them from getting used
+# when we want the real push/pop.
+
+{
+ no warnings 'once';
+
+ *push = sub {
+ my $self = shift;
+ my ($hub) = @_;
+ $hub->inherit($self->[-1]) if @$self;
+ push @$self => $hub;
+ };
+
+ *pop = sub {
+ my $self = shift;
+ my ($hub) = @_;
+ confess "No hubs on the stack"
+ unless @$self;
+ confess "You cannot pop the root hub"
+ if 1 == @$self;
+ confess "Hub stack mismatch, attempted to pop incorrect hub"
+ unless $self->[-1] == $hub;
+ pop @$self;
+ };
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2::API::Stack - Object to manage a stack of L<Test2::Hub>
+instances.
+
+=head1 ***INTERNALS NOTE***
+
+B<The internals of this package are subject to change at any time!> The public
+methods provided will not change in backwords incompatible ways, but the
+underlying implementation details might. B<Do not break encapsulation here!>
+
+=head1 DESCRIPTION
+
+This module is used to represent and manage a stack of L<Test2::Hub>
+objects. Hubs are usually in a stack so that you can push a new hub into place
+that can intercept and handle events differently than the primary hub.
+
+=head1 SYNOPSIS
+
+ my $stack = Test2::API::Stack->new;
+ my $hub = $stack->top;
+
+=head1 METHODS
+
+=over 4
+
+=item $stack = Test2::API::Stack->new()
+
+This will create a new empty stack instance. All arguments are ignored.
+
+=item $hub = $stack->new_hub()
+
+=item $hub = $stack->new_hub(%params)
+
+=item $hub = $stack->new_hub(%params, class => $class)
+
+This will generate a new hub and push it to the top of the stack. Optionally
+you can provide arguments that will be passed into the constructor for the
+L<Test2::Hub> object.
+
+If you specify the C<< 'class' => $class >> argument, the new hub will be an
+instance of the specified class.
+
+Unless your parameters specify C<'formatter'> or C<'ipc'> arguments, the
+formatter and ipc instance will be inherited from the current top hub. You can
+set the parameters to C<undef> to avoid having a formatter or ipc instance.
+
+If there is no top hub, and you do not ask to leave ipc and formatter undef,
+then a new formatter will be created, and the IPC instance from
+L<Test2::API> will be used.
+
+=item $hub = $stack->top()
+
+This will return the top hub from the stack. If there is no top hub yet this
+will create it.
+
+=item $hub = $stack->peek()
+
+This will return the top hub from the stack. If there is no top hub yet this
+will return undef.
+
+=item $stack->cull
+
+This will call C<< $hub->cull >> on all hubs in the stack.
+
+=item @hubs = $stack->all
+
+This will return all the hubs in the stack as a list.
+
+=item $stack->clear
+
+This will completely remove all hubs from the stack. Normally you do not want
+to do this, but there are a few valid reasons for it.
+
+=item $stack->push($hub)
+
+This will push the new hub onto the stack.
+
+=item $stack->pop($hub)
+
+This will pop a hub from the stack, if the hub at the top of the stack does not
+match the hub you expect (passed in as an argument) it will throw an exception.
+
+=back
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut
--- /dev/null
+package Test2::Event;
+use strict;
+use warnings;
+
+our $VERSION = '1.302015';
+
+
+use Test2::Util::HashBase qw/trace nested in_subtest subtest_id/;
+use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/;
+
+sub causes_fail { 0 }
+sub increments_count { 0 }
+sub diagnostics { 0 }
+sub no_display { 0 }
+
+sub callback { }
+
+sub terminate { () }
+sub global { () }
+sub sets_plan { () }
+
+sub summary { ref($_[0]) }
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2::Event - Base class for events
+
+=head1 DESCRIPTION
+
+Base class for all event objects that get passed through
+L<Test2>.
+
+=head1 SYNOPSIS
+
+ package Test2::Event::MyEvent;
+ use strict;
+ use warnings;
+
+ # This will make our class an event subclass (required)
+ use base 'Test2::Event';
+
+ # Add some accessors (optional)
+ # You are not obligated to use HashBase, you can use any object tool you
+ # want, or roll your own accessors.
+ use Test2::Util::HashBase qw/foo bar baz/;
+
+ # Chance to initialize some defaults
+ sub init {
+ my $self = shift;
+ # no other args in @_
+
+ $self->set_foo('xxx') unless defined $self->foo;
+
+ ...
+ }
+
+ 1;
+
+=head1 METHODS
+
+=over 4
+
+=item $trace = $e->trace
+
+Get a snapshot of the L<Test2::Util::Trace> as it was when this event was
+generated
+
+=item $bool = $e->causes_fail
+
+Returns true if this event should result in a test failure. In general this
+should be false.
+
+=item $bool = $e->increments_count
+
+Should be true if this event should result in a test count increment.
+
+=item $e->callback($hub)
+
+If your event needs to have extra effects on the L<Test2::Hub> you can override
+this method.
+
+This is called B<BEFORE> your event is passed to the formatter.
+
+=item $call = $e->created
+
+Get the C<caller()> details from when the event was generated. This is usually
+inside a tools package. This is typically used for debugging.
+
+=item $num = $e->nested
+
+If this event is nested inside of other events, this should be the depth of
+nesting. (This is mainly for subtests)
+
+=item $bool = $e->global
+
+Set this to true if your event is global, that is ALL threads and processes
+should see it no matter when or where it is generated. This is not a common
+thing to want, it is used by bail-out and skip_all to end testing.
+
+=item $code = $e->terminate
+
+This is called B<AFTER> your event has been passed to the formatter. This
+should normally return undef, only change this if your event should cause the
+test to exit immedietly.
+
+If you want this event to cause the test to exit you should return the exit
+code here. Exit code of 0 means exit success, any other integer means exit with
+failure.
+
+This is used by L<Test2::Event::Plan> to exit 0 when the plan is
+'skip_all'. This is also used by L<Test2::Event:Bail> to force the test
+to exit with a failure.
+
+This is called after the event has been sent to the formatter in order to
+ensure the event is seen and understood.
+
+=item $todo = $e->todo
+
+=item $e->set_todo($todo)
+
+Get/Set the todo reason on the event. Any value other than C<undef> makes the
+event 'TODO'.
+
+Not all events make use of this field, but they can all have it set/cleared.
+
+=item $bool = $e->diag_todo
+
+=item $e->diag_todo($todo)
+
+True if this event should be considered 'TODO' for diagnostics purposes. This
+essentially means that any message that would go to STDERR will go to STDOUT
+instead so that a harness will hide it outside of verbose mode.
+
+=item $msg = $e->summary
+
+This is intended to be a human readable summary of the event. This should
+ideally only be 1-line long, but you can use multiple lines if necessary. This
+is intended for human consumption, you do not need to make it easy for machines
+to understand.
+
+The default is to simply return the event package name.
+
+=item ($count, $directive, $reason) = $e->sets_plan()
+
+Check if this event sets the testing plan. It will return an empty list if it
+does not. If it does set the plan it will return a list of 1 to 3 items in
+order: Expected Test Count, Test Directive, Reason for directive.
+
+=item $bool = $e->diagnostics
+
+True if the event contains diagnostics info. This is useful because a
+non-verbose harness may choose to hide events that are not in this category.
+Some formatters may choose to send these to STDERR instead of STDOUT to ensure
+they are seen.
+
+=item $bool = $e->no_display
+
+False by default. This will return true on events that should not be displayed
+by formatters.
+
+=item $id = $e->in_subtest
+
+If the event is inside a subtest this should have the subtest ID.
+
+=item $id = $e->subtest_id
+
+If the event is a final subtes event, this should contain the subtest ID.
+
+=back
+
+=head1 THIRD PARTY META-DATA
+
+This object consumes L<Test2::Util::ExternalMeta> which provides a consistent
+way for you to attach meta-data to instances of this class. This is useful for
+tools, plugins, and other extentions.
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut
--- /dev/null
+package Test2::Event::Bail;
+use strict;
+use warnings;
+
+our $VERSION = '1.302015';
+
+
+use base 'Test2::Event';
+use Test2::Util::HashBase qw{reason};
+
+sub callback {
+ my $self = shift;
+ my ($hub) = @_;
+
+ $hub->set_bailed_out($self);
+}
+
+# Make sure the tests terminate
+sub terminate { 255 };
+
+sub global { 1 };
+
+sub causes_fail { 1 }
+
+sub summary {
+ my $self = shift;
+ return "Bail out! " . $self->{+REASON}
+ if $self->{+REASON};
+
+ return "Bail out!";
+}
+
+sub diagnostics { 1 }
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2::Event::Bail - Bailout!
+
+=head1 DESCRIPTION
+
+The bailout event is generated when things go horribly wrong and you need to
+halt all testing in the current file.
+
+=head1 SYNOPSIS
+
+ use Test2::API qw/context/;
+ use Test2::Event::Bail;
+
+ my $ctx = context();
+ my $event = $ctx->bail('Stuff is broken');
+
+=head1 METHODS
+
+Inherits from L<Test2::Event>. Also defines:
+
+=over 4
+
+=item $reason = $e->reason
+
+The reason for the bailout.
+
+=back
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut
--- /dev/null
+package Test2::Event::Diag;
+use strict;
+use warnings;
+
+our $VERSION = '1.302015';
+
+
+use base 'Test2::Event';
+use Test2::Util::HashBase qw/message/;
+
+sub init {
+ $_[0]->{+MESSAGE} = 'undef' unless defined $_[0]->{+MESSAGE};
+}
+
+sub summary { $_[0]->{+MESSAGE} }
+
+sub diagnostics { 1 }
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2::Event::Diag - Diag event type
+
+=head1 DESCRIPTION
+
+Diagnostics messages, typically rendered to STDERR.
+
+=head1 SYNOPSIS
+
+ use Test2::API qw/context/;
+ use Test2::Event::Diag;
+
+ my $ctx = context();
+ my $event = $ctx->diag($message);
+
+=head1 ACCESSORS
+
+=over 4
+
+=item $diag->message
+
+The message for the diag.
+
+=back
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut
--- /dev/null
+package Test2::Event::Exception;
+use strict;
+use warnings;
+
+our $VERSION = '1.302015';
+
+
+use base 'Test2::Event';
+use Test2::Util::HashBase qw{error};
+
+sub causes_fail { 1 }
+
+sub summary {
+ my $self = shift;
+ chomp(my $msg = "Exception: " . $self->{+ERROR});
+ return $msg;
+}
+
+sub diagnostics { 1 }
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2::Event::Exception - Exception event
+
+=head1 DESCRIPTION
+
+An exception event will display to STDERR, and will prevent the overall test
+file from passing.
+
+=head1 SYNOPSIS
+
+ use Test2::API qw/context/;
+ use Test2::Event::Exception;
+
+ my $ctx = context();
+ my $event = $ctx->send_event('Exception', error => 'Stuff is broken');
+
+=head1 METHODS
+
+Inherits from L<Test2::Event>. Also defines:
+
+=over 4
+
+=item $reason = $e->error
+
+The reason for the exception.
+
+=back
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut
--- /dev/null
+package Test2::Event::Note;
+use strict;
+use warnings;
+
+our $VERSION = '1.302015';
+
+
+use base 'Test2::Event';
+use Test2::Util::HashBase qw/message/;
+
+sub init {
+ $_[0]->{+MESSAGE} = 'undef' unless defined $_[0]->{+MESSAGE};
+}
+
+sub summary { $_[0]->{+MESSAGE} }
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2::Event::Note - Note event type
+
+=head1 DESCRIPTION
+
+Notes, typically rendered to STDOUT.
+
+=head1 SYNOPSIS
+
+ use Test2::API qw/context/;
+ use Test2::Event::Note;
+
+ my $ctx = context();
+ my $event = $ctx->Note($message);
+
+=head1 ACCESSORS
+
+=over 4
+
+=item $note->message
+
+The message for the note.
+
+=back
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut
--- /dev/null
+package Test2::Event::Ok;
+use strict;
+use warnings;
+
+our $VERSION = '1.302015';
+
+
+use base 'Test2::Event';
+use Test2::Util::HashBase qw{
+ pass effective_pass name todo
+};
+
+sub init {
+ my $self = shift;
+
+ # Do not store objects here, only true or false
+ $self->{+PASS} = $self->{+PASS} ? 1 : 0;
+ $self->{+EFFECTIVE_PASS} = $self->{+PASS} || (defined($self->{+TODO}) ? 1 : 0);
+
+ my $name = $self->{+NAME} or return;
+ return unless index($name, '#') != -1 || index($name, "\n") != -1;
+ $self->trace->throw("'$name' is not a valid name, names must not contain '#' or newlines.")
+}
+
+{
+ no warnings 'redefine';
+ sub set_todo {
+ my $self = shift;
+ my ($todo) = @_;
+ $self->{+TODO} = $todo;
+ $self->{+EFFECTIVE_PASS} = defined($todo) ? 1 : $self->{+PASS};
+ }
+}
+
+sub increments_count { 1 };
+
+sub causes_fail { !$_[0]->{+EFFECTIVE_PASS} }
+
+sub summary {
+ my $self = shift;
+
+ my $name = $self->{+NAME} || "Nameless Assertion";
+
+ my $todo = $self->{+TODO};
+ if ($todo) {
+ $name .= " (TODO: $todo)";
+ }
+ elsif (defined $todo) {
+ $name .= " (TODO)"
+ }
+
+ return $name;
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2::Event::Ok - Ok event type
+
+=head1 DESCRIPTION
+
+Ok events are generated whenever you run a test that produces a result.
+Examples are C<ok()>, and C<is()>.
+
+=head1 SYNOPSIS
+
+ use Test2::API qw/context/;
+ use Test2::Event::Ok;
+
+ my $ctx = context();
+ my $event = $ctx->ok($bool, $name, \@diag);
+
+or:
+
+ my $ctx = context();
+ my $event = $ctx->send_event(
+ 'Ok',
+ pass => $bool,
+ name => $name,
+ diag => \@diag
+ );
+
+=head1 ACCESSORS
+
+=over 4
+
+=item $rb = $e->pass
+
+The original true/false value of whatever was passed into the event (but
+reduced down to 1 or 0).
+
+=item $name = $e->name
+
+Name of the test.
+
+=item $diag = $e->diag
+
+An arrayref full of diagnostics strings to print in the event of a failure.
+
+=item $b = $e->effective_pass
+
+This is the true/false value of the test after TODO and similar modifiers are
+taken into account.
+
+=item $b = $e->allow_bad_name
+
+This relaxes the test name checks such that they allow characters that can
+confuse a TAP parser.
+
+=back
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut
--- /dev/null
+package Test2::Event::Plan;
+use strict;
+use warnings;
+
+our $VERSION = '1.302015';
+
+
+use base 'Test2::Event';
+use Test2::Util::HashBase qw{max directive reason};
+
+use Carp qw/confess/;
+
+my %ALLOWED = (
+ 'SKIP' => 1,
+ 'NO PLAN' => 1,
+);
+
+sub init {
+ if ($_[0]->{+DIRECTIVE}) {
+ $_[0]->{+DIRECTIVE} = 'SKIP' if $_[0]->{+DIRECTIVE} eq 'skip_all';
+ $_[0]->{+DIRECTIVE} = 'NO PLAN' if $_[0]->{+DIRECTIVE} eq 'no_plan';
+
+ confess "'" . $_[0]->{+DIRECTIVE} . "' is not a valid plan directive"
+ unless $ALLOWED{$_[0]->{+DIRECTIVE}};
+ }
+ else {
+ confess "Cannot have a reason without a directive!"
+ if defined $_[0]->{+REASON};
+
+ confess "No number of tests specified"
+ unless defined $_[0]->{+MAX};
+
+ confess "Plan test count '" . $_[0]->{+MAX} . "' does not appear to be a valid positive integer"
+ unless $_[0]->{+MAX} =~ m/^\d+$/;
+
+ $_[0]->{+DIRECTIVE} = '';
+ }
+}
+
+sub sets_plan {
+ my $self = shift;
+ return (
+ $self->{+MAX},
+ $self->{+DIRECTIVE},
+ $self->{+REASON},
+ );
+}
+
+sub callback {
+ my $self = shift;
+ my ($hub) = @_;
+
+ $hub->plan($self->{+DIRECTIVE} || $self->{+MAX});
+
+ return unless $self->{+DIRECTIVE};
+
+ $hub->set_skip_reason($self->{+REASON} || 1) if $self->{+DIRECTIVE} eq 'SKIP';
+}
+
+sub terminate {
+ my $self = shift;
+ # On skip_all we want to terminate the hub
+ return 0 if $self->{+DIRECTIVE} && $self->{+DIRECTIVE} eq 'SKIP';
+ return undef;
+}
+
+sub summary {
+ my $self = shift;
+ my $max = $self->{+MAX};
+ my $directive = $self->{+DIRECTIVE};
+ my $reason = $self->{+REASON};
+
+ return "Plan is $max assertions"
+ if $max || !$directive;
+
+ return "Plan is '$directive', $reason"
+ if $reason;
+
+ return "Plan is '$directive'";
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2::Event::Plan - The event of a plan
+
+=head1 DESCRIPTION
+
+Plan events are fired off whenever a plan is declared, done testing is called,
+or a subtext completes.
+
+=head1 SYNOPSIS
+
+ use Test2::API qw/context/;
+ use Test2::Event::Plan;
+
+ my $ctx = context();
+
+ # Plan for 10 tests to run
+ my $event = $ctx->plan(10);
+
+ # Plan to skip all tests (will exit 0)
+ $ctx->plan(0, skip_all => "These tests need to be skipped");
+
+=head1 ACCESSORS
+
+=over 4
+
+=item $num = $plan->max
+
+Get the number of expected tests
+
+=item $dir = $plan->directive
+
+Get the directive (such as TODO, skip_all, or no_plan).
+
+=item $reason = $plan->reason
+
+Get the reason for the directive.
+
+=back
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut
--- /dev/null
+package Test2::Event::Skip;
+use strict;
+use warnings;
+
+our $VERSION = '1.302015';
+
+
+use base 'Test2::Event::Ok';
+use Test2::Util::HashBase qw{reason};
+
+sub init {
+ my $self = shift;
+ $self->SUPER::init;
+ $self->{+EFFECTIVE_PASS} = 1;
+}
+
+sub causes_fail { 0 }
+
+sub summary {
+ my $self = shift;
+ my $out = $self->SUPER::summary(@_);
+
+ if (my $reason = $self->reason) {
+ $out .= " (SKIP: $reason)";
+ }
+ else {
+ $out .= " (SKIP)";
+ }
+
+ return $out;
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2::Event::Skip - Skip event type
+
+=head1 DESCRIPTION
+
+Skip events bump test counts just like L<Test2::Event::Ok> events, but
+they can never fail.
+
+=head1 SYNOPSIS
+
+ use Test2::API qw/context/;
+ use Test2::Event::Skip;
+
+ my $ctx = context();
+ my $event = $ctx->skip($name, $reason);
+
+or:
+
+ my $ctx = context();
+ my $event = $ctx->send_event(
+ 'Skip',
+ name => $name,
+ reason => $reason,
+ );
+
+=head1 ACCESSORS
+
+=over 4
+
+=item $reason = $e->reason
+
+The original true/false value of whatever was passed into the event (but
+reduced down to 1 or 0).
+
+=back
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
--- /dev/null
+package Test2::Event::Subtest;
+use strict;
+use warnings;
+
+our $VERSION = '1.302015';
+
+
+use base 'Test2::Event::Ok';
+use Test2::Util::HashBase qw{subevents buffered subtest_id};
+
+sub init {
+ my $self = shift;
+ $self->SUPER::init();
+ $self->{+SUBEVENTS} ||= [];
+}
+
+sub summary {
+ my $self = shift;
+
+ my $name = $self->{+NAME} || "Nameless Subtest";
+
+ my $todo = $self->{+TODO};
+ if ($todo) {
+ $name .= " (TODO: $todo)";
+ }
+ elsif (defined $todo) {
+ $name .= " (TODO)"
+ }
+
+ return $name;
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2::Event::Subtest - Event for subtest types
+
+=head1 DESCRIPTION
+
+This class represents a subtest. This class is a subclass of
+L<Test2::Event::Ok>.
+
+=head1 ACCESSORS
+
+This class inherits from L<Test2::Event::Ok>.
+
+=over 4
+
+=item $arrayref = $e->subevents
+
+Returns the arrayref containing all the events from the subtest
+
+=item $bool = $e->buffered
+
+True if the subtest is buffered, that is all subevents render at once. If this
+is false it means all subevents render as they are produced.
+
+=back
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut
--- /dev/null
+package Test2::Event::Waiting;
+use strict;
+use warnings;
+
+our $VERSION = '1.302015';
+
+
+use base 'Test2::Event';
+
+sub global { 1 };
+
+sub summary { "IPC is waiting for children to finish..." }
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2::Event::Waiting - Tell all procs/threads it is time to be done
+
+=head1 DESCRIPTION
+
+This event has no data of its own. This event is sent out by the IPC system
+when the main process/thread is ready to end.
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut
--- /dev/null
+package Test2::Formatter;
+use strict;
+use warnings;
+
+our $VERSION = '1.302015';
+
+
+my %ADDED;
+sub import {
+ my $class = shift;
+ return if $class eq __PACKAGE__;
+ return if $ADDED{$class}++;
+ require Test2::API;
+ Test2::API::test2_formatter_add($class);
+}
+
+sub hide_buffered { 1 }
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2::Formatter - Namespace for formatters.
+
+=head1 DESCRIPTION
+
+This is the namespace for formatters. This is an empty package.
+
+=head1 CREATING FORMATTERS
+
+A formatter is any package or object with a C<write($event, $num)> method.
+
+ package Test2::Formatter::Foo;
+ use strict;
+ use warnings;
+
+ sub write {
+ my $self_or_class = shift;
+ my ($event, $assert_num) = @_;
+ ...
+ }
+
+ sub hide_buffered { 1 }
+
+ 1;
+
+The C<write> method is a method, so it either gets a class or instance. The 2
+arguments are the C<$event> object it should record, and the C<$assert_num>
+which is the number of the current assertion (ok), or the last assertion if
+this even is not itself an assertion. The assertion number may be any inyeger 0
+or greator, and may be undefined in some cases.
+
+The C<hide_buffered()> method must return a boolean. This is used to tell
+buffered subtests whether or not to send it events as they are being buffered.
+See L<Test2::API/"run_subtest(...)"> for more information.
+
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut
--- /dev/null
+package Test2::Formatter::TAP;
+use strict;
+use warnings;
+
+our $VERSION = '1.302015';
+
+
+use Test2::Util::HashBase qw{
+ no_numbers handles _encoding
+};
+
+sub OUT_STD() { 0 }
+sub OUT_ERR() { 1 }
+
+use Carp qw/croak/;
+
+use base 'Test2::Formatter';
+
+my %CONVERTERS = (
+ 'Test2::Event::Ok' => 'event_ok',
+ 'Test2::Event::Skip' => 'event_skip',
+ 'Test2::Event::Note' => 'event_note',
+ 'Test2::Event::Diag' => 'event_diag',
+ 'Test2::Event::Bail' => 'event_bail',
+ 'Test2::Event::Exception' => 'event_exception',
+ 'Test2::Event::Subtest' => 'event_subtest',
+ 'Test2::Event::Plan' => 'event_plan',
+);
+
+# Initial list of converters are safe for direct hash access cause we control them.
+my %SAFE_TO_ACCESS_HASH = %CONVERTERS;
+
+sub register_event {
+ my $class = shift;
+ my ($type, $convert) = @_;
+ croak "Event type is a required argument" unless $type;
+ croak "Event type '$type' already registered" if $CONVERTERS{$type};
+ croak "The second argument to register_event() must be a code reference or method name"
+ unless $convert && (ref($convert) eq 'CODE' || $class->can($convert));
+ $CONVERTERS{$type} = $convert;
+}
+
+_autoflush(\*STDOUT);
+_autoflush(\*STDERR);
+
+sub init {
+ my $self = shift;
+
+ $self->{+HANDLES} ||= $self->_open_handles;
+ if(my $enc = delete $self->{encoding}) {
+ $self->encoding($enc);
+ }
+}
+
+sub hide_buffered { 1 }
+
+sub encoding {
+ my $self = shift;
+
+ if (@_) {
+ my ($enc) = @_;
+ my $handles = $self->{+HANDLES};
+
+ # https://rt.perl.org/Public/Bug/Display.html?id=31923
+ # If utf8 is requested we use ':utf8' instead of ':encoding(utf8)' in
+ # order to avoid the thread segfault.
+ if ($enc =~ m/^utf-?8$/i) {
+ binmode($_, ":utf8") for @$handles;
+ }
+ else {
+ binmode($_, ":encoding($enc)") for @$handles;
+ }
+ $self->{+_ENCODING} = $enc;
+ }
+
+ return $self->{+_ENCODING};
+}
+
+if ($^C) {
+ no warnings 'redefine';
+ *write = sub {};
+}
+sub write {
+ my ($self, $e, $num) = @_;
+
+ my $type = ref($e);
+
+ my $converter = $CONVERTERS{$type} || 'event_other';
+ my @tap = $self->$converter($e, $self->{+NO_NUMBERS} ? undef : $num) or return;
+
+ my $handles = $self->{+HANDLES};
+ my $nesting = ($SAFE_TO_ACCESS_HASH{$type} ? $e->{nested} : $e->nested) || 0;
+ my $indent = ' ' x $nesting;
+
+ # Local is expensive! Only do it if we really need to.
+ local($\, $,) = (undef, '') if $\ || $,;
+ for my $set (@tap) {
+ no warnings 'uninitialized';
+ my ($hid, $msg) = @$set;
+ next unless $msg;
+ my $io = $handles->[$hid] or next;
+
+ $msg =~ s/^/$indent/mg if $nesting;
+ print $io $msg;
+ }
+}
+
+sub _open_handles {
+ my $self = shift;
+
+ open( my $out, '>&', STDOUT ) or die "Can't dup STDOUT: $!";
+ open( my $err, '>&', STDERR ) or die "Can't dup STDERR: $!";
+
+ _autoflush($out);
+ _autoflush($err);
+
+ return [$out, $err];
+}
+
+sub _autoflush {
+ my($fh) = pop;
+ my $old_fh = select $fh;
+ $| = 1;
+ select $old_fh;
+}
+
+sub event_tap {
+ my $self = shift;
+ my ($e, $num) = @_;
+
+ my $converter = $CONVERTERS{ref($e)} or return;
+
+ $num = undef if $self->{+NO_NUMBERS};
+
+ return $self->$converter($e, $num);
+}
+
+sub event_ok {
+ my $self = shift;
+ my ($e, $num) = @_;
+
+ # We use direct hash access for performance. OK events are so common we
+ # need this to be fast.
+ my ($name, $todo) = @{$e}{qw/name todo/};
+ my $in_todo = defined($todo);
+
+ my $out = "";
+ $out .= "not " unless $e->{pass};
+ $out .= "ok";
+ $out .= " $num" if defined($num);
+ $out .= " - $name" if defined $name;
+ $out .= " # TODO" if $in_todo;
+ $out .= " $todo" if defined($todo) && length($todo);
+
+ # The primary line of TAP, if the test passed this is all we need.
+ return([OUT_STD, "$out\n"]);
+}
+
+sub event_skip {
+ my $self = shift;
+ my ($e, $num) = @_;
+
+ my $name = $e->name;
+ my $reason = $e->reason;
+ my $todo = $e->todo;
+
+ my $out = "";
+ $out .= "not " unless $e->{pass};
+ $out .= "ok";
+ $out .= " $num" if defined $num;
+ $out .= " - $name" if $name;
+ if (defined($todo)) {
+ $out .= " # TODO & SKIP"
+ }
+ else {
+ $out .= " # skip";
+ }
+ $out .= " $reason" if defined($reason) && length($reason);
+
+ return([OUT_STD, "$out\n"]);
+}
+
+sub event_note {
+ my $self = shift;
+ my ($e, $num) = @_;
+
+ chomp(my $msg = $e->message);
+ $msg =~ s/^/# /;
+ $msg =~ s/\n/\n# /g;
+
+ return [OUT_STD, "$msg\n"];
+}
+
+sub event_diag {
+ my $self = shift;
+ my ($e, $num) = @_;
+
+ chomp(my $msg = $e->message);
+ $msg =~ s/^/# /;
+ $msg =~ s/\n/\n# /g;
+
+ return [OUT_ERR, "$msg\n"];
+}
+
+sub event_bail {
+ my $self = shift;
+ my ($e, $num) = @_;
+
+ return if $e->nested;
+
+ return [
+ OUT_STD,
+ "Bail out! " . $e->reason . "\n",
+ ];
+}
+
+sub event_exception {
+ my $self = shift;
+ my ($e, $num) = @_;
+ return [ OUT_ERR, $e->error ];
+}
+
+sub event_subtest {
+ my $self = shift;
+ my ($e, $num) = @_;
+
+ # A 'subtest' is a subclass of 'ok'. Let the code that renders 'ok' render
+ # this event.
+ my ($ok, @diag) = $self->event_ok($e, $num);
+
+ # If the subtest is not buffered then the sub-events have already been
+ # rendered, we can go ahead and return.
+ return ($ok, @diag) unless $e->buffered;
+
+ # In a verbose harness we indent the diagnostics from the 'Ok' event since
+ # they will appear inside the subtest braces. This helps readability. In a
+ # non-verbose harness we do nto do this because it is less readable.
+ if ($ENV{HARNESS_IS_VERBOSE}) {
+ # index 0 is the filehandle, index 1 is the message we want to indent.
+ $_->[1] =~ s/^(.*\S.*)$/ $1/mg for @diag;
+ }
+
+ # Add the trailing ' {' to the 'ok' line of TAP output.
+ $ok->[1] =~ s/\n/ {\n/;
+
+ # Render the sub-events, we use our own counter for these.
+ my $count = 0;
+ my @subs = map {
+ # Bump the count for any event that should bump it.
+ $count++ if $_->increments_count;
+
+ # This indents all output lines generated for the sub-events.
+ # index 0 is the filehandle, index 1 is the message we want to indent.
+ map { $_->[1] =~ s/^(.*\S.*)$/ $1/mg; $_ } $self->event_tap($_, $count);
+ } @{$e->subevents};
+
+ return (
+ $ok, # opening ok - name {
+ @diag, # diagnostics if the subtest failed
+ @subs, # All the inner-event lines
+ [OUT_STD(), "}\n"], # } (closing brace)
+ );
+}
+
+sub event_plan {
+ my $self = shift;
+ my ($e, $num) = @_;
+
+ my $directive = $e->directive;
+ return if $directive && $directive eq 'NO PLAN';
+
+ my $reason = $e->reason;
+ $reason =~ s/\n/\n# /g if $reason;
+
+ my $plan = "1.." . $e->max;
+ if ($directive) {
+ $plan .= " # $directive";
+ $plan .= " $reason" if defined $reason;
+ }
+
+ return [OUT_STD, "$plan\n"];
+}
+
+sub event_other {
+ my $self = shift;
+ my ($e, $num) = @_;
+ return if $e->no_display;
+
+ my @out;
+
+ if (my ($max, $directive, $reason) = $e->sets_plan) {
+ my $plan = "1..$max";
+ $plan .= " # $directive" if $directive;
+ $plan .= " $reason" if defined $reason;
+ push @out => [OUT_STD, "$plan\n"];
+ }
+
+ if ($e->increments_count) {
+ my $ok = "";
+ $ok .= "not " if $e->causes_fail;
+ $ok .= "ok";
+ $ok .= " $num" if defined($num);
+ $ok .= " - " . $e->summary if $e->summary;
+
+ push @out => [OUT_STD, "$ok\n"];
+ }
+ else { # Comment
+ my $handle = ($e->causes_fail || $e->diagnostics) ? OUT_ERR : OUT_STD;
+ my $summary = $e->summary || ref($e);
+ chomp($summary);
+ $summary =~ s/^/# /smg;
+ push @out => [$handle, "$summary\n"];
+ }
+
+ return @out;
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2::Formatter::TAP - Standard TAP formatter
+
+=head1 DESCRIPTION
+
+This is what takes events and turns them into TAP.
+
+=head1 SYNOPSIS
+
+ use Test2::Formatter::TAP;
+ my $tap = Test2::Formatter::TAP->new();
+
+ # Switch to utf8
+ $tap->encoding('utf8');
+
+ $tap->write($event, $number); # Output an event
+
+=head1 METHODS
+
+=over 4
+
+=item $bool = $tap->no_numbers
+
+=item $tap->set_no_numbers($bool)
+
+Use to turn numbers on and off.
+
+=item $arrayref = $tap->handles
+
+=item $tap->set_handles(\@handles);
+
+Can be used to get/set the filehandles. Indexes are identified by the
+C<OUT_STD> and C<OUT_ERR> constants.
+
+=item $encoding = $tap->encoding
+
+=item $tap->encoding($encoding)
+
+Get or set the encoding. By default no encoding is set, the original settings
+of STDOUT and STDERR are used.
+
+This directly modifies the stored filehandles, it does not create new ones.
+
+=item $tap->write($e, $num)
+
+Write an event to the console.
+
+=item Test2::Formatter::TAP->register_event($pkg, sub { ... });
+
+In general custom events are not supported. There are however occasions where
+you might want to write a custom event type that results in TAP output. In
+order to do this you use the C<register_event()> class method.
+
+ package My::Event;
+ use Test2::Formatter::TAP;
+
+ use base 'Test2::Event';
+ use Test2::Util::HashBase accessors => [qw/pass name diag note/];
+
+ Test2::Formatter::TAP->register_event(
+ __PACKAGE__,
+ sub {
+ my $self = shift;
+ my ($e, $num) = @_;
+ return (
+ [Test2::Formatter::TAP::OUT_STD, "ok $num - " . $e->name . "\n"],
+ [Test2::Formatter::TAP::OUT_ERR, "# " . $e->name . " " . $e->diag . "\n"],
+ [Test2::Formatter::TAP::OUT_STD, "# " . $e->name . " " . $e->note . "\n"],
+ );
+ }
+ );
+
+ 1;
+
+=back
+
+=head2 EVENT METHODS
+
+All these methods require the event itself. Optionally they can all except a
+test number.
+
+All methods return a list of array-refs. Each array-ref will have 2 items, the
+first is an integer identifying an output handle, the second is a string that
+should be written to the handle.
+
+=over 4
+
+=item @out = $TAP->event_ok($e)
+
+=item @out = $TAP->event_ok($e, $num)
+
+Process an L<Test2::Event::Ok> event.
+
+=item @out = $TAP->event_plan($e)
+
+=item @out = $TAP->event_plan($e, $num)
+
+Process an L<Test2::Event::Plan> event.
+
+=item @out = $TAP->event_note($e)
+
+=item @out = $TAP->event_note($e, $num)
+
+Process an L<Test2::Event::Note> event.
+
+=item @out = $TAP->event_diag($e)
+
+=item @out = $TAP->event_diag($e, $num)
+
+Process an L<Test2::Event::Diag> event.
+
+=item @out = $TAP->event_bail($e)
+
+=item @out = $TAP->event_bail($e, $num)
+
+Process an L<Test2::Event::Bail> event.
+
+=item @out = $TAP->event_exception($e)
+
+=item @out = $TAP->event_exception($e, $num)
+
+Process an L<Test2::Event::Exception> event.
+
+=item @out = $TAP->event_skip($e)
+
+=item @out = $TAP->event_skip($e, $num)
+
+Process an L<Test2::Event::Skip> event.
+
+=item @out = $TAP->event_subtest($e)
+
+=item @out = $TAP->event_subtest($e, $num)
+
+Process an L<Test2::Event::Subtest> event.
+
+=item @out = $TAP->event_other($e, $num)
+
+Fallback for unregistered event types. It uses the L<Test2::Event> api to
+convert the event to TAP.
+
+=back
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Kent Fredric E<lt>kentnl@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut
--- /dev/null
+package Test2::Hub;
+use strict;
+use warnings;
+
+our $VERSION = '1.302015';
+
+
+use Carp qw/carp croak confess/;
+use Test2::Util qw/get_tid/;
+
+use Scalar::Util qw/weaken/;
+
+use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/;
+use Test2::Util::HashBase qw{
+ pid tid hid ipc
+ no_ending
+ _filters
+ _pre_filters
+ _listeners
+ _follow_ups
+ _formatter
+ _context_acquire
+ _context_init
+ _context_release
+
+ count
+ failed
+ ended
+ bailed_out
+ _passing
+ _plan
+ skip_reason
+};
+
+my $ID_POSTFIX = 1;
+sub init {
+ my $self = shift;
+
+ $self->{+PID} = $$;
+ $self->{+TID} = get_tid();
+ $self->{+HID} = join '-', $self->{+PID}, $self->{+TID}, $ID_POSTFIX++;
+
+ $self->{+COUNT} = 0;
+ $self->{+FAILED} = 0;
+ $self->{+_PASSING} = 1;
+
+ if (my $formatter = delete $self->{formatter}) {
+ $self->format($formatter);
+ }
+
+ if (my $ipc = $self->{+IPC}) {
+ $ipc->add_hub($self->{+HID});
+ }
+}
+
+sub reset_state {
+ my $self = shift;
+
+ $self->{+COUNT} = 0;
+ $self->{+FAILED} = 0;
+ $self->{+_PASSING} = 1;
+
+ delete $self->{+_PLAN};
+ delete $self->{+ENDED};
+ delete $self->{+BAILED_OUT};
+ delete $self->{+SKIP_REASON};
+}
+
+sub inherit {
+ my $self = shift;
+ my ($from, %params) = @_;
+
+ $self->{+_FORMATTER} = $from->{+_FORMATTER}
+ unless $self->{+_FORMATTER} || exists($params{formatter});
+
+ if ($from->{+IPC} && !$self->{+IPC} && !exists($params{ipc})) {
+ my $ipc = $from->{+IPC};
+ $self->{+IPC} = $ipc;
+ $ipc->add_hub($self->{+HID});
+ }
+
+ if (my $ls = $from->{+_LISTENERS}) {
+ push @{$self->{+_LISTENERS}} => grep { $_->{inherit} } @$ls;
+ }
+
+ if (my $fs = $from->{+_FILTERS}) {
+ push @{$self->{+_FILTERS}} => grep { $_->{inherit} } @$fs;
+ }
+}
+
+sub format {
+ my $self = shift;
+
+ my $old = $self->{+_FORMATTER};
+ ($self->{+_FORMATTER}) = @_ if @_;
+
+ return $old;
+}
+
+sub is_local {
+ my $self = shift;
+ return $$ == $self->{+PID}
+ && get_tid() == $self->{+TID};
+}
+
+sub listen {
+ my $self = shift;
+ my ($sub, %params) = @_;
+
+ carp "Useless addition of a listener in a child process or thread!"
+ if $$ != $self->{+PID} || get_tid() != $self->{+TID};
+
+ croak "listen only takes coderefs for arguments, got '$sub'"
+ unless ref $sub && ref $sub eq 'CODE';
+
+ push @{$self->{+_LISTENERS}} => { %params, code => $sub };
+
+ $sub; # Intentional return.
+}
+
+sub unlisten {
+ my $self = shift;
+
+ carp "Useless removal of a listener in a child process or thread!"
+ if $$ != $self->{+PID} || get_tid() != $self->{+TID};
+
+ my %subs = map {$_ => $_} @_;
+
+ @{$self->{+_LISTENERS}} = grep { !$subs{$_->{code}} } @{$self->{+_LISTENERS}};
+}
+
+sub filter {
+ my $self = shift;
+ my ($sub, %params) = @_;
+
+ carp "Useless addition of a filter in a child process or thread!"
+ if $$ != $self->{+PID} || get_tid() != $self->{+TID};
+
+ croak "filter only takes coderefs for arguments, got '$sub'"
+ unless ref $sub && ref $sub eq 'CODE';
+
+ push @{$self->{+_FILTERS}} => { %params, code => $sub };
+
+ $sub; # Intentional Return
+}
+
+sub unfilter {
+ my $self = shift;
+ carp "Useless removal of a filter in a child process or thread!"
+ if $$ != $self->{+PID} || get_tid() != $self->{+TID};
+ my %subs = map {$_ => $_} @_;
+ @{$self->{+_FILTERS}} = grep { !$subs{$_->{code}} } @{$self->{+_FILTERS}};
+}
+
+sub pre_filter {
+ my $self = shift;
+ my ($sub, %params) = @_;
+
+ croak "pre_filter only takes coderefs for arguments, got '$sub'"
+ unless ref $sub && ref $sub eq 'CODE';
+
+ push @{$self->{+_PRE_FILTERS}} => { %params, code => $sub };
+
+ $sub; # Intentional Return
+}
+
+sub pre_unfilter {
+ my $self = shift;
+ my %subs = map {$_ => $_} @_;
+ @{$self->{+_PRE_FILTERS}} = grep { !$subs{$_->{code}} } @{$self->{+_PRE_FILTERS}};
+}
+
+sub follow_up {
+ my $self = shift;
+ my ($sub) = @_;
+
+ carp "Useless addition of a follow-up in a child process or thread!"
+ if $$ != $self->{+PID} || get_tid() != $self->{+TID};
+
+ croak "follow_up only takes coderefs for arguments, got '$sub'"
+ unless ref $sub && ref $sub eq 'CODE';
+
+ push @{$self->{+_FOLLOW_UPS}} => $sub;
+}
+
+*add_context_aquire = \&add_context_acquire;
+sub add_context_acquire {
+ my $self = shift;
+ my ($sub) = @_;
+
+ croak "add_context_acquire only takes coderefs for arguments, got '$sub'"
+ unless ref $sub && ref $sub eq 'CODE';
+
+ push @{$self->{+_CONTEXT_ACQUIRE}} => $sub;
+
+ $sub; # Intentional return.
+}
+
+*remove_context_aquire = \&remove_context_acquire;
+sub remove_context_acquire {
+ my $self = shift;
+ my %subs = map {$_ => $_} @_;
+ @{$self->{+_CONTEXT_ACQUIRE}} = grep { !$subs{$_} == $_ } @{$self->{+_CONTEXT_ACQUIRE}};
+}
+
+sub add_context_init {
+ my $self = shift;
+ my ($sub) = @_;
+
+ croak "add_context_init only takes coderefs for arguments, got '$sub'"
+ unless ref $sub && ref $sub eq 'CODE';
+
+ push @{$self->{+_CONTEXT_INIT}} => $sub;
+
+ $sub; # Intentional return.
+}
+
+sub remove_context_init {
+ my $self = shift;
+ my %subs = map {$_ => $_} @_;
+ @{$self->{+_CONTEXT_INIT}} = grep { !$subs{$_} == $_ } @{$self->{+_CONTEXT_INIT}};
+}
+
+sub add_context_release {
+ my $self = shift;
+ my ($sub) = @_;
+
+ croak "add_context_release only takes coderefs for arguments, got '$sub'"
+ unless ref $sub && ref $sub eq 'CODE';
+
+ push @{$self->{+_CONTEXT_RELEASE}} => $sub;
+
+ $sub; # Intentional return.
+}
+
+sub remove_context_release {
+ my $self = shift;
+ my %subs = map {$_ => $_} @_;
+ @{$self->{+_CONTEXT_RELEASE}} = grep { !$subs{$_} == $_ } @{$self->{+_CONTEXT_RELEASE}};
+}
+
+sub send {
+ my $self = shift;
+ my ($e) = @_;
+
+ if ($self->{+_PRE_FILTERS}) {
+ for (@{$self->{+_PRE_FILTERS}}) {
+ $e = $_->{code}->($self, $e);
+ return unless $e;
+ }
+ }
+
+ my $ipc = $self->{+IPC} || return $self->process($e);
+
+ if($e->global) {
+ $ipc->send($self->{+HID}, $e, 'GLOBAL');
+ return $self->process($e);
+ }
+
+ return $ipc->send($self->{+HID}, $e)
+ if $$ != $self->{+PID} || get_tid() != $self->{+TID};
+
+ $self->process($e);
+}
+
+sub process {
+ my $self = shift;
+ my ($e) = @_;
+
+ if ($self->{+_FILTERS}) {
+ for (@{$self->{+_FILTERS}}) {
+ $e = $_->{code}->($self, $e);
+ return unless $e;
+ }
+ }
+
+ my $type = ref($e);
+ my $is_ok = $type eq 'Test2::Event::Ok';
+ my $no_fail = $type eq 'Test2::Event::Diag' || $type eq 'Test2::Event::Note';
+ my $causes_fail = $is_ok ? !$e->{effective_pass} : $no_fail ? 0 : $e->causes_fail;
+
+ $self->{+COUNT}++ if $is_ok || (!$no_fail && $e->increments_count);
+ $self->{+FAILED}++ and $self->{+_PASSING} = 0 if $causes_fail;
+
+ my $callback = $e->callback($self) unless $is_ok || $no_fail;
+
+ my $count = $self->{+COUNT};
+
+ $self->{+_FORMATTER}->write($e, $count) if $self->{+_FORMATTER};
+
+ if ($self->{+_LISTENERS}) {
+ $_->{code}->($self, $e, $count) for @{$self->{+_LISTENERS}};
+ }
+
+ return $e if $is_ok || $no_fail;
+
+ my $code = $e->terminate;
+ $self->terminate($code, $e) if defined $code;
+
+ return $e;
+}
+
+sub terminate {
+ my $self = shift;
+ my ($code) = @_;
+ exit($code);
+}
+
+sub cull {
+ my $self = shift;
+
+ my $ipc = $self->{+IPC} || return;
+ return if $self->{+PID} != $$ || $self->{+TID} != get_tid();
+
+ # No need to do IPC checks on culled events
+ $self->process($_) for $ipc->cull($self->{+HID});
+}
+
+sub finalize {
+ my $self = shift;
+ my ($trace, $do_plan) = @_;
+
+ $self->cull();
+
+ my $plan = $self->{+_PLAN};
+ my $count = $self->{+COUNT};
+ my $failed = $self->{+FAILED};
+
+ # return if NOTHING was done.
+ return unless $do_plan || defined($plan) || $count || $failed;
+
+ unless ($self->{+ENDED}) {
+ if ($self->{+_FOLLOW_UPS}) {
+ $_->($trace, $self) for reverse @{$self->{+_FOLLOW_UPS}};
+ }
+
+ # These need to be refreshed now
+ $plan = $self->{+_PLAN};
+ $count = $self->{+COUNT};
+ $failed = $self->{+FAILED};
+
+ if (($plan && $plan eq 'NO PLAN') || ($do_plan && !$plan)) {
+ $self->send(
+ Test2::Event::Plan->new(
+ trace => $trace,
+ max => $count,
+ )
+ );
+ }
+ $plan = $self->{+_PLAN};
+ }
+
+ my $frame = $trace->frame;
+ if($self->{+ENDED}) {
+ my (undef, $ffile, $fline) = @{$self->{+ENDED}};
+ my (undef, $sfile, $sline) = @$frame;
+
+ die <<" EOT"
+Test already ended!
+First End: $ffile line $fline
+Second End: $sfile line $sline
+ EOT
+ }
+
+ $self->{+ENDED} = $frame;
+ $self->is_passing(); # Generate the final boolean.
+}
+
+sub is_passing {
+ my $self = shift;
+
+ ($self->{+_PASSING}) = @_ if @_;
+
+ # If we already failed just return 0.
+ my $pass = $self->{+_PASSING} || return 0;
+ return $self->{+_PASSING} = 0 if $self->{+FAILED};
+
+ my $count = $self->{+COUNT};
+ my $ended = $self->{+ENDED};
+ my $plan = $self->{+_PLAN};
+
+ return $pass if !$count && $plan && $plan =~ m/^SKIP$/;
+
+ return $self->{+_PASSING} = 0
+ if $ended && (!$count || !$plan);
+
+ return $pass unless $plan && $plan =~ m/^\d+$/;
+
+ if ($ended) {
+ return $self->{+_PASSING} = 0 if $count != $plan;
+ }
+ else {
+ return $self->{+_PASSING} = 0 if $count > $plan;
+ }
+
+ return $pass;
+}
+
+sub plan {
+ my $self = shift;
+
+ return $self->{+_PLAN} unless @_;
+
+ my ($plan) = @_;
+
+ confess "You cannot unset the plan"
+ unless defined $plan;
+
+ confess "You cannot change the plan"
+ if $self->{+_PLAN} && $self->{+_PLAN} !~ m/^NO PLAN$/;
+
+ confess "'$plan' is not a valid plan! Plan must be an integer greater than 0, 'NO PLAN', or 'SKIP'"
+ unless $plan =~ m/^(\d+|NO PLAN|SKIP)$/;
+
+ $self->{+_PLAN} = $plan;
+}
+
+sub check_plan {
+ my $self = shift;
+
+ return undef unless $self->{+ENDED};
+ my $plan = $self->{+_PLAN} || return undef;
+
+ return 1 if $plan !~ m/^\d+$/;
+
+ return 1 if $plan == $self->{+COUNT};
+ return 0;
+}
+
+sub DESTROY {
+ my $self = shift;
+ my $ipc = $self->{+IPC} || return;
+ return unless $$ == $self->{+PID};
+ return unless get_tid() == $self->{+TID};
+
+ $ipc->drop_hub($self->{+HID});
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2::Hub - The conduit through which all events flow.
+
+=head1 SYNOPSIS
+
+ use Test2::Hub;
+
+ my $hub = Test2::Hub->new();
+ $hub->send(...);
+
+=head1 DESCRIPTION
+
+The hub is the place where all events get processed and handed off to the
+formatter. The hub also tracks test state, and provides everal hooks into the
+event pipeline.
+
+=head1 COMMON TASKS
+
+=head2 SENDING EVENTS
+
+ $hub->send($event)
+
+The C<send()> method is used to issue an event to the hub. This method will
+handle thread/fork sync, filters, listeners, TAP output, etc.
+
+=head2 ALTERING OR REMOVING EVENTS
+
+You can use either C<filter()> or C<pre_filter()>, which one depends on your
+needs. Both have identical syntax, so only C<filter()> is shown here.
+
+ $hub->filter(sub {
+ my ($hub, $event) = @_;
+
+ my $action = get_action($event);
+
+ # No action should be taken
+ return $event if $action eq 'none';
+
+ # You want your filter to remove the event
+ return undef if $action eq 'delete';
+
+ if ($action eq 'do_it') {
+ my $new_event = copy_event($event);
+ ... Change your copy of the event ...
+ return $new_event;
+ }
+
+ die "Should not happen";
+ });
+
+By default filters are not inherited by child hubs, that means if you start a
+subtest, the subtest will not inherit the filter. You can change this behavior
+with the C<inherit> parameter:
+
+ $hub->filter(sub { ... }, inherit => 1);
+
+=head2 LISTENING FOR EVENTS
+
+ $hub->listen(sub {
+ my ($hub, $event, $number) = @_;
+
+ ... do whatever you want with the event ...
+
+ # return is ignored
+ });
+
+By default listeners are not inherited by child hubs, that means if you start a
+subtest, the subtest will not inherit the listener. You can change this behavior
+with the C<inherit> parameter:
+
+ $hub->listen(sub { ... }, inherit => 1);
+
+
+=head2 POST-TEST BEHAVIORS
+
+ $hub->follow_up(sub {
+ my ($trace, $hub) = @_;
+
+ ... do whatever you need to ...
+
+ # Return is ignored
+ });
+
+follow_up subs are called only once, ether when done_testing is called, or in
+an END block.
+
+=head2 SETTING THE FORMATTER
+
+By default an instance of L<Test2::Formatter::TAP> is created and used.
+
+ my $old = $hub->format(My::Formatter->new);
+
+Setting the formatter will REPLACE any existing formatter. You may set the
+formatter to undef to prevent output. The old formatter will be returned if one
+was already set. Only 1 formatter is allowed at a time.
+
+=head1 METHODS
+
+=over 4
+
+=item $hub->send($event)
+
+This is where all events enter the hub for processing.
+
+=item $hub->process($event)
+
+This is called by send after it does any IPC handling. You can use this to
+bypass the IPC process, but in general you should avoid using this.
+
+=item $old = $hub->format($formatter)
+
+Replace the existing formatter instance with a new one. Formatters must be
+objects that implement a C<< $formatter->write($event) >> method.
+
+=item $sub = $hub->listen(sub { ... }, %optional_params)
+
+You can use this to record all events AFTER they have been sent to the
+formatter. No changes made here will be meaningful, except possibly to other
+listeners.
+
+ $hub->listen(sub {
+ my ($hub, $event, $number) = @_;
+
+ ... do whatever you want with the event ...
+
+ # return is ignored
+ });
+
+Normally listeners are not inherited by child hubs such as subtests. You can
+add the C<< inherit => 1 >> parameter to allow a listener to be inherited.
+
+=item $hub->unlisten($sub)
+
+You can use this to remove a listen callback. You must pass in the coderef
+returned by the C<listen()> method.
+
+=item $sub = $hub->filter(sub { ... }, %optional_params)
+
+=item $sub = $hub->pre_filter(sub { ... }, %optional_params)
+
+These can be used to add filters. Filters can modify, replace, or remove events
+before anything else can see them.
+
+ $hub->filter(
+ sub {
+ my ($hub, $event) = @_;
+
+ return $event; # No Changes
+ return; # Remove the event
+
+ # Or you can modify an event before returning it.
+ $event->modify;
+ return $event;
+ }
+ );
+
+If you are not using threads, forking, or IPC then the only difference between
+a C<filter> and a C<pre_filter> is that C<pre_filter> subs run first. When you
+are using threads, forking, or IPC, pre_filters happen to events before they
+are sent to their destination proc/thread, ordinary filters happen only in the
+destination hub/thread.
+
+You cannot add a regular filter to a hub if the hub was created in another
+process or thread. You can always add a pre_filter.
+
+=item $hub->unfilter($sub)
+
+=item $hub->pre_unfilter($sub)
+
+These can be used to remove filters and pre_filters. The C<$sub> argument is
+the reference returned by C<filter()> or C<pre_filter()>.
+
+=item $hub->follow_op(sub { ... })
+
+Use this to add behaviors that are called just before the hub is finalized. The
+only argument to your codeblock will be a L<Test2::Util::Trace> instance.
+
+ $hub->follow_up(sub {
+ my ($trace, $hub) = @_;
+
+ ... do whatever you need to ...
+
+ # Return is ignored
+ });
+
+follow_up subs are called only once, ether when done_testing is called, or in
+an END block.
+
+=item $sub = $hub->add_context_acquire(sub { ... });
+
+Add a callback that will be called every time someone tries to acquire a
+context. It gets a single argument, a reference the the hash of parameters
+being used the construct the context. This is your chance to change the
+parameters by directly altering the hash.
+
+ test2_add_callback_context_acquire(sub {
+ my $params = shift;
+ $params->{level}++;
+ });
+
+This is a very scary API function. Please do not use this unless you need to.
+This is here for L<Test::Builder> and backwards compatibility. This has you
+directly manipulate the hash instead of returning a new one for performance
+reasons.
+
+B<Note> Using this hook could have a huge performance impact.
+
+The coderef you provide is returned and can be used to remove the hook later.
+
+=item $hub->remove_context_acquire($sub);
+
+This can be used to remove a context acquire hook.
+
+=item $sub = $hub->add_context_init(sub { ... });
+
+This allows you to add callbacks that will trigger every time a new context is
+created for the hub. The only argument to the sub will be the
+L<Test2::API::Context> instance that was created.
+
+B<Note> Using this hook could have a huge performance impact.
+
+The coderef you provide is returned and can be used to remove the hook later.
+
+=item $hub->remove_context_init($sub);
+
+This can be used to remove a context init hook.
+
+=item $sub = $hub->add_context_release(sub { ... });
+
+This allows you to add callbacks that will trigger every time a context for
+this hub is released. The only argument to the sub will be the
+L<Test2::API::Context> instance that was released. These will run in reverse
+order.
+
+B<Note> Using this hook could have a huge performance impact.
+
+The coderef you provide is returned and can be used to remove the hook later.
+
+=item $hub->remove_context_release($sub);
+
+This can be used to remove a context release hook.
+
+=item $hub->cull()
+
+Cull any IPC events (and process them).
+
+=item $pid = $hub->pid()
+
+Get the process id under which the hub was created.
+
+=item $tid = $hub->tid()
+
+Get the thread id under which the hub was created.
+
+=item $hud = $hub->hid()
+
+Get the identifier string of the hub.
+
+=item $ipc = $hub->ipc()
+
+Get the IPC object used by the hub.
+
+=item $hub->set_no_ending($bool)
+
+=item $bool = $hub->no_ending
+
+This can be used to disable auto-ending behavior for a hub. The auto-ending
+behavior is triggered by an end block and is used to cull IPC events, and
+output the final plan if the plan was 'no_plan'.
+
+=back
+
+=head2 STATE METHODS
+
+=over 4
+
+=item $hub->reset_state()
+
+Reset all state to the start. This sets the test count to 0, clears the plan,
+removes the failures, etc.
+
+=item $num = $hub->count
+
+Get the number of tests that have been run.
+
+=item $num = $hub->failed
+
+Get the number of failures (Not all failures come from a test fail, so this
+number can be larger than the count).
+
+=item $bool = $hub->ended
+
+True if the testing has ended. This MAY return the stack frame of the tool that
+ended the test, but that is not guaranteed.
+
+=item $bool = $hub->is_passing
+
+=item $hub->is_passing($bool)
+
+Check if the overall test run is a failure. Can also be used to set the
+pass/fail status.
+
+=item $hub->plan($plan)
+
+=item $plan = $hub->plan
+
+Get or set the plan. The plan must be an integer larger than 0, the string
+'no_plan', or the string 'skip_all'.
+
+=item $bool = $hub->check_plan
+
+Check if the plan and counts match, but only if the tests have ended. If tests
+have not unded this will return undef, otherwise it will be a true/false.
+
+=back
+
+=head1 THIRD PARTY META-DATA
+
+This object consumes L<Test2::Util::ExternalMeta> which provides a consistent
+way for you to attach meta-data to instances of this class. This is useful for
+tools, plugins, and other extentions.
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut
--- /dev/null
+package Test2::Hub::Interceptor;
+use strict;
+use warnings;
+
+our $VERSION = '1.302015';
+
+
+use Test2::Hub::Interceptor::Terminator();
+
+use base 'Test2::Hub';
+use Test2::Util::HashBase;
+
+sub inherit {
+ my $self = shift;
+ my ($from, %params) = @_;
+
+ if ($from->{+IPC} && !$self->{+IPC} && !exists($params{ipc})) {
+ my $ipc = $from->{+IPC};
+ $self->{+IPC} = $ipc;
+ $ipc->add_hub($self->{+HID});
+ }
+}
+
+sub terminate {
+ my $self = shift;
+ my ($code) = @_;
+ die bless(\$code, 'Test2::Hub::Interceptor::Terminator');
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2::Hub::Interceptor - Hub used by interceptor to grab results.
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut
--- /dev/null
+package Test2::Hub::Interceptor::Terminator;
+use strict;
+use warnings;
+
+our $VERSION = '1.302015';
+
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2::Hub::Interceptor::Terminator - Exception class used by
+Test2::Hub::Interceptor
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut
--- /dev/null
+package Test2::Hub::Subtest;
+use strict;
+use warnings;
+
+our $VERSION = '1.302015';
+
+
+use base 'Test2::Hub';
+use Test2::Util::HashBase qw/nested bailed_out exit_code manual_skip_all id/;
+use Test2::Util qw/get_tid/;
+
+my $ID = 1;
+sub init {
+ my $self = shift;
+ $self->SUPER::init(@_);
+ $self->{+ID} ||= join "-", $$, get_tid, $ID++;
+}
+
+sub process {
+ my $self = shift;
+ my ($e) = @_;
+ $e->set_nested($self->nested);
+ $e->set_in_subtest($self->{+ID});
+ $self->set_bailed_out($e) if $e->isa('Test2::Event::Bail');
+ $self->SUPER::process($e);
+}
+
+sub send {
+ my $self = shift;
+ my ($e) = @_;
+
+ my $out = $self->SUPER::send($e);
+
+ return $out if $self->{+MANUAL_SKIP_ALL};
+ return $out unless $e->isa('Test2::Event::Plan')
+ && $e->directive eq 'SKIP'
+ && ($e->trace->pid != $self->pid || $e->trace->tid != $self->tid);
+
+ no warnings 'exiting';
+ last T2_SUBTEST_WRAPPER;
+}
+
+sub terminate {
+ my $self = shift;
+ my ($code, $e) = @_;
+ $self->set_exit_code($code);
+
+ return if $self->{+MANUAL_SKIP_ALL};
+ return if $e->isa('Test2::Event::Plan')
+ && $e->directive eq 'SKIP'
+ && ($e->trace->pid != $$ || $e->trace->tid != get_tid);
+
+ no warnings 'exiting';
+ last T2_SUBTEST_WRAPPER;
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2::Hub::Subtest - Hub used by subtests
+
+=head1 DESCRIPTION
+
+Subtests make use of this hub to route events.
+
+=head1 TOGGLES
+
+=over 4
+
+=item $bool = $hub->manual_skip_all
+
+=item $hub->set_manual_skip_all($bool)
+
+The default is false.
+
+Normally a skip-all plan event will cause a subtest to stop executing. This is
+accomplished via C<last LABEL> to a label inside the subtest code. Most of the
+time this is perfectly fine. There are times however where this flow control
+causes bad things to happen.
+
+This toggle lets you turn off the abort logic for the hub. When this is toggled
+to true B<you> are responsible for ensuring no additional events are generated.
+
+=back
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut
--- /dev/null
+package Test2::IPC;
+use strict;
+use warnings;
+
+our $VERSION = '1.302015';
+
+
+use Test2::API::Instance;
+use Test2::Util qw/get_tid/;
+use Test2::API qw{
+ test2_init_done
+ test2_ipc
+ test2_ipc_enable_polling
+ test2_pid
+ test2_stack
+ test2_tid
+};
+
+use Carp qw/confess/;
+
+our @EXPORT_OK = qw/cull/;
+use base 'Exporter';
+
+sub import {
+ goto &Exporter::import unless test2_init_done();
+
+ confess "Cannot add IPC in a child process" if test2_pid() != $$;
+ confess "Cannot add IPC in a child thread" if test2_tid() != get_tid();
+
+ Test2::API::_set_ipc(_make_ipc());
+ apply_ipc(test2_stack());
+
+ goto &Exporter::import;
+}
+
+sub _make_ipc {
+ # Find a driver
+ my ($driver) = Test2::API::test2_ipc_drivers();
+ unless ($driver) {
+ require Test2::IPC::Driver::Files;
+ $driver = 'Test2::IPC::Driver::Files';
+ }
+
+ return $driver->new();
+}
+
+sub apply_ipc {
+ my $stack = shift;
+
+ my ($root) = @$stack;
+
+ return unless $root;
+
+ confess "Cannot add IPC in a child process" if $root->pid != $$;
+ confess "Cannot add IPC in a child thread" if $root->tid != get_tid();
+
+ my $ipc = $root->ipc || test2_ipc() || _make_ipc();
+
+ # Add the IPC to all hubs
+ for my $hub (@$stack) {
+ my $has = $hub->ipc;
+ confess "IPC Mismatch!" if $has && $has != $ipc;
+ next if $has;
+ $hub->set_ipc($ipc);
+ $ipc->add_hub($hub->hid);
+ }
+
+ test2_ipc_enable_polling();
+
+ return $ipc;
+}
+
+sub cull {
+ my $ctx = context();
+ $ctx->hub->cull;
+ $ctx->release;
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2::IPC - Turn on IPC for threading or forking support.
+
+=head1 SYNOPSIS
+
+You should C<use Test2::IPC;> as early as possible in your test file. If you
+import this module after API initialization it will attempt to retrofit IPC
+onto the existing hubs.
+
+=head1 EXPORTS
+
+All exports are optional.
+
+=over 4
+
+=item cull()
+
+Cull allows you to collect results from other processes or threads on demand.
+
+=back
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut
--- /dev/null
+package Test2::IPC::Driver;
+use strict;
+use warnings;
+
+our $VERSION = '1.302015';
+
+
+use Carp qw/confess longmess/;
+use Test2::Util::HashBase qw{no_fatal};
+
+use Test2::API qw/test2_ipc_add_driver/;
+
+my %ADDED;
+sub import {
+ my $class = shift;
+ return if $class eq __PACKAGE__;
+ return if $ADDED{$class}++;
+ test2_ipc_add_driver($class);
+}
+
+sub use_shm { 0 }
+
+for my $meth (qw/send cull add_hub drop_hub waiting is_viable/) {
+ no strict 'refs';
+ *$meth = sub {
+ my $thing = shift;
+ confess "'$thing' did not define the required method '$meth'."
+ };
+}
+
+# Print the error and call exit. We are not using 'die' cause this is a
+# catastophic error that should never be caught. If we get here it
+# means some serious shit has happened in a child process, the only way
+# to inform the parent may be to exit false.
+
+sub abort {
+ my $self = shift;
+ chomp(my ($msg) = @_);
+ print STDERR "IPC Fatal Error: $msg\n";
+ print STDOUT "not ok - IPC Fatal Error\n";
+
+ CORE::exit(255) unless $self->no_fatal;
+}
+
+sub abort_trace {
+ my $self = shift;
+ my ($msg) = @_;
+ $self->abort(longmess($msg));
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2::IPC::Driver - Base class for Test2 IPC drivers.
+
+=head1 SYNOPSIS
+
+ package Test2::IPC::Driver::MyDriver;
+
+ use base 'Test2::IPC::Driver';
+
+ ...
+
+=head1 METHODS
+
+=over 4
+
+=item $self->abort($msg)
+
+If an IPC encounters a fatal error it should use this. This will print the
+message to STDERR with C<'IPC Fatal Error: '> prefixed to it, then it will
+forcefully exit 255. IPC errors may occur in threads or processes other than
+the main one, this method provides the best chance of the harness noticing the
+error.
+
+=item $self->abort_trace($msg)
+
+This is the same as C<< $ipc->abort($msg) >> except that it uses
+C<Carp::longmess> to add a stack trace to the message.
+
+=item $false = $self->use_shm
+
+The base class always returns false for this method. You may override it if you
+wish to use the SHM made available in L<Test2::API>/L<Test2::API::Instance>.
+
+=back
+
+=head1 LOADING DRIVERS
+
+Test2::IPC::Driver has an C<import()> method. All drivers inherit this import
+method. This import method registers the driver.
+
+In most cases you just need to load the desired IPC driver to make it work. You
+should load this driver as early as possible. A warning will be issued if you
+load it too late for it to be effective.
+
+ use Test2::IPC::Driver::MyDriver;
+ ...
+
+=head1 WRITING DRIVERS
+
+ package Test2::IPC::Driver::MyDriver;
+ use strict;
+ use warnings;
+
+ use base 'Test2::IPC::Driver';
+
+ sub is_viable {
+ return 0 if $^O eq 'win32'; # Will not work on windows.
+ return 1;
+ }
+
+ sub add_hub {
+ my $self = shift;
+ my ($hid) = @_;
+
+ ... # Make it possible to contact the hub
+ }
+
+ sub drop_hub {
+ my $self = shift;
+ my ($hid) = @_;
+
+ ... # Nothing should try to reach the hub anymore.
+ }
+
+ sub send {
+ my $self = shift;
+ my ($hid, $e, $global) = @_;
+
+ ... # Send the event to the proper hub.
+
+ # If you are using the SHM you should notify other procs/threads that
+ # there is a pending event.
+ Test2::API::test2_ipc_set_pending($uniq_val);
+ }
+
+ sub cull {
+ my $self = shift;
+ my ($hid) = @_;
+
+ my @events = ...; # Here is where you get the events for the hub
+
+ return @events;
+ }
+
+ sub waiting {
+ my $self = shift;
+
+ ... # Notify all listening procs and threads that the main
+ ... # process/thread is waiting for them to finish.
+ }
+
+ 1;
+
+=head2 METHODS SUBCLASSES MUST IMPLEMENT
+
+=over 4
+
+=item $ipc->is_viable
+
+This should return true if the driver works in the current environment. This
+should return false if it does not. This is a CLASS method.
+
+=item $ipc->add_hub($hid)
+
+This is used to alert the driver that a new hub is expecting events. The driver
+should keep track of the process and thread ids, the hub should only be dropped
+by the proc+thread that started it.
+
+ sub add_hub {
+ my $self = shift;
+ my ($hid) = @_;
+
+ ... # Make it possible to contact the hub
+ }
+
+=item $ipc->drop_hub($hid)
+
+This is used to alert the driver that a hub is no longer accepting events. The
+driver should keep track of the process and thread ids, the hub should only be
+dropped by the proc+thread that started it (This is the drivers responsibility
+to enforce).
+
+ sub drop_hub {
+ my $self = shift;
+ my ($hid) = @_;
+
+ ... # Nothing should try to reach the hub anymore.
+ }
+
+=item $ipc->send($hid, $event);
+
+=item $ipc->send($hid, $event, $global);
+
+Used to send events from the current process/thread to the specified hub in its
+process+thread.
+
+ sub send {
+ my $self = shift;
+ my ($hid, $e) = @_;
+
+ ... # Send the event to the proper hub.
+
+ # If you are using the SHM you should notify other procs/threads that
+ # there is a pending event.
+ Test2::API::test2_ipc_set_pending($uniq_val);
+ }
+
+If C<$global> is true then the driver should send the event to all hubs in all
+processes and threads.
+
+=item @events = $ipc->cull($hid)
+
+Used to collect events that have been sent to the specified hub.
+
+ sub cull {
+ my $self = shift;
+ my ($hid) = @_;
+
+ my @events = ...; # Here is where you get the events for the hub
+
+ return @events;
+ }
+
+=item $ipc->waiting()
+
+This is called in the parent process when it is complete and waiting for all
+child processes and threads to complete.
+
+ sub waiting {
+ my $self = shift;
+
+ ... # Notify all listening procs and threads that the main
+ ... # process/thread is waiting for them to finish.
+ }
+
+=back
+
+=head2 METHODS SUBCLASSES MAY IMPLEMENT OR OVERRIDE
+
+=over 4
+
+=item $bool = $ipc->use_shm()
+
+True if you want to make use of the L<Test2::API>/L<Test2::API::Instance> SHM.
+
+=item $bites = $ipc->shm_size()
+
+Use this to customize the size of the shm space. There are no guarantees about
+what the size will be if you do not implement this.
+
+=back
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut
--- /dev/null
+package Test2::IPC::Driver::Files;
+use strict;
+use warnings;
+
+our $VERSION = '1.302015';
+
+
+use base 'Test2::IPC::Driver';
+
+use Test2::Util::HashBase qw{tempdir event_id tid pid globals};
+
+use Scalar::Util qw/blessed/;
+use File::Temp();
+use Storable();
+use File::Spec();
+
+use Test2::Util qw/try get_tid pkg_to_file/;
+use Test2::API qw/test2_ipc_set_pending/;
+
+sub use_shm { 1 }
+sub shm_size() { 64 }
+
+sub is_viable { 1 }
+
+sub init {
+ my $self = shift;
+
+ my $tmpdir = File::Temp::tempdir(
+ $ENV{T2_TEMPDIR_TEMPLATE} || "test2-$$-XXXXXX",
+ CLEANUP => 0,
+ TMPDIR => 1,
+ );
+
+ $self->abort_trace("Could not get a temp dir") unless $tmpdir;
+
+ $self->{+TEMPDIR} = File::Spec->canonpath($tmpdir);
+
+ print STDERR "\nIPC Temp Dir: $tmpdir\n\n"
+ if $ENV{T2_KEEP_TEMPDIR};
+
+ $self->{+EVENT_ID} = 1;
+
+ $self->{+TID} = get_tid();
+ $self->{+PID} = $$;
+
+ $self->{+GLOBALS} = {};
+
+ return $self;
+}
+
+sub hub_file {
+ my $self = shift;
+ my ($hid) = @_;
+ my $tdir = $self->{+TEMPDIR};
+ return File::Spec->canonpath("$tdir/HUB-$hid");
+}
+
+sub event_file {
+ my $self = shift;
+ my ($hid, $e) = @_;
+
+ my $tempdir = $self->{+TEMPDIR};
+ my $type = blessed($e) or $self->abort("'$e' is not a blessed object!");
+
+ $self->abort("'$e' is not an event object!")
+ unless $type->isa('Test2::Event');
+
+ my @type = split '::', $type;
+ my $name = join('-', $hid, $$, get_tid(), $self->{+EVENT_ID}++, @type);
+
+ return File::Spec->canonpath("$tempdir/$name");
+}
+
+sub add_hub {
+ my $self = shift;
+ my ($hid) = @_;
+
+ my $hfile = $self->hub_file($hid);
+
+ $self->abort_trace("File for hub '$hid' already exists")
+ if -e $hfile;
+
+ open(my $fh, '>', $hfile) or $self->abort_trace("Could not create hub file '$hid': $!");
+ print $fh "$$\n" . get_tid() . "\n";
+ close($fh);
+}
+
+sub drop_hub {
+ my $self = shift;
+ my ($hid) = @_;
+
+ my $tdir = $self->{+TEMPDIR};
+ my $hfile = $self->hub_file($hid);
+
+ $self->abort_trace("File for hub '$hid' does not exist")
+ unless -e $hfile;
+
+ open(my $fh, '<', $hfile) or $self->abort_trace("Could not open hub file '$hid': $!");
+ my ($pid, $tid) = <$fh>;
+ close($fh);
+
+ $self->abort_trace("A hub file can only be closed by the process that started it\nExpected $pid, got $$")
+ unless $pid == $$;
+
+ $self->abort_trace("A hub file can only be closed by the thread that started it\nExpected $tid, got " . get_tid())
+ unless get_tid() == $tid;
+
+ if ($ENV{T2_KEEP_TEMPDIR}) {
+ rename($hfile, File::Spec->canonpath("$hfile.complete")) or $self->abort_trace("Could not rename file '$hfile' -> '$hfile.complete'");
+ }
+ else {
+ unlink($hfile) or $self->abort_trace("Could not remove file for hub '$hid'");
+ }
+
+ opendir(my $dh, $tdir) or $self->abort_trace("Could not open temp dir!");
+ for my $file (readdir($dh)) {
+ next if $file =~ m{\.complete$};
+ next unless $file =~ m{^$hid};
+ $self->abort_trace("Not all files from hub '$hid' have been collected!");
+ }
+ closedir($dh);
+}
+
+sub send {
+ my $self = shift;
+ my ($hid, $e, $global) = @_;
+
+ my $tempdir = $self->{+TEMPDIR};
+ my $hfile = $self->hub_file($hid);
+ my $dest = $global ? 'GLOBAL' : $hid;
+
+ $self->abort(<<" EOT") unless $global || -f $hfile;
+hub '$hid' is not available, failed to send event!
+
+There was an attempt to send an event to a hub in a parent process or thread,
+but that hub appears to be gone. This can happen if you fork, or start a new
+thread from inside subtest, and the parent finishes the subtest before the
+child returns.
+
+This can also happen if the parent process is done testing before the child
+finishes. Test2 normally waits automatically in the root process, but will not
+do so if Test::Builder is loaded for legacy reasons.
+ EOT
+
+ my $file = $self->event_file($dest, $e);
+ my $ready = File::Spec->canonpath("$file.ready");
+
+ if ($global) {
+ my $name = $ready;
+ $name =~ s{^.*(GLOBAL)}{GLOBAL};
+ $self->{+GLOBALS}->{$hid}->{$name}++;
+ }
+
+ my ($ok, $err) = try {
+ Storable::store($e, $file);
+ rename($file, $ready) or $self->abort("Could not rename file '$file' -> '$ready'");
+ test2_ipc_set_pending(substr($file, -(shm_size)));
+ };
+ if (!$ok) {
+ my $src_file = __FILE__;
+ $err =~ s{ at \Q$src_file\E.*$}{};
+ chomp($err);
+ my $tid = get_tid();
+ my $trace = $e->trace->debug;
+ my $type = blessed($e);
+
+ $self->abort(<<" EOT");
+
+*******************************************************************************
+There was an error writing an event:
+Destination: $dest
+Origin PID: $$
+Origin TID: $tid
+Event Type: $type
+Event Trace: $trace
+File Name: $file
+Ready Name: $ready
+Error: $err
+*******************************************************************************
+
+ EOT
+ }
+
+ return 1;
+}
+
+sub cull {
+ my $self = shift;
+ my ($hid) = @_;
+
+ my $tempdir = $self->{+TEMPDIR};
+
+ opendir(my $dh, $tempdir) or $self->abort("could not open IPC temp dir ($tempdir)!");
+
+ my @out;
+ for my $file (sort readdir($dh)) {
+ next if substr($file, 0, 1) eq '.';
+
+ next unless substr($file, -6, 6) eq '.ready';
+
+ my $global = substr($file, 0, 6) eq 'GLOBAL';
+ my $hid_len = length($hid);
+ my $have_hid = !$global && substr($file, 0, $hid_len) eq $hid && substr($file, $hid_len, 1) eq '-';
+
+ next unless $have_hid || $global;
+
+ next if $global && $self->{+GLOBALS}->{$hid}->{$file}++;
+
+ # Untaint the path.
+ my $full = File::Spec->canonpath("$tempdir/$file");
+ ($full) = ($full =~ m/^(.*)$/gs);
+
+ my $obj = $self->read_event_file($full);
+ push @out => $obj;
+
+ # Do not remove global events
+ next if $global;
+
+ my $complete = File::Spec->canonpath("$full.complete");
+ if ($ENV{T2_KEEP_TEMPDIR}) {
+ rename($full, $complete) or $self->abort("Could not rename IPC file '$full', '$complete'");
+ }
+ else {
+ unlink($full) or $self->abort("Could not unlink IPC file: $file");
+ }
+ }
+
+ closedir($dh);
+ return @out;
+}
+
+sub read_event_file {
+ my $self = shift;
+ my ($file) = @_;
+
+ my $obj = Storable::retrieve($file);
+ $self->abort("Got an unblessed object: '$obj'")
+ unless blessed($obj);
+
+ unless ($obj->isa('Test2::Event')) {
+ my $pkg = blessed($obj);
+ my $mod_file = pkg_to_file($pkg);
+ my ($ok, $err) = try { require $mod_file };
+
+ $self->abort("Event has unknown type ($pkg), tried to load '$mod_file' but failed: $err")
+ unless $ok;
+
+ $self->abort("'$obj' is not a 'Test2::Event' object")
+ unless $obj->isa('Test2::Event');
+ }
+
+ return $obj;
+}
+
+sub waiting {
+ my $self = shift;
+ require Test2::Event::Waiting;
+ $self->send(
+ GLOBAL => Test2::Event::Waiting->new(
+ trace => Test2::Util::Trace->new(frame => [caller()]),
+ ),
+ 'GLOBAL'
+ );
+ return;
+}
+
+sub DESTROY {
+ my $self = shift;
+
+ return unless defined $self->pid;
+ return unless defined $self->tid;
+
+ return unless $$ == $self->pid;
+ return unless get_tid() == $self->tid;
+
+ my $tempdir = $self->{+TEMPDIR};
+
+ opendir(my $dh, $tempdir) or $self->abort("Could not open temp dir! ($tempdir)");
+ while(my $file = readdir($dh)) {
+ next if $file =~ m/^\.+$/;
+ next if $file =~ m/\.complete$/;
+ my $full = File::Spec->canonpath("$tempdir/$file");
+
+ if ($file =~ m/^(GLOBAL|HUB-)/) {
+ $full =~ m/^(.*)$/;
+ $full = $1; # Untaint it
+ next if $ENV{T2_KEEP_TEMPDIR};
+ unlink($full) or $self->abort("Could not unlink IPC file: $full");
+ next;
+ }
+
+ $self->abort("Leftover files in the directory ($full)!\n");
+ }
+ closedir($dh);
+
+ if ($ENV{T2_KEEP_TEMPDIR}) {
+ print STDERR "# Not removing temp dir: $tempdir\n";
+ return;
+ }
+
+ rmdir($tempdir) or warn "Could not remove IPC temp dir ($tempdir)";
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2::IPC::Driver::Files - Temp dir + Files concurrency model.
+
+=head1 DESCRIPTION
+
+This is the default, and fallback concurrency model for L<Test2>. This
+sends events between processes and threads using serialized files in a
+temporary directory. This is not particularly fast, but it works everywhere.
+
+=head1 SYNOPSIS
+
+ use Test2::IPC::Driver::Files;
+
+ # IPC is now enabled
+
+=head1 ENVIRONMENT VARIABLES
+
+=over 4
+
+=item T2_KEEP_TEMPDIR=0
+
+When true, the tempdir used by the IPC driver will not be deleted when the test
+is done.
+
+=item T2_TEMPDIR_TEMPLATE='test2-XXXXXX'
+
+This can be used to set the template for the IPC temp dir. The template should
+follow template specifications from L<File::Temp>.
+
+=back
+
+=head1 SEE ALSO
+
+See L<Test2::IPC::Driver> for methods.
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut
--- /dev/null
+=pod
+
+=head1 NAME
+
+Test2::Transition - Transition notes when upgrading to Test2
+
+=head1 DESCRIPTION
+
+This is where gotchas and breakages related to the Test2 upgrade are
+documented. The upgrade causes Test::Builder to defer to Test2 uner the hood.
+This transition is mostly transparent, but there are a few cases that can trip
+you up.
+
+=head1 THINGS THAT BREAK
+
+This is the list of scenarios that break with the new internals.
+
+=head2 Test::Builder1.5/2 conditionals
+
+=head3 The Problem
+
+a few years back there were two attempts to upgrade/replace Test::Builder.
+Confusingly these were called Test::Builder2 and Test::Builder1.5, in that
+order. Many people put conditionals in their code to check the Test::Builder
+version number and adapt their code accordingly.
+
+The Test::Builder2/1.5 projects both died out. Now the conditional code poeple
+added has become a mine field. A vast majority of modules broken by Test2 fall
+into this category.
+
+=head3 The Fix
+
+The fix is to remove all Test::Builder1.5/2 related code. Either use the
+lagacy Test::Builder API, or use Test2 directly.
+
+=head2 Replacing the Test::Builder singleton
+
+=head3 The Problem
+
+Some test modules would replace the Test::Builder singleton instance with their
+own instance or subclass. This was usually done to intercept or modify results
+as they happened.
+
+The Test::Builder singleton is now a simple compatibility wrapper around
+Test2. The Test::Builder singleton is no longer the central place for
+results. Many results bypass the Test::Builder singleton completely, which
+breaks and behavior intended when replacing the singleton.
+
+=head3 The Fix
+
+If you simply want to intercept all results instead of letting them go to TAP,
+you should look at the L<Test2::API> docs and read about pushing a new hub onto
+the hub stack. Replacing the hub temporarily is now the correct way to
+intercept results.
+
+If your goal is purely monitoring of events use the C<< Test2::Hub->listen() >>
+method exported by Test::More to watch events as they are fired. If you wish to
+modify results before they go to TAP look at the C<< Test2::Hub->filter() >>
+method.
+
+=head2 Directly Accessing Hash Elements
+
+=head3 The Problem
+
+Some modules look directly at hash keys on the Test::Builder singleton. The
+problem here is that the Test::Builder singleton no longer holds anything
+important.
+
+=head3 The Fix
+
+The fix is to use the API specified in L<Test2::API> to look at or modify state
+as needed.
+
+=head2 Subtest indentation
+
+=head3 The Problem
+
+An early change, in fact the change that made Test2 an idea, was a change to
+the indentation of the subtest note. IT was decided it would be more readable
+to outdent the subtest note instead of having it inline withthe subtest:
+
+ # subtest foo
+ ok 1 - blah
+ 1..1
+ ok 1 - subtest foo
+
+The old style indented the note:
+
+ # subtest foo
+ ok 1 - blah
+ 1..1
+ ok 1 - subtest foo
+
+This breaks tests that do string comparison of TAP output.
+
+=head3 The Fix
+
+ my $indent = $INC{'Test2/API.pm'} ? '' : ' ';
+
+ is(
+ $subtest_output,
+ "${indent}# subtest foo",
+ "Got subtest note"
+ );
+
+Check if C<$INC{'Test2/API.pm'}> is set, if it is then no indentation should be
+expected. If it is not set than the old Test::Builder is in use, indentation
+should be expected.
+
+=head1 DISTRIBUTIONS THAT BREAK OR NEED TO BE UPGRADED
+
+This is a list of cpan modules that have been known to have been broken by the
+upgrade at one point.
+
+=head2 WORKS BUT TESTS WILL FAIL
+
+These modules still function correctly, but their test suites will not pass. If
+you already have these modules installed then you can continue to use them. If
+you are trying to install them after upgrading Test::Builder you will need to
+force installation, or bypass the broken tests.
+
+=over 4
+
+=item Test::DBIx::Class::Schema
+
+This module has a test that appears to work around a Test::Builder bug. The bug
+appears to have been fixed by Test2, which means the workaround causes a
+failure. This can be easily updated, but nobody has done so yet.
+
+Known broken in versions: 1.0.9 and older
+
+=item Test::Kit
+
+This actually works fine, but will not install because L<Test::Aggregate> is in
+the dep chain.
+
+See the L<Test::Aggregate> info below for additional information.
+
+=item Device::Chip
+
+Tests break due to subtest indentation.
+
+Known broken in version 0.07. Apparently works fine in 0.06 though. Patch has
+been submitted to fix the issue.
+
+=back
+
+=head2 UPGRADE SUGGESTED
+
+These are modules that did not break, but had broken test suites that have
+since been fixed.
+
+=over 4
+
+=item Test::Exception
+
+Old versions work fine, but have a minor test name behavior that breaks with
+Test2. Old versions will no longer install because of this. The latest version
+on CPAN will install just fine. Upgrading is not required, but is recommended.
+
+Fixed in version: 0.43
+
+=item Data::Peek
+
+Some tests depended on C<$!> and C<$?> being modified in subtle ways. A patch
+was applied to correct things that changed.
+
+The module itself works fine, there is no need to upgrade.
+
+Fixed in version: 0.45
+
+=item circular::require
+
+Some tests were fragile and required base.pm to be loaded at a late stage.
+Test2 was loading base.pm too early. The tests were updated to fix this.
+
+The module itself never broke, you do not need to upgrade.
+
+Fixed in version: 0.12
+
+=item Test::Module::Used
+
+A test worked around a now-fixed planning bug. There is no need to upgrade if
+you have an old version installed. New versions install fine if you want them.
+
+Fixed in version: 0.2.5
+
+=item Test::Moose::More
+
+Some tests were fragile, but have been fixed. The actual breakage was from the
+subtest comment indentation change.
+
+No need to upgrade, old versions work fine. Only new versions will install.
+
+Fixed in version: 0.025
+
+=item Test::FITesque
+
+This was broken by a bugfix to how planning is done. The test was updated after
+the bugfix.
+
+Fixed in version: 0.04
+
+=item autouse
+
+A test broke because it depended on Scalar::Util not being loaded. Test2 loads
+Scalar::Util. The test was updated to load Test2 after checking Scalar::Util's
+load status.
+
+There is no need to upgrade if you already have it installed.
+
+Fixed in version: 1.11
+
+=back
+
+=head2 NEED TO UPGRADE
+
+=over 4
+
+=item Test::SharedFork
+
+Old versions need to directly access Test::Builder singleton hash elements. The
+latest version on CPAN will still do this on old Test::Builder, but will defer
+to L<Test2::IPC> on Test2.
+
+Fixed in version: 0.35
+
+=item Test::Builder::Clutch
+
+This works by doing overriding methods on the singleton, and directly accessing
+hash values on the singleton. A new version has been released that uses the
+Test2 API to accomplish the same result in a saner way.
+
+Fixed in version: 0.07
+
+=item Test::Dist::VersionSync
+
+This had Test::Builder2 conditionals. This was fixed by removing the
+conditionals.
+
+Fixed in version: 1.1.4
+
+=item Test::Modern
+
+This relied on C<< Test::Builder->_try() >> which was a private method,
+documented as something nobody should use. This was fixed by using a different
+tool.
+
+Fixed in version: 0.012
+
+=back
+
+=head2 STILL BROKEN
+
+=over 4
+
+=item Test::Aggregate
+
+This distribution directly accesses the hash keys in the L<Test::Builder>
+singleton. It also approaches the problem from the wrong angle, please consider
+using L<Test2::Harness> (not yet released) or L<App::ForkProve> which both
+solve the same problem at the harness level.
+
+Still broken as of version: 0.373
+
+=item Test::Wrapper
+
+This module directly uses hash keys in the L<Test::BuildeR> singleton. This
+module is also obsolete thanks to the benefits of L<Test2>. Use C<intercept()>
+from L<Test2::API> to achieve a similar result.
+
+Still broken as of version: 0.3.0
+
+=item Test::ParallelSubtest
+
+This module overrides C<Test::Builder::subtest()> and
+C<Test::Builder::done_testing()>. It also directly accesses hash elements of
+the singleton. It has not yet been fixed.
+
+Alternatives: L<Test2::AsyncSubtest> and L<Test2::Workflow> (not stable).
+
+Still broken as of version: 0.05
+
+=item Test::Pretty
+
+See https://github.com/tokuhirom/Test-Pretty/issues/25
+
+The author admits the module is crazy, and he is awaiting a stable release of
+something new (Test2) to completely rewrite it in a sane way.
+
+Still broken as of version: 0.32
+
+=item Test::More::Prefix
+
+The current version, 0.005 is broken. A patch has been applied in git, and
+released in 0.006, but a version issue with 0.006 prevents its installation.
+
+Still broken as of version: 0.005
+Potentially fixed in version: 0.006 (not installable)
+
+=item Net::BitTorrent
+
+The tests for this module directly access L<Test::Builder> hash keys. Most, if
+not all of these hash keys have public API methods that could be used instead
+to avoid the problem.
+
+Still broken in version: 0.052
+
+=item Test::Group
+
+It monkeypatches Test::Builder, and calls it "black magic" in the code.
+
+Still broken as of version: 0.20
+
+=item Test::Flatten
+
+This modifies the Test::Builder internals in many ways. A better was to
+accomplish the goal of this module is to write your own subtest function.
+
+Still broken as of version: 0.11
+
+=item Log::Dispatch::Config::TestLog
+
+Modifies Test::Builder internals.
+
+Still broken as of version: 0.02
+
+=item Test::Able
+
+Modifies Test::Builder internals.
+
+Still broken as of version: 0.11
+
+=back
+
+=head1 MAKE ASSERTIONS -> SEND EVENTS
+
+=head2 LEGACY
+
+ use Test::Builder;
+
+ # A majority of tools out there do this:
+ # my $TB = Test::Builder->new;
+ # This works, but has always been wrong, forcing Test::Builder to implement
+ # subtests as a horrific hack. It also causes problems for tools that try
+ # to replace the singleton (also discouraged).
+
+ sub my_ok($;$) {
+ my ($bool, $name) = @_;
+ my $TB = Test::Builder->new;
+ $TB->ok($bool, $name);
+ }
+
+ sub my_diag($) {
+ my ($msg) = @_;
+ my $TB = Test::Builder->new;
+ $TB->diag($msg);
+ }
+
+=head2 TEST2
+
+ use Test2::API qw/context/;
+
+ sub my_ok($;$) {
+ my ($bool, $name) = @_;
+ my $ctx = context();
+ $ctx->ok($bool, $name);
+ $ctx->release;
+ }
+
+ sub my_diag($) {
+ my ($msg) = @_;
+ my $ctx = context();
+ $ctx->diag($msg);
+ $ctx->release;
+ }
+
+The context object has API compatible implementations of the following methods:
+
+=over 4
+
+=item ok($bool, $name)
+
+=item diag(@messages)
+
+=item note(@messages)
+
+=item subtest($name, $code)
+
+=back
+
+If you are looking for helpers with C<is>, C<like>, and others, see
+L<Test2::Suite>.
+
+=head1 WRAP EXISTING TOOLS
+
+=head2 LEGACY
+
+ use Test::More;
+
+ sub exclusive_ok {
+ my ($bool1, $bool2, $name) = @_;
+
+ # Ensure errors are reported 1 level higher
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ $ok = $bool1 || $bool2;
+ $ok &&= !($bool1 && $bool2);
+ ok($ok, $name);
+
+ return $bool;
+ }
+
+Every single tool in the chain from this, to C<ok>, to anything C<ok> calls
+needs to increment the C<$Level> variable. When an error occurs Test::Builder
+will do a trace to the stack frame determined by C<$Level>, and report that
+file+line as the one where the error occurred. If you or any other tool you use
+forgets to set C<$Level> then errors will be reported to the wrong place.
+
+=head2 TEST2
+
+ use Test::More;
+
+ sub exclusive_ok {
+ my ($bool1, $bool2, $name) = @_;
+
+ # Grab and store the context, even if you do not need to use it
+ # directly.
+ my $ctx = context();
+
+ $ok = $bool1 || $bool2;
+ $ok &&= !($bool1 && $bool2);
+ ok($ok, $name);
+
+ $ctx->release;
+ return $bool;
+ }
+
+Instead of using C<$Level> to perform a backtrace, Test2 uses a context
+object. In this sample you create a context object and store it. This locks the
+context (errors report 1 level up from here) for all wrapped tools to find. You
+do not need to use the context object, but you do need to store it in a
+variable. Once the sub ends the C<$ctx> variable is destroyed which lets future
+tools find their own.
+
+=head1 USING UTF8
+
+=head2 LEGACY
+
+ # Set the mode BEFORE anything loads Test::Builder
+ use open ':std', ':encoding(utf8)';
+ use Test::More;
+
+Or
+
+ # Modify the filehandles
+ my $builder = Test::More->builder;
+ binmode $builder->output, ":encoding(utf8)";
+ binmode $builder->failure_output, ":encoding(utf8)";
+ binmode $builder->todo_output, ":encoding(utf8)";
+
+=head2 TEST2
+
+ use Test2::API qw/test2_stack/;
+
+ test2_stack->top->format->encoding('utf8');
+
+Though a much better way is to use the L<Test2::Plugin::UTF8> plugin, which is
+part of L<Test2::Suite>.
+
+=head1 AUTHORS, CONTRIBUTORS AND REVIEWERS
+
+The following people have all contributed to this document in some way, even if
+only for review.
+
+=over 4
+
+=item Chad Granum (EXODIST) E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
--- /dev/null
+package Test2::Util;
+use strict;
+use warnings;
+
+our $VERSION = '1.302015';
+
+
+use Config qw/%Config/;
+
+our @EXPORT_OK = qw{
+ try
+
+ pkg_to_file
+
+ get_tid USE_THREADS
+ CAN_THREAD
+ CAN_REALLY_FORK
+ CAN_FORK
+};
+use base 'Exporter';
+
+sub _can_thread {
+ return 0 unless $] >= 5.008001;
+ return 0 unless $Config{'useithreads'};
+
+ # Threads are broken on perl 5.10.0 built with gcc 4.8+
+ if ($] == 5.010000 && $Config{'ccname'} eq 'gcc' && $Config{'gccversion'}) {
+ my @parts = split /\./, $Config{'gccversion'};
+ return 0 if $parts[0] >= 4 && $parts[1] >= 8;
+ }
+
+ # Change to a version check if this ever changes
+ return 0 if $INC{'Devel/Cover.pm'};
+ return 1;
+}
+
+sub _can_fork {
+ return 1 if $Config{d_fork};
+ return 0 unless $^O eq 'MSWin32' || $^O eq 'NetWare';
+ return 0 unless $Config{useithreads};
+ return 0 unless $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/;
+
+ return _can_thread();
+}
+
+BEGIN {
+ no warnings 'once';
+ *CAN_REALLY_FORK = $Config{d_fork} ? sub() { 1 } : sub() { 0 };
+ *CAN_THREAD = _can_thread() ? sub() { 1 } : sub() { 0 };
+ *CAN_FORK = _can_fork() ? sub() { 1 } : sub() { 0 };
+}
+
+sub _manual_try(&;@) {
+ my $code = shift;
+ my $args = \@_;
+ my $err;
+
+ my $die = delete $SIG{__DIE__};
+
+ eval { $code->(@$args); 1 } or $err = $@ || "Error was squashed!\n";
+
+ $die ? $SIG{__DIE__} = $die : delete $SIG{__DIE__};
+
+ return (!defined($err), $err);
+}
+
+sub _local_try(&;@) {
+ my $code = shift;
+ my $args = \@_;
+ my $err;
+
+ no warnings;
+ local $SIG{__DIE__};
+ eval { $code->(@$args); 1 } or $err = $@ || "Error was squashed!\n";
+
+ return (!defined($err), $err);
+}
+
+# Older versions of perl have a nasty bug on win32 when localizing a variable
+# before forking or starting a new thread. So for those systems we use the
+# non-local form. When possible though we use the faster 'local' form.
+BEGIN {
+ if ($^O eq 'MSWin32' && $] < 5.020002) {
+ *try = \&_manual_try;
+ }
+ else {
+ *try = \&_local_try;
+ }
+}
+
+BEGIN {
+ if(CAN_THREAD) {
+ if ($INC{'threads.pm'}) {
+ # Threads are already loaded, so we do not need to check if they
+ # are loaded each time
+ *USE_THREADS = sub() { 1 };
+ *get_tid = sub { threads->tid() };
+ }
+ else {
+ # :-( Need to check each time to see if they have been loaded.
+ *USE_THREADS = sub { $INC{'threads.pm'} ? 1 : 0 };
+ *get_tid = sub { $INC{'threads.pm'} ? threads->tid() : 0 };
+ }
+ }
+ else {
+ # No threads, not now, not ever!
+ *USE_THREADS = sub() { 0 };
+ *get_tid = sub() { 0 };
+ }
+}
+
+sub pkg_to_file {
+ my $pkg = shift;
+ my $file = $pkg;
+ $file =~ s{(::|')}{/}g;
+ $file .= '.pm';
+ return $file;
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2::Util - Tools used by Test2 and friends.
+
+=head1 DESCRIPTION
+
+Collection of tools used by L<Test2> and friends.
+
+=head1 EXPORTS
+
+All exports are optional, you must specify subs to import.
+
+=over 4
+
+=item ($success, $error) = try { ... }
+
+Eval the codeblock, return success or failure, and the error message. This code
+protects $@ and $!, they will be restored by the end of the run. This code also
+temporarily blocks $SIG{DIE} handlers.
+
+=item protect { ... }
+
+Similar to try, except that it does not catch exceptions. The idea here is to
+protect $@ and $! from changes. $@ and $! will be restored to whatever they
+were before the run so long as it is successful. If the run fails $! will still
+be restored, but $@ will contain the exception being thrown.
+
+=item CAN_FORK
+
+True if this system is capable of true or psuedo-fork.
+
+=item CAN_REALLY_FORK
+
+True if the system can really fork. This will be false for systems where fork
+is emulated.
+
+=item CAN_THREAD
+
+True if this system is capable of using threads.
+
+=item USE_THREADS
+
+Returns true if threads are enabled, false if they are not.
+
+=item get_tid
+
+This will return the id of the current thread when threads are enabled,
+otherwise it returns 0.
+
+=item my $file = pkg_to_file($package)
+
+Convert a package name to a filename.
+
+=back
+
+=head1 NOTES && CAVEATS
+
+=over 4
+
+=item 5.10.0
+
+Perl 5.10.0 has a bug when compiled with newer gcc versions. This bug causes a
+segfault whenever a new thread is launched. Test2 will attempt to detect
+this, and note that the system is not capable of forking when it is detected.
+
+=item Devel::Cover
+
+Devel::Cover does not support threads. CAN_THREAD will return false if
+Devel::Cover is loaded before the check is first run.
+
+=back
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Kent Fredric E<lt>kentnl@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut
--- /dev/null
+package Test2::Util::ExternalMeta;
+use strict;
+use warnings;
+
+our $VERSION = '1.302015';
+
+
+use Carp qw/croak/;
+
+sub META_KEY() { '_meta' }
+
+our @EXPORT = qw/meta set_meta get_meta delete_meta/;
+use base 'Exporter';
+
+sub set_meta {
+ my $self = shift;
+ my ($key, $value) = @_;
+
+ validate_key($key);
+
+ $self->{+META_KEY} ||= {};
+ $self->{+META_KEY}->{$key} = $value;
+}
+
+sub get_meta {
+ my $self = shift;
+ my ($key) = @_;
+
+ validate_key($key);
+
+ my $meta = $self->{+META_KEY} or return undef;
+ return $meta->{$key};
+}
+
+sub delete_meta {
+ my $self = shift;
+ my ($key) = @_;
+
+ validate_key($key);
+
+ my $meta = $self->{+META_KEY} or return undef;
+ delete $meta->{$key};
+}
+
+sub meta {
+ my $self = shift;
+ my ($key, $default) = @_;
+
+ validate_key($key);
+
+ my $meta = $self->{+META_KEY};
+ return undef unless $meta || defined($default);
+
+ unless($meta) {
+ $meta = {};
+ $self->{+META_KEY} = $meta;
+ }
+
+ $meta->{$key} = $default
+ if defined($default) && !defined($meta->{$key});
+
+ return $meta->{$key};
+}
+
+sub validate_key {
+ my $key = shift;
+
+ return if $key && !ref($key);
+
+ my $render_key = defined($key) ? "'$key'" : 'undef';
+ croak "Invalid META key: $render_key, keys must be true, and may not be references";
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2::Util::ExternalMeta - Allow third party tools to safely attach meta-data
+to your instances.
+
+=head1 DESCRIPTION
+
+This package lets you define a clear, and consistent way to allow third party
+tools to attach meta-data to your instances. If your object consumes this
+package, and imports its methods, then third party meta-data has a safe place
+to live.
+
+=head1 SYNOPSYS
+
+ package My::Object;
+ use strict;
+ use warnings;
+
+ use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/;
+
+ ...
+
+Now to use it:
+
+ my $inst = My::Object->new;
+
+ $inst->set_meta(foo => 'bar');
+ my $val = $inst->get_meta('foo');
+
+=head1 WHERE IS THE DATA STORED?
+
+This package assumes your instances are blessed hashrefs, it will not work if
+that is not true. It will store all meta-data in the C<_meta> key on your
+objects hash. If your object makes use of the C<_meta> key in its underlying
+hash, then there is a conflict and you cannot use this package.
+
+=head1 EXPORTS
+
+=over 4
+
+=item $val = $obj->meta($key)
+
+=item $val = $obj->meta($key, $default)
+
+This will get the value for a specified meta C<$key>. Normally this will return
+C<undef> when there is no value for the C<$key>, however you can specfi a
+C<$default> value to set when no value is already set.
+
+=item $val = $obj->get_meta($key)
+
+This will get the value for a specified meta C<$key>. This does not have the
+C<$default> overhead that C<meta()> does.
+
+=item $val = $obj->delete_meta($key)
+
+This will remove the value of a specified meta C<$key>. The old C<$val> will be
+returned.
+
+=item $obj->set_meta($key, $val)
+
+Set the value of a specified meta C<$key>.
+
+=back
+
+=head1 META-KEY RESTICTIONS
+
+Meta keys must be defined, and must be true when used as a boolean. Keys may
+not be references. You are free to stringify a reference C<"$ref"> for use as a
+key, but this package will not stringify it for you.
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut
--- /dev/null
+package Test2::Util::HashBase;
+use strict;
+use warnings;
+
+our $VERSION = '1.302015';
+
+
+require Carp;
+$Carp::Internal{+__PACKAGE__} = 1;
+
+my %ATTRS;
+my %META;
+
+sub _get_inherited_attrs {
+ no strict 'refs';
+ my @todo = map @{"$_\::ISA"}, @_;
+ my %seen;
+ my @all;
+ while (my $pkg = shift @todo) {
+ next if $seen{$pkg}++;
+ my $found = $META{$pkg};
+ push @all => %$found if $found;
+
+ my $isa = \@{"$pkg\::ISA"};
+ push @todo => @$isa if @$isa;
+ }
+
+ return \@all;
+}
+
+sub _make_subs {
+ my ($str) = @_;
+ return $ATTRS{$str} ||= {
+ uc($str) => sub() { $str },
+ $str => sub { $_[0]->{$str} },
+ "set_$str" => sub { $_[0]->{$str} = $_[1] },
+ };
+}
+
+sub import {
+ my $class = shift;
+ my $into = caller;
+
+ my %attrs = map %{_make_subs($_)}, @_;
+
+ my @meta = map uc, @_;
+ @{$META{$into}}{@meta} = map $attrs{$_}, @meta;
+
+ my %subs = (
+ %attrs,
+ @{_get_inherited_attrs($into)},
+ $into->can('new') ? () : (new => \&_new)
+ );
+
+ no strict 'refs';
+ *{"$into\::$_"} = $subs{$_} for keys %subs;
+}
+
+sub _new {
+ my ($class, %params) = @_;
+ my $self = bless \%params, $class;
+ $self->init if $self->can('init');
+ $self;
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2::Util::HashBase - Base class for classes that use a hashref
+of a hash.
+
+=head1 SYNOPSIS
+
+A class:
+
+ package My::Class;
+ use strict;
+ use warnings;
+
+ # Generate 3 accessors
+ use Test2::Util::HashBase qw/foo bar baz/;
+
+ # Chance to initialize defaults
+ sub init {
+ my $self = shift; # No other args
+ $self->{+FOO} ||= "foo";
+ $self->{+BAR} ||= "bar";
+ $self->{+BAZ} ||= "baz";
+ }
+
+ sub print {
+ print join ", " => map { $self->{$_} } FOO, BAR, BAZ;
+ }
+
+Subclass it
+
+ package My::Subclass;
+ use strict;
+ use warnings;
+
+ # Note, you should subclass before loading HashBase.
+ use base 'My::Class';
+ use Test2::Util::HashBase qw/bat/;
+
+ sub init {
+ my $self = shift;
+
+ # We get the constants from the base class for free.
+ $self->{+FOO} ||= 'SubFoo';
+ $self->{+BAT} || = 'bat';
+
+ $self->SUPER::init();
+ }
+
+use it:
+
+ package main;
+ use strict;
+ use warnings;
+ use My::Class;
+
+ my $one = My::Class->new(foo => 'MyFoo', bar => 'MyBar');
+
+ # Accessors!
+ my $foo = $one->foo; # 'MyFoo'
+ my $bar = $one->bar; # 'MyBar'
+ my $baz = $one->baz; # Defaulted to: 'baz'
+
+ # Setters!
+ $one->set_foo('A Foo');
+ $one->set_bar('A Bar');
+ $one->set_baz('A Baz');
+
+ $one->{+FOO} = 'xxx';
+
+=head1 DESCRIPTION
+
+This package is used to generate classes based on hashrefs. Using this class
+will give you a C<new()> method, as well as generating accessors you request.
+Generated accessors will be getters, C<set_ACCESSOR> setters will also be
+generated for you. You also get constants for each accessor (all caps) which
+return the key into the hash for that accessor. Single inheritence is also
+supported.
+
+=head1 METHODS
+
+=head2 PROVIDED BY HASH BASE
+
+=over 4
+
+=item $it = $class->new(@VALUES)
+
+Create a new instance using key/value pairs.
+
+HashBase will not export C<new()> if there is already a C<new()> method in your
+packages inheritence chain.
+
+B<If you do not want this method you can define your own> you just have to
+declare it before loading L<Test2::Util::HashBase>.
+
+ package My::Package;
+
+ # predeclare new() so that HashBase does not give us one.
+ sub new;
+
+ use Test2::Util::HashBase qw/foo bar baz/;
+
+ # Now we define our own new method.
+ sub new { ... }
+
+This makes it so that HashBase sees that you have your own C<new()> method.
+Alternatively you can define the method before loading HashBase instead of just
+declaring it, but that scatters your use statements.
+
+=back
+
+=head2 HOOKS
+
+=over 4
+
+=item $self->init()
+
+This gives you the chance to set some default values to your fields. The only
+argument is C<$self> with its indexes already set from the constructor.
+
+=back
+
+=head1 ACCESSORS
+
+To generate accessors you list them when using the module:
+
+ use Test2::Util::HashBase qw/foo/;
+
+This will generate the following subs in your namespace:
+
+=over 4
+
+=item foo()
+
+Getter, used to get the value of the C<foo> field.
+
+=item set_foo()
+
+Setter, used to set the value of the C<foo> field.
+
+=item FOO()
+
+Constant, returns the field C<foo>'s key into the class hashref. Subclasses will
+also get this function as a constant, not simply a method, that means it is
+copied into the subclass namespace.
+
+The main reason for using these constants is to help avoid spelling mistakes
+and similar typos. It will not help you if you forget to prefix the '+' though.
+
+=back
+
+=head1 SUBCLASSING
+
+You can subclass an existing HashBase class.
+
+ use base 'Another::HashBase::Class';
+ use Test2::Util::HashBase qw/foo bar baz/;
+
+The base class is added to C<@ISA> for you, and all constants from base classes
+are added to subclasses automatically.
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut
--- /dev/null
+package Test2::Util::Trace;
+use strict;
+use warnings;
+
+our $VERSION = '1.302015';
+
+
+use Test2::Util qw/get_tid/;
+
+use Carp qw/confess/;
+
+use Test2::Util::HashBase qw{frame detail pid tid};
+
+sub init {
+ confess "The 'frame' attribute is required"
+ unless $_[0]->{+FRAME};
+
+ $_[0]->{+PID} = $$ unless defined $_[0]->{+PID};
+ $_[0]->{+TID} = get_tid() unless defined $_[0]->{+TID};
+}
+
+sub snapshot { bless {%{$_[0]}}, __PACKAGE__ };
+
+sub debug {
+ my $self = shift;
+ return $self->{+DETAIL} if $self->{+DETAIL};
+ my ($pkg, $file, $line) = $self->call;
+ return "at $file line $line";
+}
+
+sub alert {
+ my $self = shift;
+ my ($msg) = @_;
+ warn $msg . ' ' . $self->debug . ".\n";
+}
+
+sub throw {
+ my $self = shift;
+ my ($msg) = @_;
+ die $msg . ' ' . $self->debug . ".\n";
+}
+
+sub call { @{$_[0]->{+FRAME}} }
+
+sub package { $_[0]->{+FRAME}->[0] }
+sub file { $_[0]->{+FRAME}->[1] }
+sub line { $_[0]->{+FRAME}->[2] }
+sub subname { $_[0]->{+FRAME}->[3] }
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2::Util::Trace - Debug information for events
+
+=head1 DESCRIPTION
+
+The L<Test2::API::Context> object, as well as all L<Test2::Event> types need to
+have access to information about where they were created. This object
+represents that information.
+
+=head1 SYNOPSIS
+
+ use Test2::Util::Trace;
+
+ my $trace = Test2::Util::Trace->new(
+ frame => [$package, $file, $line, $subname],
+ );
+
+=head1 METHODS
+
+=over 4
+
+=item $trace->set_detail($msg)
+
+=item $msg = $trace->detail
+
+Used to get/set a custom trace message that will be used INSTEAD of
+C<< at <FILE> line <LINE> >> when calling C<< $trace->debug >>.
+
+=item $str = $trace->debug
+
+Typically returns the string C<< at <FILE> line <LINE> >>. If C<detail> is set
+then its value wil be returned instead.
+
+=item $trace->alert($MESSAGE)
+
+This issues a warning at the frame (filename and line number where
+errors should be reported).
+
+=item $trace->throw($MESSAGE)
+
+This throws an exception at the frame (filename and line number where
+errors should be reported).
+
+=item $frame = $trace->frame()
+
+Get the call frame arrayref.
+
+=item ($package, $file, $line, $subname) = $trace->call()
+
+Get the caller details for the debug-info. This is where errors should be
+reported.
+
+=item $pkg = $trace->package
+
+Get the debug-info package.
+
+=item $file = $trace->file
+
+Get the debug-info filename.
+
+=item $line = $trace->line
+
+Get the debug-info line number.
+
+=item $subname = $trace->subname
+
+Get the debug-info subroutine name.
+
+=back
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut
package ok;
-$ok::VERSION = '0.16';
+$ok::VERSION = '1.302015';
use strict;
use Test::More ();
__END__
+=encoding UTF-8
+
=head1 NAME
ok - Alternative to Test::More::use_ok
--- /dev/null
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+chdir 't';
+
+use Test::More;
+
+my $Has_Test_Pod;
+BEGIN {
+ $Has_Test_Pod = eval 'use Test::Pod 0.95; 1';
+}
+
+chdir "..";
+my $manifest = "MANIFEST";
+open(my $manifest_fh, "<", $manifest) or plan(skip_all => "Can't open $manifest: $!");
+my @modules = map { m{^lib/(\S+)}; $1 }
+ grep { m{^lib/Test/\S*\.pm} }
+ grep { !m{/t/} } <$manifest_fh>;
+
+chomp @modules;
+close $manifest_fh;
+
+chdir 'lib';
+plan tests => scalar @modules * 2;
+foreach my $file (@modules) {
+ # Make sure we look at the local files and do not reload them if
+ # they're already loaded. This avoids recompilation warnings.
+ local @INC = @INC;
+ unshift @INC, ".";
+ ok eval { require($file); 1 } or diag "require $file failed.\n$@";
+
+ SKIP: {
+ skip "Test::Pod not installed", 1 unless $Has_Test_Pod;
+ pod_file_ok($file);
+ }
+}
+++ /dev/null
-#!perl -w
-use strict;
-use warnings;
-use IO::Pipe;
-use Test::Builder;
-use Config;
-
-my $b = Test::Builder->new;
-$b->reset;
-
-my $Can_Fork = $Config{d_fork} ||
- (($^O eq 'MSWin32' || $^O eq 'NetWare') and
- $Config{useithreads} and
- $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/
- );
-
-if( !$Can_Fork ) {
- $b->plan('skip_all' => "This system cannot fork");
-}
-else {
- $b->plan('tests' => 2);
-}
-
-my $pipe = IO::Pipe->new;
-if ( my $pid = fork ) {
- $pipe->reader;
- $b->ok((<$pipe> =~ /FROM CHILD: ok 1/), "ok 1 from child");
- $b->ok((<$pipe> =~ /FROM CHILD: 1\.\.1/), "1..1 from child");
- waitpid($pid, 0);
-}
-else {
- $pipe->writer;
- my $pipe_fd = $pipe->fileno;
- close STDOUT;
- open(STDOUT, ">&$pipe_fd");
- my $b = Test::Builder->new;
- $b->reset;
- $b->no_plan;
- $b->ok(1);
-}
-
-
-=pod
-#actual
-1..2
-ok 1
-1..1
-ok 1
-ok 2
-#expected
-1..2
-ok 1
-ok 2
-=cut
--- /dev/null
+use Test2::API qw/intercept/;
+use Test::More;
+
+my $TEST = Test::Builder->new();
+
+sub fake {
+ $TEST->use_numbers(0);
+ $TEST->no_ending(1);
+ $TEST->done_testing(1); # a computed number of tests from its deferred magic
+}
+
+my $events = intercept { fake() };
+is(@$events, 1, "only 1 event");
+is($events->[0]->max, 1, "Plan set to 1, not 0");
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test2::API qw/intercept/;
+
+my @warnings;
+
+intercept {
+ SKIP: {
+ local $SIG{__WARN__} = sub { @warnings = @_ };
+ skip 'Skipping this test' if 1;
+ my $var = 'abc';
+ is $var, 'abc';
+ }
+};
+
+ok(!@warnings, "did not warn when waiting for done_testing");
+
+intercept {
+ SKIP: {
+ local $SIG{__WARN__} = sub { @warnings = @_ };
+ plan 'no_plan';
+ skip 'Skipping this test' if 1;
+ my $var = 'abc';
+ is $var, 'abc';
+ }
+};
+
+ok(!@warnings, "did not warn with 'no_plan'");
+
+intercept {
+ SKIP: {
+ local $SIG{__WARN__} = sub { @warnings = @_ };
+ plan tests => 1;
+ skip 'Skipping this test' if 1;
+ my $var = 'abc';
+ is $var, 'abc';
+ }
+};
+
+is(@warnings, 1, "warned with static plan");
+like(
+ $warnings[0],
+ qr/skip\(\) needs to know \$how_many tests are in the block/,
+ "Got expected warning"
+);
+
+done_testing;
--- /dev/null
+#!perl -w
+use strict;
+use warnings;
+
+use Test2::Util qw/CAN_FORK/;
+BEGIN {
+ unless(CAN_FORK) {
+ require Test::More;
+ Test::More->import(skip_all => "fork is not supported");
+ }
+}
+
+use IO::Pipe;
+use Test::Builder;
+use Config;
+
+my $b = Test::Builder->new;
+$b->reset;
+
+$b->plan('tests' => 2);
+
+my $pipe = IO::Pipe->new;
+if ( my $pid = fork ) {
+ $pipe->reader;
+ my ($one, $two) = <$pipe>;
+ $b->like($one, qr/ok 1/, "ok 1 from child");
+ $b->like($two, qr/1\.\.1/, "1..1 from child");
+ waitpid($pid, 0);
+}
+else {
+ $pipe->writer;
+ $b->reset;
+ $b->no_plan;
+ $b->output($pipe);
+ $b->ok(1);
+ $b->done_testing;
+}
+
+
+=pod
+#actual
+1..2
+ok 1
+1..1
+ok 1
+ok 2
+#expected
+1..2
+ok 1
+ok 2
+=cut
--- /dev/null
+use strict;
+use warnings;
+
+BEGIN {
+ my $skip = !eval { require threads; 1 };
+ if ($skip) {
+ require Test::More;
+ Test::More::plan(skip_all => 'no threads');
+ }
+}
+
+use threads;
+use Test::More;
+
+ok 1 for (1 .. 2);
+
+# used to reset the counter after thread finishes
+my $ct_num = Test::More->builder->current_test;
+
+my $subtest_out = async {
+ my $out = '';
+
+ #simulate a subtest to not confuse the parent TAP emission
+ my $tb = Test::More->builder;
+ $tb->reset;
+ for (qw/output failure_output todo_output/) {
+ close $tb->$_;
+ open($tb->$_, '>', \$out);
+ }
+
+ ok 1 for (1 .. 3);
+
+ done_testing;
+
+ close $tb->$_ for (qw/output failure_output todo_output/);
+
+ $out;
+}
+->join;
+
+$subtest_out =~ s/^/ /gm;
+print $subtest_out;
+
+# reset as if the thread never "said" anything
+Test::More->builder->current_test($ct_num);
+
+ok 1 for (1 .. 4);
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test2::API qw/intercept/;
+
+my $res = intercept {
+ subtest foo => sub {
+ ok(1, "check");
+ };
+};
+
+is(@$res, 2, "2 results");
+
+isa_ok($res->[0], 'Test2::Event::Note');
+is($res->[0]->message, 'Subtest: foo', "got subtest note");
+
+isa_ok($res->[1], 'Test2::Event::Subtest');
+ok($res->[1]->pass, "subtest passed");
+
+my $subs = $res->[1]->subevents;
+is(@$subs, 2, "got all subevents");
+
+isa_ok($subs->[0], 'Test2::Event::Ok');
+is($subs->[0]->pass, 1, "subtest ok passed");
+is($subs->[0]->name, 'check', "subtest ok name");
+
+isa_ok($subs->[1], 'Test2::Event::Plan');
+is($subs->[1]->max, 1, "subtest plan is 1");
+
+done_testing;
use strict;
use warnings;
-use lib 't';
+use lib 't/lib';
use Test::Tester tests => 5;
*CORE::GLOBAL::exit = sub { $Exit_Code = shift; };
}
+# This test uses multiple builders, the real one is using the top hub, we need
+# to fix the ending.
+Test2::API::test2_stack()->top->set_no_ending(1);
use Test::Builder;
use Test::More;
use strict;
use warnings;
-use lib 't';
+use lib 't/lib';
use Test::Tester;
#!perl -w
+use strict;
+
+use Test2::Util qw/CAN_THREAD/;
+
+# Turn on threads here, if available, since this test tends to find
+# lots of threading bugs.
+BEGIN {
+ if (CAN_THREAD) {
+ require threads;
+ threads->import;
+ }
+}
BEGIN {
if( $ENV{PERL_CORE} ) {
}
}
-
-# Turn on threads here, if available, since this test tends to find
-# lots of threading bugs.
-use Config;
-BEGIN {
- if( $] >= 5.008001 && $Config{useithreads} ) {
- require threads;
- 'threads'->import;
- }
-}
-
-
-use strict;
-
use Test::Builder::NoOutput;
use Test::More tests => 7;
$TB->is_eq($?, 250, "exit code");
- exit grep { !$_ } $TB->summary;
+ $? = grep { !$_ } $TB->summary;
}
}
}
+use Carp qw/cluck/;
+
# Make sure this is in place before Test::More is loaded.
+my $started = 0;
my $handler_called;
BEGIN {
- $SIG{__DIE__} = sub { $handler_called++ };
+ $SIG{__DIE__} = sub { $handler_called++; cluck 'Died early!' unless $started };
}
use Test::More tests => 2;
+$started = 1;
ok !eval { die };
is $handler_called, 1, 'existing DIE handler not overridden';
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+
+$@ = 'foo';
+explain { 1 => 1 };
+is($@, 'foo', "preserved \$@");
+
+done_testing;
END {
# Test::More thinks it failed. Override that.
- exit(scalar grep { !$_ } $TB->summary);
+ $? = scalar grep { !$_ } $TB->summary;
}
--- /dev/null
+#!/usr/bin/perl -w
+use strict;
+use warnings;
+
+use Test2::Util qw/CAN_FORK/;
+BEGIN {
+ unless(CAN_FORK) {
+ require Test::More;
+ Test::More->import(skip_all => "fork is not supported");
+ }
+}
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
+}
+
+use Test::More;
+plan tests => 1;
+
+if( fork ) { # parent
+ pass("Only the parent should process the ending, not the child");
+}
+else {
+ exit; # child
+}
+
}
use strict;
-use Config;
-
+use Test2::Util qw/CAN_THREAD/;
BEGIN {
- unless ( $] >= 5.008001 && $Config{'useithreads'} &&
- eval { require threads; 'threads'->import; 1; })
- {
- print "1..0 # Skip no working threads\n";
- exit 0;
+ unless(CAN_THREAD) {
+ require Test::More;
+ Test::More->import(skip_all => "threads are not supported");
}
-
+}
+use threads;
+
+BEGIN {
unless ( $ENV{AUTHOR_TESTING} ) {
print "1..0 # Skip many perls have broken threads. Enable with AUTHOR_TESTING.\n";
exit 0;
$TB->is_eq($?, 255, "exit code");
- exit grep { !$_ } $TB->summary;
+ $? = grep { !$_ } $TB->summary;
}
#!perl -w
+use Test2::Util qw/CAN_THREAD/;
BEGIN {
if( $ENV{PERL_CORE} ) {
BEGIN {
# There was a bug with overloaded objects and threads.
# See rt.cpan.org 4218
- eval { require threads; 'threads'->import; 1; };
+ eval { require threads; 'threads'->import; 1; } if CAN_THREAD;
}
use Test::More tests => 5;
--- /dev/null
+#!/usr/bin/perl -w
+
+# Check that stray newlines in test output are properly handed.
+
+BEGIN {
+ print "1..0 # Skip not completed\n";
+ exit 0;
+}
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+chdir 't';
+
+use Test::Builder::NoOutput;
+my $tb = Test::Builder::NoOutput->create;
+
+$tb->ok(1, "name\n");
+$tb->ok(0, "foo\nbar\nbaz");
+$tb->skip("\nmoofer");
+$tb->todo_skip("foo\n\n");
$tb->ok( !eval { $tb->subtest("foo") } );
$tb->like( $@, qr/^\Qsubtest()'s second argument must be a code ref/ );
+my $foo;
$tb->subtest('Arg passing', sub {
- my $foo = shift;
- my $child = Test::Builder->new;
- $child->is_eq($foo, 'foo');
- $child->done_testing;
- $child->finalize;
+ $foo = shift;
+ $tb->ok(1);
}, 'foo');
+$tb->is_eq($foo, 'foo');
+
$tb->done_testing();
my $Exit_Code;
BEGIN {
- *CORE::GLOBAL::exit = sub { $Exit_Code = shift; };
+ *CORE::GLOBAL::exit = sub { $Exit_Code = shift; goto XXX};
}
use Test::Builder;
ok 'sub_baz';
};
+XXX:
+
$Test->is_eq( $output, <<'OUT' );
1..4
ok 1
- # Subtest: bar
+# Subtest: bar
1..3
ok 1
- # Subtest: sub_bar
+ # Subtest: sub_bar
1..3
ok 1
ok 2
OUT
$Test->is_eq( $Exit_Code, 255 );
+
+Test2::API::test2_stack()->top->set_no_ending(1);
use Test::Builder::NoOutput;
-use Test::More tests => 19;
+use Test::More tests => 12;
# Formatting may change if we're running under Test::Harness.
$ENV{HARNESS_ACTIVE} = 0;
my $tb = Test::Builder::NoOutput->create;
my $child = $tb->child('one');
can_ok $child, 'parent';
- is $child->parent, $tb, '... and it should return the parent of the child';
- ok !defined $tb->parent, '... but top level builders should not have parents';
can_ok $tb, 'name';
- is $tb->name, $0, 'The top level name should be $0';
is $child->name, 'one', '... but child names should be whatever we set them to';
$child->finalize;
$child = $tb->child;
- is $child->name, 'Child of '.$tb->name, '... or at least have a sensible default';
$child->finalize;
}
# Skip all subtests
{
my $child = $tb->child('skippy says he loves you');
eval { $child->plan( skip_all => 'cuz I said so' ) };
- ok my $error = $@, 'A child which does a "skip_all" should throw an exception';
- isa_ok $error, 'Test::Builder::Exception', '... and the exception it throws';
}
subtest 'skip all', sub {
plan skip_all => 'subtest with skip_all';
ok 0, 'This should never be run';
};
- is +Test::Builder->new->{Test_Results}[-1]{type}, 'skip',
- 'Subtests which "skip_all" are reported as skipped tests';
}
# to do tests
1..1
not ok 1 - No tests run for subtest "Child of $0"
END
- like $tb->read, qr/\Q$expected/,
+ like $tb->read, qr/\Q$expected\E/,
'Not running subtests should make the parent test fail';
}
pass("First");
-my $file = "t/subtest/for_do_t.test";
+my $file = "t/Legacy/subtest/for_do_t.test";
ok -e $file, "subtest test file exists";
subtest $file => sub { do $file };
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test2::API qw/intercept/;
+
+my $events = intercept {
+ subtest foo => sub {
+ ok(1, "pass");
+ };
+};
+
+my $st = $events->[-1];
+isa_ok($st, 'Test2::Event::Subtest');
+ok(my $id = $st->subtest_id, "got an id");
+for my $se (@{$st->subevents}) {
+ is($se->in_subtest, $id, "set subtest_id on child event");
+}
+
+done_testing;
#!/usr/bin/perl -w
use strict;
use warnings;
-use Config;
+
+use Test2::Util qw/CAN_FORK/;
+BEGIN {
+ unless(CAN_FORK) {
+ require Test::More;
+ Test::More->import(skip_all => "fork is not supported");
+ }
+}
+
use IO::Pipe;
use Test::Builder;
use Test::More;
-my $Can_Fork = $Config{d_fork} ||
- (($^O eq 'MSWin32' || $^O eq 'NetWare') and
- $Config{useithreads} and
- $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/
- );
-
-if( !$Can_Fork ) {
- plan 'skip_all' => "This system cannot fork";
-}
-else {
- plan 'tests' => 1;
-}
+plan 'tests' => 1;
subtest 'fork within subtest' => sub {
plan tests => 2;
# Force all T::B output into the pipe, for the parent
# builder as well as the current subtest builder.
- no warnings 'redefine';
- *Test::Builder::output = sub { $pipe };
- *Test::Builder::failure_output = sub { $pipe };
- *Test::Builder::todo_output = sub { $pipe };
-
+ my $tb = Test::Builder->new;
+ $tb->output($pipe);
+ $tb->failure_output($pipe);
+ $tb->todo_output($pipe);
+
diag 'Child Done';
exit 0;
}
our %line;
{
- test_out(" # Subtest: namehere");
+ test_out("# Subtest: namehere");
test_out(" 1..3");
test_out(" ok 1");
test_out(" not ok 2");
test_test("un-named inner tests");
}
{
- test_out(" # Subtest: namehere");
+ test_out("# Subtest: namehere");
test_out(" 1..3");
test_out(" ok 1 - first is good");
test_out(" not ok 2 - second is bad");
}; BEGIN{ $line{outerfail3} = __LINE__ }
}
{
- test_out(" # Subtest: namehere");
+ test_out("# Subtest: namehere");
test_out(" 1..3");
test_out(" ok 1 - first is good");
test_out(" not ok 2 - second is bad");
test_test("subtest() called from a sub");
}
{
- test_out( " # Subtest: namehere");
+ test_out( "# Subtest: namehere");
test_out( " 1..0");
test_err( " # No tests run!");
test_out( 'not ok 1 - No tests run for subtest "namehere"');
test_test("lineno in 'No tests run' diagnostic");
}
{
- test_out(" # Subtest: namehere");
+ test_out("# Subtest: namehere");
test_out(" 1..1");
test_out(" not ok 1 - foo is bar");
test_err(" # Failed test 'foo is bar'");
};
}
{
- test_out(" # Subtest: namehere");
+ test_out("# Subtest: namehere");
test_out(" 1..2");
test_out(" ok 1 - foo");
test_out(" not ok 2 - bar");
foobar_ok($value, $name);
}
{
- test_out(" # Subtest: namehere");
+ test_out("# Subtest: namehere");
test_out(" 1..2");
test_out(" ok 1 - foo");
test_out(" not ok 2 - bar");
});
}
{
- test_out(" # Subtest: namehere");
+ test_out("# Subtest: namehere");
test_out(" 1..2");
test_out(" ok 1 - foo");
test_out(" not ok 2 - bar");
barfoo_ok($value, $name);
}
{
- test_out(" # Subtest: namehere");
+ test_out("# Subtest: namehere");
test_out(" 1..2");
test_out(" ok 1 - foo");
test_out(" not ok 2 - bar");
# A subtest-based predicate called from within a subtest
{
- test_out(" # Subtest: outergroup");
+ test_out("# Subtest: outergroup");
test_out(" 1..2");
test_out(" ok 1 - this passes");
- test_out(" # Subtest: namehere");
+ test_out(" # Subtest: namehere");
test_out(" 1..2");
test_out(" ok 1 - foo");
test_out(" not ok 2 - bar");
use strict;
use warnings;
-use Config;
+use Test2::Util qw/CAN_THREAD/;
BEGIN {
- unless ( $] >= 5.008001 && $Config{'useithreads'} &&
- eval { require threads; 'threads'->import; 1; })
- {
- print "1..0 # Skip: no working threads\n";
- exit 0;
+ unless(CAN_THREAD) {
+ require Test::More;
+ Test::More->import(skip_all => "threads are not supported");
}
}
+use threads;
use Test::More;
#!/usr/bin/perl -w
-
# Test todo subtests.
#
# A subtest in a todo context should have all of its diagnostic output
foreach my $combo (@test_combos) {
my ($set_via, $todo_reason, $level) = @$combo;
- test_out(
- " # Subtest: xxx",
+ test_out( map { my $x = $_; $x =~ s/\s+$//g; $x }
+ "# Subtest: xxx",
@outlines,
"not ok 1 - $xxx # TODO $todo_reason",
"# Failed (TODO) test '$xxx'",
#!/usr/bin/perl -w
+use strict;
+use warnings;
+use Test2::Util qw/CAN_THREAD/;
BEGIN {
- if( $ENV{PERL_CORE} ) {
- chdir 't';
- @INC = '../lib';
+ unless(CAN_THREAD) {
+ require Test::More;
+ Test::More->import(skip_all => "threads are not supported");
}
}
+use threads;
-use Config;
BEGIN {
- unless ( $] >= 5.008001 && $Config{'useithreads'} &&
- eval { require threads; 'threads'->import; 1; })
- {
- print "1..0 # Skip: no working threads\n";
- exit 0;
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
}
}
eval {
$builder->todo_end;
};
-is $@, sprintf "todo_end() called without todo_start() at %s line %d.\n", $0, __LINE__ - 2;
+is $@, sprintf "todo_end() called without todo_start() at %s line %d.\n", $0, __LINE__ - 3;
{
for my $method (keys %handles) {
my $src = $handles{$method};
-
+
my $dest = Test::More->builder->$method;
-
+
is_deeply { map { $_ => 1 } PerlIO::get_layers($dest) },
{ map { $_ => 1 } PerlIO::get_layers($src) },
"layers copied to $method";
# Test utf8 is ok.
{
my $uni = "\x{11e}";
-
+
my @warnings;
local $SIG{__WARN__} = sub {
push @warnings, @_;
--- /dev/null
+use strict;
+use warnings;
+
+BEGIN { require "t/tools.pl" };
+use Test2::API qw/intercept/;
+
+plan 4;
+
+my @warnings;
+{
+ local $SIG{__WARN__} = sub { push @warnings => @_ };
+ require Test::Builder;
+};
+
+is(@warnings, 3, "got 3 warnings");
+
+like(
+ $warnings[0],
+ qr/Test::Builder was loaded after Test2 initialization, this is not recommended/,
+ "Warn about late Test::Builder load"
+);
+
+like(
+ $warnings[1],
+ qr/Formatter Test::Builder::Formatter loaded too late to be used as the global formatter/,
+ "Got the formatter warning"
+);
+
+like(
+ $warnings[2],
+ qr/The current formatter does not support 'no_header'/,
+ "Formatter does not support no_header",
+);
+
+
--- /dev/null
+use strict;
+use warnings;
+
+use Test2::API qw/context/;
+
+sub done_testing {
+ my $ctx = context();
+
+ die "Test Already ended!" if $ctx->hub->ended;
+ $ctx->hub->finalize($ctx->trace, 1);
+ $ctx->release;
+}
+
+sub ok($;$) {
+ my ($bool, $name) = @_;
+ my $ctx = context();
+ $ctx->ok($bool, $name);
+ $ctx->release;
+}
+
+ok(1, "First");
+ok(1, "Second");
+
+done_testing;
+
+1;
--- /dev/null
+use strict;
+use warnings;
+
+use Test2::Util qw/CAN_FORK/;
+use Test2::IPC;
+use Test2::API qw/context/;
+
+sub plan {
+ my $ctx = context();
+ $ctx->plan(@_);
+ $ctx->release;
+}
+
+sub ok($;$) {
+ my ($bool, $name) = @_;
+ my $ctx = context();
+ $ctx->ok($bool, $name);
+ $ctx->release;
+}
+
+plan(0, skip_all => 'System cannot fork') unless CAN_FORK();
+
+plan(6);
+
+for (1 .. 3) {
+ my $pid = fork;
+ die "Failed to fork" unless defined $pid;
+ next if $pid;
+ ok(1, "test 1 in pid $$");
+ ok(1, "test 2 in pid $$");
+ last;
+}
+
+1;
--- /dev/null
+use strict;
+use warnings;
+
+use Test2::API qw/context/;
+
+sub plan {
+ my $ctx = context();
+ $ctx->plan(@_);
+ $ctx->release;
+}
+
+sub ok($;$) {
+ my ($bool, $name) = @_;
+ my $ctx = context();
+ $ctx->ok($bool, $name);
+ $ctx->release;
+}
+
+plan(0, 'no_plan');
+
+ok(1, "First");
+ok(1, "Second");
+
+1;
--- /dev/null
+use strict;
+use warnings;
+
+use Test2::API qw/context/;
+
+sub plan {
+ my $ctx = context();
+ $ctx->plan(@_);
+ $ctx->release;
+}
+
+sub ok($;$) {
+ my ($bool, $name) = @_;
+ my $ctx = context();
+ $ctx->ok($bool, $name);
+ $ctx->release;
+}
+
+plan(2);
+
+ok(1, "First");
+ok(1, "Second");
+
+1;
--- /dev/null
+use strict;
+use warnings;
+
+use Test2::API qw/context/;
+
+sub plan {
+ my $ctx = context();
+ $ctx->plan(@_);
+ $ctx->release;
+}
+
+plan(0, skip_all => 'testing skip all');
+
+die "Should not see this";
+
+1;
--- /dev/null
+use strict;
+use warnings;
+
+use Test2::Util qw/CAN_THREAD/;
+use Test2::IPC;
+use Test2::API qw/context/;
+
+sub plan {
+ my $ctx = context();
+ $ctx->plan(@_);
+ $ctx->release;
+}
+
+sub ok($;$) {
+ my ($bool, $name) = @_;
+ my $ctx = context();
+ $ctx->ok($bool, $name);
+ $ctx->release;
+}
+
+plan(0, skip_all => 'System does not have threads') unless CAN_THREAD();
+
+plan(6);
+
+require threads;
+threads->import;
+
+for (1 .. 3) {
+ threads->create(sub {
+ ok(1, "test 1 in thread " . threads->tid());
+ ok(1, "test 2 in thread " . threads->tid());
+ });
+}
+
+1;
--- /dev/null
+use strict;
+use warnings;
+
+use Test2::API qw/context test2_stack/;
+
+sub done_testing {
+ my $ctx = context();
+
+ die "Test Already ended!" if $ctx->hub->ended;
+ $ctx->hub->finalize($ctx->trace, 1);
+ $ctx->release;
+}
+
+sub ok($;$) {
+ my ($bool, $name) = @_;
+ my $ctx = context();
+ $ctx->ok($bool, $name);
+ $ctx->release;
+}
+
+sub diag {
+ my $ctx = context();
+ $ctx->diag( join '', @_ );
+ $ctx->release;
+}
+
+ok(1, "First");
+
+my $filter = test2_stack->top->filter(sub {
+ my ($hub, $event) = @_;
+
+ # Turn a diag into a note
+ return Test2::Event::Note->new(%$event) if ref($event) eq 'Test2::Event::Diag';
+
+ # Set todo on ok's
+ if ($event->isa('Test2::Event::Ok')) {
+ $event->set_todo('here be dragons');
+ $event->set_effective_pass(1);
+ }
+
+ return $event;
+});
+
+ok(0, "Second");
+diag "should be a note";
+
+test2_stack->top->unfilter($filter);
+
+ok(1, "Third");
+diag "should be a diag";
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+BEGIN { require "t/tools.pl" };
+
+use Test2::API qw/run_subtest intercept test2_stack/;
+
+{
+ package Formatter::Hide;
+ sub write { }
+ sub hide_buffered { 1 };
+
+ package Formatter::Show;
+ sub write { }
+ sub hide_buffered { 0 };
+
+ package Formatter::NA;
+ sub write { }
+}
+
+my %HAS_FORMATTER;
+
+my $events = intercept {
+ my $code = sub {
+ my $hub = test2_stack->top;
+ $HAS_FORMATTER{unbuffered_none} = $hub->format ? 1 : 0;
+ };
+ run_subtest('unbuffered', $code);
+
+ $code = sub {
+ my $hub = test2_stack->top;
+ $HAS_FORMATTER{buffered_none} = $hub->format ? 1 : 0;
+ };
+ run_subtest('buffered', $code, 'BUFFERED');
+
+
+ #####################
+ test2_stack->top->format(bless {}, 'Formatter::Hide');
+ $code = sub {
+ my $hub = test2_stack->top;
+ $HAS_FORMATTER{unbuffered_hide} = $hub->format ? 1 : 0;
+ };
+ run_subtest('unbuffered', $code);
+
+ $code = sub {
+ my $hub = test2_stack->top;
+ $HAS_FORMATTER{buffered_hide} = $hub->format ? 1 : 0;
+ };
+ run_subtest('buffered', $code, 'BUFFERED');
+
+
+ #####################
+ test2_stack->top->format(bless {}, 'Formatter::Show');
+ $code = sub {
+ my $hub = test2_stack->top;
+ $HAS_FORMATTER{unbuffered_show} = $hub->format ? 1 : 0;
+ };
+ run_subtest('unbuffered', $code);
+
+ $code = sub {
+ my $hub = test2_stack->top;
+ $HAS_FORMATTER{buffered_show} = $hub->format ? 1 : 0;
+ };
+ run_subtest('buffered', $code, 'BUFFERED');
+
+
+ #####################
+ $code = sub {
+ my $hub = test2_stack->top;
+ $HAS_FORMATTER{unbuffered_na} = $hub->format ? 1 : 0;
+ };
+ run_subtest('unbuffered', $code);
+
+ test2_stack->top->format(bless {}, 'Formatter::NA');
+ $code = sub {
+ my $hub = test2_stack->top;
+ $HAS_FORMATTER{buffered_na} = $hub->format ? 1 : 0;
+ };
+ run_subtest('buffered', $code, 'BUFFERED');
+};
+
+ok(!$HAS_FORMATTER{unbuffered_none}, "Unbuffered with no parent formatter has no formatter");
+ok( $HAS_FORMATTER{unbuffered_show}, "Unbuffered where parent has 'show' formatter has formatter");
+ok( $HAS_FORMATTER{unbuffered_hide}, "Unbuffered where parent has 'hide' formatter has formatter");
+
+ok(!$HAS_FORMATTER{buffered_none}, "Buffered with no parent formatter has no formatter");
+ok( $HAS_FORMATTER{buffered_show}, "Buffered where parent has 'show' formatter has formatter");
+ok(!$HAS_FORMATTER{buffered_hide}, "Buffered where parent has 'hide' formatter has no formatter");
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+BEGIN { require "t/tools.pl" };
+
+use Test2::API qw/run_subtest intercept/;
+
+my $events = intercept {
+ my $code = sub { ok(1) };
+ run_subtest('blah', $code, 'buffered');
+};
+
+ok(!$events->[0]->in_subtest, "main event is not inside a subtest");
+ok($events->[0]->subtest_id, "Got subtest id");
+ok($events->[0]->subevents->[0]->in_subtest, "nested events are in the subtest");
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+BEGIN { require "t/tools.pl" };
+
+use Test2::API qw/run_subtest intercept/;
+
+my $events = intercept {
+ my $code = sub { plan 4; ok(1) };
+ run_subtest('bad_plan', $code, 'buffered');
+};
+
+is(
+ $events->[-1]->message,
+ "Bad subtest plan, expected 4 but ran 1",
+ "Helpful message if subtest has a bad plan",
+);
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl -T
+# HARNESS-NO-FORMATTER
+
+use Test2::API qw/context/;
+
+sub ok($;$@) {
+ my ($bool, $name) = @_;
+ my $ctx = context();
+ $ctx->ok($bool, $name);
+ $ctx->release;
+ return $bool ? 1 : 0;
+}
+
+sub done_testing {
+ my $ctx = context();
+ $ctx->hub->finalize($ctx->trace, 1);
+ $ctx->release;
+}
+
+ok(1);
+ok(1);
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test2::IPC;
+
+BEGIN { require "t/tools.pl" };
+
+{
+ local $! = 100;
+
+ is(0 + $!, 100, 'set $!');
+ is(0 + $!, 100, 'preserved $!');
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+BEGIN { require "t/tools.pl" };
+
+BEGIN {
+ package Foo::Bar;
+ use Test2::Util::HashBase qw/foo bar baz/;
+ use Carp qw/croak/;
+
+ sub init {
+ my $self = shift;
+ croak "'foo' is a required attribute"
+ unless $self->{+FOO};
+ }
+}
+
+$@ = "";
+my ($file, $line) = (__FILE__, __LINE__ + 1);
+eval { my $one = Foo::Bar->new };
+my $err = $@;
+
+like(
+ $err,
+ qr/^'foo' is a required attribute at \Q$file\E line $line/,
+ "Croak does not report to HashBase from init"
+);
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+BEGIN { $Test2::API::DO_DEPTH_CHECK = 1 }
+BEGIN { require "t/tools.pl" };
+
+use Test2::API qw/context/;
+
+sub outer {
+ my $code = shift;
+ my $ctx = context();
+
+ $ctx->note("outer");
+
+ my $out = eval { $code->() };
+
+ $ctx->release;
+
+ return $out;
+}
+
+sub dies {
+ my $ctx = context();
+ $ctx->note("dies");
+ die "Foo";
+}
+
+sub bad_store {
+ my $ctx = context();
+ $ctx->note("bad store");
+ return $ctx; # Emulate storing it somewhere
+}
+
+sub bad_simple {
+ my $ctx = context();
+ $ctx->note("bad simple");
+ return;
+}
+
+my @warnings;
+{
+ local $SIG{__WARN__} = sub { push @warnings => @_ };
+ eval { dies() };
+}
+ok(!@warnings, "no warnings") || diag @warnings;
+
+@warnings = ();
+my $keep = bad_store();
+eval { my $x = 1 }; # Ensure an eval changing $@ does not meddle.
+{
+ local $SIG{__WARN__} = sub { push @warnings => @_ };
+ ok(1, "random event");
+}
+ok(@warnings, "got warnings");
+like(
+ $warnings[0],
+ qr/context\(\) was called to retrieve an existing context/,
+ "got expected warning"
+);
+$keep = undef;
+
+{
+ @warnings = ();
+ local $SIG{__WARN__} = sub { push @warnings => @_ };
+ bad_simple();
+}
+ok(@warnings, "got warnings");
+like(
+ $warnings[0],
+ qr/A context appears to have been destroyed without first calling release/,
+ "got expected warning"
+);
+
+@warnings = ();
+outer(\&dies);
+{
+ local $SIG{__WARN__} = sub { push @warnings => @_ };
+ ok(1, "random event");
+}
+ok(!@warnings, "no warnings") || diag @warnings;
+
+
+
+@warnings = ();
+{
+ local $SIG{__WARN__} = sub { push @warnings => @_ };
+ outer(\&bad_store);
+}
+ok(@warnings, "got warnings");
+like(
+ $warnings[0],
+ qr/A context appears to have been destroyed without first calling release/,
+ "got expected warning"
+);
+
+
+
+{
+ @warnings = ();
+ local $SIG{__WARN__} = sub { push @warnings => @_ };
+ outer(\&bad_simple);
+}
+ok(@warnings, "got warnings") || diag @warnings;
+like(
+ $warnings[0],
+ qr/A context appears to have been destroyed without first calling release/,
+ "got expected warning"
+);
+
+
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+use Data::Dumper;
+
+###############################################################################
+# #
+# This test is to insure certain objects do not load Test2::API directly or #
+# indirectly when being required. It is ok for import() to load Test2::API if #
+# necessary, but simply requiring the modules should not. #
+# #
+###############################################################################
+
+require Test2::Formatter;
+require Test2::Formatter::TAP;
+
+require Test2::Event;
+require Test2::Event::Bail;
+require Test2::Event::Diag;
+require Test2::Event::Exception;
+require Test2::Event::Note;
+require Test2::Event::Ok;
+require Test2::Event::Plan;
+require Test2::Event::Skip;
+require Test2::Event::Subtest;
+require Test2::Event::Waiting;
+
+require Test2::Util;
+require Test2::Util::ExternalMeta;
+require Test2::Util::HashBase;
+require Test2::Util::Trace;
+
+require Test2::Hub;
+require Test2::Hub::Interceptor;
+require Test2::Hub::Subtest;
+require Test2::Hub::Interceptor::Terminator;
+
+my @loaded = grep { $INC{$_} } qw{
+ Test2/API.pm
+ Test2/API/Instance.pm
+ Test2/API/Context.pm
+ Test2/API/Stack.pm
+};
+
+require "t/tools.pl";
+
+ok(!@loaded, "Test2::API was not loaded")
+ || diag("Loaded: " . Dumper(\@loaded));
+
+done_testing();
--- /dev/null
+use strict;
+use warnings;
+# HARNESS-NO-FORMATTER
+
+BEGIN { require "t/tools.pl" };
+
+#########################
+#
+# This test us here to insure that Ok, Diag, and Note events render the way
+# Test::More renders them, trailing whitespace and all.
+#
+#########################
+
+use Test2::API qw/test2_stack/;
+
+sub capture(&) {
+ my $code = shift;
+
+ my ($err, $out) = ("", "");
+
+ my $handles = test2_stack->top->format->handles;
+ my ($ok, $e);
+ {
+ my ($out_fh, $err_fh);
+
+ ($ok, $e) = try {
+ open($out_fh, '>', \$out) or die "Failed to open a temporary STDOUT: $!";
+ open($err_fh, '>', \$err) or die "Failed to open a temporary STDERR: $!";
+
+ test2_stack->top->format->set_handles([$out_fh, $err_fh, $out_fh]);
+
+ $code->();
+ };
+ }
+ test2_stack->top->format->set_handles($handles);
+
+ die $e unless $ok;
+
+ $err =~ s/ $/_/mg;
+ $out =~ s/ $/_/mg;
+
+ return {
+ STDOUT => $out,
+ STDERR => $err,
+ };
+}
+
+# The tools in tools.pl have some intentional differences from the Test::More
+# versions, these behave more like Test::More which is important for
+# back-compat.
+sub tm_ok($;$) {
+ my ($bool, $name) = @_;
+ my $ctx = context;
+
+ $name && (
+ (index($name, "#" ) >= 0 && $name =~ s|#|\\#|g),
+ (index($name, "\n") >= 0 && $name =~ s{\n}{\n# }sg)
+ );
+
+ my $ok = bless {
+ pass => $bool,
+ name => $name,
+ effective_pass => 1,
+ trace => $ctx->trace->snapshot,
+ }, 'Test2::Event::Ok';
+ # Do not call init
+
+ $ctx->hub->send($ok);
+ $ctx->release;
+ return $bool;
+}
+
+# Test::More actually does a bit more, but for this test we just want to see
+# what happens when message is a specific string, or undef.
+sub tm_diag {
+ my $ctx = context();
+ $ctx->diag(@_);
+ $ctx->release;
+}
+
+sub tm_note {
+ my $ctx = context();
+ $ctx->note(@_);
+ $ctx->release;
+}
+
+# Ensure the top hub is generated
+test2_stack->top;
+
+my $temp_hub = test2_stack->new_hub();
+my $diag = capture {
+ tm_diag(undef);
+ tm_diag("");
+ tm_diag(" ");
+ tm_diag("A");
+ tm_diag("\n");
+ tm_diag("\nB");
+ tm_diag("C\n");
+ tm_diag("\nD\n");
+ tm_diag("E\n\n");
+};
+
+my $note = capture {
+ tm_note(undef);
+ tm_note("");
+ tm_note(" ");
+ tm_note("A");
+ tm_note("\n");
+ tm_note("\nB");
+ tm_note("C\n");
+ tm_note("\nD\n");
+ tm_note("E\n\n");
+};
+
+my $ok = capture {
+ tm_ok(1);
+ tm_ok(1, "");
+ tm_ok(1, " ");
+ tm_ok(1, "A");
+ tm_ok(1, "\n");
+ tm_ok(1, "\nB");
+ tm_ok(1, "C\n");
+ tm_ok(1, "\nD\n");
+ tm_ok(1, "E\n\n");
+};
+test2_stack->pop($temp_hub);
+
+is($diag->{STDOUT}, "", "STDOUT is empty for diag");
+is($diag->{STDERR}, <<EOT, "STDERR for diag looks right");
+# undef
+#_
+# _
+# A
+#_
+#_
+# B
+# C
+#_
+# D
+# E
+#_
+EOT
+
+
+is($note->{STDERR}, "", "STDERR for note is empty");
+is($note->{STDOUT}, <<EOT, "STDOUT looks right for note");
+# undef
+#_
+# _
+# A
+#_
+#_
+# B
+# C
+#_
+# D
+# E
+#_
+EOT
+
+
+is($ok->{STDERR}, "", "STDERR for ok is empty");
+is($ok->{STDOUT}, <<EOT, "STDOUT looks right for ok");
+ok 1
+ok 2 -_
+ok 3 - _
+ok 4 - A
+ok 5 -_
+#_
+ok 6 -_
+# B
+ok 7 - C
+#_
+ok 8 -_
+# D
+#_
+ok 9 - E
+#_
+#_
+EOT
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test2::API;
+
+my ($LOADED, $INIT);
+BEGIN {
+ $INIT = Test2::API::test2_init_done;
+ $LOADED = Test2::API::test2_load_done;
+};
+
+use Test2::IPC;
+BEGIN { require "t/tools.pl" };
+use Test2::Util qw/get_tid/;
+my $CLASS = 'Test2::API';
+
+# Ensure we do not break backcompat later by removing anything
+ok(Test2::API->can($_), "$_ method is present") for qw{
+ context_do
+ no_context
+
+ test2_init_done
+ test2_load_done
+
+ test2_pid
+ test2_tid
+ test2_stack
+ test2_no_wait
+
+ test2_add_callback_context_init
+ test2_add_callback_context_release
+ test2_add_callback_exit
+ test2_add_callback_post_load
+ test2_list_context_init_callbacks
+ test2_list_context_release_callbacks
+ test2_list_exit_callbacks
+ test2_list_post_load_callbacks
+
+ test2_ipc
+ test2_ipc_drivers
+ test2_ipc_add_driver
+ test2_ipc_polling
+ test2_ipc_disable_polling
+ test2_ipc_enable_polling
+
+ test2_formatter
+ test2_formatters
+ test2_formatter_add
+ test2_formatter_set
+};
+
+ok(!$LOADED, "Was not load_done right away");
+ok(!$INIT, "Init was not done right away");
+ok(Test2::API::test2_load_done, "We loaded it");
+
+# Note: This is a check that stuff happens in an END block.
+{
+ {
+ package FOLLOW;
+
+ sub DESTROY {
+ return if $_[0]->{fixed};
+ print "not ok - Did not run end ($_[0]->{name})!";
+ $? = 255;
+ exit 255;
+ }
+ }
+
+ our $kill1 = bless {fixed => 0, name => "Custom Hook"}, 'FOLLOW';
+ Test2::API::test2_add_callback_exit(
+ sub {
+ print "# Running END hook\n";
+ $kill1->{fixed} = 1;
+ }
+ );
+
+ our $kill2 = bless {fixed => 0, name => "set exit"}, 'FOLLOW';
+ my $old = Test2::API::Instance->can('set_exit');
+ no warnings 'redefine';
+ *Test2::API::Instance::set_exit = sub {
+ $kill2->{fixed} = 1;
+ print "# Running set_exit\n";
+ $old->(@_);
+ };
+}
+
+ok($CLASS->can('test2_init_done')->(), "init is done.");
+ok($CLASS->can('test2_load_done')->(), "Test2 is finished loading");
+
+is($CLASS->can('test2_pid')->(), $$, "got pid");
+is($CLASS->can('test2_tid')->(), get_tid(), "got tid");
+
+ok($CLASS->can('test2_stack')->(), 'got stack');
+is($CLASS->can('test2_stack')->(), $CLASS->can('test2_stack')->(), "always get the same stack");
+
+ok($CLASS->can('test2_ipc')->(), 'got ipc');
+is($CLASS->can('test2_ipc')->(), $CLASS->can('test2_ipc')->(), "always get the same IPC");
+
+is_deeply([$CLASS->can('test2_ipc_drivers')->()], [qw/Test2::IPC::Driver::Files/], "Got driver list");
+
+# Verify it reports to the correct file/line, there was some trouble with this...
+my $file = __FILE__;
+my $line = __LINE__ + 1;
+my $warnings = warnings { $CLASS->can('test2_ipc_add_driver')->('fake') };
+like(
+ $warnings->[0],
+ qr{^IPC driver fake loaded too late to be used as the global ipc driver at \Q$file\E line $line},
+ "got warning about adding driver too late"
+);
+
+is_deeply([$CLASS->can('test2_ipc_drivers')->()], [qw/fake Test2::IPC::Driver::Files/], "Got updated list");
+
+ok($CLASS->can('test2_ipc_polling')->(), "Polling is on");
+$CLASS->can('test2_ipc_disable_polling')->();
+ok(!$CLASS->can('test2_ipc_polling')->(), "Polling is off");
+$CLASS->can('test2_ipc_enable_polling')->();
+ok($CLASS->can('test2_ipc_polling')->(), "Polling is on");
+
+ok($CLASS->can('test2_formatter')->(), "Got a formatter");
+is($CLASS->can('test2_formatter')->(), $CLASS->can('test2_formatter')->(), "always get the same Formatter (class name)");
+
+my $ran = 0;
+$CLASS->can('test2_add_callback_post_load')->(sub { $ran++ });
+is($ran, 1, "ran the post-load");
+
+like(
+ exception { $CLASS->can('test2_formatter_set')->() },
+ qr/No formatter specified/,
+ "formatter_set requires an argument"
+);
+
+like(
+ exception { $CLASS->can('test2_formatter_set')->('fake') },
+ qr/Global Formatter already set/,
+ "formatter_set doesn't work after initialization",
+);
+
+ok(!$CLASS->can('test2_no_wait')->(), "no_wait is not set");
+$CLASS->can('test2_no_wait')->(1);
+ok($CLASS->can('test2_no_wait')->(), "no_wait is set");
+$CLASS->can('test2_no_wait')->(undef);
+ok(!$CLASS->can('test2_no_wait')->(), "no_wait is not set");
+
+my $pctx;
+sub tool_a($;$) {
+ Test2::API::context_do {
+ my $ctx = shift;
+ my ($bool, $name) = @_;
+ $pctx = wantarray;
+ die "xyz" unless $bool;
+ $ctx->ok($bool, $name);
+ return unless defined $pctx;
+ return (1, 2) if $pctx;
+ return 'a';
+ } @_;
+}
+
+$pctx = 'x';
+tool_a(1, "void context test");
+ok(!defined($pctx), "void context");
+
+my $x = tool_a(1, "scalar context test");
+ok(defined($pctx) && $pctx == 0, "scalar context");
+is($x, 'a', "got scalar return");
+
+my @x = tool_a(1, "array context test");
+ok($pctx, "array context");
+is_deeply(\@x, [1, 2], "Got array return");
+
+like(
+ exception { tool_a(0) },
+ qr/^xyz/,
+ "got exception"
+);
+
+sub {
+ my $outer = context();
+ sub {
+ my $middle = context();
+ is($outer->trace, $middle->trace, "got the same context before calling no_context");
+
+ Test2::API::no_context {
+ my $inner = context();
+ ok($inner->trace != $outer->trace, "Got a different context inside of no_context()");
+ $inner->release;
+ };
+
+ $middle->release;
+ }->();
+
+ $outer->release;
+}->();
+
+sub {
+ my $outer = context();
+ sub {
+ my $middle = context();
+ is($outer->trace, $middle->trace, "got the same context before calling no_context");
+
+ Test2::API::no_context {
+ my $inner = context();
+ ok($inner->trace != $outer->trace, "Got a different context inside of no_context({}, hid)");
+ $inner->release;
+ } $outer->hub->hid;
+
+ $middle->release;
+ }->();
+
+ $outer->release;
+}->();
+
+sub {
+ my @warnings;
+ my $outer = context();
+ sub {
+ my $middle = context();
+ is($outer->trace, $middle->trace, "got the same context before calling no_context");
+
+ local $SIG{__WARN__} = sub { push @warnings => @_ };
+ Test2::API::no_context {
+ my $inner = context();
+ ok($inner->trace != $outer->trace, "Got a different context inside of no_context({}, hid)");
+ } $outer->hub->hid;
+
+ $middle->release;
+ }->();
+
+ $outer->release;
+
+ is(@warnings, 1, "1 warning");
+ like(
+ $warnings[0],
+ qr/A context appears to have been destroyed without first calling release/,
+ "Got warning about unreleased context"
+ );
+}->();
+
+
+my $sub = sub { };
+
+Test2::API::test2_add_callback_context_acquire($sub);
+Test2::API::test2_add_callback_context_init($sub);
+Test2::API::test2_add_callback_context_release($sub);
+Test2::API::test2_add_callback_exit($sub);
+Test2::API::test2_add_callback_post_load($sub);
+
+is((grep { $_ == $sub } Test2::API::test2_list_context_acquire_callbacks()), 1, "got the one instance of the hook");
+is((grep { $_ == $sub } Test2::API::test2_list_context_init_callbacks()), 1, "got the one instance of the hook");
+is((grep { $_ == $sub } Test2::API::test2_list_context_release_callbacks()), 1, "got the one instance of the hook");
+is((grep { $_ == $sub } Test2::API::test2_list_exit_callbacks()), 1, "got the one instance of the hook");
+is((grep { $_ == $sub } Test2::API::test2_list_post_load_callbacks()), 1, "got the one instance of the hook");
+
+Test2::API::test2_add_callback_context_acquire($sub);
+Test2::API::test2_add_callback_context_init($sub);
+Test2::API::test2_add_callback_context_release($sub);
+Test2::API::test2_add_callback_exit($sub);
+Test2::API::test2_add_callback_post_load($sub);
+
+is((grep { $_ == $sub } Test2::API::test2_list_context_acquire_callbacks()), 2, "got the two instances of the hook");
+is((grep { $_ == $sub } Test2::API::test2_list_context_init_callbacks()), 2, "got the two instances of the hook");
+is((grep { $_ == $sub } Test2::API::test2_list_context_release_callbacks()), 2, "got the two instances of the hook");
+is((grep { $_ == $sub } Test2::API::test2_list_exit_callbacks()), 2, "got the two instances of the hook");
+is((grep { $_ == $sub } Test2::API::test2_list_post_load_callbacks()), 2, "got the two instances of the hook");
+
+done_testing;
+
--- /dev/null
+use strict;
+use warnings;
+
+use Test2::IPC;
+BEGIN { require "t/tools.pl" };
+use Test2::API::Breakage;
+my $CLASS = 'Test2::API::Breakage';
+
+for my $meth (qw/upgrade_suggested upgrade_required known_broken/) {
+ my @list = $CLASS->$meth;
+ ok(!(@list % 2), "Got even list ($meth)");
+ ok(!(grep {!defined($_)} @list), "No undefined items ($meth)");
+}
+
+{
+ no warnings 'redefine';
+ local *Test2::API::Breakage::upgrade_suggested = sub {
+ return ('T2Test::UG1' => '1.0', 'T2Test::UG2' => '0.5');
+ };
+
+ local *Test2::API::Breakage::upgrade_required = sub {
+ return ('T2Test::UR1' => '1.0', 'T2Test::UR2' => '0.5');
+ };
+
+ local *Test2::API::Breakage::known_broken = sub {
+ return ('T2Test::KB1' => '1.0', 'T2Test::KB2' => '0.5');
+ };
+ use warnings 'redefine';
+
+ ok(!$CLASS->report, "Nothing to report");
+ ok(!$CLASS->report(1), "Still nothing to report");
+
+ {
+ local %INC = (
+ %INC,
+ 'T2Test/UG1.pm' => 1,
+ 'T2Test/UG2.pm' => 1,
+ 'T2Test/UR1.pm' => 1,
+ 'T2Test/UR2.pm' => 1,
+ 'T2Test/KB1.pm' => 1,
+ 'T2Test/KB2.pm' => 1,
+ );
+ local $T2Test::UG1::VERSION = '0.9';
+ local $T2Test::UG2::VERSION = '0.9';
+ local $T2Test::UR1::VERSION = '0.9';
+ local $T2Test::UR2::VERSION = '0.9';
+ local $T2Test::KB1::VERSION = '0.9';
+ local $T2Test::KB2::VERSION = '0.9';
+
+ my @report = $CLASS->report;
+
+ is_deeply(
+ [sort @report],
+ [
+ sort
+ " * Module 'T2Test::UG1' is outdated, we recommed updating above 1.0.",
+ " * Module 'T2Test::UR1' is outdated and known to be broken, please update to 1.0 or higher.",
+ " * Module 'T2Test::KB1' is known to be broken in version 1.0 and below, newer versions have not been tested. You have: 0.9",
+ " * Module 'T2Test::KB2' is known to be broken in version 0.5 and below, newer versions have not been tested. You have: 0.9",
+ ],
+ "Got expected report items"
+ );
+ }
+
+ my %look;
+ unshift @INC => sub {
+ my ($this, $file) = @_;
+ $look{$file}++ if $file =~ m{T2Test};
+ return;
+ };
+ ok(!$CLASS->report, "Nothing to report");
+ is_deeply(\%look, {}, "Did not try to load anything");
+
+ ok(!$CLASS->report(1), "Nothing to report");
+ is_deeply(
+ \%look,
+ {
+ 'T2Test/UG1.pm' => 1,
+ 'T2Test/UG2.pm' => 1,
+ 'T2Test/UR1.pm' => 1,
+ 'T2Test/UR2.pm' => 1,
+ 'T2Test/KB1.pm' => 1,
+ 'T2Test/KB2.pm' => 1,
+ },
+ "Tried to load modules"
+ );
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+BEGIN { $Test2::API::DO_DEPTH_CHECK = 1 }
+BEGIN { require "t/tools.pl" };
+
+use Test2::API qw{
+ context intercept
+ test2_stack
+ test2_add_callback_context_acquire
+ test2_add_callback_context_init
+ test2_add_callback_context_release
+};
+
+my $error = exception { context(); 1 };
+my $exception = "context() called, but return value is ignored at " . __FILE__ . ' line ' . (__LINE__ - 1);
+like($error, qr/^\Q$exception\E/, "Got the exception" );
+
+my $ref;
+my $frame;
+sub wrap(&) {
+ my $ctx = context();
+ my ($pkg, $file, $line, $sub) = caller(0);
+ $frame = [$pkg, $file, $line, $sub];
+
+ $_[0]->($ctx);
+
+ $ref = "$ctx";
+
+ $ctx->release;
+}
+
+wrap {
+ my $ctx = shift;
+ ok($ctx->hub, "got hub");
+ delete $ctx->trace->frame->[4];
+ is_deeply($ctx->trace->frame, $frame, "Found place to report errors");
+};
+
+wrap {
+ my $ctx = shift;
+ ok("$ctx" ne "$ref", "Got a new context");
+ my $new = context();
+ my @caller = caller(0);
+ is_deeply(
+ $new,
+ {%$ctx, _is_canon => undef, _is_spawn => [@caller[0,1,2,3]]},
+ "Additional call to context gets spawn"
+ );
+ delete $ctx->trace->frame->[4];
+ is_deeply($ctx->trace->frame, $frame, "Found place to report errors");
+ $new->release;
+};
+
+wrap {
+ my $ctx = shift;
+ my $snap = $ctx->snapshot;
+
+ is_deeply(
+ $snap,
+ {%$ctx, _is_canon => undef, _is_spawn => undef, _aborted => undef},
+ "snapshot is identical except for canon/spawn/aborted"
+ );
+ ok($ctx != $snap, "snapshot is a new instance");
+};
+
+my $end_ctx;
+{ # Simulate an END block...
+ local *END = sub { local *__ANON__ = 'END'; context() };
+ my $ctx = END(); $frame = [ __PACKAGE__, __FILE__, __LINE__, 'main::END' ];
+ $end_ctx = $ctx->snapshot;
+ $ctx->release;
+}
+delete $end_ctx->trace->frame->[4];
+is_deeply( $end_ctx->trace->frame, $frame, 'context is ok in an end block');
+
+# Test event generation
+{
+ package My::Formatter;
+
+ sub write {
+ my $self = shift;
+ my ($e) = @_;
+ push @$self => $e;
+ }
+}
+my $events = bless [], 'My::Formatter';
+my $hub = Test2::Hub->new(
+ formatter => $events,
+);
+my $trace = Test2::Util::Trace->new(
+ frame => [ 'Foo::Bar', 'foo_bar.t', 42, 'Foo::Bar::baz' ],
+);
+my $ctx = Test2::API::Context->new(
+ trace => $trace,
+ hub => $hub,
+);
+
+my $e = $ctx->build_event('Ok', pass => 1, name => 'foo');
+is($e->pass, 1, "Pass");
+is($e->name, 'foo', "got name");
+is_deeply($e->trace, $trace, "Got the trace info");
+ok(!@$events, "No events yet");
+
+$e = $ctx->send_event('Ok', pass => 1, name => 'foo');
+is($e->pass, 1, "Pass");
+is($e->name, 'foo', "got name");
+is_deeply($e->trace, $trace, "Got the trace info");
+is(@$events, 1, "1 event");
+is_deeply($events, [$e], "Hub saw the event");
+pop @$events;
+
+$e = $ctx->ok(1, 'foo');
+is($e->pass, 1, "Pass");
+is($e->name, 'foo', "got name");
+is_deeply($e->trace, $trace, "Got the trace info");
+is(@$events, 1, "1 event");
+is_deeply($events, [$e], "Hub saw the event");
+pop @$events;
+
+$e = $ctx->note('foo');
+is($e->message, 'foo', "got message");
+is_deeply($e->trace, $trace, "Got the trace info");
+is(@$events, 1, "1 event");
+is_deeply($events, [$e], "Hub saw the event");
+pop @$events;
+
+$e = $ctx->diag('foo');
+is($e->message, 'foo', "got message");
+is_deeply($e->trace, $trace, "Got the trace info");
+is(@$events, 1, "1 event");
+is_deeply($events, [$e], "Hub saw the event");
+pop @$events;
+
+$e = $ctx->plan(100);
+is($e->max, 100, "got max");
+is_deeply($e->trace, $trace, "Got the trace info");
+is(@$events, 1, "1 event");
+is_deeply($events, [$e], "Hub saw the event");
+pop @$events;
+
+$e = $ctx->skip('foo', 'because');
+is($e->name, 'foo', "got name");
+is($e->reason, 'because', "got reason");
+ok($e->pass, "skip events pass by default");
+is_deeply($e->trace, $trace, "Got the trace info");
+is(@$events, 1, "1 event");
+is_deeply($events, [$e], "Hub saw the event");
+pop @$events;
+
+$e = $ctx->skip('foo', 'because', pass => 0);
+ok(!$e->pass, "can override skip params");
+pop @$events;
+
+# Test hooks
+
+my @hooks;
+$hub = test2_stack()->top;
+my $ref1 = $hub->add_context_init(sub { die "Bad Arg" unless ref($_[0]) eq 'Test2::API::Context'; push @hooks => 'hub_init' });
+my $ref2 = $hub->add_context_release(sub { die "Bad Arg" unless ref($_[0]) eq 'Test2::API::Context'; push @hooks => 'hub_release' });
+test2_add_callback_context_init(sub { die "Bad Arg" unless ref($_[0]) eq 'Test2::API::Context'; push @hooks => 'global_init' });
+test2_add_callback_context_release(sub { die "Bad Arg" unless ref($_[0]) eq 'Test2::API::Context'; push @hooks => 'global_release' });
+
+my $ref3 = $hub->add_context_acquire(sub { die "Bad Arg" unless ref($_[0]) eq 'HASH'; push @hooks => 'hub_acquire' });
+test2_add_callback_context_acquire(sub { die "Bad Arg" unless ref($_[0]) eq 'HASH'; push @hooks => 'global_acquire' });
+
+sub {
+ push @hooks => 'start';
+ my $ctx = context(on_init => sub { push @hooks => 'ctx_init' }, on_release => sub { push @hooks => 'ctx_release' });
+ push @hooks => 'deep';
+ my $ctx2 = sub {
+ context(on_init => sub { push @hooks => 'ctx_init_deep' }, on_release => sub { push @hooks => 'ctx_release_deep' });
+ }->();
+ push @hooks => 'release_deep';
+ $ctx2->release;
+ push @hooks => 'release_parent';
+ $ctx->release;
+ push @hooks => 'released_all';
+
+ push @hooks => 'new';
+ $ctx = context(on_init => sub { push @hooks => 'ctx_init2' }, on_release => sub { push @hooks => 'ctx_release2' });
+ push @hooks => 'release_new';
+ $ctx->release;
+ push @hooks => 'done';
+}->();
+
+$hub->remove_context_init($ref1);
+$hub->remove_context_release($ref2);
+$hub->remove_context_acquire($ref3);
+@{Test2::API::_context_init_callbacks_ref()} = ();
+@{Test2::API::_context_release_callbacks_ref()} = ();
+@{Test2::API::_context_acquire_callbacks_ref()} = ();
+
+is_deeply(
+ \@hooks,
+ [qw{
+ start
+ global_acquire
+ hub_acquire
+ global_init
+ hub_init
+ ctx_init
+ deep
+ global_acquire
+ hub_acquire
+ release_deep
+ release_parent
+ ctx_release_deep
+ ctx_release
+ hub_release
+ global_release
+ released_all
+ new
+ global_acquire
+ hub_acquire
+ global_init
+ hub_init
+ ctx_init2
+ release_new
+ ctx_release2
+ hub_release
+ global_release
+ done
+ }],
+ "Got all hook in correct order"
+);
+
+{
+ my $ctx = context(level => -1);
+
+ my $one = Test2::API::Context->new(
+ trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'blah']),
+ hub => test2_stack()->top,
+ );
+ is($one->_depth, 0, "default depth");
+
+ my $ran = 0;
+ my $doit = sub {
+ is_deeply(\@_, [qw/foo bar/], "got args");
+ $ran++;
+ die "Make sure old context is restored";
+ };
+
+ eval { $one->do_in_context($doit, 'foo', 'bar') };
+
+ my $spawn = context(level => -1, wrapped => -2);
+ is($spawn->trace, $ctx->trace, "Old context restored");
+ $spawn->release;
+ $ctx->release;
+
+ ok(!exception { $one->do_in_context(sub {1}) }, "do_in_context works without an original")
+}
+
+{
+ like(exception { Test2::API::Context->new() }, qr/The 'trace' attribute is required/, "need to have trace");
+
+ my $trace = Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'foo']);
+ like(exception { Test2::API::Context->new(trace => $trace) }, qr/The 'hub' attribute is required/, "need to have hub");
+
+ my $hub = test2_stack()->top;
+ my $ctx = Test2::API::Context->new(trace => $trace, hub => $hub);
+ is($ctx->{_depth}, 0, "depth set to 0 when not defined.");
+
+ $ctx = Test2::API::Context->new(trace => $trace, hub => $hub, _depth => 1);
+ is($ctx->{_depth}, 1, "Do not reset depth");
+
+ like(
+ exception { $ctx->release },
+ qr/release\(\) should not be called on context that is neither canon nor a child/,
+ "Non canonical context, do not release"
+ );
+}
+
+sub {
+ like(
+ exception { my $ctx = context(level => 20) },
+ qr/Could not find context at depth 21/,
+ "Level sanity"
+ );
+
+ ok(
+ !exception {
+ my $ctx = context(level => 20, fudge => 1);
+ $ctx->release;
+ },
+ "Was able to get context when fudging level"
+ );
+}->();
+
+sub {
+ my ($ctx1, $ctx2);
+ sub { $ctx1 = context() }->();
+
+ my @warnings;
+ {
+ local $SIG{__WARN__} = sub { push @warnings => @_ };
+ $ctx2 = context();
+ $ctx1 = undef;
+ }
+
+ $ctx2->release;
+
+ is(@warnings, 1, "1 warning");
+ like(
+ $warnings[0],
+ qr/^context\(\) was called to retrieve an existing context, however the existing/,
+ "Got expected warning"
+ );
+}->();
+
+sub {
+ my $ctx = context();
+ my $e = exception { $ctx->throw('xxx') };
+ like($e, qr/xxx/, "got exception");
+
+ $ctx = context();
+ my $warnings = warnings { $ctx->alert('xxx') };
+ like($warnings->[0], qr/xxx/, "got warning");
+ $ctx->release;
+}->();
+
+sub {
+ my $ctx = context;
+
+ is($ctx->_parse_event('Ok'), 'Test2::Event::Ok', "Got the Ok event class");
+ is($ctx->_parse_event('+Test2::Event::Ok'), 'Test2::Event::Ok', "Got the +Ok event class");
+
+ like(
+ exception { $ctx->_parse_event('+DFASGFSDFGSDGSD') },
+ qr/Could not load event module 'DFASGFSDFGSDGSD': Can't locate DFASGFSDFGSDGSD\.pm/,
+ "Bad event type"
+ );
+}->();
+
+{
+ my ($e1, $e2);
+ my $events = intercept {
+ my $ctx = context();
+ $e1 = $ctx->ok(0, 'foo', ['xxx']);
+ $e2 = $ctx->ok(0, 'foo');
+ $ctx->release;
+ };
+
+ ok($e1->isa('Test2::Event::Ok'), "returned ok event");
+ ok($e2->isa('Test2::Event::Ok'), "returned ok event");
+
+ is($events->[0], $e1, "got ok event 1");
+ is($events->[3], $e2, "got ok event 2");
+
+ is($events->[2]->message, 'xxx', "event 1 diag 2");
+}
+
+sub {
+ local $! = 100;
+ local $@ = 'foobarbaz';
+ local $? = 123;
+
+ my $ctx = context();
+
+ is($ctx->errno, 100, "saved errno");
+ is($ctx->eval_error, 'foobarbaz', "saved eval error");
+ is($ctx->child_error, 123, "saved child exit");
+
+ $! = 22;
+ $@ = 'xyz';
+ $? = 33;
+
+ is(0 + $!, 22, "altered \$! in tool");
+ is($@, 'xyz', "altered \$@ in tool");
+ is($?, 33, "altered \$? in tool");
+
+ sub {
+ my $ctx2 = context();
+
+ $! = 42;
+ $@ = 'app';
+ $? = 43;
+
+ is(0 + $!, 42, "altered \$! in tool (nested)");
+ is($@, 'app', "altered \$@ in tool (nested)");
+ is($?, 43, "altered \$? in tool (nested)");
+
+ $ctx2->release;
+
+ is(0 + $!, 22, "restored the nested \$! in tool");
+ is($@, 'xyz', "restored the nested \$@ in tool");
+ is($?, 33, "restored the nested \$? in tool");
+ }->();
+
+ sub {
+ my $ctx2 = context();
+
+ $! = 42;
+ $@ = 'app';
+ $? = 43;
+
+ is(0 + $!, 42, "altered \$! in tool (nested)");
+ is($@, 'app', "altered \$@ in tool (nested)");
+ is($?, 43, "altered \$? in tool (nested)");
+
+ # Will not warn since $@ is changed
+ $ctx2 = undef;
+
+ is(0 + $!, 42, 'Destroy does not reset $!');
+ is($@, 'app', 'Destroy does not reset $@');
+ is($?, 43, 'Destroy does not reset $?');
+ }->();
+
+ $ctx->release;
+
+ is($ctx->errno, 100, "restored errno");
+ is($ctx->eval_error, 'foobarbaz', "restored eval error");
+ is($ctx->child_error, 123, "restored child exit");
+}->();
+
+
+sub {
+ local $! = 100;
+ local $@ = 'foobarbaz';
+ local $? = 123;
+
+ my $ctx = context();
+
+ is($ctx->errno, 100, "saved errno");
+ is($ctx->eval_error, 'foobarbaz', "saved eval error");
+ is($ctx->child_error, 123, "saved child exit");
+
+ $! = 22;
+ $@ = 'xyz';
+ $? = 33;
+
+ is(0 + $!, 22, "altered \$! in tool");
+ is($@, 'xyz', "altered \$@ in tool");
+ is($?, 33, "altered \$? in tool");
+
+ # Will not warn since $@ is changed
+ $ctx = undef;
+
+ is(0 + $!, 22, "Destroy does not restore \$!");
+ is($@, 'xyz', "Destroy does not restore \$@");
+ is($?, 33, "Destroy does not restore \$?");
+}->();
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test2::IPC;
+BEGIN { require "t/tools.pl" };
+use Test2::Util qw/CAN_THREAD CAN_REALLY_FORK USE_THREADS get_tid/;
+
+my $CLASS = 'Test2::API::Instance';
+
+my $one = $CLASS->new;
+is_deeply(
+ $one,
+ {
+ pid => $$,
+ tid => get_tid(),
+ contexts => {},
+
+ finalized => undef,
+ ipc => undef,
+ formatter => undef,
+
+ ipc_polling => undef,
+ ipc_drivers => [],
+
+ formatters => [],
+
+ no_wait => 0,
+ loaded => 0,
+
+ exit_callbacks => [],
+ post_load_callbacks => [],
+ context_acquire_callbacks => [],
+ context_init_callbacks => [],
+ context_release_callbacks => [],
+
+ stack => [],
+ },
+ "Got initial settings"
+);
+
+%$one = ();
+is_deeply($one, {}, "wiped object");
+
+$one->reset;
+is_deeply(
+ $one,
+ {
+ pid => $$,
+ tid => get_tid(),
+ contexts => {},
+
+ ipc_polling => undef,
+ ipc_drivers => [],
+
+ formatters => [],
+
+ finalized => undef,
+ ipc => undef,
+ formatter => undef,
+
+ no_wait => 0,
+ loaded => 0,
+
+ exit_callbacks => [],
+ post_load_callbacks => [],
+ context_acquire_callbacks => [],
+ context_init_callbacks => [],
+ context_release_callbacks => [],
+
+ stack => [],
+ },
+ "Reset Object"
+);
+
+ok(!$one->formatter_set, "no formatter set");
+$one->set_formatter('Foo');
+ok($one->formatter_set, "formatter set");
+$one->reset;
+
+my $ran = 0;
+my $callback = sub { $ran++ };
+$one->add_post_load_callback($callback);
+ok(!$ran, "did not run yet");
+is_deeply($one->post_load_callbacks, [$callback], "stored callback for later");
+
+ok(!$one->loaded, "not loaded");
+$one->load;
+ok($one->loaded, "loaded");
+is($ran, 1, "ran the callback");
+
+$one->load;
+is($ran, 1, "Did not run the callback again");
+
+$one->add_post_load_callback($callback);
+is($ran, 2, "ran the new callback");
+is_deeply($one->post_load_callbacks, [$callback, $callback], "stored callback for the record");
+
+like(
+ exception { $one->add_post_load_callback({}) },
+ qr/Post-load callbacks must be coderefs/,
+ "Post-load callbacks must be coderefs"
+);
+
+$one->reset;
+ok($one->ipc, 'got ipc');
+ok($one->finalized, "calling ipc finalized the object");
+
+$one->reset;
+ok($one->stack, 'got stack');
+ok(!$one->finalized, "calling stack did not finaliz the object");
+
+$one->reset;
+ok($one->formatter, 'Got formatter');
+ok($one->finalized, "calling format finalized the object");
+
+$one->reset;
+$one->set_formatter('Foo');
+is($one->formatter, 'Foo', "got specified formatter");
+ok($one->finalized, "calling format finalized the object");
+
+{
+ local $ENV{T2_FORMATTER} = 'TAP';
+ $one->reset;
+ is($one->formatter, 'Test2::Formatter::TAP', "got specified formatter");
+ ok($one->finalized, "calling format finalized the object");
+
+ local $ENV{T2_FORMATTER} = '+Test2::Formatter::TAP';
+ $one->reset;
+ is($one->formatter, 'Test2::Formatter::TAP', "got specified formatter");
+ ok($one->finalized, "calling format finalized the object");
+
+ local $ENV{T2_FORMATTER} = '+Fake';
+ $one->reset;
+ like(
+ exception { $one->formatter },
+ qr/COULD NOT LOAD FORMATTER 'Fake' \(set by the 'T2_FORMATTER' environment variable\)/,
+ "Bad formatter"
+ );
+}
+
+$ran = 0;
+$one->reset;
+$one->add_exit_callback($callback);
+is(@{$one->exit_callbacks}, 1, "added an exit callback");
+$one->add_exit_callback($callback);
+is(@{$one->exit_callbacks}, 2, "added another exit callback");
+
+like(
+ exception { $one->add_exit_callback({}) },
+ qr/End callbacks must be coderefs/,
+ "Exit callbacks must be coderefs"
+);
+
+if (CAN_REALLY_FORK) {
+ $one->reset;
+ my $pid = fork;
+ die "Failed to fork!" unless defined $pid;
+ unless($pid) { exit 0 }
+
+ is($one->_ipc_wait, 0, "No errors");
+
+ $pid = fork;
+ die "Failed to fork!" unless defined $pid;
+ unless($pid) { exit 255 }
+ my @warnings;
+ {
+ local $SIG{__WARN__} = sub { push @warnings => @_ };
+ is($one->_ipc_wait, 255, "Process exited badly");
+ }
+ like($warnings[0], qr/Process .* did not exit cleanly \(status: 255\)/, "Warn about exit");
+}
+
+if (CAN_THREAD && $] ge '5.010') {
+ require threads;
+ $one->reset;
+
+ threads->new(sub { 1 });
+ is($one->_ipc_wait, 0, "No errors");
+
+ if (threads->can('error')) {
+ threads->new(sub {
+ close(STDERR);
+ close(STDOUT);
+ die "xxx"
+ });
+ my @warnings;
+ {
+ local $SIG{__WARN__} = sub { push @warnings => @_ };
+ is($one->_ipc_wait, 255, "Thread exited badly");
+ }
+ like($warnings[0], qr/Thread .* did not end cleanly: xxx/, "Warn about exit");
+ }
+}
+
+{
+ $one->reset();
+ local $? = 0;
+ $one->set_exit;
+ is($?, 0, "no errors on exit");
+}
+
+{
+ $one->reset();
+ $one->set_tid(1);
+ local $? = 0;
+ $one->set_exit;
+ is($?, 0, "no errors on exit");
+}
+
+{
+ $one->reset();
+ $one->stack->top;
+ $one->no_wait(1);
+ local $? = 0;
+ $one->set_exit;
+ is($?, 0, "no errors on exit");
+}
+
+{
+ $one->reset();
+ $one->stack->top->set_no_ending(1);
+ local $? = 0;
+ $one->set_exit;
+ is($?, 0, "no errors on exit");
+}
+
+{
+ $one->reset();
+ $one->stack->top->set_failed(2);
+ local $? = 0;
+ $one->set_exit;
+ is($?, 2, "number of failures");
+}
+
+{
+ $one->reset();
+ local $? = 500;
+ $one->set_exit;
+ is($?, 255, "set exit code to a sane number");
+}
+
+{
+ local %INC = %INC;
+ delete $INC{'Test2/IPC.pm'};
+ $one->reset();
+ my @events;
+ $one->stack->top->filter(sub { push @events => $_[1]; undef});
+ $one->stack->new_hub;
+ local $? = 0;
+ $one->set_exit;
+ is($?, 255, "errors on exit");
+ like($events[0]->message, qr/Test ended with extra hubs on the stack!/, "got diag");
+}
+
+{
+ $one->reset;
+ my $stderr = "";
+ {
+ local $INC{'Test/Builder.pm'} = __FILE__;
+ local $Test2::API::VERSION = '0.002';
+ local $Test::Builder::VERSION = '0.001';
+ local *STDERR;
+ open(STDERR, '>', \$stderr) or print "Failed to open new STDERR";
+
+ $one->set_exit;
+ }
+
+ is($stderr, <<' EOT', "Got warning about version mismatch");
+
+********************************************************************************
+* *
+* Test::Builder -- Test2::API version mismatch detected *
+* *
+********************************************************************************
+ Test2::API Version: 0.002
+Test::Builder Version: 0.001
+
+This is not a supported configuration, you will have problems.
+
+ EOT
+}
+
+{
+ require Test2::API::Breakage;
+ no warnings qw/redefine once/;
+ my $ran = 0;
+ local *Test2::API::Breakage::report = sub { $ran++; return "foo" };
+ use warnings qw/redefine once/;
+ $one->reset();
+
+ my $stderr = "";
+ {
+ local *STDERR;
+ open(STDERR, '>', \$stderr) or print "Failed to open new STDERR";
+ local $? = 255;
+ $one->set_exit;
+ }
+
+ is($stderr, <<" EOT", "Reported bad modules");
+
+You have loaded versions of test modules known to have problems with Test2.
+This could explain some test failures.
+foo
+
+ EOT
+}
+
+
+{
+ $one->reset();
+ my @events;
+ $one->stack->top->filter(sub { push @events => $_[1]; undef});
+ $one->stack->new_hub;
+ ok($one->stack->top->ipc, "Have IPC");
+ $one->stack->new_hub;
+ ok($one->stack->top->ipc, "Have IPC");
+ $one->stack->top->set_ipc(undef);
+ ok(!$one->stack->top->ipc, "no IPC");
+ $one->stack->new_hub;
+ local $? = 0;
+ $one->set_exit;
+ is($?, 255, "errors on exit");
+ like($events[0]->message, qr/Test ended with extra hubs on the stack!/, "got diag");
+}
+
+if (CAN_REALLY_FORK) {
+ local $SIG{__WARN__} = sub { };
+ $one->reset();
+ my $pid = fork;
+ die "Failed to fork!" unless defined $pid;
+ unless ($pid) { exit 255 }
+ $one->_finalize;
+ $one->stack->top;
+
+ local $? = 0;
+ $one->set_exit;
+ is($?, 255, "errors on exit");
+
+ $one->reset();
+ $pid = fork;
+ die "Failed to fork!" unless defined $pid;
+ unless ($pid) { exit 255 }
+ $one->_finalize;
+ $one->stack->top;
+
+ local $? = 122;
+ $one->set_exit;
+ is($?, 122, "kept original exit");
+}
+
+{
+ my $ctx = bless {
+ trace => Test2::Util::Trace->new(frame => ['Foo::Bar', 'Foo/Bar.pm', 42, 'xxx']),
+ hub => Test2::Hub->new(),
+ }, 'Test2::API::Context';
+ $one->contexts->{1234} = $ctx;
+
+ local $? = 500;
+ my $warnings = warnings { $one->set_exit };
+ is($?, 255, "set exit code to a sane number");
+
+ is_deeply(
+ $warnings,
+ [
+ "context object was never released! This means a testing tool is behaving very badly at Foo/Bar.pm line 42.\n"
+ ],
+ "Warned about unfreed context"
+ );
+}
+
+{
+ local %INC = %INC;
+ delete $INC{'Test2/IPC.pm'};
+ delete $INC{'threads.pm'};
+ ok(!USE_THREADS, "Sanity Check");
+
+ $one->reset;
+ ok(!$one->ipc, 'IPC not loaded, no IPC object');
+ ok($one->finalized, "calling ipc finalized the object");
+ is($one->ipc_polling, undef, "no polling defined");
+ ok(!@{$one->ipc_drivers}, "no driver");
+
+ if (CAN_THREAD) {
+ local $INC{'threads.pm'} = 1;
+ no warnings 'once';
+ local *threads::tid = sub { 0 } unless threads->can('tid');
+ $one->reset;
+ ok($one->ipc, 'IPC loaded if threads are');
+ ok($one->finalized, "calling ipc finalized the object");
+ ok($one->ipc_polling, "polling on by default");
+ is($one->ipc_drivers->[0], 'Test2::IPC::Driver::Files', "default driver");
+ }
+
+ {
+ local $INC{'Test2/IPC.pm'} = 1;
+ $one->reset;
+ ok($one->ipc, 'IPC loaded if Test2::IPC is');
+ ok($one->finalized, "calling ipc finalized the object");
+ ok($one->ipc_polling, "polling on by default");
+ is($one->ipc_drivers->[0], 'Test2::IPC::Driver::Files', "default driver");
+ }
+
+ require Test2::IPC::Driver::Files;
+ $one->reset;
+ $one->add_ipc_driver('Test2::IPC::Driver::Files');
+ ok($one->ipc, 'IPC loaded if drivers have been added');
+ ok($one->finalized, "calling ipc finalized the object");
+ ok($one->ipc_polling, "polling on by default");
+
+ my $file = __FILE__;
+ my $line = __LINE__ + 1;
+ my $warnings = warnings { $one->add_ipc_driver('Test2::IPC::Driver::Files') };
+ like(
+ $warnings->[0],
+ qr{^IPC driver Test2::IPC::Driver::Files loaded too late to be used as the global ipc driver at \Q$file\E line $line},
+ "Got warning at correct frame"
+ );
+
+ $one->reset;
+ $one->add_ipc_driver('Fake::Fake::XXX');
+ is(
+ exception { $one->ipc },
+ "IPC has been requested, but no viable drivers were found. Aborting...\n",
+ "Failed without viable IPC driver"
+ );
+}
+
+{
+ $one->reset;
+ ok(!@{$one->context_init_callbacks}, "no callbacks");
+ is($one->ipc_polling, undef, "no polling, undef");
+
+ $one->disable_ipc_polling;
+ ok(!@{$one->context_init_callbacks}, "no callbacks");
+ is($one->ipc_polling, undef, "no polling, still undef");
+
+ my $cull = 0;
+ no warnings 'once';
+ local *Fake::Hub::cull = sub { $cull++ };
+ use warnings;
+
+ $one->enable_ipc_polling;
+ is(@{$one->context_init_callbacks}, 1, "added the callback");
+ is($one->ipc_polling, 1, "polling on");
+ $one->set_ipc_shm_last('abc1');
+ $one->context_init_callbacks->[0]->({'hub' => 'Fake::Hub'});
+ is($cull, 1, "called cull once");
+ $cull = 0;
+
+ $one->disable_ipc_polling;
+ is(@{$one->context_init_callbacks}, 1, "kept the callback");
+ is($one->ipc_polling, 0, "no polling, set to 0");
+ $one->set_ipc_shm_last('abc3');
+ $one->context_init_callbacks->[0]->({'hub' => 'Fake::Hub'});
+ is($cull, 0, "did not call cull");
+ $cull = 0;
+
+ $one->enable_ipc_polling;
+ is(@{$one->context_init_callbacks}, 1, "did not add the callback");
+ is($one->ipc_polling, 1, "polling on");
+ $one->set_ipc_shm_last('abc3');
+ $one->context_init_callbacks->[0]->({'hub' => 'Fake::Hub'});
+ is($cull, 1, "called cull once");
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+use Test2::IPC;
+BEGIN { require "t/tools.pl" };
+use Test2::API::Stack;
+use Test2::API qw/test2_ipc/;
+
+ok(my $stack = Test2::API::Stack->new, "Create a stack");
+
+ok(!@$stack, "Empty stack");
+ok(!$stack->peek, "Nothing to peek at");
+
+ok(!exception { $stack->cull }, "cull lives when stack is empty");
+ok(!exception { $stack->all }, "all lives when stack is empty");
+ok(!exception { $stack->clear }, "clear lives when stack is empty");
+
+like(
+ exception { $stack->pop(Test2::Hub->new) },
+ qr/No hubs on the stack/,
+ "No hub to pop"
+);
+
+my $hub = Test2::Hub->new;
+ok($stack->push($hub), "pushed a hub");
+
+like(
+ exception { $stack->pop($hub) },
+ qr/You cannot pop the root hub/,
+ "Root hub cannot be popped"
+);
+
+$stack->push($hub);
+like(
+ exception { $stack->pop(Test2::Hub->new) },
+ qr/Hub stack mismatch, attempted to pop incorrect hub/,
+ "Must specify correct hub to pop"
+);
+
+is_deeply(
+ [ $stack->all ],
+ [ $hub, $hub ],
+ "Got all hubs"
+);
+
+ok(!exception { $stack->pop($hub) }, "Popped the correct hub");
+
+is_deeply(
+ [ $stack->all ],
+ [ $hub ],
+ "Got all hubs"
+);
+
+is($stack->peek, $hub, "got the hub");
+is($stack->top, $hub, "got the hub");
+
+$stack->clear;
+
+is_deeply(
+ [ $stack->all ],
+ [ ],
+ "no hubs"
+);
+
+ok(my $top = $stack->top, "Generated a top hub");
+is($top->ipc, test2_ipc, "Used sync's ipc");
+ok($top->format, 'Got formatter');
+
+is($stack->top, $stack->top, "do not generate a new top if there is already a top");
+
+ok(my $new = $stack->new_hub(), "Add a new hub");
+is($stack->top, $new, "new one is on top");
+is($new->ipc, $top->ipc, "inherited ipc");
+is($new->format, $top->format, "inherited formatter");
+
+my $new2 = $stack->new_hub(formatter => undef, ipc => undef);
+ok(!$new2->ipc, "built with no ipc");
+ok(!$new2->format, "built with no formatter");
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+BEGIN { require "t/tools.pl" };
+
+use Test2::Event();
+
+{
+ package My::MockEvent;
+
+ use base 'Test2::Event';
+ use Test2::Util::HashBase qw/foo bar baz/;
+}
+
+ok(My::MockEvent->can($_), "Added $_ accessor") for qw/foo bar baz/;
+
+my $one = My::MockEvent->new(trace => 'fake');
+
+ok(!$one->causes_fail, "Events do not cause failures by default");
+
+ok(!$one->$_, "$_ is false by default") for qw/increments_count terminate global/;
+
+ok(!$one->get_meta('xxx'), "no meta-data associated for key 'xxx'");
+
+$one->set_meta('xxx', '123');
+
+is($one->meta('xxx'), '123', "got meta-data");
+
+is($one->meta('xxx', '321'), '123', "did not use default");
+
+is($one->meta('yyy', '1221'), '1221', "got the default");
+
+is($one->meta('yyy'), '1221', "last call set the value to the default for future use");
+
+is($one->summary, 'My::MockEvent', "Default summary is event package");
+
+is($one->diagnostics, 0, "Not diagnostics by default");
+
+ok(!$one->in_subtest, "no subtest_id by default");
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+BEGIN { require "t/tools.pl" };
+use Test2::Event::Bail;
+
+my $bail = Test2::Event::Bail->new(
+ trace => 'fake',
+ reason => 'evil',
+);
+
+ok($bail->causes_fail, "bailout always causes fail.");
+
+is($bail->terminate, 255, "Bail will cause the test to exit.");
+is($bail->global, 1, "Bail is global, everything should bail");
+
+my $hub = Test2::Hub->new;
+ok($hub->is_passing, "passing");
+ok(!$hub->failed, "no failures");
+
+$bail->callback($hub);
+is($hub->bailed_out, $bail, "set bailed out");
+
+is($bail->summary, "Bail out! evil", "Summary includes reason");
+$bail->set_reason("");
+is($bail->summary, "Bail out!", "Summary has no reason");
+
+ok($bail->diagnostics, "Bail events are counted as diagnostics");
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+BEGIN { require "t/tools.pl" };
+use Test2::Event::Diag;
+use Test2::Util::Trace;
+
+my $diag = Test2::Event::Diag->new(
+ trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]),
+ message => 'foo',
+);
+
+is($diag->summary, 'foo', "summary is just message");
+
+$diag = Test2::Event::Diag->new(
+ trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]),
+ message => undef,
+);
+
+is($diag->message, 'undef', "set undef message to undef");
+is($diag->summary, 'undef', "summary is just message even when undef");
+
+$diag = Test2::Event::Diag->new(
+ trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]),
+ message => {},
+);
+
+like($diag->message, qr/^HASH\(.*\)$/, "stringified the input value");
+
+ok($diag->diagnostics, "Diag events are counted as diagnostics");
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+BEGIN { require "t/tools.pl" };
+use Test2::Event::Exception;
+
+my $exception = Test2::Event::Exception->new(
+ trace => 'fake',
+ error => "evil at lake_of_fire.t line 6\n",
+);
+
+ok($exception->causes_fail, "Exception events always cause failure");
+
+is($exception->summary, "Exception: evil at lake_of_fire.t line 6", "Got summary");
+
+ok($exception->diagnostics, "Exception events are counted as diagnostics");
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+BEGIN { require "t/tools.pl" };
+use Test2::Event::Note;
+use Test2::Util::Trace;
+
+my $note = Test2::Event::Note->new(
+ trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]),
+ message => 'foo',
+);
+
+is($note->summary, 'foo', "summary is just message");
+
+$note = Test2::Event::Note->new(
+ trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]),
+ message => undef,
+);
+
+is($note->message, 'undef', "set undef message to undef");
+is($note->summary, 'undef', "summary is just message even when undef");
+
+$note = Test2::Event::Note->new(
+ trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]),
+ message => {},
+);
+
+like($note->message, qr/^HASH\(.*\)$/, "stringified the input value");
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+BEGIN { require "t/tools.pl" };
+use Test2::Util::Trace;
+use Test2::Event::Ok;
+use Test2::Event::Diag;
+
+use Test2::API qw/context/;
+
+my $trace;
+sub before_each {
+ # Make sure there is a fresh trace object for each group
+ $trace = Test2::Util::Trace->new(
+ frame => ['main_foo', 'foo.t', 42, 'main_foo::flubnarb'],
+ );
+}
+
+tests Passing => sub {
+ my $ok = Test2::Event::Ok->new(
+ trace => $trace,
+ pass => 1,
+ name => 'the_test',
+ );
+ ok($ok->increments_count, "Bumps the count");
+ ok(!$ok->causes_fail, "Passing 'OK' event does not cause failure");
+ is($ok->pass, 1, "got pass");
+ is($ok->name, 'the_test', "got name");
+ is($ok->effective_pass, 1, "effective pass");
+ is($ok->summary, "the_test", "Summary is just the name of the test");
+
+ $ok = Test2::Event::Ok->new(
+ trace => $trace,
+ pass => 1,
+ name => '',
+ );
+ is($ok->summary, "Nameless Assertion", "Nameless test");
+
+};
+
+tests Failing => sub {
+ local $ENV{HARNESS_ACTIVE} = 1;
+ local $ENV{HARNESS_IS_VERBOSE} = 1;
+ my $ok = Test2::Event::Ok->new(
+ trace => $trace,
+ pass => 0,
+ name => 'the_test',
+ );
+ ok($ok->increments_count, "Bumps the count");
+ ok($ok->causes_fail, "A failing test causes failures");
+ is($ok->pass, 0, "got pass");
+ is($ok->name, 'the_test', "got name");
+ is($ok->effective_pass, 0, "effective pass");
+ is($ok->summary, "the_test", "Summary is just the name of the test");
+};
+
+tests "Failing TODO" => sub {
+ local $ENV{HARNESS_ACTIVE} = 1;
+ local $ENV{HARNESS_IS_VERBOSE} = 1;
+ my $ok = Test2::Event::Ok->new(
+ trace => $trace,
+ pass => 0,
+ name => 'the_test',
+ todo => 'A Todo',
+ );
+ ok($ok->increments_count, "Bumps the count");
+ is($ok->pass, 0, "got pass");
+ is($ok->name, 'the_test', "got name");
+ is($ok->effective_pass, 1, "effective pass is true from todo");
+ is($ok->summary, "the_test (TODO: A Todo)", "Summary is just the name of the test + todo");
+
+ $ok = Test2::Event::Ok->new(
+ trace => $trace,
+ pass => 0,
+ name => 'the_test2',
+ todo => '',
+ );
+ ok($ok->effective_pass, "empty string todo is still a todo");
+ is($ok->summary, "the_test2 (TODO)", "Summary is just the name of the test + todo");
+};
+
+tests init => sub {
+ like(
+ exception { Test2::Event::Ok->new(trace => $trace, pass => 1, name => "foo#foo") },
+ qr/'foo#foo' is not a valid name, names must not contain '#' or newlines/,
+ "Some characters do not belong in a name"
+ );
+
+ like(
+ exception { Test2::Event::Ok->new(trace => $trace, pass => 1, name => "foo\nfoo") },
+ qr/'foo\nfoo' is not a valid name, names must not contain '#' or newlines/,
+ "Some characters do not belong in a name"
+ );
+
+ my $ok = Test2::Event::Ok->new(
+ trace => $trace,
+ pass => 1,
+ );
+ is($ok->effective_pass, 1, "set effective pass");
+};
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+BEGIN { require "t/tools.pl" };
+use Test2::Event::Plan;
+use Test2::Util::Trace;
+
+my $plan = Test2::Event::Plan->new(
+ trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]),
+ max => 100,
+);
+
+is($plan->summary, "Plan is 100 assertions", "simple summary");
+is_deeply( [$plan->sets_plan], [100, '', undef], "Got plan details");
+
+ok(!$plan->global, "regular plan is not a global event");
+my $state = Test2::Hub->new;
+$plan->callback($state);
+is($state->plan, 100, "set plan in state");
+is($plan->terminate, undef, "No terminate for normal plan");
+
+$plan->set_max(0);
+$plan->set_directive('SKIP');
+$plan->set_reason('foo');
+$state = Test2::Hub->new;
+$plan->callback($state);
+is($state->plan, 'SKIP', "set plan in state");
+is($plan->terminate, 0, "Terminate 0 on skip_all");
+
+is($plan->summary, "Plan is 'SKIP', foo", "skip summary");
+is_deeply( [$plan->sets_plan], [0, 'SKIP', 'foo'], "Got skip details");
+
+$plan->set_max(0);
+$plan->set_directive('NO PLAN');
+$plan->set_reason(undef);
+is($plan->summary, "Plan is 'NO PLAN'", "NO PLAN summary");
+is_deeply( [$plan->sets_plan], [0, 'NO PLAN', undef], "Got 'NO PLAN' details");
+$state = Test2::Hub->new;
+$plan->callback($state);
+is($state->plan, 'NO PLAN', "set plan in state");
+is($plan->terminate, undef, "No terminate for no_plan");
+$plan->set_max(100);
+$plan->set_directive(undef);
+$plan->callback($state);
+is($state->plan, '100', "Update plan in state if it is 'NO PLAN'");
+
+$plan = Test2::Event::Plan->new(
+ trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]),
+ max => 0,
+ directive => 'skip_all',
+);
+is($plan->directive, 'SKIP', "Change skip_all to SKIP");
+
+$plan = Test2::Event::Plan->new(
+ trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]),
+ max => 0,
+ directive => 'no_plan',
+);
+is($plan->directive, 'NO PLAN', "Change no_plan to 'NO PLAN'");
+ok(!$plan->global, "NO PLAN is not global");
+
+like(
+ exception {
+ $plan = Test2::Event::Plan->new(
+ trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]),
+ max => 0,
+ directive => 'foo',
+ );
+ },
+ qr/'foo' is not a valid plan directive/,
+ "Invalid Directive"
+);
+
+like(
+ exception {
+ $plan = Test2::Event::Plan->new(
+ trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]),
+ max => 0,
+ reason => 'foo',
+ );
+ },
+ qr/Cannot have a reason without a directive!/,
+ "Reason without directive"
+);
+
+like(
+ exception {
+ $plan = Test2::Event::Plan->new(
+ trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]),
+ );
+ },
+ qr/No number of tests specified/,
+ "Nothing to do"
+);
+
+like(
+ exception {
+ $plan = Test2::Event::Plan->new(
+ trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]),
+ max => 'skip',
+ );
+ },
+ qr/Plan test count 'skip' does not appear to be a valid positive integer/,
+ "Max must be an integer"
+);
+
+done_testing;
--- /dev/null
+BEGIN { require "t/tools.pl" };
+use strict;
+use warnings;
+
+use Test2::Event::Skip;
+use Test2::Util::Trace;
+
+my $skip = Test2::Event::Skip->new(
+ trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]),
+ name => 'skip me',
+ reason => 'foo',
+);
+
+is($skip->name, 'skip me', "set name");
+is($skip->reason, 'foo', "got skip reason");
+ok(!$skip->pass, "no default for pass");
+ok($skip->effective_pass, "TODO always effectively passes");
+
+is($skip->summary, "skip me (SKIP: foo)", "summary with reason");
+
+$skip->set_reason('');
+is($skip->summary, "skip me (SKIP)", "summary without reason");
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+BEGIN { require "t/tools.pl" };
+use Test2::Event::Subtest;
+my $st = 'Test2::Event::Subtest';
+
+my $trace = Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'xxx']);
+my $one = $st->new(
+ trace => $trace,
+ pass => 1,
+ buffered => 1,
+ name => 'foo',
+ subtest_id => "1-1-1",
+);
+
+ok($one->isa('Test2::Event::Ok'), "Inherit from Ok");
+is_deeply($one->subevents, [], "subevents is an arrayref");
+
+is($one->summary, "foo", "simple summary");
+$one->set_todo('');
+is($one->summary, "foo (TODO)", "simple summary + TODO");
+$one->set_todo('foo');
+is($one->summary, "foo (TODO: foo)", "simple summary + TODO + Reason");
+
+$one->set_todo(undef);
+$one->set_name('');
+is($one->summary, "Nameless Subtest", "unnamed summary");
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+BEGIN { require "t/tools.pl" };
+use Test2::Event::Waiting;
+
+my $waiting = Test2::Event::Waiting->new(
+ trace => 'fake',
+);
+
+ok($waiting, "Created event");
+ok($waiting->global, "waiting is global");
+
+is($waiting->summary, "IPC is waiting for children to finish...", "Got summary");
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+use Test2::Formatter::TAP;
+use Test2::API qw/context/;
+use PerlIO;
+
+BEGIN {
+ require "t/tools.pl";
+ *OUT_STD = Test2::Formatter::TAP->can('OUT_STD') or die;
+ *OUT_ERR = Test2::Formatter::TAP->can('OUT_ERR') or die;
+}
+
+use Test2::API;
+Test2::API::test2_add_callback_context_release(sub {
+ my $ctx = shift;
+ return if $ctx->hub->is_passing;
+ $ctx->throw("(Die On Fail)");
+});
+
+ok(my $one = Test2::Formatter::TAP->new, "Created a new instance");
+my $handles = $one->handles;
+is(@$handles, 2, "Got 2 handles");
+ok($handles->[0] != $handles->[1], "First and second handles are not the same");
+my $layers = { map {$_ => 1} PerlIO::get_layers($handles->[0]) };
+
+if (${^UNICODE} & 2) { # 2 means STDIN
+ ok($layers->{utf8}, "'S' is set in PERL_UNICODE, or in -C, honor it, utf8 should be on")
+}
+else {
+ ok(!$layers->{utf8}, "Not utf8 by default")
+}
+
+$one->encoding('utf8');
+is($one->encoding, 'utf8', "Got encoding");
+$handles = $one->handles;
+is(@$handles, 2, "Got 2 handles");
+$layers = { map {$_ => 1} PerlIO::get_layers($handles->[0]) };
+ok($layers->{utf8}, "Now utf8");
+
+my $two = Test2::Formatter::TAP->new(encoding => 'utf8');
+$handles = $two->handles;
+is(@$handles, 2, "Got 2 handles");
+$layers = { map {$_ => 1} PerlIO::get_layers($handles->[0]) };
+ok($layers->{utf8}, "Now utf8");
+
+
+{
+ package My::Event;
+
+ use base 'Test2::Event';
+ use Test2::Util::HashBase qw{pass name diag note};
+
+ Test2::Formatter::TAP->register_event(
+ __PACKAGE__,
+ sub {
+ my $self = shift;
+ my ($e, $num) = @_;
+ return (
+ [main::OUT_STD, "ok $num - " . $e->name . "\n"],
+ [main::OUT_ERR, "# " . $e->name . " " . $e->diag . "\n"],
+ [main::OUT_STD, "# " . $e->name . " " . $e->note . "\n"],
+ );
+ }
+ );
+}
+
+my ($std, $err);
+open( my $stdh, '>', \$std ) || die "Ooops";
+open( my $errh, '>', \$err ) || die "Ooops";
+
+my $it = Test2::Formatter::TAP->new(
+ handles => [$stdh, $errh, $stdh],
+);
+
+$it->write(
+ My::Event->new(
+ pass => 1,
+ name => 'foo',
+ diag => 'diag',
+ note => 'note',
+ trace => 'fake',
+ ),
+ 55,
+);
+
+$it->write(
+ My::Event->new(
+ pass => 1,
+ name => 'bar',
+ diag => 'diag',
+ note => 'note',
+ trace => 'fake',
+ nested => 1,
+ ),
+ 1,
+);
+
+is($std, <<EOT, "Got expected TAP output to std");
+ok 55 - foo
+# foo note
+ ok 1 - bar
+ # bar note
+EOT
+
+is($err, <<EOT, "Got expected TAP output to err");
+# foo diag
+ # bar diag
+EOT
+
+$it = undef;
+close($stdh);
+close($errh);
+
+my ($trace, $ok, $diag, $plan, $bail);
+
+my $fmt = Test2::Formatter::TAP->new;
+sub before_each {
+ # Make sure there is a fresh trace object for each group
+ $trace = Test2::Util::Trace->new(
+ frame => ['main_foo', 'foo.t', 42, 'main_foo::flubnarb'],
+ );
+}
+
+tests bail => sub {
+ my $bail = Test2::Event::Bail->new(
+ trace => $trace,
+ reason => 'evil',
+ );
+
+ is_deeply(
+ [$fmt->event_tap($bail, 1)],
+ [[OUT_STD, "Bail out! evil\n" ]],
+ "Got tap"
+ );
+};
+
+tests diag => sub {
+ my $diag = Test2::Event::Diag->new(
+ trace => $trace,
+ message => 'foo',
+ );
+
+ is_deeply(
+ [$fmt->event_tap($diag, 1)],
+ [[OUT_ERR, "# foo\n"]],
+ "Got tap"
+ );
+
+ $diag->set_message("foo\n");
+ is_deeply(
+ [$fmt->event_tap($diag, 1)],
+ [[OUT_ERR, "# foo\n"]],
+ "Only 1 newline"
+ );
+
+ $diag->set_message("foo\nbar\nbaz");
+ is_deeply(
+ [$fmt->event_tap($diag, 1)],
+ [[OUT_ERR, "# foo\n# bar\n# baz\n"]],
+ "All lines have proper prefix"
+ );
+};
+
+tests exception => sub {
+ my $exception = Test2::Event::Exception->new(
+ trace => $trace,
+ error => "evil at lake_of_fire.t line 6\n",
+ );
+
+ is_deeply(
+ [$fmt->event_tap($exception, 1)],
+ [[OUT_ERR, "evil at lake_of_fire.t line 6\n" ]],
+ "Got tap"
+ );
+};
+
+tests note => sub {
+ my $note = Test2::Event::Note->new(
+ trace => $trace,
+ message => 'foo',
+ );
+
+ is_deeply(
+ [$fmt->event_tap($note, 1)],
+ [[OUT_STD, "# foo\n"]],
+ "Got tap"
+ );
+
+ $note->set_message("foo\n");
+ is_deeply(
+ [$fmt->event_tap($note, 1)],
+ [[OUT_STD, "# foo\n"]],
+ "Only 1 newline"
+ );
+
+ $note->set_message("foo\nbar\nbaz");
+ is_deeply(
+ [$fmt->event_tap($note, 1)],
+ [[OUT_STD, "# foo\n# bar\n# baz\n"]],
+ "All lines have proper prefix"
+ );
+};
+
+for my $pass (1, 0) {
+ local $ENV{HARNESS_IS_VERBOSE} = 1;
+ tests name_and_number => sub {
+ my $ok = Test2::Event::Ok->new(trace => $trace, pass => $pass, name => 'foo');
+ my @tap = $fmt->event_tap($ok, 7);
+ is_deeply(
+ \@tap,
+ [
+ [OUT_STD, ($pass ? 'ok' : 'not ok') . " 7 - foo\n"],
+ ],
+ "Got expected output"
+ );
+ };
+
+ tests no_number => sub {
+ my $ok = Test2::Event::Ok->new(trace => $trace, pass => $pass, name => 'foo');
+ my @tap = $fmt->event_tap($ok, );
+ is_deeply(
+ \@tap,
+ [
+ [OUT_STD, ($pass ? 'ok' : 'not ok') . " - foo\n"],
+ ],
+ "Got expected output"
+ );
+ };
+
+ tests no_name => sub {
+ my $ok = Test2::Event::Ok->new(trace => $trace, pass => $pass);
+ my @tap = $fmt->event_tap($ok, 7);
+ is_deeply(
+ \@tap,
+ [
+ [OUT_STD, ($pass ? 'ok' : 'not ok') . " 7\n"],
+ ],
+ "Got expected output"
+ );
+ };
+
+ tests todo => sub {
+ my $ok = Test2::Event::Ok->new(trace => $trace, pass => $pass);
+ $ok->set_todo('b');
+ my @tap = $fmt->event_tap($ok, 7);
+ is_deeply(
+ \@tap,
+ [
+ [OUT_STD, ($pass ? 'ok' : 'not ok') . " 7 # TODO b\n"],
+ ],
+ "Got expected output"
+ );
+
+ $ok->set_todo("");
+
+ @tap = $fmt->event_tap($ok, 7);
+ is_deeply(
+ \@tap,
+ [
+ [OUT_STD, ($pass ? 'ok' : 'not ok') . " 7 # TODO\n"],
+ ],
+ "Got expected output"
+ );
+ };
+};
+
+tests plan => sub {
+ my $plan = Test2::Event::Plan->new(
+ trace => $trace,
+ max => 100,
+ );
+
+ is_deeply(
+ [$fmt->event_tap($plan, 1)],
+ [[OUT_STD, "1..100\n"]],
+ "Got tap"
+ );
+
+ $plan->set_max(0);
+ $plan->set_directive('SKIP');
+ $plan->set_reason('foo');
+ is_deeply(
+ [$fmt->event_tap($plan, 1)],
+ [[OUT_STD, "1..0 # SKIP foo\n"]],
+ "Got tap for skip_all"
+ );
+
+ $plan = Test2::Event::Plan->new(
+ trace => $trace,
+ max => 0,
+ directive => 'skip_all',
+ );
+ is_deeply(
+ [$fmt->event_tap($plan)],
+ [[OUT_STD, "1..0 # SKIP\n"]],
+ "SKIP without reason"
+ );
+
+ $plan = Test2::Event::Plan->new(
+ trace => $trace,
+ max => 0,
+ directive => 'no_plan',
+ );
+ is_deeply(
+ [$fmt->event_tap($plan)],
+ [],
+ "NO PLAN"
+ );
+
+ $plan = Test2::Event::Plan->new(
+ trace => $trace,
+ max => 0,
+ directive => 'skip_all',
+ reason => "Foo\nBar\nBaz",
+ );
+ is_deeply(
+ [$fmt->event_tap($plan)],
+ [
+ [OUT_STD, "1..0 # SKIP Foo\n# Bar\n# Baz\n"],
+ ],
+ "Multi-line reason for skip"
+ );
+};
+
+tests subtest => sub {
+ my $st = 'Test2::Event::Subtest';
+
+ my $one = $st->new(
+ trace => $trace,
+ pass => 1,
+ buffered => 1,
+ name => 'foo',
+ subtest_id => '1-1-1',
+ );
+
+ is_deeply(
+ [$fmt->event_tap($one, 5)],
+ [
+ [OUT_STD, "ok 5 - foo {\n"],
+ [OUT_STD, "}\n"],
+ ],
+ "Got Buffered TAP output"
+ );
+
+ $one->set_buffered(0);
+ is_deeply(
+ [$fmt->event_tap($one, 5)],
+ [
+ [OUT_STD, "ok 5 - foo\n"],
+ ],
+ "Got Unbuffered TAP output"
+ );
+
+ $one = $st->new(
+ trace => $trace,
+ pass => 0,
+ buffered => 1,
+ name => 'bar',
+ subtest_id => '1-1-1',
+ subevents => [
+ Test2::Event::Ok->new(trace => $trace, name => 'first', pass => 1),
+ Test2::Event::Ok->new(trace => $trace, name => 'second', pass => 0),
+ Test2::Event::Ok->new(trace => $trace, name => 'third', pass => 1),
+
+ Test2::Event::Diag->new(trace => $trace, message => 'blah blah'),
+
+ Test2::Event::Plan->new(trace => $trace, max => 3),
+ ],
+ );
+
+ {
+ local $ENV{HARNESS_IS_VERBOSE};
+ is_deeply(
+ [$fmt->event_tap($one, 5)],
+ [
+ [OUT_STD, "not ok 5 - bar {\n"],
+ [OUT_STD, " ok 1 - first\n"],
+ [OUT_STD, " not ok 2 - second\n"],
+ [OUT_STD, " ok 3 - third\n"],
+ [OUT_ERR, " # blah blah\n"],
+ [OUT_STD, " 1..3\n"],
+ [OUT_STD, "}\n"],
+ ],
+ "Got Buffered TAP output (non-verbose)"
+ );
+ }
+
+ {
+ local $ENV{HARNESS_IS_VERBOSE} = 1;
+ is_deeply(
+ [$fmt->event_tap($one, 5)],
+ [
+ [OUT_STD, "not ok 5 - bar {\n"],
+ [OUT_STD, " ok 1 - first\n"],
+ [OUT_STD, " not ok 2 - second\n"],
+ [OUT_STD, " ok 3 - third\n"],
+ [OUT_ERR, " # blah blah\n"],
+ [OUT_STD, " 1..3\n"],
+ [OUT_STD, "}\n"],
+ ],
+ "Got Buffered TAP output (verbose)"
+ );
+ }
+
+ {
+ local $ENV{HARNESS_IS_VERBOSE};
+ $one->set_buffered(0);
+ is_deeply(
+ [$fmt->event_tap($one, 5)],
+ [
+ # In unbuffered TAP the subevents are rendered outside of this.
+ [OUT_STD, "not ok 5 - bar\n"],
+ ],
+ "Got Unbuffered TAP output (non-verbose)"
+ );
+ }
+
+ {
+ local $ENV{HARNESS_IS_VERBOSE} = 1;
+ $one->set_buffered(0);
+ is_deeply(
+ [$fmt->event_tap($one, 5)],
+ [
+ # In unbuffered TAP the subevents are rendered outside of this.
+ [OUT_STD, "not ok 5 - bar\n"],
+ ],
+ "Got Unbuffered TAP output (verbose)"
+ );
+ }
+};
+
+tests skip => sub {
+ my $skip = Test2::Event::Skip->new(trace => $trace, pass => 1, name => 'foo', reason => 'xxx');
+ my @tap = $fmt->event_tap($skip, 7);
+ is_deeply(
+ \@tap,
+ [
+ [OUT_STD, "ok 7 - foo # skip xxx\n"],
+ ],
+ "Passing Skip"
+ );
+
+ $skip->set_pass(0);
+ @tap = $fmt->event_tap($skip, 7);
+ is_deeply(
+ \@tap,
+ [
+ [OUT_STD, "not ok 7 - foo # skip xxx\n"],
+ ],
+ "Failling Skip"
+ );
+
+ $skip->set_todo("xxx");
+ @tap = $fmt->event_tap($skip, 7);
+ is_deeply(
+ \@tap,
+ [
+ [OUT_STD, "not ok 7 - foo # TODO & SKIP xxx\n"],
+ ],
+ "Todo Skip"
+ );
+};
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test2::IPC;
+BEGIN { require "t/tools.pl" };
+use Test2::API qw/context test2_ipc_drivers/;
+use Test2::Util qw/CAN_FORK CAN_THREAD CAN_REALLY_FORK/;
+
+{
+ package My::Formatter;
+
+ sub new { bless [], shift };
+
+ my $check = 1;
+ sub write {
+ my $self = shift;
+ my ($e, $count) = @_;
+ push @$self => $e;
+ }
+}
+
+{
+ package My::Event;
+
+ use base 'Test2::Event';
+ use Test2::Util::HashBase qw{msg};
+}
+
+tests basic => sub {
+ my $hub = Test2::Hub->new(
+ formatter => My::Formatter->new,
+ );
+
+ my $send_event = sub {
+ my ($msg) = @_;
+ my $e = My::Event->new(msg => $msg, trace => 'fake');
+ $hub->send($e);
+ };
+
+ ok(my $e1 = $send_event->('foo'), "Created event");
+ ok(my $e2 = $send_event->('bar'), "Created event");
+ ok(my $e3 = $send_event->('baz'), "Created event");
+
+ my $old = $hub->format(My::Formatter->new);
+
+ ok($old->isa('My::Formatter'), "old formatter");
+ is_deeply(
+ $old,
+ [$e1, $e2, $e3],
+ "Formatter got all events"
+ );
+};
+
+tests follow_ups => sub {
+ my $hub = Test2::Hub->new;
+ $hub->set_count(1);
+
+ my $trace = Test2::Util::Trace->new(
+ frame => [__PACKAGE__, __FILE__, __LINE__],
+ );
+
+ my $ran = 0;
+ $hub->follow_up(sub {
+ my ($d, $h) = @_;
+ is_deeply($d, $trace, "Got trace");
+ is_deeply($h, $hub, "Got hub");
+ ok(!$hub->ended, "Hub state has not ended yet");
+ $ran++;
+ });
+
+ like(
+ exception { $hub->follow_up('xxx') },
+ qr/follow_up only takes coderefs for arguments, got 'xxx'/,
+ "follow_up takes a coderef"
+ );
+
+ $hub->finalize($trace);
+
+ is($ran, 1, "ran once");
+
+ is_deeply(
+ $hub->ended,
+ $trace->frame,
+ "Ended at the expected place."
+ );
+
+ eval { $hub->finalize($trace) };
+
+ is($ran, 1, "ran once");
+
+ $hub = undef;
+};
+
+tests IPC => sub {
+ my ($driver) = test2_ipc_drivers();
+ is($driver, 'Test2::IPC::Driver::Files', "Default Driver");
+ my $ipc = $driver->new;
+ my $hub = Test2::Hub->new(
+ formatter => My::Formatter->new,
+ ipc => $ipc,
+ );
+
+ my $build_event = sub {
+ my ($msg) = @_;
+ return My::Event->new(msg => $msg, trace => 'fake');
+ };
+
+ my $e1 = $build_event->('foo');
+ my $e2 = $build_event->('bar');
+ my $e3 = $build_event->('baz');
+
+ my $do_send = sub {
+ $hub->send($e1);
+ $hub->send($e2);
+ $hub->send($e3);
+ };
+
+ my $do_check = sub {
+ my $name = shift;
+
+ my $old = $hub->format(My::Formatter->new);
+
+ ok($old->isa('My::Formatter'), "old formatter");
+ is_deeply(
+ $old,
+ [$e1, $e2, $e3],
+ "Formatter got all events ($name)"
+ );
+ };
+
+ if (CAN_REALLY_FORK) {
+ my $pid = fork();
+ die "Could not fork!" unless defined $pid;
+
+ if ($pid) {
+ is(waitpid($pid, 0), $pid, "waited properly");
+ ok(!$?, "child exited with success");
+ $hub->cull();
+ $do_check->('Fork');
+ }
+ else {
+ $do_send->();
+ exit 0;
+ }
+ }
+
+ if (CAN_THREAD && $] ge '5.010') {
+ require threads;
+ my $thr = threads->new(sub { $do_send->() });
+ $thr->join;
+ $hub->cull();
+ $do_check->('Threads');
+ }
+
+ $do_send->();
+ $hub->cull();
+ $do_check->('no IPC');
+};
+
+tests listen => sub {
+ my $hub = Test2::Hub->new();
+
+ my @events;
+ my @counts;
+ my $it = $hub->listen(sub {
+ my ($h, $e, $count) = @_;
+ is_deeply($h, $hub, "got hub");
+ push @events => $e;
+ push @counts => $count;
+ });
+
+ my $second;
+ my $it2 = $hub->listen(sub { $second++ });
+
+ my $ok1 = Test2::Event::Ok->new(
+ pass => 1,
+ name => 'foo',
+ trace => Test2::Util::Trace->new(
+ frame => [ __PACKAGE__, __FILE__, __LINE__ ],
+ ),
+ );
+
+ my $ok2 = Test2::Event::Ok->new(
+ pass => 0,
+ name => 'bar',
+ trace => Test2::Util::Trace->new(
+ frame => [ __PACKAGE__, __FILE__, __LINE__ ],
+ ),
+ );
+
+ my $ok3 = Test2::Event::Ok->new(
+ pass => 1,
+ name => 'baz',
+ trace => Test2::Util::Trace->new(
+ frame => [ __PACKAGE__, __FILE__, __LINE__ ],
+ ),
+ );
+
+ $hub->send($ok1);
+ $hub->send($ok2);
+
+ $hub->unlisten($it);
+
+ $hub->send($ok3);
+
+ is_deeply(\@counts, [1, 2], "Got counts");
+ is_deeply(\@events, [$ok1, $ok2], "got events");
+ is($second, 3, "got all events in listener that was not removed");
+
+ like(
+ exception { $hub->listen('xxx') },
+ qr/listen only takes coderefs for arguments, got 'xxx'/,
+ "listen takes a coderef"
+ );
+};
+
+tests metadata => sub {
+ my $hub = Test2::Hub->new();
+
+ my $default = { foo => 1 };
+ my $meta = $hub->meta('Foo', $default);
+ is_deeply($meta, $default, "Set Meta");
+
+ $meta = $hub->meta('Foo', {});
+ is_deeply($meta, $default, "Same Meta");
+
+ $hub->delete_meta('Foo');
+ is($hub->meta('Foo'), undef, "No Meta");
+
+ $hub->meta('Foo', {})->{xxx} = 1;
+ is($hub->meta('Foo')->{xxx}, 1, "Vivified meta and set it");
+
+ like(
+ exception { $hub->meta(undef) },
+ qr/Invalid META key: undef, keys must be true, and may not be references/,
+ "Cannot use undef as a meta key"
+ );
+
+ like(
+ exception { $hub->meta(0) },
+ qr/Invalid META key: '0', keys must be true, and may not be references/,
+ "Cannot use 0 as a meta key"
+ );
+
+ like(
+ exception { $hub->delete_meta(undef) },
+ qr/Invalid META key: undef, keys must be true, and may not be references/,
+ "Cannot use undef as a meta key"
+ );
+
+ like(
+ exception { $hub->delete_meta(0) },
+ qr/Invalid META key: '0', keys must be true, and may not be references/,
+ "Cannot use 0 as a meta key"
+ );
+};
+
+tests filter => sub {
+ my $hub = Test2::Hub->new();
+
+ my @events;
+ my $it = $hub->filter(sub {
+ my ($h, $e) = @_;
+ is($h, $hub, "got hub");
+ push @events => $e;
+ return $e;
+ });
+
+ my $count;
+ my $it2 = $hub->filter(sub { $count++; $_[1] });
+
+ my $ok1 = Test2::Event::Ok->new(
+ pass => 1,
+ name => 'foo',
+ trace => Test2::Util::Trace->new(
+ frame => [ __PACKAGE__, __FILE__, __LINE__ ],
+ ),
+ );
+
+ my $ok2 = Test2::Event::Ok->new(
+ pass => 0,
+ name => 'bar',
+ trace => Test2::Util::Trace->new(
+ frame => [ __PACKAGE__, __FILE__, __LINE__ ],
+ ),
+ );
+
+ my $ok3 = Test2::Event::Ok->new(
+ pass => 1,
+ name => 'baz',
+ trace => Test2::Util::Trace->new(
+ frame => [ __PACKAGE__, __FILE__, __LINE__ ],
+ ),
+ );
+
+ $hub->send($ok1);
+ $hub->send($ok2);
+
+ $hub->unfilter($it);
+
+ $hub->send($ok3);
+
+ is_deeply(\@events, [$ok1, $ok2], "got events");
+ is($count, 3, "got all events, even after other filter was removed");
+
+ $hub = Test2::Hub->new();
+ @events = ();
+
+ $hub->filter(sub { undef });
+ $hub->listen(sub {
+ my ($hub, $e) = @_;
+ push @events => $e;
+ });
+
+ $hub->send($ok1);
+ $hub->send($ok2);
+ $hub->send($ok3);
+
+ ok(!@events, "Blocked events");
+
+ like(
+ exception { $hub->filter('xxx') },
+ qr/filter only takes coderefs for arguments, got 'xxx'/,
+ "filter takes a coderef"
+ );
+};
+
+tests pre_filter => sub {
+ my $hub = Test2::Hub->new();
+
+ my @events;
+ my $it = $hub->pre_filter(sub {
+ my ($h, $e) = @_;
+ is($h, $hub, "got hub");
+ push @events => $e;
+ return $e;
+ });
+
+ my $count;
+ my $it2 = $hub->pre_filter(sub { $count++; $_[1] });
+
+ my $ok1 = Test2::Event::Ok->new(
+ pass => 1,
+ name => 'foo',
+ trace => Test2::Util::Trace->new(
+ frame => [ __PACKAGE__, __FILE__, __LINE__ ],
+ ),
+ );
+
+ my $ok2 = Test2::Event::Ok->new(
+ pass => 0,
+ name => 'bar',
+ trace => Test2::Util::Trace->new(
+ frame => [ __PACKAGE__, __FILE__, __LINE__ ],
+ ),
+ );
+
+ my $ok3 = Test2::Event::Ok->new(
+ pass => 1,
+ name => 'baz',
+ trace => Test2::Util::Trace->new(
+ frame => [ __PACKAGE__, __FILE__, __LINE__ ],
+ ),
+ );
+
+ $hub->send($ok1);
+ $hub->send($ok2);
+
+ $hub->pre_unfilter($it);
+
+ $hub->send($ok3);
+
+ is_deeply(\@events, [$ok1, $ok2], "got events");
+ is($count, 3, "got all events, even after other pre_filter was removed");
+
+ $hub = Test2::Hub->new();
+ @events = ();
+
+ $hub->pre_filter(sub { undef });
+ $hub->listen(sub {
+ my ($hub, $e) = @_;
+ push @events => $e;
+ });
+
+ $hub->send($ok1);
+ $hub->send($ok2);
+ $hub->send($ok3);
+
+ ok(!@events, "Blocked events");
+
+ like(
+ exception { $hub->pre_filter('xxx') },
+ qr/pre_filter only takes coderefs for arguments, got 'xxx'/,
+ "pre_filter takes a coderef"
+ );
+};
+
+tests state => sub {
+ my $hub = Test2::Hub->new;
+
+ is($hub->count, 0, "count starts at 0");
+ is($hub->failed, 0, "failed starts at 0");
+ is($hub->is_passing, 1, "start off passing");
+ is($hub->plan, undef, "no plan yet");
+
+ $hub->is_passing(0);
+ is($hub->is_passing, 0, "Can Fail");
+
+ $hub->is_passing(1);
+ is($hub->is_passing, 1, "Passes again");
+
+ $hub->set_count(1);
+ is($hub->count, 1, "Added a passing result");
+ is($hub->failed, 0, "still no fails");
+ is($hub->is_passing, 1, "Still passing");
+
+ $hub->set_count(2);
+ $hub->set_failed(1);
+ is($hub->count, 2, "Added a result");
+ is($hub->failed, 1, "new failure");
+ is($hub->is_passing, 0, "Not passing");
+
+ $hub->is_passing(1);
+ is($hub->is_passing, 0, "is_passing always false after a failure");
+
+ $hub->set_failed(0);
+ $hub->is_passing(1);
+ is($hub->is_passing, 1, "Passes again");
+
+ $hub->set_failed(1);
+ is($hub->count, 2, "No new result");
+ is($hub->failed, 1, "new failure");
+ is($hub->is_passing, 0, "Not passing");
+
+ ok(!eval { $hub->plan('foo'); 1 }, "Could not set plan to 'foo'");
+ like($@, qr/'foo' is not a valid plan! Plan must be an integer greater than 0, 'NO PLAN', or 'SKIP'/, "Got expected error");
+
+ ok($hub->plan(5), "Can set plan to integer");
+ is($hub->plan, 5, "Set the plan to an integer");
+
+ $hub->set__plan(undef);
+ ok($hub->plan('NO PLAN'), "Can set plan to 'NO PLAN'");
+ is($hub->plan, 'NO PLAN', "Set the plan to 'NO PLAN'");
+
+ $hub->set__plan(undef);
+ ok($hub->plan('SKIP'), "Can set plan to 'SKIP'");
+ is($hub->plan, 'SKIP', "Set the plan to 'SKIP'");
+
+ ok(!eval { $hub->plan(5); 1 }, "Cannot change plan");
+ like($@, qr/You cannot change the plan/, "Got error");
+
+ my $trace = Test2::Util::Trace->new(frame => ['Foo::Bar', 'foo.t', 42, 'blah']);
+ $hub->finalize($trace);
+ my $ok = eval { $hub->finalize($trace) };
+ my $err = $@;
+ ok(!$ok, "died");
+
+ is($err, <<" EOT", "Got expected error");
+Test already ended!
+First End: foo.t line 42
+Second End: foo.t line 42
+ EOT
+
+ $hub = Test2::Hub->new;
+
+ $hub->plan(5);
+ $hub->set_count(5);
+ $hub->set_failed(1);
+ $hub->set_ended($trace);
+ $hub->set_bailed_out("foo");
+ $hub->set_skip_reason('xxx');
+ ok(!$hub->is_passing, "not passing");
+
+ $hub->reset_state;
+
+ ok(!$hub->plan, "no plan");
+ is($hub->count, 0, "count reset to 0");
+ is($hub->failed, 0, "reset failures");
+ ok(!$hub->ended, "not ended");
+ ok(!$hub->bailed_out, "did not bail out");
+ ok(!$hub->skip_reason, "no skip reason");
+};
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+BEGIN { require "t/tools.pl" };
+
+use Test2::Hub::Interceptor;
+
+my $one = Test2::Hub::Interceptor->new();
+
+ok($one->isa('Test2::Hub'), "inheritence");;
+
+my $e = exception { $one->terminate(55) };
+ok($e->isa('Test2::Hub::Interceptor::Terminator'), "exception type");
+is($$e, 55, "Scalar reference value");
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+BEGIN { require "t/tools.pl" };
+
+use Test2::Hub::Interceptor::Terminator;
+
+ok($INC{'Test2/Hub/Interceptor/Terminator.pm'}, "loaded");
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+BEGIN { require "t/tools.pl" };
+
+use Test2::Hub::Subtest;
+use Test2::Util qw/get_tid/;
+use Carp qw/croak/;
+
+my %TODO;
+
+sub def {
+ my ($func, @args) = @_;
+
+ my @caller = caller(0);
+
+ $TODO{$caller[0]} ||= [];
+ push @{$TODO{$caller[0]}} => [$func, \@args, \@caller];
+}
+
+sub do_def {
+ my $for = caller;
+ my $tests = delete $TODO{$for} or croak "No tests to run!";
+
+ for my $test (@$tests) {
+ my ($func, $args, $caller) = @$test;
+
+ my ($pkg, $file, $line) = @$caller;
+
+# Note: The '&' below is to bypass the prototype, which is important here.
+ eval <<" EOT" or die $@;
+package $pkg;
+# line $line "(eval in DeferredTests) $file"
+\&$func(\@\$args);
+1;
+ EOT
+ }
+}
+
+my $ran = 0;
+my $event;
+
+my $one = Test2::Hub::Subtest->new(
+ nested => 3,
+);
+
+ok($one->isa('Test2::Hub'), "inheritence");
+
+{
+ no warnings 'redefine';
+ local *Test2::Hub::process = sub { $ran++; (undef, $event) = @_; 'P!' };
+ use warnings;
+
+ my $ok = Test2::Event::Ok->new(
+ pass => 1,
+ name => 'blah',
+ trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'xxx']),
+ );
+
+ def is => ($one->process($ok), 'P!', "processed");
+ def is => ($ran, 1, "ran the mocked process");
+ def is => ($event, $ok, "got our event");
+ def is => ($event->nested, 3, "nested was set");
+ def is => ($one->bailed_out, undef, "did not bail");
+
+ $ran = 0;
+ $event = undef;
+
+ my $bail = Test2::Event::Bail->new(
+ message => 'blah',
+ trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'xxx']),
+ );
+
+ def is => ($one->process($bail), 'P!', "processed");
+ def is => ($ran, 1, "ran the mocked process");
+ def is => ($event, $bail, "got our event");
+ def is => ($event->nested, 3, "nested was set");
+ def is => ($one->bailed_out, $event, "bailed");
+}
+
+do_def;
+
+my $skip = Test2::Event::Plan->new(
+ trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__], pid => $$, tid => get_tid),
+ directive => 'SKIP',
+ reason => 'foo',
+);
+
+$ran = 0;
+T2_SUBTEST_WRAPPER: {
+ $ran++;
+ $one->terminate(100, $skip);
+ $ran++;
+}
+is($ran, 1, "did not get past the terminate");
+
+$ran = 0;
+T2_SUBTEST_WRAPPER: {
+ $ran++;
+ $one->send($skip);
+ $ran++;
+}
+is($ran, 1, "did not get past the terminate");
+
+$one->reset_state;
+$one->set_manual_skip_all(1);
+
+$ran = 0;
+T2_SUBTEST_WRAPPER: {
+ $ran++;
+ $one->terminate(100, $skip);
+ $ran++;
+}
+is($ran, 2, "did not automatically abort");
+
+$one->reset_state;
+$ran = 0;
+T2_SUBTEST_WRAPPER: {
+ $ran++;
+ $one->send($skip);
+ $ran++;
+}
+is($ran, 2, "did not automatically abort");
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test2::IPC qw/cull/;
+use Test2::API qw/context test2_ipc_drivers test2_ipc/;
+
+BEGIN { require "t/tools.pl" };
+
+test2_ipc();
+
+is_deeply(
+ [test2_ipc_drivers()],
+ ['Test2::IPC::Driver::Files'],
+ "Default driver"
+);
+
+ok(__PACKAGE__->can('cull'), "Imported cull");
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test2::IPC::Driver::Files;
+
+BEGIN { require "t/tools.pl" };
+use Test2::API qw/context test2_ipc_drivers/;
+
+Test2::IPC::Driver::Files->import();
+Test2::IPC::Driver::Files->import();
+Test2::IPC::Driver::Files->import();
+
+is_deeply(
+ [test2_ipc_drivers()],
+ ['Test2::IPC::Driver::Files'],
+ "Driver not added multiple times"
+);
+
+for my $meth (qw/send cull add_hub drop_hub waiting is_viable/) {
+ my $one = Test2::IPC::Driver->new;
+ like(
+ exception { $one->$meth },
+ qr/'\Q$one\E' did not define the required method '$meth'/,
+ "Require override of method $meth"
+ );
+}
+
+tests abort => sub {
+ my $one = Test2::IPC::Driver->new(no_fatal => 1);
+ my ($err, $out) = ("", "");
+
+ {
+ local *STDERR;
+ local *STDOUT;
+ open(STDERR, '>', \$err);
+ open(STDOUT, '>', \$out);
+ $one->abort('foo');
+ }
+
+ is($err, "IPC Fatal Error: foo\n", "Got error");
+ is($out, "not ok - IPC Fatal Error\n", "got 'not ok' on stdout");
+
+ ($err, $out) = ("", "");
+
+ {
+ local *STDERR;
+ local *STDOUT;
+ open(STDERR, '>', \$err);
+ open(STDOUT, '>', \$out);
+ $one->abort_trace('foo');
+ }
+
+ is($out, "not ok - IPC Fatal Error\n", "got 'not ok' on stdout");
+ like($err, qr/IPC Fatal Error: foo/, "Got error");
+};
+
+done_testing;
--- /dev/null
+BEGIN { require "t/tools.pl" };
+use Test2::Util qw/get_tid USE_THREADS try/;
+use File::Temp qw/tempfile/;
+use strict;
+use warnings;
+
+sub capture(&) {
+ my $code = shift;
+
+ my ($err, $out) = ("", "");
+
+ my ($ok, $e);
+ {
+ local *STDOUT;
+ local *STDERR;
+
+ ($ok, $e) = try {
+ open(STDOUT, '>', \$out) or die "Failed to open a temporary STDOUT: $!";
+ open(STDERR, '>', \$err) or die "Failed to open a temporary STDERR: $!";
+
+ $code->();
+ };
+ }
+
+ die $e unless $ok;
+
+ return {
+ STDOUT => $out,
+ STDERR => $err,
+ };
+}
+
+require Test2::IPC::Driver::Files;
+ok(my $ipc = Test2::IPC::Driver::Files->new, "Created an IPC instance");
+ok($ipc->isa('Test2::IPC::Driver::Files'), "Correct type");
+ok($ipc->isa('Test2::IPC::Driver'), "inheritence");
+
+ok(-d $ipc->tempdir, "created temp dir");
+is($ipc->pid, $$, "stored pid");
+is($ipc->tid, get_tid(), "stored the tid");
+
+my $hid = '12345';
+
+$ipc->add_hub($hid);
+ok(-f $ipc->tempdir . '/HUB-' . $hid, "wrote hub file");
+if(ok(open(my $fh, '<', $ipc->tempdir . '/HUB-' . $hid), "opened hub file")) {
+ my @lines = <$fh>;
+ close($fh);
+ is_deeply(
+ \@lines,
+ [ "$$\n", get_tid() . "\n" ],
+ "Wrote pid and tid to hub file"
+ );
+}
+
+{
+ package Foo;
+ use base 'Test2::Event';
+}
+
+$ipc->send($hid, bless({ foo => 1 }, 'Foo'));
+$ipc->send($hid, bless({ bar => 1 }, 'Foo'));
+
+opendir(my $dh, $ipc->tempdir) || die "Could not open tempdir: !?";
+my @files = grep { $_ !~ m/^\.+$/ && $_ ne "HUB-$hid" } readdir($dh);
+closedir($dh);
+is(@files, 2, "2 files added to the IPC directory");
+
+my @events = $ipc->cull($hid);
+is_deeply(
+ \@events,
+ [{ foo => 1 }, { bar => 1 }],
+ "Culled both events"
+);
+
+opendir($dh, $ipc->tempdir) || die "Could not open tempdir: !?";
+@files = grep { $_ !~ m/^\.+$/ && $_ ne "HUB-$hid" } readdir($dh);
+closedir($dh);
+is(@files, 0, "All files collected");
+
+$ipc->drop_hub($hid);
+ok(!-f $ipc->tempdir . '/' . $hid, "removed hub file");
+
+$ipc->send($hid, bless({global => 1}, 'Foo'), 'GLOBAL');
+my @got = $ipc->cull($hid);
+ok(@got == 0, "did not get our own global event");
+
+my $tmpdir = $ipc->tempdir;
+ok(-d $tmpdir, "still have temp dir");
+$ipc = undef;
+ok(!-d $tmpdir, "cleaned up temp dir");
+
+{
+ my $ipc = Test2::IPC::Driver::Files->new();
+
+ my $tmpdir = $ipc->tempdir;
+
+ my $ipc_thread_clone = bless {%$ipc}, 'Test2::IPC::Driver::Files';
+ $ipc_thread_clone->set_tid(100);
+ $ipc_thread_clone = undef;
+ ok(-d $tmpdir, "Directory not removed (different thread)");
+
+ my $ipc_fork_clone = bless {%$ipc}, 'Test2::IPC::Driver::Files';
+ $ipc_fork_clone->set_pid($$ + 10);
+ $ipc_fork_clone = undef;
+ ok(-d $tmpdir, "Directory not removed (different proc)");
+
+
+ $ipc_thread_clone = bless {%$ipc}, 'Test2::IPC::Driver::Files';
+ $ipc_thread_clone->set_tid(undef);
+ $ipc_thread_clone = undef;
+ ok(-d $tmpdir, "Directory not removed (no thread)");
+
+ $ipc_fork_clone = bless {%$ipc}, 'Test2::IPC::Driver::Files';
+ $ipc_fork_clone->set_pid(undef);
+ $ipc_fork_clone = undef;
+ ok(-d $tmpdir, "Directory not removed (no proc)");
+
+ $ipc = undef;
+ ok(!-d $tmpdir, "Directory removed");
+}
+
+{
+ no warnings 'once';
+ local *Test2::IPC::Driver::Files::abort = sub {
+ my $self = shift;
+ local $self->{no_fatal} = 1;
+ $self->Test2::IPC::Driver::abort(@_);
+ die 255;
+ };
+
+ my $tmpdir;
+ my @lines;
+ my $file = __FILE__;
+
+ my $out = capture {
+ local $ENV{T2_KEEP_TEMPDIR} = 1;
+
+ my $ipc = Test2::IPC::Driver::Files->new();
+ $tmpdir = $ipc->tempdir;
+ $ipc->add_hub($hid);
+ eval { $ipc->add_hub($hid) }; push @lines => __LINE__;
+ $ipc->send($hid, bless({ foo => 1 }, 'Foo'));
+ $ipc->cull($hid);
+ $ipc->drop_hub($hid);
+ eval { $ipc->drop_hub($hid) }; push @lines => __LINE__;
+
+ # Make sure having a hub file sitting around does not throw things off
+ # in T2_KEEP_TEMPDIR
+ $ipc->add_hub($hid);
+ $ipc = undef;
+ 1;
+ };
+
+ is($out->{STDOUT}, "not ok - IPC Fatal Error\nnot ok - IPC Fatal Error\n", "printed ");
+
+ like($out->{STDERR}, qr/IPC Temp Dir: \Q$tmpdir\E/m, "Got temp dir path");
+ like($out->{STDERR}, qr/^# Not removing temp dir: \Q$tmpdir\E$/m, "Notice about not closing tempdir");
+
+ like($out->{STDERR}, qr/^IPC Fatal Error: File for hub '12345' already exists/m, "Got message for duplicate hub");
+ like($out->{STDERR}, qr/^IPC Fatal Error: File for hub '12345' does not exist/m, "Cannot remove hub twice");
+
+ $out = capture {
+ my $ipc = Test2::IPC::Driver::Files->new();
+ $ipc->add_hub($hid);
+ my $trace = Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'foo']);
+ my $e = eval { $ipc->send($hid, bless({glob => \*ok, trace => $trace}, 'Foo')); 1 };
+ print STDERR $@ unless $e || $@ =~ m/^255/;
+ $ipc->drop_hub($hid);
+ };
+
+ like($out->{STDERR}, qr/IPC Fatal Error:/, "Got fatal error");
+ like($out->{STDERR}, qr/There was an error writing an event/, "Explanation");
+ like($out->{STDERR}, qr/Destination: 12345/, "Got dest");
+ like($out->{STDERR}, qr/Origin PID:\s+$$/, "Got pid");
+ like($out->{STDERR}, qr/Error: Can't store GLOB items/, "Got cause");
+
+ $out = capture {
+ my $ipc = Test2::IPC::Driver::Files->new();
+ local $@;
+ eval { $ipc->send($hid, bless({ foo => 1 }, 'Foo')) };
+ print STDERR $@ unless $@ =~ m/^255/;
+ $ipc = undef;
+ };
+ like($out->{STDERR}, qr/IPC Fatal Error: hub '12345' is not available, failed to send event!/, "Cannot send to missing hub");
+
+ $out = capture {
+ my $ipc = Test2::IPC::Driver::Files->new();
+ $ipc->add_hub($hid);
+ $ipc->send($hid, bless({ foo => 1 }, 'Foo'));
+ local $@;
+ eval { $ipc->drop_hub($hid) };
+ print STDERR $@ unless $@ =~ m/^255/;
+ };
+ like($out->{STDERR}, qr/IPC Fatal Error: Not all files from hub '12345' have been collected/, "Leftover files");
+ like($out->{STDERR}, qr/IPC Fatal Error: Leftover files in the directory \(.*\.ready\)/, "What file");
+
+ $out = capture {
+ my $ipc = Test2::IPC::Driver::Files->new();
+ $ipc->add_hub($hid);
+
+ eval { $ipc->send($hid, { foo => 1 }) };
+ print STDERR $@ unless $@ =~ m/^255/;
+
+ eval { $ipc->send($hid, bless({ foo => 1 }, 'xxx')) };
+ print STDERR $@ unless $@ =~ m/^255/;
+ };
+ like($out->{STDERR}, qr/IPC Fatal Error: 'HASH\(.*\)' is not a blessed object/, "Cannot send unblessed objects");
+ like($out->{STDERR}, qr/IPC Fatal Error: 'xxx=HASH\(.*\)' is not an event object!/, "Cannot send non-event objects");
+
+
+ $ipc = Test2::IPC::Driver::Files->new();
+
+ my ($fh, $fn) = tempfile();
+ print $fh "\n";
+ close($fh);
+
+ Storable::store({}, $fn);
+ $out = capture { eval { $ipc->read_event_file($fn) } };
+ like(
+ $out->{STDERR},
+ qr/IPC Fatal Error: Got an unblessed object: 'HASH\(.*\)'/,
+ "Events must actually be events (must be blessed)"
+ );
+
+ Storable::store(bless({}, 'Test2::Event::FakeEvent'), $fn);
+ $out = capture { eval { $ipc->read_event_file($fn) } };
+ like(
+ $out->{STDERR},
+ qr{IPC Fatal Error: Event has unknown type \(Test2::Event::FakeEvent\), tried to load 'Test2/Event/FakeEvent\.pm' but failed: Can't locate Test2/Event/FakeEvent\.pm},
+ "Events must actually be events (not a real module)"
+ );
+
+ Storable::store(bless({}, 'Test2::API'), $fn);
+ $out = capture { eval { $ipc->read_event_file($fn) } };
+ like(
+ $out->{STDERR},
+ qr{'Test2::API=HASH\(.*\)' is not a 'Test2::Event' object},
+ "Events must actually be events (not an event type)"
+ );
+
+ Storable::store(bless({}, 'Foo'), $fn);
+ $out = capture {
+ local @INC;
+ push @INC => ('t/lib', 'lib');
+ eval { $ipc->read_event_file($fn) };
+ };
+ ok(!$out->{STDERR}, "no problem", $out->{STDERR});
+ ok(!$out->{STDOUT}, "no problem", $out->{STDOUT});
+
+ unlink($fn);
+}
+
+{
+ my $ipc = Test2::IPC::Driver::Files->new();
+ $ipc->add_hub($hid);
+ $ipc->send($hid, bless({global => 1}, 'Foo'), 'GLOBAL');
+ $ipc->set_globals({});
+ my @events = $ipc->cull($hid);
+ is_deeply(
+ \@events,
+ [ {global => 1} ],
+ "Got global event"
+ );
+
+ @events = $ipc->cull($hid);
+ ok(!@events, "Did not grab it again");
+
+ $ipc->set_globals({});
+ @events = $ipc->cull($hid);
+ is_deeply(
+ \@events,
+ [ {global => 1} ],
+ "Still there"
+ );
+
+ $ipc->drop_hub($hid);
+ $ipc = undef;
+}
+
+done_testing;
+
--- /dev/null
+use strict;
+use warnings;
+
+BEGIN { require "t/tools.pl" };
+use Test2::Util qw/
+ try
+
+ get_tid USE_THREADS
+
+ pkg_to_file
+
+ CAN_FORK
+ CAN_THREAD
+ CAN_REALLY_FORK
+/;
+
+{
+ for my $try (\&try, Test2::Util->can('_manual_try'), Test2::Util->can('_local_try')) {
+ my ($ok, $err) = $try->(sub { die "xxx" });
+ ok(!$ok, "cought exception");
+ like($err, qr/xxx/, "expected exception");
+
+ ($ok, $err) = $try->(sub { 0 });
+ ok($ok, "Success");
+ ok(!$err, "no error");
+ }
+}
+
+is(pkg_to_file('A::Package::Name'), 'A/Package/Name.pm', "Converted package to file");
+
+# Make sure running them does not die
+# We cannot really do much to test these.
+CAN_THREAD();
+CAN_FORK();
+CAN_REALLY_FORK();
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+BEGIN { require "t/tools.pl" };
+
+{
+ package Foo::Bar;
+
+ use Test2::Util::ExternalMeta;
+ use Test2::Util::HashBase qw/foo bar/;
+}
+
+ok(Foo::Bar->can($_), "Imported '$_'") for qw/meta get_meta set_meta delete_meta/;
+
+my $one = Foo::Bar->new(foo => 1, bar => 2);
+ok($one->isa('Foo::Bar'), "Got instance");
+
+is_deeply($one, {foo => 1, bar => 2}, "nothing fishy.. yet");
+
+is($one->get_meta('foo'), undef, "no meta-data for foo");
+is($one->get_meta('bar'), undef, "no meta-data for bar");
+is($one->get_meta('baz'), undef, "no meta-data for baz");
+
+is($one->meta('foo'), undef, "no meta-data for foo");
+is($one->meta('bar'), undef, "no meta-data for bar");
+is($one->meta('baz'), undef, "no meta-data for baz");
+
+is_deeply($one, {foo => 1, bar => 2}, "Still have not modified instance");
+
+$one->set_meta('foo' => 123);
+is($one->foo, 1, "did not change attribute");
+is($one->meta('foo'), 123, "get meta-data for foo");
+is($one->get_meta('foo'), 123, "get meta-data for foo again");
+
+$one->meta('foo', 345);
+is($one->foo, 1, "did not change attribute");
+is($one->meta('foo', 678), 123, "did not alter already set meta-attribute");
+is($one->get_meta('foo'), 123, "still did not alter already set meta-attribute");
+
+is($one->meta('bar', 789), 789, "used default for bar");
+is($one->bar, 2, "did not change attribute");
+
+is_deeply(
+ $one,
+ {
+ foo => 1,
+ bar => 2,
+ Test2::Util::ExternalMeta::META_KEY() => {
+ foo => 123,
+ bar => 789,
+ },
+ },
+ "Stored meta-data"
+);
+
+is($one->delete_meta('foo'), 123, "got old value on delete");
+is($one->meta('foo'), undef, "no more value");
+
+is_deeply(
+ $one,
+ {
+ foo => 1,
+ bar => 2,
+ Test2::Util::ExternalMeta::META_KEY() => {
+ bar => 789,
+ },
+ },
+ "Deleted the meta key"
+);
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+BEGIN { require "t/tools.pl" };
+BEGIN {
+ $INC{'My/HBase.pm'} = __FILE__;
+
+ package My::HBase;
+ use Test2::Util::HashBase qw/foo bar baz/;
+
+ main::is(FOO, 'foo', "FOO CONSTANT");
+ main::is(BAR, 'bar', "BAR CONSTANT");
+ main::is(BAZ, 'baz', "BAZ CONSTANT");
+}
+
+BEGIN {
+ package My::HBaseSub;
+ use base 'My::HBase';
+ use Test2::Util::HashBase qw/apple pear/;
+
+ main::is(FOO, 'foo', "FOO CONSTANT");
+ main::is(BAR, 'bar', "BAR CONSTANT");
+ main::is(BAZ, 'baz', "BAZ CONSTANT");
+ main::is(APPLE, 'apple', "APPLE CONSTANT");
+ main::is(PEAR, 'pear', "PEAR CONSTANT");
+}
+
+my $one = My::HBase->new(foo => 'a', bar => 'b', baz => 'c');
+is($one->foo, 'a', "Accessor");
+is($one->bar, 'b', "Accessor");
+is($one->baz, 'c', "Accessor");
+$one->set_foo('x');
+is($one->foo, 'x', "Accessor set");
+$one->set_foo(undef);
+
+is_deeply(
+ $one,
+ {
+ foo => undef,
+ bar => 'b',
+ baz => 'c',
+ },
+ 'hash'
+);
+
+BEGIN {
+ package My::Const::Test;
+ use Test2::Util::HashBase qw/foo/;
+
+ sub do_it {
+ if (FOO()) {
+ return 'const';
+ }
+ return 'not const'
+ }
+}
+
+my $pkg = 'My::Const::Test';
+is($pkg->do_it, 'const', "worked as expected");
+{
+ local $SIG{__WARN__} = sub { };
+ *My::Const::Test::FOO = sub { 0 };
+}
+ok(!$pkg->FOO, "overrode const sub");
+is($pkg->do_it, 'const', "worked as expected, const was constant");
+
+BEGIN {
+ $INC{'My/HBase/Wrapped.pm'} = __FILE__;
+
+ package My::HBase::Wrapped;
+ use Test2::Util::HashBase qw/foo bar/;
+
+ my $foo = __PACKAGE__->can('foo');
+ no warnings 'redefine';
+ *foo = sub {
+ my $self = shift;
+ $self->set_bar(1);
+ $self->$foo(@_);
+ };
+}
+
+BEGIN {
+ $INC{'My/HBase/Wrapped/Inherit.pm'} = __FILE__;
+
+ package My::HBase::Wrapped::Inherit;
+ use base 'My::HBase::Wrapped';
+ use Test2::Util::HashBase;
+}
+
+my $o = My::HBase::Wrapped::Inherit->new(foo => 1);
+my $foo = $o->foo;
+is($o->bar, 1, 'parent attribute sub not overridden');
+
+{
+ package Foo;
+
+ sub new;
+
+ use Test2::Util::HashBase qw/foo bar baz/;
+
+ sub new { 'foo' };
+}
+
+is(Foo->new, 'foo', "Did not override existing 'new' method");
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+BEGIN { require "t/tools.pl" };
+use Test2::Util::Trace;
+
+like(
+ exception { 'Test2::Util::Trace'->new() },
+ qr/The 'frame' attribute is required/,
+ "got error"
+);
+
+my $one = 'Test2::Util::Trace'->new(frame => ['Foo::Bar', 'foo.t', 5, 'Foo::Bar::foo']);
+is_deeply($one->frame, ['Foo::Bar', 'foo.t', 5, 'Foo::Bar::foo'], "Got frame");
+is_deeply([$one->call], ['Foo::Bar', 'foo.t', 5, 'Foo::Bar::foo'], "Got call");
+is($one->package, 'Foo::Bar', "Got package");
+is($one->file, 'foo.t', "Got file");
+is($one->line, 5, "Got line");
+is($one->subname, 'Foo::Bar::foo', "got subname");
+
+is($one->debug, "at foo.t line 5", "got trace");
+$one->set_detail("yo momma");
+is($one->debug, "yo momma", "got detail for trace");
+$one->set_detail(undef);
+
+is(
+ exception { $one->throw('I died') },
+ "I died at foo.t line 5.\n",
+ "got exception"
+);
+
+is_deeply(
+ warnings { $one->alert('I cried') },
+ [ "I cried at foo.t line 5.\n" ],
+ "alter() warns"
+);
+
+my $snap = $one->snapshot;
+is_deeply($snap, $one, "identical");
+ok($snap != $one, "Not the same instance");
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+# This test is for gh #16
+# Also see https://rt.perl.org/Public/Bug/Display.html?id=127774
+
+# Ceate this END before anything else so that $? gets set to 0
+END { $? = 0 }
+
+BEGIN {
+ print "\n1..1\n";
+ close(STDERR);
+ open(STDERR, '>&', STDOUT);
+}
+
+use Test2::API;
+
+eval(' sub { die "xxx" } ')->();
+END {
+ sub { my $ctx = Test2::API::context(); $ctx->release; }->();
+ print "ok 1 - Did not segv\n";
+ $? = 0;
+}
--- /dev/null
+use strict;
+use warnings;
+use Test2::IPC;
+BEGIN { require "t/tools.pl" };
+use Test2::API qw/context test2_stack/;
+use Test2::Util qw/CAN_FORK/;
+
+BEGIN {
+ skip_all "System cannot fork" unless CAN_FORK;
+}
+
+plan(3);
+
+pipe(my ($read, $write));
+
+test2_stack()->top;
+my $hub = test2_stack()->new_hub();
+
+my $pid = fork();
+die "Failed to fork" unless defined $pid;
+
+if ($pid) {
+ close($read);
+ test2_stack()->pop($hub);
+ $hub = undef;
+ print $write "Go\n";
+ close($write);
+ waitpid($pid, 0);
+ my $err = $? >> 8;
+ is($err, 255, "Exit code was not masked");
+ ok($err != 100, "Did not hit the safety exit");
+}
+else {
+ close($write);
+ my $ignore = <$read>;
+ close($read);
+ close(STDERR);
+ close(STDOUT);
+ open(STDERR, '>', my $x);
+ my $ctx = context(hub => $hub, level => -1);
+ my $clone = $ctx->snapshot;
+ $ctx->release;
+ $clone->ok(0, "Should not see this");
+ print STDERR "\n\nSomething went wrong!!!!\n\n";
+ exit 100; # Safety exit
+};
+
+
+# The rest of this is to make sure nothing that happens when reading the event
+# messes with $?.
+
+pipe($read, $write);
+
+$pid = fork;
+die "Failed to fork" unless defined $pid;
+
+unless($pid) {
+ my $ignore = <$read>;
+ ok(1, "Test in forked process");
+}
+
+print $write "Go\n";
+++ /dev/null
-#!/usr/bin/perl
-
-# Test important dependant modules so we don't accidentally half of CPAN.
-
-use strict;
-use warnings;
-
-use Test::More;
-
-BEGIN {
- plan skip_all => "Dependents only tested when releasing" unless $ENV{PERL_RELEASING};
-}
-
-require File::Spec;
-use CPAN;
-
-CPAN::HandleConfig->load;
-$CPAN::Config->{test_report} = 0;
-
-# Module which depend on Test::More to test
-my @Modules = qw(
- Test::Most
- Test::Warn
- Test::Exception
- Test::Class
- Test::Deep
- Test::Differences
- Test::NoWarnings
-);
-
-# Modules which are known to be broken
-my %Broken = map { $_ => 1 } qw(
-);
-
-TODO: for my $name (@ARGV ? @ARGV : @Modules) {
- local $TODO = "$name known to be broken" if $Broken{$name};
-
- local $ENV{PERL5LIB} = "$ENV{PERL5LIB}:" . File::Spec->rel2abs("blib/lib");
- my $module = CPAN::Shell->expand("Module", $name);
- $module->test;
- ok( !$module->distribution->{make_test}->failed, $name );
-}
-
-done_testing();
+++ /dev/null
-#!/usr/bin/perl -w
-
-BEGIN {
- if( $ENV{PERL_CORE} ) {
- chdir 't';
- @INC = '../lib';
- }
-}
-
-use Test::More;
-use Config;
-
-my $Can_Fork = $Config{d_fork} ||
- (($^O eq 'MSWin32' || $^O eq 'NetWare') and
- $Config{useithreads} and
- $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/
- );
-
-if( !$Can_Fork ) {
- plan skip_all => "This system cannot fork";
-}
-else {
- plan tests => 1;
-}
-
-if( fork ) { # parent
- pass("Only the parent should process the ending, not the child");
-}
-else {
- exit; # child
-}
-
--- /dev/null
+use Test::More;
+use strict;
+use warnings;
+
+use Test2::API qw{
+ test2_set_is_end
+ test2_get_is_end
+ intercept
+};
+
+my %res;
+intercept {
+ my $tb = Test::Builder->new;
+ $res{before} = test2_get_is_end();
+ test2_set_is_end();
+ $res{isset} = test2_get_is_end();
+ $tb->reset;
+ $res{reset} = test2_get_is_end();
+};
+
+ok(!$res{before}, "Not the end");
+ok($res{isset}, "the end");
+ok(!$res{reset}, "Not the end");
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+BEGIN { require "t/tools.pl" };
+
+ok(1, "");
+
+tests foo => sub {
+ ok(1, "name");
+ ok(1, "");
+};
+
+done_testing;
+++ /dev/null
-#!/usr/bin/perl -w
-
-BEGIN {
- if( $ENV{PERL_CORE} ) {
- chdir 't';
- @INC = ( '../lib', 'lib' );
- }
- else {
- unshift @INC, 't/lib';
- }
-}
-
-use strict;
-use warnings;
-use Test::Builder::NoOutput;
-use Test::More tests => 7;
-
-{
- my $tb = Test::Builder::NoOutput->create;
- $tb->child('one');
- eval { $tb->child('two') };
- my $error = $@;
- like $error, qr/\QYou already have a child named (one) running/,
- 'Trying to create a child with another one active should fail';
-}
-{
- my $tb = Test::Builder::NoOutput->create;
- my $child = $tb->child('one');
- ok my $child2 = $child->child('two'), 'Trying to create nested children should succeed';
- eval { $child->finalize };
- my $error = $@;
- like $error, qr/\QCan't call finalize() with child (two) active/,
- '... but trying to finalize() a child with open children should fail';
-}
-{
- my $tb = Test::Builder::NoOutput->create;
- my $child = $tb->child('one');
- undef $child;
- like $tb->read, qr/\QChild (one) exited without calling finalize()/,
- 'Failing to call finalize should issue an appropriate diagnostic';
- ok !$tb->is_passing, '... and should cause the test suite to fail';
-}
-{
- my $tb = Test::Builder::NoOutput->create;
-
- $tb->plan( tests => 7 );
- for( 1 .. 3 ) {
- $tb->ok( $_, "We're on $_" );
- $tb->diag("We ran $_");
- }
- {
- my $indented = $tb->child;
- $indented->plan('no_plan');
- $indented->ok( 1, "We're on 1" );
- eval { $tb->ok( 1, 'This should throw an exception' ) };
- $indented->finalize;
- }
-
- my $error = $@;
- like $error, qr/\QCannot run test (This should throw an exception) with active children/,
- 'Running a test with active children should fail';
- ok !$tb->is_passing, '... and should cause the test suite to fail';
-}
--- /dev/null
+use Scalar::Util qw/blessed/;
+
+use Test2::Util qw/try/;
+use Test2::API qw/context run_subtest/;
+
+use Test2::Hub::Interceptor();
+use Test2::Hub::Interceptor::Terminator();
+
+sub ok($;$@) {
+ my ($bool, $name, @diag) = @_;
+ my $ctx = context();
+ $ctx->ok($bool, $name, \@diag);
+ $ctx->release;
+ return $bool ? 1 : 0;
+}
+
+sub is($$;$@) {
+ my ($got, $want, $name, @diag) = @_;
+ my $ctx = context();
+
+ my $bool;
+ if (defined($got) && defined($want)) {
+ $bool = "$got" eq "$want";
+ }
+ elsif (defined($got) xor defined($want)) {
+ $bool = 0;
+ }
+ else { # Both are undef
+ $bool = 1;
+ }
+
+ unless ($bool) {
+ $got = '*NOT DEFINED*' unless defined $got;
+ $want = '*NOT DEFINED*' unless defined $want;
+ unshift @diag => (
+ "GOT: $got",
+ "EXPECTED: $want",
+ );
+ }
+
+ $ctx->ok($bool, $name, \@diag);
+ $ctx->release;
+ return $bool;
+}
+
+sub isnt($$;$@) {
+ my ($got, $want, $name, @diag) = @_;
+ my $ctx = context();
+
+ my $bool;
+ if (defined($got) && defined($want)) {
+ $bool = "$got" ne "$want";
+ }
+ elsif (defined($got) xor defined($want)) {
+ $bool = 1;
+ }
+ else { # Both are undef
+ $bool = 0;
+ }
+
+ unshift @diag => "Strings are the same (they should not be)"
+ unless $bool;
+
+ $ctx->ok($bool, $name, \@diag);
+ $ctx->release;
+ return $bool;
+}
+
+sub like($$;$@) {
+ my ($thing, $pattern, $name, @diag) = @_;
+ my $ctx = context();
+
+ my $bool;
+ if (defined($thing)) {
+ $bool = "$thing" =~ $pattern;
+ unshift @diag => (
+ "Value: $thing",
+ "Does not match: $pattern"
+ ) unless $bool;
+ }
+ else {
+ $bool = 0;
+ unshift @diag => "Got an undefined value.";
+ }
+
+ $ctx->ok($bool, $name, \@diag);
+ $ctx->release;
+ return $bool;
+}
+
+sub unlike($$;$@) {
+ my ($thing, $pattern, $name, @diag) = @_;
+ my $ctx = context();
+
+ my $bool;
+ if (defined($thing)) {
+ $bool = "$thing" !~ $pattern;
+ unshift @diag => (
+ "Unexpected pattern match (it should not match)",
+ "Value: $thing",
+ "Matches: $pattern"
+ ) unless $bool;
+ }
+ else {
+ $bool = 0;
+ unshift @diag => "Got an undefined value.";
+ }
+
+ $ctx->ok($bool, $name, \@diag);
+ $ctx->release;
+ return $bool;
+}
+
+sub is_deeply($$;$@) {
+ my ($got, $want, $name, @diag) = @_;
+ my $ctx = context();
+
+ no warnings 'once';
+ require Data::Dumper;
+ local $Data::Dumper::Sortkeys = 1;
+ local $Data::Dumper::Deparse = 1;
+ local $Data::Dumper::Freezer = 'XXX';
+ local *UNIVERSAL::XXX = sub {
+ my ($thing) = @_;
+ if (ref($thing)) {
+ $thing = {%$thing} if "$thing" =~ m/=HASH/;
+ $thing = [@$thing] if "$thing" =~ m/=ARRAY/;
+ $thing = \"$$thing" if "$thing" =~ m/=SCALAR/;
+ }
+ $_[0] = $thing;
+ };
+
+ my $g = Data::Dumper::Dumper($got);
+ my $w = Data::Dumper::Dumper($want);
+
+ my $bool = $g eq $w;
+
+ my $diff;
+# unless ($bool) {
+# use File::Temp;
+# my ($gFH, $fileg) = File::Temp::tempfile();
+# my ($wFH, $filew) = File::Temp::tempfile();
+# print $gFH $g;
+# print $wFH $w;
+# close($gFH) || die $!;
+# close($wFH) || die $!;
+# my $cmd = qq{git diff --color=always "$fileg" "$filew"};
+# $diff = eval { `$cmd` };
+# }
+
+ $ctx->ok($bool, $name, [$diff ? $diff : ($g, $w), @diag]);
+ $ctx->release;
+ return $bool;
+}
+
+sub diag {
+ my $ctx = context();
+ $ctx->diag( join '', @_ );
+ $ctx->release;
+}
+
+sub note {
+ my $ctx = context();
+ $ctx->note( join '', @_ );
+ $ctx->release;
+}
+
+sub skip_all {
+ my ($reason) = @_;
+ my $ctx = context();
+ $ctx->plan(0, SKIP => $reason);
+ $ctx->release if $ctx;
+}
+
+sub plan {
+ my ($max) = @_;
+ my $ctx = context();
+ $ctx->plan($max);
+ $ctx->release;
+}
+
+sub done_testing {
+ my $ctx = context();
+ $ctx->done_testing;
+ $ctx->release;
+}
+
+sub warnings(&) {
+ my $code = shift;
+ my @warnings;
+ local $SIG{__WARN__} = sub { push @warnings => @_ };
+ $code->();
+ return \@warnings;
+}
+
+sub exception(&) {
+ my $code = shift;
+ local ($@, $!, $SIG{__DIE__});
+ my $ok = eval { $code->(); 1 };
+ my $error = $@ || 'SQUASHED ERROR';
+ return $ok ? undef : $error;
+}
+
+sub tests {
+ my ($name, $code) = @_;
+ my $ctx = context();
+
+ before_each() if __PACKAGE__->can('before_each');
+
+ my $bool = run_subtest($name, $code, 1);
+
+ $ctx->release;
+
+ return $bool;
+}
+
+1;
--- /dev/null
+use strict;
+use warnings;
+
+use Test2::IPC;
+BEGIN { require "t/tools.pl" };
+
+use Test2::API qw/context intercept test2_stack/;
+
+ok(__PACKAGE__->can($_), "imported '$_\()'") for qw{
+ ok
+ is isnt
+ like unlike
+ diag note
+
+ is_deeply
+
+ warnings
+ exception
+
+ plan
+ skip_all
+ done_testing
+};
+
+ok(1, "'ok' Test");
+is("foo", "foo", "'is' test");
+is(undef, undef, "'is' undef test");
+isnt("foo", "bar", "'isnt' test");
+isnt("foo", undef, "'isnt' undef test 1");
+isnt(undef, "foo", "'isnt' undef test 2");
+like("foo", qr/o/, "'like' test");
+unlike("foo", qr/a/, "'unlike' test");
+diag("Testing Diag");
+note("Testing Note");
+
+my $str = "abc";
+is_deeply(
+ { a => 1, b => 2, c => { ref => \$str, obj => bless({x => 1}, 'XXX'), array => [1, 2, 3]}},
+ { a => 1, b => 2, c => { ref => \$str, obj => {x => 1}, array => [1, 2, 3]}},
+ "'is_deeply' test"
+);
+
+is_deeply(
+ warnings { warn "aaa\n"; warn "bbb\n" },
+ [ "aaa\n", "bbb\n" ],
+ "Got warnings"
+);
+
+is_deeply(
+ warnings { 1 },
+ [],
+ "no warnings"
+);
+
+is(exception { die "foo\n" }, "foo\n", "got exception");
+is(exception { 1 }, undef, "no exception");
+
+my $main_events = intercept {
+ plan 8;
+
+ ok(0, "'ok' Test");
+ is("foo", "bar", "'is' test");
+ isnt("foo", "foo", "'isnt' test");
+ like("foo", qr/a/, "'like' test");
+ unlike("foo", qr/o/, "'unlike' test");
+
+ is_deeply(
+ { a => 1, b => 2, c => {}},
+ { a => 1, b => 2, c => []},
+ "'is_deeply' test"
+ );
+};
+
+my $other_events = intercept {
+ diag("Testing Diag");
+ note("Testing Note");
+};
+
+my ($plan, $ok, $is, $isnt, $like, $unlike, $is_deeply) = grep {!$_->isa('Test2::Event::Diag')} @$main_events;
+my ($diag, $note) = @$other_events;
+
+ok($plan->isa('Test2::Event::Plan'), "got plan");
+is($plan->max, 8, "planned for 8 oks");
+
+ok($ok->isa('Test2::Event::Ok'), "got 'ok' result");
+is($ok->pass, 0, "'ok' test failed");
+
+ok($is->isa('Test2::Event::Ok'), "got 'is' result");
+is($is->pass, 0, "'is' test failed");
+
+ok($isnt->isa('Test2::Event::Ok'), "got 'isnt' result");
+is($isnt->pass, 0, "'isnt' test failed");
+
+ok($like->isa('Test2::Event::Ok'), "got 'like' result");
+is($like->pass, 0, "'like' test failed");
+
+ok($unlike->isa('Test2::Event::Ok'), "got 'unlike' result");
+is($unlike->pass, 0, "'unlike' test failed");
+
+ok($is_deeply->isa('Test2::Event::Ok'), "got 'is_deeply' result");
+is($is_deeply->pass, 0, "'is_deeply' test failed");
+
+ok($diag->isa('Test2::Event::Diag'), "got 'diag' result");
+is($diag->message, "Testing Diag", "got diag message");
+
+ok($note->isa('Test2::Event::Note'), "got 'note' result");
+is($note->message, "Testing Note", "got note message");
+
+my $events = intercept {
+ skip_all 'because';
+ ok(0, "should not see me");
+ die "should not happen";
+};
+
+is(@$events, 1, "1 event");
+ok($events->[0]->isa('Test2::Event::Plan'), "got plan");
+is($events->[0]->directive, 'SKIP', "plan is skip");
+is($events->[0]->reason, 'because', "skip reason");
+
+$events = intercept {
+ is(undef, "");
+ is("", undef);
+
+ isnt(undef, undef);
+
+ like(undef, qr//);
+ unlike(undef, qr//);
+};
+
+@$events = grep {!$_->isa('Test2::Event::Diag')} @$events;
+is(@$events, 5, "5 events");
+ok(!$_->pass, "undef test - should not pass") for @$events;
+
+sub tool { context() };
+
+my %params;
+my $ctx = context(level => -1);
+my $ictx;
+$events = intercept {
+ %params = @_;
+
+ $ictx = tool();
+ $ictx->ok(1, 'pass');
+ $ictx->ok(0, 'fail');
+ my $trace = Test2::Util::Trace->new(
+ frame => [ __PACKAGE__, __FILE__, __LINE__],
+ );
+ $ictx->hub->finalize($trace, 1);
+};
+
+@$events = grep {!$_->isa('Test2::Event::Diag')} @$events;
+
+is_deeply(
+ \%params,
+ {
+ context => { %$ctx, _is_canon => undef, _is_spawn => undef, _aborted => undef },
+ hub => $ictx->hub,
+ },
+ "Passed in some useful params"
+);
+
+ok($ctx != $ictx, "Different context inside intercept");
+
+is(@$events, 3, "got 3 events");
+
+$ctx->release;
+$ictx->release;
+
+# Test that a bail-out in an intercept does not exit.
+$events = intercept {
+ $ictx = tool();
+ $ictx->bail("The world ends");
+ $ictx->ok(0, "Should not see this");
+};
+
+is(@$events, 1, "got 1 event");
+ok($events->[0]->isa('Test2::Event::Bail'), "got the bail");
+
+$events = intercept {
+ $ictx = tool();
+};
+
+$ictx->release;
+
+like(
+ exception { intercept { die 'foo' } },
+ qr/foo/,
+ "Exception was propogated"
+);
+
+$events = intercept {
+ test2_stack()->top->set_no_ending(0);
+ ok(1);
+};
+
+is(@$events, 2, "2 events");
+ok($events->[0]->isa('Test2::Event::Ok'), "got ok");
+ok($events->[1]->isa('Test2::Event::Plan'), "finalize was called");
+
+$events = intercept {
+ test2_stack()->top->set_no_ending(0);
+ ok(1);
+ done_testing;
+};
+
+is(@$events, 2, "2 events");
+ok($events->[0]->isa('Test2::Event::Ok'), "got ok");
+ok($events->[1]->isa('Test2::Event::Plan'), "finalize was called (only 1 plan)");
+
+done_testing;
use strict;
use warnings;
package perlfaq;
-$perlfaq::VERSION = '5.021010';
+$perlfaq::VERSION = '5.021011';
1;
=head1 VERSION
-version 5.021010
+version 5.021011
=head1 DESCRIPTION
=head1 VERSION
-version 5.021010
+version 5.021011
=head1 DESCRIPTION
=item *
-The current leading implementation of Perl 6, Rakudo, released a "useful,
-usable, 'early adopter'" distribution of Perl 6 (called Rakudo Star) in July of
-2010. Please see L<http://rakudo.org/> for more information.
-
-=item *
-
There are really two tracks of perl development: a maintenance version
and an experimental version. The maintenance versions are stable, and
have an even number as the minor release (i.e. perl5.18.x, where 18 is the
=head2 What is Perl 6?
-Perl 6 was I<originally> described as the community's rewrite of Perl 5.
-Development started in 2002; syntax and design work continue to this day.
-As the language has evolved, it has become clear that it is a separate
-language, incompatible with Perl 5 but in the same language family.
+Perl 6 was I<originally> described as the community's rewrite of Perl 5,
+however as the language evolved, it became clear that it is a separate
+language, but in the same language family as Perl 5.
+
+Perl 6 is not intended primarily as a replacement for Perl 5, but as its
+own thing - and libraries exist to allow you to call Perl 5 code from Perl
+6 programs and vice versa.
Contrary to popular belief, Perl 6 and Perl 5 peacefully coexist with one
another. Perl 6 has proven to be a fascinating source of ideas for those
using Perl 5 (the L<Moose> object system is a well-known example). There is
overlap in the communities, and this overlap fosters the tradition of sharing
-and borrowing that have been instrumental to Perl's success. The current
-leading implementation of Perl 6 is Rakudo, and you can learn more about
-it at L<http://rakudo.org>.
+and borrowing that have been instrumental to Perl's success.
-If you want to learn more about Perl 6, or have a desire to help in
-the crusade to make Perl a better place then read the Perl 6 developers
+If you want to learn more about Perl 6 read the Perl 6 developers
page at L<http://www.perl6.org/> and get involved.
"We're really serious about reinventing everything that needs reinventing."
=head1 VERSION
-version 5.021010
+version 5.021011
=head1 DESCRIPTION
=head1 VERSION
-version 5.021010
+version 5.021011
=head1 DESCRIPTION
environment (IDE) for creating, testing, and debugging Perl scripts;
the tool runs on Windows 9x/NT/2000/XP or later.
+=item IntelliJ IDEA
+
+L<https://plugins.jetbrains.com/plugin/7796>
+
+Camelcade plugin provides Perl5 support in IntelliJ IDEA and other JetBrains IDEs.
+
=item Kephra
L<http://kephra.sf.net>
=head1 VERSION
-version 5.021010
+version 5.021011
=head1 DESCRIPTION
=head2 How do I determine whether a scalar is a number/whole/integer/float?
Assuming that you don't care about IEEE notations like "NaN" or
-"Infinity", you probably just want to use a regular expression:
+"Infinity", you probably just want to use a regular expression (see also
+L<perlretut> and L<perlre>):
use 5.010;
- given( $number ) {
- when( /\D/ )
- { say "\thas nondigits"; continue }
- when( /^\d+\z/ )
- { say "\tis a whole number"; continue }
- when( /^-?\d+\z/ )
- { say "\tis an integer"; continue }
- when( /^[+-]?\d+\z/ )
- { say "\tis a +/- integer"; continue }
- when( /^-?(?:\d+\.?|\.\d)\d*\z/ )
- { say "\tis a real number"; continue }
- when( /^[+-]?(?=\.?\d)\d*\.?\d*(?:e[+-]?\d+)?\z/i)
- { say "\tis a C float" }
- }
+ if ( /\D/ )
+ { say "\thas nondigits"; }
+ if ( /^\d+\z/ )
+ { say "\tis a whole number"; }
+ if ( /^-?\d+\z/ )
+ { say "\tis an integer"; }
+ if ( /^[+-]?\d+\z/ )
+ { say "\tis a +/- integer"; }
+ if ( /^-?(?:\d+\.?|\.\d)\d*\z/ )
+ { say "\tis a real number"; }
+ if ( /^[+-]?(?=\.?\d)\d*\.?\d*(?:e[+-]?\d+)?\z/i )
+ { say "\tis a C float" }
There are also some commonly used modules for the task.
L<Scalar::Util> (distributed with 5.8) provides access to perl's
=head1 VERSION
-version 5.021010
+version 5.021011
=head1 DESCRIPTION
=head1 VERSION
-version 5.021010
+version 5.021011
=head1 DESCRIPTION
=head1 VERSION
-version 5.021010
+version 5.021011
=head1 DESCRIPTION
=head1 VERSION
-version 5.021010
+version 5.021011
=head1 DESCRIPTION
=head1 VERSION
-version 5.021010
+version 5.021011
=head1 DESCRIPTION
=head1 VERSION
-version 5.021010
+version 5.021011
=head1 DESCRIPTION
}
}
-our $VERSION = '1.40';
+our $VERSION = '1.41';
$VERSION =~ tr/_//d;
our $MaxEvalLen = 0;
eval {
CORE::die;
};
- if($@ =~ /^Died at .*(, <.*?> line \d+).$/ ) {
+ if($@ =~ /^Died at .*(, <.*?> (?:line|chunk) \d+).$/ ) {
$mess .= $1;
}
}
use Carp ();
-our $VERSION = '1.40';
+our $VERSION = '1.41';
$VERSION =~ tr/_//d;
# Carp::Heavy was merged into Carp in version 1.12. Any mismatched versions
use Config;
use IPC::Open3 1.0103 qw(open3);
-use Test::More tests => 66;
+use Test::More tests => 67;
sub runperl {
my(%args) = @_;
is $@, "heek at ".__FILE__." line ".(__LINE__-2).", <DATA> line 2.\n",
'last handle line num is mentioned';
+# [cpan #100183]
+{
+ local $/ = \6;
+ <XD::DATA>;
+ eval { croak 'jeek' };
+ $@ =~ s/\n.*//; # just check first line
+ is $@, "jeek at ".__FILE__." line ".(__LINE__-2).", <DATA> chunk 3.\n",
+ 'last handle chunk num is mentioned';
+}
+
SKIP:
{
skip "IPC::Open3::open3 needs porting", 1 if $Is_VMS;
1
2
3
+abcdefghijklmnopqrstuvwxyz
-
package Locale::Maketext;
use strict;
use vars qw( @ISA $VERSION $MATCH_SUPERS $USING_LANGUAGE_TAGS
}
-$VERSION = '1.26';
+$VERSION = '1.27';
@ISA = ();
$MATCH_SUPERS = 1;
#--------------------------------------------------------------------------
+sub blacklist {
+ my ( $handle, @methods ) = @_;
+
+ unless ( defined $handle->{'blacklist'} ) {
+ no strict 'refs';
+
+ # Don't let people call methods they're not supposed to from maketext.
+ # Explicitly exclude all methods in this package that start with an
+ # underscore on principle.
+ $handle->{'blacklist'} = {
+ map { $_ => 1 } (
+ qw/
+ blacklist
+ encoding
+ fail_with
+ failure_handler_auto
+ fallback_language_classes
+ fallback_languages
+ get_handle
+ init
+ language_tag
+ maketext
+ new
+ whitelist
+ /, grep { /^_/ } keys %{ __PACKAGE__ . "::" }
+ ),
+ };
+ }
+
+ if ( scalar @methods ) {
+ $handle->{'blacklist'} = { %{ $handle->{'blacklist'} }, map { $_ => 1 } @methods };
+ }
+
+ delete $handle->{'_external_lex_cache'};
+ return;
+}
+
+sub whitelist {
+ my ( $handle, @methods ) = @_;
+ if ( scalar @methods ) {
+ $handle->{'whitelist'} = {} unless defined $handle->{'whitelist'};
+ $handle->{'whitelist'} = { %{ $handle->{'whitelist'} }, map { $_ => 1 } @methods };
+ }
+
+ delete $handle->{'_external_lex_cache'};
+ return;
+}
+
+#--------------------------------------------------------------------------
+
sub failure_handler_auto {
# Meant to be used like:
# $handle->fail_with('failure_handler_auto')
# Nothing fancy!
my $class = ref($_[0]) || $_[0];
my $handle = bless {}, $class;
+ $handle->blacklist;
$handle->init;
return $handle;
}
# on strings that don't need compiling.
return \"$string_to_compile" if($string_to_compile !~ m/[\[~\]]/ms); # return a string ref if chars [~] are not in the string
- my $target = ref($_[0]) || $_[0];
+ my $handle = $_[0];
my(@code);
my(@c) = (''); # "chunks" -- scratch.
# preceding literal.
if($in_group) {
if($1 eq '') {
- $target->_die_pointing($string_to_compile, 'Unterminated bracket group');
+ $handle->_die_pointing($string_to_compile, 'Unterminated bracket group');
}
else {
- $target->_die_pointing($string_to_compile, 'You can\'t nest bracket groups');
+ $handle->_die_pointing($string_to_compile, 'You can\'t nest bracket groups');
}
}
else {
push @code, ' (';
}
elsif($m =~ /^\w+$/s
- # exclude anything fancy, especially fully-qualified module names
+ && !$handle->{'blacklist'}{$m}
+ && ( !defined $handle->{'whitelist'} || $handle->{'whitelist'}{$m} )
+ # exclude anything fancy and restrict to the whitelist/blacklist.
) {
push @code, ' $_[0]->' . $m . '(';
}
else {
# TODO: implement something? or just too icky to consider?
- $target->_die_pointing(
+ $handle->_die_pointing(
$string_to_compile,
"Can't use \"$m\" as a method name in bracket group",
2 + length($c[-1])
push @c, '';
}
else {
- $target->_die_pointing($string_to_compile, q{Unbalanced ']'});
+ $handle->_die_pointing($string_to_compile, q{Unbalanced ']'});
}
}
sub _die_pointing {
# This is used by _compile to throw a fatal error
- my $target = shift; # class name
- # ...leaving $_[0] the error-causing text, and $_[1] the error message
+ my $target = shift;
+ $target = ref($target) || $target; # class name
+ # ...leaving $_[0] the error-causing text, and $_[1] the error message
my $i = index($_[0], "\n");
These two methods are discussed in the section "Controlling
Lookup Failure".
+=item $lh->blacklist(@list)
+
+=item $lh->whitelist(@list)
+
+These methods are discussed in the section "Bracket Notation
+Security".
+
=back
=head2 Utility Methods
to nest bracket groups, but you are welcome to email me with
convincing (real-life) arguments to the contrary.
+=head1 BRACKET NOTATION SECURITY
+
+Locale::Maketext does not use any special syntax to differentiate
+bracket notation methods from normal class or object methods. This
+design makes it vulnerable to format string attacks whenever it is
+used to process strings provided by untrusted users.
+
+Locale::Maketext does support blacklist and whitelist functionality
+to limit which methods may be called as bracket notation methods.
+
+By default, Locale::Maketext blacklists all methods in the
+Locale::Maketext namespace that begin with the '_' character,
+and all methods which include Perl's namespace separator characters.
+
+The default blacklist for Locale::Maketext also prevents use of the
+following methods in bracket notation:
+
+ blacklist
+ encoding
+ fail_with
+ failure_handler_auto
+ fallback_language_classes
+ fallback_languages
+ get_handle
+ init
+ language_tag
+ maketext
+ new
+ whitelist
+
+This list can be extended by either blacklisting additional "known bad"
+methods, or whitelisting only "known good" methods.
+
+To prevent specific methods from being called in bracket notation, use
+the blacklist() method:
+
+ my $lh = MyProgram::L10N->get_handle();
+ $lh->blacklist(qw{my_internal_method my_other_method});
+ $lh->maketext('[my_internal_method]'); # dies
+
+To limit the allowed bracked notation methods to a specific list, use the
+whitelist() method:
+
+ my $lh = MyProgram::L10N->get_handle();
+ $lh->whitelist('numerate', 'numf');
+ $lh->maketext('[_1] [numerate, _1,shoe,shoes]', 12); # works
+ $lh->maketext('[my_internal_method]'); # dies
+
+The blacklist() and whitelist() methods extend their internal lists
+whenever they are called. To reset the blacklist or whitelist, create
+a new maketext object.
+
+ my $lh = MyProgram::L10N->get_handle();
+ $lh->blacklist('numerate');
+ $lh->blacklist('numf');
+ $lh->maketext('[_1] [numerate,_1,shoe,shoes]', 12); # dies
+
+For lexicons that use an internal cache, translations which have already
+been cached in their compiled form are not affected by subsequent changes
+to the whitelist or blacklist settings. Lexicons that use an external
+cache will have their cache cleared whenever the whitelist of blacklist
+setings change. The difference between the two types of caching is explained
+in the "Readonly Lexicons" section.
+
+Methods disallowed by the blacklist cannot be permitted by the
+whitelist.
+
=head1 AUTO LEXICONS
If maketext goes to look in an individual %Lexicon for an entry
--- /dev/null
+#!/usr/bin/perl -Tw
+
+use strict;
+use warnings;
+use Test::More tests => 17;
+
+BEGIN {
+ use_ok("Locale::Maketext");
+}
+
+{
+
+ package MyTestLocale;
+ no warnings 'once';
+
+ @MyTestLocale::ISA = qw(Locale::Maketext);
+ %MyTestLocale::Lexicon = ();
+}
+
+{
+
+ package MyTestLocale::en;
+ no warnings 'once';
+
+ @MyTestLocale::en::ISA = qw(MyTestLocale);
+
+ %MyTestLocale::en::Lexicon = ( '_AUTO' => 1 );
+
+ sub custom_handler {
+ return "custom_handler_response";
+ }
+
+ sub _internal_method {
+ return "_internal_method_response";
+ }
+
+ sub new {
+ my ( $class, @args ) = @_;
+ my $lh = $class->SUPER::new(@args);
+ $lh->{use_external_lex_cache} = 1;
+ return $lh;
+ }
+}
+
+my $lh = MyTestLocale->get_handle('en');
+my $res;
+
+# get_handle blocked by default
+$res = eval { $lh->maketext('[get_handle,en]') };
+is( $res, undef, 'no return value from blocked expansion' );
+like( $@, qr/Can't use .* as a method name/, 'get_handle blocked in bracket notation by default blacklist' );
+
+# _ambient_langprefs blocked by default
+$res = eval { $lh->maketext('[_ambient_langprefs]') };
+is( $res, undef, 'no return value from blocked expansion' );
+like( $@, qr/Can't use .* as a method name/, '_ambient_langprefs blocked in bracket notation by default blacklist' );
+
+# _internal_method not blocked by default
+$res = eval { $lh->maketext('[_internal_method]') };
+is( $res, "_internal_method_response", '_internal_method allowed in bracket notation by default blacklist' );
+is( $@, '', 'no exception thrown by use of _internal_method under default blacklist' );
+
+# sprintf not blocked by default
+$res = eval { $lh->maketext('[sprintf,%s,hello]') };
+is( $res, "hello", 'sprintf allowed in bracket notation by default blacklist' );
+is( $@, '', 'no exception thrown by use of sprintf under default blacklist' );
+
+# blacklisting sprintf and numerate
+$lh->blacklist( 'sprintf', 'numerate' );
+
+# sprintf blocked by custom blacklist
+$res = eval { $lh->maketext('[sprintf,%s,hello]') };
+is( $res, undef, 'no return value from blocked expansion' );
+like( $@, qr/Can't use .* as a method name/, 'sprintf blocked in bracket notation by custom blacklist' );
+
+# blacklisting numf and _internal_method
+$lh->blacklist('numf');
+$lh->blacklist('_internal_method');
+
+# sprintf blocked by custom blacklist
+$res = eval { $lh->maketext('[sprintf,%s,hello]') };
+is( $res, undef, 'no return value from blocked expansion' );
+like( $@, qr/Can't use .* as a method name/, 'sprintf blocked in bracket notation by custom blacklist after extension of blacklist' );
+
+# _internal_method blocked by custom blacklist
+$res = eval { $lh->maketext('[_internal_method]') };
+is( $res, undef, 'no return value from blocked expansion' );
+like( $@, qr/Can't use .* as a method name/, 'sprintf blocked in bracket notation by custom blacklist after extension of blacklist' );
+
+# custom_handler not in default or custom blacklist
+$res = eval { $lh->maketext('[custom_handler]') };
+is( $res, "custom_handler_response", 'custom_handler allowed in bracket notation by default and custom blacklists' );
+is( $@, '', 'no exception thrown by use of custom_handler under default and custom blacklists' );
--- /dev/null
+#!/usr/bin/perl -Tw
+
+use strict;
+use warnings;
+use Test::More tests => 17;
+
+BEGIN {
+ use_ok("Locale::Maketext");
+}
+
+{
+
+ package MyTestLocale;
+ no warnings 'once';
+
+ @MyTestLocale::ISA = qw(Locale::Maketext);
+ %MyTestLocale::Lexicon = ();
+}
+
+{
+
+ package MyTestLocale::en;
+ no warnings 'once';
+
+ @MyTestLocale::en::ISA = qw(MyTestLocale);
+
+ %MyTestLocale::en::Lexicon = ( '_AUTO' => 1 );
+
+ sub custom_handler {
+ return "custom_handler_response";
+ }
+
+ sub _internal_method {
+ return "_internal_method_response";
+ }
+
+ sub new {
+ my ( $class, @args ) = @_;
+ my $lh = $class->SUPER::new(@args);
+ $lh->{use_external_lex_cache} = 1;
+ return $lh;
+ }
+}
+
+my $lh = MyTestLocale->get_handle('en');
+my $res;
+
+# _internal_method not blocked by default
+$res = eval { $lh->maketext('[_internal_method]') };
+is( $res, "_internal_method_response", '_internal_method allowed when no whitelist defined' );
+is( $@, '', 'no exception thrown by use of _internal_method without whitelist setting' );
+
+# whitelisting sprintf
+$lh->whitelist('sprintf');
+
+# _internal_method blocked by whitelist
+$res = eval { $lh->maketext('[_internal_method]') };
+is( $res, undef, 'no return value from blocked expansion' );
+like( $@, qr/Can't use .* as a method name/, '_internal_method blocked in bracket notation by whitelist' );
+
+# sprintf allowed by whitelist
+$res = eval { $lh->maketext('[sprintf,%s,hello]') };
+is( $res, "hello", 'sprintf allowed in bracket notation by whitelist' );
+is( $@, '', 'no exception thrown by use of sprintf with whitelist' );
+
+# custom_handler blocked by whitelist
+$res = eval { $lh->maketext('[custom_handler]') };
+is( $res, undef, 'no return value from blocked expansion' );
+like( $@, qr/Can't use .* as a method name/, 'custom_handler blocked in bracket notation by whitelist' );
+
+# adding custom_handler to whitelist
+$lh->whitelist('custom_handler');
+
+# sprintf still allowed by whitelist
+$res = eval { $lh->maketext('[sprintf,%s,hello]') };
+is( $res, "hello", 'sprintf allowed in bracket notation by whitelist' );
+is( $@, '', 'no exception thrown by use of sprintf with whitelist' );
+
+# custom_handler allowed by whitelist
+$res = eval { $lh->maketext('[custom_handler]') };
+is( $res, "custom_handler_response", 'custom_handler allowed in bracket notation by whitelist' );
+is( $@, '', 'no exception thrown by use of custom_handler with whitelist' );
+
+# _internal_method blocked by whitelist
+$res = eval { $lh->maketext('[_internal_method]') };
+is( $res, undef, 'no return value from blocked expansion' );
+like( $@, qr/Can't use .* as a method name/, '_internal_method blocked in bracket notation by whitelist' );
+
+# adding fail_with to whitelist
+$lh->whitelist('fail_with');
+
+# fail_with still blocked by blacklist
+$res = eval { $lh->maketext('[fail_with,xyzzy]') };
+is( $res, undef, 'no return value from blocked expansion' );
+like( $@, qr/Can't use .* as a method name/, 'fail_with blocked in bracket notation by blacklist even when whitelisted' );
+
+5.20160520
+ - fixed edge-case checking in is_core() (checking for a specific
+ version of a module returned false for the first perl release
+ that contained it)
+ - Updated for v5.25.1
+
5.20160429
- Updated for v5.22.2
5.20160320
- - Updated vor v5.23.9
+ - Updated for v5.23.9
5.20160228
- [perl #127624] corelist: wrong Digest::SHA version in 5.18.4
%bug_tracker %deprecated %delta/;
use Module::CoreList::TieHashDelta;
use version;
-$VERSION = '5.20160507';
+$VERSION = '5.20160520';
sub _released_order { # Sort helper, to make '?' sort after everything else
(substr($released{$a}, 0, 1) eq "?")
5.022002 => '2016-04-29',
5.024000 => '2016-05-09',
5.025000 => '2016-05-09',
+ 5.025001 => '2016-05-20',
);
for my $version ( sort { $a <=> $b } keys %released ) {
'Module::CoreList::TieHashDelta'=> '5.021001_01',
'Module::CoreList::Utils'=> '5.021001_01',
'Module::Metadata' => '1.000024',
- 'Module::Metadata::corpus::BOMTest::UTF16BE'=> undef,
- 'Module::Metadata::corpus::BOMTest::UTF16LE'=> undef,
- 'Module::Metadata::corpus::BOMTest::UTF8'=> '1',
'NDBM_File' => '1.13',
'Net::Config' => '1.14',
'Net::SMTP' => '2.34',
removed => {
}
},
+ 5.025001 => {
+ delta_from => 5.025,
+ changed => {
+ 'Archive::Tar' => '2.08',
+ 'Archive::Tar::Constant'=> '2.08',
+ 'Archive::Tar::File' => '2.08',
+ 'B::Op_private' => '5.025001',
+ 'Carp' => '1.41',
+ 'Carp::Heavy' => '1.41',
+ 'Config' => '5.025001',
+ 'Config::Perl::V' => '0.26',
+ 'DB_File' => '1.838',
+ 'Digest::MD5' => '2.55',
+ 'IPC::Cmd' => '0.94',
+ 'IPC::Msg' => '2.07',
+ 'IPC::Semaphore' => '2.07',
+ 'IPC::SharedMem' => '2.07',
+ 'IPC::SysV' => '2.07',
+ 'List::Util' => '1.45_01',
+ 'List::Util::XS' => '1.45_01',
+ 'Locale::Codes' => '3.38',
+ 'Locale::Codes::Constants'=> '3.38',
+ 'Locale::Codes::Country'=> '3.38',
+ 'Locale::Codes::Country_Codes'=> '3.38',
+ 'Locale::Codes::Country_Retired'=> '3.38',
+ 'Locale::Codes::Currency'=> '3.38',
+ 'Locale::Codes::Currency_Codes'=> '3.38',
+ 'Locale::Codes::Currency_Retired'=> '3.38',
+ 'Locale::Codes::LangExt'=> '3.38',
+ 'Locale::Codes::LangExt_Codes'=> '3.38',
+ 'Locale::Codes::LangExt_Retired'=> '3.38',
+ 'Locale::Codes::LangFam'=> '3.38',
+ 'Locale::Codes::LangFam_Codes'=> '3.38',
+ 'Locale::Codes::LangFam_Retired'=> '3.38',
+ 'Locale::Codes::LangVar'=> '3.38',
+ 'Locale::Codes::LangVar_Codes'=> '3.38',
+ 'Locale::Codes::LangVar_Retired'=> '3.38',
+ 'Locale::Codes::Language'=> '3.38',
+ 'Locale::Codes::Language_Codes'=> '3.38',
+ 'Locale::Codes::Language_Retired'=> '3.38',
+ 'Locale::Codes::Script' => '3.38',
+ 'Locale::Codes::Script_Codes'=> '3.38',
+ 'Locale::Codes::Script_Retired'=> '3.38',
+ 'Locale::Country' => '3.38',
+ 'Locale::Currency' => '3.38',
+ 'Locale::Language' => '3.38',
+ 'Locale::Maketext' => '1.27',
+ 'Locale::Script' => '3.38',
+ 'Module::CoreList' => '5.20160520',
+ 'Module::CoreList::TieHashDelta'=> '5.20160520',
+ 'Module::CoreList::Utils'=> '5.20160520',
+ 'Module::Metadata' => '1.000032',
+ 'POSIX' => '1.69',
+ 'Scalar::Util' => '1.45_01',
+ 'Sub::Util' => '1.45_01',
+ 'Sys::Syslog' => '0.34',
+ 'Term::ANSIColor' => '4.05',
+ 'Test2' => '1.302015',
+ 'Test2::API' => '1.302015',
+ 'Test2::API::Breakage' => '1.302015',
+ 'Test2::API::Context' => '1.302015',
+ 'Test2::API::Instance' => '1.302015',
+ 'Test2::API::Stack' => '1.302015',
+ 'Test2::Event' => '1.302015',
+ 'Test2::Event::Bail' => '1.302015',
+ 'Test2::Event::Diag' => '1.302015',
+ 'Test2::Event::Exception'=> '1.302015',
+ 'Test2::Event::Note' => '1.302015',
+ 'Test2::Event::Ok' => '1.302015',
+ 'Test2::Event::Plan' => '1.302015',
+ 'Test2::Event::Skip' => '1.302015',
+ 'Test2::Event::Subtest' => '1.302015',
+ 'Test2::Event::Waiting' => '1.302015',
+ 'Test2::Formatter' => '1.302015',
+ 'Test2::Formatter::TAP' => '1.302015',
+ 'Test2::Hub' => '1.302015',
+ 'Test2::Hub::Interceptor'=> '1.302015',
+ 'Test2::Hub::Interceptor::Terminator'=> '1.302015',
+ 'Test2::Hub::Subtest' => '1.302015',
+ 'Test2::IPC' => '1.302015',
+ 'Test2::IPC::Driver' => '1.302015',
+ 'Test2::IPC::Driver::Files'=> '1.302015',
+ 'Test2::Util' => '1.302015',
+ 'Test2::Util::ExternalMeta'=> '1.302015',
+ 'Test2::Util::HashBase' => '1.302015',
+ 'Test2::Util::Trace' => '1.302015',
+ 'Test::Builder' => '1.302015',
+ 'Test::Builder::Formatter'=> '1.302015',
+ 'Test::Builder::Module' => '1.302015',
+ 'Test::Builder::Tester' => '1.302015',
+ 'Test::Builder::Tester::Color'=> '1.302015',
+ 'Test::Builder::TodoDiag'=> '1.302015',
+ 'Test::More' => '1.302015',
+ 'Test::Simple' => '1.302015',
+ 'Test::Tester' => '1.302015',
+ 'Test::Tester::Capture' => '1.302015',
+ 'Test::Tester::CaptureRunner'=> '1.302015',
+ 'Test::Tester::Delegate'=> '1.302015',
+ 'Test::use::ok' => '1.302015',
+ 'XS::APItest' => '0.81',
+ '_charnames' => '1.44',
+ 'charnames' => '1.44',
+ 'ok' => '1.302015',
+ 'perlfaq' => '5.021011',
+ 're' => '0.33',
+ 'threads' => '2.08',
+ 'threads::shared' => '1.52',
+ },
+ removed => {
+ }
+ },
);
sub is_core
}
RELEASE:
foreach my $prn (@releases) {
- next RELEASE if $prn <= $first_release;
+ next RELEASE if $prn < $first_release;
last RELEASE if $prn > $perl_version;
next unless defined(my $next_module_version
= $delta{$prn}->{changed}->{$module});
removed => {
}
},
+ 5.025001 => {
+ delta_from => 5.025,
+ changed => {
+ },
+ removed => {
+ }
+ },
);
for my $version (sort { $a <=> $b } keys %deprecated) {
'Module::Load::Conditional'=> 'cpan',
'Module::Loaded' => 'cpan',
'Module::Metadata' => 'cpan',
- 'Module::Metadata::corpus::BOMTest::UTF16BE'=> 'cpan',
- 'Module::Metadata::corpus::BOMTest::UTF16LE'=> 'cpan',
- 'Module::Metadata::corpus::BOMTest::UTF8'=> 'cpan',
'NEXT' => 'cpan',
'Net::Cmd' => 'cpan',
'Net::Config' => 'cpan',
'TAP::Parser::YAMLish::Writer'=> 'cpan',
'Term::ANSIColor' => 'cpan',
'Term::Cap' => 'cpan',
+ 'Test2' => 'cpan',
+ 'Test2::API' => 'cpan',
+ 'Test2::API::Breakage' => 'cpan',
+ 'Test2::API::Context' => 'cpan',
+ 'Test2::API::Instance' => 'cpan',
+ 'Test2::API::Stack' => 'cpan',
+ 'Test2::Event' => 'cpan',
+ 'Test2::Event::Bail' => 'cpan',
+ 'Test2::Event::Diag' => 'cpan',
+ 'Test2::Event::Exception'=> 'cpan',
+ 'Test2::Event::Note' => 'cpan',
+ 'Test2::Event::Ok' => 'cpan',
+ 'Test2::Event::Plan' => 'cpan',
+ 'Test2::Event::Skip' => 'cpan',
+ 'Test2::Event::Subtest' => 'cpan',
+ 'Test2::Event::Waiting' => 'cpan',
+ 'Test2::Formatter' => 'cpan',
+ 'Test2::Formatter::TAP' => 'cpan',
+ 'Test2::Hub' => 'cpan',
+ 'Test2::Hub::Interceptor'=> 'cpan',
+ 'Test2::Hub::Interceptor::Terminator'=> 'cpan',
+ 'Test2::Hub::Subtest' => 'cpan',
+ 'Test2::IPC' => 'cpan',
+ 'Test2::IPC::Driver' => 'cpan',
+ 'Test2::IPC::Driver::Files'=> 'cpan',
+ 'Test2::Util' => 'cpan',
+ 'Test2::Util::ExternalMeta'=> 'cpan',
+ 'Test2::Util::HashBase' => 'cpan',
+ 'Test2::Util::Trace' => 'cpan',
'Test::Builder' => 'cpan',
+ 'Test::Builder::Formatter'=> 'cpan',
'Test::Builder::IO::Scalar'=> 'cpan',
'Test::Builder::Module' => 'cpan',
'Test::Builder::Tester' => 'cpan',
'Test::Builder::Tester::Color'=> 'cpan',
+ 'Test::Builder::TodoDiag'=> 'cpan',
'Test::Harness' => 'cpan',
'Test::More' => 'cpan',
'Test::Simple' => 'cpan',
'Module::Load::Conditional'=> undef,
'Module::Loaded' => undef,
'Module::Metadata' => 'https://rt.cpan.org/Public/Dist/Display.html?Name=Module-Metadata',
- 'Module::Metadata::corpus::BOMTest::UTF16BE'=> undef,
- 'Module::Metadata::corpus::BOMTest::UTF16LE'=> undef,
- 'Module::Metadata::corpus::BOMTest::UTF8'=> undef,
'NEXT' => undef,
'Net::Cmd' => undef,
'Net::Config' => undef,
'TAP::Parser::YAMLish::Writer'=> 'http://rt.cpan.org/Public/Dist/Display.html?Name=Test-Harness',
'Term::ANSIColor' => 'https://rt.cpan.org/Dist/Display.html?Name=Term-ANSIColor',
'Term::Cap' => undef,
- 'Test::Builder' => 'http://github.com/Test-More/test-more/issues/',
- 'Test::Builder::IO::Scalar'=> 'http://github.com/Test-More/test-more/issues/',
- 'Test::Builder::Module' => 'http://github.com/Test-More/test-more/issues/',
- 'Test::Builder::Tester' => 'http://github.com/Test-More/test-more/issues/',
- 'Test::Builder::Tester::Color'=> 'http://github.com/Test-More/test-more/issues/',
+ 'Test2' => 'http://github.com/Test-More/test-more/issues',
+ 'Test2::API' => 'http://github.com/Test-More/test-more/issues',
+ 'Test2::API::Breakage' => 'http://github.com/Test-More/test-more/issues',
+ 'Test2::API::Context' => 'http://github.com/Test-More/test-more/issues',
+ 'Test2::API::Instance' => 'http://github.com/Test-More/test-more/issues',
+ 'Test2::API::Stack' => 'http://github.com/Test-More/test-more/issues',
+ 'Test2::Event' => 'http://github.com/Test-More/test-more/issues',
+ 'Test2::Event::Bail' => 'http://github.com/Test-More/test-more/issues',
+ 'Test2::Event::Diag' => 'http://github.com/Test-More/test-more/issues',
+ 'Test2::Event::Exception'=> 'http://github.com/Test-More/test-more/issues',
+ 'Test2::Event::Note' => 'http://github.com/Test-More/test-more/issues',
+ 'Test2::Event::Ok' => 'http://github.com/Test-More/test-more/issues',
+ 'Test2::Event::Plan' => 'http://github.com/Test-More/test-more/issues',
+ 'Test2::Event::Skip' => 'http://github.com/Test-More/test-more/issues',
+ 'Test2::Event::Subtest' => 'http://github.com/Test-More/test-more/issues',
+ 'Test2::Event::Waiting' => 'http://github.com/Test-More/test-more/issues',
+ 'Test2::Formatter' => 'http://github.com/Test-More/test-more/issues',
+ 'Test2::Formatter::TAP' => 'http://github.com/Test-More/test-more/issues',
+ 'Test2::Hub' => 'http://github.com/Test-More/test-more/issues',
+ 'Test2::Hub::Interceptor'=> 'http://github.com/Test-More/test-more/issues',
+ 'Test2::Hub::Interceptor::Terminator'=> 'http://github.com/Test-More/test-more/issues',
+ 'Test2::Hub::Subtest' => 'http://github.com/Test-More/test-more/issues',
+ 'Test2::IPC' => 'http://github.com/Test-More/test-more/issues',
+ 'Test2::IPC::Driver' => 'http://github.com/Test-More/test-more/issues',
+ 'Test2::IPC::Driver::Files'=> 'http://github.com/Test-More/test-more/issues',
+ 'Test2::Util' => 'http://github.com/Test-More/test-more/issues',
+ 'Test2::Util::ExternalMeta'=> 'http://github.com/Test-More/test-more/issues',
+ 'Test2::Util::HashBase' => 'http://github.com/Test-More/test-more/issues',
+ 'Test2::Util::Trace' => 'http://github.com/Test-More/test-more/issues',
+ 'Test::Builder' => 'http://github.com/Test-More/test-more/issues',
+ 'Test::Builder::Formatter'=> 'http://github.com/Test-More/test-more/issues',
+ 'Test::Builder::IO::Scalar'=> 'http://github.com/Test-More/test-more/issues',
+ 'Test::Builder::Module' => 'http://github.com/Test-More/test-more/issues',
+ 'Test::Builder::Tester' => 'http://github.com/Test-More/test-more/issues',
+ 'Test::Builder::Tester::Color'=> 'http://github.com/Test-More/test-more/issues',
+ 'Test::Builder::TodoDiag'=> 'http://github.com/Test-More/test-more/issues',
'Test::Harness' => 'http://rt.cpan.org/Public/Dist/Display.html?Name=Test-Harness',
- 'Test::More' => 'http://github.com/Test-More/test-more/issues/',
- 'Test::Simple' => 'http://github.com/Test-More/test-more/issues/',
- 'Test::Tester' => 'http://github.com/Test-More/test-more/issues/',
- 'Test::Tester::Capture' => 'http://github.com/Test-More/test-more/issues/',
- 'Test::Tester::CaptureRunner'=> 'http://github.com/Test-More/test-more/issues/',
- 'Test::Tester::Delegate'=> 'http://github.com/Test-More/test-more/issues/',
- 'Test::use::ok' => 'http://github.com/Test-More/test-more/issues/',
+ 'Test::More' => 'http://github.com/Test-More/test-more/issues',
+ 'Test::Simple' => 'http://github.com/Test-More/test-more/issues',
+ 'Test::Tester' => 'http://github.com/Test-More/test-more/issues',
+ 'Test::Tester::Capture' => 'http://github.com/Test-More/test-more/issues',
+ 'Test::Tester::CaptureRunner'=> 'http://github.com/Test-More/test-more/issues',
+ 'Test::Tester::Delegate'=> 'http://github.com/Test-More/test-more/issues',
+ 'Test::use::ok' => 'http://github.com/Test-More/test-more/issues',
'Text::Balanced' => undef,
'Text::ParseWords' => undef,
'Text::Tabs' => undef,
'bigrat' => undef,
'encoding' => undef,
'experimental' => 'http://rt.cpan.org/Public/Dist/Display.html?Name=experimental',
- 'ok' => 'http://github.com/Test-More/test-more/issues/',
+ 'ok' => 'http://github.com/Test-More/test-more/issues',
'parent' => undef,
'perlfaq' => 'https://github.com/perl-doc-cats/perlfaq/issues',
'version' => 'https://rt.cpan.org/Public/Dist/Display.html?Name=version',
use strict;
use vars qw($VERSION);
-$VERSION = '5.20160507';
+$VERSION = '5.20160520';
sub TIEHASH {
my ($class, $changed, $removed, $parent) = @_;
use Module::CoreList;
use Module::CoreList::TieHashDelta;
-$VERSION = '5.20160507';
+$VERSION = '5.20160520';
sub utilities {
my $perl = shift;
removed => {
}
},
+ 5.025001 => {
+ delta_from => 5.025000,
+ changed => {
+ },
+ removed => {
+ }
+ },
);
for my $version (sort { $a <=> $b } keys %delta) {
#!perl -w
use strict;
use Module::CoreList;
-use Test::More tests => 38;
+use Test::More tests => 43;
BEGIN { require_ok('Module::CoreList'); }
ok(Module::CoreList::is_core('Pod::Plainer', undef, '5.012001') == 1, "Pod::Plainer was core in 5.12.1");
ok(Module::CoreList::is_core('Pod::Plainer', undef, '5.016003') == 0, "Pod::Plainer was removed in 5.13.1");
+ok(!Module::CoreList::is_core('File::Temp', 0, '5.006'), 'File::Temp is not in 5.006000');
+ok(Module::CoreList::is_core('File::Temp', 0, '5.006001'), 'File::Temp is in 5.006001');
+ok(!Module::CoreList::is_core('File::Temp', '0.12', '5.006'), 'File::Temp 0.12 is not in 5.006000');
+ok(Module::CoreList::is_core('File::Temp', '0.12', '5.006001'), 'File::Temp 0.12 is in 5.006001');
+ok(Module::CoreList::is_core('File::Temp', '0.12', '5.006002'), 'File::Temp 0.12 is in 5.006002');
+
+
# history of module 'encoding' in core
# version 1.00 included in 5.007003
# version 1.35 included in 5.008
use Scalar::Util qw(reftype refaddr blessed);
-our $VERSION = '1.51'; # Please update the pod, too.
+our $VERSION = '1.52'; # Please update the pod, too.
my $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
=head1 VERSION
-This document describes threads::shared version 1.51
+This document describes threads::shared version 1.52
=head1 SYNOPSIS
=head1 SEE ALSO
-L<threads::shared> Discussion Forum on CPAN:
-L<http://www.cpanforum.com/dist/threads-shared>
+threads::shared on MetaCPAN:
+L<https://metacpan.org/release/threads-shared>
+
+Code repository for CPAN distribution:
+L<https://github.com/Dual-Life/threads-shared>
L<threads>, L<perlthrtut>
Perl threads mailing list:
L<http://lists.perl.org/list/ithreads.html>
+Sample code in the I<examples> directory of this distribution on CPAN.
+
=head1 AUTHOR
Artur Bergman E<lt>sky AT crucially DOT netE<gt>
use strict;
use warnings;
-our $VERSION = '2.07';
+our $VERSION = '2.08';
my $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
=head1 VERSION
-This document describes threads version 2.07
+This document describes threads version 2.08
=head1 WARNING
=head1 SEE ALSO
-L<threads> Discussion Forum on CPAN:
-L<http://www.cpanforum.com/dist/threads>
+threads on MetaCPAN:
+L<https://metacpan.org/release/threads>
+
+Code repository for CPAN distribution:
+L<https://github.com/Dual-Life/threads>
L<threads::shared>, L<perlthrtut>
Stack size discussion:
L<http://www.perlmonks.org/?node_id=532956>
+Sample code in the I<examples> directory of this distribution on CPAN.
+
=head1 AUTHOR
Artur Bergman E<lt>sky AT crucially DOT netE<gt>
ok(! defined($rc), 'Exited: threads->exit()');
-run_perl(prog => 'use threads 2.07;' .
+run_perl(prog => 'use threads 2.08;' .
'threads->exit(86);' .
'exit(99);',
nolib => ($ENV{PERL_CORE}) ? 0 : 1,
ok(! defined($rc), 'Exited: $thr->set_thread_exit_only');
-run_perl(prog => 'use threads 2.07 qw(exit thread_only);' .
+run_perl(prog => 'use threads 2.08 qw(exit thread_only);' .
'threads->create(sub { exit(99); })->join();' .
'exit(86);',
nolib => ($ENV{PERL_CORE}) ? 0 : 1,
is($?>>8, 86, "'use threads 'exit' => 'thread_only'");
}
-my $out = run_perl(prog => 'use threads 2.07;' .
+my $out = run_perl(prog => 'use threads 2.08;' .
'threads->create(sub {' .
' exit(99);' .
'});' .
like($out, qr/1 finished and unjoined/, "exit(status) in thread");
-$out = run_perl(prog => 'use threads 2.07 qw(exit thread_only);' .
+$out = run_perl(prog => 'use threads 2.08 qw(exit thread_only);' .
'threads->create(sub {' .
' threads->set_thread_exit_only(0);' .
' exit(99);' .
like($out, qr/1 finished and unjoined/, "set_thread_exit_only(0)");
-run_perl(prog => 'use threads 2.07;' .
+run_perl(prog => 'use threads 2.08;' .
'threads->create(sub {' .
' $SIG{__WARN__} = sub { exit(99); };' .
' die();' .
# bugid #24165
-run_perl(prog => 'use threads 2.07;' .
+run_perl(prog => 'use threads 2.08;' .
'sub a{threads->create(shift)} $t = a sub{};' .
'$t->tid; $t->join; $t->tid',
nolib => ($ENV{PERL_CORE}) ? 0 : 1,
HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
+ (count < 0 ? -count : count);
while (hekp < endp) {
- if (HEK_LEN(*hekp)) {
+ if (*hekp) {
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)));
:
: proto.h: add __attribute__malloc__
:
-: b Binary backward compatibility; has an exported Perl_ implementation
-: but function is also normally a macro (i.e. has the "m" flag as well).
-: Backcompat functions ("b") can be anywhere, but if they are also
-: macros ("m") then they have no proto.h entries so must either be in
-: mathoms.c to get marked EXTERN_C (and skipped for -DNO_MATHOMS builds)
-: or else will require special attention to ensure they are marked
-: EXTERN_C (and then won't be automatically skipped for -DNO_MATHOMS
-: builds).
+: b Binary backward compatibility. This is used for functions which are
+: kept only to not have to change legacy applications that call them. If
+: there are no such legacy applications in a Perl installation for all
+: functions flagged with this, the installation can run Configure with the
+: -Accflags='-DNO_MATHOMS' parameter to not even compile them. If there
+: is a macro form of this function that provides equivalent functionality
+: (using a different implementation), also specify the 'm' flag. The 'b'
+: functions are normally moved to mathoms.c, but if circumstances dictate
+: otherwise, they can be anywhere, provided the whole function is wrapped
+: with
+: #ifndef NO_MATHOMS
+: ...
+: #endif
:
+: Note that this flag no longer automatically adds a 'Perl_' prefix to the
+: name. Additionally specify 'p' to do that.
+:
+: For functions, like wrappers, whose macro shortcut doesn't call the
+: function, but which, for whatever reason, aren't considered legacy-only,
+: use the 'o' flag
+:
+: This flag effectively causes nothing to happen if the perl interpreter
+: is compiled with -DNO_MATHOMS; otherwise these happen:
: add entry to the list of exported symbols;
-: don't define PERL_ARGS_ASSERT_FOO
+: create PERL_ARGS_ASSERT_FOO;
+: add embed.h entry (unless overridden by the 'm' flag)
:
: D Function is deprecated:
:
:
: m Implemented as a macro:
:
-: suppress proto.h entry (actually, not suppressed, but commented out)
+: suppress proto.h entry unless 'b' also specified (actually, not
+: suppressed, but commented out)
: suppress entry in the list of exported symbols
: suppress embed.h entry
:
: used in SAVEHINTS() and op.c
ApdR |HV * |hv_copy_hints_hv|NULLOK HV *const ohv
Ap |void |hv_delayfree_ent|NN HV *hv|NULLOK HE *entry
-Abmd |SV* |hv_delete |NULLOK HV *hv|NN const char *key|I32 klen \
+Abmdp |SV* |hv_delete |NULLOK HV *hv|NN const char *key|I32 klen \
|I32 flags
-Abmd |SV* |hv_delete_ent |NULLOK HV *hv|NN SV *keysv|I32 flags|U32 hash
-AbmdR |bool |hv_exists |NULLOK HV *hv|NN const char *key|I32 klen
-AbmdR |bool |hv_exists_ent |NULLOK HV *hv|NN SV *keysv|U32 hash
-Abmd |SV** |hv_fetch |NULLOK HV *hv|NN const char *key|I32 klen \
+Abmdp |SV* |hv_delete_ent |NULLOK HV *hv|NN SV *keysv|I32 flags|U32 hash
+AbmdRp |bool |hv_exists |NULLOK HV *hv|NN const char *key|I32 klen
+AbmdRp |bool |hv_exists_ent |NULLOK HV *hv|NN SV *keysv|U32 hash
+Abmdp |SV** |hv_fetch |NULLOK HV *hv|NN const char *key|I32 klen \
|I32 lval
-Abmd |HE* |hv_fetch_ent |NULLOK HV *hv|NN SV *keysv|I32 lval|U32 hash
+Abmdp |HE* |hv_fetch_ent |NULLOK HV *hv|NN SV *keysv|I32 lval|U32 hash
Ap |void* |hv_common |NULLOK HV *hv|NULLOK SV *keysv \
|NULLOK const char* key|STRLEN klen|int flags \
|int action|NULLOK SV *val|U32 hash
|U32 hash|NULLOK SV *value|U32 flags
Xpd |void |refcounted_he_free|NULLOK struct refcounted_he *he
Xpd |struct refcounted_he *|refcounted_he_inc|NULLOK struct refcounted_he *he
-Abmd |SV** |hv_store |NULLOK HV *hv|NULLOK const char *key \
+Apbmd |SV** |hv_store |NULLOK HV *hv|NULLOK const char *key \
|I32 klen|NULLOK SV *val|U32 hash
-Abmd |HE* |hv_store_ent |NULLOK HV *hv|NULLOK SV *key|NULLOK SV *val\
+Apbmd |HE* |hv_store_ent |NULLOK HV *hv|NULLOK SV *key|NULLOK SV *val\
|U32 hash
-AbmM |SV** |hv_store_flags |NULLOK HV *hv|NULLOK const char *key \
+ApbmM |SV** |hv_store_flags |NULLOK HV *hv|NULLOK const char *key \
|I32 klen|NULLOK SV *val|U32 hash|int flags
Amd |void |hv_undef |NULLOK HV *hv
poX |void |hv_undef_flags |NULLOK HV *hv|U32 flags
Ap |void |init_stacks
Ap |void |init_tm |NN struct tm *ptm
: Used in perly.y
-AnpPR |char* |instr |NN const char* big|NN const char* little
+AbmnpPR |char* |instr |NN const char* big|NN const char* little
: Used in sv.c
p |bool |io_close |NN IO* io|NULLOK GV *gv \
|bool not_implicit|bool warn_on_fail
Afp |char * |my_strftime |NN const char *fmt|int sec|int min|int hour|int mday|int mon|int year|int wday|int yday|int isdst
: Used in pp_ctl.c
p |void |my_unexec
-ADMnoPR |UV |NATIVE_TO_NEED |const UV enc|const UV ch
-ADMnoPR |UV |ASCII_TO_NEED |const UV enc|const UV ch
+AbDMnPR |UV |NATIVE_TO_NEED |const UV enc|const UV ch
+AbDMnPR |UV |ASCII_TO_NEED |const UV enc|const UV ch
Apa |OP* |newANONLIST |NULLOK OP* o
Apa |OP* |newANONHASH |NULLOK OP* o
Ap |OP* |newANONSUB |I32 floor|NULLOK OP* proto|NULLOK OP* block
Apda |OP* |newRANGE |I32 flags|NN OP* left|NN OP* right
Apda |OP* |newSLICEOP |I32 flags|NULLOK OP* subscript|NULLOK OP* listop
Apda |OP* |newSTATEOP |I32 flags|NULLOK char* label|NULLOK OP* o
-Abm |CV* |newSUB |I32 floor|NULLOK OP* o|NULLOK OP* proto \
+Apbm |CV* |newSUB |I32 floor|NULLOK OP* o|NULLOK OP* proto \
|NULLOK OP* block
p |CV * |newXS_len_flags|NULLOK const char *name|STRLEN len \
|NN XSUBADDR_t subaddr\
|NULLOK const char *const proto|U32 flags
Apd |CV* |newXS |NULLOK const char *name|NN XSUBADDR_t subaddr\
|NN const char *filename
-AmdbR |AV* |newAV
+ApmdbR |AV* |newAV
Apa |OP* |newAVREF |NN OP* o
Apda |OP* |newBINOP |I32 type|I32 flags|NULLOK OP* first|NULLOK OP* last
Apa |OP* |newCVREF |I32 flags|NULLOK OP* o
Apa |GV* |newGVgen_flags |NN const char* pack|U32 flags
Apa |OP* |newGVREF |I32 type|NULLOK OP* o
ApaR |OP* |newHVREF |NN OP* o
-AmdbR |HV* |newHV
+ApmdbR |HV* |newHV
ApaR |HV* |newHVhv |NULLOK HV *hv
Apabm |IO* |newIO
Apda |OP* |newLISTOP |I32 type|I32 flags|NULLOK OP* first|NULLOK OP* last
Apd |int |vcmp |NN SV *lhv|NN SV *rhv
: Used in pp_hot.c and pp_sys.c
p |PerlIO*|nextargv |NN GV* gv|bool nomagicopen
-AnpP |char* |ninstr |NN const char* big|NN const char* bigend \
+#ifdef HAS_MEMMEM
+AdnopP |char* |ninstr |NN const char* big|NN const char* bigend \
+ |NN const char* little|NN const char* lend
+#else
+AdnpP |char* |ninstr |NN const char* big|NN const char* bigend \
|NN const char* little|NN const char* lend
+#endif
Apd |void |op_free |NULLOK OP* arg
Mp |OP* |op_unscope |NULLOK OP* o
#ifdef PERL_CORE
#endif
Ap |void |pop_scope
Ap |void |push_scope
-Amb |OP* |ref |NULLOK OP* o|I32 type
+Apmb |OP* |ref |NULLOK OP* o|I32 type
#if defined(PERL_IN_OP_C)
s |OP* |refkids |NULLOK OP* o|I32 type
#endif
EXp |SV*|reg_qr_package|NN REGEXP * const rx
Anp |void |repeatcpy |NN char* to|NN const char* from|I32 len|IV count
-AnpP |char* |rninstr |NN const char* big|NN const char* bigend \
+AdnpP |char* |rninstr |NN const char* big|NN const char* bigend \
|NN const char* little|NN const char* lend
Ap |Sighandler_t|rsignal |int i|Sighandler_t t
: Used in pp_sys.c
#if defined(PERL_IN_SV_C)
s |bool |glob_2number |NN GV* const gv
#endif
-Amb |IV |sv_2iv |NN SV *sv
+Apmb |IV |sv_2iv |NN SV *sv
Apd |IV |sv_2iv_flags |NN SV *const sv|const I32 flags
Apd |SV* |sv_2mortal |NULLOK SV *const sv
Apd |NV |sv_2nv_flags |NN SV *const sv|const I32 flags
: Used in pp.c, pp_hot.c, sv.c
pMd |SV* |sv_2num |NN SV *const sv
-Amb |char* |sv_2pv |NN SV *sv|NULLOK STRLEN *lp
+Apmb |char* |sv_2pv |NN SV *sv|NULLOK STRLEN *lp
Apd |char* |sv_2pv_flags |NN SV *const sv|NULLOK STRLEN *const lp|const I32 flags
Apd |char* |sv_2pvutf8 |NN SV *sv|NULLOK STRLEN *const lp
Apd |char* |sv_2pvbyte |NN SV *sv|NULLOK STRLEN *const lp
Ap |char* |sv_pvn_nomg |NN SV* sv|NULLOK STRLEN* lp
-Amb |UV |sv_2uv |NN SV *sv
+Apmb |UV |sv_2uv |NN SV *sv
Apd |UV |sv_2uv_flags |NN SV *const sv|const I32 flags
Apd |IV |sv_iv |NN SV* sv
Apd |UV |sv_uv |NN SV* sv
Apd |void |sv_vcatpvf |NN SV *const sv|NN const char *const pat \
|NULLOK va_list *const args
Apd |void |sv_catpv |NN SV *const sv|NULLOK const char* ptr
-Amdb |void |sv_catpvn |NN SV *dsv|NN const char *sstr|STRLEN len
-Amdb |void |sv_catsv |NN SV *dstr|NULLOK SV *sstr
+Apmdb |void |sv_catpvn |NN SV *dsv|NN const char *sstr|STRLEN len
+Apmdb |void |sv_catsv |NN SV *dstr|NULLOK SV *sstr
Apd |void |sv_chop |NN SV *const sv|NULLOK const char *const ptr
: Used only in perl.c
pd |I32 |sv_clean_all
Apd |char* |sv_grow |NN SV *const sv|STRLEN newlen
Apd |void |sv_inc |NULLOK SV *const sv
Apd |void |sv_inc_nomg |NULLOK SV *const sv
-Amdb |void |sv_insert |NN SV *const bigstr|const STRLEN offset \
+Apmdb |void |sv_insert |NN SV *const bigstr|const STRLEN offset \
|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 \
Apd |void |sv_pos_b2u |NULLOK SV *const sv|NN I32 *const offsetp
Apd |STRLEN |sv_pos_b2u_flags|NN SV *const sv|STRLEN const offset \
|U32 flags
-Amdb |char* |sv_pvn_force |NN SV* sv|NULLOK STRLEN* lp
+Apmdb |char* |sv_pvn_force |NN SV* sv|NULLOK STRLEN* lp
Apd |char* |sv_pvutf8n_force|NN SV *const sv|NULLOK STRLEN *const lp
Apd |char* |sv_pvbyten_force|NN SV *const sv|NULLOK STRLEN *const lp
Apd |char* |sv_recode_to_utf8 |NN SV* sv|NN SV *encoding
Apd |void |sv_setpv |NN SV *const sv|NULLOK const char *const ptr
Apd |void |sv_setpvn |NN SV *const sv|NULLOK const char *const ptr|const STRLEN len
Xp |void |sv_sethek |NN SV *const sv|NULLOK const HEK *const hek
-Amdb |void |sv_setsv |NN SV *dstr|NULLOK SV *sstr
-Amdb |void |sv_taint |NN SV* sv
+Apmdb |void |sv_setsv |NN SV *dstr|NULLOK SV *sstr
+Apmdb |void |sv_taint |NN SV* sv
ApdR |bool |sv_tainted |NN SV *const sv
Apd |int |sv_unmagic |NN SV *const sv|const int type
Apd |int |sv_unmagicext |NN SV *const sv|const int type|NULLOK MGVTBL *vtbl
|NN const char *normal \
|NULLOK const char *special
#endif
-Abmd |UV |to_utf8_lower |NN const U8 *p|NN U8* ustrp|NULLOK STRLEN *lenp
+Apbmd |UV |to_utf8_lower |NN const U8 *p|NN U8* ustrp|NULLOK STRLEN *lenp
AMp |UV |_to_utf8_lower_flags |NN const U8 *p|NN U8* ustrp \
|NULLOK STRLEN *lenp|bool flags
-Abmd |UV |to_utf8_upper |NN const U8 *p|NN U8* ustrp|NULLOK STRLEN *lenp
+Apbmd |UV |to_utf8_upper |NN const U8 *p|NN U8* ustrp|NULLOK STRLEN *lenp
AMp |UV |_to_utf8_upper_flags |NN const U8 *p|NN U8* ustrp \
|NULLOK STRLEN *lenp|bool flags
-Abmd |UV |to_utf8_title |NN const U8 *p|NN U8* ustrp|NULLOK STRLEN *lenp
+Apbmd |UV |to_utf8_title |NN const U8 *p|NN U8* ustrp|NULLOK STRLEN *lenp
AMp |UV |_to_utf8_title_flags |NN const U8 *p|NN U8* ustrp \
|NULLOK STRLEN *lenp|bool flags
-Abmd |UV |to_utf8_fold |NN const U8 *p|NN U8* ustrp|NULLOK STRLEN *lenp
+Apbmd |UV |to_utf8_fold |NN const U8 *p|NN U8* ustrp|NULLOK STRLEN *lenp
AMp |UV |_to_utf8_fold_flags|NN const U8 *p|NN U8* ustrp \
|NULLOK STRLEN *lenp|U8 flags
#if defined(PERL_IN_MG_C) || defined(PERL_IN_PP_C)
ApdRmb |char* |sv_2pv_nolen |NN SV* sv
ApdRmb |char* |sv_2pvutf8_nolen|NN SV* sv
ApdRmb |char* |sv_2pvbyte_nolen|NN SV* sv
-AmdbR |char* |sv_pv |NN SV *sv
-AmdbR |char* |sv_pvutf8 |NN SV *sv
-AmdbR |char* |sv_pvbyte |NN SV *sv
-Amdb |STRLEN |sv_utf8_upgrade|NN SV *sv
+ApmdbR |char* |sv_pv |NN SV *sv
+ApmdbR |char* |sv_pvutf8 |NN SV *sv
+ApmdbR |char* |sv_pvbyte |NN SV *sv
+Apmdb |STRLEN |sv_utf8_upgrade|NN SV *sv
Amd |STRLEN |sv_utf8_upgrade_nomg|NN SV *sv
ApdM |bool |sv_utf8_downgrade|NN SV *const sv|const bool fail_ok
Apd |void |sv_utf8_encode |NN SV *const sv
Adp |void |sv_nosharing |NULLOK SV *sv
Adpbm |void |sv_nolocking |NULLOK SV *sv
Adp |bool |sv_destroyable |NULLOK SV *sv
-#ifdef NO_MATHOMS
-Adpbm |void |sv_nounlocking |NULLOK SV *sv
-#else
Adpb |void |sv_nounlocking |NULLOK SV *sv
-#endif
Adp |int |nothreadhook
p |void |init_constants
#if defined(PERL_IN_MG_C)
s |void |save_magic_flags|I32 mgs_ix|NN SV *sv|U32 flags
--s |int |magic_methpack |NN SV *sv|NN const MAGIC *mg|NN SV *meth
+s |int |magic_methpack |NN SV *sv|NN const MAGIC *mg|NN SV *meth
s |SV* |magic_methcall1|NN SV *sv|NN const MAGIC *mg \
|NN SV *meth|U32 flags \
|int n|NULLOK SV *val
#define init_i18nl14n(a) Perl_init_i18nl14n(aTHX_ a)
#define init_stacks() Perl_init_stacks(aTHX)
#define init_tm(a) Perl_init_tm(aTHX_ a)
-#define instr Perl_instr
#define intro_my() Perl_intro_my(aTHX)
#define isALNUM_lazy(a) Perl_isALNUM_lazy(aTHX_ a)
#define isIDFIRST_lazy(a) Perl_isIDFIRST_lazy(aTHX_ a)
#define new_numeric(a) Perl_new_numeric(aTHX_ a)
#define new_stackinfo(a,b) Perl_new_stackinfo(aTHX_ a,b)
#define new_version(a) Perl_new_version(aTHX_ a)
-#define ninstr Perl_ninstr
#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 pad_add_name_pvn(a,b,c,d,e) Perl_pad_add_name_pvn(aTHX_ a,b,c,d,e)
#define pad_add_name_sv(a,b,c,d) Perl_pad_add_name_sv(aTHX_ a,b,c,d)
#define pad_alloc(a,b) Perl_pad_alloc(aTHX_ a,b)
+#ifndef NO_MATHOMS
#define pad_compname_type(a) Perl_pad_compname_type(aTHX_ a)
+#endif
#define pad_findmy_pv(a,b) Perl_pad_findmy_pv(aTHX_ a,b)
#define pad_findmy_pvn(a,b,c) Perl_pad_findmy_pvn(aTHX_ a,b,c)
#define pad_findmy_sv(a,b) Perl_pad_findmy_sv(aTHX_ a,b)
#define sv_newmortal() Perl_sv_newmortal(aTHX)
#define sv_newref(a) Perl_sv_newref(aTHX_ a)
#define sv_nosharing(a) Perl_sv_nosharing(aTHX_ a)
+#ifndef NO_MATHOMS
+#define sv_nounlocking(a) Perl_sv_nounlocking(aTHX_ a)
+#endif
#define sv_nv(a) Perl_sv_nv(aTHX_ a)
#define sv_peek(a) Perl_sv_peek(aTHX_ a)
#define sv_pos_b2u(a,b) Perl_sv_pos_b2u(aTHX_ a,b)
#define sv_setpvf Perl_sv_setpvf
#define sv_setpvf_mg Perl_sv_setpvf_mg
#endif
+#ifndef NO_MATHOMS
#define sv_setpviv(a,b) Perl_sv_setpviv(aTHX_ a,b)
+#endif
+#ifndef NO_MATHOMS
#define sv_setpviv_mg(a,b) Perl_sv_setpviv_mg(aTHX_ a,b)
+#endif
#define sv_setpvn(a,b,c) Perl_sv_setpvn(aTHX_ a,b,c)
#define sv_setpvn_mg(a,b,c) Perl_sv_setpvn_mg(aTHX_ a,b,c)
#define sv_setref_iv(a,b,c) Perl_sv_setref_iv(aTHX_ a,b,c)
#define whichsig_pvn(a,b) Perl_whichsig_pvn(aTHX_ a,b)
#define whichsig_sv(a) Perl_whichsig_sv(aTHX_ a)
#define wrap_op_checker(a,b,c) Perl_wrap_op_checker(aTHX_ a,b,c)
+#if !(defined(HAS_MEMMEM))
+#define ninstr Perl_ninstr
+#endif
#if !(defined(HAS_SIGACTION) && defined(SA_SIGINFO))
#define csighandler Perl_csighandler
#endif
-#if !(defined(NO_MATHOMS))
-#define sv_nounlocking(a) Perl_sv_nounlocking(aTHX_ a)
-#endif
#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
#define my_bzero Perl_my_bzero
#endif
use vars qw($TODO $Level $using_open);
require "test.pl";
-our $VERSION = '0.13';
+our $VERSION = '0.14';
# now export checkOptree, and those test.pl functions used by tests
our @EXPORT = qw( checkOptree plan skip skip_all pass is like unlike
.* # all sorts of things follow it
v # The opening v
)
- (?:(:>,<,%,\\{) # hints when open.pm is in force
+ (?:(:>,<,%,\\\{) # hints when open.pm is in force
|(:>,<,%)) # (two variations)
(\ ->(?:-|[0-9a-z]+))?
$
]
- [$1 . ($2 && ':{') . $4]xegm; # change to the hints without open.pm
+ [$1 . ($2 && ':\{') . $4]xegm; # change to the hints without open.pm
}
EUSERS EWOULDBLOCK EXDEV FILENAME_MAX F_OK HUPCL ICANON ICRNL IEXTEN
IGNBRK IGNCR IGNPAR INLCR INPCK INT_MAX INT_MIN ISIG ISTRIP IXOFF IXON
LC_ALL LC_COLLATE LC_CTYPE LC_MESSAGES LC_MONETARY LC_NUMERIC LC_TIME
- LINK_MAX LONG_MAX LONG_MIN L_ctermid L_cuserid L_tmpnam MAX_CANON
+ LINK_MAX LONG_MAX LONG_MIN L_ctermid L_cuserid MAX_CANON
MAX_INPUT MB_LEN_MAX MSG_CTRUNC MSG_DONTROUTE MSG_EOR MSG_OOB MSG_PEEK
MSG_TRUNC MSG_WAITALL NAME_MAX NCCS NGROUPS_MAX NOFLSH OPEN_MAX OPOST
PARENB PARMRK PARODD PATH_MAX PIPE_BUF RAND_MAX R_OK SCHAR_MAX
{name=>"SIG_DFL", value=>"PTR2IV(SIG_DFL)", not_constant=>1},
{name=>"SIG_ERR", value=>"PTR2IV(SIG_ERR)", not_constant=>1},
{name=>"SIG_IGN", value=>"PTR2IV(SIG_IGN)", not_constant=>1},
- # L_tmpnam[e] was a typo--retained for compatibility
- {name=>"L_tmpname", value=>"L_tmpnam"},
{name=>"NULL", value=>"0"},
{name=>"_POSIX_JOB_CONTROL", type=>"YES", default=>["IV", "0"]},
{name=>"_POSIX_SAVED_IDS", type=>"YES", default=>["IV", "0"]},
char * buffer
size_t nbytes
-SV *
-tmpnam()
- PREINIT:
- STRLEN i;
- int len;
- CODE:
- RETVAL = newSVpvs("");
- SvGROW(RETVAL, L_tmpnam);
- /* Yes, we know tmpnam() is bad. So bad that some compilers
- * and linkers warn against using it. But it is here for
- * completeness. POSIX.pod warns against using it.
- *
- * Then again, maybe this should be removed at some point.
- * No point in enabling dangerous interfaces. */
- if (ckWARN_d(WARN_DEPRECATED)) {
- HV *warned = get_hv("POSIX::_warned", GV_ADD | GV_ADDMULTI);
- if (! hv_exists(warned, (const char *)&PL_op, sizeof(PL_op))) {
- Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Calling POSIX::tmpnam() is deprecated");
- (void)hv_store(warned, (const char *)&PL_op, sizeof(PL_op), &PL_sv_yes, 0);
- }
- }
- len = strlen(tmpnam(SvPV(RETVAL, i)));
- SvCUR_set(RETVAL, len);
- OUTPUT:
- RETVAL
-
void
abort()
our ($AUTOLOAD, %SIGRT);
-our $VERSION = '1.65';
+our $VERSION = '1.69';
require XSLoader;
my $loaded;
-sub import {
- my $pkg = shift;
-
- load_imports() unless $loaded++;
-
- # Grandfather old foo_h form to new :foo_h form
- s/^(?=\w+_h$)/:/ for my @list = @_;
-
- local $Exporter::ExportLevel = 1;
- Exporter::import($pkg,@list);
-}
-
sub croak { require Carp; goto &Carp::croak }
sub usage { croak "Usage: POSIX::$_[0]" }
XSLoader::load();
my %replacement = (
+ L_tmpnam => undef,
atexit => 'END {}',
atof => undef,
atoi => undef,
strspn => undef,
strtok => undef,
tmpfile => 'IO::File::new_tmpfile',
+ tmpnam => 'use File::Temp',
ungetc => 'IO::Handle::ungetc',
vfprintf => undef,
vprintf => undef,
);
my %reimpl = (
+ abs => 'x => CORE::abs($_[0])',
+ alarm => 'seconds => CORE::alarm($_[0])',
assert => 'expr => croak "Assertion failed" if !$_[0]',
- tolower => 'string => lc($_[0])',
- toupper => 'string => uc($_[0])',
- closedir => 'dirhandle => CORE::closedir($_[0])',
- opendir => 'directory => my $dh; CORE::opendir($dh, $_[0]) ? $dh : undef',
- readdir => 'dirhandle => CORE::readdir($_[0])',
- rewinddir => 'dirhandle => CORE::rewinddir($_[0])',
- errno => '$! + 0',
- creat => 'filename, mode => &open($_[0], &O_WRONLY | &O_CREAT | &O_TRUNC, $_[1])',
- fcntl => 'filehandle, cmd, arg => CORE::fcntl($_[0], $_[1], $_[2])',
- getgrgid => 'gid => CORE::getgrgid($_[0])',
- getgrnam => 'name => CORE::getgrnam($_[0])',
atan2 => 'x, y => CORE::atan2($_[0], $_[1])',
+ chdir => 'directory => CORE::chdir($_[0])',
+ chmod => 'mode, filename => CORE::chmod($_[0], $_[1])',
+ chown => 'uid, gid, filename => CORE::chown($_[0], $_[1], $_[2])',
+ closedir => 'dirhandle => CORE::closedir($_[0])',
cos => 'x => CORE::cos($_[0])',
+ creat => 'filename, mode => &open($_[0], &O_WRONLY | &O_CREAT | &O_TRUNC, $_[1])',
+ errno => '$! + 0',
+ exit => 'status => CORE::exit($_[0])',
exp => 'x => CORE::exp($_[0])',
fabs => 'x => CORE::abs($_[0])',
- log => 'x => CORE::log($_[0])',
- pow => 'x, exponent => $_[0] ** $_[1]',
- sin => 'x => CORE::sin($_[0])',
- sqrt => 'x => CORE::sqrt($_[0])',
- getpwnam => 'name => CORE::getpwnam($_[0])',
- getpwuid => 'uid => CORE::getpwuid($_[0])',
- kill => 'pid, sig => CORE::kill $_[1], $_[0]',
- raise => 'sig => CORE::kill $_[0], $$; # Is this good enough',
+ fcntl => 'filehandle, cmd, arg => CORE::fcntl($_[0], $_[1], $_[2])',
+ fork => 'CORE::fork',
+ fstat => 'fd => CORE::open my $dup, "<&", $_[0]; CORE::stat($dup)', # Gross.
getc => 'handle => CORE::getc($_[0])',
getchar => 'CORE::getc(STDIN)',
- gets => 'scalar <STDIN>',
- remove => 'filename => (-d $_[0]) ? CORE::rmdir($_[0]) : CORE::unlink($_[0])',
- rename => 'oldfilename, newfilename => CORE::rename($_[0], $_[1])',
- rewind => 'filehandle => CORE::seek($_[0],0,0)',
- abs => 'x => CORE::abs($_[0])',
- exit => 'status => CORE::exit($_[0])',
- getenv => 'name => $ENV{$_[0]}',
- system => 'command => CORE::system($_[0])',
- strerror => 'errno => BEGIN { local $!; require locale; locale->import} my $e = $_[0] + 0; local $!; $! = $e; "$!"',
- strstr => 'big, little => CORE::index($_[0], $_[1])',
- chmod => 'mode, filename => CORE::chmod($_[0], $_[1])',
- fstat => 'fd => CORE::open my $dup, "<&", $_[0]; CORE::stat($dup)', # Gross.
- mkdir => 'directoryname, mode => CORE::mkdir($_[0], $_[1])',
- stat => 'filename => CORE::stat($_[0])',
- umask => 'mask => CORE::umask($_[0])',
- wait => 'CORE::wait()',
- waitpid => 'pid, options => CORE::waitpid($_[0], $_[1])',
- gmtime => 'time => CORE::gmtime($_[0])',
- localtime => 'time => CORE::localtime($_[0])',
- time => 'CORE::time',
- alarm => 'seconds => CORE::alarm($_[0])',
- chdir => 'directory => CORE::chdir($_[0])',
- chown => 'uid, gid, filename => CORE::chown($_[0], $_[1], $_[2])',
- fork => 'CORE::fork',
getegid => '$) + 0',
+ getenv => 'name => $ENV{$_[0]}',
geteuid => '$> + 0',
getgid => '$( + 0',
+ getgrgid => 'gid => CORE::getgrgid($_[0])',
+ getgrnam => 'name => CORE::getgrnam($_[0])',
getgroups => 'my %seen; grep !$seen{$_}++, split " ", $)',
getlogin => 'CORE::getlogin()',
getpgrp => 'CORE::getpgrp',
getpid => '$$',
getppid => 'CORE::getppid',
+ getpwnam => 'name => CORE::getpwnam($_[0])',
+ getpwuid => 'uid => CORE::getpwuid($_[0])',
+ gets => 'scalar <STDIN>',
getuid => '$<',
+ gmtime => 'time => CORE::gmtime($_[0])',
isatty => 'filehandle => -t $_[0]',
+ kill => 'pid, sig => CORE::kill $_[1], $_[0]',
link => 'oldfilename, newfilename => CORE::link($_[0], $_[1])',
+ localtime => 'time => CORE::localtime($_[0])',
+ log => 'x => CORE::log($_[0])',
+ mkdir => 'directoryname, mode => CORE::mkdir($_[0], $_[1])',
+ opendir => 'directory => my $dh; CORE::opendir($dh, $_[0]) ? $dh : undef',
+ pow => 'x, exponent => $_[0] ** $_[1]',
+ raise => 'sig => CORE::kill $_[0], $$; # Is this good enough',
+ readdir => 'dirhandle => CORE::readdir($_[0])',
+ remove => 'filename => (-d $_[0]) ? CORE::rmdir($_[0]) : CORE::unlink($_[0])',
+ rename => 'oldfilename, newfilename => CORE::rename($_[0], $_[1])',
+ rewind => 'filehandle => CORE::seek($_[0],0,0)',
+ rewinddir => 'dirhandle => CORE::rewinddir($_[0])',
rmdir => 'directoryname => CORE::rmdir($_[0])',
+ sin => 'x => CORE::sin($_[0])',
+ sqrt => 'x => CORE::sqrt($_[0])',
+ stat => 'filename => CORE::stat($_[0])',
+ strerror => 'errno => BEGIN { local $!; require locale; locale->import} my $e = $_[0] + 0; local $!; $! = $e; "$!"',
+ strstr => 'big, little => CORE::index($_[0], $_[1])',
+ system => 'command => CORE::system($_[0])',
+ time => 'CORE::time',
+ tolower => 'string => lc($_[0])',
+ toupper => 'string => uc($_[0])',
+ umask => 'mask => CORE::umask($_[0])',
unlink => 'filename => CORE::unlink($_[0])',
utime => 'filename, atime, mtime => CORE::utime($_[1], $_[2], $_[0])',
+ wait => 'CORE::wait()',
+ waitpid => 'pid, options => CORE::waitpid($_[0], $_[1])',
);
+sub import {
+ my $pkg = shift;
+
+ load_imports() unless $loaded++;
+
+ # Grandfather old foo_h form to new :foo_h form
+ s/^(?=\w+_h$)/:/ for my @list = @_;
+
+ my @unimpl = sort grep { exists $replacement{$_} } @list;
+ if (@unimpl) {
+ for my $u (@unimpl) {
+ warn "Unimplemented: POSIX::$u(): ", unimplemented_message($u);
+ }
+ croak(sprintf("Unimplemented: %s",
+ join(" ", map { "POSIX::$_()" } @unimpl)));
+ }
+
+ local $Exporter::ExportLevel = 1;
+ Exporter::import($pkg,@list);
+}
+
eval join ';', map "sub $_", keys %replacement, keys %reimpl;
+sub unimplemented_message {
+ my $func = shift;
+ my $how = $replacement{$func};
+ return "C-specific, stopped" unless defined $how;
+ return "$$how" if ref $how;
+ return "$how instead" if $how =~ /^use /;
+ return "Use method $how() instead" if $how =~ /::/;
+ return "C-specific: use $how instead";
+}
+
sub AUTOLOAD {
my ($func) = ($AUTOLOAD =~ /.*::(.*)/);
goto &$AUTOLOAD;
}
if (exists $replacement{$func}) {
- my $how = $replacement{$func};
- croak "Unimplemented: POSIX::$func() is C-specific, stopped"
- unless defined $how;
- croak "Unimplemented: POSIX::$func() is $$how" if ref $how;
- croak "Use method $how() instead of POSIX::$func()" if $how =~ /::/;
- croak "Unimplemented: POSIX::$func() is C-specific: use $how instead";
+ croak "Unimplemented: POSIX::$func(): ", unimplemented_message($func);
}
constant($func);
stddef_h => [qw(NULL offsetof)],
stdio_h => [qw(BUFSIZ EOF FILENAME_MAX L_ctermid L_cuserid
- L_tmpname NULL SEEK_CUR SEEK_END SEEK_SET
+ NULL SEEK_CUR SEEK_END SEEK_SET
STREAM_MAX TMP_MAX stderr stdin stdout
clearerr fclose fdopen feof ferror fflush fgetc fgetpos
fgets fopen fprintf fputc fputs fread freopen
Inf NaN acosh asinh atanh cbrt copysign erf erfc exp2 expm1 fdim fma
fmax fmin fpclassify hypot ilogb isfinite isgreater isgreaterequal
isinf isless islessequal islessgreater isnan isnormal isunordered j0 j1
- jn lgamma log1p log2 logb lrint nan nearbyint nextafter nexttoward
+ jn lgamma log1p log2 logb lrint lround nan nearbyint nextafter nexttoward
remainder remquo rint round scalbn signbit tgamma trunc y0 y1 yn
)],
+ netdb_h => [qw(EAI_AGAIN EAI_BADFLAGS EAI_FAIL
+ EAI_FAMILY EAI_MEMORY EAI_NONAME
+ EAI_OVERFLOW EAI_SERVICE EAI_SOCKTYPE
+ EAI_SYSTEM)],
+
stdlib_h_c99 => [ @{$default_export_tags{stdlib_h}}, 'strtold' ],
+ sys_socket_h => [qw(
+ MSG_CTRUNC MSG_DONTROUTE MSG_EOR MSG_OOB MSG_PEEK MSG_TRUNC MSG_WAITALL
+ )],
+
nan_payload => [ qw(getpayload setpayload setpayloadsig issignaling) ],
signal_h_si_code => [qw(
# you do not want to add symbols to the following list. add a new tag instead
our @EXPORT_OK = (qw(close lchown nice open pipe read sleep times write
- printf sprintf lround),
- # lround() should really be in the :math_h_c99 tag, but
- # we're too far into the 5.24 code freeze for that to be
- # done now. This can be revisited in the 5.25.x cycle.
+ printf sprintf),
grep {!exists $export{$_}} keys %reimpl, keys %replacement, keys %export_ok);
our %EXPORT_TAGS = ( %default_export_tags, %other_export_tags );
the C<strxfrm()> function. Not really needed since
Perl can do this transparently, see L<perllocale>.
+Beware that in a UTF-8 locale, anything you pass to this function must
+be in UTF-8; and when not in a UTF-8 locale, anything passed must not be
+UTF-8 encoded.
+
=item C<strcpy>
Not implemented. C<strcpy()> is C-specific, use C<=> instead, see L<perlop>.
Not really needed since Perl can do this transparently, see
L<perllocale>.
+Beware that in a UTF-8 locale, anything you pass to this function must
+be in UTF-8; and when not in a UTF-8 locale, anything passed must not be
+UTF-8 encoded.
+
=item C<sysconf>
Retrieves values of system configurable variables.
=item C<tmpnam>
-Returns a name for a temporary file.
-
- $tmpfile = POSIX::tmpnam();
-
For security reasons, which are probably detailed in your system's
documentation for the C library C<tmpnam()> function, this interface
-should not be used; instead see L<File::Temp>.
+is no longer available; instead use L<File::Temp>.
=item C<tolower>
=item Constants
-C<BUFSIZ> C<EOF> C<FILENAME_MAX> C<L_ctermid> C<L_cuserid> C<L_tmpname> C<TMP_MAX>
+C<BUFSIZ> C<EOF> C<FILENAME_MAX> C<L_ctermid> C<L_cuserid> C<TMP_MAX>
=back
LC_CTYPE LC_MESSAGES LC_MONETARY LC_NUMERIC LC_TIME LDBL_DIG
LDBL_EPSILON LDBL_MANT_DIG LDBL_MAX LDBL_MAX_10_EXP
LDBL_MAX_EXP LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP LINK_MAX
- LONG_MAX LONG_MIN L_ctermid L_cuserid L_tmpname MAX_CANON
+ LONG_MAX LONG_MIN L_ctermid L_cuserid MAX_CANON
MAX_INPUT MB_CUR_MAX MB_LEN_MAX NAME_MAX NCCS NDEBUG
NGROUPS_MAX NOFLSH NULL OPEN_MAX OPOST O_ACCMODE O_APPEND
O_CREAT O_EXCL O_NOCTTY O_NONBLOCK O_RDONLY O_RDWR O_TRUNC
# it is OK to add new constants, but new functions may only go in EXPORT_OK
],
EXPORT_OK => [sort
+ # this stuff was added in 5.9, but not exported until 5.25
+ qw(
+ MSG_CTRUNC MSG_DONTROUTE MSG_EOR MSG_OOB MSG_PEEK
+ MSG_TRUNC MSG_WAITALL
+ ),
+ # this stuff was added in 5.11, but not exported until 5.25
+ qw(
+ EAI_AGAIN EAI_BADFLAGS EAI_FAIL EAI_FAMILY EAI_MEMORY
+ EAI_NONAME EAI_OVERFLOW EAI_SERVICE EAI_SOCKTYPE EAI_SYSTEM
+ ),
# this stuff was in 5.20.2
qw(
abs alarm atan2 chdir chmod chown close closedir cos exit
localtime log mkdir nice open opendir pipe printf rand
read readdir rename rewinddir rmdir sin sleep sprintf sqrt
srand stat system time times umask unlink utime wait
- waitpid write
+ waitpid write L_tmpnam
),
# this stuff was added in 5.21
+ # (though an oversight meant that lround wasn't listed here
+ # initially; it was added to @EXPORT_OK in 5.23, and to the
+ # :math_h_c99 tag in 5.25)
qw(
FE_DOWNWARD FE_TONEAREST FE_TOWARDZERO FE_UPWARD
fegetround fesetround
acosh asinh atanh cbrt copysign erf erfc exp2 expm1 fdim
fma fmax fmin fpclassify hypot ilogb isfinite isgreater
isgreaterequal isinf isless islessequal islessgreater isnan
- isnormal isunordered j0 j1 jn lgamma log1p log2 logb lrint nan
+ isnormal isunordered j0 j1 jn lgamma log1p log2 logb lrint lround nan
nearbyint nextafter nexttoward remainder remquo rint round scalbn
signbit tgamma trunc y0 y1 yn strtold
),
POLL_IN POLL_OUT POLL_MSG POLL_ERR POLL_PRI POLL_HUP
SI_USER SI_QUEUE SI_TIMER SI_ASYNCIO SI_MESGQ
),
- # this was implemented in 5.21, but not exported; it was added to
- # @EXPORT_OK late in 5.23, and will be added to :math_h_c99 tag early
- # in 5.25
- qw( lround ),
],
);
-plan (tests => 2 * keys %expect);
+plan (tests => 2 * keys(%expect) + keys(%POSIX::));
while (my ($var, $expect) = each %expect) {
my $have = *{$POSIX::{$var}}{ARRAY};
"Correct number of entries for \@POSIX::$var");
is_deeply([sort @$have], $expect, "Correct entries for \@POSIX::$var");
}
+
+my %no_export_needed = map +($_ => 1),
+ qw(AUTOLOAD bootstrap constant croak import load_imports
+ unimplemented_message usage);
+
+my %exported = map +($_ => 1),
+ (@POSIX::EXPORT, @POSIX::EXPORT_OK, map @$_, values %POSIX::EXPORT_TAGS);
+
+for my $name (sort keys %POSIX::) {
+ my $code = do { no strict 'refs'; \&{"POSIX::$name"} };
+ if (!defined &$code) {
+ pass("$name need not be exported as it does not name a subroutine");
+ }
+ elsif ($no_export_needed{$name}) {
+ pass("$name need not be exported as it is part of the internals");
+ }
+ else {
+ ok($exported{$name}, "subroutine POSIX::$name is exported somehow");
+ }
+}
use POSIX ':math_h_c99';
use POSIX ':nan_payload';
-use POSIX 'lround';
use Test::More;
use Config;
require 'loc_tools.pl';
}
-use Test::More tests => 94;
+use Test::More tests => 93;
use POSIX qw(fcntl_h signal_h limits_h _exit getcwd open read strftime write
errno localeconv dup dup2 lseek access);
# Check unimplemented.
$result = eval {POSIX::offsetof};
is ($result, undef, "offsetof should fail");
-like ($@, qr/^Unimplemented: POSIX::offsetof\(\) is C-specific/,
+like ($@, qr/^Unimplemented: POSIX::offsetof\(\): C-specific/,
"check its unimplemented message");
# Check reimplemented.
$result = eval {POSIX::fgets};
is ($result, undef, "fgets should fail");
-like ($@, qr/^Use method IO::Handle::gets\(\) instead/,
+like ($@, qr/^Unimplemented: POSIX::fgets\(\): Use method IO::Handle::gets\(\) instead/,
"check its redef message");
eval { use strict; POSIX->import("S_ISBLK"); my $x = S_ISBLK };
cmp_ok($!, '==', POSIX::ENOTDIR);
}
-{ # tmpnam() is deprecated
- my @warn;
- local $SIG{__WARN__} = sub { push @warn, "@_"; note "@_"; };
- my $x = sub { POSIX::tmpnam() };
- my $foo = $x->();
- $foo = $x->();
- is(@warn, 1, "POSIX::tmpnam() should warn only once per location");
- like($warn[0], qr!^Calling POSIX::tmpnam\(\) is deprecated at t/posix.t line \d+\.$!,
- "check POSIX::tmpnam warns by default");
- no warnings "deprecated";
- undef $warn;
- my $foo = POSIX::tmpnam();
- is($warn, undef, "... but the warning can be disabled");
+{ # tmpnam() has been removed as unsafe
+ my $x = eval { POSIX::tmpnam() };
+ is($x, undef, 'tmpnam has been removed');
+ like($@, qr/use File::Temp/, 'tmpnam advises File::Temp');
}
# Check that output is not flushed by _exit. This test should be last
[strspn => 'C-specific, stopped'],
[strtok => 'C-specific, stopped'],
[tmpfile => \'IO::File::new_tmpfile'],
+ [tmpnam => \'use File::Temp'],
[ungetc => \'IO::Handle::ungetc'],
[vfprintf => 'C-specific, stopped'],
[vprintf => 'C-specific, stopped'],
[vsprintf => 'C-specific, stopped'],
+ [L_tmpnam => 'C-specific, stopped'],
) {
my ($func, $action) = @$_;
my $expect = ref $action
- ? qr/Use method $$action\(\) instead of POSIX::$func\(\) at \(eval/
- : qr/Unimplemented: POSIX::$func\(\) is \Q$action\E at \(eval/;
+ ? qr/Unimplemented: POSIX::$func\(\): .*$$action(?:\(\))? instead at \(eval/
+ : qr/Unimplemented: POSIX::$func\(\): \Q$action\E at \(eval/;
is(eval "POSIX::$func(); 1", undef, "POSIX::$func fails as expected");
like($@, $expect, "POSIX::$func gives expected error message");
}
use warnings;
use Carp;
-our $VERSION = '0.80';
+our $VERSION = '0.81';
require XSLoader;
sv = sv_2mortal(newSVpvn("", 0));
sv_catpvf(sv, fmt, 5, 6, 7, 8);
+void
+load_module(flags, name, ...)
+ U32 flags
+ SV *name
+CODE:
+ if (items == 2) {
+ Perl_load_module(aTHX_ flags, SvREFCNT_inc(name), NULL);
+ } else if (items == 3) {
+ Perl_load_module(aTHX_ flags, SvREFCNT_inc(name), SvREFCNT_inc(ST(2)));
+ } else
+ Perl_croak(aTHX_ "load_module can't yet support %lu items", items);
+
MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest
int
IS_NUMBER_IN_UV IS_NUMBER_GREATER_THAN_UV_MAX
IS_NUMBER_NOT_INT IS_NUMBER_NEG IS_NUMBER_INFINITY
IS_NUMBER_NAN IS_NUMBER_TRAILING PERL_SCAN_TRAILING
+ PERL_LOADMOD_DENY PERL_LOADMOD_NOIMPORT PERL_LOADMOD_IMPORT_OPS
),
{name=>"G_WANT", default=>["IV", "G_ARRAY|G_VOID"]});
--- /dev/null
+#!perl -w
+use strict;
+
+# Test the load_module() core API function.
+#
+# Note that this function can be passed arbitrary and illegal module
+# names which would already have been caught if a require statement had
+# been compiled. So check that load_module() can catch such bad things.
+
+use Test::More;
+use XS::APItest;
+
+# This isn't complete yet. In particular, we don't test import lists, or
+# the other flags. But it's better than nothing.
+
+is($INC{'less.pm'}, undef, "less isn't loaded");
+load_module(PERL_LOADMOD_NOIMPORT, 'less');
+like($INC{'less.pm'}, qr!(?:\A|/)lib/less\.pm\z!, "less is now loaded");
+
+delete $INC{'less.pm'};
+delete $::{'less::'};
+
+is(eval { load_module(PERL_LOADMOD_NOIMPORT, 'less', 1); 1}, undef,
+ "expect load_module() to fail");
+like($@, qr/less version 1 required--this is only version 0\./,
+ 'with the correct error message');
+
+is(eval { load_module(PERL_LOADMOD_NOIMPORT, 'less', 0.03); 1}, 1,
+ "expect load_module() not to fail");
+
+#
+# Check for illegal module names
+
+for (["", qr!\ABareword in require maps to empty filename!],
+ ["::", qr!\ABareword in require must not start with a double-colon: "::"!],
+ ["::::", qr!\ABareword in require must not start with a double-colon: "::::"!],
+ ["::/", qr!\ABareword in require must not start with a double-colon: "::/!],
+ ["/", qr!\ABareword in require maps to disallowed filename "/\.pm"!],
+ ["::/WOOSH", qr!\ABareword in require must not start with a double-colon: "::/WOOSH!],
+ [".WOOSH", qr!\ABareword in require maps to disallowed filename "\.WOOSH\.pm"!],
+ ["::.WOOSH", qr!\ABareword in require must not start with a double-colon: "::.WOOSH!],
+ ["WOOSH::.sock", qr!\ABareword in require contains "/\."!],
+ ["WOOSH::.sock", qr!\ABareword in require contains "/\."!],
+ ["WOOSH/.sock", qr!\ABareword in require contains "/\."!],
+ ["WOOSH/..sock", qr!\ABareword in require contains "/\."!],
+ ["WOOSH/../sock", qr!\ABareword in require contains "/\."!],
+ ["WOOSH::..::sock", qr!\ABareword in require contains "/\."!],
+ ["WOOSH::.::sock", qr!\ABareword in require contains "/\."!],
+ ["WOOSH::./sock", qr!\ABareword in require contains "/\."!],
+ ["WOOSH/./sock", qr!\ABareword in require contains "/\."!],
+ ["WOOSH/.::sock", qr!\ABareword in require contains "/\."!],
+ ["WOOSH/..::sock", qr!\ABareword in require contains "/\."!],
+ ["WOOSH::../sock", qr!\ABareword in require contains "/\."!],
+ ["WOOSH::../..::sock", qr!\ABareword in require contains "/\."!],
+ ["WOOSH\0sock", qr!\ACan't locate WOOSH\\0sock.pm:!],
+ )
+{
+ my ($module, $error) = @$_;
+ my $module2 = $module; # load_module mangles its first argument
+ no warnings 'syscalls';
+ is(eval { load_module(PERL_LOADMOD_NOIMPORT, $module); 1}, undef,
+ "expect load_module() for '$module2' to fail");
+ like($@, $error, "check expected error for $module2");
+}
+
+done_testing();
is (DPeek ($^), 'PVMG()', '$^');
is (DPeek ($=), 'PVMG()', '$=');
is (DPeek ($-), 'PVMG()', '$-');
+
+ # This tests expects that $! will have been used as a string recently.
+ my $foo = "$!";
like (DPeek ($!), qr'^PVMG\("', '$!');
+
if ($^O eq 'VMS') {
+ local $?; # Reset anything Test::* has done to it.
# VMS defines COMPLEX_STATUS and upgrades $? to PVLV
is (DPeek ($?), 'PVLV()', '$?');
} else {
+ local $?; # Reset anything Test::* has done to it.
is (DPeek ($?), 'PVMG()', '$?');
}
is (DPeek ($|), 'PVMG(1)', '$|');
use strict;
use warnings;
-our $VERSION = "0.32";
+our $VERSION = "0.33";
our @ISA = qw(Exporter);
our @EXPORT_OK = ('regmust',
qw(is_regexp regexp_pattern
")");
}
}
- if (exists $seen{'x'} && $seen{'x'} > 1
- && (warnings::enabled("deprecated")
- || warnings::enabled("regexp")))
- {
- my $message = "Having more than one /x regexp modifier is deprecated";
- if (warnings::enabled("deprecated")) {
- warnings::warn("deprecated", $message);
- }
- else {
- warnings::warn("regexp", $message);
- }
+ if (exists $seen{'x'} && $seen{'x'} > 1) {
+ require Carp;
+ Carp::croak("Only one /x regex modifier is allowed");
}
if ($turning_all_off) {
$w = "";
eval "use re '/xamax'";
- like $w, qr/Having more than one \/x regexp modifier is deprecated/,
- "warning with eval \"use re \"/xamax\"";
+ like $@, qr/Only one \/x regex modifier is allowed/,
+ "error with eval \"use re \"/xamax\"";
}
# 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.0
+# mkdir -p /opt/perl-catamount/lib/perl5/5.25.1
# 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.0
+# cp -pr lib/* /opt/perl-catamount/lib/perl5/5.25.1
# 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
[7-9].*) # OS X 10.3.x - 10.5.x
lddlflags="${ldflags} -bundle -undefined dynamic_lookup"
case "$ld" in
- *MACOSX_DEVELOPMENT_TARGET*) ;;
+ *MACOSX_DEPLOYMENT_TARGET*) ;;
*) ld="env MACOSX_DEPLOYMENT_TARGET=10.3 ${ld}" ;;
esac
;;
return;
}
if (
- count > 0 && (HEK_UTF8(*namep) || (flags & SVf_UTF8))
+ count > 0 && ((HEK_UTF8(*namep) || (flags & SVf_UTF8))
? hek_eq_pvn_flags(aTHX_ *namep, name, (I32)len, flags)
: (HEK_LEN(*namep) == (I32)len && memEQ(HEK_KEY(*namep), name, len))
+ )
) {
aux->xhv_name_count = -count;
}
assert(CxTYPE(cx) == CXt_WHEN);
PERL_UNUSED_ARG(cx);
+ PERL_UNUSED_CONTEXT;
/* currently NOOP */
}
/* U+9D OSC */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+9E PM */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+9F APC */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
-/* U+A0 NBSP */ (1U<<_CC_BLANK)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_PRINT)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE),
+/* U+A0 NBSP */ (1U<<_CC_BLANK)|(1U<<_CC_PRINT)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE),
/* U+A1 INVERTED '!' */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
/* U+A2 CENT */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_QUOTEMETA),
/* U+A3 POUND */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_QUOTEMETA),
/* 0x3E U+9E PM */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x3F U+1A SUB */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x40 U+20 SP */ (1U<<_CC_ASCII)|(1U<<_CC_BLANK)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_PRINT)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE),
-/* 0x41 U+A0 NBSP */ (1U<<_CC_BLANK)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_PRINT)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_UTF8_IS_CONTINUATION),
+/* 0x41 U+A0 NBSP */ (1U<<_CC_BLANK)|(1U<<_CC_PRINT)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_UTF8_IS_CONTINUATION),
/* 0x42 U+E2 I8=A1 a with '^' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD)|(1U<<_CC_UTF8_IS_CONTINUATION),
/* 0x43 U+E4 I8=A2 a with diaeresis */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD)|(1U<<_CC_UTF8_IS_CONTINUATION),
/* 0x44 U+E0 I8=A3 a with grave */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD)|(1U<<_CC_UTF8_IS_CONTINUATION),
/* 0x3E U+9E PM */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x3F U+1A SUB */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x40 U+20 SP */ (1U<<_CC_ASCII)|(1U<<_CC_BLANK)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_PRINT)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE),
-/* 0x41 U+A0 NBSP */ (1U<<_CC_BLANK)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_PRINT)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_UTF8_IS_CONTINUATION),
+/* 0x41 U+A0 NBSP */ (1U<<_CC_BLANK)|(1U<<_CC_PRINT)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_UTF8_IS_CONTINUATION),
/* 0x42 U+E2 I8=A1 a with '^' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD)|(1U<<_CC_UTF8_IS_CONTINUATION),
/* 0x43 U+E4 I8=A2 a with diaeresis */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD)|(1U<<_CC_UTF8_IS_CONTINUATION),
/* 0x44 U+E0 I8=A3 a with grave */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ALPHA)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_LOWER)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_IS_IN_SOME_FOLD)|(1U<<_CC_UTF8_IS_CONTINUATION),
/Term/
/Test.pm
/Test/
+/Test2.pm
+/Test2/
/Text/
/Thread/
/Tie/File.pm
our %bits;
-our $VERSION = "5.025000";
+our $VERSION = "5.025001";
$bits{$_}{3} = 'OPpENTERSUB_AMPER' for qw(entersub rv2cv);
$bits{$_}{6} = 'OPpENTERSUB_DB' for qw(entersub rv2cv);
package _charnames;
use strict;
use warnings;
-our $VERSION = '1.43';
+our $VERSION = '1.44';
use unicore::Name; # mktables-generated algorithmically-defined names
use bytes (); # for $bytes::hint_bits
}
$^H{charnames_name_aliases}{$name} = $value;
- if (warnings::enabled('deprecated')
- && $name =~ / ( .* $nbsp ) ( .* ) $ /x)
- {
- carp "NO-BREAK SPACE in a charnames alias definition is "
- . "deprecated; marked by <-- HERE in '$1 <-- HERE "
- . $2 . "'";
- }
}
}
}
package charnames;
use strict;
use warnings;
-our $VERSION = '1.43';
+our $VERSION = '1.44';
use unicore::Name; # mktables-generated algorithmically-defined names
use _charnames (); # The submodule for this where most of the work gets done
);
$wrapper->output_like(
- qr/No manual entry for perlrules/,
+ qr/No (?:manual )?entry for perlrules/,
'perldoc command works fine',
);
}
--- /dev/null
+#!./perl
+use strict;
+
+# test that perlbug generates somewhat sane reports, but don't
+# actually send them
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+require './test.pl';
+
+# lifted from perl5db.t
+my $extracted_program = '../utils/perlbug'; # unix, nt, ...
+if ($^O eq 'VMS') { $extracted_program = '[-.utils]perlbug.com'; }
+if (!(-e $extracted_program)) {
+ print "1..0 # Skip: $extracted_program was not built\n";
+ exit 0;
+}
+
+my $result;
+my $testreport = 'test.rep';
+unlink $testreport;
+
+sub _slurp {
+ my $file = shift;
+ ok(-f $file, "saved report $file exists");
+ open(F, '<', $file) or return undef;
+ local $/;
+ my $ret = <F>;
+ close F;
+ $ret;
+}
+
+sub _dump {
+ my $file = shift;
+ my $contents = shift;
+ open(F, '>', $file) or return;
+ print F $contents;
+ close F;
+ return 1;
+}
+
+plan(22);
+
+
+# check -d
+$result = runperl( progfile => $extracted_program,
+ args => ['-d'] );
+like($result, qr/Site configuration information/,
+ 'config information dumped with -d');
+
+
+# check -v
+$result = runperl( progfile => $extracted_program,
+ args => ['-d', '-v'] );
+like($result, qr/Complete configuration data/,
+ 'full config information dumped with -d -v');
+
+# check that we need -t
+$result = runperl( progfile => $extracted_program,
+ stderr => 1, # perlbug dies with "\n";
+ stdin => undef);
+like($result, qr/Please use perlbug interactively./,
+ 'checks for terminal in non-test mode');
+
+
+# test -okay (mostly noninteractive)
+$result = runperl( progfile => $extracted_program,
+ args => ['-okay', '-F', $testreport] );
+like($result, qr/Message saved/, 'build report saved');
+like(_slurp($testreport), qr/Perl reported to build OK on this system/,
+ 'build report looks sane');
+unlink $testreport;
+
+
+# test -nokay (a bit more interactive)
+$result = runperl( progfile => $extracted_program,
+ stdin => 'f', # save to File
+ args => ['-t',
+ '-nokay',
+ '-e', 'file',
+ '-F', $testreport] );
+like($result, qr/Message saved/, 'build failure report saved');
+like(_slurp($testreport), qr/This is a build failure report for perl/,
+ 'build failure report looks sane');
+unlink $testreport;
+
+
+# test a regular report
+$result = runperl( progfile => $extracted_program,
+ # no CLI options for these
+ stdin => "\n" # Module
+ . "\n" # Category
+ . "\n" # Severity
+ . "\n" # Editor
+ . "f", # save to File
+ args => ['-t',
+ # runperl has trouble with whitespace
+ '-s', "testingperlbug",
+ '-r', 'username@example.com',
+ '-c', 'none',
+ '-b', 'testreportbody',
+ '-e', 'file',
+ '-F', $testreport] );
+like($result, qr/Message saved/, 'fake bug report saved');
+my $contents = _slurp($testreport);
+like($contents, qr/Subject: testingperlbug/,
+ 'Subject included in fake bug report');
+like($contents, qr/testreportbody/, 'body included in fake bug report');
+unlink $testreport;
+
+
+# test wrapping of long lines
+my $body = 'body.txt';
+unlink $body;
+my $A = 'A'x9;
+ok(_dump($body, ("$A "x120)), 'wrote 1200-char body to file');
+
+my $attachment = 'attached.txt';
+unlink $attachment;
+my $B = 'B'x9;
+ok(_dump($attachment, ("$B "x120)), 'wrote 1200-char attachment to file');
+
+$result = runperl( progfile => $extracted_program,
+ stdin => "testing perlbug\n" # Subject
+ . "\n" # Module
+ . "\n" # Category
+ . "\n" # Severity
+ . "f", # save to File
+ args => ['-t',
+ '-r', 'username@example.com',
+ '-c', 'none',
+ '-f', $body,
+ '-p', $attachment,
+ '-e', 'file',
+ '-F', $testreport] );
+like($result, qr/Message saved/, 'fake bug report saved');
+my $contents = _slurp($testreport);
+unlink $testreport, $body, $attachment;
+like($contents, qr/Subject: testing perlbug/,
+ 'Subject included in fake bug report');
+like($contents, qr/$A/, 'body included in fake bug report');
+like($contents, qr/$B/, 'attachment included in fake bug report');
+
+my $maxlen1 = 0; # body
+my $maxlen2 = 0; # attachment
+for (split(/\n/, $contents)) {
+ my $len = length;
+ $maxlen1 = $len if $len > $maxlen1 and !/$B/;
+ $maxlen2 = $len if $len > $maxlen2 and /$B/;
+}
+ok($maxlen1 < 1000, "[perl #128020] long body lines are wrapped: maxlen $maxlen1");
+ok($maxlen2 > 1000, "long attachment lines are not wrapped: maxlen $maxlen2");
#
# trace ... if main::DEBUG && $to_trace;
#
+# main::stack_trace() will display what its name implies
+#
# If there is just one or a few files that you're debugging, you can easily
# cause most everything else to be skipped. Change the line
#
}
}
+sub stack_trace() {
+ local $to_trace = 1 if main::DEBUG;
+ my $line = (caller(0))[2];
+ my $i = 1;
+
+ # Accumulate the stack trace
+ while (1) {
+ my ($pkg, $file, $caller_line, $caller) = caller $i++;
+
+ last unless defined $caller;
+
+ trace "called from $caller() at line $line";
+ $line = $caller_line;
+ }
+}
+
# This is for a rarely used development feature that allows you to compare two
# versions of the Unicode standard without having to deal with changes caused
# by the code points introduced in the later version. You probably also want
# used to override calculations.
main::set_access('format', \%format, 'r', 'p_s');
+ my %has_dependency;
+ # A boolean that gives whether some other table in this property is
+ # defined as the complement of this table. This is a crude, but currently
+ # sufficient, mechanism to make this table not get destroyed before what
+ # is dependent on it is. Other dependencies could be added, so the name
+ # was chosen to reflect a more general situation than actually is
+ # currently the case.
+ main::set_access('has_dependency', \%has_dependency, 'r', 's');
+
sub new {
# All arguments are key => value pairs, which you can see below, most
# of which match fields documented above. Otherwise: Re_Pod_Entry,
$note{$addr} = [ ];
$file_path{$addr} = [ ];
$locked{$addr} = "";
+ $has_dependency{$addr} = 0;
push @{$description{$addr}}, $description if $description;
push @{$note{$addr}}, $note if $note;
}
if ($write_as_invlist) {
+ if ( $previous_end > 0
+ && $output_range_counts{$addr})
+ {
+ my $complement_count = $start - $previous_end - 1;
+ if ($complement_count > 1) {
+ $OUT[-1] = merge_single_annotation_line(
+ $OUT[-1],
+ "#"
+ . (" " x 17)
+ . "["
+ . main::clarify_code_point_count(
+ $complement_count)
+ . "] in complement\n",
+ $comment_indent);
+ }
+ }
# Inversion list format has a single number per line,
# the starting code point of a range that matches the
}
my $addr = do { no overloading; pack 'J', $self; };
$complement{$addr} = $other;
+
+ # Be sure the other property knows we are depending on them; or the
+ # other table if it is one in the current property.
+ if ($self->property != $other->property) {
+ $other->property->set_has_dependency(1);
+ }
+ else {
+ $other->set_has_dependency(1);
+ }
$self->lock;
return;
}
main::set_access('pre_declared_maps',
\%pre_declared_maps, 'r', 's');
+ my %has_dependency;
+ # A boolean that gives whether some table somewhere is defined as the
+ # complement of a table in this property. This is a crude, but currently
+ # sufficient, mechanism to make this property not get destroyed before
+ # what is dependent on it is. Other dependencies could be added, so the
+ # name was chosen to reflect a more general situation than actually is
+ # currently the case.
+ main::set_access('has_dependency', \%has_dependency, 'r', 's');
+
sub new {
# The only required parameter is the positionally first, name. All
# other parameters are key => value pairs. See the documentation just
$has_only_code_point_maps{$addr} = 1;
$table_ref{$addr} = { };
$unique_maps{$addr} = { };
+ $has_dependency{$addr} = 0;
$map{$addr} = Map_Table->new($name,
Full_Name => $full_name{$addr},
+ ord("(")
+ ord(")")
+ ord("-")
- + utf8::unicode_to_native(0xA0) # NBSP
);
my @composition = ('Name', 'Unicode_1_Name', '_Perl_Name_Alias');
# Sort these so get results in same order on different runs of this
# program
- foreach my $property (sort { $a->name cmp $b->name } property_ref('*')) {
- foreach my $table (sort { $a->name cmp $b->name } $property->tables) {
+ foreach my $property (sort { $a->has_dependency <=> $b->has_dependency
+ or
+ lc $a->name cmp lc $b->name
+ } property_ref('*'))
+ {
+ foreach my $table (sort { $a->has_dependency <=> $b->has_dependency
+ or
+ lc $a->name cmp lc $b->name
+ } $property->tables)
+ {
# Find code points that match, and don't match this table.
my $valid = $table->get_valid_code_point;
else
PL_numeric_radix_sv = NULL;
- DEBUG_L(PerlIO_printf(Perl_debug_log, "Locale radix is %s, ?UTF-8=%d\n",
+ DEBUG_L(PerlIO_printf(Perl_debug_log, "Locale radix is '%s', ?UTF-8=%d\n",
(PL_numeric_radix_sv)
? SvPVX(PL_numeric_radix_sv)
: "NULL",
#ifdef MB_CUR_MAX
/* We only handle single-byte locales (outside of UTF-8 ones; so if
- * this locale requires than one byte, there are going to be
+ * this locale requires more than one byte, there are going to be
* problems. */
if (check_for_problems && MB_CUR_MAX > 1
* Any code changing the locale (outside this file) should use
* POSIX::setlocale, which calls this function. Therefore this function
* should be called directly only from this file and from
- * POSIX::setlocale() */
+ * POSIX::setlocale().
+ *
+ * The design of locale collation is that every locale change is given an
+ * index 'PL_collation_ix'. The first time a string particpates in an
+ * operation that requires collation while locale collation is active, it
+ * is given PERL_MAGIC_collxfrm magic (via sv_collxfrm_flags()). That
+ * magic includes the collation index, and the transformation of the string
+ * by strxfrm(), q.v. That transformation is used when doing comparisons,
+ * instead of the string itself. If a string changes, the magic is
+ * cleared. The next time the locale changes, the index is incremented,
+ * and so we know during a comparison that the transformation is not
+ * necessarily still valid, and so is recomputed. Note that if the locale
+ * changes enough times, the index could wrap (a U32), and it is possible
+ * that a transformation would improperly be considered valid, leading to
+ * an unlikely bug */
if (! newcoll) {
if (PL_collation_name) {
return;
}
+ /* If this is not the same locale as currently, set the new one up */
if (! PL_collation_name || strNE(PL_collation_name, newcoll)) {
++PL_collation_ix;
Safefree(PL_collation_name);
PL_collation_standard = isNAME_C_OR_POSIX(newcoll);
{
+ /* A locale collation definition includes primary, secondary,
+ * tertiary, etc. weights for each character. To sort, the primary
+ * weights are used, and only if they compare equal, then the
+ * secondary weights are used, and only if they compare equal, then
+ * the tertiary, etc. strxfrm() works by taking the input string,
+ * say ABC, and creating an output string consisting of first the
+ * primary weights, A¹B¹C¹ followed by the secondary ones, A²B²C²;
+ * and then the tertiary, etc, yielding A¹B¹C¹A²B²C²A³B³C³....
+ * Some characters may not have weights at every level. In our
+ * example, let's say B doesn't have a tertiary weight, and A
+ * doesn't have a secondary weight. The constructed string is then
+ * going to be A¹B¹C¹B²C²A³C³.... This has the desired
+ * characteristics that strcmp() will look at the secondary or
+ * tertiary weights only if the strings compare equal at all higher
+ * priority weights. The length of the transformed string is
+ * roughly a linear function of the input string. It's not exactly
+ * linear because some characters don't have weights at all levels,
+ * and there are some complications, so there is often per-string
+ * overhead. When we call strxfrm() we have to allocate some
+ * memory to hold the transformed string. The calculations below
+ * try to find constants for this locale 'm' and 'b' so that m*x +
+ * b equals how much space we need given the size of the input
+ * string in 'x'. If we calculate too small, we increase the size
+ * as needed, and call strxfrm() again, but it is better to get it
+ * right the first time to avoid wasted expensive string
+ * transformations. */
/* 2: at most so many chars ('a', 'b'). */
/* 50: surely no system expands a char more. */
#define XFRMBUFSIZE (2 * 50)
* differences. First, it handles embedded NULs. Second, it allocates
* a bit more memory than needed for the transformed data itself.
* The real transformed data begins at offset sizeof(collationix).
+ * *xlen is set to the length of that, and doesn't include the collation index
+ * size.
* Please see sv_collxfrm() to see how this is used.
*/
xAlloc = sizeof(PL_collation_ix) + PL_collxfrm_base + (PL_collxfrm_mult * len) + 1;
Newx(xbuf, xAlloc, char);
- if (! xbuf)
+ if (UNLIKELY(! xbuf))
goto bad;
+ /* Store the collation id */
*(U32*)xbuf = PL_collation_ix;
xout = sizeof(PL_collation_ix);
+
+ /* Then the transformation of the input. We loop until successful, or we
+ * give up */
for (xin = 0; xin < len; ) {
Size_t xused;
for (;;) {
xused = strxfrm(xbuf + xout, s + xin, xAlloc - xout);
- if (xused >= PERL_INT_MAX)
- goto bad;
+
+ /* If the transformed string occupies less space than we told
+ * strxfrm() was available, it means it successfully transformed
+ * the whole string. */
if ((STRLEN)xused < xAlloc - xout)
break;
+
+ if (UNLIKELY(xused >= PERL_INT_MAX))
+ goto bad;
+
+ /* Otherwise it should be that the transformation stopped in the
+ * middle because it ran out of space. Malloc more, and try again.
+ * */
xAlloc = (2 * xAlloc) + 1;
Renew(xbuf, xAlloc, char);
- if (! xbuf)
+ if (UNLIKELY(! xbuf))
goto bad;
}
die "Inconsistent module $mname has both lib/ and $first/"
if $has_lib && $has_topdir;
- print "\nRunning pm_to_blib for $ext_dir directly\n"
+ print "Running pm_to_blib for $ext_dir directly\n"
unless $silent;
my %pm;
);
}
-if ($define{'NO_MATHOMS'}) {
- # win32 builds happen in the win32/ subdirectory, but vms builds happen
- # at the top level, so we need to look in two candidate locations for
- # the mathoms.c file.
- my ($file) = grep { -f } qw( mathoms.c ../mathoms.c )
- or die "No mathoms.c file found in . or ..\n";
- open my $mathoms, '<', $file
- or die "Cannot open $file: $!\n";
- while (<$mathoms>) {
- ++$skip{$1} if /\A ( NATIVE_TO_NEED
- | ASCII_TO_NEED
- | Perl_\w+ ) \s* \( /axms;
- }
-}
-
unless ($define{'PERL_NEED_APPCTX'}) {
++$skip{PL_appctx};
}
foreach (@$embed) {
my ($flags, $retval, $func, @args) = @$_;
next unless $func;
- if ($flags =~ /[AX]/ && $flags !~ /[xmi]/ || $flags =~ /b/) {
+ if ( ($flags =~ /[AX]/ && $flags !~ /[xmi]/)
+ || ($flags =~ /b/ && ! $define{'NO_MATHOMS'}))
+ {
# public API, so export
# If a function is defined twice, for example before and after
# mean "don't export"
next if $seen{$func}++;
# Should we also skip adding the Perl_ prefix if $flags =~ /o/ ?
- $func = "Perl_$func" if ($flags =~ /[pbX]/ && $func !~ /^Perl_/);
+ $func = "Perl_$func" if ($flags =~ /[pX]/ && $func !~ /^Perl_/);
++$export{$func} unless exists $skip{$func};
}
}
-/*
+/*
* This file contains mathoms, various binary artifacts from previous
* versions of Perl. For binary or source compatibility reasons, though,
- * we cannot completely remove them from the core code.
+ * we cannot completely remove them from the core code.
*
* REMEMBER to update makedef.pl when adding a function to mathoms.c whose
* name doesn't begin with "Perl_".
*/
#else
-/* Not all of these have prototypes elsewhere, so do this to get
- * non-mangled names.
- */
-START_EXTERN_C
-
-PERL_CALLCONV OP * Perl_ref(pTHX_ OP *o, I32 type);
-PERL_CALLCONV void Perl_sv_unref(pTHX_ SV *sv);
-PERL_CALLCONV void Perl_sv_taint(pTHX_ SV *sv);
-PERL_CALLCONV IV Perl_sv_2iv(pTHX_ SV *sv);
-PERL_CALLCONV UV Perl_sv_2uv(pTHX_ SV *sv);
-PERL_CALLCONV NV Perl_sv_2nv(pTHX_ SV *sv);
-PERL_CALLCONV char * Perl_sv_2pv(pTHX_ SV *sv, STRLEN *lp);
-PERL_CALLCONV char * Perl_sv_2pv_nolen(pTHX_ SV *sv);
-PERL_CALLCONV char * Perl_sv_2pvbyte_nolen(pTHX_ SV *sv);
-PERL_CALLCONV char * Perl_sv_2pvutf8_nolen(pTHX_ SV *sv);
-PERL_CALLCONV void Perl_sv_force_normal(pTHX_ SV *sv);
-PERL_CALLCONV void Perl_sv_setsv(pTHX_ SV *dstr, SV *sstr);
-PERL_CALLCONV void Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen);
-PERL_CALLCONV void Perl_sv_catpvn_mg(pTHX_ SV *sv, const char *ptr, STRLEN len);
-PERL_CALLCONV void Perl_sv_catsv(pTHX_ SV *dstr, SV *sstr);
-PERL_CALLCONV void Perl_sv_catsv_mg(pTHX_ SV *dsv, SV *ssv);
-PERL_CALLCONV char * Perl_sv_pv(pTHX_ SV *sv);
-PERL_CALLCONV char * Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp);
-PERL_CALLCONV char * Perl_sv_pvbyte(pTHX_ SV *sv);
-PERL_CALLCONV char * Perl_sv_pvutf8(pTHX_ SV *sv);
-PERL_CALLCONV STRLEN Perl_sv_utf8_upgrade(pTHX_ SV *sv);
-PERL_CALLCONV NV Perl_huge(void);
-PERL_CALLCONV void Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix);
-PERL_CALLCONV void Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix);
-PERL_CALLCONV GV * Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name);
-PERL_CALLCONV HE * Perl_hv_iternext(pTHX_ HV *hv);
-PERL_CALLCONV void Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how);
-PERL_CALLCONV bool Perl_do_open(pTHX_ GV *gv, const char *name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO *supplied_fp);
-PERL_CALLCONV bool Perl_do_aexec(pTHX_ SV *really, SV **mark, SV **sp);
-PERL_CALLCONV U8 * Perl_uvuni_to_utf8(pTHX_ U8 *d, UV uv);
-PERL_CALLCONV bool Perl_is_utf8_string_loc(pTHX_ const U8 *s, STRLEN len, const U8 **ep);
-PERL_CALLCONV void Perl_sv_nolocking(pTHX_ SV *sv);
-PERL_CALLCONV void Perl_sv_usepvn_mg(pTHX_ SV *sv, char *ptr, STRLEN len);
-PERL_CALLCONV void Perl_sv_usepvn(pTHX_ SV *sv, char *ptr, STRLEN len);
-PERL_CALLCONV int Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...);
-PERL_CALLCONV int Perl_printf_nocontext(const char *format, ...);
-PERL_CALLCONV int Perl_magic_setglob(pTHX_ SV* sv, MAGIC* mg);
-PERL_CALLCONV AV * Perl_newAV(pTHX);
-PERL_CALLCONV HV * Perl_newHV(pTHX);
-PERL_CALLCONV IO * Perl_newIO(pTHX);
-PERL_CALLCONV I32 Perl_my_stat(pTHX);
-PERL_CALLCONV I32 Perl_my_lstat(pTHX);
-PERL_CALLCONV I32 Perl_sv_eq(pTHX_ SV *sv1, SV *sv2);
-PERL_CALLCONV char * Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp);
-PERL_CALLCONV bool Perl_sv_2bool(pTHX_ SV *const sv);
-PERL_CALLCONV CV * Perl_newSUB(pTHX_ I32 floor, OP* o, OP* proto, OP* block);
-PERL_CALLCONV UV Perl_to_utf8_lower(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp);
-PERL_CALLCONV UV Perl_to_utf8_title(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp);
-PERL_CALLCONV UV Perl_to_utf8_upper(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp);
-PERL_CALLCONV UV Perl_to_utf8_fold(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp);
-PERL_CALLCONV SV *Perl_sv_mortalcopy(pTHX_ SV *const oldstr);
+/* NOTE ALL FUNCTIONS IN THIS FILE should have an entry with the 'b' flag in
+ * embed.fnc.
+ *
+ * To move a function to this file, simply cut and paste it here, and change
+ * its embed.fnc entry to additionally have the 'b' flag. If, for some reason
+ * a function you'd like to be treated as mathoms can't be moved from its
+ * current place, simply enclose it between
+ *
+ * #ifndef NO_MATHOMS
+ * ...
+ * #endif
+ *
+ * and add the 'b' flag in embed.fnc.
+ *
+ * */
/* ref() is now a macro using Perl_doref;
* this version provided for binary compatibility only.
}
bool
-Perl_is_utf8_string_loc(pTHX_ const U8 *s, STRLEN len, const U8 **ep)
+Perl_is_utf8_string_loc(const U8 *s, STRLEN len, const U8 **ep)
{
PERL_ARGS_ASSERT_IS_UTF8_STRING_LOC;
- PERL_UNUSED_CONTEXT;
return is_utf8_string_loclen(s, len, ep, 0);
}
return PAD_COMPNAME_TYPE(po);
}
+/* return ptr to little string in big string, NULL if not found */
+/* The original version of this routine was donated by Corey Satten. */
-END_EXTERN_C
+char *
+Perl_instr(const char *big, const char *little)
+{
+ PERL_ARGS_ASSERT_INSTR;
+
+ return instr((char *) big, (char *) little);
+}
#endif /* NO_MATHOMS */
goto nope; /* Don't try to run w/ errors */
for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
- const OPCODE type = curop->op_type;
- if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
- type != OP_LIST &&
- type != OP_SCALAR &&
- type != OP_NULL &&
- type != OP_PUSHMARK)
- {
+ switch (curop->op_type) {
+ case OP_CONST:
+ if ( (curop->op_private & OPpCONST_BARE)
+ && (curop->op_private & OPpCONST_STRICT)) {
+ no_bareword_allowed(curop);
+ goto nope;
+ }
+ /* FALLTHROUGH */
+ case OP_LIST:
+ case OP_SCALAR:
+ case OP_NULL:
+ case OP_PUSHMARK:
+ /* Foldable; move to next op in list */
+ break;
+
+ default:
+ /* No other op types are considered foldable */
goto nope;
}
}
|| type == OP_CUSTOM);
scalarboolean(first);
- /* optimize AND and OR ops that have NOTs as children */
- if (first->op_type == OP_NOT
- && (first->op_flags & OPf_KIDS)
- && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
- || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
- ) {
- if (type == OP_AND || type == OP_OR) {
- if (type == OP_AND)
- type = OP_OR;
- else
- type = OP_AND;
- op_null(first);
- if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
- op_null(other);
- prepend_not = 1; /* prepend a NOT op later */
- }
- }
- }
+
/* search for a constant op that could let us fold the test */
if ((cstop = search_const(first))) {
if (cstop->op_private & OPpCONST_STRICT)
if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
(type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
(type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
+ /* Elide the (constant) lhs, since it can't affect the outcome */
*firstp = NULL;
if (other->op_type == OP_CONST)
other->op_private |= OPpCONST_SHORTCIRCUIT;
return other;
}
else {
+ /* Elide the rhs, since the outcome is entirely determined by
+ * the (constant) lhs */
+
/* check for C<my $x if 0>, or C<my($x,$y) if 0> */
const OP *o2 = other;
if ( ! (o2->op_type == OP_LIST
*otherp = NULL;
if (cstop->op_type == OP_CONST)
cstop->op_private |= OPpCONST_SHORTCIRCUIT;
- op_free(other);
+ op_free(other);
return first;
}
}
}
}
- if (!other)
- return first;
-
if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
+ /* optimize AND and OR ops that have NOTs as children */
+ if (first->op_type == OP_NOT
+ && (first->op_flags & OPf_KIDS)
+ && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
+ || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
+ ) {
+ if (type == OP_AND || type == OP_OR) {
+ if (type == OP_AND)
+ type = OP_OR;
+ else
+ type = OP_AND;
+ op_null(first);
+ if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
+ op_null(other);
+ prepend_not = 1; /* prepend a NOT op later */
+ }
+ }
+ }
+
logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
logop->op_flags |= (U8)flags;
logop->op_private = (U8)(1 | (flags >> 8));
if (ckWARN(WARN_REDEFINE)
|| ( ckWARN_d(WARN_REDEFINE)
&& ( !const_sv || SvRV(gv) == const_sv
- || sv_cmp(SvRV(gv), const_sv) )))
+ || sv_cmp(SvRV(gv), const_sv) ))) {
+ assert(cSVOPo);
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
"Constant subroutine %"SVf" redefined",
SVfARG(cSVOPo->op_sv));
+ }
SvREFCNT_inc_simple_void_NN(PL_compcv);
CopLINE_set(PL_curcop, oldline);
s = SvPVX(sv);
len = SvCUR(sv);
end = s + len;
+ /* treat ::foo::bar as foo::bar */
+ if (len >= 2 && s[0] == ':' && s[1] == ':')
+ DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
+ if (s == end)
+ DIE(aTHX_ "Bareword in require maps to empty filename");
+
for (; s < end; s++) {
if (*s == ':' && s[1] == ':') {
*s = '/';
|| ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
&& SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
)
- /* we let ck_fun handle it */
- break;
+ goto bad;
default:
- Perl_croak_nocontext(
+ yyerror_pv(Perl_form(aTHX_
"Experimental %s on scalar is now forbidden",
- PL_op_desc[orig_type]);
- break;
+ PL_op_desc[orig_type]), 0);
+ bad:
+ bad_type_pv(1, "hash or array", o, kid);
+ return o;
}
}
return ck_fun(o);
case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
case KEY_each: retsetpvs("\\[%@]", OP_EACH);
- case KEY_push: retsetpvs("\\@@", OP_PUSH);
- case KEY_unshift: retsetpvs("\\@@", OP_UNSHIFT);
- case KEY_pop: retsetpvs(";\\@", OP_POP);
- case KEY_shift: retsetpvs(";\\@", OP_SHIFT);
case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
- case KEY_splice:
- retsetpvs("\\@;$$@", OP_SPLICE);
case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
retsetpvs("", 0);
case KEY_evalbytes:
#define PERL_REVISION 5 /* age */
#define PERL_VERSION 25 /* epoch */
-#define PERL_SUBVERSION 0 /* generation */
+#define PERL_SUBVERSION 1 /* 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 0
+#define PERL_API_SUBVERSION 1
/*
XXX Note: The selection of non-default Configure options, such
as -Duselonglong may invalidate these settings. Currently, Configure
=cut
*/
+static void
+S_fixup_platform_bugs(void)
+{
+#if defined(__GLIBC__) && IVSIZE == 8 \
+ && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
+ {
+ IV l = 3;
+ IV r = -10;
+ /* Cannot do this check with inlined IV constants since
+ * that seems to work correctly even with the buggy glibc. */
+ if (l % r == -3) {
+ dTHX;
+ /* Yikes, we have the bug.
+ * Patch in the workaround version. */
+ PL_ppaddr[OP_I_MODULO] = &Perl_pp_i_modulo_glibc_bugfix;
+ }
+ }
+#endif
+}
+
void
perl_construct(pTHXx)
{
init_ids();
+ S_fixup_platform_bugs();
+
JMPENV_BOOTSTRAP;
STATUS_ALL_SUCCESS;
my_fflush_all();
#ifdef PERL_TRACE_OPS
- /* If we traced all Perl OP usage, report and clean up */
+ /* dump OP-counts if $ENV{PERL_TRACE_OPS} > 0 */
+ {
+ const char * const ptoenv = PerlEnv_getenv("PERL_TRACE_OPS");
+ UV uv;
+
+ if (!ptoenv || !Perl_grok_atoUV(ptoenv, &uv, NULL)
+ || !(uv > 0))
+ goto no_trace_out;
+ }
PerlIO_printf(Perl_debug_log, "Trace of all OPs executed:\n");
for (i = 0; i <= OP_max; ++i) {
- PerlIO_printf(Perl_debug_log, " %s: %"UVuf"\n", PL_op_name[i], PL_op_exec_cnt[i]);
- PL_op_exec_cnt[i] = 0;
+ if (PL_op_exec_cnt[i])
+ PerlIO_printf(Perl_debug_log, " %s: %"UVuf"\n", PL_op_name[i], PL_op_exec_cnt[i]);
}
/* Utility slot for easily doing little tracing experiments in the runloop: */
if (PL_op_exec_cnt[OP_max+1] != 0)
PerlIO_printf(Perl_debug_log, " SPECIAL: %"UVuf"\n", PL_op_exec_cnt[OP_max+1]);
PerlIO_printf(Perl_debug_log, "\n");
+ no_trace_out:
#endif
# ifdef PERL_MEM_LOG_NOIMPL
" PERL_MEM_LOG_NOIMPL"
# endif
+# ifdef PERL_OP_PARENT
+ " PERL_OP_PARENT"
+# endif
# ifdef PERL_PERTURB_KEYS_DETERMINISTIC
" PERL_PERTURB_KEYS_DETERMINISTIC"
# endif
typedef struct padnamelist PADNAMELIST;
typedef struct padname PADNAME;
+/* enable PERL_OP_PARENT by default */
+#if !defined(PERL_OP_PARENT) && !defined(PERL_NO_OP_PARENT)
+# define PERL_OP_PARENT
+#endif
+
/* enable PERL_COPY_ON_WRITE by default */
#if !defined(PERL_COPY_ON_WRITE) && !defined(PERL_NO_COW)
# define PERL_COPY_ON_WRITE
#line 115 "perly.y"
{
parser->expect = XSTATE;
- }
+ ;}
break;
case 3:
newPROG(block_end((ps[(3) - (4)].val.ival),(ps[(4) - (4)].val.opval)));
PL_compiling.cop_seq = 0;
(yyval.ival) = 0;
- }
+ ;}
break;
case 4:
#line 125 "perly.y"
{
parser->expect = XTERM;
- }
+ ;}
break;
case 5:
{
PL_eval_root = (ps[(3) - (3)].val.opval);
(yyval.ival) = 0;
- }
+ ;}
break;
case 6:
#line 134 "perly.y"
{
parser->expect = XBLOCK;
- }
+ ;}
break;
case 7:
(yyval.ival) = 0;
yyunlex();
parser->yychar = YYEOF;
- }
+ ;}
break;
case 8:
#line 146 "perly.y"
{
parser->expect = XSTATE;
- }
+ ;}
break;
case 9:
(yyval.ival) = 0;
yyunlex();
parser->yychar = YYEOF;
- }
+ ;}
break;
case 10:
#line 158 "perly.y"
{
parser->expect = XSTATE;
- }
+ ;}
break;
case 11:
(yyval.ival) = 0;
yyunlex();
parser->yychar = YYEOF;
- }
+ ;}
break;
case 12:
#line 170 "perly.y"
{
parser->expect = XSTATE;
- }
+ ;}
break;
case 13:
{
PL_eval_root = (ps[(3) - (3)].val.opval);
(yyval.ival) = 0;
- }
+ ;}
break;
case 14:
{ if (parser->copline > (line_t)(ps[(1) - (4)].val.ival))
parser->copline = (line_t)(ps[(1) - (4)].val.ival);
(yyval.opval) = block_end((ps[(2) - (4)].val.ival), (ps[(3) - (4)].val.opval));
- }
+ ;}
break;
case 15:
{ if (parser->copline > (line_t)(ps[(1) - (7)].val.ival))
parser->copline = (line_t)(ps[(1) - (7)].val.ival);
(yyval.opval) = block_end((ps[(2) - (7)].val.ival), (ps[(5) - (7)].val.opval));
- }
+ ;}
break;
case 16:
#line 197 "perly.y"
{ (yyval.ival) = block_start(TRUE);
- parser->parsed_sub = 0; }
+ parser->parsed_sub = 0; ;}
break;
case 17:
{ if (parser->copline > (line_t)(ps[(1) - (4)].val.ival))
parser->copline = (line_t)(ps[(1) - (4)].val.ival);
(yyval.opval) = block_end((ps[(2) - (4)].val.ival), (ps[(3) - (4)].val.opval));
- }
+ ;}
break;
case 18:
#line 209 "perly.y"
{ (yyval.ival) = block_start(FALSE);
- parser->parsed_sub = 0; }
+ parser->parsed_sub = 0; ;}
break;
case 19:
#line 215 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+ { (yyval.opval) = (OP*)NULL; ;}
break;
case 20:
PL_pad_reset_pending = TRUE;
if ((ps[(1) - (2)].val.opval) && (ps[(2) - (2)].val.opval))
PL_hints |= HINT_BLOCK_SCOPE;
- }
+ ;}
break;
case 21:
#line 226 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+ { (yyval.opval) = (OP*)NULL; ;}
break;
case 22:
PL_pad_reset_pending = TRUE;
if ((ps[(1) - (2)].val.opval) && (ps[(2) - (2)].val.opval))
PL_hints |= HINT_BLOCK_SCOPE;
- }
+ ;}
break;
case 23:
#line 237 "perly.y"
{
(yyval.opval) = (ps[(1) - (1)].val.opval) ? newSTATEOP(0, NULL, (ps[(1) - (1)].val.opval)) : NULL;
- }
+ ;}
break;
case 24:
#line 241 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 25:
#line 245 "perly.y"
{
(yyval.opval) = newSTATEOP(SVf_UTF8 * (ps[(1) - (2)].val.pval)[strlen((ps[(1) - (2)].val.pval))+1], (ps[(1) - (2)].val.pval), (ps[(2) - (2)].val.opval));
- }
+ ;}
break;
case 26:
#line 249 "perly.y"
{
(yyval.opval) = newSTATEOP(SVf_UTF8 * (ps[(1) - (2)].val.pval)[strlen((ps[(1) - (2)].val.pval))+1], (ps[(1) - (2)].val.pval), (ps[(2) - (2)].val.opval));
- }
+ ;}
break;
case 27:
#line 256 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 28:
pad_add_weakref(fmtcv);
}
parser->parsed_sub = 1;
- }
+ ;}
break;
case 29:
CvCLONE_on(PL_compcv);
parser->in_my = 0;
parser->in_my_stash = NULL;
- }
+ ;}
break;
case 30:
(yyval.opval) = (OP*)NULL;
intro_my();
parser->parsed_sub = 1;
- }
+ ;}
break;
case 31:
CvCLONE_on(PL_compcv);
parser->in_my = 0;
parser->in_my_stash = NULL;
- }
+ ;}
break;
case 32:
(yyval.opval) = (OP*)NULL;
intro_my();
parser->parsed_sub = 1;
- }
+ ;}
break;
case 33:
if ((ps[(2) - (4)].val.opval))
package_version((ps[(2) - (4)].val.opval));
(yyval.opval) = (OP*)NULL;
- }
+ ;}
break;
case 34:
#line 347 "perly.y"
- { CvSPECIAL_on(PL_compcv); /* It's a BEGIN {} */ }
+ { CvSPECIAL_on(PL_compcv); /* It's a BEGIN {} */ ;}
break;
case 35:
utilize((ps[(1) - (7)].val.ival), (ps[(2) - (7)].val.ival), (ps[(4) - (7)].val.opval), (ps[(5) - (7)].val.opval), (ps[(6) - (7)].val.opval));
parser->parsed_sub = 1;
(yyval.opval) = (OP*)NULL;
- }
+ ;}
break;
case 36:
(yyval.opval) = block_end((ps[(3) - (7)].val.ival),
newCONDOP(0, (ps[(4) - (7)].val.opval), op_scope((ps[(6) - (7)].val.opval)), (ps[(7) - (7)].val.opval)));
parser->copline = (line_t)(ps[(1) - (7)].val.ival);
- }
+ ;}
break;
case 37:
(yyval.opval) = block_end((ps[(3) - (7)].val.ival),
newCONDOP(0, (ps[(4) - (7)].val.opval), (ps[(7) - (7)].val.opval), op_scope((ps[(6) - (7)].val.opval))));
parser->copline = (line_t)(ps[(1) - (7)].val.ival);
- }
+ ;}
break;
case 38:
{
(yyval.opval) = block_end((ps[(3) - (6)].val.ival), newGIVENOP((ps[(4) - (6)].val.opval), op_scope((ps[(6) - (6)].val.opval)), 0));
parser->copline = (line_t)(ps[(1) - (6)].val.ival);
- }
+ ;}
break;
case 39:
#line 373 "perly.y"
- { (yyval.opval) = block_end((ps[(3) - (6)].val.ival), newWHENOP((ps[(4) - (6)].val.opval), op_scope((ps[(6) - (6)].val.opval)))); }
+ { (yyval.opval) = block_end((ps[(3) - (6)].val.ival), newWHENOP((ps[(4) - (6)].val.opval), op_scope((ps[(6) - (6)].val.opval)))); ;}
break;
case 40:
#line 375 "perly.y"
- { (yyval.opval) = newWHENOP(0, op_scope((ps[(2) - (2)].val.opval))); }
+ { (yyval.opval) = newWHENOP(0, op_scope((ps[(2) - (2)].val.opval))); ;}
break;
case 41:
newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
(ps[(4) - (8)].val.opval), (ps[(7) - (8)].val.opval), (ps[(8) - (8)].val.opval), (ps[(6) - (8)].val.ival)));
parser->copline = (line_t)(ps[(1) - (8)].val.ival);
- }
+ ;}
break;
case 42:
newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
(ps[(4) - (8)].val.opval), (ps[(7) - (8)].val.opval), (ps[(8) - (8)].val.opval), (ps[(6) - (8)].val.ival)));
parser->copline = (line_t)(ps[(1) - (8)].val.ival);
- }
+ ;}
break;
case 43:
#line 391 "perly.y"
- { parser->expect = XTERM; }
+ { parser->expect = XTERM; ;}
break;
case 44:
#line 393 "perly.y"
- { parser->expect = XTERM; }
+ { parser->expect = XTERM; ;}
break;
case 45:
PL_hints |= HINT_BLOCK_SCOPE;
(yyval.opval) = block_end((ps[(3) - (13)].val.ival), forop);
parser->copline = (line_t)(ps[(1) - (13)].val.ival);
- }
+ ;}
break;
case 46:
{
(yyval.opval) = block_end((ps[(3) - (9)].val.ival), newFOROP(0, (ps[(4) - (9)].val.opval), (ps[(6) - (9)].val.opval), (ps[(8) - (9)].val.opval), (ps[(9) - (9)].val.opval)));
parser->copline = (line_t)(ps[(1) - (9)].val.ival);
- }
+ ;}
break;
case 47:
(yyval.opval) = block_end((ps[(4) - (8)].val.ival), newFOROP(0,
op_lvalue((ps[(2) - (8)].val.opval), OP_ENTERLOOP), (ps[(5) - (8)].val.opval), (ps[(7) - (8)].val.opval), (ps[(8) - (8)].val.opval)));
parser->copline = (line_t)(ps[(1) - (8)].val.ival);
- }
+ ;}
break;
case 48:
#line 422 "perly.y"
- { parser->in_my = 0; (yyval.opval) = my((ps[(5) - (5)].val.opval)); }
+ { parser->in_my = 0; (yyval.opval) = my((ps[(5) - (5)].val.opval)); ;}
break;
case 49:
(ps[(8) - (11)].val.opval), (ps[(10) - (11)].val.opval), (ps[(11) - (11)].val.opval))
);
parser->copline = (line_t)(ps[(1) - (11)].val.ival);
- }
+ ;}
break;
case 50:
(ps[(3) - (9)].val.opval)),
OP_ENTERLOOP), (ps[(6) - (9)].val.opval), (ps[(8) - (9)].val.opval), (ps[(9) - (9)].val.opval)));
parser->copline = (line_t)(ps[(1) - (9)].val.ival);
- }
+ ;}
break;
case 51:
(yyval.opval) = block_end((ps[(3) - (7)].val.ival),
newFOROP(0, (OP*)NULL, (ps[(4) - (7)].val.opval), (ps[(6) - (7)].val.opval), (ps[(7) - (7)].val.opval)));
parser->copline = (line_t)(ps[(1) - (7)].val.ival);
- }
+ ;}
break;
case 52:
/* a block is a loop that happens once */
(yyval.opval) = newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
(OP*)NULL, (ps[(1) - (2)].val.opval), (ps[(2) - (2)].val.opval), 0);
- }
+ ;}
break;
case 53:
if ((ps[(2) - (5)].val.opval)) {
package_version((ps[(2) - (5)].val.opval));
}
- }
+ ;}
break;
case 54:
(OP*)NULL, block_end((ps[(5) - (8)].val.ival), (ps[(7) - (8)].val.opval)), (OP*)NULL, 0);
if (parser->copline > (line_t)(ps[(4) - (8)].val.ival))
parser->copline = (line_t)(ps[(4) - (8)].val.ival);
- }
+ ;}
break;
case 55:
#line 472 "perly.y"
{
(yyval.opval) = (ps[(1) - (2)].val.opval);
- }
+ ;}
break;
case 56:
{
(yyval.opval) = (OP*)NULL;
parser->copline = NOLINE;
- }
+ ;}
break;
case 57:
else parser->copline--;
(yyval.opval) = newSTATEOP(0, NULL,
op_convert_list(OP_FORMLINE, 0, list));
- }
+ ;}
break;
case 58:
#line 501 "perly.y"
- { (yyval.opval) = NULL; }
+ { (yyval.opval) = NULL; ;}
break;
case 59:
#line 503 "perly.y"
- { (yyval.opval) = op_unscope((ps[(2) - (3)].val.opval)); }
+ { (yyval.opval) = op_unscope((ps[(2) - (3)].val.opval)); ;}
break;
case 60:
#line 508 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+ { (yyval.opval) = (OP*)NULL; ;}
break;
case 61:
#line 510 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 62:
#line 512 "perly.y"
- { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval)); }
+ { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval)); ;}
break;
case 63:
#line 514 "perly.y"
- { (yyval.opval) = newLOGOP(OP_OR, 0, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval)); }
+ { (yyval.opval) = newLOGOP(OP_OR, 0, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval)); ;}
break;
case 64:
#line 516 "perly.y"
- { (yyval.opval) = newLOOPOP(OPf_PARENS, 1, scalar((ps[(3) - (3)].val.opval)), (ps[(1) - (3)].val.opval)); }
+ { (yyval.opval) = newLOOPOP(OPf_PARENS, 1, scalar((ps[(3) - (3)].val.opval)), (ps[(1) - (3)].val.opval)); ;}
break;
case 65:
#line 518 "perly.y"
- { (yyval.opval) = newLOOPOP(OPf_PARENS, 1, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval)); }
+ { (yyval.opval) = newLOOPOP(OPf_PARENS, 1, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval)); ;}
break;
case 66:
#line 520 "perly.y"
{ (yyval.opval) = newFOROP(0, (OP*)NULL, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval), (OP*)NULL);
- parser->copline = (line_t)(ps[(2) - (3)].val.ival); }
+ parser->copline = (line_t)(ps[(2) - (3)].val.ival); ;}
break;
case 67:
#line 523 "perly.y"
- { (yyval.opval) = newWHENOP((ps[(3) - (3)].val.opval), op_scope((ps[(1) - (3)].val.opval))); }
+ { (yyval.opval) = newWHENOP((ps[(3) - (3)].val.opval), op_scope((ps[(1) - (3)].val.opval))); ;}
break;
case 68:
#line 528 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+ { (yyval.opval) = (OP*)NULL; ;}
break;
case 69:
{
((ps[(2) - (2)].val.opval))->op_flags |= OPf_PARENS;
(yyval.opval) = op_scope((ps[(2) - (2)].val.opval));
- }
+ ;}
break;
case 70:
newSTATEOP(OPf_SPECIAL,NULL,(ps[(3) - (6)].val.opval)),
op_scope((ps[(5) - (6)].val.opval)), (ps[(6) - (6)].val.opval));
PL_hints |= HINT_BLOCK_SCOPE;
- }
+ ;}
break;
case 71:
#line 545 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+ { (yyval.opval) = (OP*)NULL; ;}
break;
case 72:
#line 547 "perly.y"
- { (yyval.opval) = op_scope((ps[(2) - (2)].val.opval)); }
+ { (yyval.opval) = op_scope((ps[(2) - (2)].val.opval)); ;}
break;
case 73:
#line 552 "perly.y"
{ (yyval.ival) = (PL_min_intro_pending &&
PL_max_intro_pending >= PL_min_intro_pending);
- intro_my(); }
+ intro_my(); ;}
break;
case 74:
#line 558 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+ { (yyval.opval) = (OP*)NULL; ;}
break;
case 76:
#line 564 "perly.y"
{ YYSTYPE tmplval;
(void)scan_num("1", &tmplval);
- (yyval.opval) = tmplval.opval; }
+ (yyval.opval) = tmplval.opval; ;}
break;
case 78:
#line 572 "perly.y"
- { (yyval.opval) = invert(scalar((ps[(1) - (1)].val.opval))); }
+ { (yyval.opval) = invert(scalar((ps[(1) - (1)].val.opval))); ;}
break;
case 79:
#line 577 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); }
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); ;}
break;
case 80:
#line 581 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); }
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); ;}
break;
case 81:
#line 584 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 82:
#line 585 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+ { (yyval.opval) = (OP*)NULL; ;}
break;
case 83:
#line 589 "perly.y"
{ (yyval.ival) = start_subparse(FALSE, 0);
- SAVEFREESV(PL_compcv); }
+ SAVEFREESV(PL_compcv); ;}
break;
case 84:
#line 595 "perly.y"
{ (yyval.ival) = start_subparse(FALSE, CVf_ANON);
- SAVEFREESV(PL_compcv); }
+ SAVEFREESV(PL_compcv); ;}
break;
case 85:
#line 600 "perly.y"
{ (yyval.ival) = start_subparse(TRUE, 0);
- SAVEFREESV(PL_compcv); }
+ SAVEFREESV(PL_compcv); ;}
break;
case 88:
#line 611 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+ { (yyval.opval) = (OP*)NULL; ;}
break;
case 90:
#line 617 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+ { (yyval.opval) = (OP*)NULL; ;}
break;
case 91:
#line 619 "perly.y"
- { (yyval.opval) = (ps[(2) - (2)].val.opval); }
+ { (yyval.opval) = (ps[(2) - (2)].val.opval); ;}
break;
case 92:
#line 621 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+ { (yyval.opval) = (OP*)NULL; ;}
break;
case 93:
#line 626 "perly.y"
- { (yyval.opval) = (ps[(2) - (2)].val.opval); }
+ { (yyval.opval) = (ps[(2) - (2)].val.opval); ;}
break;
case 94:
#line 628 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+ { (yyval.opval) = (OP*)NULL; ;}
break;
case 95:
packWARN(WARN_EXPERIMENTAL__SIGNATURES),
"The signatures feature is experimental");
(yyval.opval) = parse_subsignature();
- }
+ ;}
break;
case 96:
(yyval.opval) = op_append_list(OP_LINESEQ, (ps[(2) - (3)].val.opval),
newSTATEOP(0, NULL, sawparens(newNULLLIST())));
parser->expect = XATTRBLOCK;
- }
+ ;}
break;
case 98:
#line 652 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+ { (yyval.opval) = (OP*)NULL; ;}
break;
case 99:
#line 657 "perly.y"
- { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); }
+ { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;}
break;
case 100:
#line 659 "perly.y"
- { (yyval.opval) = newLOGOP((ps[(2) - (3)].val.ival), 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); }
+ { (yyval.opval) = newLOGOP((ps[(2) - (3)].val.ival), 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;}
break;
case 101:
#line 661 "perly.y"
- { (yyval.opval) = newLOGOP(OP_DOR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); }
+ { (yyval.opval) = newLOGOP(OP_DOR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;}
break;
case 103:
#line 667 "perly.y"
- { (yyval.opval) = (ps[(1) - (2)].val.opval); }
+ { (yyval.opval) = (ps[(1) - (2)].val.opval); ;}
break;
case 104:
{
OP* term = (ps[(3) - (3)].val.opval);
(yyval.opval) = op_append_elem(OP_LIST, (ps[(1) - (3)].val.opval), term);
- }
+ ;}
break;
case 106:
#line 678 "perly.y"
{ (yyval.opval) = op_convert_list((ps[(1) - (3)].val.ival), OPf_STACKED,
op_prepend_elem(OP_LIST, newGVREF((ps[(1) - (3)].val.ival),(ps[(2) - (3)].val.opval)), (ps[(3) - (3)].val.opval)) );
- }
+ ;}
break;
case 107:
#line 682 "perly.y"
{ (yyval.opval) = op_convert_list((ps[(1) - (5)].val.ival), OPf_STACKED,
op_prepend_elem(OP_LIST, newGVREF((ps[(1) - (5)].val.ival),(ps[(3) - (5)].val.opval)), (ps[(4) - (5)].val.opval)) );
- }
+ ;}
break;
case 108:
op_append_elem(OP_LIST,
op_prepend_elem(OP_LIST, scalar((ps[(1) - (6)].val.opval)), (ps[(5) - (6)].val.opval)),
newMETHOP(OP_METHOD, 0, (ps[(3) - (6)].val.opval))));
- }
+ ;}
break;
case 109:
{ (yyval.opval) = op_convert_list(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST, scalar((ps[(1) - (3)].val.opval)),
newMETHOP(OP_METHOD, 0, (ps[(3) - (3)].val.opval))));
- }
+ ;}
break;
case 110:
op_append_elem(OP_LIST,
op_prepend_elem(OP_LIST, (ps[(2) - (3)].val.opval), (ps[(3) - (3)].val.opval)),
newMETHOP(OP_METHOD, 0, (ps[(1) - (3)].val.opval))));
- }
+ ;}
break;
case 111:
op_append_elem(OP_LIST,
op_prepend_elem(OP_LIST, (ps[(2) - (5)].val.opval), (ps[(4) - (5)].val.opval)),
newMETHOP(OP_METHOD, 0, (ps[(1) - (5)].val.opval))));
- }
+ ;}
break;
case 112:
#line 709 "perly.y"
- { (yyval.opval) = op_convert_list((ps[(1) - (2)].val.ival), 0, (ps[(2) - (2)].val.opval)); }
+ { (yyval.opval) = op_convert_list((ps[(1) - (2)].val.ival), 0, (ps[(2) - (2)].val.opval)); ;}
break;
case 113:
#line 711 "perly.y"
- { (yyval.opval) = op_convert_list((ps[(1) - (4)].val.ival), 0, (ps[(3) - (4)].val.opval)); }
+ { (yyval.opval) = op_convert_list((ps[(1) - (4)].val.ival), 0, (ps[(3) - (4)].val.opval)); ;}
break;
case 114:
#line 713 "perly.y"
{ SvREFCNT_inc_simple_void(PL_compcv);
- (yyval.opval) = newANONATTRSUB((ps[(2) - (3)].val.ival), 0, (OP*)NULL, (ps[(3) - (3)].val.opval)); }
+ (yyval.opval) = newANONATTRSUB((ps[(2) - (3)].val.ival), 0, (OP*)NULL, (ps[(3) - (3)].val.opval)); ;}
break;
case 115:
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST,
op_prepend_elem(OP_LIST, (ps[(4) - (5)].val.opval), (ps[(5) - (5)].val.opval)), (ps[(1) - (5)].val.opval)));
- }
+ ;}
break;
case 118:
#line 731 "perly.y"
- { (yyval.opval) = newBINOP(OP_GELEM, 0, (ps[(1) - (5)].val.opval), scalar((ps[(3) - (5)].val.opval))); }
+ { (yyval.opval) = newBINOP(OP_GELEM, 0, (ps[(1) - (5)].val.opval), scalar((ps[(3) - (5)].val.opval))); ;}
break;
case 119:
#line 733 "perly.y"
{ (yyval.opval) = newBINOP(OP_AELEM, 0, oopsAV((ps[(1) - (4)].val.opval)), scalar((ps[(3) - (4)].val.opval)));
- }
+ ;}
break;
case 120:
{ (yyval.opval) = newBINOP(OP_AELEM, 0,
ref(newAVREF((ps[(1) - (5)].val.opval)),OP_RV2AV),
scalar((ps[(4) - (5)].val.opval)));
- }
+ ;}
break;
case 121:
{ (yyval.opval) = newBINOP(OP_AELEM, 0,
ref(newAVREF((ps[(1) - (4)].val.opval)),OP_RV2AV),
scalar((ps[(3) - (4)].val.opval)));
- }
+ ;}
break;
case 122:
#line 746 "perly.y"
{ (yyval.opval) = newBINOP(OP_HELEM, 0, oopsHV((ps[(1) - (5)].val.opval)), jmaybe((ps[(3) - (5)].val.opval)));
- }
+ ;}
break;
case 123:
#line 749 "perly.y"
{ (yyval.opval) = newBINOP(OP_HELEM, 0,
ref(newHVREF((ps[(1) - (6)].val.opval)),OP_RV2HV),
- jmaybe((ps[(4) - (6)].val.opval))); }
+ jmaybe((ps[(4) - (6)].val.opval))); ;}
break;
case 124:
#line 753 "perly.y"
{ (yyval.opval) = newBINOP(OP_HELEM, 0,
ref(newHVREF((ps[(1) - (5)].val.opval)),OP_RV2HV),
- jmaybe((ps[(3) - (5)].val.opval))); }
+ jmaybe((ps[(3) - (5)].val.opval))); ;}
break;
case 125:
#line 757 "perly.y"
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
- newCVREF(0, scalar((ps[(1) - (4)].val.opval)))); }
+ newCVREF(0, scalar((ps[(1) - (4)].val.opval)))); ;}
break;
case 126:
#line 760 "perly.y"
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST, (ps[(4) - (5)].val.opval),
- newCVREF(0, scalar((ps[(1) - (5)].val.opval))))); }
+ newCVREF(0, scalar((ps[(1) - (5)].val.opval))))); ;}
break;
case 127:
#line 765 "perly.y"
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST, (ps[(3) - (4)].val.opval),
- newCVREF(0, scalar((ps[(1) - (4)].val.opval))))); }
+ newCVREF(0, scalar((ps[(1) - (4)].val.opval))))); ;}
break;
case 128:
#line 769 "perly.y"
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
- newCVREF(0, scalar((ps[(1) - (3)].val.opval)))); }
+ newCVREF(0, scalar((ps[(1) - (3)].val.opval)))); ;}
break;
case 129:
#line 772 "perly.y"
- { (yyval.opval) = newSLICEOP(0, (ps[(5) - (6)].val.opval), (ps[(2) - (6)].val.opval)); }
+ { (yyval.opval) = newSLICEOP(0, (ps[(5) - (6)].val.opval), (ps[(2) - (6)].val.opval)); ;}
break;
case 130:
#line 774 "perly.y"
- { (yyval.opval) = newSLICEOP(0, (ps[(3) - (4)].val.opval), (ps[(1) - (4)].val.opval)); }
+ { (yyval.opval) = newSLICEOP(0, (ps[(3) - (4)].val.opval), (ps[(1) - (4)].val.opval)); ;}
break;
case 131:
#line 776 "perly.y"
- { (yyval.opval) = newSLICEOP(0, (ps[(4) - (5)].val.opval), (OP*)NULL); }
+ { (yyval.opval) = newSLICEOP(0, (ps[(4) - (5)].val.opval), (OP*)NULL); ;}
break;
case 132:
#line 781 "perly.y"
- { (yyval.opval) = newASSIGNOP(OPf_STACKED, (ps[(1) - (3)].val.opval), (ps[(2) - (3)].val.ival), (ps[(3) - (3)].val.opval)); }
+ { (yyval.opval) = newASSIGNOP(OPf_STACKED, (ps[(1) - (3)].val.opval), (ps[(2) - (3)].val.ival), (ps[(3) - (3)].val.opval)); ;}
break;
case 133:
#line 783 "perly.y"
- { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); }
+ { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;}
break;
case 134:
{ if ((ps[(2) - (3)].val.ival) != OP_REPEAT)
scalar((ps[(1) - (3)].val.opval));
(yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, (ps[(1) - (3)].val.opval), scalar((ps[(3) - (3)].val.opval)));
- }
+ ;}
break;
case 135:
#line 790 "perly.y"
- { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); }
+ { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;}
break;
case 136:
#line 792 "perly.y"
- { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); }
+ { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;}
break;
case 137:
#line 794 "perly.y"
- { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); }
+ { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;}
break;
case 138:
#line 796 "perly.y"
- { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); }
+ { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;}
break;
case 139:
#line 798 "perly.y"
- { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); }
+ { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;}
break;
case 140:
#line 800 "perly.y"
- { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); }
+ { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;}
break;
case 141:
#line 802 "perly.y"
- { (yyval.opval) = newRANGE((ps[(2) - (3)].val.ival), scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); }
+ { (yyval.opval) = newRANGE((ps[(2) - (3)].val.ival), scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;}
break;
case 142:
#line 804 "perly.y"
- { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); }
+ { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;}
break;
case 143:
#line 806 "perly.y"
- { (yyval.opval) = newLOGOP(OP_OR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); }
+ { (yyval.opval) = newLOGOP(OP_OR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;}
break;
case 144:
#line 808 "perly.y"
- { (yyval.opval) = newLOGOP(OP_DOR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); }
+ { (yyval.opval) = newLOGOP(OP_DOR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;}
break;
case 145:
#line 810 "perly.y"
- { (yyval.opval) = bind_match((ps[(2) - (3)].val.ival), (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); }
+ { (yyval.opval) = bind_match((ps[(2) - (3)].val.ival), (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;}
break;
case 146:
#line 815 "perly.y"
- { (yyval.opval) = newUNOP(OP_NEGATE, 0, scalar((ps[(2) - (2)].val.opval))); }
+ { (yyval.opval) = newUNOP(OP_NEGATE, 0, scalar((ps[(2) - (2)].val.opval))); ;}
break;
case 147:
#line 817 "perly.y"
- { (yyval.opval) = (ps[(2) - (2)].val.opval); }
+ { (yyval.opval) = (ps[(2) - (2)].val.opval); ;}
break;
case 148:
#line 820 "perly.y"
- { (yyval.opval) = newUNOP(OP_NOT, 0, scalar((ps[(2) - (2)].val.opval))); }
+ { (yyval.opval) = newUNOP(OP_NOT, 0, scalar((ps[(2) - (2)].val.opval))); ;}
break;
case 149:
#line 822 "perly.y"
- { (yyval.opval) = newUNOP((ps[(1) - (2)].val.ival), 0, scalar((ps[(2) - (2)].val.opval))); }
+ { (yyval.opval) = newUNOP((ps[(1) - (2)].val.ival), 0, scalar((ps[(2) - (2)].val.opval))); ;}
break;
case 150:
#line 824 "perly.y"
{ (yyval.opval) = newUNOP(OP_POSTINC, 0,
- op_lvalue(scalar((ps[(1) - (2)].val.opval)), OP_POSTINC)); }
+ op_lvalue(scalar((ps[(1) - (2)].val.opval)), OP_POSTINC)); ;}
break;
case 151:
#line 827 "perly.y"
{ (yyval.opval) = newUNOP(OP_POSTDEC, 0,
- op_lvalue(scalar((ps[(1) - (2)].val.opval)), OP_POSTDEC));}
+ op_lvalue(scalar((ps[(1) - (2)].val.opval)), OP_POSTDEC));;}
break;
case 152:
)),
(ps[(1) - (2)].val.opval)
));
- }
+ ;}
break;
case 153:
#line 841 "perly.y"
{ (yyval.opval) = newUNOP(OP_PREINC, 0,
- op_lvalue(scalar((ps[(2) - (2)].val.opval)), OP_PREINC)); }
+ op_lvalue(scalar((ps[(2) - (2)].val.opval)), OP_PREINC)); ;}
break;
case 154:
#line 844 "perly.y"
{ (yyval.opval) = newUNOP(OP_PREDEC, 0,
- op_lvalue(scalar((ps[(2) - (2)].val.opval)), OP_PREDEC)); }
+ op_lvalue(scalar((ps[(2) - (2)].val.opval)), OP_PREDEC)); ;}
break;
case 155:
#line 851 "perly.y"
- { (yyval.opval) = newANONLIST((ps[(2) - (3)].val.opval)); }
+ { (yyval.opval) = newANONLIST((ps[(2) - (3)].val.opval)); ;}
break;
case 156:
#line 853 "perly.y"
- { (yyval.opval) = newANONLIST((OP*)NULL);}
+ { (yyval.opval) = newANONLIST((OP*)NULL);;}
break;
case 157:
#line 855 "perly.y"
- { (yyval.opval) = newANONHASH((ps[(2) - (4)].val.opval)); }
+ { (yyval.opval) = newANONHASH((ps[(2) - (4)].val.opval)); ;}
break;
case 158:
#line 857 "perly.y"
- { (yyval.opval) = newANONHASH((OP*)NULL); }
+ { (yyval.opval) = newANONHASH((OP*)NULL); ;}
break;
case 159:
#line 859 "perly.y"
{ SvREFCNT_inc_simple_void(PL_compcv);
- (yyval.opval) = newANONATTRSUB((ps[(2) - (5)].val.ival), (ps[(3) - (5)].val.opval), (ps[(4) - (5)].val.opval), (ps[(5) - (5)].val.opval)); }
+ (yyval.opval) = newANONATTRSUB((ps[(2) - (5)].val.ival), (ps[(3) - (5)].val.opval), (ps[(4) - (5)].val.opval), (ps[(5) - (5)].val.opval)); ;}
break;
case 160:
op_append_list(OP_LINESEQ, (ps[(4) - (8)].val.opval), (ps[(7) - (8)].val.opval)));
SvREFCNT_inc_simple_void(PL_compcv);
(yyval.opval) = newANONATTRSUB((ps[(2) - (8)].val.ival), NULL, (ps[(5) - (8)].val.opval), body);
- }
+ ;}
break;
case 161:
#line 876 "perly.y"
- { (yyval.opval) = dofile((ps[(2) - (2)].val.opval), (ps[(1) - (2)].val.ival));}
+ { (yyval.opval) = dofile((ps[(2) - (2)].val.opval), (ps[(1) - (2)].val.ival));;}
break;
case 162:
#line 878 "perly.y"
- { (yyval.opval) = newUNOP(OP_NULL, OPf_SPECIAL, op_scope((ps[(2) - (2)].val.opval)));}
+ { (yyval.opval) = newUNOP(OP_NULL, OPf_SPECIAL, op_scope((ps[(2) - (2)].val.opval)));;}
break;
case 167:
#line 886 "perly.y"
- { (yyval.opval) = newCONDOP(0, (ps[(1) - (5)].val.opval), (ps[(3) - (5)].val.opval), (ps[(5) - (5)].val.opval)); }
+ { (yyval.opval) = newCONDOP(0, (ps[(1) - (5)].val.opval), (ps[(3) - (5)].val.opval), (ps[(5) - (5)].val.opval)); ;}
break;
case 168:
#line 888 "perly.y"
- { (yyval.opval) = newUNOP(OP_REFGEN, 0, (ps[(2) - (2)].val.opval)); }
+ { (yyval.opval) = newUNOP(OP_REFGEN, 0, (ps[(2) - (2)].val.opval)); ;}
break;
case 169:
#line 890 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 170:
#line 892 "perly.y"
- { (yyval.opval) = localize((ps[(2) - (2)].val.opval),(ps[(1) - (2)].val.ival)); }
+ { (yyval.opval) = localize((ps[(2) - (2)].val.opval),(ps[(1) - (2)].val.ival)); ;}
break;
case 171:
#line 894 "perly.y"
- { (yyval.opval) = sawparens((ps[(2) - (3)].val.opval)); }
+ { (yyval.opval) = sawparens((ps[(2) - (3)].val.opval)); ;}
break;
case 172:
#line 896 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 173:
#line 898 "perly.y"
- { (yyval.opval) = sawparens(newNULLLIST()); }
+ { (yyval.opval) = sawparens(newNULLLIST()); ;}
break;
case 174:
#line 900 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 175:
#line 902 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 176:
#line 904 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 177:
#line 906 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 178:
#line 908 "perly.y"
- { (yyval.opval) = newUNOP(OP_AV2ARYLEN, 0, ref((ps[(1) - (1)].val.opval), OP_AV2ARYLEN));}
+ { (yyval.opval) = newUNOP(OP_AV2ARYLEN, 0, ref((ps[(1) - (1)].val.opval), OP_AV2ARYLEN));;}
break;
case 179:
#line 910 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 180:
if ((yyval.opval) && (ps[(1) - (4)].val.opval))
(yyval.opval)->op_private |=
(ps[(1) - (4)].val.opval)->op_private & OPpSLICEWARNING;
- }
+ ;}
break;
case 181:
if ((yyval.opval) && (ps[(1) - (4)].val.opval))
(yyval.opval)->op_private |=
(ps[(1) - (4)].val.opval)->op_private & OPpSLICEWARNING;
- }
+ ;}
break;
case 182:
if ((yyval.opval) && (ps[(1) - (5)].val.opval))
(yyval.opval)->op_private |=
(ps[(1) - (5)].val.opval)->op_private & OPpSLICEWARNING;
- }
+ ;}
break;
case 183:
if ((yyval.opval) && (ps[(1) - (5)].val.opval))
(yyval.opval)->op_private |=
(ps[(1) - (5)].val.opval)->op_private & OPpSLICEWARNING;
- }
+ ;}
break;
case 184:
#line 952 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 185:
#line 954 "perly.y"
- { (yyval.opval) = newUNOP(OP_ENTERSUB, 0, scalar((ps[(1) - (1)].val.opval))); }
+ { (yyval.opval) = newUNOP(OP_ENTERSUB, 0, scalar((ps[(1) - (1)].val.opval))); ;}
break;
case 186:
#line 956 "perly.y"
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[(1) - (3)].val.opval)));
- }
+ ;}
break;
case 187:
{
(yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST, (ps[(3) - (4)].val.opval), scalar((ps[(1) - (4)].val.opval))));
- }
+ ;}
break;
case 188:
#line 964 "perly.y"
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST, (ps[(3) - (3)].val.opval), scalar((ps[(2) - (3)].val.opval))));
- }
+ ;}
break;
case 189:
#line 968 "perly.y"
- { (yyval.opval) = newSVREF((ps[(1) - (4)].val.opval)); }
+ { (yyval.opval) = newSVREF((ps[(1) - (4)].val.opval)); ;}
break;
case 190:
#line 970 "perly.y"
- { (yyval.opval) = newAVREF((ps[(1) - (4)].val.opval)); }
+ { (yyval.opval) = newAVREF((ps[(1) - (4)].val.opval)); ;}
break;
case 191:
#line 972 "perly.y"
- { (yyval.opval) = newHVREF((ps[(1) - (4)].val.opval)); }
+ { (yyval.opval) = newHVREF((ps[(1) - (4)].val.opval)); ;}
break;
case 192:
#line 974 "perly.y"
{ (yyval.opval) = newUNOP(OP_ENTERSUB, 0,
- scalar(newCVREF((ps[(3) - (4)].val.ival),(ps[(1) - (4)].val.opval)))); }
+ scalar(newCVREF((ps[(3) - (4)].val.ival),(ps[(1) - (4)].val.opval)))); ;}
break;
case 193:
#line 977 "perly.y"
- { (yyval.opval) = newGVREF(0,(ps[(1) - (4)].val.opval)); }
+ { (yyval.opval) = newGVREF(0,(ps[(1) - (4)].val.opval)); ;}
break;
case 194:
#line 979 "perly.y"
{ (yyval.opval) = newOP((ps[(1) - (1)].val.ival), OPf_SPECIAL);
- PL_hints |= HINT_BLOCK_SCOPE; }
+ PL_hints |= HINT_BLOCK_SCOPE; ;}
break;
case 195:
#line 982 "perly.y"
- { (yyval.opval) = newLOOPEX((ps[(1) - (2)].val.ival),(ps[(2) - (2)].val.opval)); }
+ { (yyval.opval) = newLOOPEX((ps[(1) - (2)].val.ival),(ps[(2) - (2)].val.opval)); ;}
break;
case 196:
#line 984 "perly.y"
- { (yyval.opval) = newUNOP(OP_NOT, 0, scalar((ps[(2) - (2)].val.opval))); }
+ { (yyval.opval) = newUNOP(OP_NOT, 0, scalar((ps[(2) - (2)].val.opval))); ;}
break;
case 197:
#line 986 "perly.y"
- { (yyval.opval) = newOP((ps[(1) - (1)].val.ival), 0); }
+ { (yyval.opval) = newOP((ps[(1) - (1)].val.ival), 0); ;}
break;
case 198:
#line 988 "perly.y"
- { (yyval.opval) = newUNOP((ps[(1) - (2)].val.ival), 0, (ps[(2) - (2)].val.opval)); }
+ { (yyval.opval) = newUNOP((ps[(1) - (2)].val.ival), 0, (ps[(2) - (2)].val.opval)); ;}
break;
case 199:
#line 990 "perly.y"
- { (yyval.opval) = newUNOP((ps[(1) - (2)].val.ival), 0, (ps[(2) - (2)].val.opval)); }
+ { (yyval.opval) = newUNOP((ps[(1) - (2)].val.ival), 0, (ps[(2) - (2)].val.opval)); ;}
break;
case 200:
#line 992 "perly.y"
- { (yyval.opval) = newOP(OP_REQUIRE, (ps[(1) - (1)].val.ival) ? OPf_SPECIAL : 0); }
+ { (yyval.opval) = newOP(OP_REQUIRE, (ps[(1) - (1)].val.ival) ? OPf_SPECIAL : 0); ;}
break;
case 201:
#line 994 "perly.y"
- { (yyval.opval) = newUNOP(OP_REQUIRE, (ps[(1) - (2)].val.ival) ? OPf_SPECIAL : 0, (ps[(2) - (2)].val.opval)); }
+ { (yyval.opval) = newUNOP(OP_REQUIRE, (ps[(1) - (2)].val.ival) ? OPf_SPECIAL : 0, (ps[(2) - (2)].val.opval)); ;}
break;
case 202:
#line 996 "perly.y"
- { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[(1) - (1)].val.opval))); }
+ { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[(1) - (1)].val.opval))); ;}
break;
case 203:
#line 998 "perly.y"
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
- op_append_elem(OP_LIST, (ps[(2) - (2)].val.opval), scalar((ps[(1) - (2)].val.opval)))); }
+ op_append_elem(OP_LIST, (ps[(2) - (2)].val.opval), scalar((ps[(1) - (2)].val.opval)))); ;}
break;
case 204:
#line 1001 "perly.y"
- { (yyval.opval) = newOP((ps[(1) - (1)].val.ival), 0); }
+ { (yyval.opval) = newOP((ps[(1) - (1)].val.ival), 0); ;}
break;
case 205:
#line 1003 "perly.y"
- { (yyval.opval) = newOP((ps[(1) - (3)].val.ival), 0);}
+ { (yyval.opval) = newOP((ps[(1) - (3)].val.ival), 0);;}
break;
case 206:
#line 1005 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 207:
#line 1007 "perly.y"
- { (yyval.opval) = (ps[(1) - (3)].val.opval); }
+ { (yyval.opval) = (ps[(1) - (3)].val.opval); ;}
break;
case 208:
#line 1009 "perly.y"
- { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[(1) - (1)].val.opval))); }
+ { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[(1) - (1)].val.opval))); ;}
break;
case 209:
#line 1011 "perly.y"
{ (yyval.opval) = ((ps[(1) - (3)].val.ival) == OP_NOT)
? newUNOP((ps[(1) - (3)].val.ival), 0, newSVOP(OP_CONST, 0, newSViv(0)))
- : newOP((ps[(1) - (3)].val.ival), OPf_SPECIAL); }
+ : newOP((ps[(1) - (3)].val.ival), OPf_SPECIAL); ;}
break;
case 210:
#line 1015 "perly.y"
- { (yyval.opval) = newUNOP((ps[(1) - (4)].val.ival), 0, (ps[(3) - (4)].val.opval)); }
+ { (yyval.opval) = newUNOP((ps[(1) - (4)].val.ival), 0, (ps[(3) - (4)].val.opval)); ;}
break;
case 211:
SAVEFREESV(PL_compcv);
} else
(yyval.ival) = 0;
- }
+ ;}
break;
case 212:
#line 1028 "perly.y"
- { (yyval.opval) = pmruntime((ps[(1) - (6)].val.opval), (ps[(4) - (6)].val.opval), (ps[(5) - (6)].val.opval), 1, (ps[(2) - (6)].val.ival)); }
+ { (yyval.opval) = pmruntime((ps[(1) - (6)].val.opval), (ps[(4) - (6)].val.opval), (ps[(5) - (6)].val.opval), 1, (ps[(2) - (6)].val.ival)); ;}
break;
case 215:
{
(yyval.opval) = newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0),
newSVOP(OP_CONST, 0, newSVpvs("Unimplemented")));
- }
+ ;}
break;
case 217:
#line 1041 "perly.y"
- { (yyval.opval) = my_attrs((ps[(2) - (3)].val.opval),(ps[(3) - (3)].val.opval)); }
+ { (yyval.opval) = my_attrs((ps[(2) - (3)].val.opval),(ps[(3) - (3)].val.opval)); ;}
break;
case 218:
#line 1043 "perly.y"
- { (yyval.opval) = localize((ps[(2) - (2)].val.opval),(ps[(1) - (2)].val.ival)); }
+ { (yyval.opval) = localize((ps[(2) - (2)].val.opval),(ps[(1) - (2)].val.ival)); ;}
break;
case 219:
#line 1048 "perly.y"
- { (yyval.opval) = sawparens((ps[(2) - (3)].val.opval)); }
+ { (yyval.opval) = sawparens((ps[(2) - (3)].val.opval)); ;}
break;
case 220:
#line 1050 "perly.y"
- { (yyval.opval) = sawparens(newNULLLIST()); }
+ { (yyval.opval) = sawparens(newNULLLIST()); ;}
break;
case 221:
#line 1053 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 222:
#line 1055 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 223:
#line 1057 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 224:
#line 1062 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+ { (yyval.opval) = (OP*)NULL; ;}
break;
case 225:
#line 1064 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 226:
#line 1068 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+ { (yyval.opval) = (OP*)NULL; ;}
break;
case 227:
#line 1070 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 228:
#line 1074 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+ { (yyval.opval) = (OP*)NULL; ;}
break;
case 229:
#line 1076 "perly.y"
- { (yyval.opval) = (ps[(2) - (2)].val.opval); }
+ { (yyval.opval) = (ps[(2) - (2)].val.opval); ;}
break;
case 230:
#line 1082 "perly.y"
- { parser->in_my = 0; (yyval.opval) = my((ps[(1) - (1)].val.opval)); }
+ { parser->in_my = 0; (yyval.opval) = my((ps[(1) - (1)].val.opval)); ;}
break;
case 236:
#line 1095 "perly.y"
- { (yyval.opval) = newCVREF((ps[(1) - (2)].val.ival),(ps[(2) - (2)].val.opval)); }
+ { (yyval.opval) = newCVREF((ps[(1) - (2)].val.ival),(ps[(2) - (2)].val.opval)); ;}
break;
case 237:
#line 1099 "perly.y"
- { (yyval.opval) = newSVREF((ps[(2) - (2)].val.opval)); }
+ { (yyval.opval) = newSVREF((ps[(2) - (2)].val.opval)); ;}
break;
case 238:
#line 1103 "perly.y"
{ (yyval.opval) = newAVREF((ps[(2) - (2)].val.opval));
if ((yyval.opval)) (yyval.opval)->op_private |= (ps[(1) - (2)].val.ival);
- }
+ ;}
break;
case 239:
#line 1109 "perly.y"
{ (yyval.opval) = newHVREF((ps[(2) - (2)].val.opval));
if ((yyval.opval)) (yyval.opval)->op_private |= (ps[(1) - (2)].val.ival);
- }
+ ;}
break;
case 240:
#line 1115 "perly.y"
- { (yyval.opval) = newAVREF((ps[(2) - (2)].val.opval)); }
+ { (yyval.opval) = newAVREF((ps[(2) - (2)].val.opval)); ;}
break;
case 241:
#line 1117 "perly.y"
- { (yyval.opval) = newAVREF((ps[(1) - (4)].val.opval)); }
+ { (yyval.opval) = newAVREF((ps[(1) - (4)].val.opval)); ;}
break;
case 242:
#line 1121 "perly.y"
- { (yyval.opval) = newGVREF(0,(ps[(2) - (2)].val.opval)); }
+ { (yyval.opval) = newGVREF(0,(ps[(2) - (2)].val.opval)); ;}
break;
case 244:
#line 1126 "perly.y"
- { (yyval.opval) = newAVREF((ps[(1) - (3)].val.opval)); }
+ { (yyval.opval) = newAVREF((ps[(1) - (3)].val.opval)); ;}
break;
case 246:
#line 1131 "perly.y"
- { (yyval.opval) = newHVREF((ps[(1) - (3)].val.opval)); }
+ { (yyval.opval) = newHVREF((ps[(1) - (3)].val.opval)); ;}
break;
case 248:
#line 1136 "perly.y"
- { (yyval.opval) = newGVREF(0,(ps[(1) - (3)].val.opval)); }
+ { (yyval.opval) = newGVREF(0,(ps[(1) - (3)].val.opval)); ;}
break;
case 249:
#line 1141 "perly.y"
- { (yyval.opval) = scalar((ps[(1) - (1)].val.opval)); }
+ { (yyval.opval) = scalar((ps[(1) - (1)].val.opval)); ;}
break;
case 250:
#line 1143 "perly.y"
- { (yyval.opval) = scalar((ps[(1) - (1)].val.opval)); }
+ { (yyval.opval) = scalar((ps[(1) - (1)].val.opval)); ;}
break;
case 251:
#line 1145 "perly.y"
- { (yyval.opval) = op_scope((ps[(1) - (1)].val.opval)); }
+ { (yyval.opval) = op_scope((ps[(1) - (1)].val.opval)); ;}
break;
case 252:
#line 1148 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
+
+/* Line 1267 of yacc.c. */
+
default: break;
/* Generated from:
* 703ebd267cf8ca45f9dee9bc0f4b21511117a0c1dca1c8bc9438ce91950217ae perly.y
- * a4923588f219644801577c514014847e1e5240f49413fa3b89d3306fa4874d07 regen_perly.pl
+ * 3e1dff60f26df8933d7aed0c0e87177a0f022c14800c0707eb62a7db4196ac98 regen_perly.pl
* ex: set ro: */
Any changes made here will be lost!
*/
-#define PERL_BISON_VERSION 20007
+#define PERL_BISON_VERSION 20003
#ifdef PERL_CORE
-/* A Bison parser, made by GNU Bison 2.7. */
+/* A Bison parser, made by GNU Bison 2.3. */
-/* Bison interface for Yacc-like parsers in C
-
- Copyright (C) 1984, 1989-1990, 2000-2012 Free Software Foundation, Inc.
-
- This program is free software: you can redistribute it and/or modify
+/* Skeleton interface for Bison's Yacc-like parsers in C
+
+ Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002, 2003, 2004, 2005, 2006
+ Free Software Foundation, Inc.
+
+ This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
- the Free Software Foundation, either version 3 of the License, or
- (at your option) any later version.
-
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
-
+
You should have received a copy of the GNU General Public License
- along with this program. If not, see <http://www.gnu.org/licenses/>. */
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 51 Franklin Street, Fifth Floor,
+ Boston, MA 02110-1301, USA. */
/* As a special exception, you may create a larger work that contains
part or all of the Bison parser skeleton and distribute that work
special exception, which will cause the skeleton and the resulting
Bison output files to be licensed under the GNU General Public
License without this special exception.
-
+
This special exception was added by the Free Software Foundation in
version 2.2 of Bison. */
-/* Enabling traces. */
-#ifndef YYDEBUG
-# define YYDEBUG 0
-#endif
-#if YYDEBUG
-extern int yydebug;
-#endif
-
/* Tokens. */
#ifndef YYTOKENTYPE
# define YYTOKENTYPE
ARROW = 337
};
#endif
-
/* Tokens. */
#define GRAMPROG 258
#define GRAMEXPR 259
#define ARROW 337
+
+
#ifdef PERL_IN_TOKE_C
static bool
S_is_opval_token(int type) {
#if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED
typedef union YYSTYPE
{
-/* Line 2058 of yacc.c */
-
I32 ival; /* __DEFAULT__ (marker for regen_perly.pl;
must always be 1st union member) */
char *pval;
OP *opval;
GV *gvval;
-
-
-/* Line 2058 of yacc.c */
-} YYSTYPE;
-# define YYSTYPE_IS_TRIVIAL 1
+}
+/* Line 1529 of yacc.c. */
+ YYSTYPE;
# define yystype YYSTYPE /* obsolescent; will be withdrawn */
# define YYSTYPE_IS_DECLARED 1
+# define YYSTYPE_IS_TRIVIAL 1
#endif
-#ifdef YYPARSE_PARAM
-#if defined __STDC__ || defined __cplusplus
-int yyparse (void *YYPARSE_PARAM);
-#else
-int yyparse ();
-#endif
-#else /* ! YYPARSE_PARAM */
-#if defined __STDC__ || defined __cplusplus
-int yyparse (void);
-#else
-int yyparse ();
-#endif
-#endif /* ! YYPARSE_PARAM */
/* Generated from:
* 703ebd267cf8ca45f9dee9bc0f4b21511117a0c1dca1c8bc9438ce91950217ae perly.y
- * a4923588f219644801577c514014847e1e5240f49413fa3b89d3306fa4874d07 regen_perly.pl
+ * 3e1dff60f26df8933d7aed0c0e87177a0f022c14800c0707eb62a7db4196ac98 regen_perly.pl
* ex: set ro: */
};
#endif
-#if YYDEBUG || YYERROR_VERBOSE || 0
+#if YYDEBUG || YYERROR_VERBOSE || YYTOKEN_TABLE
/* YYTNAME[SYMBOL-NUM] -- String name of the symbol SYMBOL-NUM.
First, the terminals, then, starting at YYNTOKENS, nonterminals. */
static const char *const yytname[] =
"BITOROP", "BITANDOP", "SHIFTOP", "MATCHOP", "'!'", "'~'", "REFGEN",
"UMINUS", "POWOP", "POSTJOIN", "POSTDEC", "POSTINC", "PREDEC", "PREINC",
"ARROW", "')'", "'('", "';'", "'$'", "'*'", "'/'", "$accept", "grammar",
- "$@1", "$@2", "$@3", "$@4", "$@5", "$@6", "block", "formblock",
- "remember", "mblock", "mremember", "stmtseq", "formstmtseq", "fullstmt",
- "labfullstmt", "barestmt", "$@7", "$@8", "$@9", "$@10", "$@11", "@12",
- "$@13", "formline", "formarg", "sideff", "else", "cont", "mintro",
- "nexpr", "texpr", "iexpr", "mexpr", "mnexpr", "formname", "startsub",
+ "@1", "@2", "@3", "@4", "@5", "@6", "block", "formblock", "remember",
+ "mblock", "mremember", "stmtseq", "formstmtseq", "fullstmt",
+ "labfullstmt", "barestmt", "@7", "@8", "@9", "@10", "@11", "@12", "@13",
+ "formline", "formarg", "sideff", "else", "cont", "mintro", "nexpr",
+ "texpr", "iexpr", "mexpr", "mnexpr", "formname", "startsub",
"startanonsub", "startformsub", "subname", "proto", "subattrlist",
"myattrlist", "subsignature", "@14", "optsubbody", "expr", "listexpr",
"listop", "@15", "method", "subscripted", "termbinop", "termunop",
"anonymous", "termdo", "term", "@16", "myattrterm", "myterm",
"optlistexpr", "optexpr", "optrepl", "my_scalar", "my_var",
"refgen_topic", "amper", "scalar", "ary", "hsh", "arylen", "star",
- "sliceme", "kvslice", "gelem", "indirob", YY_NULL
+ "sliceme", "kvslice", "gelem", "indirob", 0
};
#endif
1, 1, 1
};
-/* YYDEFACT[STATE-NAME] -- Default reduction number in state STATE-NUM.
- Performed when YYTABLE doesn't specify something else to do. Zero
+/* YYDEFACT[STATE-NAME] -- Default rule to reduce with in state
+ STATE-NUM when YYTABLE doesn't specify something else to do. Zero
means the default is an error. */
static const yytype_uint8 yydefact[] =
{
/* YYTABLE[YYPACT[STATE-NUM]]. What to do in state STATE-NUM. If
positive, shift that token. If negative, reduce the rule which
- number is the opposite. If YYTABLE_NINF, syntax error. */
+ number is the opposite. If zero, do what YYDEFACT says.
+ If YYTABLE_NINF, syntax error. */
#define YYTABLE_NINF -248
static const yytype_int16 yytable[] =
{
183, 0, 0, 184
};
-#define yypact_value_is_default(Yystate) \
- (!!((Yystate) == (-400)))
-
-#define yytable_value_is_error(Yytable_value) \
- (!!((Yytable_value) == (-248)))
-
static const yytype_int16 yycheck[] =
{
15, 308, 11, 9, 9, 40, 46, 46, 126, 115,
toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival,
toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival,
toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival,
- toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_opval, toketype_opval,
- toketype_ival, toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval,
- toketype_opval, toketype_opval, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival,
- toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_ival,
- toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_ival,
+ toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_opval, toketype_opval, toketype_ival,
+ toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval,
+ toketype_opval, toketype_opval, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival,
+ toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_ival, toketype_opval,
+ toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_ival,
toketype_ival, toketype_ival, toketype_opval, toketype_opval, toketype_opval,
toketype_opval, toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval,
toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval,
/* Generated from:
* 703ebd267cf8ca45f9dee9bc0f4b21511117a0c1dca1c8bc9438ce91950217ae perly.y
- * a4923588f219644801577c514014847e1e5240f49413fa3b89d3306fa4874d07 regen_perly.pl
+ * 3e1dff60f26df8933d7aed0c0e87177a0f022c14800c0707eb62a7db4196ac98 regen_perly.pl
* ex: set ro: */
* 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.0" /**/
-#define PRIVLIB_EXP "/sys/lib/perl/5.25.0" /**/
+#define PRIVLIB "/sys/lib/perl/5.25.1" /**/
+#define PRIVLIB_EXP "/sys/lib/perl/5.25.1" /**/
/* 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.0/site_perl" /**/
-#define SITELIB_EXP "/sys/lib/perl/5.25.0/site_perl" /**/
-#define SITELIB_STEM "/sys/lib/perl/5.25.0/site_perl" /**/
+#define SITELIB "/sys/lib/perl/5.25.1/site_perl" /**/
+#define SITELIB_EXP "/sys/lib/perl/5.25.1/site_perl" /**/
+#define SITELIB_STEM "/sys/lib/perl/5.25.1/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='0'
+api_subversion='1'
api_version='25'
-api_versionstring='5.25.0'
+api_versionstring='5.25.1'
ar='ar'
-archlib='/sys/lib/perl5/5.25.0/386'
-archlibexp='/sys/lib/perl5/5.25.0/386'
+archlib='/sys/lib/perl5/5.25.1/386'
+archlibexp='/sys/lib/perl5/5.25.1/386'
archname64=''
archname='386'
archobjs=''
inc_version_list_init='0'
incpath=''
inews=''
-installarchlib='/sys/lib/perl/5.25.0/386'
+installarchlib='/sys/lib/perl/5.25.1/386'
installbin='/usr/bin'
installman1dir='/sys/man/1pub'
installman3dir='/sys/man/2pub'
installprefix='/usr'
installprefixexp='/usr'
-installprivlib='/sys/lib/perl/5.25.0'
+installprivlib='/sys/lib/perl/5.25.1'
installscript='/usr/bin'
-installsitearch='/sys/lib/perl/5.25.0/site_perl/386'
+installsitearch='/sys/lib/perl/5.25.1/site_perl/386'
installsitebin='/usr/bin'
-installsitelib='/sys/lib/perl/5.25.0/site_perl'
+installsitelib='/sys/lib/perl/5.25.1/site_perl'
installstyle='lib/perl5'
installusrbinperl='undef'
installvendorarch=''
pr=''
prefix='/usr'
prefixexp='/usr'
-privlib='/sys/lib/perl/5.25.0'
-privlibexp='/sys/lib/perl/5.25.0'
+privlib='/sys/lib/perl/5.25.1'
+privlibexp='/sys/lib/perl/5.25.1'
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.0/site_perl/386'
+sitearch='/sys/lib/perl/5.25.1/site_perl/386'
sitearchexp='/sys/lib/perl/site_perl/386'
sitebin='/usr/bin'
sitebinexp='/usr/bin'
-sitelib='/sys/lib/perl/5.25.0/site_perl'
-sitelib_stem='/sys/lib/perl/5.25.0/site_perl'
-sitelibexp='/sys/lib/perl/5.25.0/site_perl'
+sitelib='/sys/lib/perl/5.25.1/site_perl'
+sitelib_stem='/sys/lib/perl/5.25.1/site_perl'
+sitelibexp='/sys/lib/perl/5.25.1/site_perl'
siteprefix='/usr'
siteprefixexp='/usr'
sizesize='4'
strerror_r_proto='0'
strings='/sys/include/ape/string.h'
submit=''
-subversion='0'
+subversion='1'
sysman='/sys/man/1pub'
tail=''
tar=''
vendorlibexp=''
vendorprefix=''
vendorprefixexp=''
-version='5.25.0'
-version_patchlevel_string='version 25 subversion 0'
+version='5.25.1'
+version_patchlevel_string='version 25 subversion 1'
versiononly='undef'
vi=''
xlibpth=''
config_argc=0
PERL_REVISION=5
PERL_VERSION=25
-PERL_SUBVERSION=0
+PERL_SUBVERSION=1
PERL_API_REVISION=5
PERL_API_VERSION=25
-PERL_API_SUBVERSION=0
+PERL_API_SUBVERSION=1
PERL_PATCHLEVEL=
PERL_CONFIG_SH=true
/roffitall
# generated
-/perl5250delta.pod
+/perl5251delta.pod
/perlapi.pod
/perlintern.pod
*.html
perlhist Perl history records
perldelta Perl changes since previous version
+ perl5250delta Perl changes in version 5.25.0
perl5240delta Perl changes in version 5.24.0
perl5222delta Perl changes in version 5.22.2
perl5221delta Perl changes in version 5.22.1
--- /dev/null
+=encoding utf8
+
+=head1 NAME
+
+[ this is a template for a new perldelta file. Any text flagged as XXX needs
+to be processed before release. ]
+
+perl5250delta - what is new for perl v5.25.0
+
+=head1 DESCRIPTION
+
+This document describes differences between the 5.24.0 release and the 5.25.0
+release.
+
+=head1 Known Problems
+
+=over 4
+
+=item *
+
+Some modules have been broken by the L<context stack rework|/Internal Changes>.
+These modules were relying on non-guaranteed implementation details in perl.
+Their maintainers have been informed, and should contact perl5-porters for
+advice if needed. Below is a subset of these modules:
+
+=over 4
+
+=item L<Algorithm::Permute>
+
+=item L<Coro>
+
+L<Coro> and perl v5.22.0 were already incompatible due to a change in the perl,
+and the reworking on the perl context stack creates a further incompatibility.
+perl5-porters has L<discussed the issue on the mailing
+list|http://www.nntp.perl.org/group/perl.perl5.porters/2016/05/msg236174.html>.
+
+=item L<Data::Alias>
+
+=item L<RPerl>
+
+=item L<Scope::Upper>
+
+=item L<TryCatch>
+
+=back
+
+=item *
+
+The module L<lexical::underscore> no longer works on perl v5.24.0, because perl
+no longer has a lexical C<$_>!
+
+=item *
+
+C<mod_perl> has been patched for compatibility for v5.22.0 and later but no
+release has been made. The relevant patch (and other changes) can be found in
+their source code repository, L<mirrored at
+GitHub|https://github.com/apache/mod_perl/commit/82827132efd3c2e25cc413c85af61bb63375da6e>.
+
+=back
+
+=head1 Acknowledgements
+
+XXX Generate this with:
+
+ perl Porting/acknowledgements.pl v5.24.0..HEAD
+
+=head1 Reporting Bugs
+
+If you find what you think is a bug, you might check the articles recently
+posted to the comp.lang.perl.misc newsgroup and the perl bug database at
+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.0
+perldelta - what is new for perl v5.25.1
=head1 DESCRIPTION
-This document describes differences between the 5.24.0 release and the 5.25.0
+This document describes differences between the 5.25.0 release and the 5.25.1
release.
-=head1 Changes Since v5.24.0
+If you are upgrading from an earlier release such as 5.24.0, first read
+L<perl5250delta>, which describes differences between 5.24.0 and 5.25.0.
-None, really. The version number is a little bit higher, though.
+=head1 Core Enhancements
+
+=head2 POSIX::tmpnam() has been removed
+
+The fundamentally unsafe C<tmpnam()> interface was deprecated in
+Perl 5.22.0 and has now been removed. In its place you can use
+for example the L<File::Temp> interfaces.
+
+=head2 require ::Foo::Bar is now illegal.
+
+Formerly, C<require ::Foo::Bar> would try to read F</Foo/Bar.pm>. Now any
+bareword require which starts with a double colon dies instead.
+
+=head2 Unescaped literal C<"{"> characters in regular expression
+patterns are no longer permissible
+
+You have to now say something like C<"\{"> or C<"[{]"> to specify to
+match a LEFT CURLY BRACKET. This will allow future extensions to the
+language. This restriction is not enforced, nor are there current plans
+to enforce it, if the C<"{"> is the first character in the pattern.
+
+These have been deprecated since v5.16, with a deprecation message
+displayed starting in v5.22.
+
+=head2 Literal control character variable names are no longer permissible
+
+A variable name may no longer contain a literal control character under
+any circumstances. These previously were allowed in single-character
+names on ASCII platforms, but have been deprecated there since Perl
+v5.20. This affects things like C<$I<\cT>>, where I<\cT> is a literal
+control (such as a C<NAK> or C<NEGATIVE ACKNOWLEDGE> character) in the
+source code.
+
+=head2 C<qr//xx> is no longer permissible
+
+Using more than one C</x> regular expression pattern modifier on a
+single pattern is now forbidden. This is to allow a future enhancement
+to the language. This usage has been deprecated since v5.22.
+
+=head2 C<NBSP> is no longer permissible in C<\N{...}>
+
+The name of a character may no longer contain non-breaking spaces. It
+has been deprecated to do so since Perl v5.22.
+
+=head1 Performance Enhancements
+
+=over 4
+
+=item *
+
+Bareword constant strings are now permitted to take part in constant
+folding. They were originally exempted from constant folding in August 1999,
+during the development of Perl 5.6, to ensure that C<use strict "subs">
+would still apply to bareword constants. That has now been accomplished a
+different way, so barewords, like other constants, now gain the performance
+benefits of constant folding.
+
+This also means that void-context warnings on constant expressions of
+barewords now report the folded constant operand, rather than the operation;
+this matches the behaviour for non-bareword constants.
+
+=back
+
+=head1 Modules and Pragmata
+
+=head2 Updated Modules and Pragmata
+
+=over 4
+
+=item *
+
+L<Archive::Tar> has been upgraded from version 2.04 to 2.08.
+
+=item *
+
+L<Carp> has been upgraded from version 1.40 to 1.41.
+
+=item *
+
+L<charnames> has been upgraded from version 1.43 to 1.44.
+
+=item *
+
+L<Config::Perl::V> has been upgraded from version 0.25 to 0.26.
+
+=item *
+
+L<DB_File> has been upgraded from version 1.835 to 1.838.
+
+=item *
+
+L<Digest::MD5> has been upgraded from version 2.54 to 2.55.
+
+=item *
+
+L<IPC::Cmd> has been upgraded from version 0.92 to 0.94.
+
+=item *
+
+L<IPC::SysV> has been upgraded from version 2.06_01 to 2.07.
+
+=item *
+
+L<List::Util> has been upgraded from version 1.42_02 to 1.45_01.
+
+=item *
+
+L<Locale::Codes> has been upgraded from version 3.37 to 3.38.
+
+=item *
+
+L<Locale::Maketext> has been upgraded from version 1.26 to 1.27.
+
+=item *
+
+L<Module::CoreList> has been upgraded from version 5.20160507 to 5.20160520.
+
+=item *
+
+L<Module::Metadata> has been upgraded from version 1.000031 to 1.000032.
+
+=item *
+
+L<perlfaq> has been upgraded from version 5.021010 to 5.021011.
+
+=item *
+
+L<POSIX> has been upgraded from version 1.65 to 1.69. This remedies several
+defects in making its symbols exportable. [perl #127821] Furthermore,
+the C<POSIX::tmpnam()> interface has been removed,
+see L</"POSIX::tmpnam() has been removed">.
+
+=item *
+
+L<re> has been upgraded from version 0.32 to 0.33.
+
+=item *
+
+L<Scalar::Util> has been upgraded from version 1.42_02 to 1.45_01.
+
+=item *
+
+L<Sys::Syslog> has been upgraded from version 0.33 to 0.34.
+
+=item *
+
+L<Term::ANSIColor> has been upgraded from version 4.04 to 4.05.
+
+=item *
+
+L<Test::Simple> has been upgraded from version 1.001014 to 1.302015.
+
+=item *
+
+L<threads> has been upgraded from version 2.07 to 2.08. Compatibility
+with 5.8 has been restored.
+
+=item *
+
+L<threads::shared> has been upgraded from version 1.51 to 1.52.
+Compatibility with 5.8 has been restored.
+
+=back
+
+=head1 Documentation
+
+=head2 Changes to Existing Documentation
+
+=over 4
+
+=item *
+
+Fixed link to Crosby paper on hash complexity attack in L<perlsec>.
+
+=back
+
+=head1 Diagnostics
+
+=head2 New Diagnostics
+
+=head3 New Errors
+
+=over 4
+
+=item *
+
+L<Bareword in require contains "%s"|perldiag/"Bareword in require contains "%s"">
+
+=item *
+
+L<Bareword in require maps to empty filename|perldiag/"Bareword in require maps to empty filename">
+
+=item *
+
+L<Bareword in require maps to disallowed filename "%s"|perldiag/"Bareword in require maps to disallowed filename "%s"">
+
+=item *
+
+L<Bareword in require must not start with a double-colon: "%s"|perldiag/"Bareword in require must not start with a double-colon: "%s"">
+
+=back
+
+=head2 Changes to Existing Diagnostics
+
+=over 4
+
+=item *
+
+Code like C<$x = $x . "a"> was incorrectly failing to yield a
+L<use of uninitialized value|perldiag/"Use of uninitialized value%s">
+warning when C<$x> was a lexical variable with an undefined value. That has
+now been fixed. [perl #127877]
+
+=item *
+
+When the error "Experimental push on scalar is now forbidden" is raised for
+the hash functions C<keys>, C<each>, and C<values>, it is now followed by
+the more helpful message, "Type of arg 1 to whatever must be hash or
+array". [perl #127976]
+
+=item *
+
+C<undef *_; shift> or C<undef *_; pop> inside a subroutine, with no
+argument to C<shift> or C<pop>, began crashing in Perl 5.14.0, but has now
+been fixed.
+
+=item *
+
+C<< "string$scalar-E<gt>$*" >> now correctly prefers concat overloading to
+string overloading if C<< $scalar-E<gt>$* >> returns an overloaded object,
+bringing it into consistency with C<$$scalar>.
+
+=item *
+
+C<< /@0{0*-E<gt>@*/*0 >> and similar contortions used to crash, but no longer
+do, but merely produce a syntax error. [perl #128171]
+
+=item *
+
+C<do> or C<require> with a reference or typeglob which, when stringified,
+contains a null character started crashing in Perl 5.20.0, but has now been
+fixed. [perl #128182]
+
+=back
+
+=head1 Utility Changes
+
+=head2 L<perlbug>
+
+=over 4
+
+=item *
+
+Long lines in the message body are now wrapped at 900 characters, to stay
+well within the 1000-character limit imposed by SMTP mail transfer agents.
+This is particularly likely to be important for the list of arguments to
+C<Configure>, which can readily exceed the limit if, for example, it names
+several non-default installation paths. This change also adds the first unit
+tests for perlbug. [perl #128020]
+
+=back
+
+=head1 Configuration and Compilation
+
+=over 4
+
+=item *
+
+C<Configure> now builds C<miniperl> and C<generate_uudmap> if you
+invoke it with C<-Dusecrosscompiler> but not C<-Dtargethost=somehost>.
+This means you can supply your target platform C<config.sh>, generate
+the headers and proceed to build your cross-target perl. [perl #127234]
+
+=item *
+
+Builds with C<-Accflags=-DPERL_TRACE_OPS> now only dump the operator
+counts when the environment variable C<PERL_TRACE_OPS> to be set to a
+non-zero integer. This allows C<make test> to pass on such a build.
+
+=item *
+
+When building with GCC 6 and link-time optimization (the C<-flto> option to
+C<gcc>), C<Configure> was treating all probed symbols as present on the
+system, regardless of whether they actually exist. This has been fixed.
+[perl #128131]
+
+=item *
+
+The F<t/test.pl> library is used for internal testing of Perl itself, and
+also copied by several CPAN modules. Some of those modules must work on
+older versions of Perl, so F<t/test.pl> must in turn avoid newer Perl
+features. Compatibility with Perl 5.8 was inadvertently removed some time
+ago; it has now been restored. [perl #128052]
+
+=item *
+
+The build process no longer emits an extra blank line before building each
+"simple" extension (those with only F<*.pm> and F<*.pod> files).
+
+=back
+
+=head1 Internal Changes
+
+=over 4
+
+=item *
+
+Perl is now built with the C<PERL_OP_PARENT> compiler define enabled by
+default. To disable it, use the C<PERL_NO_OP_PARENT> compiler define.
+This flag alters how the C<op_sibling> field is used in C<OP> structures,
+and has been available optionally since perl 5.22.0.
+
+See L<perl5220delta/"Internal Changes"> for more details of what this
+build option does.
+
+=back
+
+=head1 Selected Bug Fixes
+
+=over 4
+
+=item *
+
+Expressions containing an C<&&> or C<||> operator (or their synonyms C<and>
+and C<or>) were being compiled incorrectly in some cases. If the left-hand
+side consisted of either a negated bareword constant or a negated C<do {}>
+block containing a constant expression, and the right-hand side consisted of
+a negated non-foldable expression, one of the negations was effectively
+ignored. The same was true of C<if> and C<unless> statement modifiers,
+though with the left-hand and right-hand sides swapped. This long-standing
+bug has now been fixed. [perl #127952]
+
+=item *
+
+C<reset> with an argument no longer crashes when encountering stash entries
+other than globs. [perl #128106]
+
+=item *
+
+Assignment of hashes to, and deletion of, typeglobs named C<*::::::> no
+longer causes crashes. [perl #128086]
+
+=back
=head1 Acknowledgements
-Perl 5.25.0 represents about an hour or two of work since Perl 5.24.0 and
-contains approximately 4,900 lines of changes across 42 files from 1 author,
-who mostly just ran code-updating tools.
+Perl 5.25.1 represents approximately 2 weeks of development since Perl 5.25.0
+and contains approximately 46,000 lines of changes across 630 files from 24
+authors.
Excluding auto-generated files, documentation and release tools, there were
-approximately 66 lines of changes to 7 .pm, .t, .c and .h files.
+approximately 40,000 lines of changes to 510 .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.0:
+improvements that became Perl 5.25.1:
+
+Aaron Crane, Andreas Voegele, Chad Granum, Chris 'BinGOs' Williams, Craig A.
+Berry, David Mitchell, Doug Bell, Father Chrysostomos, H.Merijn Brand, Hugo van
+der Sanden, Jarkko Hietaniemi, Jerry D. Hedden, Jim Cromie, John Lightsey,
+Karen Etheridge, Karl Williamson, Lukas Mai, Maxwell Carey, Nicholas Clark,
+Niko Tyni, Ricardo Signes, Sawyer X, Tony Cook, Yves Orton.
+
+The list above is almost certainly incomplete as it is automatically generated
+from version control history. In particular, it does not include the names of
+the (very much appreciated) contributors who reported issues to the Perl bug
+tracker.
-Ricardo Signes
+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.
The C<strict> pragma is useful in avoiding such errors.
+=item Bareword in require contains "%s"
+
+=item Bareword in require maps to empty filename
+
+=item Bareword in require maps to disallowed filename "%s"
+
+
+(F) The bareword form of require has been invoked with a filename which could
+not have been generated by a valid bareword permitted by the parser. You
+shouldn't be able to get this error from Perl code, but XS code may throw it
+if it passes an invalid module name to C<Perl_load_module>.
+
+=item Bareword in require must not start with a double-colon: "%s"
+
+(F) In C<require Bare::Word>, the bareword is not allowed to start with a
+double-colon. Write C<require ::Foo::Bar> as C<require Foo::Bar> instead.
+
=item Bareword "%s" not allowed while "strict subs" in use
(F) With "strict subs" in use, a bareword is only allowed as a
(F) The parser has given up trying to parse the program after 10 errors.
Further error messages would likely be uninformative.
-=item Having more than one /%c regexp modifier is deprecated
-
-(D deprecated, regexp) You used the indicated regular expression pattern
-modifier at least twice in a string of modifiers. It is deprecated to
-do this with this particular modifier, to allow future extensions to the
-Perl language.
-
=item Hexadecimal float: exponent overflow
(W overflow) The hexadecimal floating point has a larger exponent
will be another way to do what you want that is, if not secure, at least
securable. See L<perlsec>.
-=item NO-BREAK SPACE in a charnames alias definition is deprecated
-
-(D deprecated) You defined a character name which contained a no-break
-space character. Change it to a regular space. Usually these names are
-defined in the C<:alias> import argument to C<use charnames>, but they
-could be defined by a translator installed into C<$^H{charnames}>. See
-L<charnames/CUSTOM ALIASES>.
-
=item No code specified for -%c
(F) Perl's B<-e> and B<-E> command-line options require an argument. If
a reference to something else instead. You can use the ref() function
to find out what kind of ref it really was. See L<perlref>.
-=item Not an unblessed ARRAY reference
-
-(F) You passed a reference to a blessed array to C<push>, C<shift> or
-another array function. These only accept unblessed array references
-or arrays beginning explicitly with C<@>.
-
=item Not a SCALAR reference
(F) Perl was trying to evaluate a reference to a scalar value, but found
(W unopened) You tried to invoke a file test operator on a filehandle
that isn't open. Check your control flow. See also L<perlfunc/-X>.
+=item Only one /x regex modifier is allowed
+
+=item Only one /x regex modifier is allowed in regex; marked by <-- HERE in m/%s/
+
+(F) You used the C</x> regular expression pattern modifier at least
+twice in a string of modifiers. It is illegal to do this with, to allow
+future extensions to the Perl language.
+
=item oops: oopsAV
(S internal) An internal warning that the grammar is screwed up.
(A) You've accidentally run your script through B<csh> instead of Perl.
Check the #! line, or manually feed your script into Perl yourself.
-=item Unescaped left brace in regex is deprecated, passed through in regex;
+=item Unescaped left brace in regex is illegal in regex;
marked by S<<-- HERE> in m/%s/
-(D deprecated, regexp) You used a literal C<"{"> character in a regular
-expression pattern. You should change to use C<"\{"> instead, because a
-future version of Perl (tentatively v5.26) will consider this to be a
-syntax error. If the pattern delimiters are also braces, any matching
+(F) You used a literal C<"{"> character in a regular
+expression pattern. You should change to use C<"\{"> or C<[{]> instead.
+If the pattern delimiters are also braces, any matching
right brace (C<"}">) should also be escaped to avoid confusing the parser,
for example,
qr{abc\{def\}ghi}
+This restriction is not enforced if the C<"{"> is the first character in
+the pattern; nor is a warning generated for this case, as there are no
+current plans to forbid it.
+
=item unexec of %s into %s failed!
(F) The unexec() routine failed for some reason. See your local FSF
generally because there's a better way to do it, and also because the
old way has bad side effects.
-=item Use of literal control characters in variable names is deprecated
-
-=item Use of literal non-graphic characters in variable names is deprecated
-
-(D deprecated) Using literal non-graphic (including control)
-characters in the source to refer to the ^FOO variables, like C<$^X> and
-C<${^GLOBAL_PHASE}> is now deprecated. (We use C<^X> and C<^G> here for
-legibility. They actually represent the non-printable control
-characters, code points 0x18 and 0x07, respectively; C<^A> would mean
-the control character whose code point is 0x01.) This only affects
-code like C<$\cT>, where C<\cT> is a control in the source code; C<${"\cT"}> and
-C<$^T> remain valid. Things that are non-controls and also not graphic
-are NO-BREAK SPACE and SOFT HYPHEN, which were previously only allowed
-for historical reasons.
-
=item Use of -l on filehandle%s
(W io) A filehandle represents an opened file, and when you opened the file
printf '<%e>', 10; # prints "<1.000000e+01>"
printf '<%.1e>', 10; # prints "<1.0e+01>"
-For "g" and "G", this specifies the maximum number of digits to show,
-including those prior to the decimal point and those after it; for
-example:
+For "g" and "G", this specifies the maximum number of significant digits to
+show; for example:
# These examples are subject to system-specific variation.
printf '<%g>', 1; # prints "<1>"
printf '<%.2g>', 100.01; # prints "<1e+02>"
printf '<%.5g>', 100.01; # prints "<100.01>"
printf '<%.4g>', 100.01; # prints "<100>"
+ printf '<%.1g>', 0.0111; # prints "<0.01>"
+ printf '<%.2g>', 0.0111; # prints "<0.011>"
+ printf '<%.3g>', 0.0111; # prints "<0.0111>"
For integer conversions, specifying a precision implies that the
output of the number itself should be zero-padded to this width,
Ricardo 5.24.0 2016-May-09
Ricardo 5.25.0 2016-May-09 The 5.25 development track
+ Sawyer X 5.25.1 2016-May-20
=head2 SELECTED RELEASE SIZES
printf "child exited with value %d\n", $? >> 8;
}
+Use the L<open> pragma to control the I/O layers used when reading the
+output of the command, for example:
+
+ use open IN => ":encoding(UTF-8)";
+ my $x = `cmd-producing-utf-8`;
+
See L</"I/O Operators"> for more discussion.
=item C<qw/I<STRING>/>
=back
-See L<http://www.cs.rice.edu/~scrosby/hash/> for more information,
+See L<https://www.usenix.org/legacy/events/sec03/tech/full_papers/crosby/crosby.pdf> for more information,
and any computer science textbook on algorithmic complexity.
=head1 SEE ALSO
}
}
-#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \
- && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
-STATIC
-PP(pp_i_modulo_0)
-#else
PP(pp_i_modulo)
-#endif
{
/* This is the vanilla old i_modulo. */
dSP; dATARGET;
}
}
-#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \
+#if defined(__GLIBC__) && IVSIZE == 8 \
&& ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
-STATIC
-PP(pp_i_modulo_1)
+PP(pp_i_modulo_glibc_bugfix)
{
/* This is the i_modulo with the workaround for the _moddi3 bug
* in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
RETURN;
}
}
-
-PP(pp_i_modulo)
-{
- dVAR; dSP; dATARGET;
- tryAMAGICbin_MG(modulo_amg, AMGf_assign);
- {
- dPOPTOPiirl_nomg;
- if (!right)
- DIE(aTHX_ "Illegal modulus zero");
- /* The assumption is to use hereafter the old vanilla version... */
- PL_op->op_ppaddr =
- PL_ppaddr[OP_I_MODULO] =
- Perl_pp_i_modulo_0;
- /* .. but if we have glibc, we might have a buggy _moddi3
- * (at least glibc 2.2.5 is known to have this bug), in other
- * words our integer modulus with negative quad as the second
- * argument might be broken. Test for this and re-patch the
- * opcode dispatch table if that is the case, remembering to
- * also apply the workaround so that this first round works
- * right, too. See [perl #9402] for more information. */
- {
- IV l = 3;
- IV r = -10;
- /* Cannot do this check with inlined IV constants since
- * that seems to work correctly even with the buggy glibc. */
- if (l % r == -3) {
- /* Yikes, we have the bug.
- * Patch in the workaround version. */
- PL_op->op_ppaddr =
- PL_ppaddr[OP_I_MODULO] =
- &Perl_pp_i_modulo_1;
- /* Make certain we work right this time, too. */
- right = PERL_ABS(right);
- }
- }
- /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
- if (right == -1)
- SETi( 0 );
- else
- SETi( left % right );
- RETURN;
- }
-}
#endif
PP(pp_i_add)
RETURN;
}
-static AV *
-S_deref_plain_array(pTHX_ AV *ary)
-{
- if (SvTYPE(ary) == SVt_PVAV) return ary;
- SvGETMAGIC((SV *)ary);
- if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
- Perl_die(aTHX_ "Not an ARRAY reference");
- else if (SvOBJECT(SvRV(ary)))
- Perl_die(aTHX_ "Not an unblessed ARRAY reference");
- return (AV *)SvRV(ary);
-}
-
-#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
-# define DEREF_PLAIN_ARRAY(ary) \
- ({ \
- AV *aRrRay = ary; \
- SvTYPE(aRrRay) == SVt_PVAV \
- ? aRrRay \
- : S_deref_plain_array(aTHX_ aRrRay); \
- })
-#else
-# define DEREF_PLAIN_ARRAY(ary) \
- ( \
- PL_Sv = (SV *)(ary), \
- SvTYPE(PL_Sv) == SVt_PVAV \
- ? (AV *)PL_Sv \
- : S_deref_plain_array(aTHX_ (AV *)PL_Sv) \
- )
-#endif
-
PP(pp_splice)
{
dSP; dMARK; dORIGMARK;
int num_args = (SP - MARK);
- AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
+ AV *ary = MUTABLE_AV(*++MARK);
SV **src;
SV **dst;
SSize_t i;
PP(pp_push)
{
dSP; dMARK; dORIGMARK; dTARGET;
- AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
+ AV * const ary = MUTABLE_AV(*++MARK);
const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
if (mg) {
{
dSP;
AV * const av = PL_op->op_flags & OPf_SPECIAL
- ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
+ ? MUTABLE_AV(GvAVn(PL_defgv)) : MUTABLE_AV(POPs);
SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
EXTEND(SP, 1);
assert (sv);
PP(pp_unshift)
{
dSP; dMARK; dORIGMARK; dTARGET;
- AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
+ AV *ary = MUTABLE_AV(*++MARK);
const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
if (mg) {
}
-/* also used for: pp_dofile() */
+/* implement 'require 5.010001' */
-PP(pp_require)
+static OP *
+S_require_version(pTHX_ SV *sv)
{
- dSP;
+ dVAR; dSP;
+
+ sv = sv_2mortal(new_version(sv));
+ if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
+ upg_version(PL_patchlevel, TRUE);
+ if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
+ if ( vcmp(sv,PL_patchlevel) <= 0 )
+ DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
+ SVfARG(sv_2mortal(vnormal(sv))),
+ SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
+ );
+ }
+ else {
+ if ( vcmp(sv,PL_patchlevel) > 0 ) {
+ I32 first = 0;
+ AV *lav;
+ SV * const req = SvRV(sv);
+ SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
+
+ /* get the left hand term */
+ lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
+
+ first = SvIV(*av_fetch(lav,0,0));
+ if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
+ || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
+ || av_tindex(lav) > 1 /* FP with > 3 digits */
+ || strstr(SvPVX(pv),".0") /* FP with leading 0 */
+ ) {
+ DIE(aTHX_ "Perl %"SVf" required--this is only "
+ "%"SVf", stopped",
+ SVfARG(sv_2mortal(vnormal(req))),
+ SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
+ );
+ }
+ else { /* probably 'use 5.10' or 'use 5.8' */
+ SV *hintsv;
+ I32 second = 0;
+
+ if (av_tindex(lav)>=1)
+ second = SvIV(*av_fetch(lav,1,0));
+
+ second /= second >= 600 ? 100 : 10;
+ hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
+ (int)first, (int)second);
+ upg_version(hintsv, TRUE);
+
+ DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
+ "--this is only %"SVf", stopped",
+ SVfARG(sv_2mortal(vnormal(req))),
+ SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
+ SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
+ );
+ }
+ }
+ }
+
+ RETPUSHYES;
+}
+
+/* Handle C<require Foo::Bar>, C<require "Foo/Bar.pm"> and C<do "Foo.pm">.
+ * The first form will have already been converted at compile time to
+ * the second form */
+
+static OP *
+S_require_file(pTHX_ SV *const sv)
+{
+ dVAR; dSP;
+
PERL_CONTEXT *cx;
- SV *sv;
const char *name;
STRLEN len;
char * unixname;
bool path_searchable;
I32 old_savestack_ix;
- sv = POPs;
- SvGETMAGIC(sv);
- if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
- sv = sv_2mortal(new_version(sv));
- if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
- upg_version(PL_patchlevel, TRUE);
- if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
- if ( vcmp(sv,PL_patchlevel) <= 0 )
- DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
- SVfARG(sv_2mortal(vnormal(sv))),
- SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
- );
- }
- else {
- if ( vcmp(sv,PL_patchlevel) > 0 ) {
- I32 first = 0;
- AV *lav;
- SV * const req = SvRV(sv);
- SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
-
- /* get the left hand term */
- lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
-
- first = SvIV(*av_fetch(lav,0,0));
- if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
- || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
- || av_tindex(lav) > 1 /* FP with > 3 digits */
- || strstr(SvPVX(pv),".0") /* FP with leading 0 */
- ) {
- DIE(aTHX_ "Perl %"SVf" required--this is only "
- "%"SVf", stopped",
- SVfARG(sv_2mortal(vnormal(req))),
- SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
- );
- }
- else { /* probably 'use 5.10' or 'use 5.8' */
- SV *hintsv;
- I32 second = 0;
-
- if (av_tindex(lav)>=1)
- second = SvIV(*av_fetch(lav,1,0));
-
- second /= second >= 600 ? 100 : 10;
- hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
- (int)first, (int)second);
- upg_version(hintsv, TRUE);
-
- DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
- "--this is only %"SVf", stopped",
- SVfARG(sv_2mortal(vnormal(req))),
- SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
- SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
- );
- }
- }
- }
-
- RETPUSHYES;
- }
if (!SvOK(sv))
DIE(aTHX_ "Missing or undefined argument to require");
name = SvPV_nomg_const(sv, len);
if (!IS_SAFE_PATHNAME(name, len, "require")) {
DIE(aTHX_ "Can't locate %s: %s",
- pv_escape(newSVpvs_flags("",SVs_TEMP),SvPVX(sv),SvCUR(sv),
- SvCUR(sv)*2,NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
+ pv_escape(newSVpvs_flags("",SVs_TEMP),name,len,len*2,
+ NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
Strerror(ENOENT));
}
TAINT_PROPER("require");
DIE(aTHX_ "Attempt to reload %s aborted.\n"
"Compilation failed in require", unixname);
}
+
+ if (PL_op->op_flags & OPf_KIDS) {
+ SVOP * const kid = (SVOP*)cUNOP->op_first;
+
+ if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
+ /* require foo (or use foo) with a bareword.
+ Perl_load_module fakes up the identical optree, but its
+ arguments aren't restricted by the parser to real barewords.
+ */
+ const STRLEN package_len = len - 3;
+ const char slashdot[2] = {'/', '.'};
+#ifdef DOSISH
+ const char backslashdot[2] = {'\\', '.'};
+#endif
+
+ /* Disallow *purported* barewords that map to absolute
+ filenames, filenames relative to the current or parent
+ directory, or (*nix) hidden filenames. Also sanity check
+ that the generated filename ends .pm */
+ if (!path_searchable || len < 3 || name[0] == '.'
+ || !memEQ(name + package_len, ".pm", 3))
+ DIE(aTHX_ "Bareword in require maps to disallowed filename \"%"SVf"\"", sv);
+ if (memchr(name, 0, package_len)) {
+ /* diag_listed_as: Bareword in require contains "%s" */
+ DIE(aTHX_ "Bareword in require contains \"\\0\"");
+ }
+ if (ninstr(name, name + package_len, slashdot,
+ slashdot + sizeof(slashdot))) {
+ /* diag_listed_as: Bareword in require contains "%s" */
+ DIE(aTHX_ "Bareword in require contains \"/.\"");
+ }
+#ifdef DOSISH
+ if (ninstr(name, name + package_len, backslashdot,
+ backslashdot + sizeof(backslashdot))) {
+ /* diag_listed_as: Bareword in require contains "%s" */
+ DIE(aTHX_ "Bareword in require contains \"\\.\"");
+ }
+#endif
+ }
+ }
}
PERL_DTRACE_PROBE_FILE_LOADING(unixname);
return op;
}
+
+/* also used for: pp_dofile() */
+
+PP(pp_require)
+{
+ dSP;
+ SV *sv = POPs;
+ SvGETMAGIC(sv);
+ PUTBACK;
+ return ((SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE)
+ ? S_require_version(aTHX_ sv)
+ : S_require_file(aTHX_ sv);
+}
+
+
/* This is a op added to hold the hints hash for
pp_entereval. The hash can be modified by the code
being eval'ed, so we return a copy instead. */
}
else { /* $l .= $r and left == TARG */
if (!SvOK(left)) {
- if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
- report_uninit(right);
+ if ((left == right /* $l .= $l */
+ || (PL_op->op_private & OPpTARGET_MY)) /* $l = $l . $r */
+ && ckWARN(WARN_UNINITIALIZED)
+ )
+ report_uninit(left);
sv_setpvs(left, "");
}
else {
PERL_CALLCONV OP *Perl_pp_xor(pTHX);
PERL_CALLCONV OP *Perl_unimplemented_op(pTHX);
+/* alternative functions */
+#if defined(__GLIBC__) && IVSIZE == 8 && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
+PERL_CALLCONV OP *Perl_pp_i_modulo_glibc_bugfix(pTHX);
+#endif
+
/* ex: set ro: */
*/
START_EXTERN_C
+#ifndef NO_MATHOMS
PERL_CALLCONV UV ASCII_TO_NEED(const UV enc, const UV ch)
__attribute__deprecated__
__attribute__warn_unused_result__
__attribute__pure__;
+#endif
PERL_CALLCONV int Perl_Gv_AMupdate(pTHX_ HV* stash, bool destructing);
#define PERL_ARGS_ASSERT_GV_AMUPDATE \
assert(stash)
+#ifndef NO_MATHOMS
PERL_CALLCONV UV NATIVE_TO_NEED(const UV enc, const UV ch)
__attribute__deprecated__
__attribute__warn_unused_result__
__attribute__pure__;
+#endif
PERL_CALLCONV const char * Perl_PerlIO_context_layers(pTHX_ const char *mode);
PERL_CALLCONV void* Perl_Slab_Alloc(pTHX_ size_t sz)
#define PERL_ARGS_ASSERT_DIE_UNWIND \
assert(msv)
-/* PERL_CALLCONV bool Perl_do_aexec(pTHX_ SV* really, SV** mark, SV** sp); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV bool Perl_do_aexec(pTHX_ SV* really, SV** mark, SV** sp);
#define PERL_ARGS_ASSERT_DO_AEXEC \
assert(mark); assert(sp)
+#endif
PERL_CALLCONV bool Perl_do_aexec5(pTHX_ SV* really, SV** mark, SV** sp, int fd, int do_report);
#define PERL_ARGS_ASSERT_DO_AEXEC5 \
assert(mark); assert(sp)
PERL_CALLCONV void Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o);
#define PERL_ARGS_ASSERT_DO_OP_DUMP \
assert(file)
-/* PERL_CALLCONV bool Perl_do_open(pTHX_ GV* gv, const char* name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO* supplied_fp); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV bool Perl_do_open(pTHX_ GV* gv, const char* name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO* supplied_fp);
#define PERL_ARGS_ASSERT_DO_OPEN \
assert(gv); assert(name)
+#endif
PERL_CALLCONV bool Perl_do_open6(pTHX_ GV *gv, const char *oname, STRLEN len, PerlIO *supplied_fp, SV **svp, U32 num);
#define PERL_ARGS_ASSERT_DO_OPEN6 \
assert(gv); assert(oname)
PERL_CALLCONV UV Perl_grok_oct(pTHX_ const char* start, STRLEN* len_p, I32* flags, NV *result);
#define PERL_ARGS_ASSERT_GROK_OCT \
assert(start); assert(len_p); assert(flags)
-/* PERL_CALLCONV GV* Perl_gv_AVadd(pTHX_ GV *gv); */
-/* PERL_CALLCONV GV* Perl_gv_HVadd(pTHX_ GV *gv); */
-/* PERL_CALLCONV GV* Perl_gv_IOadd(pTHX_ GV* gv); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV GV* Perl_gv_AVadd(pTHX_ GV *gv);
+#endif
+#ifndef NO_MATHOMS
+PERL_CALLCONV GV* Perl_gv_HVadd(pTHX_ GV *gv);
+#endif
+#ifndef NO_MATHOMS
+PERL_CALLCONV GV* Perl_gv_IOadd(pTHX_ GV* gv);
+#endif
PERL_CALLCONV GV* Perl_gv_add_by_type(pTHX_ GV *gv, svtype type);
/* PERL_CALLCONV GV* gv_autoload4(pTHX_ HV* stash, const char* name, STRLEN len, I32 method)
__attribute__warn_unused_result__; */
PERL_CALLCONV void Perl_gv_efullname(pTHX_ SV* sv, const GV* gv);
#define PERL_ARGS_ASSERT_GV_EFULLNAME \
assert(sv); assert(gv)
-/* PERL_CALLCONV void Perl_gv_efullname3(pTHX_ SV* sv, const GV* gv, const char* prefix); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV void Perl_gv_efullname3(pTHX_ SV* sv, const GV* gv, const char* prefix);
#define PERL_ARGS_ASSERT_GV_EFULLNAME3 \
assert(sv); assert(gv)
+#endif
PERL_CALLCONV void Perl_gv_efullname4(pTHX_ SV* sv, const GV* gv, const char* prefix, bool keepmain);
#define PERL_ARGS_ASSERT_GV_EFULLNAME4 \
assert(sv); assert(gv)
PERL_CALLCONV GV* Perl_gv_fetchmeth_sv_autoload(pTHX_ HV* stash, SV* namesv, I32 level, U32 flags);
#define PERL_ARGS_ASSERT_GV_FETCHMETH_SV_AUTOLOAD \
assert(namesv)
-/* PERL_CALLCONV GV* Perl_gv_fetchmethod(pTHX_ HV* stash, const char* name); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV GV* Perl_gv_fetchmethod(pTHX_ HV* stash, const char* name);
#define PERL_ARGS_ASSERT_GV_FETCHMETHOD \
assert(stash); assert(name)
+#endif
PERL_CALLCONV GV* Perl_gv_fetchmethod_autoload(pTHX_ HV* stash, const char* name, I32 autoload);
#define PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD \
assert(stash); assert(name)
PERL_CALLCONV void Perl_gv_fullname(pTHX_ SV* sv, const GV* gv);
#define PERL_ARGS_ASSERT_GV_FULLNAME \
assert(sv); assert(gv)
-/* PERL_CALLCONV void Perl_gv_fullname3(pTHX_ SV* sv, const GV* gv, const char* prefix); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV void Perl_gv_fullname3(pTHX_ SV* sv, const GV* gv, const char* prefix);
#define PERL_ARGS_ASSERT_GV_FULLNAME3 \
assert(sv); assert(gv)
+#endif
PERL_CALLCONV void Perl_gv_fullname4(pTHX_ SV* sv, const GV* gv, const char* prefix, bool keepmain);
#define PERL_ARGS_ASSERT_GV_FULLNAME4 \
assert(sv); assert(gv)
PERL_CALLCONV void Perl_hv_delayfree_ent(pTHX_ HV *hv, HE *entry);
#define PERL_ARGS_ASSERT_HV_DELAYFREE_ENT \
assert(hv)
-/* PERL_CALLCONV SV* Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV SV* Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags);
#define PERL_ARGS_ASSERT_HV_DELETE \
assert(key)
-/* PERL_CALLCONV SV* Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash); */
+#endif
+#ifndef NO_MATHOMS
+PERL_CALLCONV SV* Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash);
#define PERL_ARGS_ASSERT_HV_DELETE_ENT \
assert(keysv)
+#endif
PERL_CALLCONV HE** Perl_hv_eiter_p(pTHX_ HV *hv)
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_HV_EITER_P \
PERL_CALLCONV void Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len, U32 flags);
#define PERL_ARGS_ASSERT_HV_ENAME_DELETE \
assert(hv); assert(name)
-/* PERL_CALLCONV bool Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
- __attribute__warn_unused_result__; */
+#ifndef NO_MATHOMS
+PERL_CALLCONV bool Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
+ __attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_HV_EXISTS \
assert(key)
+#endif
-/* PERL_CALLCONV bool Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
- __attribute__warn_unused_result__; */
+#ifndef NO_MATHOMS
+PERL_CALLCONV bool Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
+ __attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_HV_EXISTS_ENT \
assert(keysv)
+#endif
-/* PERL_CALLCONV SV** Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV SV** Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval);
#define PERL_ARGS_ASSERT_HV_FETCH \
assert(key)
-/* PERL_CALLCONV HE* Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, U32 hash); */
+#endif
+#ifndef NO_MATHOMS
+PERL_CALLCONV HE* Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, U32 hash);
#define PERL_ARGS_ASSERT_HV_FETCH_ENT \
assert(keysv)
+#endif
PERL_CALLCONV STRLEN Perl_hv_fill(pTHX_ HV *const hv);
#define PERL_ARGS_ASSERT_HV_FILL \
assert(hv)
#define PERL_ARGS_ASSERT_HV_ITERKEYSV \
assert(entry)
-/* PERL_CALLCONV HE* Perl_hv_iternext(pTHX_ HV *hv)
- __attribute__warn_unused_result__; */
+#ifndef NO_MATHOMS
+PERL_CALLCONV HE* Perl_hv_iternext(pTHX_ HV *hv)
+ __attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_HV_ITERNEXT \
assert(hv)
+#endif
PERL_CALLCONV HE* Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
__attribute__warn_unused_result__;
PERL_CALLCONV void Perl_hv_ksplit(pTHX_ HV *hv, IV newmax);
#define PERL_ARGS_ASSERT_HV_KSPLIT \
assert(hv)
-/* PERL_CALLCONV void Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV void Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how);
#define PERL_ARGS_ASSERT_HV_MAGIC \
assert(hv)
+#endif
PERL_CALLCONV void Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags);
#define PERL_ARGS_ASSERT_HV_NAME_SET \
assert(hv)
#define PERL_ARGS_ASSERT_HV_SCALAR \
assert(hv)
-/* PERL_CALLCONV SV** Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash); */
-/* PERL_CALLCONV HE* Perl_hv_store_ent(pTHX_ HV *hv, SV *key, SV *val, U32 hash); */
-/* PERL_CALLCONV SV** Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash, int flags); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV SV** Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash);
+#endif
+#ifndef NO_MATHOMS
+PERL_CALLCONV HE* Perl_hv_store_ent(pTHX_ HV *hv, SV *key, SV *val, U32 hash);
+#endif
+#ifndef NO_MATHOMS
+PERL_CALLCONV SV** Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash, int flags);
+#endif
/* PERL_CALLCONV void hv_undef(pTHX_ HV *hv); */
PERL_CALLCONV void Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags);
/* PERL_CALLCONV I32 ibcmp(pTHX_ const char* a, const char* b, I32 len); */
PERL_CALLCONV void Perl_init_tm(pTHX_ struct tm *ptm);
#define PERL_ARGS_ASSERT_INIT_TM \
assert(ptm)
+#ifndef NO_MATHOMS
PERL_CALLCONV char* Perl_instr(const char* big, const char* little)
__attribute__warn_unused_result__
__attribute__pure__;
#define PERL_ARGS_ASSERT_INSTR \
assert(big); assert(little)
+#endif
PERL_CALLCONV U32 Perl_intro_my(pTHX);
PERL_CALLCONV OP* Perl_invert(pTHX_ OP* cmd)
#define PERL_ARGS_ASSERT_IS_UTF8_CHAR \
assert(s)
-/* PERL_CALLCONV STRLEN Perl_is_utf8_char_buf(const U8 *buf, const U8 *buf_end); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV STRLEN Perl_is_utf8_char_buf(const U8 *buf, const U8 *buf_end);
#define PERL_ARGS_ASSERT_IS_UTF8_CHAR_BUF \
assert(buf); assert(buf_end)
+#endif
PERL_CALLCONV bool Perl_is_utf8_cntrl(pTHX_ const U8 *p)
__attribute__deprecated__
__attribute__warn_unused_result__;
PERL_CALLCONV bool Perl_is_utf8_string(const U8 *s, STRLEN len);
#define PERL_ARGS_ASSERT_IS_UTF8_STRING \
assert(s)
-/* PERL_CALLCONV bool Perl_is_utf8_string_loc(const U8 *s, STRLEN len, const U8 **ep); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV bool Perl_is_utf8_string_loc(const U8 *s, STRLEN len, const U8 **ep);
#define PERL_ARGS_ASSERT_IS_UTF8_STRING_LOC \
assert(s)
+#endif
PERL_CALLCONV bool Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el);
#define PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN \
assert(s)
PERL_CALLCONV I32 Perl_my_fflush_all(pTHX);
PERL_CALLCONV Pid_t Perl_my_fork(void);
-/* PERL_CALLCONV I32 Perl_my_lstat(pTHX); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV I32 Perl_my_lstat(pTHX);
+#endif
PERL_CALLCONV I32 Perl_my_lstat_flags(pTHX_ const U32 flags);
PERL_CALLCONV PerlIO* Perl_my_popen_list(pTHX_ const char* mode, int n, SV ** args);
#define PERL_ARGS_ASSERT_MY_POPEN_LIST \
assert(buffer); assert(format)
PERL_CALLCONV int Perl_my_socketpair(int family, int type, int protocol, int fd[2]);
-/* PERL_CALLCONV I32 Perl_my_stat(pTHX); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV I32 Perl_my_stat(pTHX);
+#endif
PERL_CALLCONV I32 Perl_my_stat_flags(pTHX_ const U32 flags);
PERL_CALLCONV char* Perl_my_strerror(pTHX_ const int errnum);
PERL_CALLCONV char * Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst)
/* PERL_CALLCONV CV* newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block); */
PERL_CALLCONV CV* Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block, bool o_is_gv);
-/* PERL_CALLCONV AV* Perl_newAV(pTHX)
- __attribute__warn_unused_result__; */
+#ifndef NO_MATHOMS
+PERL_CALLCONV AV* Perl_newAV(pTHX)
+ __attribute__warn_unused_result__;
+#endif
PERL_CALLCONV OP* Perl_newAVREF(pTHX_ OP* o)
__attribute__malloc__
#define PERL_ARGS_ASSERT_NEWGVGEN_FLAGS \
assert(pack)
-/* PERL_CALLCONV HV* Perl_newHV(pTHX)
- __attribute__warn_unused_result__; */
+#ifndef NO_MATHOMS
+PERL_CALLCONV HV* Perl_newHV(pTHX)
+ __attribute__warn_unused_result__;
+#endif
PERL_CALLCONV OP* Perl_newHVREF(pTHX_ OP* o)
__attribute__malloc__
__attribute__malloc__
__attribute__warn_unused_result__;
-/* PERL_CALLCONV IO* Perl_newIO(pTHX)
+#ifndef NO_MATHOMS
+PERL_CALLCONV IO* Perl_newIO(pTHX)
__attribute__malloc__
- __attribute__warn_unused_result__; */
+ __attribute__warn_unused_result__;
+#endif
PERL_CALLCONV OP* Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP* first, OP* last)
__attribute__malloc__
PERL_CALLCONV CV* Perl_newSTUB(pTHX_ GV *gv, bool fake);
#define PERL_ARGS_ASSERT_NEWSTUB \
assert(gv)
-/* PERL_CALLCONV CV* Perl_newSUB(pTHX_ I32 floor, OP* o, OP* proto, OP* block); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV CV* Perl_newSUB(pTHX_ I32 floor, OP* o, OP* proto, OP* block);
+#endif
PERL_CALLCONV SV* Perl_newSV(pTHX_ const STRLEN len)
__attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV PerlIO* Perl_nextargv(pTHX_ GV* gv, bool nomagicopen);
#define PERL_ARGS_ASSERT_NEXTARGV \
assert(gv)
-PERL_CALLCONV char* Perl_ninstr(const char* big, const char* bigend, const char* little, const char* lend)
- __attribute__pure__;
-#define PERL_ARGS_ASSERT_NINSTR \
- assert(big); assert(bigend); assert(little); assert(lend)
-
PERL_CALLCONV_NO_RET void Perl_noperl_die(const char* pat, ...)
__attribute__noreturn__
__attribute__format__(__printf__,1,2);
assert(func)
PERL_CALLCONV PADOFFSET Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype);
PERL_CALLCONV void Perl_pad_block_start(pTHX_ int full);
+#ifndef NO_MATHOMS
PERL_CALLCONV HV* Perl_pad_compname_type(pTHX_ const PADOFFSET po)
__attribute__warn_unused_result__;
+#endif
PERL_CALLCONV PADOFFSET Perl_pad_findmy_pv(pTHX_ const char* name, U32 flags);
#define PERL_ARGS_ASSERT_PAD_FINDMY_PV \
#define PERL_ARGS_ASSERT_REENTRANT_RETRY \
assert(f)
PERL_CALLCONV void Perl_reentrant_size(pTHX);
-/* PERL_CALLCONV OP* Perl_ref(pTHX_ OP* o, I32 type); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV OP* Perl_ref(pTHX_ OP* o, I32 type);
+#endif
PERL_CALLCONV HV * Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *c, U32 flags);
PERL_CALLCONV SV * Perl_refcounted_he_fetch_pv(pTHX_ const struct refcounted_he *chain, const char *key, U32 hash, U32 flags);
#define PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PV \
#define PERL_ARGS_ASSERT_SAVE_DESTRUCTOR \
assert(p)
PERL_CALLCONV void Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p);
-/* PERL_CALLCONV void Perl_save_freeop(pTHX_ OP* o); */
-/* PERL_CALLCONV void Perl_save_freepv(pTHX_ char* pv); */
-/* PERL_CALLCONV void Perl_save_freesv(pTHX_ SV* sv); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV void Perl_save_freeop(pTHX_ OP* o);
+#endif
+#ifndef NO_MATHOMS
+PERL_CALLCONV void Perl_save_freepv(pTHX_ char* pv);
+#endif
+#ifndef NO_MATHOMS
+PERL_CALLCONV void Perl_save_freesv(pTHX_ SV* sv);
+#endif
PERL_CALLCONV void Perl_save_generic_pvref(pTHX_ char** str);
#define PERL_ARGS_ASSERT_SAVE_GENERIC_PVREF \
assert(str)
PERL_CALLCONV void Perl_save_long(pTHX_ long* longp);
#define PERL_ARGS_ASSERT_SAVE_LONG \
assert(longp)
-/* PERL_CALLCONV void Perl_save_mortalizesv(pTHX_ SV* sv); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV void Perl_save_mortalizesv(pTHX_ SV* sv);
#define PERL_ARGS_ASSERT_SAVE_MORTALIZESV \
assert(sv)
+#endif
PERL_CALLCONV void Perl_save_nogv(pTHX_ GV* gv);
#define PERL_ARGS_ASSERT_SAVE_NOGV \
assert(gv)
-/* PERL_CALLCONV void Perl_save_op(pTHX); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV void Perl_save_op(pTHX);
+#endif
PERL_CALLCONV void Perl_save_padsv_and_mortalize(pTHX_ PADOFFSET off);
PERL_CALLCONV void Perl_save_pptr(pTHX_ char** pptr);
#define PERL_ARGS_ASSERT_SAVE_PPTR \
PERL_CALLCONV IO* Perl_sv_2io(pTHX_ SV *const sv);
#define PERL_ARGS_ASSERT_SV_2IO \
assert(sv)
-/* PERL_CALLCONV IV Perl_sv_2iv(pTHX_ SV *sv); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV IV Perl_sv_2iv(pTHX_ SV *sv);
#define PERL_ARGS_ASSERT_SV_2IV \
assert(sv)
+#endif
PERL_CALLCONV IV Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags);
#define PERL_ARGS_ASSERT_SV_2IV_FLAGS \
assert(sv)
PERL_CALLCONV NV Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags);
#define PERL_ARGS_ASSERT_SV_2NV_FLAGS \
assert(sv)
-/* PERL_CALLCONV char* Perl_sv_2pv(pTHX_ SV *sv, STRLEN *lp); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV char* Perl_sv_2pv(pTHX_ SV *sv, STRLEN *lp);
#define PERL_ARGS_ASSERT_SV_2PV \
assert(sv)
+#endif
PERL_CALLCONV char* Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags);
#define PERL_ARGS_ASSERT_SV_2PV_FLAGS \
assert(sv)
-/* PERL_CALLCONV char* Perl_sv_2pv_nolen(pTHX_ SV* sv)
- __attribute__warn_unused_result__; */
+#ifndef NO_MATHOMS
+PERL_CALLCONV char* Perl_sv_2pv_nolen(pTHX_ SV* sv)
+ __attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_SV_2PV_NOLEN \
assert(sv)
+#endif
PERL_CALLCONV char* Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp);
#define PERL_ARGS_ASSERT_SV_2PVBYTE \
assert(sv)
-/* PERL_CALLCONV char* Perl_sv_2pvbyte_nolen(pTHX_ SV* sv)
- __attribute__warn_unused_result__; */
+#ifndef NO_MATHOMS
+PERL_CALLCONV char* Perl_sv_2pvbyte_nolen(pTHX_ SV* sv)
+ __attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_SV_2PVBYTE_NOLEN \
assert(sv)
+#endif
PERL_CALLCONV char* Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp);
#define PERL_ARGS_ASSERT_SV_2PVUTF8 \
assert(sv)
-/* PERL_CALLCONV char* Perl_sv_2pvutf8_nolen(pTHX_ SV* sv)
- __attribute__warn_unused_result__; */
+#ifndef NO_MATHOMS
+PERL_CALLCONV char* Perl_sv_2pvutf8_nolen(pTHX_ SV* sv)
+ __attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_SV_2PVUTF8_NOLEN \
assert(sv)
+#endif
-/* PERL_CALLCONV UV Perl_sv_2uv(pTHX_ SV *sv); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV UV Perl_sv_2uv(pTHX_ SV *sv);
#define PERL_ARGS_ASSERT_SV_2UV \
assert(sv)
+#endif
PERL_CALLCONV UV Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags);
#define PERL_ARGS_ASSERT_SV_2UV_FLAGS \
assert(sv)
#define PERL_ARGS_ASSERT_SV_CATPVF_MG \
assert(sv); assert(pat)
-/* PERL_CALLCONV void Perl_sv_catpvn(pTHX_ SV *dsv, const char *sstr, STRLEN len); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV void Perl_sv_catpvn(pTHX_ SV *dsv, const char *sstr, STRLEN len);
#define PERL_ARGS_ASSERT_SV_CATPVN \
assert(dsv); assert(sstr)
+#endif
PERL_CALLCONV void Perl_sv_catpvn_flags(pTHX_ SV *const dstr, const char *sstr, const STRLEN len, const I32 flags);
#define PERL_ARGS_ASSERT_SV_CATPVN_FLAGS \
assert(dstr); assert(sstr)
-/* PERL_CALLCONV void Perl_sv_catpvn_mg(pTHX_ SV *sv, const char *ptr, STRLEN len); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV void Perl_sv_catpvn_mg(pTHX_ SV *sv, const char *ptr, STRLEN len);
#define PERL_ARGS_ASSERT_SV_CATPVN_MG \
assert(sv); assert(ptr)
-/* PERL_CALLCONV void Perl_sv_catsv(pTHX_ SV *dstr, SV *sstr); */
+#endif
+#ifndef NO_MATHOMS
+PERL_CALLCONV void Perl_sv_catsv(pTHX_ SV *dstr, SV *sstr);
#define PERL_ARGS_ASSERT_SV_CATSV \
assert(dstr)
+#endif
PERL_CALLCONV void Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags);
#define PERL_ARGS_ASSERT_SV_CATSV_FLAGS \
assert(dsv)
-/* PERL_CALLCONV void Perl_sv_catsv_mg(pTHX_ SV *dsv, SV *ssv); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV void Perl_sv_catsv_mg(pTHX_ SV *dsv, SV *ssv);
#define PERL_ARGS_ASSERT_SV_CATSV_MG \
assert(dsv)
+#endif
PERL_CALLCONV void Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr);
#define PERL_ARGS_ASSERT_SV_CHOP \
assert(sv)
PERL_CALLCONV I32 Perl_sv_cmp_flags(pTHX_ SV *const sv1, SV *const sv2, const U32 flags);
PERL_CALLCONV I32 Perl_sv_cmp_locale(pTHX_ SV *const sv1, SV *const sv2);
PERL_CALLCONV I32 Perl_sv_cmp_locale_flags(pTHX_ SV *const sv1, SV *const sv2, const U32 flags);
-/* PERL_CALLCONV void Perl_sv_copypv(pTHX_ SV *const dsv, SV *const ssv); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV void Perl_sv_copypv(pTHX_ SV *const dsv, SV *const ssv);
#define PERL_ARGS_ASSERT_SV_COPYPV \
assert(dsv); assert(ssv)
+#endif
PERL_CALLCONV void Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags);
#define PERL_ARGS_ASSERT_SV_COPYPV_FLAGS \
assert(dsv); assert(ssv)
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);
-/* PERL_CALLCONV void Perl_sv_force_normal(pTHX_ SV *sv); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV void Perl_sv_force_normal(pTHX_ SV *sv);
#define PERL_ARGS_ASSERT_SV_FORCE_NORMAL \
assert(sv)
+#endif
PERL_CALLCONV void Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags);
#define PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS \
assert(sv)
assert(sv)
PERL_CALLCONV void Perl_sv_inc(pTHX_ SV *const sv);
PERL_CALLCONV void Perl_sv_inc_nomg(pTHX_ SV *const sv);
-/* PERL_CALLCONV void Perl_sv_insert(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV void Perl_sv_insert(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen);
#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);
#define PERL_ARGS_ASSERT_SV_INSERT_FLAGS \
assert(bigstr); assert(little)
PERL_CALLCONV MAGIC * Perl_sv_magicext_mglob(pTHX_ SV *sv);
#define PERL_ARGS_ASSERT_SV_MAGICEXT_MGLOB \
assert(sv)
-/* PERL_CALLCONV SV* Perl_sv_mortalcopy(pTHX_ SV *const oldsv)
+#ifndef NO_MATHOMS
+PERL_CALLCONV SV* Perl_sv_mortalcopy(pTHX_ SV *const oldsv)
__attribute__malloc__
- __attribute__warn_unused_result__; */
+ __attribute__warn_unused_result__;
+#endif
PERL_CALLCONV SV* Perl_sv_mortalcopy_flags(pTHX_ SV *const oldsv, U32 flags)
__attribute__malloc__
__attribute__warn_unused_result__;
PERL_CALLCONV SV* Perl_sv_newref(pTHX_ SV *const sv);
-/* PERL_CALLCONV void Perl_sv_nolocking(pTHX_ SV *sv); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV void Perl_sv_nolocking(pTHX_ SV *sv);
+#endif
PERL_CALLCONV void Perl_sv_nosharing(pTHX_ SV *sv);
+#ifndef NO_MATHOMS
+PERL_CALLCONV void Perl_sv_nounlocking(pTHX_ SV *sv);
+#endif
PERL_CALLCONV NV Perl_sv_nv(pTHX_ SV* sv);
#define PERL_ARGS_ASSERT_SV_NV \
assert(sv)
PERL_CALLCONV STRLEN Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp, U32 flags);
#define PERL_ARGS_ASSERT_SV_POS_U2B_FLAGS \
assert(sv)
-/* PERL_CALLCONV char* Perl_sv_pv(pTHX_ SV *sv)
- __attribute__warn_unused_result__; */
+#ifndef NO_MATHOMS
+PERL_CALLCONV char* Perl_sv_pv(pTHX_ SV *sv)
+ __attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_SV_PV \
assert(sv)
+#endif
-/* PERL_CALLCONV char* Perl_sv_pvbyte(pTHX_ SV *sv)
- __attribute__warn_unused_result__; */
+#ifndef NO_MATHOMS
+PERL_CALLCONV char* Perl_sv_pvbyte(pTHX_ SV *sv)
+ __attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_SV_PVBYTE \
assert(sv)
+#endif
PERL_CALLCONV char* Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp);
#define PERL_ARGS_ASSERT_SV_PVBYTEN \
PERL_CALLCONV char* Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp);
#define PERL_ARGS_ASSERT_SV_PVN \
assert(sv); assert(lp)
-/* PERL_CALLCONV char* Perl_sv_pvn_force(pTHX_ SV* sv, STRLEN* lp); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV char* Perl_sv_pvn_force(pTHX_ SV* sv, STRLEN* lp);
#define PERL_ARGS_ASSERT_SV_PVN_FORCE \
assert(sv)
+#endif
PERL_CALLCONV char* Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags);
#define PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS \
assert(sv)
PERL_CALLCONV char* Perl_sv_pvn_nomg(pTHX_ SV* sv, STRLEN* lp);
#define PERL_ARGS_ASSERT_SV_PVN_NOMG \
assert(sv)
-/* PERL_CALLCONV char* Perl_sv_pvutf8(pTHX_ SV *sv)
- __attribute__warn_unused_result__; */
+#ifndef NO_MATHOMS
+PERL_CALLCONV char* Perl_sv_pvutf8(pTHX_ SV *sv)
+ __attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_SV_PVUTF8 \
assert(sv)
+#endif
PERL_CALLCONV char* Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp);
#define PERL_ARGS_ASSERT_SV_PVUTF8N \
#define PERL_ARGS_ASSERT_SV_SETPVF_MG \
assert(sv); assert(pat)
+#ifndef NO_MATHOMS
PERL_CALLCONV void Perl_sv_setpviv(pTHX_ SV *const sv, const IV num);
#define PERL_ARGS_ASSERT_SV_SETPVIV \
assert(sv)
+#endif
+#ifndef NO_MATHOMS
PERL_CALLCONV void Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv);
#define PERL_ARGS_ASSERT_SV_SETPVIV_MG \
assert(sv)
+#endif
PERL_CALLCONV void Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len);
#define PERL_ARGS_ASSERT_SV_SETPVN \
assert(sv)
PERL_CALLCONV SV* Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv);
#define PERL_ARGS_ASSERT_SV_SETREF_UV \
assert(rv)
-/* PERL_CALLCONV void Perl_sv_setsv(pTHX_ SV *dstr, SV *sstr); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV void Perl_sv_setsv(pTHX_ SV *dstr, SV *sstr);
#define PERL_ARGS_ASSERT_SV_SETSV \
assert(dstr)
+#endif
PERL_CALLCONV void Perl_sv_setsv_flags(pTHX_ SV *dstr, SV *sstr, const I32 flags);
#define PERL_ARGS_ASSERT_SV_SETSV_FLAGS \
assert(dstr)
PERL_CALLCONV void Perl_sv_setuv_mg(pTHX_ SV *const sv, const UV u);
#define PERL_ARGS_ASSERT_SV_SETUV_MG \
assert(sv)
-/* PERL_CALLCONV void Perl_sv_taint(pTHX_ SV* sv); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV void Perl_sv_taint(pTHX_ SV* sv);
#define PERL_ARGS_ASSERT_SV_TAINT \
assert(sv)
+#endif
PERL_CALLCONV bool Perl_sv_tainted(pTHX_ SV *const sv)
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_SV_TAINTED \
PERL_CALLCONV int Perl_sv_unmagicext(pTHX_ SV *const sv, const int type, MGVTBL *vtbl);
#define PERL_ARGS_ASSERT_SV_UNMAGICEXT \
assert(sv)
-/* PERL_CALLCONV void Perl_sv_unref(pTHX_ SV* sv); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV void Perl_sv_unref(pTHX_ SV* sv);
#define PERL_ARGS_ASSERT_SV_UNREF \
assert(sv)
+#endif
PERL_CALLCONV void Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags);
#define PERL_ARGS_ASSERT_SV_UNREF_FLAGS \
assert(ref)
PERL_CALLCONV void Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type);
#define PERL_ARGS_ASSERT_SV_UPGRADE \
assert(sv)
-/* PERL_CALLCONV void Perl_sv_usepvn(pTHX_ SV* sv, char* ptr, STRLEN len); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV void Perl_sv_usepvn(pTHX_ SV* sv, char* ptr, STRLEN len);
#define PERL_ARGS_ASSERT_SV_USEPVN \
assert(sv)
+#endif
PERL_CALLCONV void Perl_sv_usepvn_flags(pTHX_ SV *const sv, char* ptr, const STRLEN len, const U32 flags);
#define PERL_ARGS_ASSERT_SV_USEPVN_FLAGS \
assert(sv)
-/* PERL_CALLCONV void Perl_sv_usepvn_mg(pTHX_ SV *sv, char *ptr, STRLEN len); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV void Perl_sv_usepvn_mg(pTHX_ SV *sv, char *ptr, STRLEN len);
#define PERL_ARGS_ASSERT_SV_USEPVN_MG \
assert(sv)
+#endif
PERL_CALLCONV bool Perl_sv_utf8_decode(pTHX_ SV *const sv);
#define PERL_ARGS_ASSERT_SV_UTF8_DECODE \
assert(sv)
PERL_CALLCONV void Perl_sv_utf8_encode(pTHX_ SV *const sv);
#define PERL_ARGS_ASSERT_SV_UTF8_ENCODE \
assert(sv)
-/* PERL_CALLCONV STRLEN Perl_sv_utf8_upgrade(pTHX_ SV *sv); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV STRLEN Perl_sv_utf8_upgrade(pTHX_ SV *sv);
#define PERL_ARGS_ASSERT_SV_UTF8_UPGRADE \
assert(sv)
+#endif
/* PERL_CALLCONV STRLEN Perl_sv_utf8_upgrade_flags(pTHX_ SV *const sv, const I32 flags); */
PERL_CALLCONV STRLEN Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra);
#define PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW \
#define PERL_ARGS_ASSERT_TO_UTF8_CASE \
assert(p); assert(ustrp); assert(swashp); assert(normal)
-/* PERL_CALLCONV UV Perl_to_utf8_fold(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV UV Perl_to_utf8_fold(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp);
#define PERL_ARGS_ASSERT_TO_UTF8_FOLD \
assert(p); assert(ustrp)
-/* PERL_CALLCONV UV Perl_to_utf8_lower(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp); */
+#endif
+#ifndef NO_MATHOMS
+PERL_CALLCONV UV Perl_to_utf8_lower(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp);
#define PERL_ARGS_ASSERT_TO_UTF8_LOWER \
assert(p); assert(ustrp)
-/* PERL_CALLCONV UV Perl_to_utf8_title(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp); */
+#endif
+#ifndef NO_MATHOMS
+PERL_CALLCONV UV Perl_to_utf8_title(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp);
#define PERL_ARGS_ASSERT_TO_UTF8_TITLE \
assert(p); assert(ustrp)
-/* PERL_CALLCONV UV Perl_to_utf8_upper(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp); */
+#endif
+#ifndef NO_MATHOMS
+PERL_CALLCONV UV Perl_to_utf8_upper(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp);
#define PERL_ARGS_ASSERT_TO_UTF8_UPPER \
assert(p); assert(ustrp)
+#endif
PERL_CALLCONV bool Perl_try_amagic_bin(pTHX_ int method, int flags);
PERL_CALLCONV bool Perl_try_amagic_un(pTHX_ int method, int flags);
PERL_CALLCONV I32 Perl_unpack_str(pTHX_ const char *pat, const char *patend, const char *s, const char *strbeg, const char *strend, char **new_s, I32 ocnt, U32 flags);
# endif
# endif
#endif
+#if !(defined(HAS_MEMMEM))
+PERL_CALLCONV char* Perl_ninstr(const char* big, const char* bigend, const char* little, const char* lend)
+ __attribute__pure__;
+#define PERL_ARGS_ASSERT_NINSTR \
+ assert(big); assert(bigend); assert(little); assert(lend)
+
+#endif
#if !(defined(HAS_SIGACTION) && defined(SA_SIGINFO))
PERL_CALLCONV Signal_t Perl_csighandler(int sig);
PERL_CALLCONV Signal_t Perl_sighandler(int sig);
#endif
-#if !(defined(NO_MATHOMS))
-PERL_CALLCONV void Perl_sv_nounlocking(pTHX_ SV *sv);
-#endif
#if !(defined(PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION))
PERL_CALLCONV bool Perl_do_exec(pTHX_ const char* cmd);
#define PERL_ARGS_ASSERT_DO_EXEC \
#define PERL_ARGS_ASSERT_DUMP_SV_CHILD \
assert(sv)
#endif
+#if defined(HAS_MEMMEM)
+PERL_CALLCONV char* Perl_ninstr(const char* big, const char* bigend, const char* little, const char* lend)
+ __attribute__pure__;
+#define PERL_ARGS_ASSERT_NINSTR \
+ assert(big); assert(bigend); assert(little); assert(lend)
+
+#endif
#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
PERL_CALLCONV I32 Perl_do_ipcctl(pTHX_ I32 optype, SV** mark, SV** sp);
#define PERL_ARGS_ASSERT_DO_IPCCTL \
assert(p)
#endif
-#if defined(NO_MATHOMS)
-/* PERL_CALLCONV void Perl_sv_nounlocking(pTHX_ SV *sv); */
-#endif
#if defined(PERL_ANY_COW)
PERL_CALLCONV SV* Perl_sv_setsv_cow(pTHX_ SV* dstr, SV* sstr);
#define PERL_ARGS_ASSERT_SV_SETSV_COW \
/* PERL_CALLCONV bool Perl_do_exec(pTHX_ const char* cmd); */
#endif
#if defined(PERL_DONT_CREATE_GVSV)
-/* PERL_CALLCONV GV* Perl_gv_SVadd(pTHX_ GV *gv); */
+#ifndef NO_MATHOMS
+PERL_CALLCONV GV* Perl_gv_SVadd(pTHX_ GV *gv);
+#endif
#endif
#if defined(PERL_GLOBAL_STRUCT)
PERL_CALLCONV struct perl_vars * Perl_GetVars(pTHX);
* 1a0687fb9c6c4567e853913549df0944fe40821279a3e9cdaa6ab8679bc286fd lib/unicore/extracted/DLineBreak.txt
* 40bcfed3ca727c19e1331f6c33806231d5f7eeeabd2e6a9e06a3740c85d0c250 lib/unicore/extracted/DNumType.txt
* a18d502bad39d527ac5586d7bc93e29f565859e3bcc24ada627eff606d6f5fed lib/unicore/extracted/DNumValues.txt
- * 285aef7ed2bf69724b1fa9bba177640636f666e1a5dd0ba5e538d4790129bbfe lib/unicore/mktables
+ * 718d6ea8b96ee3d12c9c3a48ceb0f5cebe023634002ac8b2ede12b306273aa52 lib/unicore/mktables
* 462c9aaa608fb2014cd9649af1c5c009485c60b9c8b15b89401fdc10cf6161c6 lib/unicore/version
* 913d2f93f3cb6cdf1664db888bf840bc4eb074eef824e082fceda24a9445e60c regen/charset_translations.pl
* d9c04ac46bdd81bb3e26519f2b8eb6242cb12337205add3f7cf092b0c58dccc4 regen/regcharclass.pl
#endif
bool seen_unfolded_sharp_s;
bool strict;
+ bool study_started;
};
#define RExC_flags (pRExC_state->flags)
#define RExC_frame_last (pRExC_state->frame_last)
#define RExC_frame_count (pRExC_state->frame_count)
#define RExC_strict (pRExC_state->strict)
+#define RExC_study_started (pRExC_state->study_started)
/* Heuristic check on the complexity of the pattern: if TOO_NAUGHTY, we set
* a flag to disable back-off on the fixed/floating substrings - if it's
GET_RE_DEBUG_FLAGS_DECL;
PERL_ARGS_ASSERT_STUDY_CHUNK;
+ RExC_study_started= 1;
if ( depth == 0 ) {
/* Else: zero-length, ignore. */
scan = regnext(scan);
}
- /* If we are exiting a recursion we can unset its recursed bit
- * and allow ourselves to enter it again - no danger of an
- * infinite loop there.
- if (stopparen > -1 && recursed) {
- DEBUG_STUDYDATA("unset:", data,depth);
- PAREN_UNSET( recursed, stopparen);
- }
- */
+
+ finish:
if (frame) {
+ /* we need to unwind recursion. */
depth = depth - 1;
DEBUG_STUDYDATA("frame-end:",data,depth);
goto fake_study_recurse;
}
- finish:
assert(!frame);
DEBUG_STUDYDATA("pre-fin:",data,depth);
RExC_contains_locale = 0;
RExC_contains_i = 0;
RExC_strict = cBOOL(pm_flags & RXf_PMf_STRICT);
+ RExC_study_started = 0;
pRExC_state->runtime_code_qr = NULL;
RExC_frame_head= NULL;
RExC_frame_last= NULL;
if (RExC_flags & RXf_PMf_FOLD) {
RExC_contains_i = 1;
}
- if (PASS2) {
- STD_PMMOD_FLAGS_PARSE_X_WARN(x_mod_count);
+
+ if (UNLIKELY((x_mod_count) > 1)) {
+ vFAIL("Only one /x regex modifier is allowed");
}
return;
/*NOTREACHED*/
} /* End of switch on '\' */
break;
case '{':
- /* Currently we don't warn when the lbrace is at the start
+ /* Currently we don't care if the lbrace is at the start
* of a construct. This catches it in the middle of a
* literal string, or when it's the first thing after
* something like "\b" */
- if (! SIZE_ONLY
- && (len || (p > RExC_start && isALPHA_A(*(p -1)))))
- {
- ckWARNregdep(p + 1, "Unescaped left brace in regex is deprecated, passed through");
+ if (len || (p > RExC_start && isALPHA_A(*(p -1)))) {
+ RExC_parse = p + 1;
+ vFAIL("Unescaped left brace in regex is illegal");
}
/*FALLTHROUGH*/
default: /* A literal character */
RExC_size += size;
return;
}
-
+ assert(!RExC_study_started); /* I believe we should never use reginsert once we have started
+ studying. If this is wrong then we need to adjust RExC_recurse
+ below like we do with RExC_open_parens/RExC_close_parens. */
src = RExC_emit;
RExC_emit += size;
dst = RExC_emit;
* iow it is 1 more than the number of parens seen in
* the pattern so far. */
for ( paren=0 ; paren < RExC_npar ; paren++ ) {
- if ( RExC_open_parens[paren] >= opnd ) {
+ /* 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 ) {
/*DEBUG_PARSE_FMT("open"," - %d",size);*/
RExC_open_parens[paren] += size;
} else {
my ($func, $flags) = @_;
return "S_$func" if $flags =~ /[si]/;
- return "Perl_$func" if $flags =~ /[bp]/;
+ return "Perl_$func" if $flags =~ /p/;
return $func;
}
}
my ($flags,$retval,$plain_func,@args) = @$_;
+ if ($flags =~ / ( [^AabDdEfiMmnOoPpRrsUXx] ) /x) {
+ warn "flag $1 is not legal (for function $plain_func)";
+ }
my @nonnull;
my $has_context = ( $flags !~ /n/ );
my $never_returns = ( $flags =~ /r/ );
- my $commented_out = ( $flags =~ /m/ );
my $binarycompat = ( $flags =~ /b/ );
+ my $commented_out = ( ! $binarycompat && $flags =~ /m/ );
my $is_malloc = ( $flags =~ /a/ );
my $can_ignore = ( $flags !~ /R/ ) && !$is_malloc;
my @names_of_nn;
}
}
$func = full_name($plain_func, $flags);
- $ret = "$retval\t$func(";
+ $ret = "";
+ $ret .= "#ifndef NO_MATHOMS\n" if $binarycompat;
+ $ret .= "$retval\t$func(";
if ( $has_context ) {
$ret .= @args ? "pTHX_ " : "pTHX";
}
$ret .= "\n#define PERL_ARGS_ASSERT_\U$plain_func\E\t\\\n\t"
. join '; ', map "assert($_)", @names_of_nn;
}
+ $ret .= "\n#endif" if $binarycompat;
$ret .= @attrs ? "\n\n" : "\n";
print $pr $ret;
unless ($flags =~ /[om]/) {
my $args = scalar @args;
if ($flags =~ /n/) {
- $ret = hide($func, full_name($func, $flags));
+ my $full_name = full_name($func, $flags);
+ next if $full_name eq $func; # Don't output a no-op.
+ $ret = hide($func, $full_name);
}
elsif ($args and $args[$args-1] =~ /\.\.\./) {
if ($flags =~ /p/) {
$ret .= "_ " if $alist;
$ret .= $alist . ")\n";
}
+ $ret = "#ifndef NO_MATHOMS\n$ret#endif\n" if $flags =~ /b/;
}
$lines .= $ret;
}
$args{$key} = $args;
}
-# Set up aliases
+# Set up aliases, and alternative funcs
-my %alias;
+my (%alias, %alts);
# Format is "this function" => "does these op names"
my @raw_alias = (
Perl_pp_shostent => [qw(snetent sprotoent sservent)],
Perl_pp_aelemfast => ['aelemfast_lex'],
Perl_pp_grepstart => ['mapstart'],
+
+ # 2 i_modulo mappings: 2nd is alt, needs 1st (explicit default) to not override the default
+ Perl_pp_i_modulo => ['i_modulo'],
+ Perl_pp_i_modulo_glibc_bugfix => {
+ 'i_modulo' =>
+ '#if defined(__GLIBC__) && IVSIZE == 8 '.
+ ' && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))' },
);
while (my ($func, $names) = splice @raw_alias, 0, 2) {
if (ref $names eq 'ARRAY') {
foreach (@$names) {
- $alias{$_} = [$func, ''];
+ defined $alias{$_}
+ ? $alts{$_} : $alias{$_} = [$func, ''];
}
} else {
while (my ($opname, $cond) = each %$names) {
- $alias{$opname} = [$func, $cond];
+ defined $alias{$opname}
+ ? $alts{$opname} : $alias{$opname} = [$func, $cond];
}
}
}
++$funcs{$name};
}
print $pp "PERL_CALLCONV OP *$_(pTHX);\n" foreach sort keys %funcs;
+
+ print $pp "\n/* alternative functions */\n" if keys %alts;
+ for my $fn (sort keys %alts) {
+ my ($x, $cond) = @{$alts{$fn}};
+ print $pp "$cond\n" if $cond;
+ print $pp "PERL_CALLCONV OP *$x(pTHX);\n";
+ print $pp "#endif\n" if $cond;
+ }
}
print $oc "\n\n";
unless ($version =~ /\b(1\.875[a-z]?|2\.[0134567]|3\.[0])\b/) { die <<EOF; }
You have the wrong version of bison in your path; currently versions
-1.875, 2.0-2.7 or 3.0 are known toi work. Try installing
+1.875, 2.0-2.7 or 3.0 are known to work. Try installing
http://ftp.gnu.org/gnu/bison/bison-2.5.1.tar.gz
or similar. Your bison identifies itself as:
yes_state = st->u.yes.prev_yes_state;
state_num = st->resume_state + 1; /* failure = success + 1 */
+ PERL_ASYNC_CHECK();
goto reenter_switch;
}
result = 0;
case XTENDED_PAT_MOD: *(pmfl) |= RXf_PMf_EXTENDED; (x_count)++; break;\
case NOCAPTURE_PAT_MOD: *(pmfl) |= RXf_PMf_NOCAPTURE; break;
-#define STD_PMMOD_FLAGS_PARSE_X_WARN(x_count) \
- if (UNLIKELY((x_count) > 1)) { \
- Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP), \
- "Having more than one /%c regexp modifier is deprecated", \
- XTENDED_PAT_MOD); \
- }
-
/* Note, includes charset ones, assumes 0 is the default for them */
#define STD_PMMOD_FLAGS_CLEAR(pmfl) \
*(pmfl) &= ~(RXf_PMf_FOLD|RXf_PMf_MULTILINE|RXf_PMf_SINGLELINE|RXf_PMf_EXTENDED|RXf_PMf_CHARSET|RXf_PMf_NOCAPTURE)
PERL_ARGS_ASSERT_SV_COLLXFRM_FLAGS;
mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
+
+ /* If we don't have collation magic on 'sv', or the locale has changed
+ * since the last time we calculated it, get it and save it now */
if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
const char *s;
char *xf;
STRLEN len, xlen;
+ /* Free the old space */
if (mg)
Safefree(mg->mg_ptr);
+
s = SvPV_flags_const(sv, len, flags);
if ((xf = mem_collxfrm(s, len, &xlen))) {
if (! mg) {
}
}
}
+
if (mg && mg->mg_ptr) {
*nxp = mg->mg_len;
return mg->mg_ptr + sizeof(PL_collation_ix);
if (!todo[(U8)*HeKEY(entry)])
continue;
gv = MUTABLE_GV(HeVAL(entry));
+ if (!isGV(gv))
+ continue;
sv = GvSV(gv);
if (sv && !SvREADONLY(sv)) {
SV_CHECK_THINKFIRST_COW_DROP(sv);
return FALSE;
}
+#ifndef NO_MATHOMS /* Can't move these to mathoms.c because call uiv_2buf(),
+ private to this file */
+
/*
=for apidoc sv_setpviv
SvSETMAGIC(sv);
}
+#endif /* NO_MATHOMS */
+
#if defined(PERL_IMPLICIT_CONTEXT)
/* pTHX_ magic can't cope with varargs, so this is a no-context
=for apidoc sv_vcatpvf
Processes its arguments like C<sv_catpvfn> called with a non-null C-style
-variable argument list, and appends the formatted
+variable argument list, and appends the formatted output
to an SV. Does not handle 'set' magic. See C<L</sv_vcatpvf_mg>>.
Usually used via its frontend C<sv_catpvf>.
#!./perl
-print "1..104\n";
+print "1..105\n";
$x = 'x';
eval ('qq{@{[0}*sub{]]}}}=sub{0' . "\c[");
print "ok $test - 125350\n"; $test++;
}
+
+{
+ # Used to crash [perl #128171]
+ eval ('/@0{0*->@*/*]');
+ print "ok $test - 128171\n"; $test++;
+}
my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0;
my $Is_UTF8 = (${^OPEN} || "") =~ /:utf8/;
-my $total_tests = 57;
+my $total_tests = 58;
if ($Is_EBCDIC || $Is_UTF8) { $total_tests -= 3; }
print "1..$total_tests\n";
eval q{return require bleah}; delete $INC{"bleah.pm"}; ++$::i;
$foo = eval {require bleah}; delete $INC{"bleah.pm"}; ++$::i;
@foo = eval {require bleah}; delete $INC{"bleah.pm"}; ++$::i;
- eval {require bleah};
+ eval {require bleah}; delete $INC{"bleah.pm"}; ++$::i;
+
+eval 'require ::bleah;';
+print "# $@\nnot " unless $@ =~ /^Bareword in require must not start with a double-colon:/;
+print "ok ", $i," - require ::bleah is banned\n";
# Test for fix of RT #24404 : "require $scalar" may load a directory
my $r = "threads";
use open qw( :utf8 :std );
use charnames ":alias" => { "NBSP SEPARATED SPACE" => "BLACK SMILING FACE" };
print "ok\n" if "\N{NBSP SEPARATED SPACE}" eq "\x{263B}";
-print "ok\n" if "\N{NBSP SEPARATED SPACE}" eq "\x{263B}";
-no warnings 'deprecated';
-print "ok\n" if "\N{NBSP SEPARATED SPACE}" eq "\x{263B}";
EXPECT
-OPTIONS regex
-NO-BREAK SPACE in a charnames alias definition is deprecated; marked by <-- HERE in 'NBSP SEPARATED <-- HERE SPACE' at - line \d+.
-ok
-ok
-ok
+OPTIONS regex fatal
+Invalid character in charnames alias definition; marked by <-- HERE in 'NBSP <-- HERE SEPARATED SPACE' at - line 3
# NAME keys BAREWORD
@a = keys FRED ;
EXPECT
-Type of arg 1 to keys must be hash (not constant item) at - line 1, near "FRED ;"
+Type of arg 1 to keys must be hash or array (not constant item) at - line 1, near "FRED ;"
Execution of - aborted due to compilation errors.
########
# NAME values BAREWORD
@a = values FRED ;
EXPECT
-Type of arg 1 to values must be hash (not constant item) at - line 1, near "FRED ;"
+Type of arg 1 to values must be hash or array (not constant item) at - line 1, near "FRED ;"
Execution of - aborted due to compilation errors.
########
# NAME each BAREWORD
@a = each FRED ;
EXPECT
-Type of arg 1 to each must be hash (not constant item) at - line 1, near "FRED ;"
+Type of arg 1 to each must be hash or array (not constant item) at - line 1, near "FRED ;"
Execution of - aborted due to compilation errors.
EXPECT
Bareword "CONST_TYPO" not allowed while "strict subs" in use at - line 5.
Execution of - aborted due to compilation errors.
+########
+# NAME constant-folded barewords still trigger stricture
+my $x = !BARE1;
+use strict 'subs';
+my $y = !BARE2;
+EXPECT
+Bareword "BARE2" not allowed while "strict subs" in use at - line 3.
+Execution of - aborted due to compilation errors.
no warnings 'reserved' ;
foo.bar;
EXPECT
-Useless use of concatenation (.) or string in void context at - line 3.
+Useless use of a constant ("foobar") in void context at - line 3.
########
--FILE-- abc
Use of uninitialized value $k in hash element at - line 12.
Use of uninitialized value $i in array element at - line 13.
Use of uninitialized value $k in hash element at - line 13.
+########
+# perl #127877
+use warnings 'uninitialized';
+my ($p, $q, $r, $s, $t, $u, $v, $w, $x, $y);
+$p = $p . "a";
+$q .= "a";
+$r = $r + 17;
+$s += 17;
+$t = $t - 17;
+$u -= 17;
+use integer;
+$v = $v + 17;
+$w += 17;
+$x = $x - 17;
+$y -= 17;
+EXPECT
+Use of uninitialized value $p in concatenation (.) or string at - line 4.
+Use of uninitialized value $r in addition (+) at - line 6.
+Use of uninitialized value $t in subtraction (-) at - line 8.
+Use of uninitialized value $v in integer addition (+) at - line 11.
+Use of uninitialized value $x in integer subtraction (-) at - line 13.
Array passed to stat will be coerced to a scalar (did you want stat $bar[0]?) at - line 9.
Array passed to stat will be coerced to a scalar at - line 10.
+########
+# NAME barewords and conditionals near constant folding
+use warnings;
+my $x1 = !a || !b; # no "in conditional" warnings
+my $x2 = !A || !B; # warning-free, because upper-case won't clash
+EXPECT
+Unquoted string "a" may clash with future reserved word at - line 2.
+Unquoted string "b" may clash with future reserved word at - line 2.
is "@a", 'a b c', 'assigning to itself';
}
+sub { undef *_; shift }->(); # This would crash; no ok() necessary.
+sub { undef *_; pop }->();
+
"We're included by lib/Tie/Array/std.t so we need to return something true";
*bar::is = *is;
*bar::like = *like;
}
-plan 151;
+plan 152;
# -------------------- Errors with feature disabled -------------------- #
{
state sub foo { 44 }
isnt \&::foo, \&foo, 'state sub is not stored in the package';
- is eval foo, 44, 'calling state sub from same package';
- is eval &foo, 44, 'calling state sub from same package (amper)';
+ is foo, 44, 'calling state sub from same package';
+ is &foo, 44, 'calling state sub from same package (amper)';
package bar;
- is eval foo, 44, 'calling state sub from another package';
- is eval &foo, 44, 'calling state sub from another package (amper)';
+ is foo, 44, 'calling state sub from another package';
+ is &foo, 44, 'calling state sub from another package (amper)';
}
package bar;
is foo, 43, 'state sub falling out of scope';
my sub x;
eval 'sub x {3}';
is x, 3, 'my sub defined inside eval';
+
+ my sub z;
+ BEGIN { eval 'sub z {4}' }
+ is z, 4, 'my sub defined in BEGIN { eval "..." }';
}
{
require './test.pl';
}
-plan tests => 17;
+plan tests => 23;
for my $i (undef, 0 .. 2, "", "0 but true") {
my $true = 1;
++$y;
$i = !$x && !$x && !$x && $y;
is( $i, 11, 'negation precedence with &&, multiple operands' );
+
+# [perl #127952]. This relates to OP_AND and OP_OR with a negated constant
+# on the lhs (either a negated bareword, or a negation of a do{} containing
+# a constant) and a negated non-foldable expression on the rhs. These cases
+# yielded 42 or "Bare" or "str" before the bug was fixed.
+{
+ $x = 42;
+
+ $i = !Bare || !$x;
+ is( $i, '', 'neg-bareword on lhs of || with non-foldable neg-true on rhs' );
+
+ $i = !Bare && !$x;
+ is( $i, '', 'neg-bareword on lhs of && with non-foldable neg-true on rhs' );
+
+ $i = do { !$x if !Bare };
+ is( $i, '', 'neg-bareword on rhs of modifier-if with non-foldable neg-true on lhs' );
+
+ $i = do { !$x unless !Bare };
+ is( $i, '', 'neg-bareword on rhs of modifier-unless with non-foldable neg-true on lhs' );
+
+ $i = !do { "str" } || !$x;
+ is( $i, '', 'neg-do-const on lhs of || with non-foldable neg-true on rhs' );
+
+ $i = !do { "str" } && !$x;
+ is( $i, '', 'neg-do-const on lhs of && with non-foldable neg-true on rhs' );
+}
use strict qw(refs subs);
-plan(115);
+plan(116);
{
no strict 'refs';
is "@{[foo->@*]}", "7 8 9", '->@* inside "@{...}"';
is "@{[foo->@[0,1]]}", "7 8", '->@[ inside "@{...}"';
is "@{[foo->@{foo}]}", "oof", '->@{ inside "@{...}"';
+
+ # "foo $_->$*" should be equivalent to "foo $$_", which uses concat
+ # overloading
+ package o {
+ use overload fallback=>1,
+ '""' => sub { $_[0][0] },
+ '.' => sub { bless [ "$_[$_[2]]"." plus "."$_[!$_[2]]" ] };
+ }
+ my $o = bless ["overload"], o::;
+ my $ref = \$o;
+ is "foo$ref->$*bar", "foo plus overload plus bar",
+ '"foo $s->$* bar" does concat overloading';
}
BEGIN {
chdir 't' if -d 't';
require './test.pl';
+ @INC="../lib";
}
use strict;
use warnings;
-plan(tests => 17);
+plan(tests => 20);
my $nonfile = tempfile();
eval "require $nonfile";
like $@, qr/^Can't locate $nonfile\.pm in \@INC \(you may need to install the $nonfile module\) \(\@INC contains: @INC\) at/,
- "correct error message for require $nonfile";
+ "correct error message for require $nonfile";
+
+eval "require ::$nonfile";
+
+like $@, qr/^Bareword in require must not start with a double-colon:/,
+ "correct error message for require ::$nonfile";
eval {
require "$nonfile.ph";
eval "require strict\0::invalid;";
like $@, qr/^syntax error at \(eval \d+\) line 1/, 'parse error with \0 in barewords module names';
+# Refs and globs that stringify with embedded nulls
+# These crashed from 5.20 to 5.24 [perl #128182].
+eval { no warnings 'syscalls'; require eval "qr/\0/" };
+like $@, qr/^Can't locate \(\?\^:\\0\):/,
+ 'require ref that stringifies with embedded null';
+eval { no strict; no warnings 'syscalls'; require *{"\0a"} };
+like $@, qr/^Can't locate \*main::\\0a:/,
+ 'require ref that stringifies with embedded null';
}
use strict;
-plan tests => 39;
+plan tests => 40;
package aiieee;
is $z, "*main::_", 'And the glob still has the right value';
}
+package _128106 {
+ # Crash on non-globs in the stash.
+ sub u; # stub without proto
+ sub v($); # proto stub
+ sub w{}; # as of 5.22, $::{w} == \&w
+ $::{x} = undef;
+ reset 'u-x';
+ ::ok (1, "no crash on non-globs in the stash");
+}
+
# This used to crash under threaded builds, because pmops were remembering
# their stashes by name, rather than by pointer.
fresh_perl_is( # it crashes more reliably with a smaller script
my $empty;
+sub set_errpat {
+ # Checking for a comma after the line number ensures that we are using
+ # yyerror for the error, rather than croak. yyerror is preferable for
+ # compile-time errors.
+ $errpat =
+ qr/Experimental $_[0] on scalar is now forbidden .* line 1,(?x:
+ ).*Type of arg 1 to $_[0] must be hash or array \(not /s;
+}
+
# Keys -- errors
-$errpat = qr/Experimental keys on scalar is now forbidden/;
+set_errpat 'keys';
eval "keys undef";
like($@, $errpat,
) or print "# Got: $@";
# Values -- errors
-$errpat = qr/Experimental values on scalar is now forbidden/;
+set_errpat 'values';
eval "values undef";
like($@, $errpat,
) or print "# Got: $@";
# Each -- errors
-$errpat = qr/Experimental each on scalar is now forbidden/;
+set_errpat 'each';
eval "each undef";
like($@, $errpat,
like($@, $errpat,
'Errors: each $hash, @stuff throws error'
) or print "# Got: $@";
-
-use feature 'refaliasing';
-my $a = 7;
-our %h;
-\$h{f} = \$a;
-($a, $b) = each %h;
-is "$a $b", "f 7", 'each %hash in list assignment';
-$a = 7;
-($a, $b) = (3, values %h);
-is "$a $b", "3 7", 'values %hash in list assignment';
-*a = sub { \@_ }->($a);
-$a = 7;
-($a, $b) = each our @a;
-is "$a $b", "0 7", 'each @array in list assignment';
-$a = 7;
-($a, $b) = (3, values @a);
-is "$a $b", "3 7", 'values @array in list assignment';
BEGIN { require "./test.pl"; }
-plan( tests => 51 );
+plan( tests => 52 );
# Used to segfault (bug #15479)
fresh_perl_like(
),
"ok\n",
'[perl #123847] no crash from *foo::=*bar::=*glob_with_hash';
+
+is runperl(
+ prog => '%h; *::::::=*h; delete $::{q|::|}; print qq|ok\n|',
+ stderr => 1,
+ ),
+ "ok\n",
+ '[perl #128086] no crash from assigning hash to *:::::: & deleting it';
use warnings;
use strict;
-plan 2249;
+plan 2250;
use B ();
multideref => 1,
},
);
+
+test_opcount(0, 'barewords can be constant-folded',
+ sub { no strict 'subs'; FOO . BAR },
+ {
+ concat => 0,
+ });
ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/t/vstrings.t 90035a2bdbf45f15b9c3196d072d7cba7e662871
File::Path cpan/File-Path/lib/File/Path.pm fd8ce4420a0c113d3f47dd3223859743655c1da8
File::Path cpan/File-Path/t/Path_win32.t 94b9276557ce7f80b91f6fd9bfa7a0cd9bf9683e
-IPC::SysV cpan/IPC-SysV/lib/IPC/Msg.pm 88865a2c7a06351cf10e08addd077bbdea02fb60
-IPC::SysV cpan/IPC-SysV/lib/IPC/Semaphore.pm 04f0d11b7d0babf8e41ccc917cccecc4a3ff9050
-IPC::SysV cpan/IPC-SysV/lib/IPC/SharedMem.pm 85dea09a5bb625fc1fdda433909633fda05ea831
-IPC::SysV cpan/IPC-SysV/lib/IPC/SysV.pm 9a0d1c3dcd67321ef1322f29102a1bc7eb91c61c
-IPC::SysV cpan/IPC-SysV/t/ipcsysv.t ee2c95e846ea201afe13c9ec53b09cef62c8ac68
Math::BigRat cpan/Math-BigRat/lib/Math/BigRat.pm 6eabc68e04f67694f6fe523e64eb013fc337ca5b
Pod::Perldoc cpan/Pod-Perldoc/lib/Pod/Perldoc.pm fe0bc906fb74b69cfd3fb289316ba669d770d465
-Scalar-List-Utils cpan/Scalar-List-Utils/lib/List/Util.pm 3b501b7332480b34929bc4df5d48581df3307267
-Scalar-List-Utils cpan/Scalar-List-Utils/lib/List/Util/XS.pm ebd169113d3df79d31ad5535dbd7a538a8c14fd2
-Scalar-List-Utils cpan/Scalar-List-Utils/lib/Scalar/Util.pm def601405bac7a4d6690b8c4207e0f05d65eb4ca
-Scalar-List-Utils cpan/Scalar-List-Utils/lib/Sub/Util.pm 1187d6cd9bccf1264bd53b3a65ea96fad7520068
-Scalar-List-Utils cpan/Scalar-List-Utils/ListUtil.xs 6128584ecb0ae69bb21b16b22daceeffc92df9d9
-Scalar-List-Utils cpan/Scalar-List-Utils/t/product.t 99bf424804f055b99ff2a18b7dcf25bb8b6d2463
+Scalar-List-Utils cpan/Scalar-List-Utils/lib/List/Util.pm e479a29c6b66ac5cbbde4ef2296afaab6c4635a6
+Scalar-List-Utils cpan/Scalar-List-Utils/lib/List/Util/XS.pm cbc38838d32fd213ae7b37ac38e30195355be3b9
+Scalar-List-Utils cpan/Scalar-List-Utils/lib/Scalar/Util.pm 14a20075dfb9a4ef33b99115ed6f43e6d1a15f9b
+Scalar-List-Utils cpan/Scalar-List-Utils/lib/Sub/Util.pm b984c0a2935bd5f5cf1733df846c8a8c0661ef32
+Scalar-List-Utils cpan/Scalar-List-Utils/ListUtil.xs 362a247c65878265fd8acae607b207400628ef3b
Socket cpan/Socket/Socket.pm 98e38176d745c38282907f391c077298f5a3d0ba
Socket cpan/Socket/Socket.xs edd4fed212785f11c5c2095a75941dad27d586d9
autodie cpan/autodie/t/mkdir.t 9e70d2282a3cc7d76a78bf8144fccba20fb37dac
skip_all_without_unicode_tables();
}
-plan tests => 789; # Update this when adding/deleting tests.
+plan tests => 790; # Update this when adding/deleting tests.
run_tests() unless caller;
fresh_perl_is($code, $expect, {}, "$bug - $test_name" );
}
}
+ {
+ fresh_perl_is('
+ BEGIN{require q(test.pl);}
+ watchdog(3);
+ $SIG{ALRM} = sub {print "Timeout\n"; exit(1)};
+ alarm 1;
+ $_ = "a" x 1000 . "b" x 1000 . "c" x 1000;
+ /.*a.*b.*c.*[de]/;
+ ',"Timeout",{},"Test Perl 73464")
+ }
} # End of sub run_tests
1;
. "SPACE";
my $NBSP_utf8 = $NBSP_Latin1;
utf8::upgrade($NBSP_utf8);
- eval qq[is("\\N{$NBSP_Latin1}", "$NBSP_Latin1", "An NBSP in character name works")];
- like ($w, qr/NO-BREAK SPACE in a charnames alias definition is deprecated/, "... but returns a deprecation warning");
+ () = eval qq[is("\\N{$NBSP_Latin1}", "$NBSP_Latin1"];
+ like ($@, qr/Invalid character in \\N\{...}/, "A NO-BREAK SPACE in a charnames alias is fatal");
undef $w;
{
use feature 'unicode_eval';
- eval qq[use utf8; is("\\N{$NBSP_utf8}", "$NBSP_utf8", "Same under 'use utf8': they work")];
- like ($w, qr/NO-BREAK SPACE in a charnames alias definition is deprecated/, "... but return a deprecation warning");
- }
- {
- # disable lexical warnings
- BEGIN { ${^WARNING_BITS} = undef; $^W = 0 }
- undef $w;
- () = eval qq["\\N{$NBSP_Latin1}"];
- like ($w, qr/NO-BREAK SPACE in a charnames alias definition is deprecated/, "And returns a deprecation warning outside of lexical warnings");
- undef $w;
- use feature 'unicode_eval';
- eval qq[use utf8; () = "\\N{$NBSP_utf8}"];
- like ($w, qr/NO-BREAK SPACE in a charnames alias definition is deprecated/, "... same under utf8");
- }
- {
- no warnings 'deprecated';
- undef $w;
- eval qq["\\N{$NBSP_Latin1}"];
- ok (! defined $w, "... and no warning if warnings are off");
- use feature 'unicode_eval';
- eval qq[use utf8; "\\N{$NBSP_utf8}"];
- ok (! defined $w, "... same under 'use utf8'");
- }
- {
- use warnings FATAL=>'deprecated';
- () = eval qq["\\N{$NBSP_Latin1}"];
- like ($@, qr/NO-BREAK SPACE in a charnames alias definition is deprecated/, "... the warning can be fatal");
- use feature 'unicode_eval';
- eval qq[use utf8; () = "\\N{$NBSP_utf8}"];
- like ($@, qr/NO-BREAK SPACE in a charnames alias definition is deprecated/, "... same under utf8");
+ eval qq[use utf8; is("\\N{$NBSP_utf8}"];
+ like ($@, qr/Invalid character in \\N\{...}/, "A NO-BREAK SPACE in a charnames alias is fatal");
}
{
}
{
- # \, breaks {3,4}
- no warnings qw{deprecated regexp};
- ok "xaaay" !~ /xa{3\,4}y/, '\, in a pattern';
- ok "xa{3,4}y" =~ /xa{3\,4}y/, '\, in a pattern';
-
# \c\ followed by _
ok "x\c_y" !~ /x\c\_y/, '\_ in a pattern';
ok "x\c\_y" =~ /x\c\_y/, '\_ in a pattern';
'/(?[\ |!])/' => 'Incomplete expression within \'(?[ ])\' {#} m/(?[\ |!{#}])/', # [perl #126180]
'/(?[()-!])/' => 'Incomplete expression within \'(?[ ])\' {#} m/(?[()-!{#}])/', # [perl #126204]
'/(?[!()])/' => 'Incomplete expression within \'(?[ ])\' {#} m/(?[!(){#}])/', # [perl #126404]
+ '/\w{/' => 'Unescaped left brace in regex is illegal {#} m/\w{{#}/',
+ '/\q{/' => 'Unescaped left brace in regex is illegal {#} m/\q{{#}/',
+ '/:{4,a}/' => 'Unescaped left brace in regex is illegal {#} m/:{{#}4,a}/',
+ '/xa{3\,4}y/' => 'Unescaped left brace in regex is illegal {#} m/xa{{#}3\,4}y/',
+ '/abc/xix' => 'Only one /x regex modifier is allowed',
+ '/(?xmsixp:abc)/' => 'Only one /x regex modifier is allowed {#} m/(?xmsixp{#}:abc)/',
+ '/(?xmsixp)abc/' => 'Only one /x regex modifier is allowed {#} m/(?xmsixp{#})abc/',
+ '/(?xxxx:abc)/' => 'Only one /x regex modifier is allowed {#} m/(?xxxx{#}:abc)/',
+
);
# These are messages that are warnings when not strict; death under 'use re
);
my @deprecated = (
- '/\w{/' => 'Unescaped left brace in regex is deprecated, passed through {#} m/\w{{#}/',
- '/\q{/' => [
- 'Unrecognized escape \q{ passed through {#} m/\q{{#}/',
- 'Unescaped left brace in regex is deprecated, passed through {#} m/\q{{#}/'
- ],
- '/:{4,a}/' => 'Unescaped left brace in regex is deprecated, passed through {#} m/:{{#}4,a}/',
- '/abc/xix' => 'Having more than one /x regexp modifier is deprecated',
- '/(?xmsixp:abc)/' => 'Having more than one /x regexp modifier is deprecated',
- '/(?xmsixp)abc/' => 'Having more than one /x regexp modifier is deprecated',
- '/(?xxxx:abc)/' => 'Having more than one /x regexp modifier is deprecated',
);
for my $strict ("", "use re 'strict';") {
# NOTE:
#
-# It's best to not features found only in more modern Perls here, as some cpan
-# distributions copy this file and operate on older Perls. Similarly keep
-# things simple as this may be run under fairly broken circumstances. For
+# Do not rely on features found only in more modern Perls here, as some CPAN
+# distributions copy this file and must operate on older Perls. Similarly, keep
+# things, simple as this may be run under fairly broken circumstances. For
# example, increment ($x++) has a certain amount of cleverness for things like
#
# $x = 'zz';
return defined $x ? '"' . display ($x) . '"' : 'undef';
};
+# Support pre-5.10 Perls, for the benefit of CPAN dists that copy this file.
+# Note that chr(90) exists in both ASCII ("Z") and EBCDIC ("!").
+my $chars_template = defined(eval { pack "W*", 90 }) ? "W*" : "U*";
+eval 'sub re::is_regexp { ref($_[0]) eq "Regexp" }'
+ if !defined &re::is_regexp;
+
# keys are the codes \n etc map to, values are 2 char strings such as \n
my %backslash_escape;
foreach my $x (split //, 'nrtfa\\\'"') {
foreach my $x (@_) {
if (defined $x and not ref $x) {
my $y = '';
- foreach my $c (unpack("W*", $x)) {
+ foreach my $c (unpack($chars_template, $x)) {
if ($c > 255) {
$y = $y . sprintf "\\x{%x}", $c;
} elsif ($backslash_escape{$c}) {
else {
$name = sprintf "\\x%02x, a C1 control", $ord;
}
- $syntax_error = $::IS_EBCDIC;
+ $syntax_error = 1;
$deprecated = ! $syntax_error;
}
elsif ($chr =~ /\p{XIDStart}/) {
}
elsif ($chr =~ /\p{XPosixSpace}/) {
$name = sprintf "\\x%02x, a non-ASCII space character", $ord;
- $syntax_error = $::IS_EBCDIC;
+ $syntax_error = 1;
$deprecated = ! $syntax_error;
}
else {
#define PL_lex_brackstack (PL_parser->lex_brackstack)
#define PL_lex_casemods (PL_parser->lex_casemods)
#define PL_lex_casestack (PL_parser->lex_casestack)
-#define PL_lex_defer (PL_parser->lex_defer)
#define PL_lex_dojoin (PL_parser->lex_dojoin)
#define PL_lex_formbrack (PL_parser->lex_formbrack)
#define PL_lex_inpat (PL_parser->lex_inpat)
string or after \E, $foo, etc */
#define LEX_INTERPCONST 2 /* NOT USED */
#define LEX_FORMLINE 1 /* expecting a format line */
-#define LEX_KNOWNEXT 0 /* next token known; just return it */
#ifdef DEBUGGING
assert(PL_nexttoke < C_ARRAY_LENGTH(PL_nexttype));
PL_nexttype[PL_nexttoke] = type;
PL_nexttoke++;
- if (PL_lex_state != LEX_KNOWNEXT) {
- PL_lex_defer = PL_lex_state;
- PL_lex_state = LEX_KNOWNEXT;
- }
}
/*
S_postderef(pTHX_ int const funny, char const next)
{
assert(funny == DOLSHARP || strchr("$@%&*", funny));
- assert(strchr("*[{", next));
if (next == '*') {
PL_expect = XOPERATOR;
if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
assert('@' == funny || '$' == funny || DOLSHARP == funny);
PL_lex_state = LEX_INTERPEND;
- force_next(POSTJOIN);
+ if ('@' == funny)
+ force_next(POSTJOIN);
}
force_next(next);
PL_bufptr+=2;
SAVEI32(PL_lex_casemods);
SAVEI32(PL_lex_starts);
SAVEI8(PL_lex_state);
- SAVEI8(PL_lex_defer);
SAVESPTR(PL_lex_repl);
SAVEVPTR(PL_lex_inpat);
SAVEI16(PL_lex_inwhat);
if (*s == ' ' && *(s-1) == ' ') {
goto multi_spaces;
}
- if ((U8) *s == NBSP_NATIVE && ckWARN_d(WARN_DEPRECATED)) {
- Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
- "NO-BREAK SPACE in a charnames "
- "alias definition is deprecated");
- }
s++;
}
}
{
goto bad_charname;
}
- if (*s == *NBSP_UTF8
- && *(s+1) == *(NBSP_UTF8+1)
- && ckWARN_d(WARN_DEPRECATED))
- {
- Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
- "NO-BREAK SPACE in a charnames "
- "alias definition is deprecated");
- }
s += 2;
}
else {
if (PL_nexttoke) {
PL_nexttoke--;
pl_yylval = PL_nextval[PL_nexttoke];
- if (!PL_nexttoke) {
- PL_lex_state = PL_lex_defer;
- PL_lex_defer = LEX_NORMAL;
- }
{
I32 next_type;
next_type = PL_nexttype[PL_nexttoke];
/* FALLTHROUGH */
case LEX_INTERPEND:
- /* Treat state as LEX_NORMAL if we have no inner lexing scope.
- XXX This hack can be removed if we stop setting PL_lex_state to
- LEX_KNOWNEXT, as can the hack under LEX_INTREPCONCAT below. */
- if (UNLIKELY(!PL_lex_inwhat)) {
- PL_lex_state = LEX_NORMAL;
- break;
- }
-
if (PL_lex_dojoin) {
const U8 dojoin_was = PL_lex_dojoin;
PL_lex_dojoin = FALSE;
Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
(long) PL_lex_brackets);
#endif
- /* Treat state as LEX_NORMAL when not in an inner lexing scope.
- XXX This hack can be removed if we stop setting PL_lex_state to
- LEX_KNOWNEXT. */
- if (UNLIKELY(!PL_lex_inwhat)) {
- PL_lex_state = LEX_NORMAL;
- break;
- }
-
if (PL_bufptr == PL_bufend)
return REPORT(sublex_done());
* 2) '{'
* The final case currently doesn't get this far in the program, so we
* don't test for it. If that were to change, it would be ok to allow it.
- * c) When not under Unicode rules, any upper Latin1 character
- * d) Otherwise, when unicode rules are used, all XIDS characters.
+ * b) When not under Unicode rules, any upper Latin1 character
+ * c) Otherwise, when unicode rules are used, all XIDS characters.
*
* Because all ASCII characters have the same representation whether
* encoded in UTF-8 or not, we can use the foo_A macros below and '\0' and
- * '{' without knowing if is UTF-8 or not.
- * EBCDIC already uses the rules that ASCII platforms will use after the
- * deprecation cycle; see comment below about the deprecation. */
-#ifdef EBCDIC
-# define VALID_LEN_ONE_IDENT(s, is_utf8) \
+ * '{' without knowing if is UTF-8 or not. */
+#define VALID_LEN_ONE_IDENT(s, is_utf8) \
(isGRAPH_A(*(s)) || ((is_utf8) \
? isIDFIRST_utf8((U8*) (s)) \
: (isGRAPH_L1(*s) \
&& LIKELY((U8) *(s) != LATIN1_TO_NATIVE(0xAD)))))
-#else
-# define VALID_LEN_ONE_IDENT(s, is_utf8) \
- (isGRAPH_A(*(s)) || ((is_utf8) \
- ? isIDFIRST_utf8((U8*) (s)) \
- : ! isASCII_utf8((U8*) (s))))
-#endif
STATIC char *
S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
: 1)
&& VALID_LEN_ONE_IDENT(s, is_utf8))
{
- /* Deprecate all non-graphic characters. Include SHY as a non-graphic,
- * because often it has no graphic representation. (We can't get to
- * here with SHY when 'is_utf8' is true, so no need to include a UTF-8
- * test for it.) */
- if ((is_utf8)
- ? ! isGRAPH_utf8( (U8*) s)
- : (! isGRAPH_L1( (U8) *s)
- || UNLIKELY((U8) *(s) == LATIN1_TO_NATIVE(0xAD))))
- {
- deprecate("literal non-graphic characters in variable names");
- }
-
if (is_utf8) {
const STRLEN skip = UTF8SKIP(s);
STRLEN i;
"Use of /c modifier is meaningless without /g" );
}
- STD_PMMOD_FLAGS_PARSE_X_WARN(x_mod_count);
+ if (UNLIKELY((x_mod_count) > 1)) {
+ yyerror("Only one /x regex modifier is allowed");
+ }
PL_lex_op = (OP*)pm;
pl_yylval.ival = OP_MATCH;
}
}
- STD_PMMOD_FLAGS_PARSE_X_WARN(x_mod_count);
+ if (UNLIKELY((x_mod_count) > 1)) {
+ yyerror("Only one /x regex modifier is allowed");
+ }
if ((pm->op_pmflags & PMf_CONTINUE)) {
Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
else if (yychar > 255)
sv_catpvs(where_sv, "next token ???");
else if (yychar == YYEMPTY) {
- if ( PL_lex_state == LEX_NORMAL
- || (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
+ 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");
{
if (flags & ~PARSE_OPTIONAL)
Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
- if (PL_lex_state == LEX_KNOWNEXT) {
+ if (PL_nexttoke) {
PL_parser->yychar = yylex();
if (PL_parser->yychar == LABEL) {
char * const lpv = pl_yylval.pval;
return (char *)from;
}
-/* return ptr to little string in big string, NULL if not found */
-/* This routine was donated by Corey Satten. */
-
-char *
-Perl_instr(const char *big, const char *little)
-{
-
- PERL_ARGS_ASSERT_INSTR;
-
- return strstr((char*)big, (char*)little);
-}
-
/*
=head1 Miscellaneous Functions
Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
{
PERL_ARGS_ASSERT_NINSTR;
+
+#ifdef HAS_MEMMEM
+ return ninstr(big, bigend, little, lend);
+#else
+
if (little >= lend)
return (char*)big;
{
}
}
return NULL;
+
+#endif
+
}
/*
# define HS_CXT cv
#endif
+#define instr(haystack, needle) strstr(haystack, needle)
+
+#ifdef HAS_MEMMEM
+# define ninstr(big, bigend, little, lend) \
+ ((char *) memmem(big, bigend - big, little, lend - little))
+#endif
+
/*
* ex: set ts=8 sts=4 sw=4 et:
*/
$::HaveTemp = ($@ eq "");
eval { require Module::CoreList; };
$::HaveCoreList = ($@ eq "");
+ eval { require Text::Wrap; };
+ $::HaveWrap = ($@ eq "");
};
my $Version = "1.40";
%opt, $have_attachment, $attachments, $has_patch, $mime_boundary
);
+my $running_noninteractively = !-t STDIN;
+
my $perl_version = $^V ? sprintf("%vd", $^V) : $];
my $config_tag2 = "$perl_version - $Config{cf_time}";
if ($opt{h}) { Help(); exit; }
if ($opt{d}) { Dump(*STDOUT); exit; }
-if (!-t STDIN && !($ok and not $opt{n})) {
+if ($running_noninteractively && !$opt{t} && !($ok and not $opt{n})) {
paraprint <<"EOF";
Please use $progname interactively. If you want to
include a file, you can use the -f switch.
$ed = $entry unless $entry eq '';
}
- _edit_file($ed);
+ _edit_file($ed) unless $running_noninteractively;
}
sub _edit_file {
EOF
retry:
print $menu;
- my $action = _prompt('', "Action (Send/Display/Edit/Subject/Save to File)");;
+ my $action = _prompt('', "Action (Send/Display/Edit/Subject/Save to File)",
+ $opt{t} ? 'q' : '');
print "\n";
if ($action =~ /^(f|sa)/i) { # <F>ile/<Sa>ve
if ( SaveMessage() ) { exit }
} elsif ($action =~ /^(d|l|sh)/i ) { # <D>isplay, <L>ist, <Sh>ow
# Display the message
- open(REP, '<:raw', $filename) or die "Couldn't open file '$filename': $!\n";
- binmode(REP, ':raw :crlf') if $Is_MSWin32;
- while (<REP>) { print $_ }
- close(REP) or die "Error closing report file '$filename': $!";
+ print _read_report($filename);
if ($have_attachment) {
print "\n\n---\nAttachment(s):\n";
for my $att (split /\s*,\s*/, $attachments) { print " $att\n"; }
if ($subject =~
/^(y(es)?|no?|help|perl( (bug|problem))?|bug|problem)$/i ||
length($subject) < 4 ||
- $subject !~ /\s/) {
+ ($subject !~ /\s/ && ! $opt{t})) { # non-whitespace is accepted in test mode
print "\nThe subject you entered wasn't very descriptive. Please try again.\n\n";
return 1;
} else {
}
print $prompt. ($default ? " [$default]" :''). ": ";
my $result = scalar(<>);
+ return $default if !defined $result; # got eof
chomp($result);
$result =~ s/^\s*(.*?)\s*$/$1/s;
if ($default && $result eq '') {
return $attach;
}
+sub _read_report {
+ my $fname = shift;
+ my $content;
+ open( REP, "<:raw", $fname ) or die "Couldn't open file '$fname': $!\n";
+ binmode(REP, ':raw :crlf') if $Is_MSWin32;
+ # wrap long lines to make sure the report gets delivered
+ local $Text::Wrap::columns = 900;
+ local $Text::Wrap::huge = 'overflow';
+ while (<REP>) {
+ if ($::HaveWrap && /\S/) { # wrap() would remove empty lines
+ $content .= Text::Wrap::wrap(undef, undef, $_);
+ } else {
+ $content .= $_;
+ }
+ }
+ close(REP) or die "Error closing report file '$fname': $!";
+ return $content;
+}
+
sub build_complete_message {
my $content = _build_header(%{_message_headers()}) . "\n\n";
$content .= _add_body_start() if $have_attachment;
- open( REP, "<:raw", $filename ) or die "Couldn't open file '$filename': $!\n";
- binmode(REP, ':raw :crlf') if $Is_MSWin32;
- while (<REP>) { $content .= $_; }
- close(REP) or die "Error closing report file '$filename': $!";
+ $content .= _read_report($filename);
$content .= _add_attachments() if $have_attachment;
return $content;
}
$fh = $msg->open;
binmode($fh, ':raw');
print $fh _add_body_start() if $have_attachment;
- open(REP, "<:raw", $filename) or die "Couldn't open '$filename': $!\n";
- binmode(REP, ':raw :crlf') if $Is_MSWin32;
- while (<REP>) { print $fh $_ }
- close(REP) or die "Error closing $filename: $!";
+ print $fh _read_report($filename);
print $fh _add_attachments() if $have_attachment;
$fh->close or die "Error sending mail: $!";
=item B<-t>
Test mode. The target address defaults to B<perlbug-test@perl.org>.
+Also makes it possible to command perlbug from a pipe or file, for
+testing purposes.
=item B<-T>
extra.pods : miniperl
@ @extra_pods.com
-PERLDELTA_CURRENT = [.pod]perl5250delta.pod
+PERLDELTA_CURRENT = [.pod]perl5251delta.pod
$(PERLDELTA_CURRENT) : [.pod]perldelta.pod
Copy/NoConfirm/Log $(MMS$SOURCE) $(PERLDELTA_CURRENT)
# versioned installation can be obtained by setting INST_TOP above to a
# path that includes an arbitrary version string.
#
-#INST_VER := \5.25.0
+#INST_VER := \5.25.1
#
# Comment this out if you DON'T want your perl installation to have
copy ..\README.tw ..\pod\perltw.pod
copy ..\README.vos ..\pod\perlvos.pod
copy ..\README.win32 ..\pod\perlwin32.pod
- copy ..\pod\perldelta.pod ..\pod\perl5250delta.pod
+ copy ..\pod\perldelta.pod ..\pod\perl5251delta.pod
$(MINIPERL) -I..\lib $(PL2BAT) $(UTILS)
$(MINIPERL) -I..\lib ..\autodoc.pl ..
$(MINIPERL) -I..\lib ..\pod\perlmodlib.PL -q ..
-if exist $(LIBDIR)\TAP rmdir /s /q $(LIBDIR)\TAP
-if exist $(LIBDIR)\Term rmdir /s /q $(LIBDIR)\Term
-if exist $(LIBDIR)\Test rmdir /s /q $(LIBDIR)\Test
+ -if exist $(LIBDIR)\Test2 rmdir /s /q $(LIBDIR)\Test
-if exist $(LIBDIR)\Text rmdir /s /q $(LIBDIR)\Text
-if exist $(LIBDIR)\Thread rmdir /s /q $(LIBDIR)\Thread
-if exist $(LIBDIR)\threads rmdir /s /q $(LIBDIR)\threads
-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 \
- perl5250delta.pod perlaix.pod perlamiga.pod perlandroid.pod \
+ perl5251delta.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.0
+#INST_VER = \5.25.1
#
# Comment this out if you DON'T want your perl installation to have
copy ..\README.tw ..\pod\perltw.pod
copy ..\README.vos ..\pod\perlvos.pod
copy ..\README.win32 ..\pod\perlwin32.pod
- copy ..\pod\perldelta.pod ..\pod\perl5250delta.pod
+ copy ..\pod\perldelta.pod ..\pod\perl5251delta.pod
cd ..\win32
$(PERLEXE) $(PL2BAT) $(UTILS)
$(MINIPERL) -I..\lib ..\autodoc.pl ..
-if exist $(LIBDIR)\TAP rmdir /s /q $(LIBDIR)\TAP
-if exist $(LIBDIR)\Term rmdir /s /q $(LIBDIR)\Term
-if exist $(LIBDIR)\Test rmdir /s /q $(LIBDIR)\Test
+ -if exist $(LIBDIR)\Test2 rmdir /s /q $(LIBDIR)\Test2
-if exist $(LIBDIR)\Text rmdir /s /q $(LIBDIR)\Text
-if exist $(LIBDIR)\Thread rmdir /s /q $(LIBDIR)\Thread
-if exist $(LIBDIR)\threads rmdir /s /q $(LIBDIR)\threads
-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 \
- perl5250delta.pod perlaix.pod perlamiga.pod perlandroid.pod \
+ perl5251delta.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.0
+#INST_VER *= \5.25.1
#
# Comment this out if you DON'T want your perl installation to have
copy ..\README.tw ..\pod\perltw.pod
copy ..\README.vos ..\pod\perlvos.pod
copy ..\README.win32 ..\pod\perlwin32.pod
- copy ..\pod\perldelta.pod ..\pod\perl5250delta.pod
+ copy ..\pod\perldelta.pod ..\pod\perl5251delta.pod
$(MINIPERL) -I..\lib $(PL2BAT) $(UTILS)
$(MINIPERL) -I..\lib ..\autodoc.pl ..
$(MINIPERL) -I..\lib ..\pod\perlmodlib.PL -q ..
-if exist $(LIBDIR)\TAP rmdir /s /q $(LIBDIR)\TAP
-if exist $(LIBDIR)\Term rmdir /s /q $(LIBDIR)\Term
-if exist $(LIBDIR)\Test rmdir /s /q $(LIBDIR)\Test
+ -if exist $(LIBDIR)\Test2 rmdir /s /q $(LIBDIR)\Test2
-if exist $(LIBDIR)\Text rmdir /s /q $(LIBDIR)\Text
-if exist $(LIBDIR)\Thread rmdir /s /q $(LIBDIR)\Thread
-if exist $(LIBDIR)\threads rmdir /s /q $(LIBDIR)\threads
-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 \
- perl5250delta.pod perlaix.pod perlamiga.pod perlandroid.pod \
+ perl5251delta.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 \
perl5222delta.pod \
perl5240delta.pod \
perl5250delta.pod \
+ perl5251delta.pod \
perl561delta.pod \
perl56delta.pod \
perl581delta.pod \
perl5222delta.man \
perl5240delta.man \
perl5250delta.man \
+ perl5251delta.man \
perl561delta.man \
perl56delta.man \
perl581delta.man \
perl5222delta.html \
perl5240delta.html \
perl5250delta.html \
+ perl5251delta.html \
perl561delta.html \
perl56delta.html \
perl581delta.html \
perl5222delta.tex \
perl5240delta.tex \
perl5250delta.tex \
+ perl5251delta.tex \
perl561delta.tex \
perl56delta.tex \
perl581delta.tex \
projects / platform / upstream / perl.git / commitdiff