Mikhail Zabaluev <mhz@alt-linux.org>
Milosz Tanski <mtanski@gridapp.com>
Milton L. Hankins <mlh@swl.msd.ray.com>
+Misty De Meo <mistydemeo@github.com>
Moritz Lenz <moritz@casella.verplant.org>
Moshe Kaminsky <kaminsky@math.huji.ac.il>
Mottaqui Karim <taqqui.karim@gmail.com>
d_duplocale=''
d_freelocale=''
d_newlocale=''
+d_querylocale=''
d_uselocale=''
i_xlocale=''
d_nextafter=''
d_strerror=''
d_sysernlst=''
d_syserrlst=''
+d_strerror_l=''
d_strerror_r=''
strerror_r_proto=''
d_strftime=''
set duplocale d_duplocale
eval $inlibc
+: see if querylocale exists
+set querylocale d_querylocale
+eval $inlibc
+
: see if frexpl exists
set frexpl d_frexpl
eval $inlibc
fi
fi
+: see if strerror_l exists
+set strerror_l d_strerror_l
+eval $inlibc
+
: see if strerror_r exists
set strerror_r d_strerror_r
eval $inlibc
d_pwquota='$d_pwquota'
d_qgcvt='$d_qgcvt'
d_quad='$d_quad'
+d_querylocale='$d_querylocale'
d_random_r='$d_random_r'
d_re_comp='$d_re_comp'
d_readdir64_r='$d_readdir64_r'
d_strctcpy='$d_strctcpy'
d_strerrm='$d_strerrm'
d_strerror='$d_strerror'
+d_strerror_l='$d_strerror_l'
d_strerror_r='$d_strerror_r'
d_strftime='$d_strftime'
d_strlcat='$d_strlcat'
: Finish up by extracting the .SH files
case "$alldone" in
exit)
- $rm -rf UU
- echo "Extraction done."
+ echo "Stopping at your request, leaving temporary files around."
exit 0
;;
cont)
EOM
fi
-if $test -f config.msg; then
+if $test -f UU/config.msg; then
echo "Hmm. I also noted the following information while running:"
echo " "
- $cat config.msg >&4
- $rm -f config.msg
+ $cat UU/config.msg >&4
fi
$rm -f kit*isdone ark*isdone
$rm -rf UU
ansi2knr=''
aphostname='/bin/hostname'
api_revision='5'
-api_subversion='1'
+api_subversion='2'
api_version='25'
-api_versionstring='5.25.1'
+api_versionstring='5.25.2'
ar='ar'
-archlib='/usr/lib/perl5/5.25.1/armv4l-linux'
-archlibexp='/usr/lib/perl5/5.25.1/armv4l-linux'
+archlib='/usr/lib/perl5/5.25.2/armv4l-linux'
+archlibexp='/usr/lib/perl5/5.25.2/armv4l-linux'
archname64=''
archname='armv4l-linux'
archobjs=''
cat='cat'
cc='cc'
cccdlflags='-fpic'
-ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.25.1/armv4l-linux/CORE'
+ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.25.2/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'
d_pwquota='undef'
d_qgcvt='define'
d_quad='define'
+d_querylocale='undef'
d_random_r='undef'
d_readdir64_r='undef'
d_readdir='define'
d_strctcpy='define'
d_strerrm='strerror(e)'
d_strerror='define'
+d_strerror_l='undef'
d_strerror_r='undef'
d_strftime='define'
d_strlcat='undef'
inc_version_list_init='0'
incpath=''
inews=''
-installarchlib='./install_me_here/usr/lib/perl5/5.25.1/armv4l-linux'
+installarchlib='./install_me_here/usr/lib/perl5/5.25.2/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.1'
+installprivlib='./install_me_here/usr/lib/perl5/5.25.2'
installscript='./install_me_here/usr/bin'
-installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.25.1/armv4l-linux'
+installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.25.2/armv4l-linux'
installsitebin='./install_me_here/usr/bin'
installsitehtml1dir=''
installsitehtml3dir=''
-installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.25.1'
+installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.25.2'
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.1'
-privlibexp='/usr/lib/perl5/5.25.1'
+privlib='/usr/lib/perl5/5.25.2'
+privlibexp='/usr/lib/perl5/5.25.2'
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.1/armv4l-linux'
-sitearchexp='/usr/lib/perl5/site_perl/5.25.1/armv4l-linux'
+sitearch='/usr/lib/perl5/site_perl/5.25.2/armv4l-linux'
+sitearchexp='/usr/lib/perl5/site_perl/5.25.2/armv4l-linux'
sitebin='/usr/bin'
sitebinexp='/usr/bin'
sitehtml1dir=''
sitehtml1direxp=''
sitehtml3dir=''
sitehtml3direxp=''
-sitelib='/usr/lib/perl5/site_perl/5.25.1'
+sitelib='/usr/lib/perl5/site_perl/5.25.2'
sitelib_stem='/usr/lib/perl5/site_perl'
-sitelibexp='/usr/lib/perl5/site_perl/5.25.1'
+sitelibexp='/usr/lib/perl5/site_perl/5.25.2'
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='1'
+subversion='2'
sysman='/usr/share/man/man1'
tail=''
tar=''
vendorprefixexp=''
vendorscript=''
vendorscriptexp=''
-version='5.25.1'
-version_patchlevel_string='version 25 subversion 1'
+version='5.25.2'
+version_patchlevel_string='version 25 subversion 2'
versiononly='undef'
vi=''
xlibpth='/usr/lib/386 /lib/386'
config_argc=0
PERL_REVISION=5
PERL_VERSION=25
-PERL_SUBVERSION=1
+PERL_SUBVERSION=2
PERL_API_REVISION=5
PERL_API_VERSION=25
-PERL_API_SUBVERSION=1
+PERL_API_SUBVERSION=2
PERL_PATCHLEVEL=
PERL_CONFIG_SH=true
ansi2knr=''
aphostname='/bin/hostname'
api_revision='5'
-api_subversion='1'
+api_subversion='2'
api_version='25'
-api_versionstring='5.25.1'
+api_versionstring='5.25.2'
ar='ar'
-archlib='/usr/lib/perl5/5.25.1/armv4l-linux'
-archlibexp='/usr/lib/perl5/5.25.1/armv4l-linux'
+archlib='/usr/lib/perl5/5.25.2/armv4l-linux'
+archlibexp='/usr/lib/perl5/5.25.2/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.1/armv4l-linux/CORE'
+ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.25.2/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.1/armv4l-linux'
+installarchlib='./install_me_here/usr/lib/perl5/5.25.2/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.1'
+installprivlib='./install_me_here/usr/lib/perl5/5.25.2'
installscript='./install_me_here/usr/bin'
-installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.25.1/armv4l-linux'
+installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.25.2/armv4l-linux'
installsitebin='./install_me_here/usr/bin'
installsitehtml1dir=''
installsitehtml3dir=''
-installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.25.1'
+installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.25.2'
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.1'
-privlibexp='/usr/lib/perl5/5.25.1'
+privlib='/usr/lib/perl5/5.25.2'
+privlibexp='/usr/lib/perl5/5.25.2'
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.1/armv4l-linux'
-sitearchexp='/usr/lib/perl5/site_perl/5.25.1/armv4l-linux'
+sitearch='/usr/lib/perl5/site_perl/5.25.2/armv4l-linux'
+sitearchexp='/usr/lib/perl5/site_perl/5.25.2/armv4l-linux'
sitebin='/usr/bin'
sitebinexp='/usr/bin'
sitehtml1dir=''
sitehtml1direxp=''
sitehtml3dir=''
sitehtml3direxp=''
-sitelib='/usr/lib/perl5/site_perl/5.25.1'
+sitelib='/usr/lib/perl5/site_perl/5.25.2'
sitelib_stem='/usr/lib/perl5/site_perl'
-sitelibexp='/usr/lib/perl5/site_perl/5.25.1'
+sitelibexp='/usr/lib/perl5/site_perl/5.25.2'
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='1'
+subversion='2'
sysman='/usr/share/man/man1'
tail=''
tar=''
vendorprefixexp=''
vendorscript=''
vendorscriptexp=''
-version='5.25.1'
-version_patchlevel_string='version 25 subversion 1'
+version='5.25.2'
+version_patchlevel_string='version 25 subversion 2'
versiononly='undef'
vi=''
xlibpth='/usr/lib/386 /lib/386'
config_argc=0
PERL_REVISION=5
PERL_VERSION=25
-PERL_SUBVERSION=1
+PERL_SUBVERSION=2
PERL_API_REVISION=5
PERL_API_VERSION=25
-PERL_API_SUBVERSION=1
+PERL_API_SUBVERSION=2
PERL_PATCHLEVEL=
PERL_CONFIG_SH=true
=item Directories for the perl distribution
-By default, Configure will use the following directories for 5.25.1.
+By default, Configure will use the following directories for 5.25.2.
$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
information about your perl, which may help us track down problems far
more quickly. But first you should read the advice in this file,
carefully re-read the error message and check the relevant manual pages
-on your system, as these may help you find an immediate solution. If
-you are not sure whether what you are seeing is a bug, you can send a
-message describing the problem to the comp.lang.perl.misc newsgroup to
-get advice.
+on your system, as these may help you find an immediate solution.
+Once you've exhausted the documentation, please report bugs to us using
+the 'perlbug' tool.
The perlbug tool is installed along with perl, so after you have
completed C<make install> it should be possible to run it with plain
=head1 Coexistence with earlier versions of perl 5
-Perl 5.25.1 is not binary compatible with earlier versions of Perl.
+Perl 5.25.2 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.1
+ sh Configure -Dprefix=/opt/perl5.25.2
-and adding /opt/perl5.25.1/bin to the shell PATH variable. Such users
+and adding /opt/perl5.25.2/bin to the shell PATH variable. Such users
may also wish to add a symbolic link /usr/local/bin/perl so that
scripts can still start with #!/usr/local/bin/perl.
subversions may not have all the compatibility wrinkles ironed out
yet.
-=head2 Upgrading from v5.22 or earlier
+=head2 Upgrading from 5.25.1 or earlier
-B<Perl 5.25.1 may not be binary compatible with Perl v5.22 or
+B<Perl 5.25.2 may not be binary compatible with Perl 5.25.1 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.1. If you find you do need to rebuild an extension with
-5.25.1, you may safely do so without disturbing the older
+used with 5.25.2. If you find you do need to rebuild an extension with
+5.25.2, 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.1 is as follows (under $Config{prefix}):
+in Linux with perl-5.25.2 is as follows (under $Config{prefix}):
./bin/perl
- ./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
+ ./lib/perl5/5.25.2/strict.pm
+ ./lib/perl5/5.25.2/warnings.pm
+ ./lib/perl5/5.25.2/i686-linux/File/Glob.pm
+ ./lib/perl5/5.25.2/feature.pm
+ ./lib/perl5/5.25.2/XSLoader.pm
+ ./lib/perl5/5.25.2/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/ExtUtils-MakeMaker/lib/ExtUtils/testlib.pm Fixes up @INC to use just-built extension
cpan/ExtUtils-MakeMaker/t/00compile.t See if MakeMaker modules compile
cpan/ExtUtils-MakeMaker/t/01perl_bugs.t
+cpan/ExtUtils-MakeMaker/t/02-xsdynamic.t
+cpan/ExtUtils-MakeMaker/t/03-xsstatic.t
cpan/ExtUtils-MakeMaker/t/arch_check.t Test MakeMaker's arch_check()
cpan/ExtUtils-MakeMaker/t/backwards.t Check MakeMaker's backwards compatibility
cpan/ExtUtils-MakeMaker/t/basic.t See if MakeMaker can build a module
cpan/ExtUtils-MakeMaker/t/Liblist.t See if ExtUtils::Liblist works
cpan/ExtUtils-MakeMaker/t/lib/MakeMaker/Test/NoXS.pm MakeMaker test utilities
cpan/ExtUtils-MakeMaker/t/lib/MakeMaker/Test/Setup/BFD.pm MakeMaker test utilities
-cpan/ExtUtils-MakeMaker/t/lib/MakeMaker/Test/Setup/MPV.pm MakeMaker test utilities
-cpan/ExtUtils-MakeMaker/t/lib/MakeMaker/Test/Setup/PL_FILES.pm MakeMaker test utilities
-cpan/ExtUtils-MakeMaker/t/lib/MakeMaker/Test/Setup/Problem.pm MakeMaker test utilities
-cpan/ExtUtils-MakeMaker/t/lib/MakeMaker/Test/Setup/Recurs.pm MakeMaker test utilities
-cpan/ExtUtils-MakeMaker/t/lib/MakeMaker/Test/Setup/SAS.pm MakeMaker test utilities
-cpan/ExtUtils-MakeMaker/t/lib/MakeMaker/Test/Setup/Unicode.pm
cpan/ExtUtils-MakeMaker/t/lib/MakeMaker/Test/Setup/XS.pm MakeMaker test utilities
cpan/ExtUtils-MakeMaker/t/lib/MakeMaker/Test/Utils.pm MakeMaker test utilities
cpan/ExtUtils-MakeMaker/t/lib/TieIn.pm Testing library for dummy input handles
cpan/ExtUtils-MakeMaker/t/vstrings.t
cpan/ExtUtils-MakeMaker/t/WriteEmptyMakefile.t See if WriteEmptyMakefile works
cpan/ExtUtils-MakeMaker/t/writemakefile_args.t See if WriteMakefile works
-cpan/ExtUtils-MakeMaker/t/xs.t Part of MakeMaker's test suite
cpan/ExtUtils-Manifest/lib/ExtUtils/Manifest.pm Utilities to write MANIFEST files
cpan/ExtUtils-Manifest/lib/ExtUtils/MANIFEST.SKIP The default MANIFEST.SKIP
cpan/ExtUtils-Manifest/t/Manifest.t See if ExtUtils::Manifest works
cpan/HTTP-Tiny/corpus/get-19.txt
cpan/HTTP-Tiny/corpus/get-20.txt
cpan/HTTP-Tiny/corpus/get-21.txt
+cpan/HTTP-Tiny/corpus/get-22.txt
cpan/HTTP-Tiny/corpus/head-01.txt
cpan/HTTP-Tiny/corpus/keepalive-01.txt
cpan/HTTP-Tiny/corpus/keepalive-02.txt
cpan/Pod-Checker/t/pod/empty.xr
cpan/Pod-Checker/t/pod/podchkenc.t
cpan/Pod-Checker/t/pod/podchkenc.xr
+cpan/Pod-Checker/t/pod/podchklink.t
cpan/Pod-Checker/t/pod/poderrs.t
cpan/Pod-Checker/t/pod/poderrs.xr
cpan/Pod-Checker/t/pod/selfcheck.t
cpan/Pod-Simple/t/x_nixer.t Pod::Simple test file
cpan/Pod-Usage/lib/Pod/Usage.pm
cpan/Pod-Usage/scripts/pod2usage.PL
+cpan/Pod-Usage/t/inc/Pod/InputObjects.pm
+cpan/Pod-Usage/t/inc/Pod/Parser.pm
+cpan/Pod-Usage/t/inc/Pod/PlainText.pm
+cpan/Pod-Usage/t/inc/Pod/Select.pm
cpan/Pod-Usage/t/pod/headwithmarkup.pl
cpan/Pod-Usage/t/pod/headwithmarkup.t
cpan/Pod-Usage/t/pod/p2u_data.pl
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/Generic.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/Test/Tester.pm
cpan/Test-Simple/lib/Test/Tutorial.pod
cpan/Test-Simple/lib/Test/use/ok.pm
-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/lib/Test/Simple/sample_tests/two_fail.plx
cpan/Test-Simple/t/lib/TieOut.pm
cpan/Test-Simple/t/regression/642_persistent_end.t
+cpan/Test-Simple/t/regression/662-tbt-no-plan.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/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/Generic.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
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/perl5251delta.pod Perl changes in version 5.25.1
pod/perl561delta.pod Perl changes in version 5.6.1
pod/perl56delta.pod Perl changes in version 5.6
pod/perl581delta.pod Perl changes in version 5.8.1
t/run/switchC.t Test the -C switch
t/run/switchd-78586.t See whether bug 78586 is fixed
t/run/switchd.t Test the -d switch
+t/run/switchDx.t Test the -D switch
t/run/switches.t Tests for the other switches (-0, -l, -c, -s, -M, -m, -V, -v, -h, -z, -i)
t/run/switchF1.t Pathological tests for the -F switch
t/run/switchF2.t Pathological tests for the -F switch
"url" : "http://perl5.git.perl.org/"
}
},
- "version" : "5.025001",
- "x_serialization_backend" : "JSON::PP version 2.27300"
+ "version" : "5.025002",
+ "x_serialization_backend" : "JSON::PP version 2.27400"
}
homepage: http://www.perl.org/
license: http://dev.perl.org/licenses/
repository: http://perl5.git.perl.org/
-version: '5.025001'
+version: '5.025002'
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/perl5251delta.pod pod/perlapi.pod pod/perlintern.pod pod/perlmodlib.pod pod/perluniprops.pod
+perltoc_pod_prereqs = extra.pods pod/perl5252delta.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
$spitshell >>$Makefile <<!GROK!THIS!
utils/Makefile: \$(MINIPERL_EXE) \$(CONFIGPM) utils/Makefile.PL
- \$(MINIPERL) -Ilib utils/Makefile.PL
+ \$(MINIPERL) utils/Makefile.PL
utilities: utils/Makefile $util_deps
@echo " "; echo " Making utilities"; cd utils; \$(LDLIBPTH) \$(MAKE) all
amigaos*)
$spitshell >>$Makefile <<'!NO!SUBS!'
perlmain.c: $(MINIPERL_EXE) ext/ExtUtils-Miniperl/pm_to_blib
- $(MINIPERL) -Ilib -MExtUtils::Miniperl -e 'writemain(\\"perlmain.c", @ARGV)' DynaLoader $(static_ext)
+ $(MINIPERL) -MExtUtils::Miniperl -e 'writemain(\\"perlmain.c", @ARGV)' DynaLoader $(static_ext)
# The file ext.libs is a list of libraries that must be linked in
# for static extensions, e.g. -lm -lgdbm, etc. The individual
*)
$spitshell >>$Makefile <<'!NO!SUBS!'
perlmain.c: $(MINIPERL_EXE) ext/ExtUtils-Miniperl/pm_to_blib
- $(MINIPERL) -Ilib -MExtUtils::Miniperl -e 'writemain(\"perlmain.c", @ARGV)' DynaLoader $(static_ext)
+ $(MINIPERL) -MExtUtils::Miniperl -e 'writemain(\"perlmain.c", @ARGV)' DynaLoader $(static_ext)
# The file ext.libs is a list of libraries that must be linked in
# for static extensions, e.g. -lm -lgdbm, etc. The individual
pod/perlmodlib.pod: $(MINIPERL_EXE) pod/perlmodlib.PL MANIFEST
$(MINIPERL) pod/perlmodlib.PL -q
-pod/perl5251delta.pod: pod/perldelta.pod
- $(RMS) pod/perl5251delta.pod
- $(LNS) perldelta.pod pod/perl5251delta.pod
+pod/perl5252delta.pod: pod/perldelta.pod
+ $(RMS) pod/perl5252delta.pod
+ $(LNS) perldelta.pod pod/perl5252delta.pod
extra.pods: $(MINIPERL_EXE)
-@test ! -f extra.pods || rm -f `cat extra.pods`
# Here comes the CW tools - TO BE FILLED TO BUILD WITH CW -
-MODULE_DESC = "Perl 5.25.1 for NetWare"
+MODULE_DESC = "Perl 5.25.2 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.1
+INST_VER = \5.25.2
#
# Comment this out if you DON'T want your perl installation to have
d_pwquota='undef'
d_qgcvt='undef'
d_quad='undef'
+d_querylocale='undef'
d_random_r='undef'
d_readdir64_r='undef'
d_readdir='define'
d_strctcpy='define'
d_strerrm='strerror(e)'
d_strerror='define'
+d_strerror_l='undef'
d_strerror_r='undef'
d_strftime='define'
d_strlcat='undef'
* 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.1\\lib\\NetWare-x86-multi-thread" /**/
+#define ARCHLIB "c:\\perl\\5.25.2\\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.1\\bin\\NetWare-x86-multi-thread" /**/
-#define BIN_EXP "c:\\perl\\5.25.1\\bin\\NetWare-x86-multi-thread" /**/
+#define BIN "c:\\perl\\5.25.2\\bin\\NetWare-x86-multi-thread" /**/
+#define BIN_EXP "c:\\perl\\5.25.2\\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.1\\lib\\NetWare-x86-multi-thread" /**/
+#define SITEARCH "c:\\perl\\site\\5.25.2\\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.1\\lib" /**/
+#define SITELIB "c:\\perl\\site\\5.25.2\\lib" /**/
/*#define SITELIB_EXP "" /**/
#define SITELIB_STEM "" /**/
},
'CPAN' => {
- 'DISTRIBUTION' => 'ANDK/CPAN-2.10.tar.gz',
+ 'DISTRIBUTION' => 'ANDK/CPAN-2.14-TRIAL.tar.gz',
'FILES' => q[cpan/CPAN],
'EXCLUDED' => [
qr{^distroprefs/},
t/yaml_code.yml
),
],
- # See commit 3198fda65dbcd975c56916e4b98f515fab7f02e5
- 'CUSTOMIZED' => [ qw[ lib/CPAN.pm ] ],
},
# Note: When updating CPAN-Meta the META.* files will need to be regenerated
'DISTRIBUTION' => 'DANKOGAI/Encode-2.80.tar.gz',
'FILES' => q[cpan/Encode],
CUSTOMIZED => [
- qw( encoding.pm
- ),
+ qw( encoding.pm ),
+ 'Byte/Makefile.PL',
],
},
},
'ExtUtils::MakeMaker' => {
- 'DISTRIBUTION' => 'BINGOS/ExtUtils-MakeMaker-7.10.tar.gz',
+ 'DISTRIBUTION' => 'BINGOS/ExtUtils-MakeMaker-7.18.tar.gz',
'FILES' => q[cpan/ExtUtils-MakeMaker],
'EXCLUDED' => [
qr{^t/lib/Test/},
'README.packaging',
'lib/ExtUtils/MakeMaker/version/vpp.pm',
],
- # Upstreamed as https://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker/commit/ede9ea4a
- 'CUSTOMIZED' => [
- qq[lib/ExtUtils/MakeMaker.pm],
- qq[t/prereq.t],
- qq[t/vstrings.t],
- # Upstreamed as https://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker/commit/dd1e236ab
- qq[lib/ExtUtils/MM_VMS.pm],
- # Not yet submitted
- qq[t/lib/MakeMaker/Test/NoXS.pm],
- # Backported commits from upstream
- qw(lib/ExtUtils/Command/MM.pm
- lib/ExtUtils/Liblist.pm
- lib/ExtUtils/Liblist/Kid.pm
- lib/ExtUtils/MM.pm
- lib/ExtUtils/MM_AIX.pm
- lib/ExtUtils/MM_Any.pm
- lib/ExtUtils/MM_BeOS.pm
- lib/ExtUtils/MM_Cygwin.pm
- lib/ExtUtils/MM_DOS.pm
- lib/ExtUtils/MM_Darwin.pm
- lib/ExtUtils/MM_MacOS.pm
- lib/ExtUtils/MM_NW5.pm
- lib/ExtUtils/MM_OS2.pm
- lib/ExtUtils/MM_QNX.pm
- lib/ExtUtils/MM_UWIN.pm
- lib/ExtUtils/MM_Unix.pm
- lib/ExtUtils/MM_VOS.pm
- lib/ExtUtils/MM_Win32.pm
- lib/ExtUtils/MM_Win95.pm
- lib/ExtUtils/MY.pm
- lib/ExtUtils/MakeMaker/Config.pm
- lib/ExtUtils/MakeMaker/FAQ.pod
- lib/ExtUtils/MakeMaker/Tutorial.pod
- lib/ExtUtils/MakeMaker/version.pm
- lib/ExtUtils/MakeMaker/version/regex.pm
- lib/ExtUtils/Mkbootstrap.pm
- lib/ExtUtils/Mksymlists.pm
- lib/ExtUtils/testlib.pm
- t/cd.t
- t/echo.t
- ),
- ],
+ 'CUSTOMIZED' => [ qw( t/basic.t ) ],
},
'ExtUtils::Manifest' => {
},
'Getopt::Long' => {
- 'DISTRIBUTION' => 'JV/Getopt-Long-2.48.tar.gz',
+ 'DISTRIBUTION' => 'JV/Getopt-Long-2.49.tar.gz',
'FILES' => q[cpan/Getopt-Long],
'EXCLUDED' => [
qr{^examples/},
},
'HTTP::Tiny' => {
- 'DISTRIBUTION' => 'DAGOLDEN/HTTP-Tiny-0.056.tar.gz',
+ 'DISTRIBUTION' => 'DAGOLDEN/HTTP-Tiny-0.058.tar.gz',
'FILES' => q[cpan/HTTP-Tiny],
'EXCLUDED' => [
't/00-report-prereqs.t',
},
'JSON::PP' => {
- 'DISTRIBUTION' => 'MAKAMAKA/JSON-PP-2.27300.tar.gz',
+ 'DISTRIBUTION' => 'MAKAMAKA/JSON-PP-2.27400.tar.gz',
'FILES' => q[cpan/JSON-PP],
},
},
'Locale-Codes' => {
- 'DISTRIBUTION' => 'SBECK/Locale-Codes-3.38.tar.gz',
+ 'DISTRIBUTION' => 'SBECK/Locale-Codes-3.39.tar.gz',
'FILES' => q[cpan/Locale-Codes],
'EXCLUDED' => [
qw( README.first
},
'Module::CoreList' => {
- 'DISTRIBUTION' => 'BINGOS/Module-CoreList-5.20160507.tar.gz',
+ 'DISTRIBUTION' => 'BINGOS/Module-CoreList-5.20160520.tar.gz',
'FILES' => q[dist/Module-CoreList],
},
},
'Pod::Checker' => {
- 'DISTRIBUTION' => 'MAREKR/Pod-Checker-1.60.tar.gz',
+ 'DISTRIBUTION' => 'MAREKR/Pod-Checker-1.73.tar.gz',
'FILES' => q[cpan/Pod-Checker],
},
},
'Pod::Usage' => {
- 'DISTRIBUTION' => 'MAREKR/Pod-Usage-1.68.tar.gz',
+ 'DISTRIBUTION' => 'MAREKR/Pod-Usage-1.69.tar.gz',
'FILES' => q[cpan/Pod-Usage],
},
},
'Test::Simple' => {
- 'DISTRIBUTION' => 'EXODIST/Test-Simple-1.001014.tar.gz',
+ 'DISTRIBUTION' => 'EXODIST/Test-Simple-1.302026.tar.gz',
'FILES' => q[cpan/Test-Simple],
'EXCLUDED' => [
qr{^t/xt},
qr{^xt},
qw( .perlcriticrc
.perltidyrc
+ perltidyrc
+ dist.ini
examples/indent.pl
examples/subtest.t
+ examples/tools.t
+ examples/tools.t
t/00compile.t
t/xxx-changes_updated.t
+ t/00-report.t
+ t/zzz-check-breaks.t
),
],
},
# correct for this (and Thread::Semaphore, threads, and threads::shared)
# to be under dist/ rather than cpan/
'Thread::Queue' => {
- 'DISTRIBUTION' => 'JDHEDDEN/Thread-Queue-3.09.tar.gz',
+ 'DISTRIBUTION' => 'JDHEDDEN/Thread-Queue-3.11.tar.gz',
'FILES' => q[dist/Thread-Queue],
'EXCLUDED' => [
qr{^examples/},
},
'threads' => {
- 'DISTRIBUTION' => 'JDHEDDEN/threads-2.08.tar.gz',
+ 'DISTRIBUTION' => 'JDHEDDEN/threads-2.09.tar.gz',
'FILES' => q[dist/threads],
'EXCLUDED' => [
qr{^examples/},
# Basic: run the tests in t/perf/benchmarks against two or
# more perls
- bench.pl [options] perl1[=label1] perl2[=label2] ...
+ bench.pl [options] -- perlA[=labelA] perlB[=labelB] ...
+
+ # run the tests against same perlA 2x, with and without extra
+ # options
+
+ bench.pl [options] -- perlA=fast PerlA=slow -Mstrict -Dpsltoc
# Run bench.pl's own built-in sanity tests
--grindargs=I<foo>
-Optional command-line arguments to pass to cachegrind invocations.
+Optional command-line arguments to pass to all cachegrind invocations.
+
+This option is appended to those which bench.pl uses for its own
+purposes; so it can be used to override them (see --debug output
+below), and can also be 'abused' to add redirects into the valgrind
+command invocation.
+
+For example, this writes PERL_MEM_LOG activity to foobar.$$, because
+3>foobar.$$ redirects fd 3, then perl under PERL_MEM_LOG writes to fd 3.
+
+ $ perl Porting/bench.pl --jobs=2 --verbose --debug \
+ --tests=call::sub::amp_empty \
+ \
+ --grindargs='--cachegrind-out-file=junk.$$ 3>foobar.$$' \
+ -- \
+ perl5.24.0 perl5.24.0:+memlog:PERL_MEM_LOG=3mst
+
+for the +memlog tests, this executes as: (shown via --debug, then prettyfied)
+
+ Command: PERL_HASH_SEED=0 PERL_MEM_LOG=3mst
+ valgrind --tool=cachegrind --branch-sim=yes
+ --cachegrind-out-file=/dev/null --cachegrind-out-file=junk.$$
+ 3>foobar.$$ perl5.24.0 - 10 2>&1
+
+The result is that a set of junk.$$ files containing raw cachegrind
+output are written, and foobar.$$ contains the expected memlog output.
+
+Notes:
+
+Theres no obvious utility for those junk.$$ and foobar.$$ files, but
+you can have them anyway.
+
+The 3 in PERL_MEM_LOG=3mst is needed because the output would
+otherwize go to STDERR, and cause parse_cachegrind() to reject the
+test and die.
+
+The --grindargs redirect is needed to capture the memlog output;
+without it, the memlog output is written to fd3, around
+parse_cachegrind and effectively into /dev/null
+
+PERL_MEM_LOG is expensive when used.
+
+call::sub::amp_empty
+&foo function call with no args or body
+
+ perl5.24.0 perl5.24.0+memlog
+ ---------- -----------------
+ Ir 394.0 543477.5
+ Dr 161.0 146814.1
+ Dw 72.0 122304.6
+ COND 58.0 66796.4
+ IND 5.0 5537.7
+
+COND_m 0.0 6743.1
+ IND_m 5.0 1490.2
+
+ Ir_m1 0.0 683.7
+ Dr_m1 0.0 65.9
+ Dw_m1 0.0 8.5
+
+ Ir_mm 0.0 11.6
+ Dr_mm 0.0 10.6
+ Dw_mm 0.0 4.7
+
=item *
--perlargs=I<foo>
-Optional command-line arguments to pass to each perl that is run as part of
-a cachegrind session. For example, C<--perlargs=-Ilib>.
+Optional command-line arguments to pass to each perl-under-test
+(perlA, perlB in synopsis) For example, C<--perlargs=-Ilib>.
=item *
use 5.010000;
use warnings;
use strict;
-use Getopt::Long qw(:config no_auto_abbrev);
+use Getopt::Long qw(:config no_auto_abbrev require_order);
use IPC::Open2 ();
use IO::Select;
use IO::File;
sub usage {
die <<EOF;
-usage: $0 [options] perl[=label] ...
+usage: $0 [options] -- perl[=label] ...
--action=foo What action to perform [default: grind].
--average Only display average, not individual test results.
--benchfile=foo File containing the benchmarks;
else {
my %t;
for (split /,/, $opt) {
- die "Error: no such test found: '$_'\n" unless exists $tests->{$_};
+ die "Error: no such test found: '$_'\n"
+ . ($OPTS{verbose} ? " have: @{[ sort keys %$tests ]}\n" : "")
+ unless exists $tests->{$_};
$t{$_} = 1;
}
for (keys %$tests) {
}
-# Validate the list of perl=label on the command line.
-# Return a list of [ exe, label ] pairs.
+# Validate the list of perl=label (+ cmdline options) on the command line.
+# Return a list of [ exe, label, cmdline-options ] tuples, ie PUTs
+
+sub process_puts {
+ my @res_puts; # returned, each item is [ perlexe, label, @putargs ]
+ my %seen;
+ my @putargs; # collect not-perls into args per PUT
+
+ for my $p (reverse @_) {
+ push @putargs, $p and next if $p =~ /^-/; # not-perl, dont send to qx//
-sub process_perls {
- my @results;
- for my $p (@_) {
- my ($perl, $label) = split /=/, $p, 2;
+ my ($perl, $label, $env) = split /[=:,]/, $p, 3;
$label //= $perl;
+ $label = $perl.$label if $label =~ /^\+/;
+ die "$label cannot be used on 2 different PUTs\n" if $seen{$label}++;
+
+ my %env;
+ if ($env) {
+ %env = split /[=,]/, $env;
+ }
my $r = qx($perl -e 'print qq(ok\n)' 2>&1);
- die "Error: unable to execute '$perl': $r" if $r ne "ok\n";
- push @results, [ $perl, $label ];
+ if ($r eq "ok\n") {
+ push @res_puts, [ $perl, $label, \%env, reverse @putargs ];
+ @putargs = ();
+ warn "Added Perl-Under-Test: [ @{[@{$res_puts[-1]}]} ]\n"
+ if $OPTS{verbose};
+ } else {
+ warn "PUT-args: @putargs + a not-perl: $p $r\n"
+ if $OPTS{verbose};
+ push @putargs, $p; # not-perl
+ }
}
- return @results;
+ return reverse @res_puts;
}
die "Error: only a single test may be specified with --bisect\n"
if defined $OPTS{bisect} and keys %$tests != 1;
- $perls = [ process_perls(@$perl_args) ];
+ $perls = [ process_puts(@$perl_args) ];
$results = grind_run($tests, $order, $perls, $loop_counts);
);
for my $p (@$perls) {
- my ($perl, $label) = @$p;
+ my ($perl, $label, $env, @putargs) = @$p;
# Run both the empty loop and the active loop
# $counts->[0] and $counts->[1] times.
for my $i (0,1) {
for my $j (0,1) {
- my $cmd = "PERL_HASH_SEED=0 "
+ my $envstr = '';
+ if (ref $env) {
+ $envstr .= "$_=$env->{$_} " for sort keys %$env;
+ }
+ my $cmd = "PERL_HASH_SEED=0 $envstr"
. "valgrind --tool=cachegrind --branch-sim=yes "
. "--cachegrind-out-file=/dev/null "
. "$OPTS{grindargs} "
- . "$perl $OPTS{perlargs} - $counts->[$j] 2>&1";
+ . "$perl $OPTS{perlargs} @putargs - $counts->[$j] 2>&1";
# for debugging and error messages
- my $id = "$test/$perl "
+ my $id = "$test/$label "
. ($i ? "active" : "empty") . "/"
. ($j ? "long" : "short") . " loop";
. "Output\n$o";
}
- $results{$j->{test}}{$j->{perl}}[$j->{active}][$j->{loopix}]
+ $results{$j->{test}}{$j->{plabel}}[$j->{active}][$j->{loopix}]
= parse_cachegrind($output, $j->{id}, $j->{perl});
}
my %counts;
my %data;
- my $perl_norm = $perls->[$OPTS{norm}][0]; # the name of the reference perl
+ my $perl_norm = $perls->[$OPTS{norm}][1]; # the label of the reference perl
for my $test_name (keys %$res) {
my $res1 = $res->{$test_name};
my ($results, $averages, $perls, $tests, $order) = @_;
my @perl_names = map $_->[0], @$perls;
+ my @perl_labels = map $_->[1], @$perls;
my %perl_labels;
$perl_labels{$_->[0]} = $_->[1] for @$perls;
# Calculate the width to display for each column.
my $min_width = $OPTS{raw} ? 8 : 6;
my @widths = map { length($_) < $min_width ? $min_width : length($_) }
- @perl_labels{@perl_names};
+ @perl_labels;
# Print standard header.
grind_blurb($perls);
print " " x $field_label_width;
for (0..$#widths) {
printf " %*s", $widths[$_],
- $i ? ('-' x$widths[$_]) : $perl_labels{$perl_names[$_]};
+ $i ? ('-' x$widths[$_]) : $perl_labels[$_];
}
print "\n";
}
print " " x $field_label_width;
for (0..$#widths) {
printf " %*s", $widths[$_],
- $i ? ('-' x$widths[$_]) : $perl_labels{$perl_names[$_]};
+ $i ? ('-' x$widths[$_]) : $perl_labels[$_];
}
print "\n";
}
}
for my $i (0..$#widths) {
- my $res2 = $res1->{$perl_names[$i]};
+ my $res2 = $res1->{$perl_labels[$i]};
my $p = $res2->{$field};
if (!defined $p) {
printf " %*s", $widths[$i], '-';
'all-fixups', 'early-fixup=s@', 'late-fixup=s@', 'valgrind',
'check-args', 'check-shebang!', 'usage|help|?', 'gold=s',
'module=s', 'with-module=s', 'cpan-config-dir=s',
+ 'no-module-tests',
'A=s@',
'D=s@' => sub {
my (undef, $val) = @_;
unless @ARGV || $match || $options{'test-build'} || defined $options{'one-liner'} || defined $options{module};
pod2usage(exitval => 255, verbose => 1)
if !$options{'one-liner'} && ($options{l} || $options{w});
+if ($options{'no-module-tests'} && $options{module}) {
+ print STDERR "--module and --no-module-tests are exclusive.\n\n";
+ pod2usage(exitval => 255, verbose => 1)
+}
check_shebang($ARGV[0])
if $options{'check-shebang'} && @ARGV && !$options{match};
=item *
+--no-module-tests
+
+Use in conjunction with I<--with-module> to install the modules without
+running their tests. This can be a big time saver.
+
+For example:
+
+ .../Porting/bisect.pl --with-module=Moose --no-module-tests \
+ -e 'use Moose; ...'
+
+=item *
+
--cpan-config-dir /home/blah/custom
If defined, this will cause L<CPAN> to look for F<CPAN/MyConfig.pm> inside of
s/-/::/g if /-/ and !m|/|;
}
my $install = join ",", map { "'$_'" } @m;
+ if ($options{'no-module-tests'}) {
+ $install = "notest('install',$install)";
+ } else {
+ $install = "install($install)";
+ }
my $last = $m[-1];
- my $shellcmd = "install($install); die unless CPAN::Shell->expand(Module => '$last')->uptodate;";
+ my $shellcmd = "$install; die unless CPAN::Shell->expand(Module => '$last')->uptodate;";
if ($options{module}) {
run_report_and_exit(@cpanshell, $shellcmd);
ansi2knr=''
aphostname='/bin/hostname'
api_revision='5'
-api_subversion='1'
+api_subversion='2'
api_version='25'
-api_versionstring='5.25.1'
+api_versionstring='5.25.2'
ar='ar'
-archlib='/tmp/mblead/lib/perl5/5.25.1/darwin-2level'
-archlibexp='/tmp/mblead/lib/perl5/5.25.1/darwin-2level'
+archlib='/tmp/mblead/lib/perl5/5.25.2/darwin-2level'
+archlibexp='/tmp/mblead/lib/perl5/5.25.2/darwin-2level'
archname64=''
archname='darwin-2level'
archobjs=''
d_pwquota='undef'
d_qgcvt='undef'
d_quad='define'
+d_querylocale='undef'
d_random_r='undef'
d_re_comp='undef'
d_readdir64_r='undef'
d_strctcpy='define'
d_strerrm='strerror(e)'
d_strerror='define'
+d_strerror_l='undef'
d_strerror_r='undef'
d_strftime='define'
d_strlcat='define'
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.1/darwin-2level'
+installarchlib='/tmp/mblead/lib/perl5/5.25.2/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.1'
+installprivlib='/tmp/mblead/lib/perl5/5.25.2'
installscript='/tmp/mblead/bin'
-installsitearch='/tmp/mblead/lib/perl5/site_perl/5.25.1/darwin-2level'
+installsitearch='/tmp/mblead/lib/perl5/site_perl/5.25.2/darwin-2level'
installsitebin='/tmp/mblead/bin'
installsitehtml1dir=''
installsitehtml3dir=''
-installsitelib='/tmp/mblead/lib/perl5/site_perl/5.25.1'
+installsitelib='/tmp/mblead/lib/perl5/site_perl/5.25.2'
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.1'
+perlpath='/tmp/mblead/bin/perl5.25.2'
pg='pg'
phostname='hostname'
pidtype='pid_t'
pr=''
prefix='/tmp/mblead'
prefixexp='/tmp/mblead'
-privlib='/tmp/mblead/lib/perl5/5.25.1'
-privlibexp='/tmp/mblead/lib/perl5/5.25.1'
+privlib='/tmp/mblead/lib/perl5/5.25.2'
+privlibexp='/tmp/mblead/lib/perl5/5.25.2'
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.1/darwin-2level'
-sitearchexp='/tmp/mblead/lib/perl5/site_perl/5.25.1/darwin-2level'
+sitearch='/tmp/mblead/lib/perl5/site_perl/5.25.2/darwin-2level'
+sitearchexp='/tmp/mblead/lib/perl5/site_perl/5.25.2/darwin-2level'
sitebin='/tmp/mblead/bin'
sitebinexp='/tmp/mblead/bin'
sitehtml1dir=''
sitehtml1direxp=''
sitehtml3dir=''
sitehtml3direxp=''
-sitelib='/tmp/mblead/lib/perl5/site_perl/5.25.1'
+sitelib='/tmp/mblead/lib/perl5/site_perl/5.25.2'
sitelib_stem='/tmp/mblead/lib/perl5/site_perl'
-sitelibexp='/tmp/mblead/lib/perl5/site_perl/5.25.1'
+sitelibexp='/tmp/mblead/lib/perl5/site_perl/5.25.2'
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.1'
+startperl='#!/tmp/mblead/bin/perl5.25.2'
startsh='#!/bin/sh'
static_ext=' '
stdchar='char'
strerror_r_proto='0'
strings='/usr/include/string.h'
submit=''
-subversion='1'
+subversion='2'
sysman='/usr/share/man/man1'
sysroot=''
tail=''
vendorprefixexp=''
vendorscript=''
vendorscriptexp=''
-version='5.25.1'
-version_patchlevel_string='version 25 subversion 1'
+version='5.25.2'
+version_patchlevel_string='version 25 subversion 2'
versiononly='define'
vi=''
xlibpth='/usr/lib/386 /lib/386'
zip='zip'
PERL_REVISION=5
PERL_VERSION=25
-PERL_SUBVERSION=1
+PERL_SUBVERSION=2
PERL_API_REVISION=5
PERL_API_VERSION=25
-PERL_API_SUBVERSION=1
+PERL_API_SUBVERSION=2
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.1/i686-linux-64int-ld" /**/
-#define ARCHLIB_EXP "/pro/lib/perl5/5.25.1/i686-linux-64int-ld" /**/
+#define ARCHLIB "/pro/lib/perl5/5.25.2/i686-linux-64int-ld" /**/
+#define ARCHLIB_EXP "/pro/lib/perl5/5.25.2/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.1" /**/
-#define PRIVLIB_EXP "/pro/lib/perl5/5.25.1" /**/
+#define PRIVLIB "/pro/lib/perl5/5.25.2" /**/
+#define PRIVLIB_EXP "/pro/lib/perl5/5.25.2" /**/
/* 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.1/i686-linux-64int-ld" /**/
-#define SITEARCH_EXP "/pro/lib/perl5/site_perl/5.25.1/i686-linux-64int-ld" /**/
+#define SITEARCH "/pro/lib/perl5/site_perl/5.25.2/i686-linux-64int-ld" /**/
+#define SITEARCH_EXP "/pro/lib/perl5/site_perl/5.25.2/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.1" /**/
-#define SITELIB_EXP "/pro/lib/perl5/site_perl/5.25.1" /**/
+#define SITELIB "/pro/lib/perl5/site_perl/5.25.2" /**/
+#define SITELIB_EXP "/pro/lib/perl5/site_perl/5.25.2" /**/
#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.1" /**/
+#define STARTPERL "#!/pro/bin/perl5.25.2" /**/
/* HAS_STDIO_STREAM_ARRAY:
* This symbol, if defined, tells that there is an array
=head1 EPIGRAPHS
+=head2 v5.25.1 - Eli Pariser, "The Filter Bubble"
+
+L<Announced on 2016-05-20 by Sawyer X|http://www.nntp.perl.org/group/perl.perl5.porters/2016/05/msg236566.html>
+
+Imagine that you're a smart high school student on the low end of the social
+totem pole. You're alienated from adult authority, but unlike many teenagers,
+you're also alienated from the power structures of your peers -- an existence
+that can feel lonely and peripheral. Systems and equations are intuitive, but
+people aren't -- social signals are confusing and messy, difficult to interpret.
+
+Then you discover code. You may be powerless at the lunch table, but code
+gives you power over an infinitely malleable world and opens the door to a
+symbolic system that's perfectly clear and ordered. The jostling for position
+and status fades away. The nagging parental voices disappear. There's just a
+clean, white page for you to fill, an opportunity to build a better place, a
+home, from the ground up.
+
+No wonder you're a geek.
+
=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>
use 5.14.0;
use autodie;
use HTTP::Tiny;
+use JSON::PP;
+
+$|=1;
my $http = HTTP::Tiny->new;
-my $url = 'http://www.cpan.org/SITES';
-my $filename = 'SITES';
-my $response = $http->mirror( $url, $filename );
+my $url = 'http://www.cpan.org/indices/mirrors.json';
+
+my $response = $http->get($url);
+
unless ( $response->{success} ) {
die "Error downloading $url";
}
-my $fh = IO::File->new($filename);
+die "No content" unless $response->{content};
-while ( my $line = <$fh> ) {
- chomp $line;
- last
- if $line eq
- '[Africa] [Asia] [Australasia] [Central America] [Europe] [North America] [South America]';
-}
+my $json = JSON::PP->new->utf8;
+my $mirrors = $json->decode( $response->{content} );
+my %sorted;
+my @rsync;
-my $line = <$fh>;
+foreach my $mirror ( sort { $a->{continent} cmp $b->{continent} || $a->{country} cmp $b->{country} } @{ $mirrors } ) {
+ if ( $mirror->{country} eq 'United States' ) {
+ push @{ $sorted{ $mirror->{continent} }{ $mirror->{country} }{ $mirror->{region} } }, $mirror;
+ }
+ else {
+ push @{ $sorted{ $mirror->{continent} }{ $mirror->{country} } }, $mirror;
+ }
+}
say 'Registered CPAN sites';
say '';
say 'Generated by Porting/make_modlib_cpan.pl';
say '';
-my $continent;
-my $country;
-my $state;
-
-while ( my $line = <$fh> ) {
- chomp $line;
- next if $line =~ /^\s+$/;
- last if $line eq 'Feedback';
-
- if ( $line =~ /^(?<continent>\w.+)$/ ) {
- if ($continent) {
- say '';
- if ($continent) {
- say "=back";
- say '';
- }
- if ( $continent eq 'North America' ) {
- say "=back";
- say '';
- }
- }
- $continent = $+{continent};
- undef $country;
- say "=head2 $continent";
- say '';
- say '=over 4';
- say '';
- } elsif ( $line =~ /^\s{3}(?<country>\w.+)$/ ) {
- if ($country) {
- say '';
- }
- $country = $+{country};
- undef $state;
- say "=item $country";
+foreach my $continent ( sort { $a cmp $b } keys %sorted ) {
+ say "=head2 $continent";
+ say '';
+ say '=over 4';
+ say '';
+ foreach my $country ( sort { $a cmp $b } keys %{ $sorted{ $continent } } ) {
+ say "=item $country";
+ say '';
+ if ( $country eq 'United States' ) {
+ say '=over 8';
+ say '';
+ foreach my $state ( sort { $a cmp $b } keys %{ $sorted{ $continent }{ $country } } ) {
+ say "=item $state";
say '';
- if ( $country eq 'United States' ) {
- say '=over 8';
- say '';
- }
- } elsif ( $line =~ /^\s{5}(?<state>\w.+)$/ ) {
- if ($state) {
- say '';
+ foreach my $mirror ( @{ $sorted{ $continent }{ $country }{ $state } } ) {
+ say " " . $mirror->{http} if $mirror->{http};
+ say " " . $mirror->{ftp} if $mirror->{ftp};
+ push @rsync, $mirror->{rsync} if $mirror->{rsync};
}
- $state = $+{state};
- say "=item $state";
say '';
- } elsif ( $line =~ /^\s{22}(?<site>\w.+$)/ ) {
- say " $+{site}";
- } else {
- die "Unknown line: $line";
+ }
+ say '=back';
+ say '';
+ }
+ else {
+ foreach my $mirror ( @{ $sorted{ $continent }{ $country } } ) {
+ say " " . $mirror->{http} if $mirror->{http};
+ say " " . $mirror->{ftp} if $mirror->{ftp};
+ push @rsync, $mirror->{rsync} if $mirror->{rsync};
+ }
+ say '';
}
+ }
+ say '=back';
+ say '';
+}
+
+say '=head2 RSYNC Mirrors';
+say '';
+
+foreach my $rsync ( @rsync ) {
+ say "\t\t$rsync";
}
say '';
-say '=back';
XXX Generate this with:
- perl Porting/acknowledgements.pl v5.25.1..HEAD
+ perl Porting/acknowledgements.pl v5.25.2..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
+If you find what you think is a bug, you might check the perl bug database
+at L<https://rt.perl.org/> . There may also be information at
L<http://www.perl.org/> , the Perl Home Page.
If you believe you have an unreported bug, please run the L<perlbug> program
=head1 Help Save the World
You should definitely announce your patch on the perl5-porters list.
-You should also consider announcing your patch on
-comp.lang.perl.announce, though you should make it quite clear that a
-subversion is not a production release, and be prepared to deal with
-people who will not read your disclaimer.
=head1 Todo
=head2 Perl 5.25
2016-04-08 5.25.0 ✓ Ricardo Signes
- 2016-05-20 5.25.1 Sawyer X
+ 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-10-20 5.25.6 Sawyer X
2016-11-20 5.25.7 Aaron Crane
2016-12-20 5.25.8 ?
+ 2017-01-20 5.25.9 ?
+ 2017-02-20 5.25.10 Renée Bäcker
(RC0 for 5.26.0 will be released once we think that all the blockers have been
addressed. This typically means some time in April or May.)
F<AUTHORS> file, which ships in the official distribution. How many other
programming languages offer you 1 line of immortality?
-=head1 Tasks that need only a little Perl knowledge
-
-=head2 Fix POD errors in Perl documentation
-
-Perl documentation is furnished in POD (Plain Old Documentation); see
-L<perlpod>. We also have a utility that checks for various errors in
-this documentation: F<t/porting/podcheck.t>. Unfortunately many files
-have errors in them, and there is a database of known problems, kept in
-F<t/porting/known_pod_issues.dat>. The most prevalent errors are lines
-too wide to fit in a standard terminal window, but there are more
-serious problems as well; and there are items listed there that are not
-in fact errors. The task would be to go through and clean up the
-documentation. This would be a good way to learn more about Perl.
-
=head1 Tasks that only need Perl knowledge
=head2 Classify bug tickets by type
the bug remains open because no one realizes that it has been fixed.
Ideally, every open bug should have a TODO test in the core test suite.
+=head2 deparse warnings nicely
+
+Currently Deparse punts on deparsing the bitmask for warnings, which it
+dumps uglily as-is. Try running this:
+
+ $ ./perl -Ilib -MO=Deparse -e 'use warnings "pipe"; die'
+
+Deparse.pm could use the package variables in warnings.pm that warnings.pm
+itself uses to convert the list passed to it into a bitfield. Deparse just
+needs to reverse that.
+
+=head2 test and fix Deparse with perl's test suite
+
+If you run perl's tests with the TEST_ARGS environment variable set to
+C<-deparse> (e.g., run C<TEST=-deparse make test>), each test file will be
+deparsed and the deparsed output will be run. Currently there are many
+failures, which ought to be fixed. There is in F<Porting/deparse-skips.txt>
+a list of tests known to fail, but it is out of date. Updating it would
+also help.
+
+This is an incremental task. Every small bit helps. It is also a task that
+may never end. As new tests are added, they tickle corner cases that
+B::Deparse cannot yet handle correctly.
+
+This task I<may> need a bit of perl guts knowledge. But what changes need
+to be made is usually easy to see by dumping op trees with B::Concise:
+
+ $ ./perl -Ilib -MO=Concise -e 'foo(); print @_; die $$_'
+
+and adjusting B::Deparse to handle whatever you see B::Concise produce.
+This is also a good way to I<learn> how perl's op trees work.
+
=head1 Tasks that need a little sysadmin-type knowledge
Or if you prefer, tasks that you would learn from, and broaden your skills
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.1.
+options would be nice for perl 5.25.2.
=head2 Profile Perl - am I hot or not?
been written so that it reflects the state of the read-only attribute, even
for directories (whatever CRT is being used), for symmetry with chmod().)
-=head2 strcat(), strcpy(), strncat(), strncpy(), sprintf(), vsprintf()
-
-Maybe create a utility that checks after each libperl.a creation that
-none of the above (nor sprintf(), vsprintf(), or *SHUDDER* gets())
-ever creep back to libperl.a.
-
- nm libperl.a | ./miniperl -alne '$o = $F[0] if /:$/;
- print "$o $F[1]" if $F[0] eq "U" && $F[1]
- =~ /^(?:strn?c(?:at|py)|v?sprintf|gets)$/'
-
-Note, of course, that this will only tell whether B<your> platform
-is using those naughty interfaces.
-
=head2 Arenas for GPs? For MAGIC?
C<struct gp> and C<struct magic> are both currently allocated by C<malloc>.
progressively update ExtUtils::ParseXS to generate OP implementations for
some XSUBs.
+=head2 Document how XS modules can install lexical subs
+
+There is an example in XS::APItest (look for C<lexical_import> in
+F<ext/XS-APItest/APItest.xs>). The documentation could be based on it.
+
=head2 Remove the use of SVs as temporaries in dump.c
F<dump.c> contains debugging routines to dump out the contains of perl data
system() accepts a LIST syntax (and a PROGRAM LIST syntax) to avoid
running a shell. readpipe() (the function behind qx//) could be similarly
-extended.
+extended. Note that changing readpipe() itself may not be the solution, as
+it currently has unary precedence, and allowing a list would change the
+precedence.
=head2 Audit the code for destruction ordering assumptions
These tasks would need C knowledge, and knowledge of how the interpreter works,
or a willingness to learn.
+=head2 fix refaliasing with nested and recursive subroutines
+
+Currently aliasing lexical variables via reference only applies to the
+current subroutine, and does not propagate to inner closures, nor does
+aliasing of outer variables within closures propagate to the outer
+subroutine. This is because each subroutine has its own lexical pad and the
+aliasing works by changing which SV the pad points to.
+
+One possible way to fix this would be to create new ops for accessing
+variables that are closed over. So C<my $x; sub {$x}> would use a new op
+type, say C<padoutsv>, instead of the C<padsv> currently used in the
+sub. That new op would possibly check a flag or some such and see if it
+needs to fetch the variable from an outer pad. If we follow this approach,
+it should be possible at compile time to detect cases where the more
+complex C<padoutsv> op is unnecessary and revert back to the simpler,
+faster C<padsv>. There would need to be corresponding ops for arrays,
+hashes, and subs, too.
+
+There is also a related issue with recursion and C<state> variables. A
+subroutine actually has a list of lexical pads, each one used at a
+different recursion level. If a C<state> variable is aliased to another
+variable after a recursive call to the same subroutine, that higher call
+depth will not see the effect of aliasing, because the second pad will have
+been created already. Similarly, aliasing a state variable within a
+recursive call will not affect outer calls, even though all call depths are
+supposed to share the same C<state> variables.
+
+Both of these bugs affect C<foreach> aliasing, too.
+
=head2 forbid labels with keyword names
Currently C<goto keyword> "computes" the label value:
=head2 truncate() prototype
The prototype of truncate() is currently C<$$>. It should probably
-be C<*$> instead. (This is changed in F<opcode.pl>)
+be C<*$> instead. (This is changed in F<regen/opcodes>.)
=head2 error reporting of [$a ; $b]
debugger on a running Perl program, although I'm not sure how it would be
done." ssh and screen do this with named pipes in /tmp. Maybe we can too.
-=head2 LVALUE functions for lists
-
-The old perltodo notes that lvalue functions don't work for list or hash
-slices. This would be good to fix.
-
=head2 regexp optimizer optional
The regexp optimizer is not optional. It should be configurable to be optional
This would allow proposals such as short circuiting sort to be implemented
as a module on CPAN.
-=head2 lexical aliases
-
-Allow lexical aliases (maybe via the syntax C<my \$alias = \$foo>).
-
=head2 Self-ties
Self-ties are currently illegal because they caused too many segfaults. Maybe
=head2 repack the optree
+B<Note:> This entry was written in reference to the I<old> slab allocator,
+removed in commit 7aef8e5bd14.
+
Repacking the optree after execution order is determined could allow
removal of NULL ops, and optimal ordering of OPs with respect to cache-line
filling. I think that
=head1 Big projects
Tasks that will get your name mentioned in the description of the "Highlights
-of 5.25.1"
+of 5.25.2"
=head2 make ithreads more robust
=head2 Compiling Perl 5 on AIX
-For information on compilers on older versions of AIX, see L<Compiling
+For information on compilers on older versions of AIX, see L</Compiling
Perl 5 on older AIX versions up to 4.3.3>.
When compiling Perl, you must use an ANSI C compiler. AIX does not ship
If you plan to link Perl to any module that requires thread-support,
like DBD::Oracle, it is better to use the _r version of the compiler.
This will not build a threaded Perl, but a thread-enabled Perl. See
-also L<Threaded Perl> later on.
+also L</Threaded Perl> later on.
As of writing (2010-09) only the I<IBM XL C for AIX> or I<IBM XL C/C++
for AIX> compiler is supported by IBM on AIX 5L/6.1/7.1.
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.1/BePC-haiku/CORE/libperl.so .
+ cd /boot/common/lib; ln -s perl5/5.25.2/BePC-haiku/CORE/libperl.so .
-Replace C<5.25.1> with your respective version of Perl.
+Replace C<5.25.2> 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.1.tar.gz
- tar -xzf perl-5.25.1.tar.gz
- cd perl-5.25.1
+ curl -O http://www.cpan.org/src/perl-5.25.2.tar.gz
+ tar -xzf perl-5.25.2.tar.gz
+ cd perl-5.25.2
./Configure -des -Dprefix=/usr/local/
make
make test
=head1 DESCRIPTION
-The latest Perl release (5.25.1 as of this writing) builds without changes
+The latest Perl release (5.25.2 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',
run (and build extensions, and - possibly - be built itself) under any
environment which can run EMX. The current list is DOS,
DOS-inside-OS/2, Win0.3*, Win0.95 and WinNT. Out of many perl flavors,
-only one works, see L<"perl_.exe">.
+only one works, see L</"F<perl_.exe>">.
Note that not all features of Perl are available under these
environments. This depends on the features the I<extender> - most
To run Perl on DPMI platforms one needs RSX runtime. This is
needed under DOS-inside-OS/2, Win0.3*, Win0.95 and WinNT (see
-L<"Other OSes">). RSX would not work with VCPI
+L</"Other OSes">). RSX would not work with VCPI
only, as EMX would, it requires DMPI.
Having RSX and the latest F<sh.exe> one gets a fully functional
pipes in between, and/or quoting of arguments), Perl uses an external
shell. With EMX port such shell should be named F<sh.exe>, and located
either in the wired-in-during-compile locations (usually F<F:/bin>),
-or in configurable location (see L<"PERL_SH_DIR">).
+or in configurable location (see L</"C<PERL_SH_DIR>">).
For best results use EMX pdksh. The standard binary (5.2.14 or later) runs
under DOS (with L</RSX>) as well, see
do).
Note however that to use some of these operators you need to have a
-sh-syntax shell installed (see L<"Pdksh">,
-L<"Frequently asked questions">), and perl should be able to find it
-(see L<"PERL_SH_DIR">).
+sh-syntax shell installed (see L</"Pdksh">,
+L</"Frequently asked questions">), and perl should be able to find it
+(see L</"C<PERL_SH_DIR>">).
The cases when the shell is used are:
=head2 C<``> and pipe-C<open> do not work under DOS.
-This may a variant of just L<"I cannot run external programs">, or a
+This may a variant of just L</"I cannot run external programs">, or a
deeper problem. Basically: you I<need> RSX (see L</Prerequisites>)
for these commands to work, and you may need a port of F<sh.exe> which
understands command arguments. One of such ports is listed in
L</Prerequisites> under RSX. Do not forget to set variable
-C<L<"PERL_SH_DIR">> as well.
+L</"C<PERL_SH_DIR>"> as well.
DPMI is required for RSX.
=item C<PERL_BADLANG>
may be needed if you change your codepage I<after> perl installation,
-and the new value is not supported by EMX. See L<"PERL_BADLANG">.
+and the new value is not supported by EMX. See L</"C<PERL_BADLANG>">.
=item C<PERL_BADFREE>
-see L<"PERL_BADFREE">.
+see L</"C<PERL_BADFREE>">.
=item F<Config.pm>
B<NOTE>. Because of a typo the binary installer of 5.00305
would install a variable C<PERL_SHPATH> into F<Config.sys>. Please
-remove this variable and put C<L</PERL_SH_DIR>> instead.
+remove this variable and put L</C<PERL_SH_DIR>> instead.
=head2 Manual binary installation
into F<perl.exe>, you do not need to change
anything. However, for perl to find the library if you use a different
path, you need to
-C<set PERLLIB_PREFIX> in F<Config.sys>, see L<"PERLLIB_PREFIX">.
+C<set PERLLIB_PREFIX> in F<Config.sys>, see L</"C<PERLLIB_PREFIX>">.
=item Additional Perl modules
- unzip perl_ste.zip -d f:/perllib/lib/site_perl/5.25.1/
+ unzip perl_ste.zip -d f:/perllib/lib/site_perl/5.25.2/
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
require shell, like the commands using I<redirection> and I<shell
metacharacters>. It is also used instead of explicit F</bin/sh>.
-Set C<PERL_SH_DIR> (see L<"PERL_SH_DIR">) if you move F<sh.exe> from
+Set C<PERL_SH_DIR> (see L</"C<PERL_SH_DIR>">) if you move F<sh.exe> from
the above location.
B<Note.> It may be possible to use some other sh-compatible shell (untested).
The automatic and manual perl installation leave precompiled paths
inside perl executables. While these paths are overwriteable (see
-L<"PERLLIB_PREFIX">, L<"PERL_SH_DIR">), some people may prefer
+L</"C<PERLLIB_PREFIX>">, L</"C<PERL_SH_DIR>">), some people may prefer
binary editing of paths inside the executables/DLLs.
=head1 Accessing documentation
view perl ExtUtils::MakeMaker
(currently the last two may hit a wrong location, but this may improve
-soon). Under Win* see L<"SYNOPSIS">.
+soon). Under Win* see L</"SYNOPSIS">.
If you want to build the docs yourself, and have I<OS/2 toolkit>, run
C<prefix> means: where to install the resulting perl library. Giving
correct prefix you may avoid the need to specify C<PERLLIB_PREFIX>,
-see L<"PERLLIB_PREFIX">.
+see L</"C<PERLLIB_PREFIX>">.
I<Ignore the message about missing C<ln>, and about C<-c> option to
tr>. The latter is most probably already fixed, if you see it and can trace
=item A lot of C<bad free>
in database tests related to Berkeley DB. I<This should be fixed already.>
-If it persists, you may disable this warnings, see L<"PERL_BADFREE">.
+If it persists, you may disable this warnings, see L</"C<PERL_BADFREE>">.
=item Process terminated by SIGTERM/SIGINT
=head2 C<a.out>-style build
-Proceed as above, but make F<perl_.exe> (see L<"perl_.exe">) by
+Proceed as above, but make F<perl_.exe> (see L</"F<perl_.exe>">) by
make perl_
a new executable per XS extension.
Here is a possible workaround: create a toplevel F<Makefile.PL> in
-F<$CPANHOME/.cpan/build/> with contents being (compare with L<Making
+F<$CPANHOME/.cpan/build/> with contents being (compare with L</Making
executables with a custom collection of statically loaded extensions>)
use ExtUtils::MakeMaker;
to ignore the environment when setting the Perl-library search patch, etc.
If you fill comfortable with I<embedding> interface (see L<perlembed>), such
-things are easy to do repeating the steps outlined in L<Making
+things are easy to do repeating the steps outlined in L/<Making
executables with a custom collection of statically loaded extensions>, and
doing more comprehensive edits to main() of F<perlmain.c>. The people with
little desire to understand Perl can just rename main(), and do necessary
system qw(C:/emx.add/bin/bash.exe -x -c C:/emx/bin/foo.cmd bar baz)
One additional translation is performed: instead of F</bin/sh> Perl uses
-the hardwired-or-customized shell (see C<L<"PERL_SH_DIR">>).
+the hardwired-or-customized shell (see L</"C<PERL_SH_DIR>">).
The above search for "interpreter" is recursive: if F<bash> executable is not
found, but F<bash.btm> is found, Perl will investigate its first line etc.
The argument true means that a real message loop is going to be served.
OS2::MorphPM() returns the PM message queue handle as an integer.
-See L<"Centralized management of resources"> for additional details.
+See L</"Centralized management of resources"> for additional details.
=item C<OS2::Serve_Messages(force)>
handling exception mask: if no C<mask>, uses exception mask part of C<new>
only. If no C<new>, disables all the floating point exceptions.
-See L<"Misfeatures"> for details.
+See L</"Misfeatures"> for details.
=item C<OS2::DLLname([how [, \&xsub]])>
=item *
-See L<"Text-mode filehandles">.
+See L</"Text-mode filehandles">.
=item *
=item C<popen>
-C<my_popen> uses F<sh.exe> if shell is required, cf. L<"PERL_SH_DIR">.
+C<my_popen> uses F<sh.exe> if shell is required, cf. L</"C<PERL_SH_DIR>">.
=item C<tmpnam>
I<This is the only executable with does not require OS/2.> The
friends locked into C<M$> world would appreciate the fact that this
executable runs under DOS, Win0.3*, Win0.95 and WinNT with an
-appropriate extender. See L<"Other OSes">.
+appropriate extender. See L</"Other OSes">.
=head2 F<perl__.exe>
Due to a popular demand the perl external program calling has been
changed wrt Andreas Kaiser's port. I<If> perl needs to call an
external program I<via shell>, the F<f:/bin/sh.exe> will be called, or
-whatever is the override, see L<"PERL_SH_DIR">.
+whatever is the override, see L</"C<PERL_SH_DIR>">.
Thus means that you need to get some copy of a F<sh.exe> as well (I
use one from pdksh). The path F<F:/bin> above is set up automatically during
Note that OS2 perl defines 2 pseudo-extension functions
OS2::Copy::copy and DynaLoader::mod2fname (many more now, see
-L<Prebuilt methods>).
+L</Prebuilt methods>).
The -R switch of older perl is deprecated. If you need to call a REXX code
which needs access to variables, include the call into a REXX compartment
If you have problems with dynamic loading using gcc on SunOS or
Solaris, and you are using GNU as and GNU ld, see the section
-L<"GNU as and GNU ld"> above.
+L</"GNU as and GNU ld"> above.
=item ld.so.1: ./perl: fatal: relocation error:
If you get this message on SunOS or Solaris, and you're using gcc,
it's probably the GNU as or GNU ld problem in the previous item
-L<"GNU as and GNU ld">.
+L</"GNU as and GNU ld">.
=item dlopen: stub interception failed
The primary cause of the 'dlopen: stub interception failed' message is
that the LD_LIBRARY_PATH environment variable includes a directory
which is a symlink to /usr/lib (such as /lib). See
-L<"LD_LIBRARY_PATH"> above.
+L</"LD_LIBRARY_PATH"> above.
=item #error "No DATAMODEL_NATIVE specified"
then fdopen(3C) with the resulting file descriptor, perl is limited
to 255 simultaneous open files, even if sysopen() is used. If this
proves to be an insurmountable problem, you can compile perl as a
-LP64 application, see L<Building an LP64 perl> for details. Note
+LP64 application, see L</Building an LP64 perl> for details. Note
also that the default resource limit for open file descriptors on
Solaris is 255, so you will have to modify your ulimit or rctl
(Solaris 9 onwards) appropriately.
Since it is based on Linux, the NAS can run many popular Linux
software packages, including Perl. In fact, Synology provides a
ready-to-install package for Perl, depending on the version of DSM
-the installed perl ranges from 5.8.6 on DSM-4.3 to 5.18.4 on DSM-5.1.
+the installed perl ranges from 5.8.6 on DSM-4.3 to 5.18.4 on DSM-6.0.1.
There is an active user community that provides many software packages
for the Synology DSM systems; at the time of writing this document
system that will affect how Perl 5 (hereafter just Perl) is
configured, compiled and/or runs. It has been compiled and verified by
Johan Vromans for the Synology DS413 (QorIQ), with feedback from
-H.Merijn Brand (DS213, ARMv5tel).
+H.Merijn Brand (DS213, ARMv5tel and RS815, Intel Atom x64).
=head2 Setting up the build environment
+=head3 DSM 5
+
As DSM is a trimmed-down Linux system, it lacks many of the tools and
libraries commonly found on Linux. The basic tools like sh, cp, rm,
etc. are implemented using
B<WARNING:> When you perform a system software upgrade, these links
will disappear and need to be re-established.
+=head3 DSM 6
+
+Using iPkg has been deprecated on DSM 6, but an alternative is available
+for DSM 6: entware/opkg. For instructions on how to use that, please read
+L<Install Entware-ng on Synology NAS|https://github.com/Entware-ng/Entware-ng/wiki/Install-on-Synology-NAS>
+
+That sadly does not (yet) work on QorIQ. At the moment of writing, the
+supported architectures are armv5, armv7, mipsel, x86_32 and x86_64.
+
+Entware-ng comes with a precompiled 5.22.1 (June 2016) that allowes
+building shared XS code. Note that this installation does B<not> use
+a site_perl folder.
+
=head2 Compiling Perl 5
When the build environment has been set up, building and testing Perl
=head1 REVISION
-March 2015, for Synology DSM 5.1.5022.
+June 2016, for Synology DSM 5.1.5022 and DSM 6.0.1-7393.
=head1 AUTHOR
正體中文版的歐萊禮 Perl 書藉
-=item L<http://groups.google.com/groups?q=tw.bbs.comp.lang.perl>
-
-臺灣 Perl 連線討論區 (也就是各大 BBS 的 Perl 連線版)
-
=back
=head2 Perl 使用者集會
choice. Once you have done so, use a command like the following to
unpack the archive:
- vmstar -xvf perl-5^.25^.1.tar
+ vmstar -xvf perl-5^.25^.2.tar
Then set default to the top-level source directory like so:
- set default [.perl-5^.25^.1]
+ set default [.perl-5^.25^.2]
and proceed with configuration as described in the next section.
Once you issue your MMS or MMK command, sit back and wait. Perl should
compile and link without a problem. If a problem does occur check the
"CAVEATS" section of this document. If that does not help send some
-mail to the VMSPERL mailing list. Instructions are in the L<"Mailing Lists">
+mail to the VMSPERL mailing list. Instructions are in the L</"Mailing Lists">
section of this document.
=head1 Testing Perl
was extracted. Make sure you read and understand the terms under
which this software is being distributed.
-Also make sure you read L<BUGS AND CAVEATS> below for the
+Also make sure you read L</BUGS AND CAVEATS> below for the
known limitations of this port.
The INSTALL file in the perl top-level has much information that is
This port fully supports MakeMaker (the set of modules that
is used to build extensions to perl). Therefore, you should be
able to build and install most extensions found in the CPAN sites.
-See L<Usage Hints for Perl on Windows> below for general hints about this.
+See L</Usage Hints for Perl on Windows> below for general hints about this.
=head2 Setting Up Perl on Windows
ones and makes tests fail. Remove them from your path while testing to
avoid these errors.
-Please report any other failures as described under L<BUGS AND CAVEATS>.
+Please report any other failures as described under L</BUGS AND CAVEATS>.
=head2 Installation of Perl on Windows
#endif /* defined(PERL_IN_REGEXEC_C) */
/* Generated from:
- * cb3170dd603ad12ba0299440e99e8f50a8afde60ade2ffcbf1ff4a8a53854b90 lib/Unicode/UCD.pm
+ * 66726fe32be96a422e8c9b45bc9daf61e068d988c99ff41112972ef721365521 lib/Unicode/UCD.pm
* ae98bec7e4f0564758eed81eca5015481ba32581f8a735a825b71b3bba714450 lib/unicore/ArabicShaping.txt
* 1687fe5994eb7e5c0dab8503fc2a1b3b479d91af9d3b8055941c9bd791f7d0b5 lib/unicore/BidiBrackets.txt
* 350d1302116194b0b21def287434b55c5088098fbc726e879f7420a391965643 lib/unicore/BidiMirroring.txt
#$d_getlogin HAS_GETLOGIN /**/
/* HAS_GETPGID:
- * This symbol, if defined, indicates to the C program that
+ * This symbol, if defined, indicates to the C program that
* the getpgid(pid) function is available to get the
* process group id.
*/
* This symbol holds the type used for the second argument to
* getgroups() and setgroups(). Usually, this is the same as
* gidtype (gid_t) , but sometimes it isn't.
- * It can be int, ushort, gid_t, etc...
- * It may be necessary to include <sys/types.h> to get any
+ * It can be int, ushort, gid_t, etc...
+ * It may be necessary to include <sys/types.h> to get any
* typedef'ed information. This is only required if you have
* getgroups() or setgroups()..
*/
* This symbol, if defined, indicates that the uselocale routine is
* available to set the current locale for the calling thread.
*/
+/* HAS_QUERYLOCALE:
+ * This symbol, if defined, indicates that the querylocale routine is
+ * available to return the name of the locale for a category mask.
+ */
#$d_newlocale HAS_NEWLOCALE /**/
#$d_freelocale HAS_FREELOCALE /**/
#$d_uselocale HAS_USELOCALE /**/
+#$d_querylocale HAS_QUERYLOCALE /**/
/* HAS_NEXTAFTER:
* This symbol, if defined, indicates that the nextafter routine is
*/
#$d_fstatvfs HAS_FSTATVFS /**/
+/* HAS_STRERROR_L:
+ * This symbol, if defined, indicates that the strerror_l routine is
+ * available to return the error message for a given errno value in
+ * a particular locale (identified by a locale_t object).
+ */
+#$d_strerror_l HAS_STRERROR_L /**/
+
/* HAS_STRFTIME:
* This symbol, if defined, indicates that the strftime routine is
* available to do time formatting.
my ($bincompat, $non_bincompat, $date, @patches) = Internals::V();
- my $opts = join ' ', sort split ' ', "$bincompat $non_bincompat";
-
- # wrap at 76 columns.
-
- $opts =~ s/(?=.{53})(.{1,53}) /$1\n /mg;
+ my @opts = sort split ' ', "$bincompat $non_bincompat";
print Config::myconfig();
print "\nCharacteristics of this %s: \n";
- print " Compile-time options: $opts\n";
+ print " Compile-time options:\n";
+ print " $_\n" for @opts;
if (@patches) {
print " Locally applied patches:\n";
- print "\t$_\n" foreach @patches;
+ print " $_\n" foreach @patches;
}
print " Built under %s\n";
$ WC "d_localtime_r='undef'" ! leave undef'd; we use my_localtime
$ WC "d_localtime_r_needs_tzset='undef'"
$ WC "d_newlocale='undef'"
+$ WC "d_querylocale='undef'"
$ WC "d_random_r='undef'"
$ WC "d_readdir_r='define'" ! always defined; we roll our own
$ WC "d_readdir64_r='undef'"
$ WC "d_snprintf='" + d_snprintf + "'"
$ WC "d_srand48_r='undef'"
$ WC "d_srandom_r='undef'"
+$ WC "d_strerror_l='undef'"
$ WC "d_strerror_r='undef'"
$ WC "d_tmpnam_r='undef'"
$ WC "d_ttyname_r='" + d_ttyname_r + "'"
/* Restore old @_ */
#define CX_POP_SAVEARRAY(cx) \
STMT_START { \
- AV *av = GvAV(PL_defgv); \
+ AV *cx_pop_savearray_av = GvAV(PL_defgv); \
GvAV(PL_defgv) = cx->blk_sub.savearray; \
cx->blk_sub.savearray = NULL; \
- SvREFCNT_dec(av); \
+ SvREFCNT_dec(cx_pop_savearray_av); \
} STMT_END
/* junk in @_ spells trouble when cloning CVs and in pp_caller(), so don't
use if $] < 5.008 => 'IO::Scalar';
-$VERSION = '1.63';
+$VERSION = '1.64';
=head1 NAME
cpan
# without arguments, but some switches
- cpan [-ahpruvACDLOP]
+ cpan [-ahpruvACDLOPX]
=head1 DESCRIPTION
Print a help message and exit. When you specify C<-h>, it ignores all
of the other options and arguments.
-=item -i
+=item -i module [ module ... ]
Install the specified modules. With no other switches, this switch
is implied.
Recompiles dynamically loaded modules with CPAN::Shell->recompile.
-=item -t
+=item -s
+
+Drop in the CPAN.pm shell. This command does this automatically if you don't
+specify any arguments.
+
+=item -t module [ module ... ]
Run a `make test` on the specified modules.
Turn on cpan warnings. This checks various things, like directory permissions,
and tells you about problems you might have.
+=item -x module [ module ... ]
+
+Find close matches to the named modules that you think you might have
+mistyped. This requires the optional installation of Text::Levenshtein or
+Text::Levenshtein::Damerau.
+
+=item -X
+
+Dump all the namespaces to standard output.
+
=back
=head2 Examples
use vars qw( @META_OPTIONS $Default %CPAN_METHODS @CPAN_OPTIONS @option_order
%Method_table %Method_table_index );
-@META_OPTIONS = qw( h v V I g G M: C A D O l L a r p P j: J w T);
+@META_OPTIONS = qw( h v V I g G M: C A D O l L a r p P j: J w x X );
$Default = 'default';
't' => 'test',
'u' => 'upgrade',
'T' => 'notest',
+ 's' => 'shell',
);
@CPAN_OPTIONS = grep { $_ ne $Default } sort keys %CPAN_METHODS;
h => [ \&_print_help, NO_ARGS, GOOD_EXIT, 'Printing help' ],
v => [ \&_print_version, NO_ARGS, GOOD_EXIT, 'Printing version' ],
V => [ \&_print_details, NO_ARGS, GOOD_EXIT, 'Printing detailed version' ],
+ X => [ \&_list_all_namespaces, NO_ARGS, GOOD_EXIT, 'Listing all namespaces' ],
# options that affect other options
j => [ \&_load_config, ARGS, GOOD_EXIT, 'Use specified config file' ],
w => [ \&_turn_on_warnings, NO_ARGS, GOOD_EXIT, 'Turning on warnings' ],
# options that do their one thing
- g => [ \&_download, NO_ARGS, GOOD_EXIT, 'Download the latest distro' ],
- G => [ \&_gitify, NO_ARGS, GOOD_EXIT, 'Down and gitify the latest distro' ],
+ g => [ \&_download, ARGS, GOOD_EXIT, 'Download the latest distro' ],
+ G => [ \&_gitify, ARGS, GOOD_EXIT, 'Down and gitify the latest distro' ],
C => [ \&_show_Changes, ARGS, GOOD_EXIT, 'Showing Changes file' ],
A => [ \&_show_Author, ARGS, GOOD_EXIT, 'Showing Author' ],
r => [ \&_recompile, NO_ARGS, GOOD_EXIT, 'Recompiling' ],
u => [ \&_upgrade, NO_ARGS, GOOD_EXIT, 'Running `make test`' ],
+ 's' => [ \&_shell, NO_ARGS, GOOD_EXIT, 'Running `make test`' ],
+ 'x' => [ \&_guess_namespace, ARGS, GOOD_EXIT, 'Guessing namespaces' ],
c => [ \&_default, ARGS, GOOD_EXIT, 'Running `make clean`' ],
f => [ \&_default, ARGS, GOOD_EXIT, 'Installing with force' ],
i => [ \&_default, ARGS, GOOD_EXIT, 'Running `make install`' ],
last OPTION;
}
- $logger->info( "$description -- ignoring other arguments" )
+ $logger->info( "[$option] $description -- ignoring other arguments" )
if( @ARGV && ! $takes_args );
$return_value = $sub->( \ @ARGV, $options );
unless( $log4perl_loaded )
{
- print "Loading internal null logger. Install Log::Log4perl for logging messages\n";
+ print STDERR "Loading internal null logger. Install Log::Log4perl for logging messages\n";
$logger = Local::Null::Logger->new;
return $logger;
}
foreach my $arg ( @$args )
{
+ # check the argument and perhaps capture typos
+ my $module = _expand_module( $arg ) or do {
+ $logger->error( "Skipping $arg because I couldn't find a matching namespace." );
+ next;
+ };
+
_clear_cpanpm_output();
$action->( $arg );
$CPAN::Frontend->myprint("\n");
}
- my $mirrors = CPAN::Mirrors->new( );
- $mirrors->parse_mirrored_by( File::Spec->catfile($CPAN::Config->{keep_source_where},'MIRRORED.BY') );
+ my $mirrors = CPAN::Mirrors->new( _mirror_file() );
my @continents = $mirrors->find_best_continents;
my @mirrors = $mirrors->get_mirrors_by_continents( $continents[0] );
$uri->scheme eq 'file'
}
-sub _find_good_mirrors {
- require CPAN::Mirrors;
-
+sub _mirror_file {
my $file = do {
my $file = 'MIRRORED.BY';
my $local_path = File::Spec->catfile(
$local_path;
}
};
- my $mirrors = CPAN::Mirrors->new( $file );
+ }
+
+sub _find_good_mirrors {
+ require CPAN::Mirrors;
+
+ my $mirrors = CPAN::Mirrors->new( _mirror_file() );
my @mirrors = $mirrors->best_mirrors(
how_many => 5,
return HEY_IT_WORKED;
}
+sub _shell
+ {
+ $logger->info( "Dropping into shell" );
+
+ CPAN::shell();
+
+ return HEY_IT_WORKED;
+ }
+
sub _load_config # -j
{
my $file = shift || '';
my %paths;
- foreach my $module ( @$args )
- {
- $logger->info( "Checking $module" );
- my $path = CPAN::Shell->expand( "Module", $module )->cpan_file;
+ foreach my $arg ( @$args ) {
+ $logger->info( "Checking $arg" );
+
+ my $module = _expand_module( $arg ) or next;
+ my $path = $module->cpan_file;
$logger->debug( "Inst file would be $path\n" );
- $paths{$module} = _get_file( _make_path( $path ) );
+ $paths{$arg} = _get_file( _make_path( $path ) );
+
+ $logger->info( "Downloaded [$arg] to [$paths{$module}]" );
}
return \%paths;
my $starting_dir = cwd();
- foreach my $module ( @$args )
+ foreach my $arg ( @$args )
{
- $logger->info( "Checking $module" );
- my $path = CPAN::Shell->expand( "Module", $module )->cpan_file;
-
- my $store_paths = _download( [ $module ] );
- $logger->debug( "gitify Store path is $store_paths->{$module}" );
- my $dirname = dirname( $store_paths->{$module} );
+ $logger->info( "Checking $arg" );
+ my $store_paths = _download( [ $arg ] );
+ $logger->debug( "gitify Store path is $store_paths->{$arg}" );
+ my $dirname = dirname( $store_paths->{$arg} );
- my $ae = Archive::Extract->new( archive => $store_paths->{$module} );
+ my $ae = Archive::Extract->new( archive => $store_paths->{$arg} );
$ae->extract( to => $dirname );
chdir $ae->extract_path;
{
$logger->info( "Checking $arg\n" );
- my $module = eval { CPAN::Shell->expand( "Module", $arg ) };
+ my $module = _expand_module( $arg ) or next;
+
my $out = _get_cpanpm_output();
next unless eval { $module->inst_file };
foreach my $arg ( @$args )
{
- my $module = CPAN::Shell->expand( "Module", $arg );
+ my $module = _expand_module( $arg ) or next;
+
unless( $module )
{
$logger->info( "Didn't find a $arg module, so no author!" );
foreach my $arg ( @$args )
{
- my $module = CPAN::Shell->expand( "Module", $arg );
+ my $module = _expand_module( $arg ) or next;
my $author = CPAN::Shell->expand( "Author", $module->userid );
next unless $module->userid;
return HEY_IT_WORKED;
}
+BEGIN {
+my $modules;
+sub _get_all_namespaces
+ {
+ return $modules if $modules;
+ $modules = [ map { $_->id } CPAN::Shell->expand( "Module", "/./" ) ];
+ }
+}
+
sub _show_out_of_date
{
- my @modules = CPAN::Shell->expand( "Module", "/./" );
+ my $modules = _get_all_namespaces();
printf "%-40s %6s %6s\n", "Module Name", "Local", "CPAN";
print "-" x 73, "\n";
- foreach my $module ( @modules )
+ foreach my $module ( @$modules )
{
next unless $module->inst_file;
next if $module->uptodate;
my %hash = map { lc $_, 1 } @$args;
- my @modules = CPAN::Shell->expand( "Module", "/./" );
+ my $modules = _get_all_namespaces();
- foreach my $module ( @modules )
- {
+ foreach my $module ( @$modules ) {
next unless exists $hash{ lc $module->userid };
print $module->id, "\n";
}
return $module_name;
}
+
+sub _expand_module
+ {
+ my( $module ) = @_;
+
+ my $expanded = CPAN::Shell->expand( "Module", $module );
+ unless( defined $expanded ) {
+ $logger->error( "Could not expand [$module]. Check the module name." );
+ my $threshold = (
+ grep { int }
+ sort { length $a <=> length $b }
+ length($module)/4, 4
+ )[0];
+
+ my $guesses = _guess_at_module_name( $module, $threshold );
+ if( defined $guesses and @$guesses ) {
+ $logger->info( "Perhaps you meant one of these:" );
+ foreach my $guess ( @$guesses ) {
+ $logger->info( "\t$guess" );
+ }
+ }
+ return;
+ }
+
+ return $expanded;
+ }
+
+my $guessers = [
+ [ qw( Text::Levenshtein::XS distance 7 ) ],
+ [ qw( Text::Levenshtein::Damerau::XS xs_edistance 7 ) ],
+
+ [ qw( Text::Levenshtein distance 7 ) ],
+ [ qw( Text::Levenshtein::Damerau::PP pp_edistance 7 ) ],
+
+ ];
+
+# for -x
+sub _guess_namespace
+ {
+ my $args = shift;
+
+ foreach my $arg ( @$args )
+ {
+ $logger->debug( "Checking $arg" );
+ my $guesses = _guess_at_module_name( $arg );
+
+ foreach my $guess ( @$guesses ) {
+ print $guess, "\n";
+ }
+ }
+
+ return HEY_IT_WORKED;
+ }
+
+sub _list_all_namespaces {
+ my $modules = _get_all_namespaces();
+
+ foreach my $module ( @$modules ) {
+ print $module, "\n";
+ }
+ }
+
+BEGIN {
+my $distance;
+sub _guess_at_module_name
+ {
+ my( $target, $threshold ) = @_;
+
+ unless( defined $distance ) {
+ foreach my $try ( @$guessers ) {
+ my $can_guess = eval "require $try->[0]; 1" or next;
+
+ no strict 'refs';
+ $distance = \&{ join "::", @$try[0,1] };
+ $threshold ||= $try->[2];
+ }
+ }
+
+ unless( $distance ) {
+ my $modules = join ", ", map { $_->[0] } @$guessers;
+ substr $modules, rindex( $modules, ',' ), 1, ', and';
+
+ $logger->info( "I can suggest names if you install one of $modules" );
+ return;
+ }
+
+ my $modules = _get_all_namespaces();
+ $logger->info( "Checking " . @$modules . " namespaces for close match suggestions" );
+
+ my %guesses;
+ foreach my $guess ( @$modules ) {
+ my $distance = $distance->( $target, $guess );
+ next if $distance > $threshold;
+ $guesses{$guess} = $distance;
+ }
+
+ my @guesses = sort { $guesses{$a} <=> $guesses{$b} } keys %guesses;
+ return [ grep { defined } @guesses[0..9] ];
+ }
+}
+
1;
=back
* Check then exit
-* no test option
-
=head1 BUGS
* none noted
=head1 COPYRIGHT
-Copyright (c) 2001-2014, brian d foy, All Rights Reserved.
+Copyright (c) 2001-2015, brian d foy, All Rights Reserved.
You may redistribute this under the same terms as Perl itself.
# vim: ts=4 sts=4 sw=4:
use strict;
package CPAN;
-$CPAN::VERSION = '2.11';
+$CPAN::VERSION = '2.14';
$CPAN::VERSION =~ s/_//;
# we need to run chdir all over and we would get at wrong libraries
$inc = File::Spec->rel2abs($inc) unless ref $inc;
}
}
+ $SIG{WINCH} = 'IGNORE' if exists $SIG{WINCH};
}
use CPAN::Author;
use CPAN::HandleConfig;
}
for my $class (qw(Module Distribution)) {
# again unsafe meta access?
- for my $dm (keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) {
+ for my $dm (sort keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) {
next unless $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
CPAN->debug("BUG: $class '$dm' was in command state, resetting");
delete $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
my $otherpid = <$fh>;
my $otherhost = <$fh>;
$fh->close;
- if (defined $otherpid && $otherpid) {
+ if (defined $otherpid && length $otherpid) {
chomp $otherpid;
}
- if (defined $otherhost && $otherhost) {
+ if (defined $otherhost && length $otherhost) {
chomp $otherhost;
}
my $thishost = hostname();
+ my $ask_if_degraded_wanted = 0;
if (defined $otherhost && defined $thishost &&
$otherhost ne '' && $thishost ne '' &&
$otherhost ne $thishost) {
});
if (kill 0, $otherpid or $!{EPERM}) {
$CPAN::Frontend->mywarn(qq{Other job is running.\n});
- my($ans) =
- CPAN::Shell::colorable_makemaker_prompt
- (qq{Shall I try to run in downgraded }.
- qq{mode? (Y/n)},"y");
- if ($ans =~ /^y/i) {
- $CPAN::Frontend->mywarn("Running in downgraded mode (experimental).
-Please report if something unexpected happens\n");
- $RUN_DEGRADED = 1;
- for ($CPAN::Config) {
- # XXX
- # $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that?
- $_->{commandnumber_in_prompt} = 0; # visibility
- $_->{histfile} = ""; # who should win otherwise?
- $_->{cache_metadata} = 0; # better would be a lock?
- $_->{use_sqlite} = 0; # better would be a write lock!
- $_->{auto_commit} = 0; # we are violent, do not persist
- $_->{test_report} = 0; # Oliver Paukstadt had sent wrong reports in degraded mode
- }
- } else {
- $CPAN::Frontend->mydie("
-You may want to kill the other job and delete the lockfile. On UNIX try:
- kill $otherpid
- rm $lockfile
-");
- }
+ $ask_if_degraded_wanted = 1;
} elsif (-w $lockfile) {
my($ans) =
CPAN::Shell::colorable_makemaker_prompt
qq{ and then rerun us.\n}
);
}
+ } elsif ($^O eq "MSWin32") {
+ $CPAN::Frontend->mywarn(
+ qq{
+There seems to be running another CPAN process according to '$lockfile'.
+});
+ $ask_if_degraded_wanted = 1;
} else {
$CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ".
"'$lockfile', please remove. Cannot proceed.\n"));
}
+ if ($ask_if_degraded_wanted) {
+ my($ans) =
+ CPAN::Shell::colorable_makemaker_prompt
+ (qq{Shall I try to run in downgraded }.
+ qq{mode? (Y/n)},"y");
+ if ($ans =~ /^y/i) {
+ $CPAN::Frontend->mywarn("Running in downgraded mode (experimental).
+Please report if something unexpected happens\n");
+ $RUN_DEGRADED = 1;
+ for ($CPAN::Config) {
+ # XXX
+ # $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that?
+ $_->{commandnumber_in_prompt} = 0; # visibility
+ $_->{histfile} = ""; # who should win otherwise?
+ $_->{cache_metadata} = 0; # better would be a lock?
+ $_->{use_sqlite} = 0; # better would be a write lock!
+ $_->{auto_commit} = 0; # we are violent, do not persist
+ $_->{test_report} = 0; # Oliver Paukstadt had sent wrong reports in degraded mode
+ }
+ } else {
+ my $msg = "You may want to kill the other job and delete the lockfile.";
+ if (defined $otherpid) {
+ $msg .= " Something like:
+ kill $otherpid
+ rm $lockfile
+";
+ }
+ $CPAN::Frontend->mydie("\n$msg");
+ }
+ }
}
my $dotcpan = $CPAN::Config->{cpan_home};
eval { File::Path::mkpath($dotcpan);};
keys %{$self->{is_tested}};
if ($foul) {
$CPAN::Frontend->mywarn("Lost build_dir detected ($foul), giving up all cached test results of currently running session.\n");
- for my $dbd (keys %{$self->{is_tested}}) { # distro-build-dir
- SEARCH: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
+ for my $dbd (sort keys %{$self->{is_tested}}) { # distro-build-dir
+ SEARCH: for my $d (sort { $a->id cmp $b->id } $CPAN::META->all_objects("CPAN::Distribution")) {
if ($d->{build_dir} && $d->{build_dir} eq $dbd) {
$CPAN::Frontend->mywarn(sprintf "Flushing cache for %s\n", $d->pretty_id);
$d->fforce("");
Modulename=arg0,arg1,arg2,arg3,...
+eg:
+
+ CPAN::Plugin::Flurb=dir,/opt/pkgs/flurb/raw,verbose,1
+
At run time, each listed plugin is instantiated as a singleton object
by running the equivalent of this pseudo code:
use File::Path ();
@CPAN::Distribution::ISA = qw(CPAN::InfoObj);
use vars qw($VERSION);
-$VERSION = "2.04";
+$VERSION = "2.12";
# no prepare, because prepare is not a command on the shell command line
# TODO: clear instance cache on reload
if (defined $prereq_pm) {
# XXX also optional_req & optional_breq? -- xdg, 2012-04-01
# A: no, optional deps may recurse -- ak, 2014-05-07
- PREREQ: for my $pre (
+ PREREQ: for my $pre (sort(
keys %{$prereq_pm->{requires}||{}},
keys %{$prereq_pm->{build_requires}||{}},
- ) {
+ )) {
next PREREQ if $pre eq "perl";
my $premo;
unless ($premo = CPAN::Shell->expand("Module",$pre)) {
#-> sub CPAN::Distribution::containsmods ;
sub containsmods {
my $self = shift;
- return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
+ return sort keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
my $dist_id = $self->{ID};
for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
my $mod_file = $mod->cpan_file or next;
}
$self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
}
- keys %{$self->{CONTAINSMODS}||={}};
+ sort keys %{$self->{CONTAINSMODS}||={}};
}
#-> sub CPAN::Distribution::upload_date ;
@readdir = grep { $_ ne "pax_global_header" } @readdir;
}
$dh->close;
- my ($packagedir);
- # XXX here we want in each branch File::Temp to protect all build_dir directories
- if (CPAN->has_usable("File::Temp")) {
- my $tdir_base;
- my $from_dir;
- my @dirents;
- if (@readdir == 1 && -d $readdir[0]) {
- $tdir_base = $readdir[0];
- $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
- my $dh2;
- unless ($dh2 = DirHandle->new($from_dir)) {
- my($mode) = (stat $from_dir)[2];
- my $why = sprintf
- (
- "Couldn't opendir '%s', mode '%o': %s",
- $from_dir,
- $mode,
- $!,
- );
- $CPAN::Frontend->mywarn("$why\n");
- $self->{writemakefile} = CPAN::Distrostatus->new("NO -- $why");
- return;
- }
- @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC??
- } else {
- my $userid = $self->cpan_userid;
- CPAN->debug("userid[$userid]");
- if (!$userid or $userid eq "N/A") {
- $userid = "anon";
- }
- $tdir_base = $userid;
- $from_dir = File::Spec->curdir;
- @dirents = @readdir;
+ my $tdir_base;
+ my $from_dir;
+ my @dirents;
+ if (@readdir == 1 && -d $readdir[0]) {
+ $tdir_base = $readdir[0];
+ $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
+ my $dh2;
+ unless ($dh2 = DirHandle->new($from_dir)) {
+ my($mode) = (stat $from_dir)[2];
+ my $why = sprintf
+ (
+ "Couldn't opendir '%s', mode '%o': %s",
+ $from_dir,
+ $mode,
+ $!,
+ );
+ $CPAN::Frontend->mywarn("$why\n");
+ $self->{writemakefile} = CPAN::Distrostatus->new("NO -- $why");
+ return;
}
- eval { File::Path::mkpath $builddir; };
- if ($@) {
- $CPAN::Frontend->mydie("Cannot create directory $builddir: $@");
+ @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC??
+ } else {
+ my $userid = $self->cpan_userid;
+ CPAN->debug("userid[$userid]");
+ if (!$userid or $userid eq "N/A") {
+ $userid = "anon";
}
- $packagedir = File::Temp::tempdir(
- "$tdir_base-XXXXXX",
- DIR => $builddir,
- CLEANUP => 0,
- );
- chmod 0777 &~ umask, $packagedir; # may fail
- my $f;
- for $f (@dirents) { # is already without "." and ".."
- my $from = File::Spec->catfile($from_dir,$f);
- my $to = File::Spec->catfile($packagedir,$f);
- unless (File::Copy::move($from,$to)) {
- my $err = $!;
- $from = File::Spec->rel2abs($from);
- Carp::confess("Couldn't move $from to $to: $err");
- }
+ $tdir_base = $userid;
+ $from_dir = File::Spec->curdir;
+ @dirents = @readdir;
+ }
+ eval { File::Path::mkpath $builddir; };
+ if ($@) {
+ $CPAN::Frontend->mydie("Cannot create directory $builddir: $@");
+ }
+ my $packagedir;
+ my $eexist = $CPAN::META->has_usable("Errno") ? &Errno::EEXIST : undef;
+ for(my $suffix = 0; ; $suffix++) {
+ $packagedir = File::Spec->catdir($builddir, "$tdir_base-$suffix");
+ my $parent = $builddir;
+ mkdir($packagedir, 0777) and last;
+ if((defined($eexist) && $! != $eexist) || $suffix == 999) {
+ $CPAN::Frontend->mydie("Cannot create directory $packagedir: $!\n");
}
- } else { # older code below, still better than nothing when there is no File::Temp
- my($distdir);
- if (@readdir == 1 && -d $readdir[0]) {
- $distdir = $readdir[0];
- $packagedir = File::Spec->catdir($builddir,$distdir);
- $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
- if $CPAN::DEBUG;
- -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
- "$packagedir\n");
- File::Path::rmtree($packagedir);
- unless (File::Copy::move($distdir,$packagedir)) {
- $CPAN::Frontend->unrecoverable_error(<<EOF);
-Couldn't move '$distdir' to '$packagedir': $!
-
-Cannot continue: Please find the reason why I cannot move
-$builddir/tmp-$$/$distdir
-to
-$packagedir
-and fix the problem, then retry
-
-EOF
- }
- $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
- $distdir,
- $packagedir,
- -e $packagedir,
- -d $packagedir,
- )) if $CPAN::DEBUG;
- } else {
- my $userid = $self->cpan_userid;
- CPAN->debug("userid[$userid]") if $CPAN::DEBUG;
- if (!$userid or $userid eq "N/A") {
- $userid = "anon";
- }
- my $pragmatic_dir = $userid . '000';
- $pragmatic_dir =~ s/\W_//g;
- $pragmatic_dir++ while -d "../$pragmatic_dir";
- $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
- $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
- File::Path::mkpath($packagedir);
- my($f);
- for $f (@readdir) { # is already without "." and ".."
- my $to = File::Spec->catdir($packagedir,$f);
- File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
- }
+ }
+ my $f;
+ for $f (@dirents) { # is already without "." and ".."
+ my $from = File::Spec->catfile($from_dir,$f);
+ my $to = File::Spec->catfile($packagedir,$f);
+ unless (File::Copy::move($from,$to)) {
+ my $err = $!;
+ $from = File::Spec->rel2abs($from);
+ $CPAN::Frontend->mydie("Couldn't move $from to $to: $err");
}
}
$self->{build_dir} = $packagedir;
return 1 unless @prereq;
$self->debug(\@prereq) if $CPAN::DEBUG;
if ($self->{configure_requires_later}) {
- for my $k (keys %{$self->{configure_requires_later_for}||{}}) {
+ for my $k (sort keys %{$self->{configure_requires_later_for}||{}}) {
if ($self->{configure_requires_later_for}{$k}>1) {
my $type = "";
for my $p (@prereq) {
"system()\n");
}
}
- my $system_ok;
+ my ($system_ok, $system_err);
if ($want_expect) {
# XXX probably want to check _should_report here and
# warn about not being able to use CPAN::Reporter with expect
$system_ok = ! $ret;
}
else {
- $system_ok = system($system) == 0;
+ my $rc = system($system);
+ $system_ok = $rc == 0;
+ $system_err = $! if $rc == -1;
}
$self->introduce_myself;
if ( $system_ok ) {
$self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
$self->{make} = CPAN::Distrostatus->new("NO");
$CPAN::Frontend->mywarn(" $system -- NOT OK\n");
+ $CPAN::Frontend->mywarn(" $system_err\n") if defined $system_err;
}
$self->store_persistent_state;
$CPAN::META->has_usable("CPAN::Meta::Requirements")
or die "CPAN::Meta::Requirements not available";
my $merged = CPAN::Meta::Requirements->from_string_hash($merged_hash);
- my @merged = $merged->required_modules;
+ my @merged = sort $merged->required_modules;
CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG;
NEED: for my $need_module ( @merged ) {
my $need_version = $merged->requirements_for_module($need_module);
}
my $areq;
my $do_replace;
- while (my($k,$v) = each %{$req||{}}) {
+ foreach my $k (sort keys %{$req||{}}) {
+ my $v = $req->{$k};
next unless defined $v;
if ($v =~ /\d/) {
$areq->{$k} = $v;
my @prereq;
# local $CPAN::DEBUG = 16; # Distribution
- for my $m (keys %{$self->{sponsored_mods}}) {
+ for my $m (sort keys %{$self->{sponsored_mods}}) {
next unless $self->{sponsored_mods}{$m} > 0;
my $m_obj = CPAN::Shell->expand("Module",$m) or next;
# XXX we need available_version which reflects
use vars qw(
$VERSION
);
-$VERSION = "5.5006";
+$VERSION = "5.5007";
#-> sub CPAN::FTP::ftp_statistics
# if they want to rewrite, they need to pass in a filehandle
while (!CPAN::_flock($fh, $locktype|LOCK_NB)) {
$waitstart ||= localtime();
if ($sleep>3) {
- $CPAN::Frontend->mywarn("Waiting for a read lock on '$file' (since $waitstart)\n");
+ my $now = localtime();
+ $CPAN::Frontend->mywarn("$now: waiting for read lock on '$file' (since $waitstart)\n");
}
- $CPAN::Frontend->mysleep($sleep);
+ sleep($sleep); # this sleep must not be overridden;
+ # Frontend->mysleep with AUTOMATED_TESTING has
+ # provoked complete lock contention on my NFS
if ($sleep <= 3) {
$sleep+=0.33;
- } elsif ($sleep <=6) {
+ } elsif ($sleep <= 6) {
$sleep+=0.11;
+ } else {
+ # retry to get a fresh handle. If it is NFS and the handle is stale, we will never get an flock
+ open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!");
}
}
my $stats = eval { CPAN->_yaml_loadfile($file); };
use File::Spec ();
use CPAN::Mirrors ();
use vars qw($VERSION $auto_config);
-$VERSION = "5.5307";
+$VERSION = "5.5309";
=head1 NAME
}
} elsif (0 == length $matcher) {
} elsif (0 && $matcher eq "~") { # extremely buggy, but a nice idea
- my @unconfigured = grep { not exists $CPAN::Config->{$_}
+ my @unconfigured = sort grep { not exists $CPAN::Config->{$_}
or not defined $CPAN::Config->{$_}
or not length $CPAN::Config->{$_}
} keys %$CPAN::Config;
$CPAN::Frontend->myprint("\nWriting $configpm for bootstrap...\n");
delete $CPAN::Config->{install_help}; # temporary only
CPAN::HandleConfig->commit;
- my $dist;
- if ( $dist = CPAN::Shell->expand('Module', 'local::lib')->distribution ) {
+ my($dist, $locallib);
+ $locallib = CPAN::Shell->expand('Module', 'local::lib');
+ if ( $locallib and $dist = $locallib->distribution ) {
# this is a hack to force bootstrapping
$dist->{prefs}{pl}{commandline} = "$^X Makefile.PL --bootstrap";
# Set @INC for this process so we find things as they bootstrap
=cut
-$VERSION = "5.5006"; # see also CPAN::Config::VERSION at end of file
+$VERSION = "5.5007"; # see also CPAN::Config::VERSION at end of file
%can = (
commit => "Commit changes to disk",
sprintf "\t%-18s => %s\n",
"[$_]",
defined $v->{$_} ? "[$v->{$_}]" : "undef"
- } keys %$v;
+ } sort keys %$v;
}
$CPAN::Frontend->myprint(
join(
return join "", @m;
}
return "$v" unless $t eq 'HASH';
- my(@m, $key, $val);
- while (($key,$val) = each %$v) {
- last unless defined $key; # cautious programming in case (undef,undef) is true
+ my @m;
+ foreach my $key (sort keys %$v) {
+ my $val = $v->{$key};
push(@m,"q[$key]=>".$self->neatvalue($val)) ;
}
return "{ ".join(', ',@m)." }";
use strict;
use vars qw($AUTOLOAD $VERSION);
- $VERSION = "5.5006";
+ $VERSION = "5.5007";
# formerly CPAN::HandleConfig was known as CPAN::Config
sub AUTOLOAD { ## no critic
package CPAN::Index;
use strict;
use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED $VERSION);
-$VERSION = "1.9601";
+$VERSION = "2.12";
@CPAN::Index::ISA = qw(CPAN::Debug);
$LAST_TIME ||= 0;
$DATE_OF_03 ||= 0;
my $until = keys(%$ret);
my $painted = 0;
CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
- for (keys %$ret) {
+ for (sort keys %$ret) {
my $obj = $CPAN::META->instance("CPAN::Module",$_);
delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
$obj->set(%{$ret->{$_}});
package CPAN::Mirrors;
use strict;
use vars qw($VERSION $urllist $silent);
-$VERSION = "1.9601";
+$VERSION = "2.12";
use Carp;
use FileHandle;
sub continents {
my ($self) = @_;
- return keys %{$self->{geography}};
+ return sort keys %{$self->{geography}};
}
=item countries( [CONTINENTS] )
@continents = $self->continents unless @continents;
my @countries;
for my $c (@continents) {
- push @countries, keys %{ $self->{geography}{$c} };
+ push @countries, sort keys %{ $self->{geography}{$c} };
}
return @countries;
}
use strict;
use warnings;
-our $VERSION = '0.95';
+our $VERSION = '0.96';
require CPAN;
=head1 SYNOPSIS
- package My::Plugin;
- use base 'CPAN::Plugin';
+ package CPAN::Plugin::Flurb;
+ use parent 'CPAN::Plugin';
sub post_test {
my ($self, $distribution_object) = @_;
"CPAN/Tarzip.pm",
"CPAN/Version.pm",
);
-$VERSION = "5.5005";
+$VERSION = "5.5006";
# record the initial timestamp for reload.
$reload = { map {$INC{$_} ? ($_,(stat $INC{$_})[9]) : ()} @relo };
@CPAN::Shell::ISA = qw(CPAN::Debug);
test make test (implies make) readme display these README files
install make install (implies test) perldoc display POD documentation
-Upgrade
- r WORDs or /REGEXP/ or NONE report updates for some/matching/all modules
+Upgrade installed modules
+ r WORDs or /REGEXP/ or NONE report updates for some/matching/all
upgrade WORDs or /REGEXP/ or NONE upgrade some/matching/all modules
Pragmas
$s->{dltime} += $dltime;
}
my $res;
- for my $url (keys %{$S{ok}}) {
+ for my $url (sort keys %{$S{ok}}) {
next if $S{ok}{$url}{dltime} == 0; # div by zero
push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)},
$S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime},
$url,
];
}
- for my $url (keys %{$S{no}}) {
+ for my $url (sort keys %{$S{no}}) {
push @{$res->{no}}, [$S{no}{$url},
$url,
];
}
CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
if $CPAN::DEBUG;
+ my $includefile;
+ if ($includefile = $INC{$f} and -e $includefile) {
+ $f = $includefile;
+ }
delete $INC{$f};
local @INC = @inc;
eval "require '$f'";
sub find_failed {
my($self,$only_id) = @_;
my @failed;
- DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
+ DIST: for my $d (sort { $a->id cmp $b->id } $CPAN::META->all_objects("CPAN::Distribution")) {
my $failed = "";
NAY: for my $nosayer ( # order matters!
"unwrapped",
use strict;
use vars qw($VERSION);
-use App::Cpan '1.60_02';
-$VERSION = '1.61';
+use App::Cpan '1.64';
+$VERSION = '1.64';
my $rc = App::Cpan->run( @ARGV );
cpan module_name [ module_name ... ]
# with switches, installs modules with extra behavior
- cpan [-cfgimtTw] module_name [ module_name ... ]
+ cpan [-cfFimtTw] module_name [ module_name ... ]
+
+ # use local::lib
+ cpan -I module_name [ module_name ... ]
+
+ # one time mirror override for faster mirrors
+ cpan -p ...
# with just the dot, install from the distribution in the
# current directory
# without arguments, starts CPAN.pm shell
cpan
- # force install modules (usually those that fail tests)
- cpan -f module_name [ module_name ... ]
-
- # install modules but without testing them
- cpan -T module_name [ module_name ... ]
-
- # dump the configuration
- cpan -J
-
- # load a different configuration to install Module::Foo
- cpan -j some/other/file Module::Foo
-
# without arguments, but some switches
- cpan [-ahrvACDlLO]
+ cpan [-ahpruvACDLOPX]
=head1 DESCRIPTION
=item -D module [ module ... ]
-Show the module details.
+Show the module details. This prints one line for each out-of-date module
+(meaning, modules locally installed but have newer versions on CPAN).
+Each line has three columns: module name, local version, and CPAN
+version.
=item -f
Print a help message and exit. When you specify C<-h>, it ignores all
of the other options and arguments.
-=item -i
+=item -i module [ module ... ]
-Install the specified modules.
+Install the specified modules. With no other switches, this switch
+is implied.
=item -I
-Load C<local::lib> (think like C<-I> for loading lib paths).
+Load C<local::lib> (think like C<-I> for loading lib paths). Too bad
+C<-l> was already taken.
=item -j Config.pm
Make the specified modules.
+=item -M mirror1,mirror2,...
+
+A comma-separated list of mirrors to use for just this run. The C<-P>
+option can find them for you automatically.
+
+=item -n
+
+Do a dry run, but don't actually install anything. (unimplemented)
+
=item -O
Show the out-of-date modules.
=item -p
-Ping the configured mirrors
+Ping the configured mirrors and print a report
=item -P
-Find the best mirrors you could be using (but doesn't configure them just yet)
+Find the best mirrors you could be using and use them for the current
+session.
=item -r
Recompiles dynamically loaded modules with CPAN::Shell->recompile.
-=item -t
+=item -s
+
+Drop in the CPAN.pm shell. This command does this automatically if you don't
+specify any arguments.
+
+=item -t module [ module ... ]
Run a `make test` on the specified modules.
Turn on cpan warnings. This checks various things, like directory permissions,
and tells you about problems you might have.
+=item -x module [ module ... ]
+
+Find close matches to the named modules that you think you might have
+mistyped. This requires the optional installation of Text::Levenshtein or
+Text::Levenshtein::Damerau.
+
+=item -X
+
+Dump all the namespaces to standard output.
+
=back
=head2 Examples
# force install modules ( must use -i )
cpan -fi CGI::Minimal URI
-=head1 ENVIRONMENT VARIABLES
+ # install modules but without testing them
+ cpan -Ti CGI::Minimal URI
-=over 4
+=head2 Environment variables
There are several components in CPAN.pm that use environment variables.
The build tools, L<ExtUtils::MakeMaker> and L<Module::Build> use some,
=over 4
+=item NONINTERACTIVE_TESTING
+
+Assume no one is paying attention and skips prompts for distributions
+that do that correctly. C<cpan(1)> sets this to C<1> unless it already
+has a value (even if that value is false).
+
+=item PERL_MM_USE_DEFAULT
+
+Use the default answer for a prompted questions. C<cpan(1)> sets this
+to C<1> unless it already has a value (even if that value is false).
+
=item CPAN_OPTS
-C<cpan> splits this variable on whitespace and prepends that list to C<@ARGV>
-before it processes the command-line arguments. For instance, if you always
-want to use C<local:lib>, you can set C<CPAN_OPTS> to C<-I>.
+As with C<PERL5OPTS>, a string of additional C<cpan(1)> options to
+add to those you specify on the command line.
=item CPANSCRIPT_LOGLEVEL
The path to the C<git> binary to use for the Git features. The default
is C</usr/local/bin/git>.
-=item NONINTERACTIVE_TESTING
-
-Assume no one is paying attention and skips prompts for distributions
-that do that correctly. C<cpan(1)> sets this to C<1> unless it already
-has a value (even if that value is false).
-
-=item PERL_MM_USE_DEFAULT
-
-Use the default answer for a prompted questions. C<cpan(1)> sets this
-to C<1> unless it already has a value (even if that value is false).
-
-=back
-
=back
=head1 EXIT VALUES
=head1 COPYRIGHT
-Copyright (c) 2001-2014, brian d foy, All Rights Reserved.
+Copyright (c) 2001-2015, brian d foy, All Rights Reserved.
You may redistribute this under the same terms as Perl itself.
@ISA = qw(Exporter);
@EXPORT = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f test_d chmod
dos2unix);
-$VERSION = '7.10';
+$VERSION = '7.18';
$VERSION = eval $VERSION;
my $Is_VMS = $^O eq 'VMS';
open ORIG, $_ or do { warn "dos2unix can't open $_: $!"; return };
open TEMP, ">$temp" or
do { warn "dos2unix can't create .dos2unix_tmp: $!"; return };
+ binmode ORIG; binmode TEMP;
while (my $line = <ORIG>) {
$line =~ s/\015\012/\012/g;
print TEMP $line;
our @EXPORT = qw(test_harness pod2man perllocal_install uninstall
warn_if_old_packlist test_s cp_nonempty);
-our $VERSION = '7.10_01';
+our $VERSION = '7.18';
+$VERSION = eval $VERSION;
my $Is_VMS = $^O eq 'VMS';
-eval { require Time::HiRes; die unless Time::HiRes->can("stat"); };
-*mtime = $@ ?
- sub { [ stat($_[0])]->[9] } :
- sub { [Time::HiRes::stat($_[0])]->[9] } ;
+sub mtime {
+ no warnings 'redefine';
+ local $@;
+ *mtime = (eval { require Time::HiRes } && defined &Time::HiRes::stat)
+ ? sub { (Time::HiRes::stat($_[0]))[9] }
+ : sub { ( stat($_[0]))[9] }
+ ;
+ goto &mtime;
+}
=head1 NAME
: @ARGV;
my $pod;
- $pod = sprintf <<POD, scalar localtime;
- =head2 %s: C<$type> L<$name|$name>
+ $pod = sprintf <<'POD', scalar(localtime), $type, $name, $name;
+ =head2 %s: C<%s> L<%s|%s>
=over 4
use strict;
-our $VERSION = '7.10_01';
+our $VERSION = '7.18';
+$VERSION = eval $VERSION;
use File::Spec;
require ExtUtils::Liblist::Kid;
sub lsdir {
shift;
my $rex = qr/$_[1]/;
- opendir DIR, $_[0];
- my @out = grep /$rex/, readdir DIR;
- closedir DIR;
+ opendir my $dir_fh, $_[0];
+ my @out = grep /$rex/, readdir $dir_fh;
+ closedir $dir_fh;
return @out;
}
use strict;
use warnings;
-our $VERSION = '7.10_01';
+our $VERSION = '7.18';
+$VERSION = eval $VERSION;
use ExtUtils::MakeMaker::Config;
use Cwd 'cwd';
$libs_seen{$fullname} = 1 if $path; # why is this a special case?
}
- my @libs = keys %libs_seen;
+ my @libs = sort keys %libs_seen;
return ( '', '', '', '', ( $give_libs ? \@libs : () ) ) unless @extralibs;
use strict;
use ExtUtils::MakeMaker::Config;
-our $VERSION = '7.10_01';
+our $VERSION = '7.18';
+$VERSION = eval $VERSION;
require ExtUtils::Liblist;
require ExtUtils::MakeMaker;
package ExtUtils::MM_AIX;
use strict;
-our $VERSION = '7.10_01';
+our $VERSION = '7.18';
+$VERSION = eval $VERSION;
require ExtUtils::MM_Unix;
our @ISA = qw(ExtUtils::MM_Unix);
-use ExtUtils::MakeMaker qw(neatvalue);
-
-
=head1 NAME
ExtUtils::MM_AIX - AIX specific subclass of ExtUtils::MM_Unix
sub dlsyms {
my($self,%attribs) = @_;
+ return '' unless $self->needs_linking;
+ my @m;
+ # these will need XSMULTI-fying but maybe that already happens
+ push @m,"\ndynamic :: $self->{BASEEXT}.exp\n\n"
+ unless $self->{SKIPHASH}{'dynamic'}; # dynamic and static are subs, so...
+ push @m,"\nstatic :: $self->{BASEEXT}.exp\n\n"
+ unless $self->{SKIPHASH}{'static'}; # we avoid a warning if we tick them
+ join "\n", @m, $self->xs_dlsyms_iterator(\%attribs);
+}
- return '' unless $self->needs_linking();
-
- my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {};
- my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || [];
- my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || [];
- my(@m);
-
- push(@m,"
-dynamic :: $self->{BASEEXT}.exp
-
-") unless $self->{SKIPHASH}{'dynamic'}; # dynamic and static are subs, so...
-
- push(@m,"
-static :: $self->{BASEEXT}.exp
+=head3 xs_dlsyms_ext
-") unless $self->{SKIPHASH}{'static'}; # we avoid a warning if we tick them
+On AIX, is C<.exp>.
- push(@m,"
-$self->{BASEEXT}.exp: Makefile.PL
-",' $(PERLRUN) -e \'use ExtUtils::Mksymlists; \\
- Mksymlists("NAME" => "',$self->{NAME},'", "DL_FUNCS" => ',
- neatvalue($funcs), ', "FUNCLIST" => ', neatvalue($funclist),
- ', "DL_VARS" => ', neatvalue($vars), ');\'
-');
+=cut
- join('',@m);
+sub xs_dlsyms_ext {
+ '.exp';
}
-
=head1 AUTHOR
Michael G Schwern <schwern@pobox.com> with code from ExtUtils::MM_Unix
package ExtUtils::MM_Any;
use strict;
-our $VERSION = '7.10_01';
+our $VERSION = '7.18';
+$VERSION = eval $VERSION;
use Carp;
use File::Spec;
BEGIN { our @ISA = qw(File::Spec); }
# We need $Verbose
-use ExtUtils::MakeMaker qw($Verbose);
+use ExtUtils::MakeMaker qw($Verbose neatvalue _sprintf562);
use ExtUtils::MakeMaker::Config;
# So we don't have to keep calling the methods over and over again,
# we have these globals to cache the values. Faster and shrtr.
my $Curdir = __PACKAGE__->curdir;
-my $Rootdir = __PACKAGE__->rootdir;
-my $Updir = __PACKAGE__->updir;
+#my $Updir = __PACKAGE__->updir;
+my $METASPEC_URL = 'https://metacpan.org/pod/CPAN::Meta::Spec';
+my $METASPEC_V = 2;
=head1 NAME
}
+=head3 make_type
+
+Returns a suitable string describing the type of makefile being written.
+
+=cut
+
+# override if this isn't suitable!
+sub make_type { return 'Unix-style'; }
+
+
+=head3 stashmeta
+
+ my @recipelines = $MM->stashmeta($text, $file);
+
+Generates a set of C<@recipelines> which will result in the literal
+C<$text> ending up in literal C<$file> when the recipe is executed. Call
+it once, with all the text you want in C<$file>. Make macros will not
+be expanded, so the locations will be fixed at configure-time, not
+at build-time.
+
+=cut
+
+sub stashmeta {
+ my($self, $text, $file) = @_;
+ $self->echo($text, $file, { allow_variables => 0, append => 0 });
+}
+
+
=head3 echo
my @commands = $MM->echo($text);
Example of use:
- my $make = map "\t$_\n", $MM->echo($text, $file);
+ my $make = join '', map "\t$_\n", $MM->echo($text, $file);
=cut
$oneliner = $MM->oneliner('print "Foo\n"');
$make = '$oneliner > somefile';
-All dollar signs must be doubled in the $perl_code if you expect them
-to be interpreted normally, otherwise it will be considered a make
-macro. Also remember to quote make macros else it might be used as a
-bareword. For example:
+Dollar signs in the $perl_code will be protected from make using the
+C<quote_literal> method, unless they are recognised as being a make
+variable, C<$(varname)>, in which case they will be left for make
+to expand. Remember to quote make macros else it might be used as a
+bareword. For example:
# Assign the value of the $(VERSION_FROM) make macro to $vf.
- $oneliner = $MM->oneliner('$$vf = "$(VERSION_FROM)"');
+ $oneliner = $MM->oneliner('$vf = "$(VERSION_FROM)"');
Its currently very simple and may be expanded sometime in the figure
to include more flexible code and switches.
=cut
+sub _xs_list_basenames {
+ my ($self) = @_;
+ map { (my $b = $_) =~ s/\.xs$//; $b } sort keys %{ $self->{XS} };
+}
+
sub blibdirs_target {
my $self = shift;
bin script
man1dir man3dir
);
+ if ($self->{XSMULTI}) {
+ for my $ext ($self->_xs_list_basenames) {
+ my ($v, $d, $f) = File::Spec->splitpath($ext);
+ my @d = File::Spec->splitdir($d);
+ shift @d if $d[0] eq 'lib';
+ push @dirs, $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f);
+ }
+ }
my @exists = map { $_.'$(DFSEP).exists' } @dirs;
');
my @files = sort values %{$self->{XS}}; # .c files from *.xs files
+ push @files, map {
+ my $file = $_;
+ map { $file.$_ } $self->{OBJ_EXT}, qw(.def _def.old .bs .bso .exp .base);
+ } $self->_xs_list_basenames;
my @dirs = qw(blib);
# Normally these are all under blib but they might have been
}
+=head3 xs_dlsyms_ext
+
+Returns file-extension for C<xs_make_dlsyms> method's output file,
+including any "." character.
+
+=cut
+
+sub xs_dlsyms_ext {
+ die "Pure virtual method";
+}
+
+=head3 xs_dlsyms_extra
+
+Returns any extra text to be prepended to the C<$extra> argument of
+C<xs_make_dlsyms>.
+
+=cut
+
+sub xs_dlsyms_extra {
+ '';
+}
+
+=head3 xs_dlsyms_iterator
+
+Iterates over necessary shared objects, calling C<xs_make_dlsyms> method
+for each with appropriate arguments.
+
+=cut
+
+sub xs_dlsyms_iterator {
+ my ($self, $attribs) = @_;
+ if ($self->{XSMULTI}) {
+ my @m;
+ for my $ext ($self->_xs_list_basenames) {
+ my @parts = File::Spec->splitdir($ext);
+ shift @parts if $parts[0] eq 'lib';
+ my $name = join '::', @parts;
+ push @m, $self->xs_make_dlsyms(
+ $attribs,
+ $ext . $self->xs_dlsyms_ext,
+ "$ext.xs",
+ $name,
+ $parts[-1],
+ {}, [], {}, [],
+ $self->xs_dlsyms_extra . q!, 'FILE' => ! . neatvalue($ext),
+ );
+ }
+ return join "\n", @m;
+ } else {
+ return $self->xs_make_dlsyms(
+ $attribs,
+ $self->{BASEEXT} . $self->xs_dlsyms_ext,
+ 'Makefile.PL',
+ $self->{NAME},
+ $self->{DLBASE},
+ $attribs->{DL_FUNCS} || $self->{DL_FUNCS} || {},
+ $attribs->{FUNCLIST} || $self->{FUNCLIST} || [],
+ $attribs->{IMPORTS} || $self->{IMPORTS} || {},
+ $attribs->{DL_VARS} || $self->{DL_VARS} || [],
+ $self->xs_dlsyms_extra,
+ );
+ }
+}
+
+=head3 xs_make_dlsyms
+
+ $self->xs_make_dlsyms(
+ \%attribs, # hashref from %attribs in caller
+ "$self->{BASEEXT}.def", # output file for Makefile target
+ 'Makefile.PL', # dependency
+ $self->{NAME}, # shared object's "name"
+ $self->{DLBASE}, # last ::-separated part of name
+ $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {}, # various params
+ $attribs{FUNCLIST} || $self->{FUNCLIST} || [],
+ $attribs{IMPORTS} || $self->{IMPORTS} || {},
+ $attribs{DL_VARS} || $self->{DL_VARS} || [],
+ # optional extra param that will be added as param to Mksymlists
+ );
+
+Utility method that returns Makefile snippet to call C<Mksymlists>.
+
+=cut
+
+sub xs_make_dlsyms {
+ my ($self, $attribs, $target, $dep, $name, $dlbase, $funcs, $funclist, $imports, $vars, $extra) = @_;
+ my @m = (
+ "\n$target: $dep\n",
+ q! $(PERLRUN) -MExtUtils::Mksymlists \\
+ -e "Mksymlists('NAME'=>\"!, $name,
+ q!\", 'DLBASE' => '!,$dlbase,
+ # The above two lines quoted differently to work around
+ # a bug in the 4DOS/4NT command line interpreter. The visible
+ # result of the bug was files named q('extension_name',) *with the
+ # single quotes and the comma* in the extension build directories.
+ q!', 'DL_FUNCS' => !,neatvalue($funcs),
+ q!, 'FUNCLIST' => !,neatvalue($funclist),
+ q!, 'IMPORTS' => !,neatvalue($imports),
+ q!, 'DL_VARS' => !, neatvalue($vars)
+ );
+ push @m, $extra if defined $extra;
+ push @m, qq!);"\n!;
+ join '', @m;
+}
+
=head3 dynamic (o)
Defines the dynamic target.
my($self) = shift;
'
-dynamic :: $(FIRST_MAKEFILE) $(BOOTSTRAP) $(INST_DYNAMIC)
+dynamic :: $(FIRST_MAKEFILE) config $(INST_BOOT) $(INST_DYNAMIC)
$(NOECHO) $(NOOP)
';
}
}
my $manify = <<END;
-manifypods : pure_all $dependencies
+manifypods : pure_all config $dependencies
END
my @man_cmds;
foreach my $section (qw(1 3)) {
my $pods = $self->{"MAN${section}PODS"};
- my $p2m = sprintf <<CMD, $] > 5.008 ? " -u" : "";
- \$(NOECHO) \$(POD2MAN) --section=$section --perm_rw=\$(PERM_RW)%s
+ my $p2m = sprintf <<'CMD', $section, $] > 5.008 ? " -u" : "";
+ $(NOECHO) $(POD2MAN) --section=%s --perm_rw=$(PERM_RW)%s
CMD
push @man_cmds, $self->split_command($p2m, map {($_,$pods->{$_})} sort keys %$pods);
}
return $manify;
}
-sub _has_cpan_meta {
- return eval {
- require CPAN::Meta;
- CPAN::Meta->VERSION(2.112150);
- 1;
- };
+{
+ my $has_cpan_meta;
+ sub _has_cpan_meta {
+ return $has_cpan_meta if defined $has_cpan_meta;
+ return $has_cpan_meta = !!eval {
+ require CPAN::Meta;
+ CPAN::Meta->VERSION(2.112150);
+ 1;
+ };
+ }
}
=head3 metafile_target
$(NOECHO) $(NOOP)
MAKE_FRAG
- my %metadata = $self->metafile_data(
+ my $metadata = $self->metafile_data(
$self->{META_ADD} || {},
$self->{META_MERGE} || {},
);
- _fix_metadata_before_conversion( \%metadata );
-
- # paper over validation issues, but still complain, necessary because
- # there's no guarantee that the above will fix ALL errors
- my $meta = eval { CPAN::Meta->create( \%metadata, { lazy_validation => 1 } ) };
- warn $@ if $@ and
- $@ !~ /encountered CODE.*, but JSON can only represent references to arrays or hashes/;
+ my $meta = $self->_fix_metadata_before_conversion( $metadata );
- # use the original metadata straight if the conversion failed
- # or if it can't be stringified.
- if( !$meta ||
- !eval { $meta->as_string( { version => "1.4" } ) } ||
- !eval { $meta->as_string }
- )
- {
- $meta = bless \%metadata, 'CPAN::Meta';
- }
-
- my @write_metayml = $self->echo(
+ my @write_metayml = $self->stashmeta(
$meta->as_string({version => "1.4"}), 'META_new.yml'
);
- my @write_metajson = $self->echo(
- $meta->as_string(), 'META_new.json'
+ my @write_metajson = $self->stashmeta(
+ $meta->as_string({version => "2.0"}), 'META_new.json'
);
my $metayml = join("\n\t", @write_metayml);
=head3 _fix_metadata_before_conversion
- _fix_metadata_before_conversion( \%metadata );
+ $mm->_fix_metadata_before_conversion( \%metadata );
Fixes errors in the metadata before it's handed off to CPAN::Meta for
conversion. This hopefully results in something that can be used further
=cut
sub _fix_metadata_before_conversion {
- my ( $metadata ) = @_;
+ my ( $self, $metadata ) = @_;
# we should never be called unless this already passed but
# prefer to be defensive in case somebody else calls this
my $bad_version = $metadata->{version} &&
!CPAN::Meta::Validator->new->version( 'version', $metadata->{version} );
-
# just delete all invalid versions
if( $bad_version ) {
warn "Can't parse version '$metadata->{version}'\n";
$metadata->{version} = '';
}
- my $validator = CPAN::Meta::Validator->new( $metadata );
- return if $validator->is_valid;
-
+ my $validator2 = CPAN::Meta::Validator->new( $metadata );
+ my @errors;
+ push @errors, $validator2->errors if !$validator2->is_valid;
+ my $validator14 = CPAN::Meta::Validator->new(
+ {
+ %$metadata,
+ 'meta-spec' => { version => 1.4 },
+ }
+ );
+ push @errors, $validator14->errors if !$validator14->is_valid;
# fix non-camelcase custom resource keys (only other trick we know)
- for my $error ( $validator->errors ) {
+ for my $error ( @errors ) {
my ( $key ) = ( $error =~ /Custom resource '(.*)' must be in CamelCase./ );
next if !$key;
( my $new_key = $key ) =~ s/[^_a-zA-Z]//g;
# if that doesn't work, uppercase first one
- $new_key = ucfirst $new_key if !$validator->custom_1( $new_key );
+ $new_key = ucfirst $new_key if !$validator14->custom_1( $new_key );
# copy to new key if that worked
$metadata->{resources}{$new_key} = $metadata->{resources}{$key}
- if $validator->custom_1( $new_key );
+ if $validator14->custom_1( $new_key );
# and delete old one in any case
delete $metadata->{resources}{$key};
}
- return;
+ # paper over validation issues, but still complain, necessary because
+ # there's no guarantee that the above will fix ALL errors
+ my $meta = eval { CPAN::Meta->create( $metadata, { lazy_validation => 1 } ) };
+ warn $@ if $@ and
+ $@ !~ /encountered CODE.*, but JSON can only represent references to arrays or hashes/;
+
+ # use the original metadata straight if the conversion failed
+ # or if it can't be stringified.
+ if( !$meta ||
+ !eval { $meta->as_string( { version => $METASPEC_V } ) } ||
+ !eval { $meta->as_string }
+ ) {
+ $meta = bless $metadata, 'CPAN::Meta';
+ }
+
+ my $now_license = $meta->as_struct({ version => 2 })->{license};
+ if ($self->{LICENSE} and $self->{LICENSE} ne 'unknown' and
+ @{$now_license} == 1 and $now_license->[0] eq 'unknown'
+ ) {
+ warn "Invalid LICENSE value '$self->{LICENSE}' ignored\n";
+ }
+
+ $meta;
}
=head3 metafile_data
- my @metadata_pairs = $mm->metafile_data(\%meta_add, \%meta_merge);
+ my $metadata_hashref = $mm->metafile_data(\%meta_add, \%meta_merge);
Returns the data which MakeMaker turns into the META.yml file
-and the META.json file.
+and the META.json file. It is always in version 2.0 of the format.
Values of %meta_add will overwrite any existing metadata in those
keys. %meta_merge will be merged with them.
my $self = shift;
my($meta_add, $meta_merge) = @_;
+ $meta_add ||= {};
+ $meta_merge ||= {};
+
+ my $version = _normalize_version($self->{VERSION});
+ my $release_status = ($version =~ /_/) ? 'unstable' : 'stable';
my %meta = (
# required
- name => $self->{DISTNAME},
- version => _normalize_version($self->{VERSION}),
abstract => $self->{ABSTRACT} || 'unknown',
- license => $self->{LICENSE} || 'unknown',
+ author => defined($self->{AUTHOR}) ? $self->{AUTHOR} : ['unknown'],
dynamic_config => 1,
-
- # optional
- distribution_type => $self->{PM} ? 'module' : 'script',
-
- no_index => {
- directory => [qw(t inc)]
- },
-
generated_by => "ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION",
+ license => [ $self->{LICENSE} || 'unknown' ],
'meta-spec' => {
- url => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
- version => 1.4
+ url => $METASPEC_URL,
+ version => $METASPEC_V,
},
+ name => $self->{DISTNAME},
+ release_status => $release_status,
+ version => $version,
+
+ # optional
+ no_index => { directory => [qw(t inc)] },
);
+ $self->_add_requirements_to_meta(\%meta);
- # The author key is required and it takes a list.
- $meta{author} = defined $self->{AUTHOR} ? $self->{AUTHOR} : [];
+ if (!eval { require JSON::PP; require CPAN::Meta::Converter; CPAN::Meta::Converter->VERSION(2.141170) }) {
+ return \%meta;
+ }
- {
- my $vers = _metaspec_version( $meta_add, $meta_merge );
- my $method = $vers =~ m!^2!
- ? '_add_requirements_to_meta_v2'
- : '_add_requirements_to_meta_v1_4';
- %meta = $self->$method( %meta );
+ # needs to be based on the original version
+ my $v1_add = _metaspec_version($meta_add) !~ /^2/;
+
+ for my $frag ($meta_add, $meta_merge) {
+ $frag = CPAN::Meta::Converter->new($frag, default_version => "1.4")->upgrade_fragment;
}
+ # if we upgraded a 1.x _ADD fragment, we gave it a prereqs key that
+ # will override all prereqs, which is more than the user asked for;
+ # instead, we'll go inside the prereqs and override all those
while( my($key, $val) = each %$meta_add ) {
- $meta{$key} = $val;
+ if ($v1_add and $key eq 'prereqs') {
+ $meta{$key}{$_} = $val->{$_} for keys %$val;
+ } elsif ($key ne 'meta-spec') {
+ $meta{$key} = $val;
+ }
}
while( my($key, $val) = each %$meta_merge ) {
+ next if $key eq 'meta-spec';
$self->_hash_merge(\%meta, $key, $val);
}
- return %meta;
+ return \%meta;
}
=cut
+sub _add_requirements_to_meta {
+ my ( $self, $meta ) = @_;
+ # Check the original args so we can tell between the user setting it
+ # to an empty hash and it just being initialized.
+ $meta->{prereqs}{configure}{requires} = $self->{ARGS}{CONFIGURE_REQUIRES}
+ ? $self->{CONFIGURE_REQUIRES}
+ : { 'ExtUtils::MakeMaker' => 0, };
+ $meta->{prereqs}{build}{requires} = $self->{ARGS}{BUILD_REQUIRES}
+ ? $self->{BUILD_REQUIRES}
+ : { 'ExtUtils::MakeMaker' => 0, };
+ $meta->{prereqs}{test}{requires} = $self->{TEST_REQUIRES}
+ if $self->{ARGS}{TEST_REQUIRES};
+ $meta->{prereqs}{runtime}{requires} = $self->{PREREQ_PM}
+ if $self->{ARGS}{PREREQ_PM};
+ $meta->{prereqs}{runtime}{requires}{perl} = _normalize_version($self->{MIN_PERL_VERSION})
+ if $self->{MIN_PERL_VERSION};
+}
+
+# spec version of given fragment - if not given, assume 1.4
sub _metaspec_version {
- my ( $meta_add, $meta_merge ) = @_;
- return $meta_add->{'meta-spec'}->{version}
- if defined $meta_add->{'meta-spec'}
- and defined $meta_add->{'meta-spec'}->{version};
- return $meta_merge->{'meta-spec'}->{version}
- if defined $meta_merge->{'meta-spec'}
- and defined $meta_merge->{'meta-spec'}->{version};
+ my ( $meta ) = @_;
+ return $meta->{'meta-spec'}->{version}
+ if defined $meta->{'meta-spec'}
+ and defined $meta->{'meta-spec'}->{version};
return '1.4';
}
sub _add_requirements_to_meta_v1_4 {
- my ( $self, %meta ) = @_;
-
+ my ( $self, $meta ) = @_;
# Check the original args so we can tell between the user setting it
# to an empty hash and it just being initialized.
if( $self->{ARGS}{CONFIGURE_REQUIRES} ) {
- $meta{configure_requires} = $self->{CONFIGURE_REQUIRES};
+ $meta->{configure_requires} = $self->{CONFIGURE_REQUIRES};
} else {
- $meta{configure_requires} = {
+ $meta->{configure_requires} = {
'ExtUtils::MakeMaker' => 0,
};
}
-
if( $self->{ARGS}{BUILD_REQUIRES} ) {
- $meta{build_requires} = $self->{BUILD_REQUIRES};
+ $meta->{build_requires} = $self->{BUILD_REQUIRES};
} else {
- $meta{build_requires} = {
+ $meta->{build_requires} = {
'ExtUtils::MakeMaker' => 0,
};
}
-
if( $self->{ARGS}{TEST_REQUIRES} ) {
- $meta{build_requires} = {
- %{ $meta{build_requires} },
+ $meta->{build_requires} = {
+ %{ $meta->{build_requires} },
%{ $self->{TEST_REQUIRES} },
};
}
-
- $meta{requires} = $self->{PREREQ_PM}
+ $meta->{requires} = $self->{PREREQ_PM}
if defined $self->{PREREQ_PM};
- $meta{requires}{perl} = _normalize_version($self->{MIN_PERL_VERSION})
+ $meta->{requires}{perl} = _normalize_version($self->{MIN_PERL_VERSION})
if $self->{MIN_PERL_VERSION};
-
- return %meta;
-}
-
-sub _add_requirements_to_meta_v2 {
- my ( $self, %meta ) = @_;
-
- # Check the original args so we can tell between the user setting it
- # to an empty hash and it just being initialized.
- if( $self->{ARGS}{CONFIGURE_REQUIRES} ) {
- $meta{prereqs}{configure}{requires} = $self->{CONFIGURE_REQUIRES};
- } else {
- $meta{prereqs}{configure}{requires} = {
- 'ExtUtils::MakeMaker' => 0,
- };
- }
-
- if( $self->{ARGS}{BUILD_REQUIRES} ) {
- $meta{prereqs}{build}{requires} = $self->{BUILD_REQUIRES};
- } else {
- $meta{prereqs}{build}{requires} = {
- 'ExtUtils::MakeMaker' => 0,
- };
- }
-
- if( $self->{ARGS}{TEST_REQUIRES} ) {
- $meta{prereqs}{test}{requires} = $self->{TEST_REQUIRES};
- }
-
- $meta{prereqs}{runtime}{requires} = $self->{PREREQ_PM}
- if $self->{ARGS}{PREREQ_PM};
- $meta{prereqs}{runtime}{requires}{perl} = _normalize_version($self->{MIN_PERL_VERSION})
- if $self->{MIN_PERL_VERSION};
-
- return %meta;
}
# Adapted from Module::Build::Base
$version = 0 unless defined $version;
if ( ref $version eq 'version' ) { # version objects
- $version = $version->is_qv ? $version->normal : $version->stringify;
+ $version = $version->stringify;
}
elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots
# normalize string tuples without "v": "1.2.3" -> "v1.2.3"
$self->oneliner(<<'CODE', ['-MExtUtils::Manifest=maniadd']),
exit unless -e q{META.yml};
eval { maniadd({q{META.yml} => q{Module YAML meta-data (added by MakeMaker)}}) }
- or print "Could not add META.yml to MANIFEST: $${'@'}\n"
+ or die "Could not add META.yml to MANIFEST: ${'@'}"
CODE
$self->oneliner(<<'CODE', ['-MExtUtils::Manifest=maniadd'])
exit unless -f q{META.json};
eval { maniadd({q{META.json} => q{Module JSON meta-data (added by MakeMaker)}}) }
- or print "Could not add META.json to MANIFEST: $${'@'}\n"
+ or die "Could not add META.json to MANIFEST: ${'@'}"
CODE
);
my $v2 = 1;
unless ( $mymeta ) {
- my @metadata = $self->metafile_data(
+ $mymeta = $self->metafile_data(
$self->{META_ADD} || {},
$self->{META_MERGE} || {},
);
- $mymeta = {@metadata};
$v2 = 0;
}
# Overwrite the non-configure dependency hashes
-
- my $method = $v2
- ? '_add_requirements_to_meta_v2'
- : '_add_requirements_to_meta_v1_4';
-
- $mymeta = { $self->$method( %$mymeta ) };
+ $self->_add_requirements_to_meta($mymeta);
$mymeta->{dynamic_config} = 0;
return unless _has_cpan_meta();
- _fix_metadata_before_conversion( $mymeta );
+ my $meta_obj = $self->_fix_metadata_before_conversion( $mymeta );
- # this can still blow up
- # not sure if i should just eval this and skip file creation if it
- # blows up
- my $meta_obj = CPAN::Meta->new( $mymeta, { lazy_validation => 1 } );
- $meta_obj->save( 'MYMETA.json' );
+ $meta_obj->save( 'MYMETA.json', { version => "2.0" } );
$meta_obj->save( 'MYMETA.yml', { version => "1.4" } );
return 1;
}
}
# Occasionally files are repeated several times from different sources
- { my(%f) = map { ($_ => 1) } @files; @files = keys %f; }
- { my(%d) = map { ($_ => 1) } @dirs; @dirs = keys %d; }
+ { my(%f) = map { ($_ => 1) } @files; @files = sort keys %f; }
+ { my(%d) = map { ($_ => 1) } @dirs; @dirs = sort keys %d; }
my $rm_cmd = join "\n\t", map { "$_" }
$self->split_command('- $(RM_F)', @files);
my $m = sprintf <<'MAKE', $rm_cmd, $rmf_cmd;
# Delete temporary files (via clean) and also delete dist files
-realclean purge :: clean realclean_subdirs
+realclean purge :: realclean_subdirs
%s
%s
MAKE
sub realclean_subdirs_target {
my $self = shift;
-
- return <<'NOOP_FRAG' unless @{$self->{DIR}};
-realclean_subdirs :
- $(NOECHO) $(NOOP)
-NOOP_FRAG
-
- my $rclean = "realclean_subdirs :\n";
-
+ my @m = <<'EOF';
+# so clean is forced to complete before realclean_subdirs runs
+realclean_subdirs : clean
+EOF
+ return join '', @m, "\t\$(NOECHO) \$(NOOP)\n" unless @{$self->{DIR}};
foreach my $dir (@{$self->{DIR}}) {
foreach my $makefile ('$(MAKEFILE_OLD)', '$(FIRST_MAKEFILE)' ) {
- my $subrclean .= $self->oneliner(sprintf <<'CODE', $dir, ($makefile) x 2);
-chdir '%s'; system '$(MAKE) $(USEMAKEFILE) %s realclean' if -f '%s';
+ my $subrclean .= $self->oneliner(_sprintf562 <<'CODE', $dir, $makefile);
+chdir '%1$s'; system '$(MAKE) $(USEMAKEFILE) %2$s realclean' if -f '%2$s';
CODE
-
- $rclean .= sprintf <<'RCLEAN', $subrclean;
- - %s
-RCLEAN
-
+ push @m, "\t- $subrclean\n";
}
}
-
- return $rclean;
+ return join '', @m;
}
my $add_sign = $self->oneliner(<<'CODE', ['-MExtUtils::Manifest=maniadd']);
eval { maniadd({q{SIGNATURE} => q{Public-key signature (added by MakeMaker)}}) }
- or print "Could not add SIGNATURE to MANIFEST: $${'@'}\n"
+ or die "Could not add SIGNATURE to MANIFEST: ${'@'}"
CODE
my $sign_dist = $self->cd('$(DISTVNAME)' => 'cpansign -s');
my $make_frag = <<'MAKE_FRAG';
.SUFFIXES : .xs .c .C .cpp .i .s .cxx .cc $(OBJ_EXT)
-.PHONY: all config static dynamic test linkext manifest blibdirs clean realclean disttest distdir
+.PHONY: all config static dynamic test linkext manifest blibdirs clean realclean disttest distdir pure_all subdirs clean_subdirs makemakerdflt manifypods realclean_subdirs subdirs_dynamic subdirs_pure_nolink subdirs_static subdirs-test_dynamic subdirs-test_static test_dynamic test_static
MAKE_FRAG
if ( $self->{OBJECT} ) {
$self->{OBJECT} = join(" ", @{$self->{OBJECT}}) if ref $self->{OBJECT};
$self->{OBJECT} =~ s!\.o(bj)?\b!\$(OBJ_EXT)!g;
- } elsif ( $self->{MAGICXS} && @{$self->{O_FILES}||[]} ) {
+ } elsif ( ($self->{MAGICXS} || $self->{XSMULTI}) && @{$self->{O_FILES}||[]} ) {
$self->{OBJECT} = join(" ", @{$self->{O_FILES}});
$self->{OBJECT} =~ s!\.o(bj)?\b!\$(OBJ_EXT)!g;
} else {
my $tests = $mm->find_tests_recursive;
Returns a string suitable for feeding to the shell to return all
-tests in t/ but recursively.
+tests in t/ but recursively. Equivalent to
+
+ my $tests = $mm->find_tests_recursive_in('t');
=cut
sub find_tests_recursive {
- my($self) = shift;
- return '' unless -d 't';
+ my $self = shift;
+ return $self->find_tests_recursive_in('t');
+}
+
+=head3 find_tests_recursive_in
+
+ my $tests = $mm->find_tests_recursive_in($dir);
+
+Returns a string suitable for feeding to the shell to return all
+tests in $dir recursively.
+
+=cut
+
+sub find_tests_recursive_in {
+ my($self, $dir) = @_;
+ return '' unless -d $dir;
require File::Find;
- my %testfiles;
+ my $base_depth = grep { $_ ne '' } File::Spec->splitdir( (File::Spec->splitpath($dir))[1] );
+ my %depths;
my $wanted = sub {
return unless m!\.t$!;
my ($volume,$directories,$file) =
File::Spec->splitpath( $File::Find::name );
- my @dirs = File::Spec->splitdir( $directories );
- for ( @dirs ) {
- next if $_ eq 't';
- unless ( $_ ) {
- $_ = '*.t';
- next;
- }
- $_ = '*';
- }
- my $testfile = join '/', @dirs;
- $testfiles{ $testfile } = 1;
+ my $depth = grep { $_ ne '' } File::Spec->splitdir( $directories );
+ $depth -= $base_depth;
+ $depths{ $depth } = 1;
};
- File::Find::find( $wanted, 't' );
+ File::Find::find( $wanted, $dir );
- return join ' ', sort keys %testfiles;
+ return join ' ',
+ map { $dir . '/*' x $_ . '.t' }
+ sort { $a <=> $b }
+ keys %depths;
}
=head3 extra_clean_files
return '';
}
+=head3 post_constants (o)
+
+Returns an empty string per default. Dedicated to overrides from
+within Makefile.PL after all constants have been defined.
+
+=cut
+
+sub post_constants {
+ "";
+}
+
+=head3 post_initialize (o)
+
+Returns an empty string per default. Used in Makefile.PLs to add some
+chunk of text to the Makefile after the object is initialized.
+
+=cut
+
+sub post_initialize {
+ "";
+}
+
+=head3 postamble (o)
+
+Returns an empty string. Can be used in Makefile.PLs to write some
+text to the Makefile at the end.
+
+=cut
+
+sub postamble {
+ "";
+}
+
=begin private
=head3 _PREREQ_PRINT
Implements PRINT_PREREQ, a slightly different version of PREREQ_PRINT
added by Redhat to, I think, support generating RPMs from Perl modules.
-Should not include BUILD_REQUIRES as RPMs do not incluide them.
+Should not include BUILD_REQUIRES as RPMs do not include them.
Refactored out of MakeMaker->new().
=begin private
-=head3 _all_prereqs
-
- my $prereqs = $self->_all_prereqs;
-
-Returns a hash ref of both PREREQ_PM and BUILD_REQUIRES.
-
-=end private
-
-=cut
-
-sub _all_prereqs {
- my $self = shift;
-
- return { %{$self->{PREREQ_PM}}, %{$self->{BUILD_REQUIRES}} };
-}
-
-=begin private
-
=head3 _perl_header_files
my $perl_header_files= $self->_perl_header_files;
require ExtUtils::MM_Unix;
our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
-our $VERSION = '7.10_01';
+our $VERSION = '7.18';
+$VERSION = eval $VERSION;
=item os_flavor
require ExtUtils::MM_Win32;
our @ISA = qw( ExtUtils::MM_Unix );
-our $VERSION = '7.10_01';
+our $VERSION = '7.18';
+$VERSION = eval $VERSION;
=head1 NAME
sub dynamic_lib {
my($self, %attribs) = @_;
my $s = ExtUtils::MM_Unix::dynamic_lib($self, %attribs);
- my $ori = "$self->{INSTALLARCHLIB}/auto/$self->{FULLEXT}/$self->{BASEEXT}.$self->{DLEXT}";
- if (-e $ori) {
- my $imagebase = `/bin/objdump -p $ori | /bin/grep ImageBase | /bin/cut -c12-`;
- chomp $imagebase;
- if ($imagebase gt "40000000") {
- my $LDDLFLAGS = $self->{LDDLFLAGS};
- $LDDLFLAGS =~ s/-Wl,--enable-auto-image-base/-Wl,--image-base=0x$imagebase/;
- $s =~ s/ \$\(LDDLFLAGS\) / $LDDLFLAGS /m;
- }
- }
+ return '' unless $s;
+ return $s unless %{$self->{XS}};
+
+ # do an ephemeral rebase so the new DLL fits to the current rebase map
+ $s .= "\t/bin/find \$\(INST_ARCHLIB\)/auto -xdev -name \\*.$self->{DLEXT} | /bin/rebase -sOT -" if (( $Config{myarchname} eq 'i686-cygwin' ) and not ( exists $ENV{CYGPORT_PACKAGE_VERSION} ));
+ $s;
+}
+
+=item install
+
+Rebase dll's with the global rebase database after installation.
+
+=cut
+
+sub install {
+ my($self, %attribs) = @_;
+ my $s = ExtUtils::MM_Unix::install($self, %attribs);
+ return '' unless $s;
+ return $s unless %{$self->{XS}};
+
+ my $INSTALLDIRS = $self->{INSTALLDIRS};
+ my $INSTALLLIB = $self->{"INSTALL". ($INSTALLDIRS eq 'perl' ? 'ARCHLIB' : uc($INSTALLDIRS)."ARCH")};
+ my $dop = "\$\(DESTDIR\)$INSTALLLIB/auto/";
+ my $dll = "$dop/$self->{FULLEXT}/$self->{BASEEXT}.$self->{DLEXT}";
+ $s =~ s|^(pure_install :: pure_\$\(INSTALLDIRS\)_install\n\t)\$\(NOECHO\) \$\(NOOP\)\n|$1\$(CHMOD) \$(PERM_RWX) $dll\n\t/bin/find $dop -xdev -name \\*.$self->{DLEXT} \| /bin/rebase -sOT -\n|m if (( $Config{myarchname} eq 'i686-cygwin') and not ( exists $ENV{CYGPORT_PACKAGE_VERSION} ));
$s;
}
use strict;
-our $VERSION = '7.10_01';
+our $VERSION = '7.18';
+$VERSION = eval $VERSION;
require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
our @ISA = qw( ExtUtils::MM_Unix );
}
-our $VERSION = '7.10_01';
+our $VERSION = '7.18';
+$VERSION = eval $VERSION;
=head1 NAME
use strict;
-our $VERSION = '7.10_01';
+our $VERSION = '7.18';
+$VERSION = eval $VERSION;
sub new {
die 'MacOS Classic (MacPerl) is no longer supported by MakeMaker';
use ExtUtils::MakeMaker::Config;
use File::Basename;
-our $VERSION = '7.10_01';
+our $VERSION = '7.18';
+$VERSION = eval $VERSION;
require ExtUtils::MM_Win32;
our @ISA = qw(ExtUtils::MM_Win32);
-use ExtUtils::MakeMaker qw( &neatvalue );
+use ExtUtils::MakeMaker qw(&neatvalue &_sprintf562);
$ENV{EMXSHELL} = 'sh'; # to run `commands`
-my $BORLAND = $Config{'cc'} =~ /^bcc/i;
-my $GCC = $Config{'cc'} =~ /^gcc/i;
+my $BORLAND = $Config{'cc'} =~ /\bbcc/i;
+my $GCC = $Config{'cc'} =~ /\bgcc/i;
=item os_flavor
return $make_frag;
}
+=item static_lib_pure_cmd
-=item const_cccmd
+Defines how to run the archive utility
=cut
-sub const_cccmd {
- my($self,$libperl)=@_;
- return $self->{CONST_CCCMD} if $self->{CONST_CCCMD};
- return '' unless $self->needs_linking();
- return $self->{CONST_CCCMD} = <<'MAKE_FRAG';
-CCCMD = $(CC) $(CCFLAGS) $(INC) $(OPTIMIZE) \
- $(PERLTYPE) $(MPOLLUTE) -o $@ \
- -DVERSION=\"$(VERSION)\" -DXS_VERSION=\"$(XS_VERSION)\"
-MAKE_FRAG
-
-}
-
-
-=item static_lib
-
-=cut
-
-sub static_lib {
- my($self) = @_;
-
- return '' unless $self->has_link_code;
-
- my $m = <<'END';
-$(INST_STATIC): $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)$(DFSEP).exists
- $(RM_RF) $@
-END
-
- # If this extension has it's own library (eg SDBM_File)
- # then copy that to $(INST_STATIC) and add $(OBJECT) into it.
- $m .= <<'END' if $self->{MYEXTLIB};
- $self->{CP} $(MYEXTLIB) $@
-END
-
- my $ar_arg;
- if( $BORLAND ) {
- $ar_arg = '$@ $(OBJECT:^"+")';
- }
- elsif( $GCC ) {
- $ar_arg = '-ru $@ $(OBJECT)';
- }
- else {
- $ar_arg = '-type library -o $@ $(OBJECT)';
- }
-
- $m .= sprintf <<'END', $ar_arg;
- $(AR) %s
- $(NOECHO) $(ECHO) "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)\extralibs.ld
- $(CHMOD) 755 $@
-END
-
- $m .= <<'END' if $self->{PERL_SRC};
- $(NOECHO) $(ECHO) "$(EXTRALIBS)" >> $(PERL_SRC)\ext.libs
-
-
-END
- return $m;
+sub static_lib_pure_cmd {
+ my ($self, $src) = @_;
+ $src =~ s/(\$\(\w+)(\))/$1:^"+"$2/g if $BORLAND;
+ sprintf qq{\t\$(AR) %s\n}, ($BORLAND ? '$@ ' . $src
+ : ($GCC ? '-ru $@ ' . $src
+ : '-type library -o $@ ' . $src));
}
=item dynamic_lib
-Defines how to produce the *.so (or equivalent) files.
+Override of utility methods for OS-specific work.
=cut
-sub dynamic_lib {
- my($self, %attribs) = @_;
- return '' unless $self->needs_linking(); #might be because of a subdir
-
- return '' unless $self->has_link_code;
-
- my($otherldflags) = $attribs{OTHERLDFLAGS} || ($BORLAND ? 'c0d32.obj': '');
- my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || "";
- my($ldfrom) = '$(LDFROM)';
-
- (my $boot = $self->{NAME}) =~ s/:/_/g;
-
- my $m = <<'MAKE_FRAG';
-# This section creates the dynamically loadable $(INST_DYNAMIC)
-# from $(OBJECT) and possibly $(MYEXTLIB).
-OTHERLDFLAGS = '.$otherldflags.'
-INST_DYNAMIC_DEP = '.$inst_dynamic_dep.'
-
+sub xs_make_dynamic_lib {
+ my ($self, $attribs, $from, $to, $todir, $ldfrom, $exportlist) = @_;
+ my @m;
+ # Taking care of long names like FileHandle, ByteLoader, SDBM_File etc
+ if ($to =~ /^\$/) {
+ if ($self->{NLM_SHORT_NAME}) {
+ # deal with shortnames
+ my $newto = q{$(INST_AUTODIR)\\$(NLM_SHORT_NAME).$(DLEXT)};
+ push @m, "$to: $newto\n\n";
+ $to = $newto;
+ }
+ } else {
+ my ($v, $d, $f) = File::Spec->splitpath($to);
+ # relies on $f having a literal "." in it, unlike for $(OBJ_EXT)
+ if ($f =~ /[^\.]{9}\./) {
+ # 9+ chars before '.', need to shorten
+ $f = substr $f, 0, 8;
+ }
+ my $newto = File::Spec->catpath($v, $d, $f);
+ push @m, "$to: $newto\n\n";
+ $to = $newto;
+ }
+ # bits below should be in dlsyms, not here
+ # 1 2 3 4
+ push @m, _sprintf562 <<'MAKE_FRAG', $to, $from, $todir, $exportlist;
# Create xdc data for an MT safe NLM in case of mpk build
-$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).exists
- $(NOECHO) $(ECHO) Export boot_$(BOOT_SYMBOL) > $(BASEEXT).def
- $(NOECHO) $(ECHO) $(BASE_IMPORT) >> $(BASEEXT).def
- $(NOECHO) $(ECHO) Import @$(PERL_INC)\perl.imp >> $(BASEEXT).def
+%1$s: %2$s $(MYEXTLIB) $(BOOTSTRAP) %3$s$(DFSEP).exists
+ $(NOECHO) $(ECHO) Export boot_$(BOOT_SYMBOL) > %4$s
+ $(NOECHO) $(ECHO) $(BASE_IMPORT) >> %4$s
+ $(NOECHO) $(ECHO) Import @$(PERL_INC)\perl.imp >> %4$s
MAKE_FRAG
-
-
if ( $self->{CCFLAGS} =~ m/ -DMPK_ON /) {
- $m .= <<'MAKE_FRAG';
- $(MPKTOOL) $(XDCFLAGS) $(BASEEXT).xdc
- $(NOECHO) $(ECHO) xdcdata $(BASEEXT).xdc >> $(BASEEXT).def
+ (my $xdc = $exportlist) =~ s#def\z#xdc#;
+ $xdc = '$(BASEEXT).xdc';
+ push @m, sprintf <<'MAKE_FRAG', $xdc, $exportlist;
+ $(MPKTOOL) $(XDCFLAGS) %s
+ $(NOECHO) $(ECHO) xdcdata $(BASEEXT).xdc >> %s
MAKE_FRAG
}
-
# Reconstruct the X.Y.Z version.
my $version = join '.', map { sprintf "%d", $_ }
$] =~ /(\d)\.(\d{3})(\d{2})/;
- $m .= sprintf ' $(LD) $(LDFLAGS) $(OBJECT:.obj=.obj) -desc "Perl %s Extension ($(BASEEXT)) XS_VERSION: $(XS_VERSION)" -nlmversion $(NLM_VERSION)', $version;
-
- # Taking care of long names like FileHandle, ByteLoader, SDBM_File etc
- if($self->{NLM_SHORT_NAME}) {
- # In case of nlms with names exceeding 8 chars, build nlm in the
- # current dir, rename and move to auto\lib.
- $m .= q{ -o $(NLM_SHORT_NAME).$(DLEXT)}
- } else {
- $m .= q{ -o $(INST_AUTODIR)\\$(BASEEXT).$(DLEXT)}
- }
-
- # Add additional lib files if any (SDBM_File)
- $m .= q{ $(MYEXTLIB) } if $self->{MYEXTLIB};
-
- $m .= q{ $(PERL_INC)\Main.lib -commandfile $(BASEEXT).def}."\n";
-
- if($self->{NLM_SHORT_NAME}) {
- $m .= <<'MAKE_FRAG';
- if exist $(INST_AUTODIR)\$(NLM_SHORT_NAME).$(DLEXT) del $(INST_AUTODIR)\$(NLM_SHORT_NAME).$(DLEXT)
- move $(NLM_SHORT_NAME).$(DLEXT) $(INST_AUTODIR)
-MAKE_FRAG
- }
-
- $m .= <<'MAKE_FRAG';
-
+ push @m, sprintf <<'EOF', $from, $version, $to, $exportlist;
+ $(LD) $(LDFLAGS) %s -desc "Perl %s Extension ($(BASEEXT)) XS_VERSION: $(XS_VERSION)" -nlmversion $(NLM_VERSION) -o %s $(MYEXTLIB) $(PERL_INC)\Main.lib -commandfile %s
$(CHMOD) 755 $@
-MAKE_FRAG
-
- return $m;
+EOF
+ join '', @m;
}
-
1;
__END__
=back
=cut
-
-
use ExtUtils::MakeMaker qw(neatvalue);
use File::Spec;
-our $VERSION = '7.10_01';
+our $VERSION = '7.18';
+$VERSION = eval $VERSION;
require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
sub dlsyms {
my($self,%attribs) = @_;
-
- my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {};
- my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || [];
- my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || [];
- my($imports) = $attribs{IMPORTS} || $self->{IMPORTS} || {};
- my(@m);
- (my $boot = $self->{NAME}) =~ s/:/_/g;
-
- if (not $self->{SKIPHASH}{'dynamic'}) {
- push(@m,"
-$self->{BASEEXT}.def: Makefile.PL
-",
- ' $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e \'use ExtUtils::Mksymlists; \\
- Mksymlists("NAME" => "$(NAME)", "DLBASE" => "$(DLBASE)", ',
- '"VERSION" => "$(VERSION)", "DISTNAME" => "$(DISTNAME)", ',
- '"INSTALLDIRS" => "$(INSTALLDIRS)", ',
- '"DL_FUNCS" => ',neatvalue($funcs),
- ', "FUNCLIST" => ',neatvalue($funclist),
- ', "IMPORTS" => ',neatvalue($imports),
- ', "DL_VARS" => ', neatvalue($vars), ');\'
-');
- }
if ($self->{IMPORTS} && %{$self->{IMPORTS}}) {
# Make import files (needed for static build)
-d 'tmp_imp' or mkdir 'tmp_imp', 0777 or die "Can't mkdir tmp_imp";
open my $imp, '>', 'tmpimp.imp' or die "Can't open tmpimp.imp";
- while (my($name, $exp) = each %{$self->{IMPORTS}}) {
+ foreach my $name (sort keys %{$self->{IMPORTS}}) {
+ my $exp = $self->{IMPORTS}->{$name};
my ($lib, $id) = ($exp =~ /(.*)\.(.*)/) or die "Malformed IMPORT `$exp'";
print $imp "$name $lib $id ?\n";
}
system "cd tmp_imp; $Config::Config{ar} x ../tmpimp$Config::Config{lib_ext}"
and die "Cannot extract import objects: $!, \$?=$?";
}
- join('',@m);
+ return '' if $self->{SKIPHASH}{'dynamic'};
+ $self->xs_dlsyms_iterator(\%attribs);
}
-sub static_lib {
- my($self) = @_;
- my $old = $self->ExtUtils::MM_Unix::static_lib();
- return $old unless $self->{IMPORTS} && %{$self->{IMPORTS}};
+sub xs_dlsyms_ext {
+ '.def';
+}
- my @chunks = split /\n{2,}/, $old;
- shift @chunks unless length $chunks[0]; # Empty lines at the start
- $chunks[0] .= <<'EOC';
+sub xs_dlsyms_extra {
+ join '', map { qq{, "$_" => "\$($_)"} } qw(VERSION DISTNAME INSTALLDIRS);
+}
- $(AR) $(AR_STATIC_ARGS) $@ tmp_imp/* && $(RANLIB) $@
+sub static_lib_pure_cmd {
+ my($self) = @_;
+ my $old = $self->SUPER::static_lib_pure_cmd;
+ return $old unless $self->{IMPORTS} && %{$self->{IMPORTS}};
+ $old . <<'EOC';
+ $(AR) $(AR_STATIC_ARGS) "$@" tmp_imp/*
+ $(RANLIB) "$@"
EOC
- return join "\n\n". '', @chunks;
}
sub replace_manpage_separator {
package ExtUtils::MM_QNX;
use strict;
-our $VERSION = '7.10_01';
+our $VERSION = '7.18';
+$VERSION = eval $VERSION;
require ExtUtils::MM_Unix;
our @ISA = qw(ExtUtils::MM_Unix);
package ExtUtils::MM_UWIN;
use strict;
-our $VERSION = '7.10_01';
+our $VERSION = '7.18';
+$VERSION = eval $VERSION;
require ExtUtils::MM_Unix;
our @ISA = qw(ExtUtils::MM_Unix);
use Carp;
use ExtUtils::MakeMaker::Config;
use File::Basename qw(basename dirname);
-use DirHandle;
our %Config_Override;
-use ExtUtils::MakeMaker qw($Verbose neatvalue);
+use ExtUtils::MakeMaker qw($Verbose neatvalue _sprintf562);
# If we make $VERSION an our variable parse_version() breaks
use vars qw($VERSION);
-$VERSION = '7.10_01';
+$VERSION = '7.18';
$VERSION = eval $VERSION; ## no critic [BuiltinFunctions::ProhibitStringyEval]
require ExtUtils::MM_Any;
# So we don't have to keep calling the methods over and over again,
# we have these globals to cache the values. Faster and shrtr.
my $Curdir = __PACKAGE__->curdir;
-my $Rootdir = __PACKAGE__->rootdir;
my $Updir = __PACKAGE__->updir;
};
}
- push @m, qq{
-.c.s:
- $command -S $flags \$*.c
+ my $m_o = $self->{XSMULTI} ? $self->xs_obj_opt('$*.s') : '';
+ push @m, sprintf <<'EOF', $command, $flags, $m_o;
-.c\$(OBJ_EXT):
- $command $flags \$*.c
+.c.s :
+ %s -S %s $*.c %s
+EOF
-.cpp\$(OBJ_EXT):
- $command $flags \$*.cpp
+ my @exts = qw(c cpp cxx cc);
+ push @exts, 'C' if !$Is{OS2} and !$Is{Win32} and !$Is{Dos}; #Case-specific
+ $m_o = $self->{XSMULTI} ? $self->xs_obj_opt('$*$(OBJ_EXT)') : '';
+ for my $ext (@exts) {
+ push @m, "\n.$ext\$(OBJ_EXT) :\n\t$command $flags \$*.$ext" . ( $m_o ? " $m_o" : '' ) . "\n";
+ }
+ return join "", @m;
+}
-.cxx\$(OBJ_EXT):
- $command $flags \$*.cxx
-.cc\$(OBJ_EXT):
- $command $flags \$*.cc
-};
+=item xs_obj_opt
- push @m, qq{
-.C\$(OBJ_EXT):
- $command $flags \$*.C
-} if !$Is{OS2} and !$Is{Win32} and !$Is{Dos}; #Case-specific
+Takes the object file as an argument, and returns the portion of compile
+command-line that will output to the specified object file.
- return join "", @m;
+=cut
+
+sub xs_obj_opt {
+ my ($self, $output_file) = @_;
+ "-o $output_file";
}
+
=item cflags (o)
Does very much the same as the cflags script in the perl
$pollute = '$(PERL_MALLOC_DEF)';
}
- $self->{CCFLAGS} = quote_paren($self->{CCFLAGS});
- $self->{OPTIMIZE} = quote_paren($self->{OPTIMIZE});
-
return $self->{CFLAGS} = qq{
CCFLAGS = $self->{CCFLAGS}
OPTIMIZE = $self->{OPTIMIZE}
foreach my $key (@{$self->{CONFIG}}){
# SITE*EXP macros are defined in &constants; avoid duplicates here
next if $once_only{$key};
- $self->{uc $key} = quote_paren($self->{uc $key});
push @m, uc($key) , ' = ' , $self->{uc $key}, "\n";
$once_only{$key} = 1;
}
push @m, "
# Handy lists of source code files:
XS_FILES = ".$self->wraplist(sort keys %{$self->{XS}})."
-C_FILES = ".$self->wraplist(@{$self->{C}})."
-O_FILES = ".$self->wraplist(@{$self->{O_FILES}})."
-H_FILES = ".$self->wraplist(@{$self->{H}})."
+C_FILES = ".$self->wraplist(sort @{$self->{C}})."
+O_FILES = ".$self->wraplist(sort @{$self->{O_FILES}})."
+H_FILES = ".$self->wraplist(sort @{$self->{H}})."
MAN1PODS = ".$self->wraplist(sort keys %{$self->{MAN1PODS}})."
MAN3PODS = ".$self->wraplist(sort keys %{$self->{MAN3PODS}})."
";
push @m, q{
# Where is the Config information that we are using/depend on
CONFIGDEP = $(PERL_ARCHLIBDEP)$(DFSEP)Config.pm $(PERL_INCDEP)$(DFSEP)config.h
-} if -e File::Spec->catfile( $self->{PERL_INC}, 'config.h' );
+} if -e $self->catfile( $self->{PERL_INC}, 'config.h' );
push @m, qq{
push @m, "
-TO_INST_PM = ".$self->wraplist(sort keys %{$self->{PM}})."
-
-PM_TO_BLIB = ".$self->wraplist(map { ($_ => $self->{PM}->{$_}) } sort keys %{$self->{PM}})."
-";
+TO_INST_PM = ".$self->wraplist(map $self->quote_dep($_), sort keys %{$self->{PM}})."\n";
join('',@m);
}
sub depend {
my($self,%attribs) = @_;
my(@m,$key,$val);
- while (($key,$val) = each %attribs){
- last unless defined $key;
+ for my $key (sort keys %attribs){
+ my $val = $attribs{$key};
+ next unless defined $key and defined $val;
push @m, "$key : $val\n";
}
join "", @m;
sub dynamic_bs {
my($self, %attribs) = @_;
- return '
-BOOTSTRAP =
-' unless $self->has_link_code();
-
- my $target = $Is{VMS} ? '$(MMS$TARGET)' : '$@';
-
- return sprintf <<'MAKE_FRAG', ($target) x 2;
-BOOTSTRAP = $(BASEEXT).bs
-
+ return "\nBOOTSTRAP =\n" unless $self->has_link_code();
+ my @exts;
+ if ($self->{XSMULTI}) {
+ @exts = $self->_xs_list_basenames;
+ } else {
+ @exts = '$(BASEEXT)';
+ }
+ return join "\n",
+ "BOOTSTRAP = @{[map { qq{$_.bs} } @exts]}\n",
+ map { $self->_xs_make_bs($_) } @exts;
+}
+
+sub _xs_make_bs {
+ my ($self, $basename) = @_;
+ my ($v, $d, $f) = File::Spec->splitpath($basename);
+ my @d = File::Spec->splitdir($d);
+ shift @d if $self->{XSMULTI} and $d[0] eq 'lib';
+ my $instdir = $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f);
+ $instdir = '$(INST_ARCHAUTODIR)' if $basename eq '$(BASEEXT)';
+ my $instfile = $self->catfile($instdir, "$f.bs");
+ my $exists = "$instdir\$(DFSEP).exists"; # match blibdirs_target
+ # 1 2 3
+ return _sprintf562 <<'MAKE_FRAG', $basename, $instfile, $exists;
# As Mkbootstrap might not write a file (if none is required)
# we use touch to prevent make continually trying to remake it.
# The DynaLoader only reads a non-empty file.
-$(BOOTSTRAP) : $(FIRST_MAKEFILE) $(BOOTDEP) $(INST_ARCHAUTODIR)$(DFSEP).exists
- $(NOECHO) $(ECHO) "Running Mkbootstrap for $(NAME) ($(BSLOADLIBS))"
+%1$s.bs : $(FIRST_MAKEFILE) $(BOOTDEP)
+ $(NOECHO) $(ECHO) "Running Mkbootstrap for %1$s ($(BSLOADLIBS))"
$(NOECHO) $(PERLRUN) \
"-MExtUtils::Mkbootstrap" \
- -e "Mkbootstrap('$(BASEEXT)','$(BSLOADLIBS)');"
- $(NOECHO) $(TOUCH) "%s"
- $(CHMOD) $(PERM_RW) "%s"
+ -e "Mkbootstrap('%1$s','$(BSLOADLIBS)');"
+ $(NOECHO) $(TOUCH) "%1$s.bs"
+ $(CHMOD) $(PERM_RW) "%1$s.bs"
+
+%2$s : %1$s.bs %3$s
+ $(NOECHO) $(RM_RF) %2$s
+ - $(CP_NONEMPTY) %1$s.bs %2$s $(PERM_RW)
MAKE_FRAG
}
sub dynamic_lib {
my($self, %attribs) = @_;
return '' unless $self->needs_linking(); #might be because of a subdir
-
return '' unless $self->has_link_code;
+ my @m = $self->xs_dynamic_lib_macros(\%attribs);
+ my @libs;
+ if ($self->{XSMULTI}) {
+ my @exts = $self->_xs_list_basenames;
+ for my $ext (@exts) {
+ my ($v, $d, $f) = File::Spec->splitpath($ext);
+ my @d = File::Spec->splitdir($d);
+ shift @d if $d[0] eq 'lib';
+ my $instdir = $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f);
+
+ # Dynamic library names may need special handling.
+ eval { require DynaLoader };
+ if (defined &DynaLoader::mod2fname) {
+ $f = &DynaLoader::mod2fname([@d, $f]);
+ }
- my($otherldflags) = $attribs{OTHERLDFLAGS} || "";
- my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || "";
- my($armaybe) = $attribs{ARMAYBE} || $self->{ARMAYBE} || ":";
- my($ldfrom) = '$(LDFROM)';
- $armaybe = 'ar' if ($Is{OSF} and $armaybe eq ':');
- my(@m);
- my $ld_opt = $Is{OS2} ? '$(OPTIMIZE) ' : ''; # Useful on other systems too?
+ my $instfile = $self->catfile($instdir, "$f.\$(DLEXT)");
+ my $objfile = $self->_xsbuild_value('xs', $ext, 'OBJECT');
+ $objfile = "$ext\$(OBJ_EXT)" unless defined $objfile;
+ my $ldfrom = $self->_xsbuild_value('xs', $ext, 'LDFROM');
+ $ldfrom = $objfile unless defined $ldfrom;
+ my $exportlist = "$ext.def";
+ push @libs, [ $objfile, $instfile, $instdir, $ldfrom, $exportlist ];
+ }
+ } else {
+ @libs = ([ qw($(OBJECT) $(INST_DYNAMIC) $(INST_ARCHAUTODIR) $(LDFROM) $(EXPORT_LIST)) ]);
+ }
+ push @m, map { $self->xs_make_dynamic_lib(\%attribs, @$_); } @libs;
+
+ return join("\n",@m);
+}
+
+=item xs_dynamic_lib_macros
+
+Defines the macros for the C<dynamic_lib> section.
+
+=cut
+
+sub xs_dynamic_lib_macros {
+ my ($self, $attribs) = @_;
+ my $otherldflags = $attribs->{OTHERLDFLAGS} || "";
+ my $inst_dynamic_dep = $attribs->{INST_DYNAMIC_DEP} || "";
+ my $armaybe = $self->_xs_armaybe($attribs);
+ my $ld_opt = $Is{OS2} ? '$(OPTIMIZE) ' : ''; # Useful on other systems too?
my $ld_fix = $Is{OS2} ? '|| ( $(RM_F) $@ && sh -c false )' : '';
- push(@m,'
-# This section creates the dynamically loadable $(INST_DYNAMIC)
-# from $(OBJECT) and possibly $(MYEXTLIB).
-ARMAYBE = '.$armaybe.'
-OTHERLDFLAGS = '.$ld_opt.$otherldflags.'
-INST_DYNAMIC_DEP = '.$inst_dynamic_dep.'
-INST_DYNAMIC_FIX = '.$ld_fix.'
-
-$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)$(DFSEP).exists $(EXPORT_LIST) $(PERL_ARCHIVEDEP) $(PERL_ARCHIVE_AFTER) $(INST_DYNAMIC_DEP)
-');
+ sprintf <<'EOF', $armaybe, $ld_opt.$otherldflags, $inst_dynamic_dep, $ld_fix;
+# This section creates the dynamically loadable objects from relevant
+# objects and possibly $(MYEXTLIB).
+ARMAYBE = %s
+OTHERLDFLAGS = %s
+INST_DYNAMIC_DEP = %s
+INST_DYNAMIC_FIX = %s
+EOF
+}
+
+sub _xs_armaybe {
+ my ($self, $attribs) = @_;
+ my $armaybe = $attribs->{ARMAYBE} || $self->{ARMAYBE} || ":";
+ $armaybe = 'ar' if ($Is{OSF} and $armaybe eq ':');
+ $armaybe;
+}
+
+=item xs_make_dynamic_lib
+
+Defines the recipes for the C<dynamic_lib> section.
+
+=cut
+
+sub xs_make_dynamic_lib {
+ my ($self, $attribs, $object, $to, $todir, $ldfrom, $exportlist) = @_;
+ $exportlist = '' if $exportlist ne '$(EXPORT_LIST)';
+ my $armaybe = $self->_xs_armaybe($attribs);
+ my @m = sprintf '%s : %s $(MYEXTLIB) %s$(DFSEP).exists %s $(PERL_ARCHIVEDEP) $(PERL_ARCHIVE_AFTER) $(INST_DYNAMIC_DEP)'."\n", $to, $object, $todir, $exportlist;
if ($armaybe ne ':'){
- $ldfrom = 'tmp$(LIB_EXT)';
- push(@m,' $(ARMAYBE) cr '.$ldfrom.' $(OBJECT)'."\n");
- push(@m,' $(RANLIB) '."$ldfrom\n");
+ $ldfrom = 'tmp$(LIB_EXT)';
+ push(@m," \$(ARMAYBE) cr $ldfrom $object\n");
+ push(@m," \$(RANLIB) $ldfrom\n");
}
$ldfrom = "-all $ldfrom -none" if $Is{OSF};
# is using them. This is painful if one for instance tries to restart
# a failed build because the link command will fail unnecessarily 'cos
# the shared object/library is 'busy'.
- push(@m,' $(RM_F) $@
-');
+ push(@m," \$(RM_F) \$\@\n");
my $libs = '$(LDLOADLIBS)';
-
if (($Is{NetBSD} || $Is{Interix} || $Is{Android}) && $Config{'useshrplib'} eq 'true') {
- # Use nothing on static perl platforms, and to the flags needed
- # to link against the shared libperl library on shared perl
- # platforms. We peek at lddlflags to see if we need -Wl,-R
- # or -R to add paths to the run-time library search path.
+ # Use nothing on static perl platforms, and to the flags needed
+ # to link against the shared libperl library on shared perl
+ # platforms. We peek at lddlflags to see if we need -Wl,-R
+ # or -R to add paths to the run-time library search path.
if ($Config{'lddlflags'} =~ /-Wl,-R/) {
$libs .= ' "-L$(PERL_INC)" "-Wl,-R$(INSTALLARCHLIB)/CORE" "-Wl,-R$(PERL_ARCHLIB)/CORE" -lperl';
} elsif ($Config{'lddlflags'} =~ /-R/) {
my $ld_run_path_shell = "";
if ($self->{LD_RUN_PATH} ne "") {
- $ld_run_path_shell = 'LD_RUN_PATH="$(LD_RUN_PATH)" ';
+ $ld_run_path_shell = 'LD_RUN_PATH="$(LD_RUN_PATH)" ';
}
- push @m, sprintf <<'MAKE', $ld_run_path_shell, $ldrun, $ldfrom, $libs;
- %s$(LD) %s $(LDDLFLAGS) %s $(OTHERLDFLAGS) -o $@ $(MYEXTLIB) \
- $(PERL_ARCHIVE) %s $(PERL_ARCHIVE_AFTER) $(EXPORT_LIST) \
+ push @m, sprintf <<'MAKE', $ld_run_path_shell, $ldrun, $self->xs_obj_opt('$@'), $ldfrom, $libs, $exportlist;
+ %s$(LD) %s $(LDDLFLAGS) %s $(OTHERLDFLAGS) %s $(MYEXTLIB) \
+ $(PERL_ARCHIVE) %s $(PERL_ARCHIVE_AFTER) %s \
$(INST_DYNAMIC_FIX)
-MAKE
-
- push @m, <<'MAKE';
$(CHMOD) $(PERM_RWX) $@
- $(NOECHO) $(RM_RF) $(BOOTSTRAP)
- - $(CP_NONEMPTY) $(BOOTSTRAP) $(INST_BOOT) $(PERM_RW)
MAKE
-
- return join('',@m);
+ join '', @m;
}
=item exescan
}
foreach my $name (@$names){
- foreach my $dir (@$dirs){
+ my ($abs, $use_dir);
+ if ($self->file_name_is_absolute($name)) { # /foo/bar
+ $abs = $name;
+ } elsif ($self->canonpath($name) eq
+ $self->canonpath(basename($name))) { # foo
+ $use_dir = 1;
+ } else { # foo/bar
+ $abs = $self->catfile($Curdir, $name);
+ }
+ foreach my $dir ($use_dir ? @$dirs : 1){
next unless defined $dir; # $self->{PERL_SRC} may be undefined
- my ($abs, $val);
- if ($self->file_name_is_absolute($name)) { # /foo/bar
- $abs = $name;
- } elsif ($self->canonpath($name) eq
- $self->canonpath(basename($name))) { # foo
- $abs = $self->catfile($dir, $name);
- } else { # foo/bar
- $abs = $self->catfile($Curdir, $name);
- }
+
+ $abs = $self->catfile($dir, $name)
+ if $use_dir;
+
print "Checking $abs\n" if ($trace >= 2);
next unless $self->maybe_command($abs);
print "Executing $abs\n" if ($trace >= 2);
+ my $val;
my $version_check = qq{"$abs" -le "require $ver; print qq{VER_OK}"};
# To avoid using the unportable 2>&1 to suppress STDERR,
= reverse grep { $self->file_name_is_absolute($_) } $self->path;
$interpreter = '';
- foreach my $dir (@absdirs) {
- if ( $self->maybe_command($cmd) ) {
+ foreach my $dir (@absdirs) {
+ my $maybefile = $self->catfile($dir,$cmd);
+ if ( $self->maybe_command($maybefile) ) {
warn "Ignoring $interpreter in $file\n"
if $Verbose && $interpreter;
- $interpreter = $self->catfile( $dir, $cmd );
+ $interpreter = $maybefile;
}
}
}
# To force inclusion, just name it "Configure.pod", or override
# MAN3PODS
foreach my $name (keys %manifypods) {
- if ($self->{PERL_CORE} and $name =~ /(config|setup).*\.pm/is) {
+ if (
+ ($self->{PERL_CORE} and $name =~ /(config|setup).*\.pm/is) or
+ ( $name =~ m/^README\.pod$/i ) # don't manify top-level README.pod
+ ) {
delete $manifypods{$name};
next;
}
$inst = $self->libscan($inst);
print "libscan($path) => '$inst'\n" if ($Verbose >= 2);
return unless $inst;
- $self->{PM}{$path} = $inst;
+ if ($self->{XSMULTI} and $inst =~ /\.xs\z/) {
+ my($base); ($base = $path) =~ s/\.xs\z//;
+ $self->{XS}{$path} = "$base.c";
+ push @{$self->{C}}, "$base.c";
+ push @{$self->{O_FILES}}, "$base$self->{OBJ_EXT}";
+ } else {
+ $self->{PM}{$path} = $inst;
+ }
}, @{$self->{PMLIBDIRS}});
}
}
$self->{PERL_CORE} = $ENV{PERL_CORE} unless exists $self->{PERL_CORE};
$self->{PERL_CORE} = 0 unless defined $self->{PERL_CORE};
+ # Make sure perl can find itself before it's installed.
+ my $lib_paths = $self->{UNINSTALLED_PERL} || $self->{PERL_CORE}
+ ? $self->{PERL_ARCHLIB} ne $self->{PERL_LIB} ?
+ q{ "-I$(PERL_LIB)" "-I$(PERL_ARCHLIB)"} : q{ "-I$(PERL_LIB)"}
+ : undef;
+ my $inst_lib_paths = $self->{INST_ARCHLIB} ne $self->{INST_LIB}
+ ? 'RUN)'.$perlflags.' "-I$(INST_ARCHLIB)" "-I$(INST_LIB)"'
+ : 'RUN)'.$perlflags.' "-I$(INST_LIB)"';
# How do we run perl?
foreach my $perl (qw(PERL FULLPERL ABSPERL)) {
my $run = $perl.'RUN';
$self->{$run} = qq{\$($perl)};
+ $self->{$run} .= $lib_paths if $lib_paths;
- # Make sure perl can find itself before it's installed.
- $self->{$run} .= q{ "-I$(PERL_LIB)" "-I$(PERL_ARCHLIB)"}
- if $self->{UNINSTALLED_PERL} || $self->{PERL_CORE};
-
- $self->{$perl.'RUNINST'} =
- sprintf q{$(%sRUN)%s "-I$(INST_ARCHLIB)" "-I$(INST_LIB)"},
- $perl, $perlflags;
+ $self->{$perl.'RUNINST'} = '$('.$perl.$inst_lib_paths;
}
return 1;
$self->catfile('$(INST_ARCHAUTODIR)', '$(DLBASE).$(DLEXT)');
$self->{INST_BOOT} =
$self->catfile('$(INST_ARCHAUTODIR)', '$(BASEEXT).bs');
+ if ($self->{XSMULTI}) {
+ my @exts = $self->_xs_list_basenames;
+ my (@statics, @dynamics, @boots);
+ for my $ext (@exts) {
+ my ($v, $d, $f) = File::Spec->splitpath($ext);
+ my @d = File::Spec->splitdir($d);
+ shift @d if defined $d[0] and $d[0] eq 'lib';
+ my $instdir = $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f);
+ my $instfile = $self->catfile($instdir, $f);
+ push @statics, "$instfile\$(LIB_EXT)";
+
+ # Dynamic library names may need special handling.
+ my $dynfile = $instfile;
+ eval { require DynaLoader };
+ if (defined &DynaLoader::mod2fname) {
+ $dynfile = $self->catfile($instdir, &DynaLoader::mod2fname([@d, $f]));
+ }
+
+ push @dynamics, "$dynfile.\$(DLEXT)";
+ push @boots, "$instfile.bs";
+ }
+ $self->{INST_STATIC} = join ' ', @statics;
+ $self->{INST_DYNAMIC} = join ' ', @dynamics;
+ $self->{INST_BOOT} = join ' ', @boots;
+ }
} else {
$self->{INST_STATIC} = '';
$self->{INST_DYNAMIC} = '';
-$(NOECHO) $(MKPATH) "$(DESTINSTALLARCHLIB)"
-$(NOECHO) $(DOC_INSTALL) \
"Module" "$(NAME)" \
- "installed into" $(INSTALLPRIVLIB) \
+ "installed into" "$(INSTALLPRIVLIB)" \
LINKTYPE "$(LINKTYPE)" \
VERSION "$(VERSION)" \
EXE_FILES "$(EXE_FILES)" \
-$(NOECHO) $(MKPATH) "$(DESTINSTALLARCHLIB)"
-$(NOECHO) $(DOC_INSTALL) \
"Module" "$(NAME)" \
- "installed into" $(INSTALLSITELIB) \
+ "installed into" "$(INSTALLSITELIB)" \
LINKTYPE "$(LINKTYPE)" \
VERSION "$(VERSION)" \
EXE_FILES "$(EXE_FILES)" \
-$(NOECHO) $(MKPATH) "$(DESTINSTALLARCHLIB)"
-$(NOECHO) $(DOC_INSTALL) \
"Module" "$(NAME)" \
- "installed into" $(INSTALLVENDORLIB) \
+ "installed into" "$(INSTALLVENDORLIB)" \
LINKTYPE "$(LINKTYPE)" \
VERSION "$(VERSION)" \
EXE_FILES "$(EXE_FILES)" \
my($self) = shift;
return "" unless $self->{EXE_FILES} && ref $self->{EXE_FILES} eq "ARRAY";
- my @exefiles = @{$self->{EXE_FILES}};
+ my @exefiles = sort @{$self->{EXE_FILES}};
return "" unless @exefiles;
@exefiles = map vmsify($_), @exefiles if $Is{VMS};
$to = vmsify($to) if $Is{VMS};
$fromto{$from} = $to;
}
- my @to = values %fromto;
+ my @to = sort values %fromto;
my @m;
push(@m, qq{
push @m, map "\t$_\n", $self->split_command('$(RM_F)', @to);
push @m, "\n";
-
# A target for each exe file.
- while (my($from,$to) = each %fromto) {
- last unless defined $from;
-
- push @m, sprintf <<'MAKE', $to, $from, $to, $from, $to, $to, $to;
-%s : %s $(FIRST_MAKEFILE) $(INST_SCRIPT)$(DFSEP).exists $(INST_BIN)$(DFSEP).exists
- $(NOECHO) $(RM_F) %s
- $(CP) %s %s
- $(FIXIN) %s
- -$(NOECHO) $(CHMOD) $(PERM_RWX) %s
+ my @froms = sort keys %fromto;
+ for my $from (@froms) {
+ # 1 2
+ push @m, _sprintf562 <<'MAKE', $from, $fromto{$from};
+%2$s : %1$s $(FIRST_MAKEFILE) $(INST_SCRIPT)$(DFSEP).exists $(INST_BIN)$(DFSEP).exists
+ $(NOECHO) $(RM_F) %2$s
+ $(CP) %1$s %2$s
+ $(FIXIN) %2$s
+ -$(NOECHO) $(CHMOD) $(PERM_RWX) %2$s
MAKE
join "", @m;
}
-
=item linkext (o)
Defines the linkext target which in turn defines the LINKTYPE.
=cut
+# LINKTYPE => static or dynamic or ''
sub linkext {
my($self, %attribs) = @_;
- # LINKTYPE => static or dynamic or ''
- my($linktype) = defined $attribs{LINKTYPE} ?
- $attribs{LINKTYPE} : '$(LINKTYPE)';
+ my $linktype = $attribs{LINKTYPE};
+ $linktype = $self->{LINKTYPE} unless defined $linktype;
+ if (defined $linktype and $linktype eq '') {
+ warn "Warning: LINKTYPE set to '', no longer necessary\n";
+ }
+ $linktype = '$(LINKTYPE)' unless defined $linktype;
"
linkext :: $linktype
\$(NOECHO) \$(NOOP)
=cut
sub lsdir {
- my($self) = shift;
- my($dir, $regex) = @_;
- my(@ls);
- my $dh = new DirHandle;
- $dh->open($dir || ".") or return ();
- @ls = $dh->read;
- $dh->close;
- @ls = grep(/$regex/, @ls) if $regex;
+ # $self
+ my(undef, $dir, $regex) = @_;
+ opendir(my $dh, defined($dir) ? $dir : ".")
+ or return;
+ my @ls = readdir $dh;
+ closedir $dh;
+ @ls = grep(/$regex/, @ls) if defined $regex;
@ls;
}
sub macro {
my($self,%attribs) = @_;
- my(@m,$key,$val);
- while (($key,$val) = each %attribs){
- last unless defined $key;
+ my @m;
+ foreach my $key (sort keys %attribs) {
+ my $val = $attribs{$key};
push @m, "$key = $val\n";
}
join "", @m;
my($self, %attribs) = @_;
my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmp, $libperl) =
@attribs{qw(MAKE DIRS STAT EXTRA INCL TARGET TMP LIBPERL)};
+ s/^(.*)/"-I$1"/ for @{$perlinc || []};
my(@m);
push @m, "
# --- MakeMaker makeaperl section ---
MAP_TARGET = $target
FULLPERL = $self->{FULLPERL}
+MAP_PERLINC = @{$perlinc || []}
";
return join '', @m if $self->{PARENT};
unless ($self->{MAKEAPERL}) {
push @m, q{
-$(MAP_TARGET) :: static $(MAKE_APERL_FILE)
+$(MAP_TARGET) :: $(MAKE_APERL_FILE)
$(MAKE) $(USEMAKEFILE) $(MAKE_APERL_FILE) $@
-$(MAKE_APERL_FILE) : $(FIRST_MAKEFILE) pm_to_blib
+$(MAKE_APERL_FILE) : static $(FIRST_MAKEFILE) pm_to_blib
$(NOECHO) $(ECHO) Writing \"$(MAKE_APERL_FILE)\" for this $(MAP_TARGET)
$(NOECHO) $(PERLRUNINST) \
Makefile.PL DIR="}, $dir, q{" \
MAKEAPERL=1 NORECURS=1 CCCDLFLAGS=};
foreach (@ARGV){
- if( /\s/ ){
- s/=(.*)/='$1'/;
+ my $arg = $_; # avoid lvalue aliasing
+ if ( $arg =~ /(^.*?=)(.*['\s].*)/ ) {
+ $arg = $1 . $self->quote_literal($2);
}
- push @m, " \\\n\t\t$_";
+ push @m, " \\\n\t\t$arg";
}
-# push @m, map( " \\\n\t\t$_", @ARGV );
push @m, "\n";
return join '', @m;
}
-
-
- my($cccmd, $linkcmd, $lperl);
-
-
- $cccmd = $self->const_cccmd($libperl);
+ my $cccmd = $self->const_cccmd($libperl);
$cccmd =~ s/^CCCMD\s*=\s*//;
$cccmd =~ s/\$\(INC\)/ "-I$self->{PERL_INC}" /;
$cccmd .= " $Config{cccdlflags}"
$cccmd =~ s/\(CC\)/\(PERLMAINCC\)/;
# The front matter of the linkcommand...
- $linkcmd = join ' ', "\$(CC)",
+ my $linkcmd = join ' ', "\$(CC)",
grep($_, @Config{qw(ldflags ccdlflags)});
$linkcmd =~ s/\s+/ /g;
$linkcmd =~ s,(perl\.exp),\$(PERL_INC)/$1,;
# Which *.a files could we make use of...
my %static;
require File::Find;
+ # don't use File::Spec here because on Win32 F::F still uses "/"
+ my $installed_version = join('/',
+ 'auto', $self->{FULLEXT}, "$self->{BASEEXT}$self->{LIB_EXT}"
+ );
File::Find::find(sub {
return unless m/\Q$self->{LIB_EXT}\E$/;
# Once the patch to minimod.PL is in the distribution, I can
# drop it
- return if $File::Find::name =~ m:auto/$self->{FULLEXT}/$self->{BASEEXT}$self->{LIB_EXT}\z:;
+ return if $File::Find::name =~ m:\Q$installed_version\E\z:;
use Cwd 'cwd';
$static{cwd() . "/" . $_}++;
}, grep( -d $_, @{$searchdirs || []}) );
# MAP_STATIC doesn't look into subdirs yet. Once "all" is made and we
# regenerate the Makefiles, MAP_STATIC and the dependencies for
# extralibs.all are computed correctly
+ my @map_static = reverse sort keys %static;
push @m, "
MAP_LINKCMD = $linkcmd
-MAP_PERLINC = @{$perlinc || []}
-MAP_STATIC = ",
-join(" \\\n\t", reverse sort keys %static), "
+MAP_STATIC = ", join(" \\\n\t", map { qq{"$_"} } @map_static), "
+MAP_STATICDEP = ", join(' ', map { $self->quote_dep($_) } @map_static), "
MAP_PRELIBS = $Config{perllibs} $Config{cryptlib}
";
+ my $lperl;
if (defined $libperl) {
($lperl = $libperl) =~ s/\$\(A\)/$self->{LIB_EXT}/;
}
}
}
- print "Warning: $libperl not found
- If you're going to build a static perl binary, make sure perl is installed
- otherwise ignore this warning\n"
- unless (-f $lperl || defined($self->{PERL_SRC}));
+ print <<EOF unless -f $lperl || defined($self->{PERL_SRC});
+Warning: $libperl not found
+If you're going to build a static perl binary, make sure perl is installed
+otherwise ignore this warning
+EOF
}
# SUNOS ld does not take the full path to a shared library
my $llibperl = $libperl ? '$(MAP_LIBPERL)' : '-lperl';
+ my $libperl_dep = $self->quote_dep($libperl);
push @m, "
MAP_LIBPERL = $libperl
+MAP_LIBPERLDEP = $libperl_dep
LLIBPERL = $llibperl
";
push @m, "\tcat $catfile >> \$\@\n";
}
-push @m, "
-\$(MAP_TARGET) :: $tmp/perlmain\$(OBJ_EXT) \$(MAP_LIBPERL) \$(MAP_STATIC) \$(INST_ARCHAUTODIR)/extralibs.all
- \$(MAP_LINKCMD) -o \$\@ \$(OPTIMIZE) $tmp/perlmain\$(OBJ_EXT) \$(LDFROM) \$(MAP_STATIC) \$(LLIBPERL) `cat \$(INST_ARCHAUTODIR)/extralibs.all` \$(MAP_PRELIBS)
- \$(NOECHO) \$(ECHO) 'To install the new \"\$(MAP_TARGET)\" binary, call'
- \$(NOECHO) \$(ECHO) ' \$(MAKE) \$(USEMAKEFILE) $makefilename inst_perl MAP_TARGET=\$(MAP_TARGET)'
- \$(NOECHO) \$(ECHO) 'To remove the intermediate files say'
- \$(NOECHO) \$(ECHO) ' \$(MAKE) \$(USEMAKEFILE) $makefilename map_clean'
+ my $ldfrom = $self->{XSMULTI} ? '' : '$(LDFROM)';
+ # 1 2 3 4
+ push @m, _sprintf562 <<'EOF', $tmp, $self->xs_obj_opt('$@'), $ldfrom, $makefilename;
+$(MAP_TARGET) :: %1$s/perlmain$(OBJ_EXT) $(MAP_LIBPERLDEP) $(MAP_STATICDEP) $(INST_ARCHAUTODIR)/extralibs.all
+ $(MAP_LINKCMD) %2$s $(OPTIMIZE) %1$s/perlmain$(OBJ_EXT) %3$s $(MAP_STATIC) "$(LLIBPERL)" `cat $(INST_ARCHAUTODIR)/extralibs.all` $(MAP_PRELIBS)
+ $(NOECHO) $(ECHO) "To install the new '$(MAP_TARGET)' binary, call"
+ $(NOECHO) $(ECHO) " $(MAKE) $(USEMAKEFILE) %4$s inst_perl MAP_TARGET=$(MAP_TARGET)"
+ $(NOECHO) $(ECHO) " $(MAKE) $(USEMAKEFILE) %4$s map_clean"
-$tmp/perlmain\$(OBJ_EXT): $tmp/perlmain.c
-";
+%1$s/perlmain\$(OBJ_EXT): %1$s/perlmain.c
+EOF
push @m, "\t".$self->cd($tmp, qq[$cccmd "-I\$(PERL_INC)" perlmain.c])."\n";
- push @m, qq{
-$tmp/perlmain.c: $makefilename}, q{
+ my $maybe_DynaLoader = $Config{usedl} ? 'q(DynaLoader)' : '';
+ push @m, _sprintf562 <<'EOF', $tmp, $makefilename, $maybe_DynaLoader;
+
+%1$s/perlmain.c: %2$s
$(NOECHO) $(ECHO) Writing $@
- $(NOECHO) $(PERL) $(MAP_PERLINC) "-MExtUtils::Miniperl" \\
- -e "writemain(grep s#.*/auto/##s, split(q| |, q|$(MAP_STATIC)|))" > $@t && $(MV) $@t $@
+ $(NOECHO) $(PERL) $(MAP_PERLINC) "-MExtUtils::Miniperl" \
+ -e "writemain(grep(s#.*/auto/##s, @ARGV), %3$s)" $(MAP_STATIC) > $@t
+ $(MV) $@t $@
-};
+EOF
push @m, "\t", q{$(NOECHO) $(PERL) "$(INSTALLSCRIPT)/fixpmain"
} if (defined (&Dos::UseLFN) && Dos::UseLFN()==0);
local $/ = "\n";
open(my $fh, '<', $parsefile) or die "Could not open '$parsefile': $!";
+ binmode $fh;
my $inpod = 0;
my $pod_encoding;
my $package = $self->{DISTNAME};
while (<$fh>) {
$inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;
next if !$inpod;
- chop;
+ s#\r*\n\z##; # handle CRLF input
if ( /^=encoding\s*(.*)$/i ) {
$pod_encoding = $1;
next if $inpod || /^\s*#/;
chop;
next if /^\s*(if|unless|elsif)/;
- if ( m{^ \s* package \s+ \w[\w\:\']* \s+ (v?[0-9._]+) \s* ; }x ) {
+ if ( m{^ \s* package \s+ \w[\w\:\']* \s+ (v?[0-9._]+) \s* (;|\{) }x ) {
local $^W = 0;
$result = $1;
}
=item pasthru (o)
Defines the string that is passed to recursive make calls in
-subdirectories.
+subdirectories. The variables like C<PASTHRU_DEFINE> are used in each
+level, and passed downwards on the command-line with e.g. the value of
+that level's DEFINE. Example:
+
+ # Level 0 has DEFINE = -Dfunky
+ # This code will define level 0's PASTHRU=PASTHRU_DEFINE="$(DEFINE)
+ # $(PASTHRU_DEFINE)"
+ # Level 0's $(CCCMD) will include macros $(DEFINE) and $(PASTHRU_DEFINE)
+ # So will level 1's, so when level 1 compiles, it will get right values
+ # And so ad infinitum
=cut
}
foreach my $key (qw(DEFINE INC)) {
- next unless defined $self->{$key};
- push @pasthru, "PASTHRU_$key=\"\$(PASTHRU_$key)\"";
+ # default to the make var
+ my $val = qq{\$($key)};
+ # expand within perl if given since need to use quote_literal
+ # since INC might include space-protecting ""!
+ chomp($val = $self->{$key}) if defined $self->{$key};
+ $val .= " \$(PASTHRU_$key)";
+ my $quoted = $self->quote_literal($val);
+ push @pasthru, qq{PASTHRU_$key=$quoted};
}
push @m, "\nPASTHRU = ", join ($sep, @pasthru), "\n";
CODE
my @cmds = $self->split_command($pm_to_blib,
- map { ($_, $self->{PM}->{$_}) } sort keys %{$self->{PM}});
+ map { ($self->quote_literal($_) => $self->quote_literal($self->{PM}->{$_})) } sort keys %{$self->{PM}});
$r .= join '', map { "\t\$(NOECHO) $_\n" } @cmds;
$r .= qq{\t\$(NOECHO) \$(TOUCH) pm_to_blib\n};
return $r;
}
-=item post_constants (o)
-
-Returns an empty string per default. Dedicated to overrides from
-within Makefile.PL after all constants have been defined.
-
-=cut
-
-sub post_constants{
- "";
-}
-
-=item post_initialize (o)
-
-Returns an empty string per default. Used in Makefile.PLs to add some
-chunk of text to the Makefile after the object is initialized.
-
-=cut
-
-sub post_initialize {
- "";
-}
-
-=item postamble (o)
-
-Returns an empty string. Can be used in Makefile.PLs to write some
-text to the Makefile at the end.
-
-=cut
-
-sub postamble {
- "";
-}
-
# transform dot-separated version string into comma-separated quadruple
# examples: '1.2.3.4.5' => '1,2,3,4'
# '1.2.3' => '1,2,3,0'
$abstract =~ s/</</g;
$abstract =~ s/>/>/g;
- my $author = join(', ',@{$self->{AUTHOR} || []});
+ my $author = join(', ',@{ ref $self->{AUTHOR} eq 'ARRAY' ? $self->{AUTHOR} : [ $self->{AUTHOR} || '']});
$author =~ s/</</g;
$author =~ s/>/>/g;
- my $ppd_file = '$(DISTNAME).ppd';
+ my $ppd_file = "$self->{DISTNAME}.ppd";
- my @ppd_cmds = $self->echo(<<'PPD_HTML', $ppd_file, { append => 0, allow_variables => 1 });
-<SOFTPKG NAME="$(DISTNAME)" VERSION="$(VERSION)">
-PPD_HTML
+ my @ppd_chunks = qq(<SOFTPKG NAME="$self->{DISTNAME}" VERSION="$self->{VERSION}">\n);
- my $ppd_xml = sprintf <<'PPD_HTML', $abstract, $author;
+ push @ppd_chunks, sprintf <<'PPD_HTML', $abstract, $author;
<ABSTRACT>%s</ABSTRACT>
<AUTHOR>%s</AUTHOR>
PPD_HTML
- $ppd_xml .= " <IMPLEMENTATION>\n";
+ push @ppd_chunks, " <IMPLEMENTATION>\n";
if ( $self->{MIN_PERL_VERSION} ) {
my $min_perl_version = $self->_ppd_version($self->{MIN_PERL_VERSION});
- $ppd_xml .= sprintf <<'PPD_PERLVERS', $min_perl_version;
+ push @ppd_chunks, sprintf <<'PPD_PERLVERS', $min_perl_version;
<PERLCORE VERSION="%s" />
PPD_PERLVERS
my %attrs = ( NAME => $name );
$attrs{VERSION} = $version if $version;
my $attrs = join " ", map { qq[$_="$attrs{$_}"] } sort keys %attrs;
- $ppd_xml .= qq( <REQUIRE $attrs />\n);
+ push @ppd_chunks, qq( <REQUIRE $attrs />\n);
}
my $archname = $Config{archname};
# version that changes when binary compatibility may change
$archname .= "-$Config{PERL_REVISION}.$Config{PERL_VERSION}";
}
- $ppd_xml .= sprintf <<'PPD_OUT', $archname;
+ push @ppd_chunks, sprintf <<'PPD_OUT', $archname;
<ARCHITECTURE NAME="%s" />
PPD_OUT
if ($self->{PPM_INSTALL_SCRIPT}) {
if ($self->{PPM_INSTALL_EXEC}) {
- $ppd_xml .= sprintf qq{ <INSTALL EXEC="%s">%s</INSTALL>\n},
+ push @ppd_chunks, sprintf qq{ <INSTALL EXEC="%s">%s</INSTALL>\n},
$self->{PPM_INSTALL_EXEC}, $self->{PPM_INSTALL_SCRIPT};
}
else {
- $ppd_xml .= sprintf qq{ <INSTALL>%s</INSTALL>\n},
+ push @ppd_chunks, sprintf qq{ <INSTALL>%s</INSTALL>\n},
$self->{PPM_INSTALL_SCRIPT};
}
}
if ($self->{PPM_UNINSTALL_SCRIPT}) {
if ($self->{PPM_UNINSTALL_EXEC}) {
- $ppd_xml .= sprintf qq{ <UNINSTALL EXEC="%s">%s</UNINSTALL>\n},
+ push @ppd_chunks, sprintf qq{ <UNINSTALL EXEC="%s">%s</UNINSTALL>\n},
$self->{PPM_UNINSTALL_EXEC}, $self->{PPM_UNINSTALL_SCRIPT};
}
else {
- $ppd_xml .= sprintf qq{ <UNINSTALL>%s</UNINSTALL>\n},
+ push @ppd_chunks, sprintf qq{ <UNINSTALL>%s</UNINSTALL>\n},
$self->{PPM_UNINSTALL_SCRIPT};
}
}
my ($bin_location) = $self->{BINARY_LOCATION} || '';
$bin_location =~ s/\\/\\\\/g;
- $ppd_xml .= sprintf <<'PPD_XML', $bin_location;
+ push @ppd_chunks, sprintf <<'PPD_XML', $bin_location;
<CODEBASE HREF="%s" />
</IMPLEMENTATION>
</SOFTPKG>
PPD_XML
- push @ppd_cmds, $self->echo($ppd_xml, $ppd_file, { append => 1 });
+ my @ppd_cmds = $self->stashmeta(join('', @ppd_chunks), $ppd_file);
return sprintf <<'PPD_OUT', join "\n\t", @ppd_cmds;
# Creates a PPD (Perl Package Description) for a binary distribution.
foreach my $plfile (sort keys %$pl_files) {
my $list = ref($pl_files->{$plfile})
? $pl_files->{$plfile}
- : [$pl_files->{$plfile}];
+ : [$pl_files->{$plfile}];
- foreach my $target (@$list) {
+ foreach my $target (@$list) {
if( $Is{VMS} ) {
$plfile = vmsify($self->eliminate_macros($plfile));
$target = vmsify($self->eliminate_macros($target));
}
- # Normally a .PL file runs AFTER pm_to_blib so it can have
- # blib in its @INC and load the just built modules. BUT if
- # the generated module is something in $(TO_INST_PM) which
- # pm_to_blib depends on then it can't depend on pm_to_blib
- # else we have a dependency loop.
- my $pm_dep;
- my $perlrun;
- if( defined $self->{PM}{$target} ) {
- $pm_dep = '';
- $perlrun = 'PERLRUN';
- }
- else {
- $pm_dep = 'pm_to_blib';
- $perlrun = 'PERLRUNINST';
- }
+ # Normally a .PL file runs AFTER pm_to_blib so it can have
+ # blib in its @INC and load the just built modules. BUT if
+ # the generated module is something in $(TO_INST_PM) which
+ # pm_to_blib depends on then it can't depend on pm_to_blib
+ # else we have a dependency loop.
+ my $pm_dep;
+ my $perlrun;
+ if( defined $self->{PM}{$target} ) {
+ $pm_dep = '';
+ $perlrun = 'PERLRUN';
+ }
+ else {
+ $pm_dep = 'pm_to_blib';
+ $perlrun = 'PERLRUNINST';
+ }
$m .= <<MAKE_FRAG;
\$($perlrun) $plfile $target
MAKE_FRAG
- }
+ }
}
return $m;
';
}
-=item static_lib (o)
+sub static_lib {
+ my($self) = @_;
+ return '' unless $self->has_link_code;
+ my(@m);
+ my @libs;
+ if ($self->{XSMULTI}) {
+ for my $ext ($self->_xs_list_basenames) {
+ my ($v, $d, $f) = File::Spec->splitpath($ext);
+ my @d = File::Spec->splitdir($d);
+ shift @d if $d[0] eq 'lib';
+ my $instdir = $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f);
+ my $instfile = $self->catfile($instdir, "$f\$(LIB_EXT)");
+ my $objfile = "$ext\$(OBJ_EXT)";
+ push @libs, [ $objfile, $instfile, $instdir ];
+ }
+ } else {
+ @libs = ([ qw($(OBJECT) $(INST_STATIC) $(INST_ARCHAUTODIR)) ]);
+ }
+ push @m, map { $self->xs_make_static_lib(@$_); } @libs;
+ join "\n", @m;
+}
+
+=item xs_make_static_lib
-Defines how to produce the *.a (or equivalent) files.
+Defines the recipes for the C<static_lib> section.
=cut
-sub static_lib {
- my($self) = @_;
- return '' unless $self->has_link_code;
+sub xs_make_static_lib {
+ my ($self, $from, $to, $todir) = @_;
+ my @m = sprintf '%s: %s $(MYEXTLIB) %s$(DFSEP).exists'."\n", $to, $from, $todir;
+ push @m, "\t\$(RM_F) \"\$\@\"\n";
+ push @m, $self->static_lib_fixtures;
+ push @m, $self->static_lib_pure_cmd($from);
+ push @m, "\t\$(CHMOD) \$(PERM_RWX) \$\@\n";
+ push @m, $self->static_lib_closures($todir);
+ join '', @m;
+}
- my(@m);
- push(@m, <<'END');
+=item static_lib_closures
-$(INST_STATIC) : $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)$(DFSEP).exists
- $(RM_RF) $@
-END
+Records C<$(EXTRALIBS)> in F<extralibs.ld> and F<$(PERL_SRC)/ext.libs>.
+
+=cut
+sub static_lib_closures {
+ my ($self, $todir) = @_;
+ my @m = sprintf <<'MAKE_FRAG', $todir;
+ $(NOECHO) $(ECHO) "$(EXTRALIBS)" > %s$(DFSEP)extralibs.ld
+MAKE_FRAG
+ # Old mechanism - still available:
+ push @m, <<'MAKE_FRAG' if $self->{PERL_SRC} && $self->{EXTRALIBS};
+ $(NOECHO) $(ECHO) "$(EXTRALIBS)" >> $(PERL_SRC)$(DFSEP)ext.libs
+MAKE_FRAG
+ @m;
+}
+
+=item static_lib_fixtures
+
+Handles copying C<$(MYEXTLIB)> as starter for final static library that
+then gets added to.
+
+=cut
+
+sub static_lib_fixtures {
+ my ($self) = @_;
# If this extension has its own library (eg SDBM_File)
# then copy that to $(INST_STATIC) and add $(OBJECT) into it.
- push(@m, <<'MAKE_FRAG') if $self->{MYEXTLIB};
- $(CP) $(MYEXTLIB) "$@"
-MAKE_FRAG
+ return unless $self->{MYEXTLIB};
+ "\t\$(CP) \$(MYEXTLIB) \"\$\@\"\n";
+}
+
+=item static_lib_pure_cmd
+
+Defines how to run the archive utility.
+=cut
+
+sub static_lib_pure_cmd {
+ my ($self, $from) = @_;
my $ar;
if (exists $self->{FULL_AR} && -x $self->{FULL_AR}) {
# Prefer the absolute pathed ar if available so that PATH
} else {
$ar = 'AR';
}
- push @m, sprintf <<'MAKE_FRAG', $ar;
- $(%s) $(AR_STATIC_ARGS) $@ $(OBJECT) && $(RANLIB) $@
- $(CHMOD) $(PERM_RWX) $@
- $(NOECHO) $(ECHO) "$(EXTRALIBS)" > "$(INST_ARCHAUTODIR)/extralibs.ld"
+ sprintf <<'MAKE_FRAG', $ar, $from;
+ $(%s) $(AR_STATIC_ARGS) "$@" %s
+ $(RANLIB) "$@"
MAKE_FRAG
-
- # Old mechanism - still available:
- push @m, <<'MAKE_FRAG' if $self->{PERL_SRC} && $self->{EXTRALIBS};
- $(NOECHO) $(ECHO) "$(EXTRALIBS)" >> "$(PERL_SRC)/ext.libs"
-MAKE_FRAG
-
- join('', @m);
}
=item staticmake (o)
# subdirectories containing further Makefile.PL scripts.
# It calls the subdir_x() method for each subdirectory.
foreach my $dir (@{$self->{DIR}}){
- push(@m, $self->subdir_x($dir));
+ push @m, $self->subdir_x($dir);
#### print "Including $dir subdirectory\n";
}
if (@m){
- unshift(@m, "
+ unshift @m, <<'EOF';
+
# The default clean, realclean and test targets in this Makefile
# have automatically been given entries for each subdir.
-");
+EOF
} else {
push(@m, "\n# none")
}
=cut
sub test {
-# --- Test and Installation Sections ---
-
my($self, %attribs) = @_;
my $tests = $attribs{TESTS} || '';
if (!$tests && -d 't' && defined $attribs{RECURSIVE_TEST_FILES}) {
# have to do this because nmake is broken
$tests =~ s!/!\\!g if $self->is_make_type('nmake');
# note: 'test.pl' name is also hardcoded in init_dirscan()
- my(@m);
- push(@m,"
+ my @m;
+ my $default_testtype = $Config{usedl} ? 'dynamic' : 'static';
+ push @m, <<EOF;
TEST_VERBOSE=0
TEST_TYPE=test_\$(LINKTYPE)
TEST_FILE = test.pl
TESTDB_SW = -d
testdb :: testdb_\$(LINKTYPE)
+ \$(NOECHO) \$(NOOP)
-test :: \$(TEST_TYPE) subdirs-test
-
-subdirs-test ::
+test :: \$(TEST_TYPE)
\$(NOECHO) \$(NOOP)
-");
+# Occasionally we may face this degenerate target:
+test_ : test_$default_testtype
+ \$(NOECHO) \$(NOOP)
- foreach my $dir (@{ $self->{DIR} }) {
- my $test = $self->cd($dir, '$(MAKE) test $(PASTHRU)');
+EOF
- push @m, <<END
-subdirs-test ::
- \$(NOECHO) $test
+ for my $linktype (qw(dynamic static)) {
+ my $directdeps = "$linktype pure_all";
+ push @m, "subdirs-test_$linktype :: $directdeps\n";
+ foreach my $dir (@{ $self->{DIR} }) {
+ my $test = $self->cd($dir, "\$(MAKE) test_$linktype \$(PASTHRU)");
+ push @m, "\t\$(NOECHO) $test\n";
+ }
+ push @m, "\n";
+ if ($tests or -f "test.pl") {
+ for my $testspec ([ '', '' ], [ 'db', ' $(TESTDB_SW)' ]) {
+ my ($db, $switch) = @$testspec;
+ my ($command, $deps);
+ # if testdb, build all but don't test all
+ $deps = $db eq 'db' ? $directdeps : "subdirs-test_$linktype";
+ if ($linktype eq 'static' and $self->needs_linking) {
+ my $target = File::Spec->rel2abs('$(MAP_TARGET)');
+ $command = qq{"$target" \$(MAP_PERLINC)};
+ $deps .= ' $(MAP_TARGET)';
+ } else {
+ $command = '$(FULLPERLRUN)' . $switch;
+ }
+ push @m, "test${db}_$linktype :: $deps\n";
+ if ($db eq 'db') {
+ push @m, $self->test_via_script($command, '$(TEST_FILE)')
+ } else {
+ push @m, $self->test_via_script($command, '$(TEST_FILE)')
+ if -f "test.pl";
+ push @m, $self->test_via_harness($command, '$(TEST_FILES)')
+ if $tests;
+ }
+ push @m, "\n";
+ }
+ } else {
+ push @m, _sprintf562 <<'EOF', $linktype;
+testdb_%1$s test_%1$s :: subdirs-test_%1$s
+ $(NOECHO) $(ECHO) 'No tests defined for $(NAME) extension.'
-END
+EOF
+ }
}
- push(@m, "\t\$(NOECHO) \$(ECHO) 'No tests defined for \$(NAME) extension.'\n")
- unless $tests or -f "test.pl" or @{$self->{DIR}};
- push(@m, "\n");
-
- push(@m, "test_dynamic :: pure_all\n");
- push(@m, $self->test_via_harness('$(FULLPERLRUN)', '$(TEST_FILES)'))
- if $tests;
- push(@m, $self->test_via_script('$(FULLPERLRUN)', '$(TEST_FILE)'))
- if -f "test.pl";
- push(@m, "\n");
-
- push(@m, "testdb_dynamic :: pure_all\n");
- push(@m, $self->test_via_script('$(FULLPERLRUN) $(TESTDB_SW)',
- '$(TEST_FILE)'));
- push(@m, "\n");
-
- # Occasionally we may face this degenerate target:
- push @m, "test_ : test_dynamic\n\n";
-
- if ($self->needs_linking()) {
- push(@m, "test_static :: pure_all \$(MAP_TARGET)\n");
- push(@m, $self->test_via_harness('./$(MAP_TARGET)', '$(TEST_FILES)')) if $tests;
- push(@m, $self->test_via_script('./$(MAP_TARGET)', '$(TEST_FILE)')) if -f "test.pl";
- push(@m, "\n");
- push(@m, "testdb_static :: pure_all \$(MAP_TARGET)\n");
- push(@m, $self->test_via_script('./$(MAP_TARGET) $(TESTDB_SW)', '$(TEST_FILE)'));
- push(@m, "\n");
- } else {
- push @m, "test_static :: test_dynamic\n";
- push @m, "testdb_static :: testdb_dynamic\n";
- }
- join("", @m);
+ join "", @m;
}
=item test_via_harness (override)
}
die "ExtUtils::MM_Unix::tool_xsubpp : Can't find xsubpp" if !$foundxsubpp;
- my $tmdir = File::Spec->catdir($self->{PERL_LIB},"ExtUtils");
+ my $tmdir = $self->catdir($self->{PERL_LIB},"ExtUtils");
my(@tmdeps) = $self->catfile($tmdir,'typemap');
if( $self->{TYPEMAPS} ){
foreach my $typemap (@{$self->{TYPEMAPS}}){
warn "Typemap $typemap not found.\n";
}
else {
- push(@tmdeps, $typemap);
+ $typemap = vmsify($typemap) if $Is{VMS};
+ push(@tmdeps, $typemap);
}
}
}
push(@tmdeps, "typemap") if -f "typemap";
- my @tmargs = map(qq{-typemap "$_"}, @tmdeps);
+ # absolutised because with deep-located typemaps, eg "lib/XS/typemap",
+ # if xsubpp is called from top level with
+ # $(XSUBPP) ... -typemap "lib/XS/typemap" "lib/XS/Test.xs"
+ # it says:
+ # Can't find lib/XS/type map in (fulldir)/lib/XS
+ # because ExtUtils::ParseXS::process_file chdir's to .xs file's
+ # location. This is the only way to get all specified typemaps used,
+ # wherever located.
+ my @tmargs = map { '-typemap '.$self->quote_literal(File::Spec->rel2abs($_)) } @tmdeps;
$_ = $self->quote_dep($_) for @tmdeps;
if( exists $self->{XSOPT} ){
unshift( @tmargs, $self->{XSOPT} );
push @m, $self->all_target, "\n" unless $self->{SKIPHASH}{'all'};
- push @m, '
+ push @m, sprintf <<'EOF';
pure_all :: config pm_to_blib subdirs linkext
$(NOECHO) $(NOOP)
+ $(NOECHO) $(NOOP)
+
subdirs :: $(MYEXTLIB)
$(NOECHO) $(NOOP)
config :: $(FIRST_MAKEFILE) blibdirs
$(NOECHO) $(NOOP)
-';
+EOF
push @m, '
-$(O_FILES): $(H_FILES)
+$(O_FILES) : $(H_FILES)
' if @{$self->{O_FILES} || []} && @{$self->{H} || []};
push @m, q{
return '' unless $self->needs_linking();
'
.xs.c:
- $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(XSUBPP_EXTRA_ARGS) $*.xs > $*.xsc && $(MV) $*.xsc $*.c
+ $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(XSUBPP_EXTRA_ARGS) $*.xs > $*.xsc
+ $(MV) $*.xsc $*.c
';
}
return '' unless $self->needs_linking();
'
.xs.cpp:
- $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc && $(MV) $*.xsc $*.cpp
+ $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc
+ $(MV) $*.xsc $*.cpp
';
}
=item xs_o (o)
-Defines suffix rules to go from XS to object files directly. This is
-only intended for broken make implementations.
+Defines suffix rules to go from XS to object files directly. This was
+originally only intended for broken make implementations, but is now
+necessary for per-XS file under C<XSMULTI>, since each XS file might
+have an individual C<$(VERSION)>.
=cut
-sub xs_o { # many makes are too dumb to use xs_c then c_o
- my($self) = shift;
+sub xs_o {
+ my ($self) = @_;
return '' unless $self->needs_linking();
- '
-.xs$(OBJ_EXT):
- $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc && $(MV) $*.xsc $*.c
- $(CCCMD) $(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) $(DEFINE) $*.c
-';
+ my $m_o = $self->{XSMULTI} ? $self->xs_obj_opt('$*$(OBJ_EXT)') : '';
+ my $frag = '';
+ # dmake makes noise about ambiguous rule
+ $frag .= sprintf <<'EOF', $m_o unless $self->is_make_type('dmake');
+.xs$(OBJ_EXT) :
+ $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc
+ $(MV) $*.xsc $*.c
+ $(CCCMD) $(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) $(DEFINE) $*.c %s
+EOF
+ if ($self->{XSMULTI}) {
+ for my $ext ($self->_xs_list_basenames) {
+ my $pmfile = "$ext.pm";
+ croak "$ext.xs has no matching $pmfile: $!" unless -f $pmfile;
+ my $version = $self->parse_version($pmfile);
+ my $cccmd = $self->{CONST_CCCMD};
+ $cccmd =~ s/^\s*CCCMD\s*=\s*//;
+ $cccmd =~ s/\$\(DEFINE_VERSION\)/-DVERSION=\\"$version\\"/;
+ $cccmd =~ s/\$\(XS_DEFINE_VERSION\)/-DXS_VERSION=\\"$version\\"/;
+ $self->_xsbuild_replace_macro($cccmd, 'xs', $ext, 'INC');
+ my $define = '$(DEFINE)';
+ $self->_xsbuild_replace_macro($define, 'xs', $ext, 'DEFINE');
+ # 1 2 3 4
+ $frag .= _sprintf562 <<'EOF', $ext, $cccmd, $m_o, $define;
+
+%1$s$(OBJ_EXT): %1$s.xs
+ $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc
+ $(MV) $*.xsc $*.c
+ %2$s $(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) %4$s $*.c %3$s
+EOF
+ }
+ }
+ $frag;
}
+# param gets modified
+sub _xsbuild_replace_macro {
+ my ($self, undef, $xstype, $ext, $varname) = @_;
+ my $value = $self->_xsbuild_value($xstype, $ext, $varname);
+ return unless defined $value;
+ $_[1] =~ s/\$\($varname\)/$value/;
+}
+
+sub _xsbuild_value {
+ my ($self, $xstype, $ext, $varname) = @_;
+ return $self->{XSBUILD}{$xstype}{$ext}{$varname}
+ if $self->{XSBUILD}{$xstype}{$ext}{$varname};
+ return $self->{XSBUILD}{$xstype}{all}{$varname}
+ if $self->{XSBUILD}{$xstype}{all}{$varname};
+ ();
+}
1;
use File::Basename;
-our $VERSION = '7.10_01';
+our $VERSION = '7.18';
+$VERSION = eval $VERSION;
require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
-use ExtUtils::MakeMaker qw($Verbose neatvalue);
+use ExtUtils::MakeMaker qw($Verbose neatvalue _sprintf562);
our $Revision = $ExtUtils::MakeMaker::Revision;
=item pasthru (override)
-VMS has $(MMSQUALIFIERS) which is a listing of all the original command line
-options. This is used in every invocation of make in the VMS Makefile so
-PASTHRU should not be necessary. Using PASTHRU tends to blow commands past
-the 256 character limit.
+The list of macro definitions to be passed through must be specified using
+the /MACRO qualifier and must not add another /DEFINE qualifier. We prepend
+our own comma here to the contents of $(PASTHRU_DEFINE) because it is often
+empty and a comma always present in CCFLAGS would generate a missing
+qualifier value error.
=cut
sub pasthru {
- return "PASTHRU=\n";
+ my($self) = shift;
+ my $pasthru = $self->SUPER::pasthru;
+ $pasthru =~ s|(PASTHRU\s*=\s*)|$1/MACRO=(|;
+ $pasthru =~ s|\n\z|)\n|m;
+ $pasthru =~ s|/defi?n?e?=\(?([^\),]+)\)?|,$1|ig;
+
+ return $pasthru;
}
my $term = $1;
$term =~ s:^\((.+)\)$:$1:;
push @terms, $term;
- }
+ }
if ($type eq 'Def') {
push @terms, qw[ $(DEFINE_VERSION) $(XS_DEFINE_VERSION) ];
}
if (@terms) {
$quals =~ s:/${type}i?n?e?=[^/]+::ig;
- $quals .= "/${type}ine=(" . join(',',@terms) . ')';
+ # PASTHRU_DEFINE will have its own comma
+ $quals .= "/${type}ine=(" . join(',',@terms) . ($type eq 'Def' ? '$(PASTHRU_DEFINE)' : '') . ')';
}
}
return '' unless $self->needs_linking();
'
.c$(OBJ_EXT) :
- $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c
+ $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT)
.cpp$(OBJ_EXT) :
- $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cpp
+ $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cpp /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT)
.cxx$(OBJ_EXT) :
- $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cxx
+ $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cxx /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT)
';
}
return '' unless $self->needs_linking();
'
.xs.c :
- $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET)
+ $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET_NAME).xsc
+ $(MV) $(MMS$TARGET_NAME).xsc $(MMS$TARGET_NAME).c
';
}
=cut
-sub xs_o { # many makes are too dumb to use xs_c then c_o
- my($self) = @_;
+sub xs_o {
+ my ($self) = @_;
return '' unless $self->needs_linking();
- '
+ my $frag = '
.xs$(OBJ_EXT) :
- $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET_NAME).c
- $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c
+ $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET_NAME).xsc
+ $(MV) $(MMS$TARGET_NAME).xsc $(MMS$TARGET_NAME).c
+ $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT)
';
+ if ($self->{XSMULTI}) {
+ for my $ext ($self->_xs_list_basenames) {
+ my $version = $self->parse_version("$ext.pm");
+ my $ccflags = $self->{CCFLAGS};
+ $ccflags =~ s/\$\(DEFINE_VERSION\)/\"VERSION_MACRO=\\"\"$version\\"\"/;
+ $ccflags =~ s/\$\(XS_DEFINE_VERSION\)/\"XS_VERSION_MACRO=\\"\"$version\\"\"/;
+ $self->_xsbuild_replace_macro($ccflags, 'xs', $ext, 'INC');
+ $self->_xsbuild_replace_macro($ccflags, 'xs', $ext, 'DEFINE');
+
+ $frag .= _sprintf562 <<'EOF', $ext, $ccflags;
+
+%1$s$(OBJ_EXT) : %1$s.xs
+ $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs > $(MMS$TARGET_NAME).xsc
+ $(MV) $(MMS$TARGET_NAME).xsc $(MMS$TARGET_NAME).c
+ $(CC)%2$s$(OPTIMIZE) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT)
+EOF
+ }
+ }
+ $frag;
}
+=item _xsbuild_replace_macro (override)
-=item dlsyms (override)
+There is no simple replacement possible since a qualifier and all its
+subqualifiers must be considered together, so we use our own utility
+routine for the replacement.
-Create VMS linker options files specifying universal symbols for this
-extension's shareable image, and listing other shareable images or
-libraries to which it should be linked.
+=cut
+
+sub _xsbuild_replace_macro {
+ my ($self, undef, $xstype, $ext, $varname) = @_;
+ my $value = $self->_xsbuild_value($xstype, $ext, $varname);
+ return unless defined $value;
+ $_[1] = _vms_replace_qualifier($self, $_[1], $value, $varname);
+}
+
+=item _xsbuild_value (override)
+
+Convert the extension spec to Unix format, as that's what will
+match what's in the XSBUILD data structure.
=cut
-sub dlsyms {
- my($self,%attribs) = @_;
+sub _xsbuild_value {
+ my ($self, $xstype, $ext, $varname) = @_;
+ $ext = unixify($ext);
+ return $self->SUPER::_xsbuild_value($xstype, $ext, $varname);
+}
- return '' unless $self->needs_linking();
+sub _vms_replace_qualifier {
+ my ($self, $flags, $newflag, $macro) = @_;
+ my $qual_type;
+ my $type_suffix;
+ my $quote_subquals = 0;
+ my @subquals_new = split /\s+/, $newflag;
+
+ if ($macro eq 'DEFINE') {
+ $qual_type = 'Def';
+ $type_suffix = 'ine';
+ map { $_ =~ s/^-D// } @subquals_new;
+ $quote_subquals = 1;
+ }
+ elsif ($macro eq 'INC') {
+ $qual_type = 'Inc';
+ $type_suffix = 'lude';
+ map { $_ =~ s/^-I//; $_ = $self->fixpath($_) } @subquals_new;
+ }
- my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {};
- my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || [];
- my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || [];
- my(@m);
+ my @subquals = ();
+ while ($flags =~ m:/${qual_type}\S{0,4}=([^/]+):ig) {
+ my $term = $1;
+ $term =~ s/\"//g;
+ $term =~ s:^\((.+)\)$:$1:;
+ push @subquals, split /,/, $term;
+ }
+ for my $new (@subquals_new) {
+ my ($sq_new, $sqval_new) = split /=/, $new;
+ my $replaced_old = 0;
+ for my $old (@subquals) {
+ my ($sq, $sqval) = split /=/, $old;
+ if ($sq_new eq $sq) {
+ $old = $sq_new;
+ $old .= '=' . $sqval_new if defined($sqval_new) and length($sqval_new);
+ $replaced_old = 1;
+ last;
+ }
+ }
+ push @subquals, $new unless $replaced_old;
+ }
- unless ($self->{SKIPHASH}{'dynamic'}) {
- push(@m,'
-dynamic :: $(INST_ARCHAUTODIR)$(BASEEXT).opt
- $(NOECHO) $(NOOP)
-');
+ if (@subquals) {
+ $flags =~ s:/${qual_type}\S{0,4}=[^/]+::ig;
+ # add quotes if requested but not for unexpanded macros
+ map { $_ = qq/"$_"/ if $_ !~ m/^\$\(/ } @subquals if $quote_subquals;
+ $flags .= "/${qual_type}$type_suffix=(" . join(',',@subquals) . ')';
}
- push(@m,'
-static :: $(INST_ARCHAUTODIR)$(BASEEXT).opt
- $(NOECHO) $(NOOP)
-') unless $self->{SKIPHASH}{'static'};
+ return $flags;
+}
- push @m,'
-$(INST_ARCHAUTODIR)$(BASEEXT).opt : $(BASEEXT).opt
- $(CP) $(MMS$SOURCE) $(MMS$TARGET)
-$(BASEEXT).opt : Makefile.PL
- $(PERLRUN) -e "use ExtUtils::Mksymlists;" -
- ',qq[-e "Mksymlists('NAME' => '$self->{NAME}', 'DL_FUNCS' => ],
- neatvalue($funcs),q[, 'DL_VARS' => ],neatvalue($vars),
- q[, 'FUNCLIST' => ],neatvalue($funclist),qq[)"\n];
-
- push @m, ' $(PERL) -e "print ""$(INST_STATIC)/Include=';
- if ($self->{OBJECT} =~ /\bBASEEXT\b/ or
- $self->{OBJECT} =~ /\b$self->{BASEEXT}\b/i) {
- push @m, ($Config{d_vms_case_sensitive_symbols}
- ? uc($self->{BASEEXT}) :'$(BASEEXT)');
- }
- else { # We don't have a "main" object file, so pull 'em all in
- # Upcase module names if linker is being case-sensitive
- my($upcase) = $Config{d_vms_case_sensitive_symbols};
- my(@omods) = split ' ', $self->eliminate_macros($self->{OBJECT});
- for (@omods) {
- s/\.[^.]*$//; # Trim off file type
- s[\$\(\w+_EXT\)][]; # even as a macro
- s/.*[:>\/\]]//; # Trim off dir spec
- $_ = uc if $upcase;
- };
-
- my(@lines);
- my $tmp = shift @omods;
- foreach my $elt (@omods) {
- $tmp .= ",$elt";
- if (length($tmp) > 80) { push @lines, $tmp; $tmp = ''; }
+sub xs_dlsyms_ext {
+ '.opt';
+}
+
+=item dlsyms (override)
+
+Create VMS linker options files specifying universal symbols for this
+extension's shareable image(s), and listing other shareable images or
+libraries to which it should be linked.
+
+=cut
+
+sub dlsyms {
+ my ($self, %attribs) = @_;
+ return '' unless $self->needs_linking;
+ $self->xs_dlsyms_iterator;
+}
+
+sub xs_make_dlsyms {
+ my ($self, $attribs, $target, $dep, $name, $dlbase, $funcs, $funclist, $imports, $vars, $extra) = @_;
+ my @m;
+ my $instloc;
+ if ($self->{XSMULTI}) {
+ my ($v, $d, $f) = File::Spec->splitpath($target);
+ my @d = File::Spec->splitdir($d);
+ shift @d if $d[0] eq 'lib';
+ $instloc = $self->catfile('$(INST_ARCHLIB)', 'auto', @d, $f);
+ push @m,"\ndynamic :: $instloc\n\t\$(NOECHO) \$(NOOP)\n"
+ unless $self->{SKIPHASH}{'dynamic'};
+ push @m,"\nstatic :: $instloc\n\t\$(NOECHO) \$(NOOP)\n"
+ unless $self->{SKIPHASH}{'static'};
+ push @m, "\n", sprintf <<'EOF', $instloc, $target;
+%s : %s
+ $(CP) $(MMS$SOURCE) $(MMS$TARGET)
+EOF
+ }
+ else {
+ push @m,"\ndynamic :: \$(INST_ARCHAUTODIR)$self->{BASEEXT}.opt\n\t\$(NOECHO) \$(NOOP)\n"
+ unless $self->{SKIPHASH}{'dynamic'};
+ push @m,"\nstatic :: \$(INST_ARCHAUTODIR)$self->{BASEEXT}.opt\n\t\$(NOECHO) \$(NOOP)\n"
+ unless $self->{SKIPHASH}{'static'};
+ push @m, "\n", sprintf <<'EOF', $target;
+$(INST_ARCHAUTODIR)$(BASEEXT).opt : %s
+ $(CP) $(MMS$SOURCE) $(MMS$TARGET)
+EOF
+ }
+ push @m,
+ "\n$target : $dep\n\t",
+ q!$(PERLRUN) -MExtUtils::Mksymlists -e "Mksymlists('NAME'=>'!, $name,
+ q!', 'DLBASE' => '!,$dlbase,
+ q!', 'DL_FUNCS' => !,neatvalue($funcs),
+ q!, 'FUNCLIST' => !,neatvalue($funclist),
+ q!, 'IMPORTS' => !,neatvalue($imports),
+ q!, 'DL_VARS' => !, neatvalue($vars);
+ push @m, $extra if defined $extra;
+ push @m, qq!);"\n\t!;
+ # Can't use dlbase as it's been through mod2fname.
+ my $olb_base = basename($target, '.opt');
+ if ($self->{XSMULTI}) {
+ # We've been passed everything but the kitchen sink -- and the location of the
+ # static library we're using to build the dynamic library -- so concoct that
+ # location from what we do have.
+ my $olb_dir = $self->catdir(dirname($instloc), $olb_base);
+ push @m, qq!\$(PERL) -e "print ""${olb_dir}${olb_base}\$(LIB_EXT)/Include=!;
+ push @m, ($Config{d_vms_case_sensitive_symbols} ? uc($olb_base) : $olb_base);
+ push @m, '\n' . $olb_dir . $olb_base . '$(LIB_EXT)/Library\n"";" >>$(MMS$TARGET)',"\n";
+ }
+ else {
+ push @m, qq!\$(PERL) -e "print ""\$(INST_ARCHAUTODIR)${olb_base}\$(LIB_EXT)/Include=!;
+ if ($self->{OBJECT} =~ /\bBASEEXT\b/ or
+ $self->{OBJECT} =~ /\b$self->{BASEEXT}\b/i) {
+ push @m, ($Config{d_vms_case_sensitive_symbols}
+ ? uc($self->{BASEEXT}) :'$(BASEEXT)');
+ }
+ else { # We don't have a "main" object file, so pull 'em all in
+ # Upcase module names if linker is being case-sensitive
+ my($upcase) = $Config{d_vms_case_sensitive_symbols};
+ my(@omods) = split ' ', $self->eliminate_macros($self->{OBJECT});
+ for (@omods) {
+ s/\.[^.]*$//; # Trim off file type
+ s[\$\(\w+_EXT\)][]; # even as a macro
+ s/.*[:>\/\]]//; # Trim off dir spec
+ $_ = uc if $upcase;
+ };
+ my(@lines);
+ my $tmp = shift @omods;
+ foreach my $elt (@omods) {
+ $tmp .= ",$elt";
+ if (length($tmp) > 80) { push @lines, $tmp; $tmp = ''; }
+ }
+ push @lines, $tmp;
+ push @m, '(', join( qq[, -\\n\\t"";" >>\$(MMS\$TARGET)\n\t\$(PERL) -e "print ""], @lines),')';
}
- push @lines, $tmp;
- push @m, '(', join( qq[, -\\n\\t"";" >>\$(MMS\$TARGET)\n\t\$(PERL) -e "print ""], @lines),')';
+ push @m, '\n$(INST_ARCHAUTODIR)' . $olb_base . '$(LIB_EXT)/Library\n"";" >>$(MMS$TARGET)',"\n";
}
- push @m, '\n$(INST_STATIC)/Library\n"";" >>$(MMS$TARGET)',"\n";
-
if (length $self->{LDLOADLIBS}) {
my($line) = '';
foreach my $lib (split ' ', $self->{LDLOADLIBS}) {
}
push @m, "\t\$(PERL) -e \"print qq{$line}\" >>\$(MMS\$TARGET)\n" if $line;
}
+ join '', @m;
+}
- join('',@m);
+=item xs_obj_opt
+
+Override to fixup -o flags.
+
+=cut
+
+sub xs_obj_opt {
+ my ($self, $output_file) = @_;
+ "/OBJECT=$output_file";
}
=item dynamic_lib (override)
=cut
-sub dynamic_lib {
- my($self, %attribs) = @_;
- return '' unless $self->needs_linking(); #might be because of a subdir
-
- return '' unless $self->has_link_code();
+sub xs_dynamic_lib_macros {
+ my ($self, $attribs) = @_;
+ my $otherldflags = $attribs->{OTHERLDFLAGS} || "";
+ my $inst_dynamic_dep = $attribs->{INST_DYNAMIC_DEP} || "";
+ sprintf <<'EOF', $otherldflags, $inst_dynamic_dep;
+# This section creates the dynamically loadable objects from relevant
+# objects and possibly $(MYEXTLIB).
+OTHERLDFLAGS = %s
+INST_DYNAMIC_DEP = %s
+EOF
+}
- my($otherldflags) = $attribs{OTHERLDFLAGS} || "";
- my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || "";
+sub xs_make_dynamic_lib {
+ my ($self, $attribs, $from, $to, $todir, $ldfrom, $exportlist) = @_;
my $shr = $Config{'dbgprefix'} . 'PerlShr';
- my(@m);
- push @m,"
-
-OTHERLDFLAGS = $otherldflags
-INST_DYNAMIC_DEP = $inst_dynamic_dep
-
-";
- push @m, '
-$(INST_DYNAMIC) : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt $(INST_ARCHAUTODIR)$(DFSEP).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP)
- If F$TrnLNm("',$shr,'").eqs."" Then Define/NoLog/User ',"$shr Sys\$Share:$shr.$Config{'dlext'}",'
- Link $(LDFLAGS) /Shareable=$(MMS$TARGET)$(OTHERLDFLAGS) $(BASEEXT).opt/Option,$(PERL_INC)perlshr_attr.opt/Option
-';
-
- join('',@m);
+ $exportlist =~ s/.def$/.opt/; # it's a linker options file
+ # 1 2 3 4 5
+ _sprintf562 <<'EOF', $to, $todir, $exportlist, $shr, "$shr Sys\$Share:$shr.$Config{'dlext'}";
+%1$s : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt %2$s$(DFSEP).exists %3$s $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP)
+ If F$TrnLNm("%4$s").eqs."" Then Define/NoLog/User %5$s
+ Link $(LDFLAGS) /Shareable=$(MMS$TARGET)$(OTHERLDFLAGS) %3$s/Option,$(PERL_INC)perlshr_attr.opt/Option
+EOF
}
-
-=item static_lib (override)
+=item xs_make_static_lib (override)
Use VMS commands to manipulate object library.
=cut
-sub static_lib {
- my($self) = @_;
- return '' unless $self->needs_linking();
-
- return '
-$(INST_STATIC) :
- $(NOECHO) $(NOOP)
-' unless ($self->{OBJECT} or @{$self->{C} || []} or $self->{MYEXTLIB});
+sub xs_make_static_lib {
+ my ($self, $object, $to, $todir) = @_;
+
+ my @objects;
+ if ($self->{XSMULTI}) {
+ # The extension name should be the main object file name minus file type.
+ my $lib = $object;
+ $lib =~ s/\$\(OBJ_EXT\)\z//;
+ my $override = $self->_xsbuild_value('xs', $lib, 'OBJECT');
+ $object = $override if defined $override;
+ @objects = map { $self->fixpath($_,0) } split /(?<!\^)\s+/, $object;
+ }
+ else {
+ push @objects, $object;
+ }
- my(@m);
- push @m,'
-# Rely on suffix rule for update action
-$(OBJECT) : $(INST_ARCHAUTODIR)$(DFSEP).exists
+ my @m;
+ for my $obj (@objects) {
+ push(@m, sprintf "\n%s : %s\$(DFSEP).exists", $obj, $todir);
+ }
+ push(@m, sprintf "\n\n%s : %s \$(MYEXTLIB)\n", $to, (join ' ', @objects));
-$(INST_STATIC) : $(OBJECT) $(MYEXTLIB)
-';
# If this extension has its own library (eg SDBM_File)
# then copy that to $(INST_STATIC) and add $(OBJECT) into it.
push(@m, "\t",'$(CP) $(MYEXTLIB) $(MMS$TARGET)',"\n") if $self->{MYEXTLIB};
# 'cause it's a library and you can't stick them in other libraries.
# In that case, we use $OBJECT instead and hope for the best
if ($self->{MYEXTLIB}) {
- push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) $(OBJECT)',"\n");
- } else {
+ for my $obj (@objects) {
+ push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) ' . $obj,"\n");
+ }
+ }
+ else {
push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) $(MMS$SOURCE_LIST)',"\n");
}
]);
}
- push(@m, join(" ", map($self->fixpath($_,0),values %{$self->{XS}}))." : \$(XSUBPPDEPS)\n")
+ push(@m, join(" ", map($self->fixpath($_,0),sort values %{$self->{XS}}))." : \$(XSUBPPDEPS)\n")
if %{$self->{XS}};
join('',@m);
# (e.g. Intuit::DWIM will precede Intuit, so unresolved
# references from [.intuit.dwim]dwim.obj can be found
# in [.intuit]intuit.olb).
- for (sort { length($a) <=> length($b) } keys %olbs) {
+ for (sort { length($a) <=> length($b) || $a cmp $b } keys %olbs) {
next unless $olbs{$_} =~ /\Q$self->{LIB_EXT}\E$/;
my($dir) = $self->fixpath($_,1);
my($extralibs) = $dir . "extralibs.ld";
=item maketext_filter (override)
-Insure that colons marking targets are preceded by space, in order
+Ensure that colons marking targets are preceded by space, in order
to distinguish the target delimiter from a colon appearing as
part of a filespec.
=item B<echo>
perl trips up on "<foo>" thinking it's an input redirect. So we use the
-native Write command instead. Besides, its faster.
+native Write command instead. Besides, it's faster.
=cut
$complex = 1;
}
}
- else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
+ else {
+ $macro = $self->{$macro};
+ # Don't unixify if there is unescaped whitespace
+ $macro = unixify($macro) unless ($macro =~ /(?<!\^)\s/);
+ $macro =~ s#/\Z(?!\n)##;
+ }
$npath = "$head$macro$tail";
}
}
}
+=item make_type (override)
+
+Returns a suitable string describing the type of makefile being written.
+
+=cut
+
+sub make_type { "$Config{make}-style"; }
+
+
=back
package ExtUtils::MM_VOS;
use strict;
-our $VERSION = '7.10_01';
+our $VERSION = '7.18';
+$VERSION = eval $VERSION;
require ExtUtils::MM_Unix;
our @ISA = qw(ExtUtils::MM_Unix);
use ExtUtils::MakeMaker::Config;
use File::Basename;
use File::Spec;
-use ExtUtils::MakeMaker qw( neatvalue );
+use ExtUtils::MakeMaker qw(neatvalue _sprintf562);
require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
-our $VERSION = '7.10_01';
+our $VERSION = '7.18';
+$VERSION = eval $VERSION;
$ENV{EMXSHELL} = 'sh'; # to run `commands`
-my ( $BORLAND, $GCC, $DLLTOOL ) = _identify_compiler_environment( \%Config );
+my ( $BORLAND, $GCC, $MSVC ) = _identify_compiler_environment( \%Config );
sub _identify_compiler_environment {
my ( $config ) = @_;
- my $BORLAND = $config->{cc} =~ /^bcc/i ? 1 : 0;
+ my $BORLAND = $config->{cc} =~ /\bbcc/i ? 1 : 0;
my $GCC = $config->{cc} =~ /\bgcc\b/i ? 1 : 0;
- my $DLLTOOL = $config->{dlltool} || 'dlltool';
+ my $MSVC = $config->{cc} =~ /\b(?:cl|icl)/i ? 1 : 0; # MSVC can come as clarm.exe, icl=Intel C
- return ( $BORLAND, $GCC, $DLLTOOL );
+ return ( $BORLAND, $GCC, $MSVC );
}
sub dlsyms {
my($self,%attribs) = @_;
+ return '' if $self->{SKIPHASH}{'dynamic'};
+ $self->xs_dlsyms_iterator(\%attribs);
+}
- my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {};
- my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || [];
- my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || [];
- my($imports) = $attribs{IMPORTS} || $self->{IMPORTS} || {};
- my(@m);
-
- if (not $self->{SKIPHASH}{'dynamic'}) {
- push(@m,"
-$self->{BASEEXT}.def: Makefile.PL
-",
- q! $(PERLRUN) -MExtUtils::Mksymlists \\
- -e "Mksymlists('NAME'=>\"!, $self->{NAME},
- q!\", 'DLBASE' => '!,$self->{DLBASE},
- # The above two lines quoted differently to work around
- # a bug in the 4DOS/4NT command line interpreter. The visible
- # result of the bug was files named q('extension_name',) *with the
- # single quotes and the comma* in the extension build directories.
- q!', 'DL_FUNCS' => !,neatvalue($funcs),
- q!, 'FUNCLIST' => !,neatvalue($funclist),
- q!, 'IMPORTS' => !,neatvalue($imports),
- q!, 'DL_VARS' => !, neatvalue($vars), q!);"
-!);
- }
- join('',@m);
+=item xs_dlsyms_ext
+
+On Win32, is C<.def>.
+
+=cut
+
+sub xs_dlsyms_ext {
+ '.def';
}
=item replace_manpage_separator
return $make_frag;
}
+=item static_lib_pure_cmd
-=item static_lib
-
-Changes how to run the linker.
-
-The rest is duplicate code from MM_Unix. Should move the linker code
-to its own method.
+Defines how to run the archive utility
=cut
-sub static_lib {
- my($self) = @_;
- return '' unless $self->has_link_code;
-
- my(@m);
- push(@m, <<'END');
-$(INST_STATIC): $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)$(DFSEP).exists
- $(RM_RF) $@
-END
-
- # If this extension has its own library (eg SDBM_File)
- # then copy that to $(INST_STATIC) and add $(OBJECT) into it.
- push @m, <<'MAKE_FRAG' if $self->{MYEXTLIB};
- $(CP) $(MYEXTLIB) $@
-MAKE_FRAG
-
- push @m,
-q{ $(AR) }.($BORLAND ? '$@ $(OBJECT:^"+")'
- : ($GCC ? '-ru $@ $(OBJECT)'
- : '-out:$@ $(OBJECT)')).q{
- $(CHMOD) $(PERM_RWX) $@
- $(NOECHO) $(ECHO) "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)\extralibs.ld
-};
-
- # Old mechanism - still available:
- push @m, <<'MAKE_FRAG' if $self->{PERL_SRC} && $self->{EXTRALIBS};
- $(NOECHO) $(ECHO) "$(EXTRALIBS)" >> $(PERL_SRC)\ext.libs
-MAKE_FRAG
-
- join('', @m);
+sub static_lib_pure_cmd {
+ my ($self, $from) = @_;
+ $from =~ s/(\$\(\w+)(\))/$1:^"+"$2/g if $BORLAND;
+ sprintf qq{\t\$(AR) %s\n}, ($BORLAND ? '$@ ' . $from
+ : ($GCC ? '-ru $@ ' . $from
+ : '-out:$@ ' . $from));
}
-
=item dynamic_lib
-Complicated stuff for Win32 that I don't understand. :(
+Methods are overridden here: not dynamic_lib itself, but the utility
+ones that do the OS-specific work.
=cut
-sub dynamic_lib {
- my($self, %attribs) = @_;
- return '' unless $self->needs_linking(); #might be because of a subdir
-
- return '' unless $self->has_link_code;
-
- my($otherldflags) = $attribs{OTHERLDFLAGS} || ($BORLAND ? 'c0d32.obj': '');
- my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || "";
- my($ldfrom) = '$(LDFROM)';
- my(@m);
-
- push(@m,'
-# This section creates the dynamically loadable $(INST_DYNAMIC)
-# from $(OBJECT) and possibly $(MYEXTLIB).
-OTHERLDFLAGS = '.$otherldflags.'
-INST_DYNAMIC_DEP = '.$inst_dynamic_dep.'
-
-$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).exists $(EXPORT_LIST) $(PERL_ARCHIVEDEP) $(INST_DYNAMIC_DEP)
-');
+sub xs_make_dynamic_lib {
+ my ($self, $attribs, $from, $to, $todir, $ldfrom, $exportlist) = @_;
+ my @m = sprintf '%s : %s $(MYEXTLIB) %s$(DFSEP).exists %s $(PERL_ARCHIVEDEP) $(INST_DYNAMIC_DEP)'."\n", $to, $from, $todir, $exportlist;
if ($GCC) {
- push(@m,
- q{ }.$DLLTOOL.q{ --def $(EXPORT_LIST) --output-exp dll.exp
- $(LD) -o $@ -Wl,--base-file -Wl,dll.base $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) "$(PERL_ARCHIVE)" $(LDLOADLIBS) dll.exp
- }.$DLLTOOL.q{ --def $(EXPORT_LIST) --base-file dll.base --output-exp dll.exp
- $(LD) -o $@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) "$(PERL_ARCHIVE)" $(LDLOADLIBS) dll.exp });
+ # per https://rt.cpan.org/Ticket/Display.html?id=78395 no longer
+ # uses dlltool - relies on post 2002 MinGW
+ # 1 2
+ push @m, _sprintf562 <<'EOF', $exportlist, $ldfrom;
+ $(LD) %1$s -o $@ $(LDDLFLAGS) %2$s $(OTHERLDFLAGS) $(MYEXTLIB) "$(PERL_ARCHIVE)" $(LDLOADLIBS) -Wl,--enable-auto-image-base
+EOF
} elsif ($BORLAND) {
- push(@m,
- q{ $(LD) $(LDDLFLAGS) $(OTHERLDFLAGS) }.$ldfrom.q{,$@,,}
- .($self->is_make_type('dmake')
- ? q{"$(PERL_ARCHIVE:s,/,\,)" $(LDLOADLIBS:s,/,\,) }
- .q{$(MYEXTLIB:s,/,\,),$(EXPORT_LIST:s,/,\,)}
- : q{"$(subst /,\,$(PERL_ARCHIVE))" $(subst /,\,$(LDLOADLIBS)) }
- .q{$(subst /,\,$(MYEXTLIB)),$(subst /,\,$(EXPORT_LIST))})
- .q{,$(RESFILES)});
+ my $ldargs = $self->is_make_type('dmake')
+ ? q{"$(PERL_ARCHIVE:s,/,\,)" $(LDLOADLIBS:s,/,\,) $(MYEXTLIB:s,/,\,),}
+ : q{"$(subst /,\,$(PERL_ARCHIVE))" $(subst /,\,$(LDLOADLIBS)) $(subst /,\,$(MYEXTLIB)),};
+ my $subbed;
+ if ($exportlist eq '$(EXPORT_LIST)') {
+ $subbed = $self->is_make_type('dmake')
+ ? q{$(EXPORT_LIST:s,/,\,)}
+ : q{$(subst /,\,$(EXPORT_LIST))};
+ } else {
+ # in XSMULTI, exportlist is per-XS, so have to sub in perl not make
+ ($subbed = $exportlist) =~ s#/#\\#g;
+ }
+ push @m, sprintf <<'EOF', $ldfrom, $ldargs . $subbed;
+ $(LD) $(LDDLFLAGS) $(OTHERLDFLAGS) %s,$@,,%s,$(RESFILES)
+EOF
} else { # VC
- push(@m,
- q{ $(LD) -out:$@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) }
- .q{$(MYEXTLIB) "$(PERL_ARCHIVE)" $(LDLOADLIBS) -def:$(EXPORT_LIST)});
-
+ push @m, sprintf <<'EOF', $ldfrom, $exportlist;
+ $(LD) -out:$@ $(LDDLFLAGS) %s $(OTHERLDFLAGS) $(MYEXTLIB) "$(PERL_ARCHIVE)" $(LDLOADLIBS) -def:%s
+EOF
# Embed the manifest file if it exists
- push(@m, q{
- if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;2
+ push(@m, q{ if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;2
if exist $@.manifest del $@.manifest});
}
- push @m, '
- $(CHMOD) $(PERM_RWX) $@
-';
+ push @m, "\n\t\$(CHMOD) \$(PERM_RWX) \$\@\n";
+
+ join '', @m;
+}
- join('',@m);
+sub xs_dynamic_lib_macros {
+ my ($self, $attribs) = @_;
+ my $otherldflags = $attribs->{OTHERLDFLAGS} || ($BORLAND ? 'c0d32.obj': '');
+ my $inst_dynamic_dep = $attribs->{INST_DYNAMIC_DEP} || "";
+ sprintf <<'EOF', $otherldflags, $inst_dynamic_dep;
+# This section creates the dynamically loadable objects from relevant
+# objects and possibly $(MYEXTLIB).
+OTHERLDFLAGS = %s
+INST_DYNAMIC_DEP = %s
+EOF
}
=item extra_clean_files
return $self->SUPER::quote_dep($arg);
}
-=item xs_o
-This target is stubbed out. Not sure why.
+=item xs_obj_opt
+
+Override to fixup -o flags for MSVC.
=cut
-sub xs_o {
- return ''
+sub xs_obj_opt {
+ my ($self, $output_file) = @_;
+ ($MSVC ? "/Fo" : "-o ") . $output_file;
}
sub pasthru {
my($self) = shift;
- return "PASTHRU = " . ($self->is_make_type('nmake') ? "-nologo" : "");
+ my $old = $self->SUPER::pasthru;
+ return $old unless $self->is_make_type('nmake');
+ $old =~ s/(PASTHRU\s*=\s*)/$1 -nologo /;
+ $old;
}
}
+=item make_type
+
+Returns a suitable string describing the type of makefile being written.
+
+=cut
+
+sub make_type {
+ my ($self) = @_;
+ my $make = $self->make;
+ $make = +( File::Spec->splitpath( $make ) )[-1];
+ $make =~ s!\.exe$!!i;
+ if ( $make =~ m![^A-Z0-9]!i ) {
+ ($make) = grep { m!make!i } split m![^A-Z0-9]!i, $make;
+ }
+ return "$make-style";
+}
+
1;
__END__
use strict;
-our $VERSION = '7.10_01';
+our $VERSION = '7.18';
+$VERSION = eval $VERSION;
require ExtUtils::MM_Win32;
our @ISA = qw(ExtUtils::MM_Win32);
=head2 Overridden methods
Most of these make up for limitations in the Win9x/nmake command shell.
-Mostly its lack of &&.
=over 4
-=item xs_c
-
-The && problem.
-
-=cut
-
-sub xs_c {
- my($self) = shift;
- return '' unless $self->needs_linking();
- '
-.xs.c:
- $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.c
- '
-}
-
-
-=item xs_cpp
-
-The && problem
-
-=cut
-
-sub xs_cpp {
- my($self) = shift;
- return '' unless $self->needs_linking();
- '
-.xs.cpp:
- $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.cpp
- ';
-}
-
-=item xs_o
-
-The && problem.
-
-=cut
-
-sub xs_o {
- my($self) = shift;
- return '' unless $self->needs_linking();
- '
-.xs$(OBJ_EXT):
- $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.c
- $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c
- ';
-}
-
-
=item max_exec_len
Win98 chokes on things like Encode if we set the max length to nmake's max
use strict;
require ExtUtils::MM;
-our $VERSION = '7.10_01';
+our $VERSION = '7.18';
+$VERSION = eval $VERSION;
our @ISA = qw(ExtUtils::MM);
{
our %macro_fsentity; # whether a macro is a filesystem name
our %macro_dep; # whether a macro is a dependency
-our $VERSION = '7.10_01';
+our $VERSION = '7.18';
$VERSION = eval $VERSION; ## no critic [BuiltinFunctions::ProhibitStringyEval]
# Emulate something resembling CVS $Revision$
our @ISA = qw(Exporter);
our @EXPORT = qw(&WriteMakefile $Verbose &prompt);
our @EXPORT_OK = qw($VERSION &neatvalue &mkbootstrap &mksymlists
- &WriteEmptyMakefile);
+ &WriteEmptyMakefile &open_for_writing &write_file_via_tmp
+ &_sprintf562);
# These will go away once the last of the Win32 & VMS specific code is
# purged.
# This will go when Embed is its own CPAN module.
+# 5.6.2 can't do sprintf "%1$s" - this can only do %s
+sub _sprintf562 {
+ my ($format, @args) = @_;
+ for (my $i = 1; $i <= @args; $i++) {
+ $format =~ s#%$i\$s#$args[$i-1]#g;
+ }
+ $format;
+}
+
sub WriteMakefile {
croak "WriteMakefile: Need even number of args" if @_ % 2;
SKIP => 'ARRAY',
TYPEMAPS => 'ARRAY',
XS => 'HASH',
+ XSBUILD => 'HASH',
VERSION => ['version',''],
_KEEP_AFTER_FLUSH => '',
sub _verify_att {
my($att) = @_;
- while( my($key, $val) = each %$att ) {
+ foreach my $key (sort keys %$att) {
+ my $val = $att->{$key};
my $sig = $Att_Sigs{$key};
unless( defined $sig ) {
warn "WARNING: $key is not a known parameter.\n";
PERM_DIR PERM_RW PERM_RWX MAGICXS
PL_FILES PM PM_FILTER PMLIBDIRS PMLIBPARENTDIRS POLLUTE
PREREQ_FATAL PREREQ_PM PREREQ_PRINT PRINT_PREREQ
- SIGN SKIP TEST_REQUIRES TYPEMAPS UNINST VERSION VERSION_FROM XS XSOPT XSPROTOARG
- XS_VERSION clean depend dist dynamic_lib linkext macro realclean
- tool_autosplit
+ SIGN SKIP TEST_REQUIRES TYPEMAPS UNINST VERSION VERSION_FROM XS
+ XSBUILD XSMULTI XSOPT XSPROTOARG XS_VERSION
+ clean depend dist dynamic_lib linkext macro realclean tool_autosplit
MAN1EXT MAN3EXT
);
}
+sub _has_cpan_meta_requirements {
+ return eval {
+ require CPAN::Meta::Requirements;
+ CPAN::Meta::Requirements->VERSION(2.130);
+ require B; # CMR requires this, for core we have to too.
+ };
+}
+
sub new {
my($class,$self) = @_;
my($key);
bless $self, "MM";
# Cleanup all the module requirement bits
+ my %key2cmr;
for my $key (qw(PREREQ_PM BUILD_REQUIRES CONFIGURE_REQUIRES TEST_REQUIRES)) {
$self->{$key} ||= {};
- $self->clean_versions( $key );
+ if (_has_cpan_meta_requirements) {
+ my $cmr = CPAN::Meta::Requirements->from_string_hash(
+ $self->{$key},
+ {
+ bad_version_hook => sub {
+ #no warnings 'numeric'; # module doesn't use warnings
+ my $fallback;
+ if ( $_[0] =~ m!^[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?$! ) {
+ $fallback = sprintf "%f", $_[0];
+ } else {
+ ($fallback) = $_[0] ? ($_[0] =~ /^([0-9.]+)/) : 0;
+ $fallback += 0;
+ carp "Unparsable version '$_[0]' for prerequisite $_[1] treated as $fallback";
+ }
+ version->new($fallback);
+ },
+ },
+ );
+ $self->{$key} = $cmr->as_string_hash;
+ $key2cmr{$key} = $cmr;
+ } else {
+ for my $module (sort keys %{ $self->{$key} }) {
+ my $version = $self->{$key}->{$module};
+ my $fallback = 0;
+ if (!defined($version) or !length($version)) {
+ carp "Undefined requirement for $module treated as '0' (CPAN::Meta::Requirements not available)";
+ }
+ elsif ($version =~ /^\d+(?:\.\d+(?:_\d+)*)?$/) {
+ next;
+ }
+ else {
+ if ( $version =~ m!^[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?$! ) {
+ $fallback = sprintf "%f", $version;
+ } else {
+ ($fallback) = $version ? ($version =~ /^([0-9.]+)/) : 0;
+ $fallback += 0;
+ carp "Unparsable version '$version' for prerequisite $module treated as $fallback (CPAN::Meta::Requirements not available)";
+ }
+ }
+ $self->{$key}->{$module} = $fallback;
+ }
+ }
}
-
if ("@ARGV" =~ /\bPREREQ_PRINT\b/) {
$self->_PREREQ_PRINT;
}
my(%initial_att) = %$self; # record initial attributes
my(%unsatisfied) = ();
- my $prereqs = $self->_all_prereqs;
- foreach my $prereq (sort keys %$prereqs) {
- my $required_version = $prereqs->{$prereq};
+ my %prereq2version;
+ my $cmr;
+ if (_has_cpan_meta_requirements) {
+ $cmr = CPAN::Meta::Requirements->new;
+ for my $key (qw(PREREQ_PM BUILD_REQUIRES CONFIGURE_REQUIRES TEST_REQUIRES)) {
+ $cmr->add_requirements($key2cmr{$key}) if $key2cmr{$key};
+ }
+ foreach my $prereq ($cmr->required_modules) {
+ $prereq2version{$prereq} = $cmr->requirements_for_module($prereq);
+ }
+ } else {
+ for my $key (qw(PREREQ_PM BUILD_REQUIRES CONFIGURE_REQUIRES TEST_REQUIRES)) {
+ next unless my $module2version = $self->{$key};
+ $prereq2version{$_} = $module2version->{$_} for keys %$module2version;
+ }
+ }
+ foreach my $prereq (sort keys %prereq2version) {
+ my $required_version = $prereq2version{$prereq};
my $pr_version = 0;
my $installed_file;
$installed_file = MM->_installed_file_for_module($prereq);
$pr_version = MM->parse_version($installed_file) if $installed_file;
$pr_version = 0 if $pr_version eq 'undef';
+ if ( !eval { version->new( $pr_version ); 1 } ) {
+ #no warnings 'numeric'; # module doesn't use warnings
+ my $fallback;
+ if ( $pr_version =~ m!^[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?$! ) {
+ $fallback = sprintf '%f', $pr_version;
+ } else {
+ ($fallback) = $pr_version ? ($pr_version =~ /^([0-9.]+)/) : 0;
+ $fallback += 0;
+ carp "Unparsable version '$pr_version' for installed prerequisite $prereq treated as $fallback";
+ }
+ $pr_version = $fallback;
+ }
}
# convert X.Y_Z alpha version #s to X.YZ for easier comparisons
$unsatisfied{$prereq} = 'not installed';
}
- elsif ($pr_version < $required_version ){
+ elsif (
+ $cmr
+ ? !$cmr->accepts_module($prereq, $pr_version)
+ : $required_version > $pr_version
+ ) {
warn sprintf "Warning: prerequisite %s %s not found. We have %s.\n",
$prereq, $required_version, ($pr_version || 'unknown version')
unless $self->{PREREQ_FATAL}
or $UNDER_CORE;
- $unsatisfied{$prereq} = $required_version ? $required_version : 'unknown version' ;
+ $unsatisfied{$prereq} = $required_version || 'unknown version' ;
}
}
$self->init_others();
$self->init_platform();
$self->init_PERM();
- my($argv) = neatvalue(\@ARGV);
+ my @args = @ARGV;
+ @args = map { Encode::decode(locale => $_) } @args if $CAN_DECODE;
+ my($argv) = neatvalue(\@args);
$argv =~ s/^\[/(/;
$argv =~ s/\]$/)/;
croak "WriteEmptyMakefile: Need an even number of args" if @_ % 2;
my %att = @_;
+ $att{DIR} = [] unless $att{DIR}; # don't recurse by default
my $self = MM->new(\%att);
my $new = $self->{MAKEFILE};
print $mfh <<'EOP';
all :
+manifypods :
+
+subdirs :
+
+dynamic :
+
+static :
+
clean :
install :
test :
+test_dynamic :
+
+test_static :
+
EOP
close $mfh or die "close $new for write: $!";
}
my($hint_file) = shift;
local($@, $!);
- warn "Processing hints file $hint_file\n";
+ print "Processing hints file $hint_file\n" if $Verbose;
# Just in case the ./ isn't on the hint file, which File::Spec can
# often strip off, we bung the curdir into @INC
sub mv_all_methods {
my($from,$to) = @_;
-
- # Here you see the *current* list of methods that are overridable
- # from Makefile.PL via MY:: subroutines. As of VERSION 5.07 I'm
- # still trying to reduce the list to some reasonable minimum --
- # because I want to make it easier for the user. A.K.
-
local $SIG{__WARN__} = sub {
# can't use 'no warnings redefined', 5.6 only
warn @_ unless $_[0] =~ /^Subroutine .* redefined/
};
foreach my $method (@Overridable) {
-
- # We cannot say "next" here. Nick might call MY->makeaperl
- # which isn't defined right now
-
- # Above statement was written at 4.23 time when Tk-b8 was
- # around. As Tk-b9 only builds with 5.002something and MM 5 is
- # standard, we try to enable the next line again. It was
- # commented out until MM 5.23
-
next unless defined &{"${from}::$method"};
+ no strict 'refs'; ## no critic
+ *{"${to}::$method"} = \&{"${from}::$method"};
+
+ # If we delete a method, then it will be undefined and cannot
+ # be called. But as long as we have Makefile.PLs that rely on
+ # %MY:: being intact, we have to fill the hole with an
+ # inheriting method:
{
- no strict 'refs'; ## no critic
- *{"${to}::$method"} = \&{"${from}::$method"};
-
- # If we delete a method, then it will be undefined and cannot
- # be called. But as long as we have Makefile.PLs that rely on
- # %MY:: being intact, we have to fill the hole with an
- # inheriting method:
-
- {
- package MY;
- my $super = "SUPER::".$method;
- *{$method} = sub {
- shift->$super(@_);
- };
- }
+ package MY;
+ my $super = "SUPER::".$method;
+ *{$method} = sub {
+ shift->$super(@_);
+ };
}
}
-
- # We have to clean out %INC also, because the current directory is
- # changed frequently and Graham Barr prefers to get his version
- # out of a History.pl file which is "required" so wouldn't get
- # loaded again in another extension requiring a History.pl
-
- # With perl5.002_01 the deletion of entries in %INC caused Tk-b11
- # to core dump in the middle of a require statement. The required
- # file was Tk/MMutil.pm. The consequence is, we have to be
- # extremely careful when we try to give perl a reason to reload a
- # library with same name. The workaround prefers to drop nothing
- # from %INC and teach the writers not to use such libraries.
-
-# my $inc;
-# foreach $inc (keys %INC) {
-# #warn "***$inc*** deleted";
-# delete $INC{$inc};
-# }
}
sub skipcheck {
my($self) = shift;
my($section) = @_;
+ return 'skipped' if $section eq 'metafile' && $UNDER_CORE;
if ($section eq 'dynamic') {
print "Warning (non-fatal): Target 'dynamic' depends on targets ",
"in skipped section 'dynamic_bs'\n"
return '';
}
+# returns filehandle, dies on fail. :raw so no :crlf
+sub open_for_writing {
+ my ($file) = @_;
+ open my $fh ,">", $file or die "Unable to open $file: $!";
+ my @layers = ':raw';
+ push @layers, join ' ', ':encoding(locale)' if $CAN_DECODE;
+ binmode $fh, join ' ', @layers;
+ $fh;
+}
+
sub flush {
my $self = shift;
- # This needs a bit more work for more wacky OSen
- my $type = 'Unix-style';
- if ( $self->os_flavor_is('Win32') ) {
- my $make = $self->make;
- $make = +( File::Spec->splitpath( $make ) )[-1];
- $make =~ s!\.exe$!!i;
- $type = $make . '-style';
- }
- elsif ( $Is_VMS ) {
- $type = $Config{make} . '-style';
- }
-
my $finalname = $self->{MAKEFILE};
- print "Generating a $type $finalname\n";
- print "Writing $finalname for $self->{NAME}\n";
+ printf "Generating a %s %s\n", $self->make_type, $finalname if $Verbose || !$self->{PARENT};
+ print "Writing $finalname for $self->{NAME}\n" if $Verbose || !$self->{PARENT};
unlink($finalname, "MakeMaker.tmp", $Is_VMS ? 'Descrip.MMS' : ());
- open(my $fh,">", "MakeMaker.tmp")
- or die "Unable to open MakeMaker.tmp: $!";
- binmode $fh, ':encoding(locale)' if $CAN_DECODE;
- for my $chunk (@{$self->{RESULT}}) {
+ write_file_via_tmp($finalname, $self->{RESULT});
+
+ # Write MYMETA.yml to communicate metadata up to the CPAN clients
+ print "Writing MYMETA.yml and MYMETA.json\n"
+ if !$self->{NO_MYMETA} and $self->write_mymeta( $self->mymeta );
+
+ # save memory
+ if ($self->{PARENT} && !$self->{_KEEP_AFTER_FLUSH}) {
+ my %keep = map { ($_ => 1) } qw(NEEDS_LINKING HAS_LINK_CODE);
+ delete $self->{$_} for grep !$keep{$_}, keys %$self;
+ }
+
+ system("$Config::Config{eunicefix} $finalname")
+ if $Config::Config{eunicefix} ne ":";
+
+ return;
+}
+
+sub write_file_via_tmp {
+ my ($finalname, $contents) = @_;
+ my $fh = open_for_writing("MakeMaker.tmp");
+ die "write_file_via_tmp: 2nd arg must be ref" unless ref $contents;
+ for my $chunk (@$contents) {
my $to_write = $chunk;
utf8::encode $to_write if !$CAN_DECODE && $] > 5.008;
print $fh "$to_write\n" or die "Can't write to MakeMaker.tmp: $!";
}
-
- close $fh
- or die "Can't write to MakeMaker.tmp: $!";
+ close $fh or die "Can't write to MakeMaker.tmp: $!";
_rename("MakeMaker.tmp", $finalname) or
warn "rename MakeMaker.tmp => $finalname: $!";
- chmod 0644, $finalname unless $Is_VMS;
-
- unless ($self->{NO_MYMETA}) {
- # Write MYMETA.yml to communicate metadata up to the CPAN clients
- if ( $self->write_mymeta( $self->mymeta ) ) {
- print "Writing MYMETA.yml and MYMETA.json\n";
- }
-
- }
- my %keep = map { ($_ => 1) } qw(NEEDS_LINKING HAS_LINK_CODE);
- if ($self->{PARENT} && !$self->{_KEEP_AFTER_FLUSH}) {
- foreach (keys %$self) { # safe memory
- delete $self->{$_} unless $keep{$_};
- }
- }
-
- system("$Config::Config{eunicefix} $finalname") unless $Config::Config{eunicefix} eq ":";
+ chmod 0644, $finalname if !$Is_VMS;
+ return;
}
# This is a rename for OS's where the target must be unlinked first.
sub _rename {
my($src, $dest) = @_;
- chmod 0666, $dest;
- unlink $dest;
+ _unlink($dest);
return rename $src, $dest;
}
return $tvalue;
}
-
-# Look for weird version numbers, warn about them and set them to 0
-# before CPAN::Meta chokes.
-sub clean_versions {
- my($self, $key) = @_;
- my $reqs = $self->{$key};
- for my $module (keys %$reqs) {
- my $v = $reqs->{$module};
- my $printable = _find_magic_vstring($v);
- $v = $printable if length $printable;
- my $version = eval {
- local $SIG{__WARN__} = sub {
- # simulate "use warnings FATAL => 'all'" for vintage perls
- die @_;
- };
- version->new($v)->stringify;
- };
- if( $@ || $reqs->{$module} eq '' ) {
- if ( $] < 5.008 && $v !~ /^v?[\d_\.]+$/ ) {
- $v = sprintf "v%vd", $v unless $v eq '';
- }
- carp "Unparsable version '$v' for prerequisite $module";
- $reqs->{$module} = 0;
- }
- else {
- $reqs->{$module} = $version;
- }
- }
-}
-
sub selfdocument {
my($self) = @_;
my(@m);
push @m, "# $key => $v";
}
}
+ # added here as selfdocument is not overridable
+ push @m, <<'EOF';
+
+# here so even if top_targets is overridden, these will still be defined
+# gmake will silently still work if any are .PHONY-ed but nmake won't
+EOF
+ push @m, join "\n", map "$_ ::\n\t\$(NOECHO) \$(NOOP)\n",
+ # config is so manifypods won't puke if no subdirs
+ grep !$self->{SKIPHASH}{$_},
+ qw(static dynamic config);
join "\n", @m;
}
=item PERL
-Perl binary for tasks that can be done by miniperl.
+Perl binary for tasks that can be done by miniperl. If it contains
+spaces or other shell metacharacters, it needs to be quoted in a way
+that protects them, since this value is intended to be inserted in a
+shell command line in the Makefile. E.g.:
+
+ # Perl executable lives in "C:/Program Files/Perl/bin"
+ # Normally you don't need to set this yourself!
+ $ perl Makefile.PL PERL='"C:/Program Files/Perl/bin/perl.exe" -w'
=item PERL_CORE
MakeMaker can run programs to generate files for you at build time.
By default any file named *.PL (except Makefile.PL and Build.PL) in
the top level directory will be assumed to be a Perl program and run
-passing its own basename in as an argument. For example...
+passing its own basename in as an argument. This basename is actually a build
+target, and there is an intention, but not a requirement, that the *.PL file
+make the file passed to to as an argument. For example...
perl foo.PL foo
PL_FILES => {'bin/foobar.PL' => 'bin/foobar'}
+ PL_FILES => {'foo.PL' => 'foo.c'}
+
Would run bin/foobar.PL like this:
perl bin/foobar.PL bin/foobar
accessed... unless the PL file is making a module (or anything else in
PM) in which case it is run B<before> pm_to_blib and does not include
INST_LIB and INST_ARCH in its C<@INC>. This apparently odd behavior
-is there for backwards compatibility (and it's somewhat DWIM).
-
+is there for backwards compatibility (and it's somewhat DWIM). The argument
+passed to the .PL is set up as a target to build in the Makefile. In other
+sections such as C<postamble> you can specify a dependency on the
+filename/argument that the .PL is supposed (or will have, now that that is
+is a dependency) to generate. Note the file to be generated will still be
+generated and the .PL will still run even without an explicit dependency created
+by you, since the C<all> target still depends on running all eligible to run.PL
+files.
=item PM
A filter program, in the traditional Unix sense (input from stdin, output
to stdout) that is passed on each .pm file during the build (in the
pm_to_blib() phase). It is empty by default, meaning no filtering is done.
+You could use:
-Great care is necessary when defining the command if quoting needs to be
-done. For instance, you would need to say:
-
- {'PM_FILTER' => 'grep -v \\"^\\#\\"'}
+ PM_FILTER => 'perl -ne "print unless /^\\#/"',
-to remove all the leading comments on the fly during the build. The
-extra \\ are necessary, unfortunately, because this variable is interpolated
-within the context of a Perl program built on the command line, and double
-quotes are what is used with the -e switch to build that command line. The
-# is escaped for the Makefile, since what is going to be generated will then
-be:
+to remove all the leading comments on the fly during the build. In order
+to be as portable as possible, please consider using a Perl one-liner
+rather than Unix (or other) utilities, as above. The # is escaped for
+the Makefile, since what is going to be generated will then be:
- PM_FILTER = grep -v \"^\#\"
+ PM_FILTER = perl -ne "print unless /^\#/"
-Without the \\ before the #, we'd have the start of a Makefile comment,
+Without the \ before the #, we'd have the start of a Makefile comment,
and the macro would be incorrectly defined.
+You will almost certainly be better off using the C<PL_FILES> system,
+instead. See above, or the L<ExtUtils::MakeMaker::FAQ> entry.
+
=item POLLUTE
Release 5.005 grandfathered old global symbol names by providing preprocessor
A hash of modules that are needed to run your module. The keys are
the module names ie. Test::More, and the minimum version is the
value. If the required version number is 0 any version will do.
+The versions given may be a Perl v-string (see L<version>) or a range
+(see L<CPAN::Meta::Requirements>).
-This will go into the C<requires> field of your F<META.yml> and the C<runtime> of the C<prereqs> field of your F<META.json>.
+This will go into the C<requires> field of your F<META.yml> and the
+C<runtime> of the C<prereqs> field of your F<META.json>.
PREREQ_PM => {
# Require Test::More at least 0.47
The .c files will automatically be included in the list of files
deleted by a make clean.
+=item XSBUILD
+
+Hashref with options controlling the operation of C<XSMULTI>:
+
+ {
+ xs => {
+ all => {
+ # options applying to all .xs files for this distribution
+ },
+ 'lib/Class/Name/File' => { # specifically for this file
+ DEFINE => '-Dfunktastic', # defines for only this file
+ INC => "-I$funkyliblocation", # include flags for only this file
+ # OBJECT => 'lib/Class/Name/File$(OBJ_EXT)', # default
+ LDFROM => "lib/Class/Name/File\$(OBJ_EXT) $otherfile\$(OBJ_EXT)", # what's linked
+ },
+ },
+ }
+
+Note C<xs> is the file-extension. More possibilities may arise in the
+future. Note that object names are specified without their XS extension.
+
+C<LDFROM> defaults to the same as C<OBJECT>. C<OBJECT> defaults to,
+for C<XSMULTI>, just the XS filename with the extension replaced with
+the compiler-specific object-file extension.
+
+The distinction between C<OBJECT> and C<LDFROM>: C<OBJECT> is the make
+target, so make will try to build it. However, C<LDFROM> is what will
+actually be linked together to make the shared object or static library
+(SO/SL), so if you override it, make sure it includes what you want to
+make the final SO/SL, almost certainly including the XS basename with
+C<$(OBJ_EXT)> appended.
+
+=item XSMULTI
+
+When this is set to C<1>, multiple XS files may be placed under F<lib/>
+next to their corresponding C<*.pm> files (this is essential for compiling
+with the correct C<VERSION> values). This feature should be considered
+experimental, and details of it may change.
+
+This feature was inspired by, and small portions of code copied from,
+L<ExtUtils::MakeMaker::BigHelper>. Hopefully this feature will render
+that module mainly obsolete.
+
=item XSOPT
String of options to pass to xsubpp. This might include C<-C++> or
seamlessly and rapidly populate CPAN with module meta-data. If you wish to
shut this feature off, set the C<NO_META> C<WriteMakefile()> flag to true.
-At the 2008 QA Hackathon in Oslo, Perl module toolchain maintainers agrees
+At the 2008 QA Hackathon in Oslo, Perl module toolchain maintainers agreed
to use the CPAN Meta format to communicate post-configuration requirements
between toolchain components. These files, F<MYMETA.json> and F<MYMETA.yml>,
are generated when F<Makefile.PL> generates a F<Makefile> (if L<CPAN::Meta>
-is installed). Clients like L<CPAN> or L<CPANPLUS> will read this
+is installed). Clients like L<CPAN> or L<CPANPLUS> will read these
files to see what prerequisites must be fulfilled before building or testing
-the distribution. If you with to shut this feature off, set the C<NO_MYMETA>
+the distribution. If you wish to shut this feature off, set the C<NO_MYMETA>
C<WriteMakeFile()> flag to true.
=head2 Disabling an extension
use strict;
-our $VERSION = '7.10_01';
+our $VERSION = '7.18';
+$VERSION = eval $VERSION;
use Config ();
package ExtUtils::MakeMaker::FAQ;
-our $VERSION = '7.10_01';
+our $VERSION = '7.18';
+$VERSION = eval $VERSION;
1;
__END__
=item How do I install a module into my home directory?
If you're not the Perl administrator you probably don't have
-permission to install a module to its default location. Then you
-should install it for your own use into your home directory like so:
+permission to install a module to its default location. Ways of handling
+this with a B<lot> less manual effort on your part are L<perlbrew>
+and L<local::lib>.
+
+Otherwise, you can install it for your own use into your home directory
+like so:
# Non-unix folks, replace ~ with /path/to/your/home/dir
perl Makefile.PL INSTALL_BASE=~
use lib "/path/to/your/home/dir/lib/perl5";
-
=item How do I get MakeMaker and Module::Build to install to the same place?
Module::Build, as of 0.28, supports two ways to install to the same
make
make test
-...and then set the PERL5LIB environment variable to point at the
-blib/lib and blib/arch directories.
+...and then use L<blib> to point Perl at the built but uninstalled module:
+
+ perl -Mblib script.pl
+ perl -Mblib -e '...'
The other is to install the module in a temporary location.
And then set PERL5LIB to F<~/tmp/lib/perl5>. This works well when you
have multiple modules to work with. It also ensures that the module
goes through its full installation process which may modify it.
+Again, L<local::lib> may assist you here.
=item PREFIX vs INSTALL_BASE from Module::Build::Cookbook
The behavior of PREFIX is complicated and depends closely on how your
-Perl is configured. The resulting installation locations will vary from
-machine to machine and even different installations of Perl on the same machine.
-Because of this, its difficult to document where prefix will place your modules.
+Perl is configured. The resulting installation locations will vary
+from machine to machine and even different installations of Perl on the
+same machine. Because of this, its difficult to document where prefix
+will place your modules.
+
+In contrast, INSTALL_BASE has predictable, easy to explain installation
+locations. Now that Module::Build and MakeMaker both have INSTALL_BASE
+there is little reason to use PREFIX other than to preserve your existing
+installation locations. If you are starting a fresh Perl installation we
+encourage you to use INSTALL_BASE. If you have an existing installation
+installed via PREFIX, consider moving it to an installation structure
+matching INSTALL_BASE and using that instead.
+
+=item Generating *.pm files with substitutions eg of $VERSION
+
+If you want to configure your module files for local conditions, or to
+automatically insert a version number, you can use EUMM's C<PL_FILES>
+capability, where it will automatically run each F<*.PL> it finds to
+generate its basename. For instance:
+
+ # Makefile.PL:
+ require 'common.pl';
+ my $version = get_version();
+ my @pms = qw(Foo.pm);
+ WriteMakefile(
+ NAME => 'Foo',
+ VERSION => $version,
+ PM => { map { ($_ => "\$(INST_LIB)/$_") } @pms },
+ clean => { FILES => join ' ', @pms },
+ );
-In contrast, INSTALL_BASE has predictable, easy to explain installation locations.
-Now that Module::Build and MakeMaker both have INSTALL_BASE there is little reason
-to use PREFIX other than to preserve your existing installation locations. If you
-are starting a fresh Perl installation we encourage you to use INSTALL_BASE. If
-you have an existing installation installed via PREFIX, consider moving it to an
-installation structure matching INSTALL_BASE and using that instead.
+ # common.pl:
+ sub get_version { '0.04' }
+ sub process { my $v = get_version(); s/__VERSION__/$v/g; }
+ 1;
+
+ # Foo.pm.PL:
+ require 'common.pl';
+ $_ = join '', <DATA>;
+ process();
+ my $file = shift;
+ open my $fh, '>', $file or die "$file: $!";
+ print $fh $_;
+ __DATA__
+ package Foo;
+ our $VERSION = '__VERSION__';
+ 1;
+
+You may notice that C<PL_FILES> is not specified above, since the default
+of mapping each .PL file to its basename works well.
+
+If the generated module were architecture-specific, you could replace
+C<$(INST_LIB)> above with C<$(INST_ARCHLIB)>, although if you locate
+modules under F<lib>, that would involve ensuring any C<lib/> in front
+of the module location were removed.
=back
=back
-Module::Build was long the official heir apparent to MakeMaker. The rate of
-both its development and adoption has slowed in recent years, though, and it is
-unclear what the future holds for it. That said, Module::Build set the stage
-for I<something> to become the heir to MakeMaker. MakeMaker's maintainers have
-long said that it is a dead end and should be kept functioning, but not
-extended with new features. It's complicated enough as it is!
+Module::Build was long the official heir apparent to MakeMaker. The
+rate of both its development and adoption has slowed in recent years,
+though, and it is unclear what the future holds for it. That said,
+Module::Build set the stage for I<something> to become the heir to
+MakeMaker. MakeMaker's maintainers have long said that it is a dead
+end and should be kept functioning, while being cautious about extending
+with new features.
=back
-
=head2 Module Writing
=over 4
important is it goes up every time the module is changed. Doing this
by hand is a pain and you often forget.
-Simplest way to do it automatically is to use your version control
-system's revision number (you are using version control, right?).
+Probably the easiest way to do this is using F<perl-reversion> in
+L<Perl::Version>:
+
+ perl-reversion -bump
+
+If your version control system supports revision numbers (git doesn't
+easily), the simplest way to do it automatically is to use its revision
+number (you are using version control, right?).
In CVS, RCS and SVN you use $Revision$ (see the documentation of your
version control system for details). Every time the file is checked
We recommend ptar from Archive::Tar not older than 1.66 with '-C' option.
-=item Which zip should I use on Windows for '[nd]make zipdist'?
+=item Which zip should I use on Windows for '[ndg]make zipdist'?
We recommend InfoZIP: L<http://www.info-zip.org/Zip.html>
=head2 XS
-=over 4
-
-=item How do I prevent "object version X.XX does not match bootstrap parameter Y.YY" errors?
+=head3 How do I prevent "object version X.XX does not match bootstrap parameter Y.YY" errors?
XS code is very sensitive to the module version number and will
complain if the version number in your Perl module doesn't match. If
depend => { '$(FIRST_MAKEFILE)' => '$(VERSION_FROM)' }
-=item How do I make two or more XS files coexist in the same directory?
+=head3 How do I make two or more XS files coexist in the same directory?
Sometimes you need to have two and more XS files in the same package.
-One way to go is to put them into separate directories, but sometimes
-this is not the most suitable solution. The following technique allows
-you to put two (and more) XS files in the same directory.
+There are three ways: C<XSMULTI>, separate directories, and bootstrapping
+one XS from another.
+
+=head4 XSMULTI
+
+Structure your modules so they are all located under F<lib>, such that
+C<Foo::Bar> is in F<lib/Foo/Bar.pm> and F<lib/Foo/Bar.xs>, etc. Have your
+top-level C<WriteMakefile> set the variable C<XSMULTI> to a true value.
+
+Er, that's it.
+
+=head4 Separate directories
+
+Put each XS files into separate directories, each with their own
+F<Makefile.PL>. Make sure each of those F<Makefile.PL>s has the correct
+C<CFLAGS>, C<INC>, C<LIBS> etc. You will need to make sure the top-level
+F<Makefile.PL> refers to each of these using C<DIR>.
+
+=head4 Bootstrapping
Let's assume that we have a package C<Cool::Foo>, which includes
C<Cool::Foo> and C<Cool::Bar> modules each having a separate XS
This tip has been brought to you by Nick Ing-Simmons and Stas Bekman.
+An alternative way to achieve this can be seen in L<Gtk2::CodeGen>
+and L<Glib::CodeGen>.
+
=back
+=head1 DESIGN
+
+=head2 MakeMaker object hierarchy (simplified)
+
+What most people need to know (superclasses on top.)
+
+ ExtUtils::MM_Any
+ |
+ ExtUtils::MM_Unix
+ |
+ ExtUtils::MM_{Current OS}
+ |
+ ExtUtils::MakeMaker
+ |
+ MY
+
+The object actually used is of the class MY which allows you to
+override bits of MakeMaker inside your Makefile.PL by declaring
+MY::foo() methods.
+
+=head2 MakeMaker object hierarchy (real)
+
+Here's how it really works:
+
+ ExtUtils::MM_Any
+ |
+ ExtUtils::MM_Unix
+ |
+ ExtUtils::Liblist::Kid ExtUtils::MM_{Current OS} (if necessary)
+ | |
+ ExtUtils::Liblist ExtUtils::MakeMaker |
+ | | |
+ | | |-----------------------
+ ExtUtils::MM
+ | |
+ ExtUtils::MY MM (created by ExtUtils::MM)
+ | |
+ MY (created by ExtUtils::MY) |
+ . |
+ (mixin) |
+ . |
+ PACK### (created each call to ExtUtils::MakeMaker->new)
+
+NOTE: Yes, this is a mess. See
+L<http://archive.develooper.com/makemaker@perl.org/msg00134.html>
+for some history.
+
+NOTE: When ExtUtils::MM is loaded it chooses a superclass for MM from
+amongst the ExtUtils::MM_* modules based on the current operating
+system.
+
+NOTE: ExtUtils::MM_{Current OS} represents one of the ExtUtils::MM_*
+modules except ExtUtils::MM_Any chosen based on your operating system.
+
+NOTE: The main object used by MakeMaker is a PACK### object, *not*
+ExtUtils::MakeMaker. It is, effectively, a subclass of MY,
+ExtUtils::Makemaker, ExtUtils::Liblist and ExtUtils::MM_{Current OS}
+
+NOTE: The methods in MY are simply copied into PACK### rather than
+MY being a superclass of PACK###. I don't remember the rationale.
+
+NOTE: ExtUtils::Liblist should be removed from the inheritence hiearchy
+and simply be called as functions.
+
+NOTE: Modules like File::Spec and Exporter have been omitted for clarity.
+
+
+=head2 The MM_* hierarchy
+
+ MM_Win95 MM_NW5
+ \ /
+ MM_BeOS MM_Cygwin MM_OS2 MM_VMS MM_Win32 MM_DOS MM_UWIN
+ \ | | | / / /
+ ------------------------------------------------
+ | |
+ MM_Unix |
+ | |
+ MM_Any
+
+NOTE: Each direct MM_Unix subclass is also an MM_Any subclass. This
+is a temporary hack because MM_Unix overrides some MM_Any methods with
+Unix specific code. It allows the non-Unix modules to see the
+original MM_Any implementations.
+
+NOTE: Modules like File::Spec and Exporter have been omitted for clarity.
+
=head1 PATCHING
If you have a question you'd like to see added to the FAQ (whether or
-not you have the answer) please send it to makemaker@perl.org.
+not you have the answer) please either:
+
+=over 2
+
+=item * make a pull request on the MakeMaker github repository
+
+=item * raise a issue on the MakeMaker github repository
+
+=item * file an RT ticket
+
+=item * email makemaker@perl.org
+
+=back
=head1 AUTHOR
package ExtUtils::MakeMaker::Locale;
use strict;
-our $VERSION = "7.10";
+our $VERSION = "7.18";
+$VERSION = eval $VERSION;
use base 'Exporter';
our @EXPORT_OK = qw(
sub _flush_aliases {
no strict 'refs';
- for my $a (keys %Encode::Alias::Alias) {
+ for my $a (sort keys %Encode::Alias::Alias) {
if (defined ${"ENCODING_" . uc($a)}) {
delete $Encode::Alias::Alias{$a};
warn "Flushed alias cache for $a" if DEBUG;
package ExtUtils::MakeMaker::Tutorial;
-our $VERSION = '7.10_01';
+our $VERSION = '7.18';
+$VERSION = eval $VERSION;
=head1 NAME
package ExtUtils::MakeMaker::version;
-use 5.006002;
+use 5.006001;
use strict;
use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);
-$VERSION = '7.10_01';
+$VERSION = '7.18';
+$VERSION = eval $VERSION;
$CLASS = 'version';
{
use vars qw($VERSION $CLASS $STRICT $LAX);
-$VERSION = '7.10_01';
+$VERSION = '7.18';
+$VERSION = eval $VERSION;
#--------------------------------------------------------------------------#
# Version regexp components
# There's just too much Dynaloader incest here to turn on strict vars.
use strict 'refs';
-our $VERSION = '7.10_01';
+our $VERSION = '7.18';
+$VERSION = eval $VERSION;
require Exporter;
our @ISA = ('Exporter');
my(@all) = (@bsloadlibs, @DynaLoader::dl_resolve_using);
my($method) = '';
- if (@all){
+ if (@all || (defined $DynaLoader::bscode && length $DynaLoader::bscode)){
open my $bs, ">", "$baseext.bs"
or die "Unable to open $baseext.bs: $!";
print "Writing $baseext.bs\n";
print $bs "# Do not edit this file, changes will be lost.\n";
print $bs "# This file was automatically generated by the\n";
print $bs "# Mkbootstrap routine in ExtUtils::Mkbootstrap (v$VERSION).\n";
- print $bs "\@DynaLoader::dl_resolve_using = ";
- # If @all contains names in the form -lxxx or -Lxxx then it's asking for
- # runtime library location so we automatically add a call to dl_findfile()
- if (" @all" =~ m/ -[lLR]/){
- print $bs " dl_findfile(qw(\n @all\n ));\n";
- }else{
- print $bs " qw(@all);\n";
+ if (@all) {
+ print $bs "\@DynaLoader::dl_resolve_using = ";
+ # If @all contains names in the form -lxxx or -Lxxx then it's asking for
+ # runtime library location so we automatically add a call to dl_findfile()
+ if (" @all" =~ m/ -[lLR]/){
+ print $bs " dl_findfile(qw(\n @all\n ));\n";
+ } else {
+ print $bs " qw(@all);\n";
+ }
}
# write extra code if *_BS says so
print $bs $DynaLoader::bscode if $DynaLoader::bscode;
our @ISA = qw(Exporter);
our @EXPORT = qw(&Mksymlists);
-our $VERSION = '7.10_01';
+our $VERSION = '7.18';
+$VERSION = eval $VERSION;
sub Mksymlists {
my(%spec) = @_;
open( my $def, ">", "$data->{FILE}.def" )
or croak("Can't create $data->{FILE}.def: $!\n");
# put library name in quotes (it could be a keyword, like 'Alias')
- if ($Config::Config{'cc'} !~ /^gcc/i) {
+ if ($Config::Config{'cc'} !~ /\bgcc/i) {
print $def "LIBRARY \"$data->{DLBASE}\"\n";
}
print $def "EXPORTS\n ";
use strict;
use warnings;
-our $VERSION = '7.10_01';
+our $VERSION = '7.18';
+$VERSION = eval $VERSION;
use Cwd;
use File::Spec;
use lib 't/lib';
-use Test::More;
+use Test::More tests => 1;
note "The 0.01 / Gconvert bug"; {
my $number = 0.01;
END
};
}
-
-done_testing;
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use warnings;
+use Config;
+BEGIN {
+ chdir 't' or die "chdir(t): $!\n";
+ unshift @INC, 'lib/';
+}
+use MakeMaker::Test::Utils;
+use MakeMaker::Test::Setup::XS;
+use Test::More;
+
+plan skip_all => 'Dynaloading not enabled' if !$Config{usedl} or $Config{usedl} ne 'define';
+plan skip_all => "ExtUtils::CBuilder not installed or couldn't find a compiler"
+ unless have_compiler();
+my @tests = list_dynamic();
+plan skip_all => "No tests" unless @tests;
+plan tests => 6 * @tests;
+my $perl = which_perl();
+perl_lib;
+$| = 1;
+run_tests($perl, @$_) for @tests;
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use warnings;
+use Config;
+BEGIN {
+ chdir 't' or die "chdir(t): $!\n";
+ unshift @INC, 'lib/';
+}
+use MakeMaker::Test::Utils;
+use MakeMaker::Test::Setup::XS;
+use Test::More;
+
+plan skip_all => "Disabled as broken perl installs give false negative"
+ # if not static perl, and not author
+ unless !$Config{usedl} or $ENV{AUTHOR_TESTING};
+plan skip_all => "ExtUtils::CBuilder not installed or couldn't find a compiler"
+ unless have_compiler();
+plan skip_all => 'Shared perl library' if $Config{useshrplib} eq 'true';
+plan skip_all => $^O if $^O =~ m!^(MSWin32|cygwin|haiku)$!;
+my @tests = list_static();
+plan skip_all => "No tests" unless @tests;
+plan tests => 6 * @tests;
+my $perl = which_perl();
+perl_lib;
+$| = 1;
+run_tests($perl, @$_) for @tests;
unshift @INC, 't/lib';
}
-use File::Temp qw[tempdir];
-my $tmpdir = tempdir( DIR => 't', CLEANUP => 1 );
-chdir $tmpdir;
-
use strict;
use Test::More tests => 7;
use MakeMaker::Test::Setup::BFD;
use MakeMaker::Test::Utils;
+chdir 't';
+perl_lib; # sets $ENV{PERL5LIB} relative to t/
+
+use File::Temp qw[tempdir];
+my $tmpdir = tempdir( DIR => '../t', CLEANUP => 1 );
+use Cwd; my $cwd = getcwd; END { chdir $cwd } # so File::Temp can cleanup
+chdir $tmpdir;
+
my $perl = which_perl();
my $make = make_run();
-perl_lib();
-
ok( setup_recurs(), 'setup' );
END {
use TieOut;
use Config;
+chdir 't';
+perl_lib; # sets $ENV{PERL5LIB} relative to t/
+
use File::Temp qw[tempdir];
-my $tmpdir = tempdir( DIR => 't', CLEANUP => 1 );
+my $tmpdir = tempdir( DIR => '../t', CLEANUP => 1 );
+use Cwd; my $cwd = getcwd; END { chdir $cwd } # so File::Temp can cleanup
chdir $tmpdir;
-perl_lib;
-
$| = 1;
my $Makefile = makefile_name;
PERL_CORE => $ENV{PERL_CORE},
);
like( $stdout->read, qr{
- Generating\ a\ \w+?-style\ $Makefile\n
- Writing\ $Makefile\ for\ Big::Liar\n
+ (?:Generating\ a\ \w+?-style\ $Makefile\n)?
+ (?:Writing\ $Makefile\ for\ Big::Liar\n)?
(?:Writing\ MYMETA.yml\ and\ MYMETA.json\n)?
Big::Liar's\ vars\n
INST_LIB\ =\ \S+\n
INST_MAN1DIR => 'none',
);
like( $stdout->read, qr{
- Generating\ a\ \w+?-style\ $Makefile\n
- Writing\ $Makefile\ for\ Big::Liar\n
+ (?:Generating\ a\ \w+?-style\ $Makefile\n)?
+ (?:Writing\ $Makefile\ for\ Big::Liar\n)?
(?:Writing\ MYMETA.yml\ and\ MYMETA.json\n)?
Big::Liar's\ vars\n
INST_LIB\ =\ \S+\n
use MakeMaker::Test::Utils;
use MakeMaker::Test::Setup::BFD;
-use Test::More;
use Config;
use ExtUtils::MM;
-plan !MM->can_run(make()) && $ENV{PERL_CORE} && $Config{'usecrosscompile'}
+use Test::More
+ !MM->can_run(make()) && $ENV{PERL_CORE} && $Config{'usecrosscompile'}
? (skip_all => "cross-compiling and make not available")
- : (tests => 3 + $CLEANUP + @INSTDIRS * (15 + $CLEANUP));
+ : ();
+plan tests => 4 + $CLEANUP + @INSTDIRS * (15 + $CLEANUP);
my $Is_VMS = $^O eq 'VMS';
my $perl = which_perl();
+chdir 't';
+perl_lib; # sets $ENV{PERL5LIB} relative to t/
+
use File::Temp qw[tempdir];
-my $tmpdir = tempdir( DIR => 't', CLEANUP => $CLEANUP );
+my $tmpdir = tempdir( DIR => '../t', CLEANUP => $CLEANUP );
+use Cwd; my $cwd = getcwd; END { chdir $cwd } # so File::Temp can cleanup
chdir $tmpdir;
-perl_lib;
-
-ok( setup_recurs(), 'setup' );
+my $SPACEDIR = 'space dir';
+ok( setup_recurs($SPACEDIR), 'setup' );
END {
ok( chdir File::Spec->updir, 'chdir updir' );
+ ok( chdir File::Spec->updir, 'chdir updir again' );
ok( teardown_recurs(), 'teardown' ) if $CLEANUP;
map { rmtree $_ } @INSTDIRS if $CLEANUP;
}
-ok( chdir('Big-Dummy'), "chdir'd to Big-Dummy") || diag("chdir failed; $!");
+ok( chdir(File::Spec->catdir($SPACEDIR, 'Big-Dummy')), "chdir'd to Big-Dummy") || diag("chdir failed; $!");
for my $instdir (@INSTDIRS) {
+ $instdir = File::Spec->rel2abs($instdir);
+ $instdir = VMS::Filespec::unixpath($instdir) if $Is_VMS;
my @mpl_out = run(qq{$perl Makefile.PL "INSTALL_BASE=$instdir"});
cmp_ok( $?, '==', 0, 'Makefile.PL exited with zero' ) ||
my $Is_VMS = $^O eq 'VMS';
+chdir 't';
+perl_lib; # sets $ENV{PERL5LIB} relative to t/
+
use File::Temp qw[tempdir];
-my $tmpdir = tempdir( DIR => 't', CLEANUP => 1 );
+my $tmpdir = tempdir( DIR => '../t', CLEANUP => 1 );
+use Cwd; my $cwd = getcwd; END { chdir $cwd } # so File::Temp can cleanup
chdir $tmpdir;
-perl_lib;
-
$| = 1;
my $Makefile = makefile_name;
);
like( $stdout->read, qr{
- Generating\ a\ \w+?-style\ $Makefile\n
- Writing\ $Makefile\ for\ Big::Liar\n
+ (?:Generating\ a\ \w+?-style\ $Makefile\n)?
+ (?:Writing\ $Makefile\ for\ Big::Liar\n)?
(?:Writing\ MYMETA.yml\ and\ MYMETA.json\n)?
Big::Liar's\ vars\n
INST_LIB\ =\ \S+\n
PREFIX => $PREFIX,
);
like( $stdout->read, qr{
- Generating\ a\ \w+?-style\ $Makefile\n
- Writing\ $Makefile\ for\ Big::Liar\n
+ (?:Generating\ a\ \w+?-style\ $Makefile\n)?
+ (?:Writing\ $Makefile\ for\ Big::Liar\n)?
(?:Writing\ MYMETA.yml\ and\ MYMETA.json\n)?
Big::Liar's\ vars\n
INST_LIB\ =\ \S+\n
$MM->{MAN3PODS} = { foo => 'foo.1' };
my $res = $MM->manifypods();
-like( $res, qr/pure_all.*foo.*foo.1/s, '... should add MAN3PODS targets' );
+like( $res, qr/manifypods.*foo.*foo.1/s, '... should add MAN3PODS targets' );
# init_linker
$mm_w32->{$key} = '';
}
my $s_PM = join( " \\\n\t", sort keys %{$mm_w32->{PM}} );
- my $k_PM = join( " \\\n\t", %{$mm_w32->{PM}} );
like( $mm_w32->constants(),
qr|^NAME\ =\ TestMM_NW5\s+VERSION\ =\ 1\.00.+
MM_VERSION\ =\ \Q$ExtUtils::MakeMaker::VERSION\E.+
VERSION_FROM\ =\ TestMM_NW5.+
TO_INST_PM\ =\ \Q$s_PM\E\s+
- PM_TO_BLIB\ =\ \Q$k_PM\E
|xs, 'constants()' );
}
END {
use File::Path;
- rmtree('tmp_imp');
+ rmtree('tmp_imp') if -e 'tmp_imp';
unlink 'tmpimp.imp';
}
ppd
prefixify
processPL
- quote_paren
realclean
static
static_lib
like( $t->{CCFLAGS}, qr/\-DMY_THING/, 'cflags retains CCFLAGS' );
}
+{
+ my @targv = ("var=don't forget about spaces and single quotes");
+ local @ARGV = @targv;
+ my $t = bless { NAME => "Foo", FULLPERL => $0, DIR => [] }, $class;
+ $t->makeaperl( TARGET => "Tgt" );
+ is_deeply( \@ARGV, \@targv, 'ARGV is not polluted by makeaperl' );
+}
plan skip_all => 'This is not Win32';
}
}
+plan 'no_plan'; # BinGOs says there are 63 but I can only see 62
use Config;
use File::Spec;
$mm_w32->init_xs;
my $s_PM = join( " \\\n\t", sort keys %{$mm_w32->{PM}} );
- my $k_PM = join( " \\\n\t", %{$mm_w32->{PM}} );
my $constants = $mm_w32->constants;
qr|^MAKEMAKER \s* = \s* \Q$INC{'ExtUtils/MakeMaker.pm'}\E \s* $|xms,
qr|^MM_VERSION \s* = \s* \Q$ExtUtils::MakeMaker::VERSION\E \s* $|xms,
qr|^TO_INST_PM \s* = \s* \Q$s_PM\E \s* $|xms,
- qr|^PM_TO_BLIB \s* = \s* \Q$k_PM\E \s* $|xms,
)
{
like( $constants, $regex, 'constants() check' );
my @cc_env = ExtUtils::MM_Win32::_identify_compiler_environment( $config );
- my %cc_env = ( BORLAND => $cc_env[0], GCC => $cc_env[1], DLLTOOL => $cc_env[2] );
+ my %cc_env = ( BORLAND => $cc_env[0], GCC => $cc_env[1], MSVC => $cc_env[2] );
return \%cc_env;
}
my @tests = (
{
config => {},
- key => 'DLLTOOL', expect => 'dlltool',
- desc => 'empty dlltool defaults to "dlltool"',
- },
- {
- config => { dlltool => 'test' },
- key => 'DLLTOOL', expect => 'test',
- desc => 'dlltool value is taken over verbatim from %Config, if set',
- },
- {
- config => {},
key => 'GCC', expect => 0,
desc => 'empty cc is not recognized as gcc',
},
},
{
config => { cc => 'C:/Borland/bin/bcc.exe' },
- key => 'BORLAND', expect => 0,
- desc => 'fully qualified borland cc is not recognized',
+ key => 'BORLAND', expect => 1,
+ desc => 'fully qualified borland cc is recognized',
},
{
config => { cc => 'bcc-1.exe' },
_check_cc_id_value($_) for @tests;
}
-
-done_testing;
-
-
package FakeOut;
sub TIEHANDLE {
use warnings;
use ExtUtils::MakeMaker;
-use Test::More;
+use Test::More tests => 6;
my $mm = bless {}, "MM";
# NAME => q[Foo]
# PREREQ_PM => { Baz=>q[0.12], Foo::Bar=>q[1.23], Long=>q[1.45], Short=>q[0] }
EXPECT
-
-done_testing();
chmod 0444, 'dasboot.bs';
SKIP: {
- skip("cannot write readonly files", 1) if -w 'dasboot.bs';
+ skip("cannot write readonly files", 1) if -w 'dasboot.bs' || $^O eq 'cygwin';
eval{ Mkbootstrap('dasboot', 1) };
like( $@, qr/Unable to open dasboot\.bs/, 'should die given bad filename' );
}
use strict;
+use warnings;
-use File::Spec;
-use File::Temp qw[tempdir];
-use MakeMaker::Test::Setup::PL_FILES;
use MakeMaker::Test::Utils;
use Config;
-use Test::More;
use ExtUtils::MM;
-plan !MM->can_run(make()) && $ENV{PERL_CORE} && $Config{'usecrosscompile'}
+use Test::More
+ !MM->can_run(make()) && $ENV{PERL_CORE} && $Config{'usecrosscompile'}
? (skip_all => "cross-compiling and make not available")
- : (tests => 9);
+ : (tests => 10);
+use File::Spec;
+use File::Temp qw[tempdir];
+use File::Path;
my $perl = which_perl();
my $make = make_run();
-perl_lib();
+chdir 't';
+perl_lib; # sets $ENV{PERL5LIB} relative to t/
-my $tmpdir = tempdir( DIR => 't', CLEANUP => 1 );
+my $tmpdir = tempdir( DIR => '../t', CLEANUP => 1 );
+use Cwd; my $cwd = getcwd; END { chdir $cwd } # so File::Temp can cleanup
chdir $tmpdir;
-setup;
+my $DIRNAME = 'PL-Module';
+my %FILES = (
+ 'Makefile.PL' => <<'END',
+use ExtUtils::MakeMaker;
+# A module for testing PL_FILES
+WriteMakefile(
+ NAME => 'PL::Module',
+ PL_FILES => { 'single.PL' => 'single.out',
+ 'multi.PL' => [qw(1.out 2.out)],
+ 'Bar_pm.PL' => '$(INST_LIB)/PL/Bar.pm',
+ 'Bar2.pm.PL' => 'Bar2.pm',
+ },
+);
+
+package MY;
+sub init_PM {
+ my ($self) = @_;
+ $self->SUPER::init_PM;
+ $self->{PM}{'Bar2.pm'} = '$(INST_LIBDIR)/Bar2.pm'; # PDL does this in WM args
+}
+END
+
+ 'single.PL' => _gen_pl_files(),
+ 'multi.PL' => _gen_pl_files(),
+ 'Bar_pm.PL' => _gen_pm_files(),
+ 'Bar2.pm.PL' => _gen_pm_files(),
+ 'lib/PL/Foo.pm' => <<'END',
+# Module to load to ensure PL_FILES have blib in @INC.
+package PL::Foo;
+sub bar { 42 }
+1;
+END
+);
+
+hash2files($DIRNAME, \%FILES);
END {
ok( chdir File::Spec->updir );
- ok( teardown );
+ ok( rmtree($DIRNAME) );
}
-ok chdir('PL_FILES-Module');
+ok chdir($DIRNAME);
run(qq{$perl Makefile.PL});
cmp_ok( $?, '==', 0 );
my $make_out = run("$make");
is( $?, 0 ) || diag $make_out;
-foreach my $file (qw(single.out 1.out 2.out blib/lib/PL/Bar.pm)) {
+foreach my $file (qw(single.out 1.out 2.out blib/lib/PL/Bar.pm blib/lib/PL/Bar2.pm)) {
ok( -e $file, "$file was created" );
}
+
+sub _gen_pl_files {
+ my $test = <<'END';
+#!/usr/bin/perl -w
+
+# Ensure we have blib in @INC
+use PL::Foo;
+die unless PL::Foo::bar() == 42;
+
+# Had a bug where PL_FILES weren't sent the file to generate
+die "argv empty\n" unless @ARGV;
+die "too many in argv: @ARGV\n" unless @ARGV == 1;
+
+my $file = $ARGV[0];
+open OUT, ">$file" or die $!;
+
+print OUT "Testing\n";
+close OUT
+END
+
+ $test =~ s/^\n//;
+
+ return $test;
+}
+
+sub _gen_pm_files {
+ my $test = <<'END';
+#!/usr/bin/perl -w
+
+# Ensure we do NOT have blib in @INC when building a module
+eval { require PL::Foo; };
+#die $@ unless $@ =~ m{^Can't locate PL/Foo.pm in \@INC };
+
+# Had a bug where PL_FILES weren't sent the file to generate
+die "argv empty\n" unless @ARGV;
+die "too many in argv: @ARGV\n" unless @ARGV == 1;
+
+my $file = $ARGV[0];
+open OUT, ">$file" or die $!;
+
+print OUT "Testing\n";
+close OUT
+END
+
+ $test =~ s/^\n//;
+
+ return $test;
+}
use File::Temp qw[tempdir];
my $tmpdir = tempdir( DIR => 't', CLEANUP => 1 );
+use Cwd; my $cwd = getcwd; END { chdir $cwd } # so File::Temp can cleanup
chdir $tmpdir;
use strict;
use MakeMaker::Test::Utils;
use MakeMaker::Test::Setup::BFD;
use Config;
-use Test::More;
use ExtUtils::MM;
-plan !MM->can_run(make()) && $ENV{PERL_CORE} && $Config{'usecrosscompile'}
+use Test::More
+ !MM->can_run(make()) && $ENV{PERL_CORE} && $Config{'usecrosscompile'}
? (skip_all => "cross-compiling and make not available")
- : (tests => 171);
+ : (tests => 186);
use File::Find;
use File::Spec;
use File::Path;
}
}
-my $tmpdir = tempdir( DIR => 't', CLEANUP => 1 );
-chdir $tmpdir;
+chdir 't';
+perl_lib; # sets $ENV{PERL5LIB} relative to t/
-perl_lib;
+my $tmpdir = tempdir( DIR => '../t', CLEANUP => 1 );
+use Cwd; my $cwd = getcwd; END { chdir $cwd } # so File::Temp can cleanup
+chdir $tmpdir;
my $Touch_Time = calibrate_mtime();
$| = 1;
ok( setup_recurs(), 'setup' );
-END {
- ok chdir File::Spec->updir or die;
- ok teardown_recurs, "teardown";
-}
ok( chdir('Big-Dummy'), "chdir'd to Big-Dummy" ) ||
diag("chdir failed: $!");
-sub extrachar { $] > 5.008 && !$ENV{PERL_CORE} ? utf8::decode(my $c='š') : 's' }
+sub extrachar {
+ return 's'
+ if 1; # until Perl gains native support for Unicode filenames
+# if $] <= 5.008 || $ENV{PERL_CORE}
+# || $^O =~ /bsd|dragonfly|mswin32/i;
+ 'š';
+}
my $DUMMYINST = '../dummy-in'.extrachar().'tall';
my @mpl_out = run(qq{$perl Makefile.PL "PREFIX=$DUMMYINST"});
-END { rmtree $DUMMYINST; }
cmp_ok( $?, '==', 0, 'Makefile.PL exited with zero' ) ||
diag(@mpl_out);
my $mtime = (stat($makefile))[9];
cmp_ok( $Touch_Time, '<=', $mtime, ' been touched' );
-END { unlink makefile_name(), makefile_backup() }
-
my $make = make_run();
{
ok( -s 'MANIFEST', ' not empty' );
}
-END { unlink 'MANIFEST'; }
-
my $ppd_out = run("$make ppd");
is( $?, 0, ' exited normally' ) || diag $ppd_out;
ok( open(PPD, 'Big-Dummy.ppd'), ' .ppd file generated' );
like( $ppd_html, qr{^\s*<CODEBASE HREF="" />}m, ' <CODEBASE>');
like( $ppd_html, qr{^\s*</IMPLEMENTATION>}m, ' </IMPLEMENTATION>');
like( $ppd_html, qr{^\s*</SOFTPKG>}m, ' </SOFTPKG>');
-END { unlink 'Big-Dummy.ppd' }
-
my $test_out = run("$make test");
like( $test_out, qr/All tests successful/, 'make test' );
my $make_test_verbose = make_macro($make, 'test', TEST_VERBOSE => 1);
$test_out = run("$make_test_verbose");
like( $test_out, qr/ok \d+ - TEST_VERBOSE/, 'TEST_VERBOSE' );
+like( $test_out, qr/ok \d+ - testing test.pl/, 'test.pl' ); # in test.pl
+like( $test_out, qr/ok \d+ - testing t\/\*.t/, 't/*.t' ); # in *.t
like( $test_out, qr/All tests successful/, ' successful' );
is( $?, 0, ' exited normally' ) ||
diag $test_out;
+# Test 'make testdb TEST_FILE=t/compile.t'
+# TESTDB_SW override is because perl -d is too clever for me to outwit
+my $make_testdb_file = make_macro(
+ $make,
+ 'testdb',
+ TEST_FILE => 't/compile.t',
+ TESTDB_SW => '-Ixyzzy',
+);
+$test_out = run($make_testdb_file);
+unlike( $test_out, qr/harness/, 'no harness' );
+unlike( $test_out, qr/sanity\.t/, 'no wrong test' );
+like( $test_out, qr/compile\.t/, 'get right test' );
+like( $test_out, qr/xyzzy/, 'signs of TESTDB_SW' );
+is( $?, 0, ' exited normally' ) ||
+ diag $test_out;
+
# now simulate what Module::Install does, and edit $(PERL) to add flags
open my $fh, '<', $makefile;
my $mtext = join '', <$fh>;
like( $install_out, qr/^Installing /m );
sub check_dummy_inst {
- my $loc = shift;
+ my ($loc, $skipsubdir) = @_;
my %files = ();
find( sub {
# do it case-insensitive for non-case preserving OSs
$files{$file} = $File::Find::name;
}, $loc );
ok( $files{'dummy.pm'}, ' Dummy.pm installed' );
- ok( $files{'liar.pm'}, ' Liar.pm installed' );
+ ok( $files{'liar.pm'}, ' Liar.pm installed' ) unless $skipsubdir;
ok( $files{'program'}, ' program installed' );
ok( $files{'.packlist'}, ' packlist created' );
ok( $files{'perllocal.pod'},' perllocal.pod created' );
rmtree('other');
}
+my ($dist_test_out, $distdir, $meta_yml, $mymeta_yml, $meta_json, $mymeta_json);
+SKIP: {
+ skip 'disttest depends on metafile, which is not run in core', 1 if $ENV{PERL_CORE};
+ $dist_test_out = run("$make disttest");
+ is( $?, 0, 'disttest' ) || diag($dist_test_out);
+
+ # Test META.yml generation
+ use ExtUtils::Manifest qw(maniread);
+
+ $distdir = 'Big-Dummy-0.01';
+ $distdir =~ s/\./_/g if $Is_VMS;
+ $meta_yml = "$distdir/META.yml";
+ $mymeta_yml = "$distdir/MYMETA.yml";
+ $meta_json = "$distdir/META.json";
+ $mymeta_json = "$distdir/MYMETA.json";
+}
-my $dist_test_out = run("$make disttest");
-is( $?, 0, 'disttest' ) || diag($dist_test_out);
-
-# Test META.yml generation
-use ExtUtils::Manifest qw(maniread);
-
-my $distdir = 'Big-Dummy-0.01';
-$distdir =~ s/\./_/g if $Is_VMS;
-my $meta_yml = "$distdir/META.yml";
-my $mymeta_yml = "$distdir/MYMETA.yml";
-my $meta_json = "$distdir/META.json";
-my $mymeta_json = "$distdir/MYMETA.json";
+note "META file validity"; SKIP: {
+ skip 'disttest depends on metafile, which is not run in core', 104 if $ENV{PERL_CORE};
-note "META file validity"; {
- require CPAN::Meta;
+ eval { require CPAN::Meta; };
+ skip 'Loading CPAN::Meta failed', 104 if $@;
ok( !-f 'META.yml', 'META.yml not written to source dir' );
ok( -f $meta_yml, 'META.yml written to dist dir' );
open(STDERR, ">&SAVERR") or die $!;
close SAVERR;
+# test linkext=>{LINKTYPE=>''} still installs a pure-perl installation
+# warning, edits the Makefile.PL so either rewrite after this or do this last
+my $file = 'Makefile.PL';
+my $text = slurp $file;
+ok(($text =~ s#\);# linkext=>{LINKTYPE=>''},\n$&#), 'successful M.PL edit');
+open $fh, '>', $file or die "$file: $!";
+print $fh $text;
+close $fh;
+# now do with "Liar" subdir still there
+rmtree $DUMMYINST; # so no false positive from before
+@mpl_out = run(qq{$perl Makefile.PL "PREFIX=$DUMMYINST"});
+$install_out = run("$make install");
+check_dummy_inst($DUMMYINST);
+# now clean, delete "Liar" subdir, do again
+$realclean_out = run("$make realclean");
+rmtree 'Liar';
+rmtree $DUMMYINST; # so no false positive from before
+@mpl_out = run(qq{$perl Makefile.PL "PREFIX=$DUMMYINST"});
+$install_out = run("$make install");
+check_dummy_inst($DUMMYINST, 1);
+
sub _normalize {
my $hash = shift;
}
use strict;
-use Test::More tests => 9;
+use Test::More tests => 10;
use File::Spec;
use File::Temp qw[tempdir];
# ensure these tests will still work.
$Config{installman3dir} = 'none';
-my $tmpdir = tempdir( DIR => 't', CLEANUP => 1 );
-chdir $tmpdir;
+chdir 't';
+perl_lib; # sets $ENV{PERL5LIB} relative to t/
-perl_lib();
+my $tmpdir = tempdir( DIR => '../t', CLEANUP => 1 );
+use Cwd; my $cwd = getcwd; END { chdir $cwd } # so File::Temp can cleanup
+chdir $tmpdir;
ok( setup_recurs(), 'setup' );
END {
- ok( chdir File::Spec->updir );
- ok( teardown_recurs(), 'teardown' );
+ ok chdir File::Spec->updir, 'chdir updir';
+ ok teardown_recurs(), 'teardown';
}
ok( chdir 'Big-Dummy', "chdir'd to Big-Dummy" ) ||
diag("chdir failed: $!");
+my $README = 'README.pod';
+{ open my $fh, '>', $README or die "$README: $!"; }
-ok( my $stdout = tie *STDOUT, 'TieOut' );
+ok((my $stdout = tie *STDOUT, 'TieOut'), 'tie stdout');
{
local $Config{installman3dir} = File::Spec->catdir(qw(t lib));
-
my $mm = WriteMakefile(
NAME => 'Big::Dummy',
VERSION_FROM => 'lib/Big/Dummy.pm',
);
-
- ok( keys %{ $mm->{MAN3PODS} } );
+ my %got = %{ $mm->{MAN3PODS} };
+ # because value too OS-specific
+ my $delete_key = $^O eq 'VMS' ? '[.lib.Big]Dummy.pm' : 'lib/Big/Dummy.pm';
+ ok delete($got{$delete_key}), 'normal man3pod';
+ is_deeply \%got, {}, 'no extra man3pod';
}
{
VERSION_FROM => 'lib/Big/Dummy.pm',
INSTALLMAN3DIR => 'none'
);
-
- is_deeply( $mm->{MAN3PODS}, {} );
+ is_deeply $mm->{MAN3PODS}, {}, 'suppress man3pod with "none"';
}
-
{
my $mm = WriteMakefile(
NAME => 'Big::Dummy',
VERSION_FROM => 'lib/Big/Dummy.pm',
MAN3PODS => {}
);
-
- is_deeply( $mm->{MAN3PODS}, { } );
+ is_deeply $mm->{MAN3PODS}, {}, 'suppress man3pod with {}';
}
-
{
my $mm = WriteMakefile(
NAME => 'Big::Dummy',
VERSION_FROM => 'lib/Big/Dummy.pm',
MAN3PODS => { "Foo.pm" => "Foo.1" }
);
-
- is_deeply( $mm->{MAN3PODS}, { "Foo.pm" => "Foo.1" } );
+ is_deeply $mm->{MAN3PODS}, { "Foo.pm" => "Foo.1" }, 'override man3pod';
}
use File::Temp qw[tempdir];
my $tmpdir = tempdir( DIR => 't', CLEANUP => 1 );
+use Cwd; my $cwd = getcwd; END { chdir $cwd } # so File::Temp can cleanup
chdir $tmpdir;
my $Is_VMS = $^O eq 'VMS';
use File::Temp qw[tempdir];
my $tmpdir = tempdir( DIR => 't', CLEANUP => 1 );
+use Cwd; my $cwd = getcwd; END { chdir $cwd } # so File::Temp can cleanup
chdir $tmpdir;
use Test::More tests => 1;
use File::Temp;
use Cwd 'abs_path';
-use Test::More;
use ExtUtils::MM;
-plan !MM->can_run(make()) && $ENV{PERL_CORE} && $Config{'usecrosscompile'}
+use Test::More
+ !MM->can_run(make()) && $ENV{PERL_CORE} && $Config{'usecrosscompile'}
? (skip_all => "cross-compiling and make not available")
- : ();
+ : (tests => 18);
#--------------------- Setup
"Foo\nBar\nBaz\n",
"append"
);
-
-done_testing;
unshift @INC, 't/lib/';
}
-use File::Temp qw[tempdir];
-my $tmpdir = tempdir( DIR => 't', CLEANUP => 1 );
-chdir $tmpdir;
-
use File::Spec;
use Test::More tests => 22;
use ExtUtils::MakeMaker;
chdir 't';
+perl_lib; # sets $ENV{PERL5LIB} relative to t/
-perl_lib();
+use File::Temp qw[tempdir];
+my $tmpdir = tempdir( DIR => '../t', CLEANUP => 1 );
+use Cwd; my $cwd = getcwd; END { chdir $cwd } # so File::Temp can cleanup
+chdir $tmpdir;
ok( setup_recurs(), 'setup' );
END {
use File::Temp qw[tempdir];
my $tmpdir = tempdir( DIR => 't', CLEANUP => 1 );
+use Cwd; my $cwd = getcwd; END { chdir $cwd } # so File::Temp can cleanup
chdir $tmpdir;
use File::Spec;
$mm->check_hints;
is( $mm->{CCFLAGS}, 'basset hounds got long ears' );
- is( $stderr, "Processing hints file $Hint_File\n" );
+ is( $stderr, "" );
}
$mm->check_hints;
is( $stderr, <<OUT, 'hint files produce errors' );
-Processing hints file $Hint_File
Argh!
OUT
}
use lib './lib';
use ExtUtils::MakeMaker;
-use Test::More;
+use Test::More tests => 4;
use File::Spec;
my $want = $INC{"Test/More.pm"};
path_is( MM->_installed_file_for_module("Test::More"), $want, "Foo::Bar style" );
}
-
-
-done_testing(4);
1;
END
- 'Big-Dummy/t/compile.t' => <<'END',
-print "1..2\n";
+ 'Big-Dummy/test.pl' => <<'END',
+print "1..1\n";
+print "ok 1 - testing test.pl\n";
+END
+ 'Big-Dummy/t/compile.t' => <<'END',
+print "1..3\n";
print eval "use Big::Dummy; 1;" ? "ok 1\n" : "not ok 1\n";
print "ok 2 - TEST_VERBOSE\n";
+print "ok 3 - testing t/*.t\n";
END
'Big-Dummy/Liar/t/sanity.t' => <<'END',
print "1..3\n";
-
print eval "use Big::Dummy; 1;" ? "ok 1\n" : "not ok 1\n";
print eval "use Big::Liar; 1;" ? "ok 2\n" : "not ok 2\n";
print "ok 3 - TEST_VERBOSE\n";
);
+# if given args, those are inserted as components in resulting path, eg:
+# setup_recurs('dir') means instead of creating Big-Dummy/*, dir/Big-Dummy/*
sub setup_recurs {
-
while(my($file, $text) = each %Files) {
# Convert to a relative, native file path.
- $file = File::Spec->catfile(File::Spec->curdir, split m{\/}, $file);
+ $file = File::Spec->catfile(File::Spec->curdir, @_, split m{\/}, $file);
+ $file = File::Spec->rel2abs($file);
my $dir = dirname($file);
mkpath $dir;
+++ /dev/null
-package MakeMaker::Test::Setup::MPV;
-
-@ISA = qw(Exporter);
-require Exporter;
-@EXPORT = qw(setup_recurs teardown_recurs);
-
-use strict;
-use File::Path;
-use File::Basename;
-
-my %Files = (
- 'Min-PerlVers/Makefile.PL' => <<'END',
-use ExtUtils::MakeMaker;
-
-WriteMakefile(
- NAME => 'Min::PerlVers',
- AUTHOR => 'John Doe <jd@example.com>',
- VERSION_FROM => 'lib/Min/PerlVers.pm',
- PREREQ_PM => { strict => 0 },
- MIN_PERL_VERSION => '5.005',
-);
-END
-
- 'Min-PerlVers/lib/Min/PerlVers.pm' => <<'END',
-package Min::PerlVers;
-
-$VERSION = 0.05;
-
-=head1 NAME
-
-Min::PerlVers - being picky about perl versions
-
-=cut
-
-1;
-END
-
-);
-
-
-sub setup_recurs {
- while(my($file, $text) = each %Files) {
- # Convert to a relative, native file path.
- $file = File::Spec->catfile(File::Spec->curdir, split m{\/}, $file);
-
- my $dir = dirname($file);
- mkpath $dir;
- open(FILE, ">$file") || die "Can't create $file: $!";
- print FILE $text;
- close FILE;
- }
-
- return 1;
-}
-
-sub teardown_recurs {
- foreach my $file (keys %Files) {
- my $dir = dirname($file);
- if( -e $dir ) {
- rmtree($dir) || return;
- }
- }
- return 1;
-}
-
-
-1;
+++ /dev/null
-package MakeMaker::Test::Setup::PL_FILES;
-
-@ISA = qw(Exporter);
-require Exporter;
-@EXPORT = qw(setup teardown);
-
-use strict;
-use File::Path;
-use File::Basename;
-use File::Spec;
-use MakeMaker::Test::Utils;
-
-my %Files = (
- 'PL_FILES-Module/Makefile.PL' => <<'END',
-use ExtUtils::MakeMaker;
-
-# A module for testing PL_FILES
-WriteMakefile(
- NAME => 'PL_FILES::Module',
- PL_FILES => { 'single.PL' => 'single.out',
- 'multi.PL' => [qw(1.out 2.out)],
- 'Bar_pm.PL' => '$(INST_LIB)/PL/Bar.pm',
- }
-);
-END
-
- 'PL_FILES-Module/single.PL' => _gen_pl_files(),
- 'PL_FILES-Module/multi.PL' => _gen_pl_files(),
- 'PL_FILES-Module/Bar_pm.PL' => _gen_pm_files(),
- 'PL_FILES-Module/lib/PL/Foo.pm' => <<'END',
-# Module to load to ensure PL_FILES have blib in @INC.
-package PL::Foo;
-sub bar { 42 }
-1;
-END
-
-);
-
-
-sub _gen_pl_files {
- my $test = <<'END';
-#!/usr/bin/perl -w
-
-# Ensure we have blib in @INC
-use PL::Foo;
-die unless PL::Foo::bar() == 42;
-
-# Had a bug where PL_FILES weren't sent the file to generate
-die "argv empty\n" unless @ARGV;
-die "too many in argv: @ARGV\n" unless @ARGV == 1;
-
-my $file = $ARGV[0];
-open OUT, ">$file" or die $!;
-
-print OUT "Testing\n";
-close OUT
-END
-
- $test =~ s/^\n//;
-
- return $test;
-}
-
-
-sub _gen_pm_files {
- my $test = <<'END';
-#!/usr/bin/perl -w
-
-# Ensure we do NOT have blib in @INC when building a module
-eval { require PL::Foo; };
-#die $@ unless $@ =~ m{^Can't locate PL/Foo.pm in \@INC };
-
-# Had a bug where PL_FILES weren't sent the file to generate
-die "argv empty\n" unless @ARGV;
-die "too many in argv: @ARGV\n" unless @ARGV == 1;
-
-my $file = $ARGV[0];
-open OUT, ">$file" or die $!;
-
-print OUT "Testing\n";
-close OUT
-END
-
- $test =~ s/^\n//;
-
- return $test;
-}
-
-
-sub setup {
-
- while(my($file, $text) = each %Files) {
- # Convert to a relative, native file path.
- $file = File::Spec->catfile(File::Spec->curdir, split m{\/}, $file);
-
- my $dir = dirname($file);
- mkpath $dir;
- open(FILE, ">$file") || die "Can't create $file: $!";
- print FILE $text;
- close FILE;
-
- # ensure file at least 1 second old for makes that assume
- # files with the same time are out of date.
- my $time = calibrate_mtime();
- utime $time, $time - 1, $file;
- }
-
- return 1;
-}
-
-sub teardown {
- foreach my $file (keys %Files) {
- my $dir = dirname($file);
- if( -e $dir ) {
- rmtree($dir) || return;
- }
- }
- return 1;
-}
+++ /dev/null
-package MakeMaker::Test::Setup::Problem;
-
-@ISA = qw(Exporter);
-require Exporter;
-@EXPORT = qw(setup_recurs teardown_recurs);
-
-use strict;
-use File::Path;
-use File::Basename;
-use MakeMaker::Test::Utils;
-
-my %Files = (
- 'Problem-Module/Makefile.PL' => <<'END',
-use ExtUtils::MakeMaker;
-
-WriteMakefile(
- NAME => 'Problem::Module',
-);
-END
-
- 'Problem-Module/subdir/Makefile.PL' => <<'END',
-printf "\@INC %s .\n", (grep { $_ eq '.' } @INC) ? "has" : "doesn't have";
-
-warn "I think I'm going to be sick\n";
-die "YYYAaaaakkk\n";
-END
-
-);
-
-
-sub setup_recurs {
- while(my($file, $text) = each %Files) {
- # Convert to a relative, native file path.
- $file = File::Spec->catfile(File::Spec->curdir, split m{\/}, $file);
-
- my $dir = dirname($file);
- mkpath $dir;
- open(FILE, ">$file") || die "Can't create $file: $!";
- print FILE $text;
- close FILE;
-
- # ensure file at least 1 second old for makes that assume
- # files with the same time are out of date.
- my $time = calibrate_mtime();
- utime $time, $time - 1, $file;
- }
-
- return 1;
-}
-
-sub teardown_recurs {
- foreach my $file (keys %Files) {
- my $dir = dirname($file);
- if( -e $dir ) {
- rmtree($dir) || return;
- }
- }
- return 1;
-}
-
-
-1;
+++ /dev/null
-package MakeMaker::Test::Setup::Recurs;
-
-@ISA = qw(Exporter);
-require Exporter;
-@EXPORT = qw(setup_recurs teardown_recurs);
-
-use strict;
-use File::Path;
-use File::Basename;
-use MakeMaker::Test::Utils;
-
-my %Files = (
- 'Recurs/Makefile.PL' => <<'END',
-use ExtUtils::MakeMaker;
-
-WriteMakefile(
- NAME => 'Recurs',
- VERSION => 1.00,
-);
-END
-
- 'Recurs/prj2/Makefile.PL' => <<'END',
-use ExtUtils::MakeMaker;
-
-WriteMakefile(
- NAME => 'Recurs::prj2',
- VERSION => 1.00,
-);
-END
-
- # Check if a test failure in a subdir causes make test to fail
- 'Recurs/prj2/t/fail.t' => <<'END',
-#!/usr/bin/perl -w
-
-print "1..1\n";
-print "not ok 1\n";
-END
- );
-
-sub setup_recurs {
-
- while(my($file, $text) = each %Files) {
- # Convert to a relative, native file path.
- $file = File::Spec->catfile(File::Spec->curdir, split m{\/}, $file);
-
- my $dir = dirname($file);
- mkpath $dir;
- open(FILE, ">$file") || die "Can't create $file: $!";
- print FILE $text;
- close FILE;
-
- # ensure file at least 1 second old for makes that assume
- # files with the same time are out of date.
- my $time = calibrate_mtime();
- utime $time, $time - 1, $file;
- }
-
- return 1;
-}
-
-sub teardown_recurs {
- foreach my $file (keys %Files) {
- my $dir = dirname($file);
- if( -e $dir ) {
- rmtree($dir) || return;
- }
- }
- return 1;
-}
-
-
-1;
+++ /dev/null
-package MakeMaker::Test::Setup::SAS;
-
-@ISA = qw(Exporter);
-require Exporter;
-@EXPORT = qw(setup_recurs teardown_recurs);
-
-use strict;
-use File::Path;
-use File::Basename;
-
-our $dirname='Multiple-Authors';
-my %Files = (
- $dirname.'/Makefile.PL' => <<'END',
-use ExtUtils::MakeMaker;
-
-WriteMakefile(
- NAME => 'Multiple::Authors',
- AUTHOR => ['John Doe <jd@example.com>', 'Jane Doe <jd@example.com>'],
- VERSION_FROM => 'lib/Multiple/Authors.pm',
- PREREQ_PM => { strict => 0 },
-);
-END
-
- $dirname.'/lib/Multiple/Authors.pm' => <<'END',
-package Multiple::Authors;
-
-$VERSION = 0.05;
-
-=head1 NAME
-
-Multiple::Authors - several authors
-
-=cut
-
-1;
-END
-
-);
-
-
-sub setup_recurs {
- while(my($file, $text) = each %Files) {
- # Convert to a relative, native file path.
- $file = File::Spec->catfile(File::Spec->curdir, split m{\/}, $file);
-
- my $dir = dirname($file);
- mkpath $dir;
- open(FILE, ">$file") || die "Can't create $file: $!";
- print FILE $text;
- close FILE;
- }
-
- return 1;
-}
-
-sub teardown_recurs {
- foreach my $file (keys %Files) {
- my $dir = dirname($file);
- if( -e $dir ) {
- rmtree($dir) || return;
- }
- }
- return 1;
-}
-
-
-1;
+++ /dev/null
-package MakeMaker::Test::Setup::Unicode;
-
-@ISA = qw(Exporter);
-require Exporter;
-@EXPORT = qw(setup_recurs teardown_recurs);
-
-use strict;
-use File::Path;
-use File::Basename;
-use MakeMaker::Test::Utils;
-use utf8;
-use Config;
-
-my %Files = (
- 'Problem-Module/Makefile.PL' => <<'PL_END',
-use ExtUtils::MakeMaker;
-use utf8;
-
-WriteMakefile(
- NAME => 'Problem::Module',
- ABSTRACT_FROM => 'lib/Problem/Module.pm',
- AUTHOR => q{Danijel Tašov},
- EXE_FILES => [ qw(bin/probscript) ],
- INSTALLMAN1DIR => "some", # even if disabled in $Config{man1dir}
- MAN1EXT => 1, # set to 0 if man pages disabled
-);
-PL_END
-
- 'Problem-Module/lib/Problem/Module.pm' => <<'pm_END',
-use utf8;
-
-=pod
-
-=encoding utf8
-
-=head1 NAME
-
-Problem::Module - Danijel Tašov's great new module
-
-=cut
-
-1;
-pm_END
-
- 'Problem-Module/bin/probscript' => <<'pl_END',
-#!/usr/bin/perl
-use utf8;
-
-=encoding utf8
-
-=head1 NAME
-
-文档 - Problem script
-pl_END
-);
-
-
-sub setup_recurs {
- while(my($file, $text) = each %Files) {
- # Convert to a relative, native file path.
- $file = File::Spec->catfile(File::Spec->curdir, split m{\/}, $file);
-
- my $dir = dirname($file);
- mkpath $dir;
- my $utf8 = ($] < 5.008 or !$Config{useperlio}) ? "" : ":utf8";
- open(FILE, ">$utf8", $file) || die "Can't create $file: $!";
- print FILE $text;
- close FILE;
-
- # ensure file at least 1 second old for makes that assume
- # files with the same time are out of date.
- my $time = calibrate_mtime();
- utime $time, $time - 1, $file;
- }
-
- return 1;
-}
-
-sub teardown_recurs {
- foreach my $file (keys %Files) {
- my $dir = dirname($file);
- if( -e $dir ) {
- rmtree($dir) || return;
- }
- }
- return 1;
-}
-
-
-1;
@ISA = qw(Exporter);
require Exporter;
-@EXPORT = qw(setup_xs teardown_xs);
+@EXPORT = qw(run_tests list_dynamic list_static);
use strict;
use File::Path;
-use File::Basename;
use MakeMaker::Test::Utils;
use Config;
+use Carp qw(croak);
+use Test::More;
+use File::Spec;
+use File::Temp qw[tempdir];
+use Cwd;
use ExtUtils::MM;
+# this is to avoid MM->new overwriting _eumm in top dir
+my $tempdir = tempdir(DIR => getcwd, CLEANUP => 1);
+chdir $tempdir;
my $typemap = 'type map';
-$typemap =~ s/ //g unless MM->new({NAME=>'name'})->can_dep_space;
+$typemap =~ s/ //g unless MM->new({NAME=>'name', NORECURS=>1})->can_dep_space;
+chdir File::Spec->updir;
-my %Files = (
- 'XS-Test/lib/XS/Test.pm' => <<'END',
+my $PM_TEST = <<'END';
package XS::Test;
-
require Exporter;
require DynaLoader;
-
$VERSION = 1.01;
@ISA = qw(Exporter DynaLoader);
@EXPORT = qw(is_even);
-
bootstrap XS::Test $VERSION;
-
1;
END
- 'XS-Test/Makefile.PL' => <<END,
-use ExtUtils::MakeMaker;
+my $XS_TEST = <<'END';
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+MODULE = XS::Test PACKAGE = XS::Test
+PROTOTYPES: DISABLE
+int
+is_even(input)
+ int input
+ CODE:
+ RETVAL = (input % 2 == 0);
+ OUTPUT:
+ RETVAL
+END
+my $T_TEST = <<'END';
+#!/usr/bin/perl -w
+use Test::More tests => 3;
+use_ok "XS::Test";
+ok !is_even(1);
+ok is_even(2);
+END
+
+my $MAKEFILEPL = <<'END';
+use ExtUtils::MakeMaker;
WriteMakefile(
- NAME => 'XS::Test',
- VERSION_FROM => 'lib/XS/Test.pm',
- TYPEMAPS => [ '$typemap' ],
- PERL => "\$^X -w",
+ NAME => 'XS::%s',
+ VERSION_FROM => '%s',
+ TYPEMAPS => [ %s ],
+ PERL => "$^X -w",
+ %s
);
END
- "XS-Test/$typemap" => '',
+my $BS_TEST = '$DynaLoader::bscode = q(warn "BIG NOISE";)';
+
+my $T_BOOTSTRAP = <<'EOF';
+use Test::More tests => 1;
+my $w = '';
+$SIG{__WARN__} = sub { $w .= join '', @_; };
+require XS::Test;
+like $w, qr/NOISE/;
+EOF
+
+my $PM_OTHER = <<'END';
+package XS::Other;
+require Exporter;
+require DynaLoader;
+$VERSION = 1.20;
+@ISA = qw(Exporter DynaLoader);
+@EXPORT = qw(is_odd);
+bootstrap XS::Other $VERSION;
+1;
+END
- 'XS-Test/Test.xs' => <<'END',
+my $XS_OTHER = <<'END';
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
-
-MODULE = XS::Test PACKAGE = XS::Test
-
+MODULE = XS::Other PACKAGE = XS::Other
PROTOTYPES: DISABLE
-
int
-is_even(input)
+is_odd(input)
int input
CODE:
- RETVAL = (input % 2 == 0);
+ RETVAL = (INVAR % 2 == 1);
OUTPUT:
RETVAL
END
- 'XS-Test/t/is_even.t' => <<'END',
+my $T_OTHER = <<'END';
#!/usr/bin/perl -w
-
use Test::More tests => 3;
+use_ok "XS::Other";
+ok is_odd(1);
+ok !is_odd(2);
+END
-use_ok "XS::Test";
-ok !is_even(1);
-ok is_even(2);
+my $PLUS1_C = <<'EOF';
+#ifdef __cplusplus
+extern "C" {
+int plus1(int i)
+#else
+int plus1(i)
+int i;
+#endif
+{ return i + 1; }
+#ifdef __cplusplus
+}
+#endif
+EOF
+
+my %Files = (
+ 'lib/XS/Test.pm' => $PM_TEST,
+ $typemap => '',
+ 'Test.xs' => $XS_TEST,
+ 't/is_even.t' => $T_TEST,
+ 'Makefile.PL' => sprintf($MAKEFILEPL, 'Test', 'lib/XS/Test.pm', qq{'$typemap'}, ''),
+);
+
+my %label2files = (basic => \%Files);
+
+$label2files{bscode} = +{
+ %{ $label2files{'basic'} }, # make copy
+ 'Test_BS' => $BS_TEST,
+ 't/bs.t' => $T_BOOTSTRAP,
+};
+delete $label2files{bscode}->{'t/is_even.t'};
+
+$label2files{static} = +{
+ %{ $label2files{'basic'} }, # make copy
+ 'Makefile.PL' => sprintf(
+ $MAKEFILEPL, 'Test', 'lib/XS/Test.pm', qq{'$typemap'},
+ q{LINKTYPE => 'static'},
+ ),
+};
+
+$label2files{subdirs} = +{
+ %{ $label2files{'basic'} }, # make copy
+ 'Makefile.PL' => sprintf(
+ $MAKEFILEPL, 'Test', 'Test.pm', qq{'$typemap'},
+ q{DEFINE => '-DINVAR=input', INC => "-Inewline\n", LIBS => "-Lnewline\n",},
+ ),
+ 'Other/Makefile.PL' => sprintf($MAKEFILEPL, 'Other', 'Other.pm', qq{}, ''),
+ 'Other/Other.pm' => $PM_OTHER,
+ 'Other/Other.xs' => $XS_OTHER,
+ 't/is_odd.t' => $T_OTHER,
+};
+virtual_rename('subdirs', 'lib/XS/Test.pm', 'Test.pm');
+
+# to mimic behaviour of Unicode-LineBreak version 2015.07.16
+$label2files{subdirscomplex} = +{
+ %{ $label2files{'subdirs'} }, # make copy
+ 'Other/Makefile.PL' => sprintf(
+ $MAKEFILEPL,
+ 'Other', 'Other.pm', qq{},
+ <<'EOF',
+C => [qw(lib$(DIRFILESEP)file.c)],
+OBJECT => 'lib$(DIRFILESEP)file$(OBJ_EXT)',
+EOF
+ ) . <<'EOF',
+sub MY::c_o {
+ package MY;
+ my $self = shift;
+ my $inherited = $self->SUPER::c_o(@_);
+ $inherited =~ s{(:\n\t)(.*(?:\n\t.*)*)}
+ { $1 . $self->cd('lib', split /(?<!\\)\n\t/, $2) }eg;
+ $inherited =~ s{(\s)(\$\*\.c\s)}
+ { "$1..\$(DIRFILESEP)$2" }eg;
+ $inherited;
+}
+
+sub MY::top_targets {
+ <<'SNIP';
+all :: lib$(DIRFILESEP)file$(OBJ_EXT)
+ $(NOECHO) $(NOOP)
+
+config ::
+ $(NOECHO) $(NOOP)
+
+pure_all ::
+ $(NOECHO) $(NOOP)
+SNIP
+}
+EOF
+ 'Other/lib/file.c' => $PLUS1_C,
+};
+delete $label2files{subdirscomplex}{'Other/Other.xs'};
+delete $label2files{subdirscomplex}{'t/is_odd.t'};
+
+$label2files{subdirsstatic} = +{
+ %{ $label2files{'subdirs'} }, # make copy
+ 'Makefile.PL' => sprintf(
+ $MAKEFILEPL, 'Test', 'Test.pm', qq{'$typemap'},
+ q{DEFINE => '-DINVAR=input', LINKTYPE => 'static',},
+ ),
+};
+
+my $XS_MULTI = $XS_OTHER;
+# check compiling from top dir still can include local
+$XS_MULTI =~ s:(#include "XSUB.h"):$1\n#include "header.h":;
+$label2files{multi} = +{
+ %{ $label2files{'basic'} }, # make copy
+ 'Makefile.PL' => sprintf(
+ $MAKEFILEPL, 'Test', 'lib/XS/Test.pm', qq{'lib/XS/$typemap'},
+ q{XSMULTI => 1,},
+ ),
+ 'lib/XS/Other.pm' => $PM_OTHER,
+ 'lib/XS/Other.xs' => $XS_MULTI,
+ 't/is_odd.t' => $T_OTHER,
+ 'lib/XS/header.h' => "#define INVAR input\n",
+};
+virtual_rename('multi', $typemap, "lib/XS/$typemap");
+virtual_rename('multi', 'Test.xs', 'lib/XS/Test.xs');
+
+$label2files{bscodemulti} = +{
+ %{ $label2files{'multi'} }, # make copy
+ 'lib/XS/Test_BS' => $BS_TEST,
+ 't/bs.t' => $T_BOOTSTRAP,
+};
+delete $label2files{bscodemulti}->{'t/is_even.t'};
+delete $label2files{bscodemulti}->{'t/is_odd.t'};
+
+$label2files{staticmulti} = +{
+ %{ $label2files{'multi'} }, # make copy
+ 'Makefile.PL' => sprintf(
+ $MAKEFILEPL, 'Test', 'lib/XS/Test.pm', qq{'$typemap'},
+ q{LINKTYPE => 'static', XSMULTI => 1,},
+ ),
+};
+
+$label2files{xsbuild} = +{
+ %{ $label2files{'multi'} }, # make copy
+ 'Makefile.PL' => sprintf(
+ $MAKEFILEPL, 'Test', 'lib/XS/Test.pm', qq{'$typemap'},
+ q{
+ XSMULTI => 1,
+ XSBUILD => {
+ xs => {
+ 'lib/XS/Other' => {
+ DEFINE => '-DINVAR=input',
+ OBJECT => 'lib/XS/Other$(OBJ_EXT) lib/XS/plus1$(OBJ_EXT)'
+ }
+ },
+ },
+ },
+ ),
+
+ 'lib/XS/Other.xs' => <<EOF,
+#ifdef __cplusplus
+extern "C" {
+#endif
+int plus1(int);
+#ifdef __cplusplus
+}
+#endif
+$XS_OTHER
+int
+plus1(input)
+ int input
+ CODE:
+ RETVAL = plus1(INVAR);
+ OUTPUT:
+ RETVAL
+EOF
+
+ 'lib/XS/plus1.c' => $PLUS1_C,
+
+ 't/is_odd.t' => <<'END',
+#!/usr/bin/perl -w
+use Test::More tests => 4;
+use_ok "XS::Other";
+ok is_odd(1);
+ok !is_odd(2);
+is XS::Other::plus1(3), 4;
END
- );
+};
+
+sub virtual_rename {
+ my ($label, $oldfile, $newfile) = @_;
+ $label2files{$label}->{$newfile} = delete $label2files{$label}->{$oldfile};
+}
sub setup_xs {
+ my ($label, $sublabel) = @_;
+ croak "Must supply label" unless defined $label;
+ my $files = $label2files{$label};
+ croak "Must supply valid label" unless defined $files;
+ croak "Must supply sublabel" unless defined $sublabel;
+ my $prefix = "XS-Test$label$sublabel";
+ hash2files($prefix, $files);
+ return $prefix;
+}
+
+sub list_static {
+ (
+ ( !$Config{usedl} ? [ 'basic', '', '' ] : ()), # still needs testing on static perl
+ [ 'static', '', '' ],
+ [ 'basic', ' static', '_static' ],
+ [ 'multi', ' static', '_static' ],
+ [ 'subdirs', ' LINKTYPE=static', ' LINKTYPE=static' ],
+ [ 'subdirsstatic', '', '' ],
+ [ 'staticmulti', '', '' ],
+ );
+}
+
+sub list_dynamic {
+ (
+ [ 'basic', '', '' ],
+ $^O ne 'MSWin32' ? (
+ [ 'bscode', '', '' ],
+ [ 'bscodemulti', '', '' ],
+ [ 'subdirscomplex', '', '' ],
+ ) : (), # DynaLoader different
+ [ 'subdirs', '', '' ],
+ [ 'subdirsstatic', ' LINKTYPE=dynamic', ' LINKTYPE=dynamic' ],
+ [ 'subdirsstatic', ' dynamic', '_dynamic' ],
+ [ 'multi', '', '' ],
+ [ 'staticmulti', ' LINKTYPE=dynamic', ' LINKTYPE=dynamic' ],
+ [ 'staticmulti', ' dynamic', '_dynamic' ],
+ [ 'xsbuild', '', '' ],
+ );
+}
- while(my($file, $text) = each %Files) {
- # Convert to a relative, native file path.
- $file = File::Spec->catfile(File::Spec->curdir, split m{\/}, $file);
+sub run_tests {
+ my ($perl, $label, $add_target, $add_testtarget) = @_;
+ my $sublabel = $add_target;
+ $sublabel =~ s#[\s=]##g;
+ ok( my $dir = setup_xs($label, $sublabel), "setup $label$sublabel" );
- my $dir = dirname($file);
- mkpath $dir;
- open(FILE, ">$file") || die "Can't create $file: $!";
- print FILE $text;
- close FILE;
+ ok( chdir($dir), "chdir'd to $dir" ) || diag("chdir failed: $!");
+
+ my @mpl_out = run(qq{$perl Makefile.PL});
+ SKIP: {
+ unless (cmp_ok( $?, '==', 0, 'Makefile.PL exited with zero' )) {
+ diag(@mpl_out);
+ skip 'perl Makefile.PL failed', 2;
}
- return 1;
-}
+ my $make = make_run();
+ my $target = '';
+ my %macros = ();
+ if (defined($add_target)) {
+ if ($add_target =~ m/(\S+)=(\S+)/) {
+ $macros{$1} = $2;
+ }
+ else {
+ $target = $add_target;
+ }
+ }
+ my $make_cmd = make_macro($make, $target, %macros);
+ my $make_out = run($make_cmd);
+ unless (is( $?, 0, "$make_cmd exited normally" )) {
+ diag $make_out;
+ skip 'Make failed - skipping test', 1;
+ }
-sub teardown_xs {
- foreach my $file (keys %Files) {
- my $dir = dirname($file);
- if( -e $dir ) {
- rmtree($dir) || return;
+ $target = 'test';
+ %macros = ();
+ if (defined($add_testtarget) && length($add_testtarget)) {
+ if ($add_testtarget =~ m/(\S+)=(\S+)/) {
+ $macros{$1} = $2;
+ }
+ else {
+ # an underscore prefix means combine, e.g. 'test' + '_dynamic'
+ unless ($add_testtarget =~ m/^_/) {
+ $target .= ($make =~ m/^MM(K|S)/i) ? ',' : ' ';
+ }
+ $target .= $add_testtarget;
}
}
- return 1;
+ my $test_cmd = make_macro($make, $target, %macros);
+ my $test_out = run($test_cmd);
+ is( $?, 0, "$test_cmd exited normally" ) || diag "$make_out\n$test_out";
+ }
+
+ chdir File::Spec->updir or die;
+ ok rmtree($dir), "teardown $dir";
}
1;
use File::Spec;
use strict;
use Config;
+use Cwd qw(getcwd);
+use Carp qw(croak);
+use File::Path;
+use File::Basename;
require Exporter;
our @ISA = qw(Exporter);
have_compiler slurp
$Is_VMS $Is_MacOS
run_ok
+ hash2files
+ in_dir
);
my $old5lib = $ENV{PERL5LIB};
my $had5lib = exists $ENV{PERL5LIB};
sub perl_lib {
+ my $basecwd = (File::Spec->splitdir(getcwd))[-1];
+ croak "Basename of cwd needs to be 't' but is '$basecwd'\n"
+ unless $basecwd eq 't';
# perl-src/t/
my $lib = $ENV{PERL_CORE} ? qq{../lib}
# ExtUtils-MakeMaker/t/
my $is_mms = $make =~ /^MM(K|S)/i;
- my $cmd = $make;
- my $macros = '';
+ my @macros;
while( my($key,$val) = splice(@_, 0, 2) ) {
- if( $is_mms ) {
- $macros .= qq{/macro="$key=$val"};
+ push @macros, qq{$key=$val};
+ }
+ my $macros = '';
+ if (scalar(@macros)) {
+ if ($is_mms) {
+ map { $_ = qq{"$_"} } @macros;
+ $macros = '/MACRO=(' . join(',', @macros) . ')';
}
else {
- $macros .= qq{ $key=$val};
+ $macros = join(' ', @macros);
}
}
=cut
sub calibrate_mtime {
- open(FILE, ">calibrate_mtime.tmp") || die $!;
+ my $file = "calibrate_mtime-$$.tmp";
+ open(FILE, ">$file") || die $!;
print FILE "foo";
close FILE;
- my($mtime) = (stat('calibrate_mtime.tmp'))[9];
- unlink 'calibrate_mtime.tmp';
+ my($mtime) = (stat($file))[9];
+ unlink $file;
return $mtime;
}
sub have_compiler {
my $have_compiler = 0;
-
- # ExtUtils::CBuilder prints its compilation lines to the screen.
- # Shut it up.
- use TieOut;
- local *STDOUT = *STDOUT;
- local *STDERR = *STDERR;
-
- tie *STDOUT, 'TieOut';
- tie *STDERR, 'TieOut';
-
eval {
- require ExtUtils::CBuilder;
- my $cb = ExtUtils::CBuilder->new;
-
- $have_compiler = $cb->have_compiler;
+ require ExtUtils::CBuilder;
+ my $cb = ExtUtils::CBuilder->new(quiet=>1);
+ $have_compiler = $cb->have_compiler;
};
-
return $have_compiler;
}
return $text;
}
+=item hash2files
+
+ hash2files('dirname', { 'filename' => 'some content' });
+
+Goes through given hash-ref, treating each key as a /-separated filename
+under the specified directory, and writing the value into it. Will create
+any necessary directories.
+
+Will die if errors occur.
+
+=cut
+
+sub hash2files {
+ my ($prefix, $hashref) = @_;
+ while(my ($file, $text) = each %$hashref) {
+ # Convert to a relative, native file path.
+ $file = File::Spec->catfile(File::Spec->curdir, $prefix, split m{\/}, $file);
+ my $dir = dirname($file);
+ mkpath $dir;
+ my $utf8 = ($] < 5.008 or !$Config{useperlio}) ? "" : ":utf8";
+ open(FILE, ">$utf8", $file) || die "Can't create $file: $!";
+ print FILE $text;
+ close FILE;
+ # ensure file at least 1 second old for makes that assume
+ # files with the same time are out of date.
+ my $time = calibrate_mtime();
+ utime $time, $time - 1, $file;
+ }
+}
+
+=item in_dir
+
+ $retval = in_dir(\&coderef);
+ $retval = in_dir(\&coderef, $specified_dir);
+ $retval = in_dir { somecode(); };
+ $retval = in_dir { somecode(); } $specified_dir;
+
+Does a C<chdir> to either a directory. If none is specified, one is
+created with L<File::Temp> and then automatically deleted after. It ends
+by C<chdir>ing back to where it started.
+
+If the given code throws an exception, it will be re-thrown after the
+re-C<chdir>.
+
+Returns the return value of the given code.
+
+=cut
+
+sub in_dir(&;$) {
+ my $code = shift;
+ require File::Temp;
+ my $dir = shift || File::Temp::tempdir(TMPDIR => 1, CLEANUP => 1);
+ # chdir to the new directory
+ my $orig_dir = getcwd();
+ chdir $dir or die "Can't chdir to $dir: $!";
+ # Run the code, but trap the error so we can chdir back
+ my $return;
+ my $ok = eval { $return = $code->(); 1; };
+ my $err = $@;
+ # chdir back
+ chdir $orig_dir or die "Can't chdir to $orig_dir: $!";
+ # rethrow if necessary
+ die $err unless $ok;
+ return $return;
+}
+
=back
=head1 AUTHOR
-BEGIN {
- chdir '..' if -d '../t';
- unshift @INC, 't/lib';
- use lib 'lib';
-}
+#!perl -w
use strict;
use warnings;
-use Test::More 'no_plan';
+BEGIN { unshift @INC, 't/lib'; }
+use Test::More eval { require CPAN::Meta; CPAN::Meta->VERSION(2.143240) } ? ()
+ : (skip_all => 'CPAN::Meta 2.143240 required for this test');
+use File::Temp qw[tempdir];
require ExtUtils::MM_Any;
-sub ExtUtils::MM_Any::quote_literal { $_[1] }
-
-my $new_mm = sub {
- return bless { ARGS => {@_}, @_ }, 'ExtUtils::MM_Any';
-};
+my $tmpdir = tempdir( DIR => 't', CLEANUP => 1 );
+use Cwd; my $cwd = getcwd; END { chdir $cwd } # so File::Temp can cleanup
+chdir $tmpdir or die "chdir $tmpdir: $!";
+
+my $EMPTY = qr/['"]?version['"]?\s*:\s*['"]['"]/;
+my @DATA = (
+ [
+ [ DISTNAME => 'Net::FTP::Recursive', VERSION => 'Recursive.pm', ],
+ qr{Can't parse version 'Recursive.pm'},
+ 'VERSION => filename',
+ $EMPTY,
+ ],
+ [
+ [ DISTNAME => 'Image::Imgur', VERSION => 'undef', ],
+ qr{Can't parse version 'undef'},
+ 'no $VERSION in file -> VERSION=>"undef"',
+ $EMPTY,
+ ],
+ [
+ [ DISTNAME => 'SQL::Library', VERSION => 0.0.3, ],
+ qr{Can't parse version '\x00\x00\x03'},
+ "x.y.z version",
+ $EMPTY,
+ ],
+ [
+ [ DISTNAME => 'Array::Suffix', VERSION => '.5', ],
+ qr{Can't parse version '.5'},
+ ".5 version",
+ $EMPTY,
+ ],
+ [
+ [
+ DISTNAME => 'Attribute::Signature',
+ META_MERGE => {
+ resources => {
+ repository => 'http://github.com/chorny/Attribute-Signature',
+ 'Repository-clone' => 'git://github.com/chorny/Attribute-Signature.git',
+ },
+ },
+ ],
+ qr/^$/,
+ "Non-camel case metadata",
+ qr/x_Repositoryclone/,
+ ],
+ [
+ [
+ DISTNAME => 'CPAN::Testers::ParseReport',
+ VERSION => '2.34',
+ META_ADD => {
+ provides => {
+ "CPAN::Testers::ParseReport" => {
+ version => version->new("v1.2.3"),
+ file => "lib/CPAN/Testers/ParseReport.pm"
+ }
+ }
+ },
+ ],
+ qr/^$/,
+ "version object in provides",
+ qr/['"]?version['"]?\s*:\s*['"]v1\.2\.3['"]/,
+ ],
+ [
+ [
+ DISTNAME => 'Bad::License',
+ VERSION => '2.34',
+ LICENSE => 'death and retribution',
+ ],
+ qr/Invalid LICENSE value/,
+ "Bad licence warns",
+ qr/['"]?version['"]?\s*:\s*['"]2\.34['"]/,
+ ],
+);
+
+plan tests => 3 * @DATA;
+run_test(@$_) for @DATA;
-my $warn_ok = sub {
- my($code, $want, $name) = @_;
+sub ExtUtils::MM_Any::quote_literal { $_[1] }
- my @have;
+sub run_test {
+ my ($mmargs, $expected, $label, $metadata_re) = @_;
+ my $mm = bless { ARGS => {@$mmargs}, @$mmargs }, 'ExtUtils::MM_Any';
+ my @warnings;
my $ret;
{
- local $SIG{__WARN__} = sub { push @have, @_ };
- $ret = $code->();
+ local $SIG{__WARN__} = sub { push @warnings, @_ };
+ eval { $ret = $mm->metafile_target; };
+ }
+ SKIP: {
+ if ($@) {
+ diag $@;
+ skip "$label got exception", 3 if $@;
+ }
+ ok 1, "$label metafile_target";
+ like join("", @warnings), $expected, "$label right warning";
+ like $ret, $metadata_re, "$label metadata";
}
-
- like join("", @have), $want, $name;
- return $ret;
-};
-
-my $version_regex = qr/version: ''/;
-my $version_action = "they're converted to empty string";
-
-
-note "Filename as version"; {
- my $mm = $new_mm->(
- DISTNAME => 'Net::FTP::Recursive',
- VERSION => 'Recursive.pm',
- );
-
- my $res = $warn_ok->(
- sub { eval { $mm->metafile_target } },
- qr{Can't parse version 'Recursive.pm'}
- );
- ok $res, 'we know how to deal with bogus versions defined in Makefile.PL';
- like $res, $version_regex, $version_action;
-}
-
-
-note "'undef' version from parse_version"; {
- my $mm = $new_mm->(
- DISTNAME => 'Image::Imgur',
- VERSION => 'undef',
- );
- my $res = $warn_ok->(
- sub { eval { $mm->metafile_target } },
- qr{Can't parse version 'undef'}
- );
- ok $res, q|when there's no $VERSION in Module.pm, $self->{VERSION} = 'undef'; via MM_Unix::parse_version and we know how to deal with that|;
- like $res, $version_regex, $version_action;
-}
-
-
-note "x.y.z version"; {
- my $mm = $new_mm->(
- DISTNAME => 'SQL::Library',
- VERSION => 0.0.3,
- );
-
- # It would be more useful if the warning got translated to visible characters
- my $res = $warn_ok->(
- sub { eval { $mm->metafile_target } },
- qr{Can't parse version '\x00\x00\x03'}
- );
- ok $res, q|we know how to deal with our $VERSION = 0.0.3; style versions defined in the module|;
- like $res, $version_regex, $version_action;
-}
-
-
-note ".5 version"; {
- my $mm = $new_mm->(
- DISTNAME => 'Array::Suffix',
- VERSION => '.5',
- );
- my $res = $warn_ok->(
- sub { eval { $mm->metafile_target } },
- qr{Can't parse version '.5'}
- );
- ok $res, q|we know how to deal with our $VERSION = '.5'; style versions defined in the module|;
- like $res, $version_regex, $version_action;
-}
-
-
-note "Non-camel case metadata"; {
- my $mm = $new_mm->(
- DISTNAME => 'Attribute::Signature',
- META_MERGE => {
- resources => {
- repository => 'http://github.com/chorny/Attribute-Signature',
- 'Repository-clone' => 'git://github.com/chorny/Attribute-Signature.git',
- },
- },
- );
- my $res = eval { $mm->metafile_target };
- ok $res, q|we know how to deal with non-camel-cased custom meta resource keys defined in Makefile.PL|;
- like $res, qr/x_Repositoryclone/, "they're camel-cased";
-}
-
-
-note "version object in provides"; {
- my $mm = $new_mm->(
- DISTNAME => 'CPAN::Testers::ParseReport',
- VERSION => '2.34',
- META_ADD => {
- provides => {
- "CPAN::Testers::ParseReport" => {
- version => version->new("v1.2.3"),
- file => "lib/CPAN/Testers/ParseReport.pm"
- }
- }
- },
- );
- my $res = eval { $mm->metafile_target };
- like $res, qr{version: \s* v1.2.3}x;
}
}
use strict;
-use Test::More tests => 31;
-
+use Test::More;
+BEGIN {
+ eval { require CPAN::Meta; CPAN::Meta->VERSION(2.143240) }
+ or plan skip_all => 'CPAN::Meta 2.143240 required for this test';
+ eval { require CPAN::Meta::Converter; }
+ or plan skip_all => 'CPAN::Meta::Converter required for this test';
+ eval { require Parse::CPAN::Meta; }
+ or plan skip_all => 'Parse::CPAN::Meta required for this test';
+}
use Data::Dumper;
use File::Temp;
use Cwd;
-use Parse::CPAN::Meta;
+use MakeMaker::Test::Utils;
+plan tests => 31;
require ExtUtils::MM_Any;
-sub in_dir(&;$) {
- my $code = shift;
- my $dir = shift || File::Temp->newdir;
-
- # chdir to the new directory
- my $orig_dir = cwd();
- chdir $dir or die "Can't chdir to $dir: $!";
-
- # Run the code, but trap the error so we can chdir back
- my $return;
- my $ok = eval { $return = $code->(); 1; };
- my $err = $@;
-
- # chdir back
- chdir $orig_dir or die "Can't chdir to $orig_dir: $!";
-
- # rethrow if necessary
- die $err unless $ok;
-
- return $return;
-}
-
sub mymeta_ok {
my($have, $want, $name) = @_;
-
local $Test::Builder::Level = $Test::Builder::Level + 1;
-
my $have_gen = delete $have->{generated_by};
my $want_gen = delete $want->{generated_by};
my $have_url = delete $have->{'meta-spec'}->{url};
my $want_url = delete $want->{'meta-spec'}->{url};
-
is_deeply $have, $want, $name;
like $have_gen, qr{CPAN::Meta}, "CPAN::Meta mentioned in the generated_by";
like $have_url, qr{CPAN::Meta::Spec}, "CPAN::Meta::Spec mentioned in meta-spec URL";
-
return;
}
my $new_mm = sub {
return bless { ARGS => {@_}, @_ }, 'ExtUtils::MM_Any';
};
+my @METASPEC14 = (
+ 'meta-spec' => {
+ url => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
+ version => 1.4
+ },
+);
+my @METASPEC20 = (
+ 'meta-spec' => {
+ url => 'https://metacpan.org/pod/CPAN::Meta::Spec',
+ version => 2
+ },
+);
+my @REQ20 = (
+ configure => { requires => { 'ExtUtils::MakeMaker' => 0, }, },
+ build => { requires => { 'ExtUtils::MakeMaker' => 0, }, },
+);
+my @GENERIC_IN = (
+ DISTNAME => 'Foo-Bar',
+ VERSION => 1.23,
+ PM => { "Foo::Bar" => 'lib/Foo/Bar.pm', },
+);
+my @GENERIC_OUT = (
+ # mandatory
+ abstract => 'unknown',
+ author => [qw(unknown)],
+ dynamic_config => 1,
+ generated_by => "ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION",
+ license => ['unknown'],
+ @METASPEC20,
+ name => 'Foo-Bar',
+ release_status => 'stable',
+ version => 1.23,
+ # optional
+ no_index => { directory => [qw(t inc)], },
+);
{
- my $mm = $new_mm->(
- DISTNAME => 'Foo-Bar',
- VERSION => 1.23,
- PM => {
- "Foo::Bar" => 'lib/Foo/Bar.pm',
- },
- );
-
- is_deeply {$mm->metafile_data}, {
- name => 'Foo-Bar',
- version => 1.23,
- abstract => 'unknown',
- author => [],
- license => 'unknown',
- dynamic_config => 1,
- distribution_type => 'module',
-
- configure_requires => {
- 'ExtUtils::MakeMaker' => 0,
- },
- build_requires => {
- 'ExtUtils::MakeMaker' => 0,
- },
-
- no_index => {
- directory => [qw(t inc)],
- },
-
- generated_by => "ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION",
- 'meta-spec' => {
- url => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
- version => 1.4
- },
+ my $mm = $new_mm->(@GENERIC_IN);
+ is_deeply $mm->metafile_data, {
+ @GENERIC_OUT,
+ prereqs => { @REQ20, },
};
-
-
- is_deeply {$mm->metafile_data({}, { no_index => { directory => [qw(foo)] } })}, {
- name => 'Foo-Bar',
- version => 1.23,
- abstract => 'unknown',
- author => [],
- license => 'unknown',
- dynamic_config => 1,
- distribution_type => 'module',
-
- configure_requires => {
- 'ExtUtils::MakeMaker' => 0,
- },
- build_requires => {
- 'ExtUtils::MakeMaker' => 0,
- },
-
- no_index => {
- directory => [qw(t inc foo)],
- },
-
- generated_by => "ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION",
- 'meta-spec' => {
- url => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
- version => 1.4
- },
+ is_deeply $mm->metafile_data({}, { no_index => { directory => [qw(foo)] } }), {
+ @GENERIC_OUT,
+ prereqs => { @REQ20, },
+ no_index => { directory => [qw(t inc foo)], },
}, 'rt.cpan.org 39348';
}
-
{
my $mm = $new_mm->(
DISTNAME => 'Foo-Bar',
VERSION => 1.23,
AUTHOR => ['Some Guy'],
- PREREQ_PM => {
- Foo => 2.34,
- Bar => 4.56,
- },
+ PREREQ_PM => { Foo => 2.34, Bar => 4.56, },
);
-
- is_deeply {$mm->metafile_data(
+ is_deeply $mm->metafile_data(
{
- configure_requires => {
- Stuff => 2.34
- },
+ configure_requires => { Stuff => 2.34 },
wobble => 42
},
{
- no_index => {
- package => "Thing"
- },
+ no_index => { package => "Thing" },
wibble => 23
},
- )},
+ ),
{
- name => 'Foo-Bar',
- version => 1.23,
- abstract => 'unknown',
+ @GENERIC_OUT, # some overridden, which is fine
author => ['Some Guy'],
- license => 'unknown',
- dynamic_config => 1,
- distribution_type => 'script',
-
- configure_requires => {
- Stuff => 2.34,
- },
- build_requires => {
- 'ExtUtils::MakeMaker' => 0,
- },
-
- requires => {
- Foo => 2.34,
- Bar => 4.56,
+ prereqs => {
+ @REQ20,
+ configure => { requires => { Stuff => 2.34, }, },
+ runtime => { requires => { Foo => 2.34, Bar => 4.56, }, },
},
-
no_index => {
directory => [qw(t inc)],
- package => 'Thing',
+ package => ['Thing'],
},
-
- generated_by => "ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION",
- 'meta-spec' => {
- url => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
- version => 1.4
- },
-
- wibble => 23,
- wobble => 42,
- };
+ x_wibble => 23,
+ x_wobble => 42,
+ }, '_add vs _merge';
}
-
# Test MIN_PERL_VERSION meta-spec 1.4
{
my $mm = $new_mm->(
- DISTNAME => 'Foo-Bar',
- VERSION => 1.23,
- PM => {
- "Foo::Bar" => 'lib/Foo/Bar.pm',
- },
+ @GENERIC_IN,
MIN_PERL_VERSION => 5.006,
);
-
- is_deeply {$mm->metafile_data}, {
- name => 'Foo-Bar',
- version => 1.23,
- abstract => 'unknown',
- author => [],
- license => 'unknown',
- dynamic_config => 1,
- distribution_type => 'module',
-
- configure_requires => {
- 'ExtUtils::MakeMaker' => 0,
- },
- build_requires => {
- 'ExtUtils::MakeMaker' => 0,
- },
-
- requires => {
- perl => '5.006',
- },
-
- no_index => {
- directory => [qw(t inc)],
- },
-
- generated_by => "ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION",
- 'meta-spec' => {
- url => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
- version => 1.4
+ is_deeply $mm->metafile_data( {}, { @METASPEC14 }, ), {
+ @GENERIC_OUT,
+ prereqs => {
+ @REQ20,
+ runtime => { requires => { perl => 5.006, }, },
},
}, 'MIN_PERL_VERSION meta-spec 1.4';
}
# Test MIN_PERL_VERSION meta-spec 2.0
{
my $mm = $new_mm->(
- DISTNAME => 'Foo-Bar',
- VERSION => 1.23,
- PM => {
- "Foo::Bar" => 'lib/Foo/Bar.pm',
- },
+ @GENERIC_IN,
MIN_PERL_VERSION => 5.006,
);
-
- is_deeply {
- $mm->metafile_data(
- {}, {
- 'meta-spec' => {
- url => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec',
- version => 2
- } } )
- }, {
- name => 'Foo-Bar',
- version => 1.23,
- abstract => 'unknown',
- author => [],
- license => 'unknown',
- dynamic_config => 1,
- distribution_type => 'module',
-
+ is_deeply $mm->metafile_data, {
prereqs => {
- configure => {
- requires => {
- 'ExtUtils::MakeMaker' => 0,
- },
- },
- build => {
- requires => {
- 'ExtUtils::MakeMaker' => 0,
- },
- },
- runtime => {
- requires => {
- 'perl' => '5.006',
- },
- },
- },
-
- no_index => {
- directory => [qw(t inc)],
- },
-
- generated_by => "ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION",
- 'meta-spec' => {
-
- url => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec',
- version => 2
+ @REQ20,
+ runtime => { requires => { 'perl' => '5.006', }, },
},
+ @GENERIC_OUT,
}, 'MIN_PERL_VERSION meta-spec 2.0';
}
# Test MIN_PERL_VERSION meta-spec 1.4
{
my $mm = $new_mm->(
- DISTNAME => 'Foo-Bar',
- VERSION => 1.23,
- PM => {
- "Foo::Bar" => 'lib/Foo/Bar.pm',
- },
+ @GENERIC_IN,
MIN_PERL_VERSION => 5.006,
- PREREQ_PM => {
- 'Foo::Bar' => 1.23,
- },
+ PREREQ_PM => { 'Foo::Bar' => 1.23, },
);
-
- is_deeply {$mm->metafile_data}, {
- name => 'Foo-Bar',
- version => 1.23,
- abstract => 'unknown',
- author => [],
- license => 'unknown',
- dynamic_config => 1,
- distribution_type => 'module',
-
- configure_requires => {
- 'ExtUtils::MakeMaker' => 0,
- },
- build_requires => {
- 'ExtUtils::MakeMaker' => 0,
- },
-
- requires => {
- perl => '5.006',
- 'Foo::Bar' => 1.23,
- },
-
- no_index => {
- directory => [qw(t inc)],
- },
-
- generated_by => "ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION",
- 'meta-spec' => {
- url => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
- version => 1.4
+ is_deeply $mm->metafile_data, {
+ @GENERIC_OUT,
+ prereqs => {
+ @REQ20,
+ runtime => {
+ requires => {
+ 'Foo::Bar' => 1.23,
+ 'perl' => '5.006',
+ },
+ },
},
}, 'MIN_PERL_VERSION and PREREQ_PM meta-spec 1.4';
}
# Test CONFIGURE_REQUIRES meta-spec 1.4
{
my $mm = $new_mm->(
- DISTNAME => 'Foo-Bar',
- VERSION => 1.23,
- CONFIGURE_REQUIRES => {
- "Fake::Module1" => 1.01,
- },
- PM => {
- "Foo::Bar" => 'lib/Foo/Bar.pm',
- },
+ @GENERIC_IN,
+ CONFIGURE_REQUIRES => { "Fake::Module1" => 1.01, },
);
-
- is_deeply {$mm->metafile_data}, {
- name => 'Foo-Bar',
- version => 1.23,
- abstract => 'unknown',
- author => [],
- license => 'unknown',
- dynamic_config => 1,
- distribution_type => 'module',
-
- configure_requires => {
- 'Fake::Module1' => 1.01,
- },
- build_requires => {
- 'ExtUtils::MakeMaker' => 0,
- },
-
- no_index => {
- directory => [qw(t inc)],
- },
-
- generated_by => "ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION",
- 'meta-spec' => {
- url => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
- version => 1.4
+ is_deeply $mm->metafile_data( {}, { @METASPEC14 }, ), {
+ prereqs => {
+ @REQ20,
+ configure => { requires => { 'Fake::Module1' => 1.01, }, },
},
+ @GENERIC_OUT,
},'CONFIGURE_REQUIRES meta-spec 1.4';
}
# Test CONFIGURE_REQUIRES meta-spec 2.0
{
my $mm = $new_mm->(
- DISTNAME => 'Foo-Bar',
- VERSION => 1.23,
- CONFIGURE_REQUIRES => {
- "Fake::Module1" => 1.01,
- },
- PM => {
- "Foo::Bar" => 'lib/Foo/Bar.pm',
- },
+ @GENERIC_IN,
+ CONFIGURE_REQUIRES => { "Fake::Module1" => 1.01, },
);
-
- is_deeply {
- $mm->metafile_data(
- {}, {
- 'meta-spec' => {
- url => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec',
- version => 2
- } } )
- }, {
- name => 'Foo-Bar',
- version => 1.23,
- abstract => 'unknown',
- author => [],
- license => 'unknown',
- dynamic_config => 1,
- distribution_type => 'module',
-
+ is_deeply $mm->metafile_data, {
prereqs => {
- configure => {
- requires => {
- 'Fake::Module1' => 1.01,
- },
- },
- build => {
- requires => {
- 'ExtUtils::MakeMaker' => 0,
- },
- },
- },
-
- no_index => {
- directory => [qw(t inc)],
- },
-
- generated_by => "ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION",
- 'meta-spec' => {
- url => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec',
- version => 2
+ @REQ20,
+ configure => { requires => { 'Fake::Module1' => 1.01, }, },
},
+ @GENERIC_OUT,
},'CONFIGURE_REQUIRES meta-spec 2.0';
}
-
# Test BUILD_REQUIRES meta-spec 1.4
{
my $mm = $new_mm->(
- DISTNAME => 'Foo-Bar',
- VERSION => 1.23,
- BUILD_REQUIRES => {
- "Fake::Module1" => 1.01,
- },
- PM => {
- "Foo::Bar" => 'lib/Foo/Bar.pm',
- },
+ @GENERIC_IN,
+ BUILD_REQUIRES => { "Fake::Module1" => 1.01, },
+ META_MERGE => { "meta-spec" => { version => 1.4 }},
);
-
- is_deeply {$mm->metafile_data}, {
- name => 'Foo-Bar',
- version => 1.23,
- abstract => 'unknown',
- author => [],
- license => 'unknown',
- dynamic_config => 1,
- distribution_type => 'module',
-
- configure_requires => {
- 'ExtUtils::MakeMaker' => 0,
- },
- build_requires => {
- 'Fake::Module1' => 1.01,
- },
-
- no_index => {
- directory => [qw(t inc)],
- },
-
- generated_by => "ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION",
- 'meta-spec' => {
- url => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
- version => 1.4
+ is_deeply $mm->metafile_data( {}, { @METASPEC14 }, ), {
+ prereqs => {
+ @REQ20,
+ build => { requires => { 'Fake::Module1' => 1.01, }, },
},
+ @GENERIC_OUT,
},'BUILD_REQUIRES meta-spec 1.4';
}
# Test BUILD_REQUIRES meta-spec 2.0
{
my $mm = $new_mm->(
- DISTNAME => 'Foo-Bar',
- VERSION => 1.23,
- BUILD_REQUIRES => {
- "Fake::Module1" => 1.01,
- },
- PM => {
- "Foo::Bar" => 'lib/Foo/Bar.pm',
- },
- META_MERGE => { "meta-spec" => { version => 2 }},
+ @GENERIC_IN,
+ BUILD_REQUIRES => { "Fake::Module1" => 1.01, },
);
-
- is_deeply {
- $mm->metafile_data(
- {}, {
- 'meta-spec' => {
- url => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec',
- version => 2
- } } )
- }, {
- name => 'Foo-Bar',
- version => 1.23,
- abstract => 'unknown',
- author => [],
- license => 'unknown',
- dynamic_config => 1,
- distribution_type => 'module',
-
+ is_deeply $mm->metafile_data, {
prereqs => {
- configure => {
- requires => {
- 'ExtUtils::MakeMaker' => 0,
- },
- },
- build => {
- requires => {
- 'Fake::Module1' => 1.01,
- },
- },
- },
-
- no_index => {
- directory => [qw(t inc)],
- },
-
- generated_by => "ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION",
- 'meta-spec' => {
- url => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec',
- version => 2
+ @REQ20,
+ build => { requires => { 'Fake::Module1' => 1.01, }, },
},
+ @GENERIC_OUT,
},'BUILD_REQUIRES meta-spec 2.0';
}
# Test TEST_REQUIRES meta-spec 1.4
{
my $mm = $new_mm->(
- DISTNAME => 'Foo-Bar',
- VERSION => 1.23,
- TEST_REQUIRES => {
- "Fake::Module1" => 1.01,
- },
- PM => {
- "Foo::Bar" => 'lib/Foo/Bar.pm',
- },
+ @GENERIC_IN,
+ TEST_REQUIRES => { "Fake::Module1" => 1.01, },
+ META_MERGE => { "meta-spec" => { version => 1.4 }},
);
-
- is_deeply {$mm->metafile_data}, {
- name => 'Foo-Bar',
- version => 1.23,
- abstract => 'unknown',
- author => [],
- license => 'unknown',
- dynamic_config => 1,
- distribution_type => 'module',
-
- configure_requires => {
- 'ExtUtils::MakeMaker' => 0,
- },
- build_requires => {
- 'ExtUtils::MakeMaker' => 0,
- 'Fake::Module1' => 1.01,
- },
-
- no_index => {
- directory => [qw(t inc)],
- },
-
- generated_by => "ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION",
- 'meta-spec' => {
- url => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
- version => 1.4
+ is_deeply $mm->metafile_data( {}, { @METASPEC14 }, ), {
+ prereqs => {
+ @REQ20,
+ test => { requires => { "Fake::Module1" => 1.01, }, },
},
+ @GENERIC_OUT,
},'TEST_REQUIRES meta-spec 1.4';
}
# Test TEST_REQUIRES meta-spec 2.0
{
my $mm = $new_mm->(
- DISTNAME => 'Foo-Bar',
- VERSION => 1.23,
- TEST_REQUIRES => {
- "Fake::Module1" => 1.01,
- },
- PM => {
- "Foo::Bar" => 'lib/Foo/Bar.pm',
- },
- META_MERGE => { "meta-spec" => { version => 2 }},
+ @GENERIC_IN,
+ TEST_REQUIRES => { "Fake::Module1" => 1.01, },
);
-
- is_deeply {
- $mm->metafile_data(
- {}, {
- 'meta-spec' => {
- url => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec',
- version => 2
- } } )
- }, {
- name => 'Foo-Bar',
- version => 1.23,
- abstract => 'unknown',
- author => [],
- license => 'unknown',
- dynamic_config => 1,
- distribution_type => 'module',
-
+ is_deeply $mm->metafile_data, {
prereqs => {
- configure => {
- requires => {
- 'ExtUtils::MakeMaker' => 0,
- },
- },
- build => {
- requires => {
- 'ExtUtils::MakeMaker' => 0,
- },
- },
- test => {
- requires => {
- "Fake::Module1" => 1.01,
- },
- },
- },
-
- no_index => {
- directory => [qw(t inc)],
- },
-
- generated_by => "ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION",
- 'meta-spec' => {
- url => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec',
- version => 2
+ @REQ20,
+ test => { requires => { "Fake::Module1" => 1.01, }, },
},
+ @GENERIC_OUT,
},'TEST_REQUIRES meta-spec 2.0';
}
-
# Test _REQUIRES key priority over META_ADD
-
{
my $mm = $new_mm->(
- DISTNAME => 'Foo-Bar',
- VERSION => 1.23,
- BUILD_REQUIRES => {
- "Fake::Module1" => 1.01,
- },
+ @GENERIC_IN,
+ BUILD_REQUIRES => { "Fake::Module1" => 1.01, },
META_ADD => (my $meta_add = { build_requires => {}, configure_requires => {} }),
- PM => {
- "Foo::Bar" => 'lib/Foo/Bar.pm',
- },
);
-
- is_deeply {$mm->metafile_data($meta_add)}, {
- name => 'Foo-Bar',
- version => 1.23,
- abstract => 'unknown',
- author => [],
- license => 'unknown',
- dynamic_config => 1,
- distribution_type => 'module',
-
- configure_requires => { },
- build_requires => { },
-
- no_index => {
- directory => [qw(t inc)],
- },
-
- generated_by => "ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION",
- 'meta-spec' => {
- url => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
- version => 1.4
+ is_deeply $mm->metafile_data($meta_add), {
+ prereqs => {
+ configure => { requires => { }, },
+ build => { requires => { }, },
},
+ @GENERIC_OUT,
},'META.yml data (META_ADD wins)';
-
-
# Yes, this is all hard coded.
- require CPAN::Meta;
+
my $want_mymeta = {
name => 'ExtUtils-MakeMaker',
version => '6.57_07',
author => ['Michael G Schwern <schwern@pobox.com>'],
license => ['perl_5'],
dynamic_config => 0,
-
prereqs => {
runtime => {
requires => {
"perl" => "5.006",
},
},
- configure => {
- requires => {
- 'ExtUtils::MakeMaker' => 0,
- },
- },
- build => {
- requires => {
- 'Fake::Module1' => 1.01,
- },
- },
+ @REQ20,
+ build => { requires => { 'Fake::Module1' => 1.01, }, },
},
-
release_status => 'testing',
resources => {
license => [ 'http://dev.perl.org/licenses/' ],
repository => { url => 'http://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker' },
x_MailingList => 'makemaker@perl.org',
},
-
no_index => {
directory => [qw(t inc)],
package => ["DynaLoader", "in"],
},
-
generated_by => "ExtUtils::MakeMaker version 6.5707, CPAN::Meta::Converter version 2.110580",
- 'meta-spec' => {
- url => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec',
- version => 2,
- },
+ @METASPEC20,
};
-
mymeta_ok $mm->mymeta("t/META_for_testing.json"),
$want_mymeta,
'MYMETA JSON data (BUILD_REQUIRES wins)';
-
mymeta_ok $mm->mymeta("t/META_for_testing.yml"),
$want_mymeta,
'MYMETA YAML data (BUILD_REQUIRES wins)';
{
my $mm = $new_mm->(
- DISTNAME => 'Foo-Bar',
- VERSION => 1.23,
+ @GENERIC_IN,
CONFIGURE_REQUIRES => { "Fake::Module0" => 0.99 },
BUILD_REQUIRES => { "Fake::Module1" => 1.01 },
TEST_REQUIRES => { "Fake::Module2" => 1.23 },
);
-
my $meta = $mm->mymeta('t/META_for_testing.json');
is($meta->{configure_requires}, undef, "no configure_requires in v2 META");
is($meta->{build_requires}, undef, "no build_requires in v2 META");
{ "Fake::Module0" => 0.99 },
"configure requires are one thing in META v2...",
);
-
is_deeply(
$meta->{prereqs}{build}{requires},
{ "Fake::Module1" => 1.01 },
"build requires are one thing in META v2...",
);
-
is_deeply(
$meta->{prereqs}{test}{requires},
{ "Fake::Module2" => 1.23 },
);
}
-note "CPAN::Meta bug using the module version instead of the meta spec version"; {
+note "CPAN::Meta bug using the module version instead of the meta spec version";
+{
my $mm = $new_mm->(
NAME => 'GD::Barcode::Code93',
AUTHOR => 'Chris DiMartino',
},
VERSION => '1.4',
);
-
my $meta = $mm->mymeta("t/META_for_testing_tricky_version.yml");
is $meta->{'meta-spec'}{version}, 2, "internally, our MYMETA struct is v2";
-
in_dir {
$mm->write_mymeta($meta);
ok -e "MYMETA.yml";
ok -e "MYMETA.json";
-
my $meta_yml = Parse::CPAN::Meta->load_file("MYMETA.yml");
is $meta_yml->{'meta-spec'}{version}, 1.4, "MYMETA.yml correctly downgraded to 1.4";
-
my $meta_json = Parse::CPAN::Meta->load_file("MYMETA.json");
cmp_ok $meta_json->{'meta-spec'}{version}, ">=", 2, "MYMETA.json at 2 or better";
};
}
-
-note "A bad license string"; {
+note "A bad license string";
+{
my $mm = $new_mm->(
- DISTNAME => 'Foo::Bar',
- VERSION => '1.4',
+ @GENERIC_IN,
LICENSE => 'death and retribution',
);
-
in_dir {
my $meta = $mm->mymeta;
- $mm->write_mymeta($meta);
-
+ {
+ local $SIG{__WARN__} = sub {}; # suppress "Invalid" warning
+ $mm->write_mymeta($meta);
+ }
my $meta_yml = Parse::CPAN::Meta->load_file("MYMETA.yml");
is $meta_yml->{license}, "unknown", "in yaml";
-
my $meta_json = Parse::CPAN::Meta->load_file("MYMETA.json");
is_deeply $meta_json->{license}, ["unknown"], "in json";
};
}
use strict;
+use warnings;
use TieOut;
use MakeMaker::Test::Utils;
-use MakeMaker::Test::Setup::MPV;
use Config;
-use Test::More;
use ExtUtils::MM;
-plan !MM->can_run(make()) && $ENV{PERL_CORE} && $Config{'usecrosscompile'}
+use Test::More
+ !MM->can_run(make()) && $ENV{PERL_CORE} && $Config{'usecrosscompile'}
? (skip_all => "cross-compiling and make not available")
- : (tests => 36);
+ : (tests => 35);
use File::Path;
use ExtUtils::MakeMaker;
+my $CM = eval { require CPAN::Meta; };
+
+my $DIRNAME = 'Min-PerlVers';
+my %FILES = (
+ 'Makefile.PL' => <<'END',
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ NAME => 'Min::PerlVers',
+ AUTHOR => 'John Doe <jd@example.com>',
+ VERSION_FROM => 'lib/Min/PerlVers.pm',
+ PREREQ_PM => { strict => 0 },
+ MIN_PERL_VERSION => '5.005',
+);
+END
+
+ 'lib/Min/PerlVers.pm' => <<'END',
+package Min::PerlVers;
+$VERSION = 0.05;
+
+=head1 NAME
+
+Min::PerlVers - being picky about perl versions
+
+=cut
+
+1;
+END
+
+);
# avoid environment variables interfering with our make runs
-delete @ENV{qw(LIB MAKEFLAGS)};
+delete @ENV{qw(LIB MAKEFLAGS PERL_CORE)};
my $perl = which_perl();
my $make = make_run();
perl_lib();
-ok( setup_recurs(), 'setup' );
+hash2files($DIRNAME, \%FILES);
END {
ok( chdir(File::Spec->updir), 'leaving dir' );
- ok( teardown_recurs(), 'teardown' );
+ ok( rmtree($DIRNAME), 'teardown' );
}
ok( chdir 'Min-PerlVers', 'entering dir Min-PerlVers' ) ||
note "PREREQ_PRINT output"; {
my $prereq_out = run(qq{$perl Makefile.PL "PREREQ_PRINT=1"});
is( $?, 0, 'PREREQ_PRINT exiting normally' );
+ $prereq_out =~ s/.*(\$PREREQ_PM\s*=)/$1/s; # strip off errors eg from chcp
my $prereq_out_sane = $prereq_out =~ /^\s*\$PREREQ_PM\s*=/;
ok( $prereq_out_sane, ' and talking like we expect' ) ||
diag($prereq_out);
package _Prereq::Print::WithMPV; ## no critic
our($PREREQ_PM, $BUILD_REQUIRES, $MIN_PERL_VERSION, $ERR);
+ $BUILD_REQUIRES = undef; # suppress "used only once"
$ERR = '';
eval {
eval $prereq_out; ## no critic
is( $?, 0, 'PRINT_PREREQ exiting normally' );
ok( $prereq_out !~ /^warning/i, ' and not complaining loudly' );
like( $prereq_out,
- qr/^perl\(perl\) \s* >= 5\.005 \s+ perl\(strict\) \s* >= \s* 0 \s*$/x,
+ qr/^perl\(perl\) \s* >= 5\.005 \s+ perl\(strict\) \s* >= \s* 0 \s*$/mx,
'dump has prereqs and perl version' );
}
}
-note "META.yml output"; {
+note "META.yml output"; SKIP: {
+ skip 'Failed to load CPAN::Meta', 4 unless $CM;
my $distdir = 'Min-PerlVers-0.05';
$distdir =~ s{\.}{_}g if $Is_VMS;
my $meta_yml = "$distdir/META.yml";
my $meta_json = "$distdir/META.json";
my @make_out = run(qq{$make metafile});
- END { rmtree $distdir }
+ END { rmtree $distdir if defined $distdir }
for my $case (
['META.yml', $meta_yml],
);
}
}
-
local $Test::Builder::Level = $Test::Builder::Level + 1;
- my ($fh,$file) = tempfile( DIR => 't', UNLINK => 1 );
- print $fh $code;
- close $fh;
-
- # Hack up a minimal MakeMaker object.
- my $mm = bless { DISTNAME => $package }, "MM";
- my $have = $mm->parse_abstract($file);
-
- my $ok = is( $have, $want, $name );
-
+ my $ok = 0;
+ for my $crlf (0, 1) {
+ my ($fh,$file) = tempfile( DIR => 't', UNLINK => 1 );
+ binmode $fh, $crlf ? ':crlf' : ':raw';
+ print $fh $code;
+ close $fh;
+ # Hack up a minimal MakeMaker object.
+ my $mm = bless { DISTNAME => $package }, "MM";
+ my $have = $mm->parse_abstract($file);
+ $ok += is( $have, $want, "$name :crlf=$crlf" ) ? 1 : 0;
+ }
return $ok;
}
END
}
+if( $] >= 5.014 ) {
+ $versions{'package Foo 1.23 { }' } = '1.23';
+ $versions{'package Foo::Bar 1.23 { }' } = '1.23';
+ $versions{'package Foo v1.2.3 { }' } = 'v1.2.3';
+ $versions{'package Foo::Bar v1.2.3 { }' } = 'v1.2.3';
+ $versions{' package Foo::Bar 1.23 { }' } = '1.23';
+ $versions{"package Foo'Bar 1.23 { }" } = '1.23';
+ $versions{"package Foo::Bar 1.2.3 { }" } = '1.2.3';
+ $versions{'package Foo 1.230 { }' } = '1.230';
+ $versions{'package Foo 1.23_01 { }' } = '1.23_01';
+ $versions{'package Foo v1.23_01 { }' } = 'v1.23_01';
+ $versions{<<'END'} = '1.23';
+package Foo 1.23 {
+our $VERSION = 2.34;
+}
+END
+
+ $versions{<<'END'} = '2.34';
+our $VERSION = 2.34;
+package Foo 1.23 { }
+END
+
+ $versions{<<'END'} = '2.34';
+package Foo::100 {
+our $VERSION = 2.34;
+}
+END
+}
+
if ( $] > 5.009 && $] < 5.012 ) {
delete $versions{'$VERSION = -1.0'};
}
use MakeMaker::Test::Utils;
use MakeMaker::Test::Setup::BFD;
use Config;
-use Test::More;
use ExtUtils::MM;
-plan !MM->can_run(make()) && $ENV{PERL_CORE} && $Config{'usecrosscompile'}
+use Test::More
+ !MM->can_run(make()) && $ENV{PERL_CORE} && $Config{'usecrosscompile'}
? (skip_all => "cross-compiling and make not available")
: 'no_plan';
# Setup our test environment
{
- my $tmpdir = tempdir( DIR => 't', CLEANUP => 1 );
- chdir $tmpdir;
+ chdir 't';
+ perl_lib; # sets $ENV{PERL5LIB} relative to t/
- perl_lib;
+ my $tmpdir = tempdir( DIR => '../t', CLEANUP => 1 );
+ use Cwd; my $cwd = getcwd; END { chdir $cwd } # so File::Temp can cleanup
+ chdir $tmpdir;
ok( setup_recurs(), 'setup' );
END {
use ExtUtils::MakeMaker;
use TieOut;
+chdir 't';
+perl_lib; # sets $ENV{PERL5LIB} relative to t/
+
use File::Temp qw[tempdir];
-my $tmpdir = tempdir( DIR => 't', CLEANUP => 1 );
+my $tmpdir = tempdir( DIR => '../t', CLEANUP => 1 );
+use Cwd; my $cwd = getcwd; END { chdir $cwd } # so File::Temp can cleanup
chdir $tmpdir;
-perl_lib;
$| = 1;
my $Makefile = makefile_name;
use strict;
use Config;
-use Test::More tests => 16;
+use Test::More tests => 21;
use File::Temp qw[tempdir];
use TieOut;
use ExtUtils::MakeMaker;
-my $tmpdir = tempdir( DIR => 't', CLEANUP => 1 );
-chdir $tmpdir;
+chdir 't';
+perl_lib; # sets $ENV{PERL5LIB} relative to t/
-perl_lib();
+my $tmpdir = tempdir( DIR => '../t', CLEANUP => 1 );
+use Cwd; my $cwd = getcwd; END { chdir $cwd } # so File::Temp can cleanup
+chdir $tmpdir;
ok( setup_recurs(), 'setup' );
END {
- ok( chdir File::Spec->updir );
+ ok( chdir File::Spec->updir, 'chdir updir' );
ok( teardown_recurs(), 'teardown' );
}
diag("chdir failed: $!");
{
- ok( my $stdout = tie *STDOUT, 'TieOut' );
+ ok my $stdout = tie(*STDOUT, 'TieOut'), 'tie STDOUT';
my $warnings = '';
local $SIG{__WARN__} = sub {
if ( $Config{usecrosscompile} ) {
strict => 0
}
);
- is $warnings, '';
+ is $warnings, '', 'basic prereq';
+
+ SKIP: {
+ skip 'No CMR, no version ranges', 1
+ unless ExtUtils::MakeMaker::_has_cpan_meta_requirements;
+ $warnings = '';
+ WriteMakefile(
+ NAME => 'Big::Dummy',
+ PREREQ_PM => {
+ strict => '>= 0, <= 99999',
+ }
+ );
+ is $warnings, '', 'version range';
+ }
$warnings = '';
WriteMakefile(
);
is $warnings,
sprintf("Warning: prerequisite strict 99999 not found. We have %s.\n",
- $strict::VERSION);
+ $strict::VERSION), 'strict 99999';
$warnings = '';
WriteMakefile(
}
);
is $warnings,
- "Warning: prerequisite I::Do::Not::Exist 0 not found.\n";
+ "Warning: prerequisite I::Do::Not::Exist 0 not found.\n", 'non-exist prereq';
+
+ $warnings = '';
+ WriteMakefile(
+ NAME => 'Big::Dummy',
+ CONFIGURE_REQUIRES => {
+ "I::Do::Not::Configure" => 0,
+ }
+ );
+ is $warnings,
+ "Warning: prerequisite I::Do::Not::Configure 0 not found.\n", 'non-exist prereq';
+
+ $warnings = '';
+ WriteMakefile(
+ NAME => 'Big::Dummy',
+ TEST_REQUIRES => {
+ "I::Do::Not::Test" => 0,
+ }
+ );
+ is $warnings,
+ "Warning: prerequisite I::Do::Not::Test 0 not found.\n", 'non-exist prereq';
$warnings = '';
}
);
my @warnings = split /\n/, $warnings;
- is @warnings, 2;
- like $warnings[0], qr{^Unparsable version '' for prerequisite I::Do::Not::Exist\b};
- is $warnings[1], "Warning: prerequisite I::Do::Not::Exist 0 not found.";
+ is @warnings, 2, '2 warnings';
+ like $warnings[0], qr{^Undefined requirement for I::Do::Not::Exist\b}, 'undef version warning';
+ is $warnings[1], "Warning: prerequisite I::Do::Not::Exist 0 not found.", 'not found warning';
$warnings = '';
is $warnings,
"Warning: prerequisite I::Do::Not::Exist 0 not found.\n".
sprintf("Warning: prerequisite strict 99999 not found. We have %s.\n",
- $strict::VERSION);
+ $strict::VERSION), '2 bad prereq warnings';
$warnings = '';
eval {
);
};
- is $warnings, '';
+ is $warnings, '', 'no warnings on PREREQ_FATAL';
is $@, <<'END', "PREREQ_FATAL";
MakeMaker FATAL: prerequisites not found.
I::Do::Not::Exist not installed
);
};
- is $warnings, '';
+ is $warnings, '', 'CONFIGURE sub non-exist req no warn';
is $@, <<'END', "PREREQ_FATAL happens before CONFIGURE";
MakeMaker FATAL: prerequisites not found.
I::Do::Not::Exist not installed
Please install these modules first and rerun 'perl Makefile.PL'.
END
+
+ $warnings = '';
+ @ARGV = 'PREREQ_FATAL=1';
+ eval {
+ WriteMakefile(
+ NAME => 'Big::Dummy',
+ PREREQ_PM => { "I::Do::Not::Exist" => 0, },
+ );
+ };
+ is $warnings, "Warning: prerequisite I::Do::Not::Exist 0 not found.\n",
+ 'CLI PREREQ_FATAL warns';
+ isnt $@, '', "CLI PREREQ_FATAL works";
+
}
my $Makefile = makefile_name();
my $Is_VMS = $^O eq 'VMS';
-my $tmpdir = tempdir( DIR => 't', CLEANUP => 1 );
-chdir $tmpdir;
+chdir 't';
+perl_lib; # sets $ENV{PERL5LIB} relative to t/
-perl_lib;
+my $tmpdir = tempdir( DIR => '../t', CLEANUP => 1 );
+use Cwd; my $cwd = getcwd; END { chdir $cwd } # so File::Temp can cleanup
+chdir $tmpdir;
$| = 1;
my $prereq_out = run(qq{$Perl Makefile.PL "PREREQ_PRINT=1"});
ok( !-r $Makefile, "PREREQ_PRINT produces no $Makefile" );
is( $?, 0, ' exited normally' );
+$prereq_out =~ s/^'chcp' is not recognized.*batch file\.//s; # remove errors
{
package _Prereq::Print;
no strict;
$prereq_out = run(qq{$Perl Makefile.PL "PRINT_PREREQ=1"});
ok( !-r $Makefile, "PRINT_PREREQ produces no $Makefile" );
is( $?, 0, ' exited normally' );
-::like( $prereq_out, qr/^perl\(strict\) \s* >= \s* 0 \s*$/x,
+::like( $prereq_out, qr/^perl\(strict\) \s* >= \s* 0 \s*$/mx,
'prereqs dumped' );
chdir 't';
use strict;
-use Test::More tests => 6;
+use Test::More tests => 5;
use ExtUtils::MM;
-use MakeMaker::Test::Setup::Problem;
+use MakeMaker::Test::Utils;
+use File::Path;
use TieOut;
my $MM = bless { DIR => ['subdir'] }, 'MM';
-
-ok( setup_recurs(), 'setup' );
+my $DIRNAME = 'Problem-Module';
+my %FILES = (
+ 'Makefile.PL' => <<'END',
+use ExtUtils::MakeMaker;
+WriteMakefile(NAME => 'Problem::Module');
+END
+
+ 'subdir/Makefile.PL' => <<'END',
+printf "\@INC %s .\n", (grep { $_ eq '.' } @INC) ? "has" : "doesn't have";
+warn "I think I'm going to be sick\n";
+die "YYYAaaaakkk\n";
+END
+
+);
+
+hash2files($DIRNAME, \%FILES);
END {
- ok( chdir File::Spec->updir );
- ok( teardown_recurs(), 'teardown' );
+ ok( chdir File::Spec->updir, 'chdir ..' );
+ ok( rmtree($DIRNAME), 'teardown' );
}
-ok( chdir 'Problem-Module', "chdir'd to Problem-Module" ) ||
+ok( chdir $DIRNAME, "chdir'd to Problem-Module" ) ||
diag("chdir failed: $!");
is( prompt("Foo?", 'Bar!'), 'Bar!', 'default' );
like( $stdout->read, qr/^Foo\? \[Bar!\]\s+Bar!\n$/, ' question' );
-
-SKIP: {
- skip "eof() doesn't honor ties in 5.5.3", 3 if $] < 5.006;
-
- $ENV{PERL_MM_USE_DEFAULT} = 0;
- close STDIN;
- my $stdin = tie *STDIN, 'TieIn' or die;
- $stdin->write("From STDIN");
- ok( !-t STDIN, 'STDIN not a tty' );
-
- is( prompt("Foo?", 'Bar!'), 'From STDIN', 'from STDIN' );
- like( $stdout->read, qr/^Foo\? \[Bar!\]\s*$/, ' question' );
-}
+$ENV{PERL_MM_USE_DEFAULT} = 0;
+close STDIN;
+my $stdin = tie *STDIN, 'TieIn' or die;
+$stdin->write("From STDIN");
+ok( !-t STDIN, 'STDIN not a tty' );
+
+is( prompt("Foo?", 'Bar!'), 'From STDIN', 'from STDIN' );
+like( $stdout->read, qr/^Foo\? \[Bar!\]\s*$/, ' question' );
}
use strict;
-use Config;
-
-use File::Temp qw[tempdir];
-
+use warnings;
use MakeMaker::Test::Utils;
-use MakeMaker::Test::Setup::Recurs;
use Config;
-use Test::More;
use ExtUtils::MM;
-plan !MM->can_run(make()) && $ENV{PERL_CORE} && $Config{'usecrosscompile'}
+use Test::More
+ !MM->can_run(make()) && $ENV{PERL_CORE} && $Config{'usecrosscompile'}
? (skip_all => "cross-compiling and make not available")
- : (tests => 26);
+ : (tests => 28);
+use File::Temp qw[tempdir];
+use File::Path;
# 'make disttest' sets a bunch of environment variables which interfere
# with our testing.
delete @ENV{qw(PREFIX LIB MAKEFLAGS)};
-my $perl = which_perl();
-my $Is_VMS = $^O eq 'VMS';
+my $DIRNAME = 'Recurs';
+my $BASICMPL = <<'END';
+use ExtUtils::MakeMaker;
+WriteMakefile(NAME => 'Recurs', VERSION => 1.00);
+END
+my %FILES = (
+ 'Makefile.PL' => $BASICMPL,
+
+ 'prj2/Makefile.PL' => <<'END',
+use ExtUtils::MakeMaker;
+WriteMakefile(NAME => 'Recurs::prj2', VERSION => 1.00);
+END
+
+ # Check if a test failure in a subdir causes make test to fail
+ 'prj2/t/fail.t' => <<'END',
+#!/usr/bin/perl -w
+print "1..1\n";
+print "not ok 1\n";
+END
+);
-my $tmpdir = tempdir( DIR => 't', CLEANUP => 1 );
-chdir $tmpdir;
+my $perl = which_perl();
-perl_lib;
+chdir 't';
+perl_lib; # sets $ENV{PERL5LIB} relative to t/
-my $Touch_Time = calibrate_mtime();
+my $tmpdir = tempdir( DIR => '../t', CLEANUP => 1 );
+use Cwd; my $cwd = getcwd; END { chdir $cwd } # so File::Temp can cleanup
+chdir $tmpdir;
$| = 1;
-ok( setup_recurs(), 'setup' );
+hash2files($DIRNAME, \%FILES);
END {
ok( chdir File::Spec->updir );
- ok( teardown_recurs(), 'teardown' );
+ ok( rmtree($DIRNAME), 'teardown' );
}
-ok( chdir('Recurs'), q{chdir'd to Recurs} ) ||
+ok( chdir($DIRNAME), q{chdir'd to Recurs} ) ||
diag("chdir failed: $!");
is( $?, 0, 'recursive make exited normally' ) || diag $make_out;
ok( chdir File::Spec->updir );
-ok( teardown_recurs(), 'cleaning out recurs' );
-ok( setup_recurs(), ' setting up fresh copy' );
-ok( chdir('Recurs'), q{chdir'd to Recurs} ) ||
+ok( rmtree($DIRNAME), 'cleaning out recurs' );
+hash2files($DIRNAME, \%FILES);
+ok( chdir($DIRNAME), q{chdir'd to Recurs} ) ||
diag("chdir failed: $!");
ok( chdir File::Spec->updir );
-ok( teardown_recurs(), 'cleaning out recurs' );
-ok( setup_recurs(), ' setting up fresh copy' );
-ok( chdir('Recurs'), q{chdir'd to Recurs} ) ||
+ok( rmtree($DIRNAME), 'cleaning out recurs' );
+hash2files($DIRNAME, \%FILES);
+ok( chdir($DIRNAME), q{chdir'd to Recurs} ) ||
diag("chdir failed: $!");
my $test_out = run("$make test");
isnt $?, 0, 'test failure in a subdir causes make to fail';
}
+
+# test override of top_targets in sub-M.PL with no pure_nolink doesn't break
+ok( chdir File::Spec->updir );
+ok( rmtree($DIRNAME), 'cleaning out recurs' );
+hash2files($DIRNAME, {
+ 'Makefile.PL' => $BASICMPL,
+
+ 'subdir/Makefile.PL' => <<'EOF',
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ NAME => 'Recurs::subdir',
+ SKIP => [qw(all static static_lib dynamic dynamic_lib)],
+);
+
+sub MY::top_targets {'
+all :: static
+
+pure_all :: static
+
+static :: libfcrypt$(LIB_EXT)
+
+libfcrypt$(LIB_EXT) :
+ $(TOUCH) libfcrypt$(LIB_EXT)
+
+dynamic :
+ $(NOOP)
+';
+}
+EOF
+
+});
+ok( chdir($DIRNAME), q{chdir'd to Recurs} ) ||
+ diag("chdir failed: $!");
+@mpl_out = run(qq{$perl Makefile.PL});
+
+cmp_ok( $?, '==', 0, 'Makefile.PL exited with zero' ) ||
+ diag(@mpl_out);
+
+$make_out = run($make);
+is( $?, 0, 'recursive make exited normally' ) || diag $make_out;
use TieOut;
use MakeMaker::Test::Utils;
-use MakeMaker::Test::Setup::SAS;
use Config;
-use Test::More;
use ExtUtils::MM;
-plan !MM->can_run(make()) && $ENV{PERL_CORE} && $Config{'usecrosscompile'}
+use Test::More
+ !MM->can_run(make()) && $ENV{PERL_CORE} && $Config{'usecrosscompile'}
? (skip_all => "cross-compiling and make not available")
- : (tests => 20);
+ : (tests => 19);
use File::Path;
use File::Temp qw[tempdir];
use ExtUtils::MakeMaker;
+my $CM = eval { require CPAN::Meta; };
+
+my $DIRNAME = 'Multiple-Authors';
+my %FILES = (
+ 'Makefile.PL' => <<'END',
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ NAME => 'Multiple::Authors',
+ AUTHOR => ['John Doe <jd@example.com>', 'Jane Doe <jd@example.com>'],
+ VERSION_FROM => 'lib/Multiple/Authors.pm',
+ PREREQ_PM => { strict => 0 },
+);
+END
+
+ 'lib/Multiple/Authors.pm' => <<'END',
+package Multiple::Authors;
+
+$VERSION = 0.05;
+
+=head1 NAME
+
+Multiple::Authors - several authors
+
+=cut
+
+1;
+END
+
+);
# avoid environment variables interfering with our make runs
-delete @ENV{qw(LIB MAKEFLAGS)};
+delete @ENV{qw(LIB MAKEFLAGS PERL_CORE)};
my $perl = which_perl();
my $make = make_run();
my $makefile = makefile_name();
-my $tmpdir = tempdir( DIR => 't', CLEANUP => 1 );
-chdir $tmpdir;
+chdir 't';
+perl_lib; # sets $ENV{PERL5LIB} relative to t/
-perl_lib();
+my $tmpdir = tempdir( DIR => '../t', CLEANUP => 1 );
+use Cwd; my $cwd = getcwd; END { chdir $cwd } # so File::Temp can cleanup
+chdir $tmpdir;
-ok( setup_recurs(), 'setup' );
+hash2files($DIRNAME, \%FILES);
END {
ok( chdir(File::Spec->updir), 'leaving dir' );
- ok( teardown_recurs(), 'teardown' );
+ ok( rmtree($DIRNAME), 'teardown' );
}
-ok( chdir $MakeMaker::Test::Setup::SAS::dirname, "entering dir $MakeMaker::Test::Setup::SAS::dirname" ) ||
+ok( chdir $DIRNAME, "entering dir $DIRNAME" ) ||
diag("chdir failed: $!");
note "argument verification"; {
}
-note "META.yml output"; {
+note "META.yml output"; SKIP: {
+ skip 'Failed to load CPAN::Meta', 5 unless $CM;
my $distdir = 'Multiple-Authors-0.05';
$distdir =~ s{\.}{_}g if $Is_VMS;
my $meta_yml = "$distdir/META.yml";
my $meta_json = "$distdir/META.json";
my @make_out = run(qq{$make metafile});
- END { rmtree $distdir }
+ END { rmtree $distdir if defined $distdir }
cmp_ok( $?, '==', 0, 'Make metafile exiting normally' ) || diag(@make_out);
use strict;
use ExtUtils::MakeMaker;
-use Test::More;
+use Test::More tests => 1;
-pass("Your test code goes here");
-
-done_testing();
+ok(1, "Your test code goes here");
chdir 't';
use strict;
+use ExtUtils::MM;
+use MakeMaker::Test::Utils qw(makefile_name make make_run run hash2files);
use Test::More;
use Config;
+use File::Path;
+use utf8;
BEGIN {
plan skip_all => 'Need perlio and perl 5.8+.'
if $] < 5.008 or !$Config{useperlio};
- plan tests => 9;
+ plan skip_all => 'cross-compiling and make not available'
+ if !MM->can_run(make()) && $ENV{PERL_CORE} && $Config{'usecrosscompile'};
+
+ plan tests => 8;
}
-use ExtUtils::MM;
-use MakeMaker::Test::Setup::Unicode;
-use MakeMaker::Test::Utils qw(makefile_name make_run run);
use TieOut;
my $MM = bless { DIR => ['.'] }, 'MM';
-ok( setup_recurs(), 'setup' );
+my $DIRNAME = 'Problem-Module';
+my %FILES = (
+ 'Makefile.PL' => <<'PL_END',
+use ExtUtils::MakeMaker;
+use utf8;
+WriteMakefile(
+ NAME => 'Problem::Module',
+ ABSTRACT_FROM => 'lib/Problem/Module.pm',
+ AUTHOR => q{Danijel Tašov},
+ EXE_FILES => [ qw(bin/probscript) ],
+ INSTALLMAN1DIR => "some", # even if disabled in $Config{man1dir}
+ MAN1EXT => 1, # set to 0 if man pages disabled
+);
+PL_END
+
+ 'lib/Problem/Module.pm' => <<'pm_END',
+use utf8;
+
+=pod
+
+=encoding utf8
+
+=head1 NAME
+
+Problem::Module - Danijel Tašov's great new module
+
+=cut
+
+1;
+pm_END
+
+ 'bin/probscript' => <<'pl_END',
+#!/usr/bin/perl
+use utf8;
+
+=encoding utf8
+
+=head1 NAME
+
+文档 - Problem script
+pl_END
+);
+
+hash2files($DIRNAME, \%FILES);
END {
ok( chdir File::Spec->updir, 'chdir updir' );
- ok( teardown_recurs(), 'teardown' );
+ ok( rmtree($DIRNAME), 'teardown' );
}
-ok( chdir 'Problem-Module', "chdir'd to Problem-Module" ) ||
+ok( chdir $DIRNAME, "chdir'd to $DIRNAME" ) ||
diag("chdir failed: $!");
if ($] >= 5.008) {
my $json = do { local $/; <$json_fh> };
close $json_fh;
+ no utf8; # leave the data below as bytes and let Encode sort it out
require Encode;
my $str = Encode::decode( 'utf8', "Danijel Tašov's" );
like( $json, qr/$str/, 'utf8 abstract' );
}
my $make = make_run();
-my $make_out = run("$make");
-is $? >> 8, 0, 'Exit code of make == 0';
+my $make_out = run($make);
+diag $make_out unless is $? >> 8, 0, 'Exit code of make == 0';
my $manfile = File::Spec->catfile(qw(blib man1 probscript.1));
SKIP: {
my $man = do { local $/; <$man_fh> };
close $man_fh;
+ no utf8; # leave the data below as bytes and let Encode sort it out
require Encode;
my $str = Encode::decode( 'utf8', "文档" );
like( $man, qr/$str/, 'utf8 man-snippet' );
}
$make_out = run("$make realclean");
-is $? >> 8, 0, 'Exit code of make == 0';
+diag $make_out unless is $? >> 8, 0, 'Exit code of make == 0';
sub makefile_content {
open my $fh, '<', makefile_name or die;
use TieOut;
use MakeMaker::Test::Utils qw(makefile_name);
use File::Temp qw[tempdir];
+use Test::More;
use ExtUtils::MakeMaker;
-use Test::More;
my $tmpdir = tempdir( DIR => '.', CLEANUP => 1 );
+use Cwd; my $cwd = getcwd; END { chdir $cwd } # so File::Temp can cleanup
chdir $tmpdir;
+my $UNDEFRE = qr/Undefined requirement .* treated as '0'/;
+my $UNPARSABLERE = qr/Unparsable\s+version/;
+# [ pkg, version, okwarningRE, descrip, nocmrRE ]
+# only supply nocmrRE if want to treat differently when no CMR
+my @DATA = (
+ [ Undef => undef, $UNDEFRE, 'Undef' ],
+ [ ZeroLength => '', $UNDEFRE, 'Zero-length' ],
+ [ SemiColon => '0;', $UNPARSABLERE, 'Semi-colon after 0' ],
+ [ BrokenString => 'nan', $UNPARSABLERE, 'random string' ],
+ [ Decimal2 => 1.2, qr/^$/, '2-part Decimal' ],
+ [ Decimal2String => '1.2', qr/^$/, '2-part Decimal String' ],
+ [ Decimal2Underscore => '1.02_03', qr/^$/, '2-part Underscore String' ],
+ [ Decimal3String => '1.2.3', qr/^$/, '3-part Decimal String', $UNPARSABLERE ],
+ [ BareV2String => v1.2, qr/^$/, '2-part bare v-string', $UNPARSABLERE ],
+ [ BareV3String => v1.2.3, qr/^$/, '3-part bare V-string', $UNPARSABLERE ],
+ [ V2DecimalString => 'v1.2', qr/^$/, '2-part v-decimal string', $UNPARSABLERE ],
+ [ V3DecimalString => 'v1.2.3', qr/^$/, '3-part v-Decimal String', $UNPARSABLERE ],
+ [ RangeString => '>= 5.0, <= 6.0', qr/^$/, 'Version range', $UNPARSABLERE ],
+ [ Scientific => 0.000005, qr/^$/, 'Scientific Notation' ],
+);
+
+plan tests => (1 + (@DATA * 4));
+
+ok my $stdout = tie(*STDOUT, 'TieOut'), 'tie STDOUT';
+
+# fake CMR to test fallback if CMR not present
+my $CMR = 'CPAN/Meta/Requirements.pm';
+my $CM = 'CPAN/Meta.pm';
+$INC{$CMR} = undef;
+$INC{$CM} = undef;
+run_test(0, @$_) for @DATA;
+
+# now try to load real CMR
+delete $INC{$CMR};
+delete $INC{$CM};
+SKIP: {
+ skip 'No actual CMR found', 2 * @DATA
+ unless ExtUtils::MakeMaker::_has_cpan_meta_requirements;
+ run_test(1, @$_) for @DATA;
+}
+
sub capture_make {
my ($package, $version) = @_ ;
}
sub makefile_content {
- open my $fh, '<', makefile_name or die;
- return <$fh>;
+ my $file = makefile_name;
+ open my $fh, '<', $file or return "$file: $!\n";
+ join q{}, grep { $_ =~ /Fake/i } <$fh>;
}
-# [ pkg, version, pattern, descrip, invertre ]
-my @DATA = (
- [ DecimalString => '1.2.3', qr/isn't\s+numeric/, '3-part Decimal String' ],
- [ VDecimalString => 'v1.2.3', qr/Unparsable\s+version/, '3-part V-Decimal String' ],
- [ BareVString => v1.2.3, qr/Unparsable\s+version/, '3-part bare V-string' ],
- [ VDecimalString => 'v1.2', qr/Unparsable\s+version/, '2-part v-decimal string' ],
- [ BareVString => v1.2, qr/Unparsable\s+version/, '2-part bare v-string' ],
- [ BrokenString => 'nan', qr/Unparsable\s+version/, 'random string', 1 ],
-);
-
-ok(my $stdout = tie *STDOUT, 'TieOut');
-for my $tuple (@DATA) {
- my ($pkg, $version, $pattern, $descrip, $invertre) = @$tuple;
- next if $] < 5.008 && $pkg eq 'BareVString' && $descrip =~ m!^2-part!;
- my $out;
- eval { $out = capture_make("Fake::$pkg" => $version); };
- is($@, '', "$descrip not fatal");
- if ($invertre) {
- like ( $out , qr/$pattern/i, "$descrip parses");
- } else {
- unlike ( $out , qr/$pattern/i , "$descrip parses");
+sub run_test {
+ my ($gotrealcmr, $pkg, $version, $okwarningRE, $descrip, $nocmrRE) = @_;
+ local $_;
+ SKIP: {
+ skip "No vstring test <5.8", 2
+ if $] < 5.008 && $pkg eq 'BareV2String' && $descrip =~ m!^2-part!;
+ my $warnings;
+ eval { $warnings = capture_make("Fake::$pkg" => $version); };
+ is($@, '', "$descrip not fatal") or skip "$descrip WM failed", 1;
+ $warnings =~ s#^Warning: prerequisite Fake::$pkg.* not found\.\n##m;
+ my $re = (!$gotrealcmr && $nocmrRE) ? $nocmrRE : $okwarningRE;
+ like $warnings, $re, "$descrip handled right";
}
-# note(join q{}, grep { $_ =~ /Fake/i } makefile_content);
+# diag makefile_content();
}
-
-done_testing();
use ExtUtils::MakeMaker;
+chdir 't';
+perl_lib; # sets $ENV{PERL5LIB} relative to t/
+
use File::Temp qw[tempdir];
-my $tmpdir = tempdir( DIR => 't', CLEANUP => 1 );
+my $tmpdir = tempdir( DIR => '../t', CLEANUP => 1 );
+use Cwd; my $cwd = getcwd; END { chdir $cwd } # so File::Temp can cleanup
chdir $tmpdir;
-perl_lib();
-
ok( setup_recurs(), 'setup' );
END {
ok( chdir File::Spec->updir );
+++ /dev/null
-#!/usr/bin/perl -w
-
-BEGIN {
- unshift @INC, 't/lib/';
-}
-chdir 't';
-
-use strict;
-
-use MakeMaker::Test::Utils;
-use MakeMaker::Test::Setup::XS;
-use Test::More
- have_compiler()
- ? (tests => 5)
- : (skip_all => "ExtUtils::CBuilder not installed or couldn't find a compiler");
-use File::Spec;
-
-my $Is_VMS = $^O eq 'VMS';
-my $perl = which_perl();
-
-chdir 't';
-
-perl_lib;
-
-$| = 1;
-
-ok( setup_xs(), 'setup' );
-END {
- chdir File::Spec->updir or die;
- teardown_xs(), 'teardown' or die;
-}
-
-ok( chdir('XS-Test'), "chdir'd to XS-Test" ) ||
- diag("chdir failed: $!");
-
-my @mpl_out = run(qq{$perl Makefile.PL});
-SKIP: {
- unless (cmp_ok( $?, '==', 0, 'Makefile.PL exited with zero' )) {
- diag(@mpl_out);
- skip 'perl Makefile.PL failed', 2;
- }
-
- my $make = make_run();
- my $make_out = run("$make");
- unless (is( $?, 0, ' make exited normally' )) {
- diag $make_out;
- skip 'Make failed - skipping test', 1;
- }
-
- my $test_out = run("$make test");
- is( $?, 0, ' make test exited normally' ) ||
- diag $test_out;
-}
# Author : Johan Vromans
# Created On : Tue Sep 11 15:00:12 1990
# Last Modified By: Johan Vromans
-# Last Modified On: Thu Oct 8 14:57:49 2015
-# Update Count : 1697
+# Last Modified On: Thu Jun 9 14:50:37 2016
+# Update Count : 1699
# Status : Released
################ Module Preamble ################
use strict;
use vars qw($VERSION);
-$VERSION = 2.48;
+$VERSION = 2.49;
# For testing versions only.
use vars qw($VERSION_STRING);
-$VERSION_STRING = "2.48";
+$VERSION_STRING = "2.49";
use Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK);
if ( $gnu_compat ) {
my $optargtype = 0; # 0 = none, 1 = empty, 2 = nonempty
$optargtype = ( !defined($optarg) ? 0 : ( (length($optarg) == 0) ? 1 : 2 ) );
- return (1, $opt, $ctl, undef)
+ return (1, $opt, $ctl, defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : undef)
if (($optargtype == 0) && !$mand);
return (1, $opt, $ctl, $type eq 's' ? '' : 0)
if $optargtype == 1; # --foo= -> return nothing
my $v = $main::VERSION;
my $fh = $pa->{-output} ||
- ($pa->{-exitval} eq "NOEXIT" || $pa->{-exitval} < 2) ? \*STDOUT : \*STDERR;
+ ( ($pa->{-exitval} eq "NOEXIT" || $pa->{-exitval} < 2) ? \*STDOUT : \*STDERR );
print $fh (defined($pa->{-message}) ? $pa->{-message} : (),
$0, defined $v ? " version $v" : (),
headers
Accept: */*
X-Custom: This is a custom header
+ x-lower: This is a lower-case custom header
+ authorization: fake auth data
----------
GET /index.html HTTP/1.1
Host: example.com
Accept: */*
+Authorization: fake auth data
Connection: close
User-Agent: HTTP-Tiny/VERSION
X-Custom: This is a custom header
+x-lower: This is a lower-case custom header
----------
HTTP/1.1 200 OK
--- /dev/null
+url
+ http://example.com/index.html
+expected_rc
+ 599
+expected_like
+ Invalid HTTP header field
+headers
+ trailing-space : foo
+----------
+----------
use warnings;
# ABSTRACT: A small, simple, correct HTTP/1.1 client
-our $VERSION = '0.056';
+our $VERSION = '0.058';
use Carp ();
#pod This constructor returns a new HTTP::Tiny object. Valid attributes include:
#pod
#pod =for :list
-#pod * C<agent> —
-#pod A user-agent string (defaults to 'HTTP-Tiny/$VERSION'). If C<agent> — ends in a space character, the default user-agent string is appended.
-#pod * C<cookie_jar> —
-#pod An instance of L<HTTP::CookieJar> — or equivalent class that supports the C<add> and C<cookie_header> methods
-#pod * C<default_headers> —
-#pod A hashref of default headers to apply to requests
-#pod * C<local_address> —
-#pod The local IP address to bind to
-#pod * C<keep_alive> —
-#pod Whether to reuse the last connection (if for the same scheme, host and port) (defaults to 1)
-#pod * C<max_redirect> —
-#pod Maximum number of redirects allowed (defaults to 5)
-#pod * C<max_size> —
-#pod Maximum response size in bytes (only when not using a data callback). If defined, responses larger than this will return an exception.
-#pod * C<http_proxy> —
-#pod URL of a proxy server to use for HTTP connections (default is C<$ENV{http_proxy}> — if set)
-#pod * C<https_proxy> —
-#pod URL of a proxy server to use for HTTPS connections (default is C<$ENV{https_proxy}> — if set)
-#pod * C<proxy> —
-#pod URL of a generic proxy server for both HTTP and HTTPS connections (default is C<$ENV{all_proxy}> — if set)
-#pod * C<no_proxy> —
-#pod List of domain suffixes that should not be proxied. Must be a comma-separated string or an array reference. (default is C<$ENV{no_proxy}> —)
-#pod * C<timeout> —
-#pod Request timeout in seconds (default is 60)
-#pod * C<verify_SSL> —
-#pod A boolean that indicates whether to validate the SSL certificate of an C<https> —
-#pod connection (default is false)
-#pod * C<SSL_options> —
-#pod A hashref of C<SSL_*> — options to pass through to L<IO::Socket::SSL>
+#pod * C<agent> — A user-agent string (defaults to 'HTTP-Tiny/$VERSION'). If
+#pod C<agent> — ends in a space character, the default user-agent string is
+#pod appended.
+#pod * C<cookie_jar> — An instance of L<HTTP::CookieJar> — or equivalent class
+#pod that supports the C<add> and C<cookie_header> methods
+#pod * C<default_headers> — A hashref of default headers to apply to requests
+#pod * C<local_address> — The local IP address to bind to
+#pod * C<keep_alive> — Whether to reuse the last connection (if for the same
+#pod scheme, host and port) (defaults to 1)
+#pod * C<max_redirect> — Maximum number of redirects allowed (defaults to 5)
+#pod * C<max_size> — Maximum response size in bytes (only when not using a data
+#pod callback). If defined, responses larger than this will return an
+#pod exception.
+#pod * C<http_proxy> — URL of a proxy server to use for HTTP connections
+#pod (default is C<$ENV{http_proxy}> — if set)
+#pod * C<https_proxy> — URL of a proxy server to use for HTTPS connections
+#pod (default is C<$ENV{https_proxy}> — if set)
+#pod * C<proxy> — URL of a generic proxy server for both HTTP and HTTPS
+#pod connections (default is C<$ENV{all_proxy}> — if set)
+#pod * C<no_proxy> — List of domain suffixes that should not be proxied. Must
+#pod be a comma-separated string or an array reference. (default is
+#pod C<$ENV{no_proxy}> —)
+#pod * C<timeout> — Request timeout in seconds (default is 60) If a socket open,
+#pod read or write takes longer than the timeout, an exception is thrown.
+#pod * C<verify_SSL> — A boolean that indicates whether to validate the SSL
+#pod certificate of an C<https> — connection (default is false)
+#pod * C<SSL_options> — A hashref of C<SSL_*> — options to pass through to
+#pod L<IO::Socket::SSL>
#pod
#pod Passing an explicit C<undef> for C<proxy>, C<http_proxy> or C<https_proxy> will
#pod prevent getting the corresponding proxies from the environment.
BEGIN {
@attributes = qw(
cookie_jar default_headers http_proxy https_proxy keep_alive
- local_address max_redirect max_size proxy no_proxy timeout
+ local_address max_redirect max_size proxy no_proxy
SSL_options verify_SSL
);
my %persist_ok = map {; $_ => 1 } qw(
return $self->{agent};
}
+sub timeout {
+ my ($self, $timeout) = @_;
+ if ( @_ > 1 ) {
+ $self->{timeout} = $timeout;
+ if ($self->{handle}) {
+ $self->{handle}->timeout($timeout);
+ }
+ }
+ return $self->{timeout};
+}
+
sub new {
my($class, %args) = @_;
#pod * C<data_callback> —
#pod A code reference that will be called for each chunks of the response
#pod body received.
+#pod * C<peer> —
+#pod Override host resolution and force all connections to go only to a
+#pod specific peer address, regardless of the URL of the request. This will
+#pod include any redirections! This options should be used with extreme
+#pod caution (e.g. debugging or very special circumstances).
#pod
#pod The C<Host> header is generated from the URL in accordance with RFC 2616. It
#pod is a fatal error to specify C<Host> in the C<headers> option. Other headers
#pod A hashref of header fields. All header field names will be normalized
#pod to be lower case. If a header is repeated, the value will be an arrayref;
#pod it will otherwise be a scalar string containing the value
+#pod * C<redirects>
+#pod If this field exists, it is an arrayref of response hash references from
+#pod redirects in the same order that redirections occurred. If it does
+#pod not exist, then no redirections occurred.
#pod
#pod On an exception during the execution of the request, the C<status> field will
#pod contain 599, and the C<content> field will contain the text of the exception.
wantarray ? ($ok, $reason) : $ok;
}
+#pod =method connected
+#pod
+#pod $host = $http->connected;
+#pod ($host, $port) = $http->connected;
+#pod
+#pod Indicates if a connection to a peer is being kept alive, per the C<keep_alive>
+#pod option.
+#pod
+#pod In scalar context, returns the peer host and port, joined with a colon, or
+#pod C<undef> (if no peer is connected).
+#pod In list context, returns the peer host and port or an empty list (if no peer
+#pod is connected).
+#pod
+#pod B<Note>: This method cannot reliably be used to discover whether the remote
+#pod host has closed its end of the socket.
+#pod
+#pod =cut
+
+sub connected {
+ my ($self) = @_;
+
+ # If a socket exists...
+ if ($self->{handle} && $self->{handle}{fh}) {
+ my $socket = $self->{handle}{fh};
+
+ # ...and is connected, return the peer host and port.
+ if ($socket->connected) {
+ return wantarray
+ ? ($socket->peerhost, $socket->peerport)
+ : join(':', $socket->peerhost, $socket->peerport);
+ }
+ }
+ return;
+}
+
#--------------------------------------------------------------------------#
# private methods
#--------------------------------------------------------------------------#
headers => {},
};
+ my $peer = $args->{peer} || $host;
+
# We remove the cached handle so it is not reused in the case of redirect.
# If all is well, it will be recached at the end of _request. We only
# reuse for the same scheme, host and port
my $handle = delete $self->{handle};
if ( $handle ) {
- unless ( $handle->can_reuse( $scheme, $host, $port ) ) {
+ unless ( $handle->can_reuse( $scheme, $host, $port, $peer ) ) {
$handle->close;
undef $handle;
}
}
- $handle ||= $self->_open_handle( $request, $scheme, $host, $port );
+ $handle ||= $self->_open_handle( $request, $scheme, $host, $port, $peer );
$self->_prepare_headers_and_cb($request, $args, $url, $auth);
$handle->write_request($request);
until (substr($response->{status},0,1) ne '1');
$self->_update_cookie_jar( $url, $response ) if $self->{cookie_jar};
-
- if ( my @redir_args = $self->_maybe_redirect($request, $response, $args) ) {
- $handle->close;
- return $self->_request(@redir_args, $args);
- }
+ my @redir_args = $self->_maybe_redirect($request, $response, $args);
my $known_message_length;
if ($method eq 'HEAD' || $response->{status} =~ /^[23]04/) {
$known_message_length = 1;
}
else {
- my $data_cb = $self->_prepare_data_cb($response, $args);
+ # Ignore any data callbacks during redirection.
+ my $cb_args = @redir_args ? +{} : $args;
+ my $data_cb = $self->_prepare_data_cb($response, $cb_args);
$known_message_length = $handle->read_body($data_cb, $response);
}
$response->{success} = substr( $response->{status}, 0, 1 ) eq '2';
$response->{url} = $url;
+
+ # Push the current response onto the stack of redirects if redirecting.
+ if (@redir_args) {
+ push @{$args->{_redirects}}, $response;
+ return $self->_request(@redir_args, $args);
+ }
+
+ # Copy the stack of redirects into the response before returning.
+ $response->{redirects} = delete $args->{_redirects}
+ if @{$args->{_redirects}};
return $response;
}
sub _open_handle {
- my ($self, $request, $scheme, $host, $port) = @_;
+ my ($self, $request, $scheme, $host, $port, $peer) = @_;
my $handle = HTTP::Tiny::Handle->new(
timeout => $self->{timeout},
return $self->_proxy_connect( $request, $handle );
}
else {
- return $handle->connect($scheme, $host, $port);
+ return $handle->connect($scheme, $host, $port, $peer);
}
}
$self->_add_basic_auth_header( $request, 'proxy-authorization' => $p_auth );
}
- $handle->connect($p_scheme, $p_host, $p_port);
+ $handle->connect($p_scheme, $p_host, $p_port, $p_host);
if ($request->{scheme} eq 'https') {
$self->_create_proxy_tunnel( $request, $handle );
next unless defined;
while (my ($k, $v) = each %$_) {
$request->{headers}{lc $k} = $v;
+ $request->{header_case}{lc $k} = $k;
}
}
my ($self, $request, $response, $args) = @_;
my $headers = $response->{headers};
my ($status, $method) = ($response->{status}, $request->{method});
+ $args->{_redirects} ||= [];
+
if (($status eq '303' or ($status =~ /^30[1278]/ && $method =~ /^GET|HEAD$/))
and $headers->{location}
- and ++$args->{redirects} <= $self->{max_redirect}
+ and @{$args->{_redirects}} < $self->{max_redirect}
) {
my $location = ($headers->{location} =~ /^\//)
? "$request->{scheme}://$request->{host_port}$headers->{location}"
use Errno qw[EINTR EPIPE];
use IO::Socket qw[SOCK_STREAM];
+use Socket qw[SOL_SOCKET SO_KEEPALIVE];
# PERL_HTTP_TINY_IPV4_ONLY is a private environment variable to force old
# behavior if someone is unable to boostrap CPAN from a new perl install; it is
};
my $Token = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
+my $Field_Content = qr/[[:print:]]+ (?: [\x20\x09]+ [[:print:]]+ )*/x;
sub new {
my ($class, %args) = @_;
}, $class;
}
+sub timeout {
+ my ($self, $timeout) = @_;
+ if ( @_ > 1 ) {
+ $self->{timeout} = $timeout;
+ if ( $self->{fh} && $self->{fh}->can('timeout') ) {
+ $self->{fh}->timeout($timeout);
+ }
+ }
+ return $self->{timeout};
+}
+
sub connect {
- @_ == 4 || die(q/Usage: $handle->connect(scheme, host, port)/ . "\n");
- my ($self, $scheme, $host, $port) = @_;
+ @_ == 5 || die(q/Usage: $handle->connect(scheme, host, port, peer)/ . "\n");
+ my ($self, $scheme, $host, $port, $peer) = @_;
if ( $scheme eq 'https' ) {
$self->_assert_ssl;
die(qq/Unsupported URL scheme '$scheme'\n/);
}
$self->{fh} = $SOCKET_CLASS->new(
- PeerHost => $host,
+ PeerHost => $peer,
PeerPort => $port,
$self->{local_address} ?
( LocalAddr => $self->{local_address} ) : (),
Proto => 'tcp',
Type => SOCK_STREAM,
Timeout => $self->{timeout},
- KeepAlive => !!$self->{keep_alive}
) or die(qq/Could not connect to '$host:$port': $@\n/);
binmode($self->{fh})
or die(qq/Could not binmode() socket: '$!'\n/);
+ if ( $self->{keep_alive} ) {
+ unless ( defined( $self->{fh}->setsockopt( SOL_SOCKET, SO_KEEPALIVE, 1 ) ) ) {
+ CORE::close($self->{fh});
+ die(qq/Could not set SO_KEEPALIVE on socket: '$!'\n/);
+ }
+ }
+
$self->start_ssl($host) if $scheme eq 'https';
$self->{scheme} = $scheme;
$self->{host} = $host;
+ $self->{peer} = $peer;
$self->{port} = $port;
$self->{pid} = $$;
$self->{tid} = _get_tid();
sub write_request {
@_ == 2 || die(q/Usage: $handle->write_request(request)/ . "\n");
my($self, $request) = @_;
- $self->write_request_header(@{$request}{qw/method uri headers/});
+ $self->write_request_header(@{$request}{qw/method uri headers header_case/});
$self->write_body($request) if $request->{cb};
return;
}
-my %HeaderCase = (
- 'content-md5' => 'Content-MD5',
- 'etag' => 'ETag',
- 'te' => 'TE',
- 'www-authenticate' => 'WWW-Authenticate',
- 'x-xss-protection' => 'X-XSS-Protection',
+# Standard request header names/case from HTTP/1.1 RFCs
+my @rfc_request_headers = qw(
+ Accept Accept-Charset Accept-Encoding Accept-Language Authorization
+ Cache-Control Connection Content-Length Expect From Host
+ If-Match If-Modified-Since If-None-Match If-Range If-Unmodified-Since
+ Max-Forwards Pragma Proxy-Authorization Range Referer TE Trailer
+ Transfer-Encoding Upgrade User-Agent Via
+);
+
+my @other_request_headers = qw(
+ Content-Encoding Content-MD5 Content-Type Cookie DNT Date Origin
+ X-XSS-Protection
);
+my %HeaderCase = map { lc($_) => $_ } @rfc_request_headers, @other_request_headers;
+
# to avoid multiple small writes and hence nagle, you can pass the method line or anything else to
# combine writes.
sub write_header_lines {
- (@_ == 2 || @_ == 3 && ref $_[1] eq 'HASH') || die(q/Usage: $handle->write_header_lines(headers[,prefix])/ . "\n");
- my($self, $headers, $prefix_data) = @_;
+ (@_ >= 2 && @_ <= 4 && ref $_[1] eq 'HASH') || die(q/Usage: $handle->write_header_lines(headers, [header_case, prefix])/ . "\n");
+ my($self, $headers, $header_case, $prefix_data) = @_;
+ $header_case ||= {};
my $buf = (defined $prefix_data ? $prefix_data : '');
+
+ # Per RFC, control fields should be listed first
+ my %seen;
+ for my $k ( qw/host cache-control expect max-forwards pragma range te/ ) {
+ next unless exists $headers->{$k};
+ $seen{$k}++;
+ my $field_name = $HeaderCase{$k};
+ my $v = $headers->{$k};
+ for (ref $v eq 'ARRAY' ? @$v : $v) {
+ $_ = '' unless defined $_;
+ $buf .= "$field_name: $_\x0D\x0A";
+ }
+ }
+
+ # Other headers sent in arbitrary order
while (my ($k, $v) = each %$headers) {
my $field_name = lc $k;
+ next if $seen{$field_name};
if (exists $HeaderCase{$field_name}) {
$field_name = $HeaderCase{$field_name};
}
else {
+ if (exists $header_case->{$field_name}) {
+ $field_name = $header_case->{$field_name};
+ }
+ else {
+ $field_name =~ s/\b(\w)/\u$1/g;
+ }
$field_name =~ /\A $Token+ \z/xo
or die(q/Invalid HTTP header field name: / . $Printable->($field_name) . "\n");
- $field_name =~ s/\b(\w)/\u$1/g;
$HeaderCase{lc $field_name} = $field_name;
}
for (ref $v eq 'ARRAY' ? @$v : $v) {
+ # unwrap a field value if pre-wrapped by user
+ s/\x0D?\x0A\s+/ /g;
+ die(qq/Invalid HTTP header field value ($field_name): / . $Printable->($_). "\n")
+ unless $_ eq '' || /\A $Field_Content \z/xo;
$_ = '' unless defined $_;
$buf .= "$field_name: $_\x0D\x0A";
}
}
sub write_request_header {
- @_ == 4 || die(q/Usage: $handle->write_request_header(method, request_uri, headers)/ . "\n");
- my ($self, $method, $request_uri, $headers) = @_;
+ @_ == 5 || die(q/Usage: $handle->write_request_header(method, request_uri, headers, header_case)/ . "\n");
+ my ($self, $method, $request_uri, $headers, $header_case) = @_;
- return $self->write_header_lines($headers, "$method $request_uri HTTP/1.1\x0D\x0A");
+ return $self->write_header_lines($headers, $header_case, "$method $request_uri HTTP/1.1\x0D\x0A");
}
sub _do_timeout {
}
sub can_reuse {
- my ($self,$scheme,$host,$port) = @_;
+ my ($self,$scheme,$host,$port,$peer) = @_;
return 0 if
$self->{pid} != $$
|| $self->{tid} != _get_tid()
|| $scheme ne $self->{scheme}
|| $host ne $self->{host}
|| $port ne $self->{port}
+ || $peer ne $self->{peer}
|| eval { $self->can_read(0) }
|| $@ ;
return 1;
sub _find_CA_file {
my $self = shift();
- if ( $self->{SSL_options}->{SSL_ca_file} ) {
- unless ( -r $self->{SSL_options}->{SSL_ca_file} ) {
- die qq/SSL_ca_file '$self->{SSL_options}->{SSL_ca_file}' not found or not readable\n/;
+ my $ca_file =
+ defined( $self->{SSL_options}->{SSL_ca_file} )
+ ? $self->{SSL_options}->{SSL_ca_file}
+ : $ENV{SSL_CERT_FILE};
+
+ if ( defined $ca_file ) {
+ unless ( -r $ca_file ) {
+ die qq/SSL_ca_file '$ca_file' not found or not readable\n/;
}
- return $self->{SSL_options}->{SSL_ca_file};
+ return $ca_file;
}
return Mozilla::CA::SSL_ca_file()
=head1 VERSION
-version 0.056
+version 0.058
=head1 SYNOPSIS
=item *
-C<timeout> — Request timeout in seconds (default is 60)
+C<timeout> — Request timeout in seconds (default is 60) If a socket open, read or write takes longer than the timeout, an exception is thrown.
=item *
C<data_callback> — A code reference that will be called for each chunks of the response body received.
+=item *
+
+C<peer> — Override host resolution and force all connections to go only to a specific peer address, regardless of the URL of the request. This will include any redirections! This options should be used with extreme caution (e.g. debugging or very special circumstances).
+
=back
The C<Host> header is generated from the URL in accordance with RFC 2616. It
C<headers> — A hashref of header fields. All header field names will be normalized to be lower case. If a header is repeated, the value will be an arrayref; it will otherwise be a scalar string containing the value
+=item *
+
+C<redirects> If this field exists, it is an arrayref of response hash references from redirects in the same order that redirections occurred. If it does not exist, then no redirections occurred.
+
=back
On an exception during the execution of the request, the C<status> field will
In list context, returns the boolean and a (possibly multi-line) string of
errors indicating why SSL isn't available.
+=head2 connected
+
+ $host = $http->connected;
+ ($host, $port) = $http->connected;
+
+Indicates if a connection to a peer is being kept alive, per the C<keep_alive>
+option.
+
+In scalar context, returns the peer host and port, joined with a colon, or
+C<undef> (if no peer is connected).
+In list context, returns the peer host and port or an empty list (if no peer
+is connected).
+
+B<Note>: This method cannot reliably be used to discover whether the remote
+host has closed its end of the socket.
+
=for Pod::Coverage SSL_options
agent
cookie_jar
concerned about security, you should enable this option.
Certificate verification requires a file containing trusted CA certificates.
+
+If the environment variable C<SSL_CERT_FILE> is present, HTTP::Tiny
+will try to find a CA certificate file in that location.
+
If the L<Mozilla::CA> module is installed, HTTP::Tiny will use the CA file
included with it as a source of trusted CA's. (This means you trust Mozilla,
the author of Mozilla::CA, the CPAN mirror where you got Mozilla::CA, the
There is no support for a Request-URI of '*' for the 'OPTIONS' request.
+=item *
+
+Headers mentioned in the RFCs and some other, well-known headers are
+generated with their canonical case. Other headers are sent in the
+case provided by the user. Except for control headers (which are sent first),
+headers are sent in arbitrary order.
+
=back
Despite the limitations listed above, HTTP::Tiny is considered
=head1 CONTRIBUTORS
-=for stopwords Alan Gardner Alessandro Ghedini Brad Gilbert Chris Nehren Weyl Claes Jakobsson Clinton Gormley Dean Pearce Edward Zborowski James Raspass Jeremy Mates Jess Robinson Lukas Eklund Martin J. Evans Martin-Louis Bright Mike Doherty Olaf Alders Olivier Mengué Petr Písař Sören Kornetzki Syohei YOSHIDA Tatsuhiko Miyagawa Tom Hukins Tony Cook
+=for stopwords Alan Gardner Alessandro Ghedini A. Sinan Unur Brad Gilbert brian m. carlson Chris Nehren Weyl Claes Jakobsson Clinton Gormley David Golden Dean Pearce Edward Zborowski James Raspass Jeremy Mates Jess Robinson Lukas Eklund Martin J. Evans Martin-Louis Bright Mike Doherty Olaf Alders Olivier Mengué Petr Písař SkyMarshal Sören Kornetzki Syohei YOSHIDA Tatsuhiko Miyagawa Tom Hukins Tony Cook
=over 4
=item *
+A. Sinan Unur <nanis@cpan.org>
+
+=item *
+
Brad Gilbert <bgills@cpan.org>
=item *
+brian m. carlson <sandals@crustytoothpaste.net>
+
+=item *
+
Chris Nehren <apeiron@cpan.org>
=item *
=item *
+David Golden <xdg@xdg.me>
+
+=item *
+
Dean Pearce <pearce@pythian.com>
=item *
=item *
+SkyMarshal <skymarshal1729@gmail.com>
+
+=item *
+
Sören Kornetzki <soeren.kornetzki@delti.com>
=item *
=head1 COPYRIGHT AND LICENSE
-This software is copyright (c) 2015 by Christian Hansen.
+This software is copyright (c) 2016 by Christian Hansen.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
);
my @methods = qw(
new get head put post delete post_form request mirror www_form_urlencode can_ssl
+ connected
);
my %api;
else {
$check_expected->( $response->{content}, "$label content" );
}
+
+ ok ( ! exists $response->{redirects}, "$label redirects array doesn't exist")
+ or diag explain $response->{redirects};
}
done_testing;
open my $fh, ">", $tempfile;
close $fh;
utime $mtime, $mtime, $tempfile;
+ if ($^O eq 'MSWin32') {
+ # Deal with stat and daylight savings issues on Windows
+ # by reading back mtime
+ $timestamp{$url_basename} = (stat $tempfile)[9];
+ }
}
# setup mocking and test
my $data = do { local (@ARGV,$/) = $file; <> };
my ($params, @case_pairs) = split /--+\n/, $data;
my $case = parse_case($params);
+ my $number_of_requests = @case_pairs / 2;
my $url = $case->{url}[0];
my $method = $case->{method}[0] || 'GET';
my $http = HTTP::Tiny->new(keep_alive => 0, %new_args);
my $response = $http->request(@$call_args);
-
- my $calls = 0
- + (defined($new_args{max_redirect}) ? $new_args{max_redirect} : 5);
+ my $max_redirects = defined($new_args{max_redirect}) ? $new_args{max_redirect} : 5;
+ my $calls = 0 + $max_redirects;
for my $i ( 0 .. $calls ) {
last unless @socket_pairs;
is ( $response->{content}, $exp_content, "$label content" );
+ my $number_of_redirects =
+ $max_redirects < $number_of_requests ? $max_redirects : $number_of_requests - 1;
+ is ( @{ $response->{redirects} || [] }, $number_of_redirects,
+ "$label redirects array size"
+ ) or diag explain $response->{redirects};
+
if ( $case->{expected_url} ) {
is ( $response->{url}, $case->{expected_url}[0], "$label response URL" );
}
*HTTP::Tiny::Handle::can_read = sub {1};
*HTTP::Tiny::Handle::can_write = sub {1};
*HTTP::Tiny::Handle::connect = sub {
- my ($self, $scheme, $host, $port) = @_;
+ my ($self, $scheme, $host, $port, $peer) = @_;
$self->{host} = $monkey_host = $host;
$self->{port} = $monkey_port = $port;
+ $self->{peer} = $peer;
$self->{scheme} = $scheme;
$self->{fh} = shift @req_fh;
$self->{pid} = $$;
$json_opt = '' if $json_opt eq '-';
-my @json_opt = grep { $allow_json_opt{ $_ } or die "'$_' is invalid json opttion" } split/,/, $json_opt;
+my @json_opt = grep { $allow_json_opt{ $_ } or die "'$_' is not a valid json option" } split/,/, $json_opt;
my %F = (
'json' => sub {
use B ();
#use Devel::Peek;
-$JSON::PP::VERSION = '2.27300';
+$JSON::PP::VERSION = '2.27400';
@JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json);
allow_barekey escape_slash as_nonblessed
);
- # Perl version check, Unicode handling is enable?
+ # Perl version check, Unicode handling is enabled?
# Helper module sets @JSON::PP::_properties.
if ($] < 5.008 ) {
my $helper = $] >= 5.006 ? 'JSON::PP::Compat5006' : 'JSON::PP::Compat5005';
my $text; # json data
my $at; # offset
- my $ch; # 1chracter
+ my $ch; # first character
my $len; # text length (changed according to UTF8 or NON UTF8)
# INTERNAL
my $depth; # nest counter
my $utf8_len; # utf8 byte length
# FLAGS
my $utf8; # must be utf8
- my $max_depth; # max nest nubmer of objects and arrays
+ my $max_depth; # max nest number of objects and arrays
my $max_size;
my $relaxed;
my $cb_object;
sub number {
my $n = '';
my $v;
+ my $is_dec;
- # According to RFC4627, hex or oct digts are invalid.
+ # According to RFC4627, hex or oct digits are invalid.
if($ch eq '0'){
my $peek = substr($text,$at,1);
my $hex = $peek =~ /[xX]/; # 0 or 1
if(defined $ch and $ch eq '.'){
$n .= '.';
+ $is_dec = 1;
next_chr;
if (!defined $ch or $ch !~ /\d/) {
return Math::BigFloat->new($v);
}
- return 0+$v;
+ return $is_dec ? $v/1.0 : 0+$v;
}
$_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;
if ( $_[0]->{_incr_parser}->{incr_parsing} ) {
- Carp::croak("incr_text can not be called when the incremental parser already started parsing");
+ Carp::croak("incr_text cannot be called when the incremental parser already started parsing");
}
$_[0]->{_incr_parser}->{incr_text};
}
}
-# shamely copied and modified from JSON::XS code.
+# shamelessly copied and modified from JSON::XS code.
$JSON::PP::true = do { bless \(my $dummy = 1), "JSON::PP::Boolean" };
$JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" };
sub incr_text {
if ( $_[0]->{incr_parsing} ) {
- Carp::croak("incr_text can not be called when the incremental parser already started parsing");
+ Carp::croak("incr_text cannot be called when the incremental parser already started parsing");
}
$_[0]->{incr_text};
}
=head1 VERSION
- 2.27300
+ 2.27400
L<JSON::XS> 2.27 (~2.30) compatible.
=head1 NOTE
-JSON::PP had been inculded in JSON distribution (CPAN module).
+JSON::PP had been included in JSON distribution (CPAN module).
It was a perl core module in Perl 5.14.
=head1 DESCRIPTION
There is no guessing, no generating of illegal JSON texts by default,
and only JSON is accepted as input by default (the latter is a security feature).
-But when some options are set, loose chcking features are available.
+But when some options are set, loose checking features are available.
=back
=head1 HOW DO I DECODE A DATA FROM OUTER AND ENCODE TO OUTER
-This section supposes that your perl vresion is 5.8 or later.
+This section supposes that your perl version is 5.8 or later.
If you know a JSON text from an outer world - a network, a file content, and so on,
is encoded in UTF-8, you should use C<decode_json> or C<JSON> module object
-with C<utf8> enable. And the decoded result will contain UNICODE characters.
+with C<utf8> enabled. And the decoded result will contain UNICODE characters.
# from network
my $json = JSON::PP->new->utf8;
# $unicode_json_text = <$fh>;
In this case, C<$unicode_json_text> is of course UNICODE string.
-So you B<cannot> use C<decode_json> nor C<JSON> module object with C<utf8> enable.
+So you B<cannot> use C<decode_json> nor C<JSON> module object with C<utf8> enabled.
Instead of them, you use C<JSON> module object with C<utf8> disable.
$perl_scalar = $json->utf8(0)->decode( $unicode_json_text );
send it to an outer world - a network or a file content, and so on.
Your data usually contains UNICODE strings and you want the converted data to be encoded
-in UTF-8, you should use C<encode_json> or C<JSON> module object with C<utf8> enable.
+in UTF-8, you should use C<encode_json> or C<JSON> module object with C<utf8> enabled.
print encode_json( $perl_scalar ); # to a network? file? or display?
# or
If C<$perl_scalar> does not contain UNICODE but C<$encoding>-encoded strings
for some reason, then its characters are regarded as B<latin1> for perl
(because it does not concern with your $encoding).
-You B<cannot> use C<encode_json> nor C<JSON> module object with C<utf8> enable.
+You B<cannot> use C<encode_json> nor C<JSON> module object with C<utf8> enabled.
Instead of them, you use C<JSON> module object with C<utf8> disable.
Note that the resulted text is a UNICODE string but no problem to print it.
$json = JSON::PP->new
-Rturns a new JSON::PP object that can be used to de/encode JSON
+Returns a new JSON::PP object that can be used to de/encode JSON
strings.
All boolean flags described below are by default I<disabled>.
This setting has no effect when decoding JSON texts.
-If you want your own sorting routine, you can give a code referece
+If you want your own sorting routine, you can give a code reference
or a subroutine name to C<sort_by>. See to C<JSON::PP OWN METHODS>.
=head2 allow_nonref
If no argument is given, the highest possible setting will be used, which
is rarely useful.
-See L<JSON::XS/SSECURITY CONSIDERATIONS> for more info on why this is useful.
+See L<JSON::XS/SECURITY CONSIDERATIONS> for more info on why this is useful.
When a large value (100 or more) was set and it de/encodes a deep nested object/text,
-it may raise a warning 'Deep recursion on subroutin' at the perl runtime phase.
+it may raise a warning 'Deep recursion on subroutine' at the perl runtime phase.
=head2 max_size
If no argument is given, the limit check will be deactivated (same as when
C<0> is specified).
-See L<JSON::XS/SSECURITY CONSIDERATIONS> for more info on why this is useful.
+See L<JSON::XS/SECURITY CONSIDERATIONS> for more info on why this is useful.
=head2 encode
This module will only attempt to parse the JSON text once it is sure it
has enough text to get a decisive result, using a very simple but
truly incremental parser. This means that it sometimes won't stop as
-early as the full parser, for example, it doesn't detect parenthese
+early as the full parser, for example, it doesn't detect parentheses
mismatches. The only thing it guarantees is that it starts decoding as
soon as a syntactically valid JSON text has been seen. This means you need
to set resource limits (e.g. C<max_size>) to ensure the parser will stop
exactly I<one> JSON object. If that is successful, it will return this
object, otherwise it will return C<undef>. If there is a parse error,
this method will croak just as C<decode> would do (one can then use
-C<incr_skip> to skip the errornous part). This is the most common way of
+C<incr_skip> to skip the erroneous part). This is the most common way of
using the method.
And finally, in list context, it will try to extract as many objects
This completely resets the incremental parser, that is, after this call,
it will be as if the parser had never parsed anything.
-This is useful if you want ot repeatedly parse JSON objects and want to
+This is useful if you want to repeatedly parse JSON objects and want to
ignore any trailing data, which means you have to reset the parser after
each successful decode.
the big integer Perl cannot handle as integer into a L<Math::BigInt>
object and convert a floating number (any) into a L<Math::BigFloat>.
-On the contary, C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
-objects into JSON numbers with C<allow_blessed> enable.
+On the contrary, C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
+objects into JSON numbers with C<allow_blessed> enabled.
$json->allow_nonref->allow_blessed->allow_bignum;
$bigfloat = $json->decode('2.000000000000000000000000001');
print $json->encode($bigfloat);
# => 2.000000000000000000000000001
-See to L<JSON::XS/MAPPING> aboout the normal conversion of JSON number.
+See to L<JSON::XS/MAPPING> about the normal conversion of JSON number.
=head2 loose
$json = $json->loose([$enable])
The unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid in JSON strings
-and the module doesn't allow to C<decode> to these (except for \x2f).
+and the module doesn't allow you to C<decode> to these (except for \x2f).
If C<$enable> is true (or missing), then C<decode> will accept these
unescaped strings.
$json->loose->decode(qq|["abc
def"]|);
-See L<JSON::XS/SSECURITY CONSIDERATIONS>.
+See L<JSON::XS/SECURITY CONSIDERATIONS>.
=head2 escape_slash
a numeric (floating point) value if that is possible without loss of
precision. Otherwise it will preserve the number as a string value (in
which case you lose roundtripping ability, as the JSON number will be
-re-encoded toa JSON string).
+re-encoded to a JSON string).
Numbers containing a fractional or exponential part will always be
represented as numeric (floating point) values, possibly at a loss of
Note that precision is not accuracy - binary floating point values cannot
represent most decimal fractions exactly, and when converting from and to
floating point, C<JSON> only guarantees precision up to but not including
-the leats significant bit.
+the least significant bit.
-When C<allow_bignum> is enable, the big integers
+When C<allow_bignum> is enabled, the big integers
and the numeric can be optionally converted into L<Math::BigInt> and
L<Math::BigFloat> objects.
These JSON atoms become C<JSON::PP::true> and C<JSON::PP::false>,
respectively. They are overloaded to act almost exactly like the numbers
-C<1> and C<0>. You can check wether a scalar is a JSON boolean by using
+C<1> and C<0>. You can check whether a scalar is a JSON boolean by using
the C<JSON::is_bool> function.
print JSON::PP::true . "\n";
A JSON null atom becomes C<undef> in Perl.
-C<JSON::PP::null> returns C<unddef>.
+C<JSON::PP::null> returns C<undef>.
=back
my $x = "3"; # some variable containing a string
$x += 0; # numify it, ensuring it will be dumped as a number
- $x *= 1; # same thing, the choise is yours.
+ $x *= 1; # same thing, the choice is yours.
-You can not currently force the type in other, less obscure, ways.
+You cannot currently force the type in other, less obscure, ways.
Note that numerical precision has the same meaning as under Perl (so
binary to decimal conversion follows the same rules as in Perl, which
=item Big Number
-When C<allow_bignum> is enable,
+When C<allow_bignum> is enabled,
C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
objects into JSON numbers.
$json->allow_nonref->encode(chr hex 3042);
$json->allow_nonref->encode(chr hex 12345);
-Reuturns C<"\u3042"> and C<"\ud808\udf45"> respectively.
+Returns C<"\u3042"> and C<"\ud808\udf45"> respectively.
$json->allow_nonref->decode('"\u3042"');
$json->allow_nonref->decode('"\ud808\udf45"');
=head2 Perl 5.005
-Perl 5.005 is a byte sementics world -- all strings are sequences of bytes.
+Perl 5.005 is a byte semantics world -- all strings are sequences of bytes.
That means the unicode handling is not available.
In encoding,
$json->decode('"\u00e3\u0081\u0082"');
The returned is a byte sequence C<0xE3 0x81 0x82> for UTF-8 encoded
-japanese character (C<HIRAGANA LETTER A>).
+Japanese character (C<HIRAGANA LETTER A>).
And if it is represented in Unicode code point, C<U+3042>.
Next,
=head1 COPYRIGHT AND LICENSE
-Copyright 2007-2014 by Makamaka Hannyaharamitu
+Copyright 2007-2016 by Makamaka Hannyaharamitu
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
#! perl
-# use the testsuite from http://www.json.org/JSON::PP_checker/
+# use the testsuite from http://www.json.org/JSON_checker/
# except for fail18.json, as we do not support a depth of 20 (but 16 and 32).
# copied over from JSON::PP::XS and modified to use JSON::PP
$j->incr_text;
};
-like( $@, qr/incr_text can not be called when the incremental parser already started parsing/ );
+like( $@, qr/incr_text cannot be called when the incremental parser already started parsing/ );
$object = $j->incr_parse($parts[1]);
my $utf8 = $json->decode(q|"\ud808\udf45"|); # chr 12345
-utf8::encode($utf8); # UTf-8 flaged off
+utf8::encode($utf8); # UTF-8 flagged off
is($utf8, "\xf0\x92\x8d\x85");
# $Retired{ TYPE }{ CODESET }{ code }{ CODE } = NAME
# { name }{ NAME } = [CODE,NAME] (the key is lowercase)
-$VERSION='3.38';
+$VERSION='3.39';
#=======================================================================
#
=head1 VERSION 3.40 (planned 2016-09-01; sbeck)
-=head1 VERSION 3.39 (planned 2016-06-01; sbeck)
+=head1 VERSION 3.39 (2016-05-31; sbeck)
+
+No new codes (for the existing codesets).
+
+=over 4
+
+=item B<Added UN codes back in>
+
+The UN codes have been added back in as their own list of codes.
+Jarkko Hietaniemi
+
+=item B<Added GENC codes>
+
+The GENC codes have been added. These are the new US Government codes
+that replace the FIPS-10 codes. They are based on, but not identical to
+the ISO 3166 codes.
+
+=back
=head1 VERSION 3.38 (2016-03-02; sbeck)
our($VERSION,@ISA,@EXPORT);
our(%ALL_CODESETS);
-$VERSION='3.38';
+$VERSION='3.39';
@ISA = qw(Exporter);
@EXPORT = qw(LOCALE_CODE_ALPHA_2
LOCALE_CODE_ALPHA_3
LOCALE_CODE_NUMERIC
LOCALE_CODE_DOM
+ LOCALE_CODE_UN_NUMERIC
+ LOCALE_CODE_UN_ALPHA_3
+ LOCALE_CODE_GENC_ALPHA_2
+ LOCALE_CODE_GENC_ALPHA_3
+ LOCALE_CODE_GENC_NUMERIC
LOCALE_LANG_ALPHA_2
LOCALE_LANG_ALPHA_3
# Constants
#-----------------------------------------------------------------------
-use constant LOCALE_CODE_ALPHA_2 => 'alpha-2';
-use constant LOCALE_CODE_ALPHA_3 => 'alpha-3';
-use constant LOCALE_CODE_NUMERIC => 'numeric';
-use constant LOCALE_CODE_DOM => 'dom';
+use constant LOCALE_CODE_ALPHA_2 => 'alpha-2';
+use constant LOCALE_CODE_ALPHA_3 => 'alpha-3';
+use constant LOCALE_CODE_NUMERIC => 'numeric';
+use constant LOCALE_CODE_DOM => 'dom';
+use constant LOCALE_CODE_UN_ALPHA_3 => 'un-alpha-3';
+use constant LOCALE_CODE_UN_NUMERIC => 'un-numeric';
+use constant LOCALE_CODE_GENC_ALPHA_2 => 'genc-alpha-2';
+use constant LOCALE_CODE_GENC_ALPHA_3 => 'genc-alpha-3';
+use constant LOCALE_CODE_GENC_NUMERIC => 'genc-numeric';
$ALL_CODESETS{'country'} = {
'default' => 'alpha-2',
- 'codesets' => { 'alpha-2' => ['lc'],
- 'alpha-3' => ['lc'],
- 'numeric' => ['numeric',3],
- 'dom' => ['lc'],
+ 'codesets' => { 'alpha-2' => ['lc'],
+ 'alpha-3' => ['lc'],
+ 'numeric' => ['numeric',3],
+ 'dom' => ['lc'],
+ 'un-alpha-3' => ['uc'],
+ 'un-numeric' => ['numeric',3],
+ 'genc-alpha-2' => ['uc'],
+ 'genc-alpha-3' => ['uc'],
+ 'genc-numeric' => ['numeric',3],
}
};
our($VERSION,@ISA,@EXPORT,@EXPORT_OK);
-$VERSION='3.38';
+$VERSION='3.39';
@ISA = qw(Exporter);
@EXPORT = qw(code2country
country2code
domains. The country domains are the two-letter (lowercase) codes from ISO 3166
with a few other additions.
+=item B<un-alpha-3, LOCALE_CODE_UN_ALPHA_3>
+
+=item B<un-numeric, LOCALE_CODE_UN_NUMERIC>
+
+The UN maintains a list of codes that is similar, but not identical, to the
+standard ISO 3166 lists. They maintain a 3-letter code (similar to alpha-3)
+and a numeric code (similar to numeric).
+
+=item B<genc-alpha-2, LOCALE_CODE_GENC_ALPHA_2>
+
+=item B<genc-alpha-3, LOCALE_CODE_GENC_ALPHA_3>
+
+=item B<genc-numeric, LOCALE_CODE_GENC_NUMERIC>
+
+The GENC codes are the US Government codes that replace the FIPS-11 codes.
+They are based on, but not identical to the standard ISO 3166 lists.
+
=back
NOTE: As of version 3.27, the FIPS code set is no longer supported. See the
=item L<http://unstats.un.org/unsd/methods/m49/m49alpha.htm>
-The source of the official ISO 3166-1 three-letter codes and
-three-digit codes.
+The source of the UN codes.
+
+Previously, this table was treated as a source of the ISO 3166 data,
+but I found that the table was incomplete, so I stopped using it.
+Later, it was added back in as it's own list of codes.
+
+=item L<https://nsgreg.nga.mil/genc/discovery>
-For some reason, this table is incomplete! Several countries are
-missing from it, and I cannot find them anywhere on the UN site. I
-no longer use this as a source of data.
+The source of the GENC codes.
=item L<https://www.cia.gov/library/publications/the-world-factbook/appendix/print_appendix-d.html>
# This file was automatically generated. Any changes to this file will
# be lost the next time 'harvest_data' is run.
-# Generated on: Wed Mar 2 08:57:53 EST 2016
+# Generated on: Wed May 25 11:27:17 EDT 2016
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.38';
+$VERSION='3.39';
-$Locale::Codes::Data{'country'}{'id'} = '0250';
+$Locale::Codes::Data{'country'}{'id'} = '0283';
$Locale::Codes::Data{'country'}{'id2names'} = {
q(0001) => [
],
q(0028) => [
q(Bonaire, Sint Eustatius and Saba),
+ q(Bonaire, Sint Eustatius, and Saba),
],
q(0029) => [
q(Bosnia and Herzegovina),
q(The Democratic People's Republic of Korea),
q(Democratic People's Republic of Korea),
q(North Korea),
+ q(Korea, North),
],
q(0119) => [
q(Korea, The Republic of),
q(The Republic of Korea),
q(Republic of Korea),
q(South Korea),
+ q(Korea, South),
],
q(0120) => [
q(Kuwait),
q(The Lao People's Democratic Republic),
q(Lao People's Democratic Republic, The),
q(Lao People's Democratic Republic (The)),
+ q(Laos),
],
q(0123) => [
q(Latvia),
q(Moldova (Republic of)),
q(The Republic of Moldova),
q(Republic of Moldova),
+ q(Moldova),
],
q(0147) => [
q(Monaco),
q(The Russian Federation),
q(Russian Federation, The),
q(Russian Federation (The)),
+ q(Russia),
],
q(0184) => [
q(Rwanda),
q(0186) => [
q(Saint Helena, Ascension and Tristan da Cunha),
q(Saint Helena),
+ q(Saint Helena, Ascension, and Tristan Da Cunha),
],
q(0187) => [
q(Saint Kitts and Nevis),
],
q(0201) => [
q(Sint Maarten (Dutch part)),
+ q(Sint Maarten),
],
q(0202) => [
q(Slovakia),
q(0207) => [
q(South Georgia and the South Sandwich Islands),
q(South Georgia and the Islands),
+ q(South Georgia and South Sandwich Islands),
],
q(0208) => [
q(South Sudan),
q(Tanzania, United Republic of),
q(Tanzania (United Republic of)),
q(United Republic of Tanzania),
+ q(Tanzania),
],
q(0221) => [
q(Thailand),
q(Republic of Zimbabwe, The),
q(Republic of Zimbabwe (The)),
],
+ q(0250) => [
+ q(Channel Islands),
+ ],
+ q(0251) => [
+ q(Sark),
+ ],
+ q(0252) => [
+ q(Akrotiri),
+ ],
+ q(0253) => [
+ q(Ashmore and Cartier Islands),
+ ],
+ q(0254) => [
+ q(Baker Island),
+ ],
+ q(0255) => [
+ q(Bassas Da India),
+ ],
+ q(0256) => [
+ q(Clipperton Island),
+ ],
+ q(0257) => [
+ q(Coral Sea Islands),
+ ],
+ q(0258) => [
+ q(Dhekelia),
+ ],
+ q(0259) => [
+ q(Diego Garcia),
+ ],
+ q(0260) => [
+ q(Entity 1),
+ q(Entity 2),
+ q(Entity 3),
+ q(Entity 4),
+ q(Entity 5),
+ ],
+ q(0261) => [
+ q(Entity 6),
+ ],
+ q(0262) => [
+ q(Europa Island),
+ ],
+ q(0263) => [
+ q(Gaza Strip),
+ ],
+ q(0264) => [
+ q(Glorioso Islands),
+ ],
+ q(0265) => [
+ q(Guantanamo Bay Naval Base),
+ ],
+ q(0266) => [
+ q(Howland Island),
+ ],
+ q(0267) => [
+ q(Jan Mayen),
+ ],
+ q(0268) => [
+ q(Jarvis Island),
+ ],
+ q(0269) => [
+ q(Johnston Atoll),
+ ],
+ q(0270) => [
+ q(Juan de Nova Island),
+ ],
+ q(0271) => [
+ q(Kingman Reef),
+ ],
+ q(0272) => [
+ q(Kosovo),
+ ],
+ q(0273) => [
+ q(Midway Islands),
+ ],
+ q(0274) => [
+ q(Navassa Island),
+ ],
+ q(0275) => [
+ q(Palmyra Atoll),
+ ],
+ q(0276) => [
+ q(Paracel Islands),
+ ],
+ q(0277) => [
+ q(Spratly Islands),
+ ],
+ q(0278) => [
+ q(Svalbard),
+ ],
+ q(0279) => [
+ q(Tromelin Island),
+ ],
+ q(0280) => [
+ q(Unknown),
+ ],
+ q(0281) => [
+ q(Wake Island),
+ ],
+ q(0282) => [
+ q(West Bank),
+ ],
};
$Locale::Codes::Data{'country'}{'alias2id'} = {
q(0001),
q(0),
],
+ q(akrotiri) => [
+ q(0252),
+ q(0),
+ ],
q(aland islands) => [
q(0002),
q(0),
q(0013),
q(0),
],
+ q(ashmore and cartier islands) => [
+ q(0253),
+ q(0),
+ ],
q(australia) => [
q(0014),
q(0),
q(0018),
q(0),
],
+ q(baker island) => [
+ q(0254),
+ q(0),
+ ],
q(bangladesh) => [
q(0019),
q(0),
q(0020),
q(0),
],
+ q(bassas da india) => [
+ q(0255),
+ q(0),
+ ],
q(belarus) => [
q(0021),
q(0),
q(0028),
q(0),
],
+ q(bonaire, sint eustatius, and saba) => [
+ q(0028),
+ q(1),
+ ],
q(bosnia and herzegovina) => [
q(0029),
q(0),
q(0044),
q(0),
],
+ q(channel islands) => [
+ q(0250),
+ q(0),
+ ],
q(chile) => [
q(0045),
q(0),
q(0047),
q(0),
],
+ q(clipperton island) => [
+ q(0256),
+ q(0),
+ ],
q(cocos (keeling) islands) => [
q(0048),
q(0),
q(0053),
q(2),
],
+ q(coral sea islands) => [
+ q(0257),
+ q(0),
+ ],
q(costa rica) => [
q(0054),
q(0),
q(0061),
q(0),
],
+ q(dhekelia) => [
+ q(0258),
+ q(0),
+ ],
+ q(diego garcia) => [
+ q(0259),
+ q(0),
+ ],
q(djibouti) => [
q(0062),
q(0),
q(0067),
q(0),
],
+ q(entity 1) => [
+ q(0260),
+ q(0),
+ ],
+ q(entity 2) => [
+ q(0260),
+ q(1),
+ ],
+ q(entity 3) => [
+ q(0260),
+ q(2),
+ ],
+ q(entity 4) => [
+ q(0260),
+ q(3),
+ ],
+ q(entity 5) => [
+ q(0260),
+ q(4),
+ ],
+ q(entity 6) => [
+ q(0261),
+ q(0),
+ ],
q(equatorial guinea) => [
q(0068),
q(0),
q(0071),
q(0),
],
+ q(europa island) => [
+ q(0262),
+ q(0),
+ ],
q(faeroe islands) => [
q(0073),
q(4),
q(0081),
q(2),
],
+ q(gaza strip) => [
+ q(0263),
+ q(0),
+ ],
q(georgia) => [
q(0082),
q(0),
q(0085),
q(0),
],
+ q(glorioso islands) => [
+ q(0264),
+ q(0),
+ ],
q(great britain) => [
q(0235),
q(4),
q(0090),
q(0),
],
+ q(guantanamo bay naval base) => [
+ q(0265),
+ q(0),
+ ],
q(guatemala) => [
q(0091),
q(0),
q(0100),
q(3),
],
+ q(howland island) => [
+ q(0266),
+ q(0),
+ ],
q(hungary) => [
q(0101),
q(0),
q(0111),
q(0),
],
+ q(jan mayen) => [
+ q(0267),
+ q(0),
+ ],
q(japan) => [
q(0112),
q(0),
],
+ q(jarvis island) => [
+ q(0268),
+ q(0),
+ ],
q(jersey) => [
q(0113),
q(0),
],
+ q(johnston atoll) => [
+ q(0269),
+ q(0),
+ ],
q(jordan) => [
q(0114),
q(0),
],
+ q(juan de nova island) => [
+ q(0270),
+ q(0),
+ ],
q(kazakhstan) => [
q(0115),
q(0),
q(0116),
q(0),
],
+ q(kingman reef) => [
+ q(0271),
+ q(0),
+ ],
q(kiribati) => [
q(0117),
q(0),
q(0118),
q(2),
],
+ q(korea, north) => [
+ q(0118),
+ q(7),
+ ],
q(korea, republic of) => [
q(0119),
q(2),
],
+ q(korea, south) => [
+ q(0119),
+ q(7),
+ ],
q(korea, the democratic people's republic of) => [
q(0118),
q(0),
q(0119),
q(0),
],
+ q(kosovo) => [
+ q(0272),
+ q(0),
+ ],
q(kuwait) => [
q(0120),
q(0),
q(0122),
q(2),
],
+ q(laos) => [
+ q(0122),
+ q(4),
+ ],
q(latvia) => [
q(0123),
q(0),
q(0145),
q(4),
],
+ q(midway islands) => [
+ q(0273),
+ q(0),
+ ],
+ q(moldova) => [
+ q(0146),
+ q(6),
+ ],
q(moldova (republic of)) => [
q(0146),
q(3),
q(0155),
q(0),
],
+ q(navassa island) => [
+ q(0274),
+ q(0),
+ ],
q(nepal) => [
q(0156),
q(0),
q(0170),
q(0),
],
+ q(palmyra atoll) => [
+ q(0275),
+ q(0),
+ ],
q(panama) => [
q(0171),
q(0),
q(0172),
q(0),
],
+ q(paracel islands) => [
+ q(0276),
+ q(0),
+ ],
q(paraguay) => [
q(0173),
q(0),
q(0182),
q(0),
],
+ q(russia) => [
+ q(0183),
+ q(4),
+ ],
q(russian federation) => [
q(0183),
q(0),
q(0186),
q(0),
],
+ q(saint helena, ascension, and tristan da cunha) => [
+ q(0186),
+ q(2),
+ ],
q(saint kitts and nevis) => [
q(0187),
q(0),
q(0194),
q(0),
],
+ q(sark) => [
+ q(0251),
+ q(0),
+ ],
q(saudi arabia) => [
q(0195),
q(0),
q(0200),
q(0),
],
+ q(sint maarten) => [
+ q(0201),
+ q(1),
+ ],
q(sint maarten (dutch part)) => [
q(0201),
q(0),
q(0206),
q(0),
],
+ q(south georgia and south sandwich islands) => [
+ q(0207),
+ q(2),
+ ],
q(south georgia and the islands) => [
q(0207),
q(1),
q(0209),
q(0),
],
+ q(spratly islands) => [
+ q(0277),
+ q(0),
+ ],
q(sri lanka) => [
q(0210),
q(0),
q(0212),
q(0),
],
+ q(svalbard) => [
+ q(0278),
+ q(0),
+ ],
q(svalbard and jan mayen) => [
q(0213),
q(0),
q(0219),
q(0),
],
+ q(tanzania) => [
+ q(0220),
+ q(3),
+ ],
q(tanzania (united republic of)) => [
q(0220),
q(1),
q(0226),
q(0),
],
+ q(tromelin island) => [
+ q(0279),
+ q(0),
+ ],
q(tunisia) => [
q(0227),
q(0),
q(0237),
q(6),
],
+ q(unknown) => [
+ q(0280),
+ q(0),
+ ],
q(uruguay) => [
q(0238),
q(0),
q(0244),
q(3),
],
+ q(wake island) => [
+ q(0281),
+ q(0),
+ ],
q(wallis and futuna) => [
q(0245),
q(0),
q(0245),
q(1),
],
+ q(west bank) => [
+ q(0282),
+ q(0),
+ ],
q(western sahara) => [
q(0246),
q(0),
q(0),
],
},
- q(numeric) => {
- q(004) => [
- q(0001),
+ q(genc-alpha-2) => {
+ q(A1) => [
+ q(0280),
q(0),
],
- q(008) => [
- q(0003),
+ q(A2) => [
+ q(0265),
q(0),
],
- q(010) => [
- q(0009),
+ q(A3) => [
+ q(0261),
q(0),
],
- q(012) => [
- q(0004),
+ q(AD) => [
+ q(0006),
q(0),
],
- q(016) => [
- q(0005),
+ q(AE) => [
+ q(0234),
q(0),
],
- q(020) => [
- q(0006),
+ q(AF) => [
+ q(0001),
q(0),
],
- q(024) => [
- q(0007),
+ q(AG) => [
+ q(0010),
q(0),
],
- q(028) => [
- q(0010),
+ q(AI) => [
+ q(0008),
q(0),
],
- q(031) => [
- q(0016),
+ q(AL) => [
+ q(0003),
q(0),
],
- q(032) => [
+ q(AM) => [
+ q(0012),
+ q(0),
+ ],
+ q(AO) => [
+ q(0007),
+ q(0),
+ ],
+ q(AQ) => [
+ q(0009),
+ q(0),
+ ],
+ q(AR) => [
q(0011),
q(0),
],
- q(036) => [
- q(0014),
+ q(AS) => [
+ q(0005),
q(0),
],
- q(040) => [
+ q(AT) => [
q(0015),
q(0),
],
- q(044) => [
- q(0017),
+ q(AU) => [
+ q(0014),
q(0),
],
- q(048) => [
- q(0018),
+ q(AW) => [
+ q(0013),
q(0),
],
- q(050) => [
- q(0019),
+ q(AZ) => [
+ q(0016),
q(0),
],
- q(051) => [
- q(0012),
+ q(BA) => [
+ q(0029),
q(0),
],
- q(052) => [
+ q(BB) => [
q(0020),
q(0),
],
- q(056) => [
- q(0022),
+ q(BD) => [
+ q(0019),
q(0),
],
- q(060) => [
- q(0025),
+ q(BE) => [
+ q(0022),
q(0),
],
- q(064) => [
- q(0026),
+ q(BF) => [
+ q(0036),
q(0),
],
- q(068) => [
- q(0027),
+ q(BG) => [
+ q(0035),
q(0),
],
- q(070) => [
- q(0029),
+ q(BH) => [
+ q(0018),
q(0),
],
- q(072) => [
- q(0030),
+ q(BI) => [
+ q(0037),
q(0),
],
- q(074) => [
- q(0031),
+ q(BJ) => [
+ q(0024),
q(0),
],
- q(076) => [
- q(0032),
+ q(BL) => [
+ q(0185),
q(0),
],
- q(084) => [
- q(0023),
+ q(BM) => [
+ q(0025),
q(0),
],
- q(086) => [
- q(0033),
+ q(BN) => [
+ q(0034),
q(0),
],
- q(090) => [
- q(0204),
+ q(BO) => [
+ q(0027),
q(0),
],
- q(092) => [
- q(0243),
- q(0),
+ q(BQ) => [
+ q(0028),
+ q(1),
],
- q(096) => [
- q(0034),
+ q(BR) => [
+ q(0032),
q(0),
],
- q(100) => [
- q(0035),
+ q(BS) => [
+ q(0017),
q(0),
],
- q(104) => [
- q(0153),
+ q(BT) => [
+ q(0026),
q(0),
],
- q(108) => [
- q(0037),
+ q(BV) => [
+ q(0031),
q(0),
],
- q(112) => [
- q(0021),
+ q(BW) => [
+ q(0030),
q(0),
],
- q(116) => [
- q(0039),
+ q(BY) => [
+ q(0021),
q(0),
],
- q(120) => [
- q(0040),
+ q(BZ) => [
+ q(0023),
q(0),
],
- q(124) => [
+ q(CA) => [
q(0041),
q(0),
],
- q(132) => [
- q(0038),
+ q(CC) => [
+ q(0048),
q(0),
],
- q(136) => [
- q(0042),
+ q(CD) => [
+ q(0051),
q(0),
],
- q(140) => [
+ q(CF) => [
q(0043),
q(0),
],
- q(144) => [
+ q(CG) => [
+ q(0052),
+ q(0),
+ ],
+ q(CH) => [
+ q(0216),
+ q(0),
+ ],
+ q(CI) => [
+ q(0055),
+ q(0),
+ ],
+ q(CK) => [
+ q(0053),
+ q(0),
+ ],
+ q(CL) => [
+ q(0045),
+ q(0),
+ ],
+ q(CM) => [
+ q(0040),
+ q(0),
+ ],
+ q(CN) => [
+ q(0046),
+ q(0),
+ ],
+ q(CO) => [
+ q(0049),
+ q(0),
+ ],
+ q(CP) => [
+ q(0256),
+ q(0),
+ ],
+ q(CR) => [
+ q(0054),
+ q(0),
+ ],
+ q(CU) => [
+ q(0057),
+ q(0),
+ ],
+ q(CV) => [
+ q(0038),
+ q(0),
+ ],
+ q(CW) => [
+ q(0058),
+ q(0),
+ ],
+ q(CX) => [
+ q(0047),
+ q(0),
+ ],
+ q(CY) => [
+ q(0059),
+ q(0),
+ ],
+ q(CZ) => [
+ q(0060),
+ q(0),
+ ],
+ q(DE) => [
+ q(0083),
+ q(0),
+ ],
+ q(DG) => [
+ q(0259),
+ q(0),
+ ],
+ q(DJ) => [
+ q(0062),
+ q(0),
+ ],
+ q(DK) => [
+ q(0061),
+ q(0),
+ ],
+ q(DM) => [
+ q(0063),
+ q(0),
+ ],
+ q(DO) => [
+ q(0064),
+ q(0),
+ ],
+ q(DZ) => [
+ q(0004),
+ q(0),
+ ],
+ q(EC) => [
+ q(0065),
+ q(0),
+ ],
+ q(EE) => [
+ q(0070),
+ q(0),
+ ],
+ q(EG) => [
+ q(0066),
+ q(0),
+ ],
+ q(EH) => [
+ q(0246),
+ q(0),
+ ],
+ q(ER) => [
+ q(0069),
+ q(0),
+ ],
+ q(ES) => [
+ q(0209),
+ q(0),
+ ],
+ q(ET) => [
+ q(0071),
+ q(0),
+ ],
+ q(FI) => [
+ q(0075),
+ q(0),
+ ],
+ q(FJ) => [
+ q(0074),
+ q(0),
+ ],
+ q(FK) => [
+ q(0072),
+ q(0),
+ ],
+ q(FM) => [
+ q(0145),
+ q(0),
+ ],
+ q(FO) => [
+ q(0073),
+ q(0),
+ ],
+ q(FR) => [
+ q(0076),
+ q(0),
+ ],
+ q(GA) => [
+ q(0080),
+ q(0),
+ ],
+ q(GB) => [
+ q(0235),
+ q(0),
+ ],
+ q(GD) => [
+ q(0088),
+ q(0),
+ ],
+ q(GE) => [
+ q(0082),
+ q(0),
+ ],
+ q(GF) => [
+ q(0077),
+ q(0),
+ ],
+ q(GG) => [
+ q(0092),
+ q(0),
+ ],
+ q(GH) => [
+ q(0084),
+ q(0),
+ ],
+ q(GI) => [
+ q(0085),
+ q(0),
+ ],
+ q(GL) => [
+ q(0087),
+ q(0),
+ ],
+ q(GM) => [
+ q(0081),
+ q(0),
+ ],
+ q(GN) => [
+ q(0093),
+ q(0),
+ ],
+ q(GP) => [
+ q(0089),
+ q(0),
+ ],
+ q(GQ) => [
+ q(0068),
+ q(0),
+ ],
+ q(GR) => [
+ q(0086),
+ q(0),
+ ],
+ q(GS) => [
+ q(0207),
+ q(2),
+ ],
+ q(GT) => [
+ q(0091),
+ q(0),
+ ],
+ q(GU) => [
+ q(0090),
+ q(0),
+ ],
+ q(GW) => [
+ q(0094),
+ q(0),
+ ],
+ q(GY) => [
+ q(0095),
+ q(0),
+ ],
+ q(HK) => [
+ q(0100),
+ q(0),
+ ],
+ q(HM) => [
+ q(0097),
+ q(0),
+ ],
+ q(HN) => [
+ q(0099),
+ q(0),
+ ],
+ q(HR) => [
+ q(0056),
+ q(0),
+ ],
+ q(HT) => [
+ q(0096),
+ q(0),
+ ],
+ q(HU) => [
+ q(0101),
+ q(0),
+ ],
+ q(ID) => [
+ q(0104),
+ q(0),
+ ],
+ q(IE) => [
+ q(0107),
+ q(0),
+ ],
+ q(IL) => [
+ q(0109),
+ q(0),
+ ],
+ q(IM) => [
+ q(0108),
+ q(0),
+ ],
+ q(IN) => [
+ q(0103),
+ q(0),
+ ],
+ q(IO) => [
+ q(0033),
+ q(0),
+ ],
+ q(IQ) => [
+ q(0106),
+ q(0),
+ ],
+ q(IR) => [
+ q(0105),
+ q(0),
+ ],
+ q(IS) => [
+ q(0102),
+ q(0),
+ ],
+ q(IT) => [
+ q(0110),
+ q(0),
+ ],
+ q(JE) => [
+ q(0113),
+ q(0),
+ ],
+ q(JM) => [
+ q(0111),
+ q(0),
+ ],
+ q(JO) => [
+ q(0114),
+ q(0),
+ ],
+ q(JP) => [
+ q(0112),
+ q(0),
+ ],
+ q(KE) => [
+ q(0116),
+ q(0),
+ ],
+ q(KG) => [
+ q(0121),
+ q(0),
+ ],
+ q(KH) => [
+ q(0039),
+ q(0),
+ ],
+ q(KI) => [
+ q(0117),
+ q(0),
+ ],
+ q(KM) => [
+ q(0050),
+ q(0),
+ ],
+ q(KN) => [
+ q(0187),
+ q(0),
+ ],
+ q(KP) => [
+ q(0118),
+ q(7),
+ ],
+ q(KR) => [
+ q(0119),
+ q(7),
+ ],
+ q(KW) => [
+ q(0120),
+ q(0),
+ ],
+ q(KY) => [
+ q(0042),
+ q(0),
+ ],
+ q(KZ) => [
+ q(0115),
+ q(0),
+ ],
+ q(LA) => [
+ q(0122),
+ q(4),
+ ],
+ q(LB) => [
+ q(0124),
+ q(0),
+ ],
+ q(LC) => [
+ q(0188),
+ q(0),
+ ],
+ q(LI) => [
+ q(0128),
+ q(0),
+ ],
+ q(LK) => [
+ q(0210),
+ q(0),
+ ],
+ q(LR) => [
+ q(0126),
+ q(0),
+ ],
+ q(LS) => [
+ q(0125),
+ q(0),
+ ],
+ q(LT) => [
+ q(0129),
+ q(0),
+ ],
+ q(LU) => [
+ q(0130),
+ q(0),
+ ],
+ q(LV) => [
+ q(0123),
+ q(0),
+ ],
+ q(LY) => [
+ q(0127),
+ q(0),
+ ],
+ q(MA) => [
+ q(0151),
+ q(0),
+ ],
+ q(MC) => [
+ q(0147),
+ q(0),
+ ],
+ q(MD) => [
+ q(0146),
+ q(6),
+ ],
+ q(ME) => [
+ q(0149),
+ q(0),
+ ],
+ q(MF) => [
+ q(0189),
+ q(0),
+ ],
+ q(MG) => [
+ q(0133),
+ q(0),
+ ],
+ q(MH) => [
+ q(0139),
+ q(0),
+ ],
+ q(MK) => [
+ q(0132),
+ q(0),
+ ],
+ q(ML) => [
+ q(0137),
+ q(0),
+ ],
+ q(MM) => [
+ q(0153),
+ q(0),
+ ],
+ q(MN) => [
+ q(0148),
+ q(0),
+ ],
+ q(MO) => [
+ q(0131),
+ q(0),
+ ],
+ q(MP) => [
+ q(0165),
+ q(0),
+ ],
+ q(MQ) => [
+ q(0140),
+ q(0),
+ ],
+ q(MR) => [
+ q(0141),
+ q(0),
+ ],
+ q(MS) => [
+ q(0150),
+ q(0),
+ ],
+ q(MT) => [
+ q(0138),
+ q(0),
+ ],
+ q(MU) => [
+ q(0142),
+ q(0),
+ ],
+ q(MV) => [
+ q(0136),
+ q(0),
+ ],
+ q(MW) => [
+ q(0134),
+ q(0),
+ ],
+ q(MX) => [
+ q(0144),
+ q(0),
+ ],
+ q(MY) => [
+ q(0135),
+ q(0),
+ ],
+ q(MZ) => [
+ q(0152),
+ q(0),
+ ],
+ q(NA) => [
+ q(0154),
+ q(0),
+ ],
+ q(NC) => [
+ q(0158),
+ q(0),
+ ],
+ q(NE) => [
+ q(0161),
+ q(0),
+ ],
+ q(NF) => [
+ q(0164),
+ q(0),
+ ],
+ q(NG) => [
+ q(0162),
+ q(0),
+ ],
+ q(NI) => [
+ q(0160),
+ q(0),
+ ],
+ q(NL) => [
+ q(0157),
+ q(0),
+ ],
+ q(NO) => [
+ q(0166),
+ q(0),
+ ],
+ q(NP) => [
+ q(0156),
+ q(0),
+ ],
+ q(NR) => [
+ q(0155),
+ q(0),
+ ],
+ q(NU) => [
+ q(0163),
+ q(0),
+ ],
+ q(NZ) => [
+ q(0159),
+ q(0),
+ ],
+ q(OM) => [
+ q(0167),
+ q(0),
+ ],
+ q(PA) => [
+ q(0171),
+ q(0),
+ ],
+ q(PE) => [
+ q(0174),
+ q(0),
+ ],
+ q(PF) => [
+ q(0078),
+ q(0),
+ ],
+ q(PG) => [
+ q(0172),
+ q(0),
+ ],
+ q(PH) => [
+ q(0175),
+ q(0),
+ ],
+ q(PK) => [
+ q(0168),
+ q(0),
+ ],
+ q(PL) => [
+ q(0177),
+ q(0),
+ ],
+ q(PM) => [
+ q(0190),
+ q(0),
+ ],
+ q(PN) => [
+ q(0176),
+ q(0),
+ ],
+ q(PR) => [
+ q(0179),
+ q(0),
+ ],
+ q(PT) => [
+ q(0178),
+ q(0),
+ ],
+ q(PW) => [
+ q(0169),
+ q(0),
+ ],
+ q(PY) => [
+ q(0173),
+ q(0),
+ ],
+ q(QA) => [
+ q(0180),
+ q(0),
+ ],
+ q(QM) => [
+ q(0273),
+ q(0),
+ ],
+ q(QS) => [
+ q(0255),
+ q(0),
+ ],
+ q(QU) => [
+ q(0270),
+ q(0),
+ ],
+ q(QW) => [
+ q(0281),
+ q(0),
+ ],
+ q(QX) => [
+ q(0264),
+ q(0),
+ ],
+ q(QZ) => [
+ q(0252),
+ q(0),
+ ],
+ q(RE) => [
+ q(0181),
+ q(0),
+ ],
+ q(RO) => [
+ q(0182),
+ q(0),
+ ],
+ q(RS) => [
+ q(0197),
+ q(0),
+ ],
+ q(RU) => [
+ q(0183),
+ q(4),
+ ],
+ q(RW) => [
+ q(0184),
+ q(0),
+ ],
+ q(SA) => [
+ q(0195),
+ q(0),
+ ],
+ q(SB) => [
+ q(0204),
+ q(0),
+ ],
+ q(SC) => [
+ q(0198),
+ q(0),
+ ],
+ q(SD) => [
+ q(0211),
+ q(0),
+ ],
+ q(SE) => [
+ q(0215),
+ q(0),
+ ],
+ q(SG) => [
+ q(0200),
+ q(0),
+ ],
+ q(SH) => [
+ q(0186),
+ q(2),
+ ],
+ q(SI) => [
+ q(0203),
+ q(0),
+ ],
+ q(SK) => [
+ q(0202),
+ q(0),
+ ],
+ q(SL) => [
+ q(0199),
+ q(0),
+ ],
+ q(SM) => [
+ q(0193),
+ q(0),
+ ],
+ q(SN) => [
+ q(0196),
+ q(0),
+ ],
+ q(SO) => [
+ q(0205),
+ q(0),
+ ],
+ q(SR) => [
+ q(0212),
+ q(0),
+ ],
+ q(SS) => [
+ q(0208),
+ q(0),
+ ],
+ q(ST) => [
+ q(0194),
+ q(0),
+ ],
+ q(SV) => [
+ q(0067),
+ q(0),
+ ],
+ q(SX) => [
+ q(0201),
+ q(1),
+ ],
+ q(SY) => [
+ q(0217),
+ q(0),
+ ],
+ q(SZ) => [
+ q(0214),
+ q(0),
+ ],
+ q(TC) => [
+ q(0230),
+ q(0),
+ ],
+ q(TD) => [
+ q(0044),
+ q(0),
+ ],
+ q(TF) => [
+ q(0079),
+ q(0),
+ ],
+ q(TG) => [
+ q(0223),
+ q(0),
+ ],
+ q(TH) => [
+ q(0221),
+ q(0),
+ ],
+ q(TJ) => [
+ q(0219),
+ q(0),
+ ],
+ q(TK) => [
+ q(0224),
+ q(0),
+ ],
+ q(TL) => [
+ q(0222),
+ q(0),
+ ],
+ q(TM) => [
+ q(0229),
+ q(0),
+ ],
+ q(TN) => [
+ q(0227),
+ q(0),
+ ],
+ q(TO) => [
+ q(0225),
+ q(0),
+ ],
+ q(TR) => [
+ q(0228),
+ q(0),
+ ],
+ q(TT) => [
+ q(0226),
+ q(0),
+ ],
+ q(TV) => [
+ q(0231),
+ q(0),
+ ],
+ q(TW) => [
+ q(0218),
+ q(0),
+ ],
+ q(TZ) => [
+ q(0220),
+ q(3),
+ ],
+ q(UA) => [
+ q(0233),
+ q(0),
+ ],
+ q(UG) => [
+ q(0232),
+ q(0),
+ ],
+ q(US) => [
+ q(0237),
+ q(0),
+ ],
+ q(UY) => [
+ q(0238),
+ q(0),
+ ],
+ q(UZ) => [
+ q(0239),
+ q(0),
+ ],
+ q(VA) => [
+ q(0098),
+ q(0),
+ ],
+ q(VC) => [
+ q(0191),
+ q(0),
+ ],
+ q(VE) => [
+ q(0241),
+ q(0),
+ ],
+ q(VG) => [
+ q(0243),
+ q(0),
+ ],
+ q(VI) => [
+ q(0244),
+ q(0),
+ ],
+ q(VN) => [
+ q(0242),
+ q(0),
+ ],
+ q(VU) => [
+ q(0240),
+ q(0),
+ ],
+ q(WF) => [
+ q(0245),
+ q(0),
+ ],
+ q(WS) => [
+ q(0192),
+ q(0),
+ ],
+ q(XA) => [
+ q(0253),
+ q(0),
+ ],
+ q(XB) => [
+ q(0254),
+ q(0),
+ ],
+ q(XC) => [
+ q(0257),
+ q(0),
+ ],
+ q(XD) => [
+ q(0258),
+ q(0),
+ ],
+ q(XE) => [
+ q(0262),
+ q(0),
+ ],
+ q(XG) => [
+ q(0263),
+ q(0),
+ ],
+ q(XH) => [
+ q(0266),
+ q(0),
+ ],
+ q(XJ) => [
+ q(0267),
+ q(0),
+ ],
+ q(XK) => [
+ q(0272),
+ q(0),
+ ],
+ q(XL) => [
+ q(0275),
+ q(0),
+ ],
+ q(XM) => [
+ q(0271),
+ q(0),
+ ],
+ q(XP) => [
+ q(0276),
+ q(0),
+ ],
+ q(XQ) => [
+ q(0268),
+ q(0),
+ ],
+ q(XR) => [
+ q(0278),
+ q(0),
+ ],
+ q(XS) => [
+ q(0277),
+ q(0),
+ ],
+ q(XT) => [
+ q(0279),
+ q(0),
+ ],
+ q(XU) => [
+ q(0269),
+ q(0),
+ ],
+ q(XV) => [
+ q(0274),
+ q(0),
+ ],
+ q(XW) => [
+ q(0282),
+ q(0),
+ ],
+ q(YE) => [
+ q(0247),
+ q(0),
+ ],
+ q(YT) => [
+ q(0143),
+ q(0),
+ ],
+ q(ZA) => [
+ q(0206),
+ q(0),
+ ],
+ q(ZM) => [
+ q(0248),
+ q(0),
+ ],
+ q(ZW) => [
+ q(0249),
+ q(0),
+ ],
+ q([None Assigned]) => [
+ q(0260),
+ q(4),
+ ],
+ },
+ q(genc-alpha-3) => {
+ q(ABW) => [
+ q(0013),
+ q(0),
+ ],
+ q(AFG) => [
+ q(0001),
+ q(0),
+ ],
+ q(AGO) => [
+ q(0007),
+ q(0),
+ ],
+ q(AIA) => [
+ q(0008),
+ q(0),
+ ],
+ q(ALB) => [
+ q(0003),
+ q(0),
+ ],
+ q(AND) => [
+ q(0006),
+ q(0),
+ ],
+ q(ARE) => [
+ q(0234),
+ q(0),
+ ],
+ q(ARG) => [
+ q(0011),
+ q(0),
+ ],
+ q(ARM) => [
+ q(0012),
+ q(0),
+ ],
+ q(ASM) => [
+ q(0005),
+ q(0),
+ ],
+ q(ATA) => [
+ q(0009),
+ q(0),
+ ],
+ q(ATF) => [
+ q(0079),
+ q(0),
+ ],
+ q(ATG) => [
+ q(0010),
+ q(0),
+ ],
+ q(AUS) => [
+ q(0014),
+ q(0),
+ ],
+ q(AUT) => [
+ q(0015),
+ q(0),
+ ],
+ q(AX1) => [
+ q(0280),
+ q(0),
+ ],
+ q(AX2) => [
+ q(0265),
+ q(0),
+ ],
+ q(AX3) => [
+ q(0261),
+ q(0),
+ ],
+ q(AZE) => [
+ q(0016),
+ q(0),
+ ],
+ q(BDI) => [
+ q(0037),
+ q(0),
+ ],
+ q(BEL) => [
+ q(0022),
+ q(0),
+ ],
+ q(BEN) => [
+ q(0024),
+ q(0),
+ ],
+ q(BES) => [
+ q(0028),
+ q(1),
+ ],
+ q(BFA) => [
+ q(0036),
+ q(0),
+ ],
+ q(BGD) => [
+ q(0019),
+ q(0),
+ ],
+ q(BGR) => [
+ q(0035),
+ q(0),
+ ],
+ q(BHR) => [
+ q(0018),
+ q(0),
+ ],
+ q(BHS) => [
+ q(0017),
+ q(0),
+ ],
+ q(BIH) => [
+ q(0029),
+ q(0),
+ ],
+ q(BLM) => [
+ q(0185),
+ q(0),
+ ],
+ q(BLR) => [
+ q(0021),
+ q(0),
+ ],
+ q(BLZ) => [
+ q(0023),
+ q(0),
+ ],
+ q(BMU) => [
+ q(0025),
+ q(0),
+ ],
+ q(BOL) => [
+ q(0027),
+ q(0),
+ ],
+ q(BRA) => [
+ q(0032),
+ q(0),
+ ],
+ q(BRB) => [
+ q(0020),
+ q(0),
+ ],
+ q(BRN) => [
+ q(0034),
+ q(0),
+ ],
+ q(BTN) => [
+ q(0026),
+ q(0),
+ ],
+ q(BVT) => [
+ q(0031),
+ q(0),
+ ],
+ q(BWA) => [
+ q(0030),
+ q(0),
+ ],
+ q(CAF) => [
+ q(0043),
+ q(0),
+ ],
+ q(CAN) => [
+ q(0041),
+ q(0),
+ ],
+ q(CCK) => [
+ q(0048),
+ q(0),
+ ],
+ q(CHE) => [
+ q(0216),
+ q(0),
+ ],
+ q(CHL) => [
+ q(0045),
+ q(0),
+ ],
+ q(CHN) => [
+ q(0046),
+ q(0),
+ ],
+ q(CIV) => [
+ q(0055),
+ q(0),
+ ],
+ q(CMR) => [
+ q(0040),
+ q(0),
+ ],
+ q(COD) => [
+ q(0051),
+ q(0),
+ ],
+ q(COG) => [
+ q(0052),
+ q(0),
+ ],
+ q(COK) => [
+ q(0053),
+ q(0),
+ ],
+ q(COL) => [
+ q(0049),
+ q(0),
+ ],
+ q(COM) => [
+ q(0050),
+ q(0),
+ ],
+ q(CPT) => [
+ q(0256),
+ q(0),
+ ],
+ q(CPV) => [
+ q(0038),
+ q(0),
+ ],
+ q(CRI) => [
+ q(0054),
+ q(0),
+ ],
+ q(CUB) => [
+ q(0057),
+ q(0),
+ ],
+ q(CUW) => [
+ q(0058),
+ q(0),
+ ],
+ q(CXR) => [
+ q(0047),
+ q(0),
+ ],
+ q(CYM) => [
+ q(0042),
+ q(0),
+ ],
+ q(CYP) => [
+ q(0059),
+ q(0),
+ ],
+ q(CZE) => [
+ q(0060),
+ q(0),
+ ],
+ q(DEU) => [
+ q(0083),
+ q(0),
+ ],
+ q(DGA) => [
+ q(0259),
+ q(0),
+ ],
+ q(DJI) => [
+ q(0062),
+ q(0),
+ ],
+ q(DMA) => [
+ q(0063),
+ q(0),
+ ],
+ q(DNK) => [
+ q(0061),
+ q(0),
+ ],
+ q(DOM) => [
+ q(0064),
+ q(0),
+ ],
+ q(DZA) => [
+ q(0004),
+ q(0),
+ ],
+ q(ECU) => [
+ q(0065),
+ q(0),
+ ],
+ q(EGY) => [
+ q(0066),
+ q(0),
+ ],
+ q(ERI) => [
+ q(0069),
+ q(0),
+ ],
+ q(ESH) => [
+ q(0246),
+ q(0),
+ ],
+ q(ESP) => [
+ q(0209),
+ q(0),
+ ],
+ q(EST) => [
+ q(0070),
+ q(0),
+ ],
+ q(ETH) => [
+ q(0071),
+ q(0),
+ ],
+ q(FIN) => [
+ q(0075),
+ q(0),
+ ],
+ q(FJI) => [
+ q(0074),
+ q(0),
+ ],
+ q(FLK) => [
+ q(0072),
+ q(0),
+ ],
+ q(FRA) => [
+ q(0076),
+ q(0),
+ ],
+ q(FRO) => [
+ q(0073),
+ q(0),
+ ],
+ q(FSM) => [
+ q(0145),
+ q(0),
+ ],
+ q(GAB) => [
+ q(0080),
+ q(0),
+ ],
+ q(GBR) => [
+ q(0235),
+ q(0),
+ ],
+ q(GEO) => [
+ q(0082),
+ q(0),
+ ],
+ q(GGY) => [
+ q(0092),
+ q(0),
+ ],
+ q(GHA) => [
+ q(0084),
+ q(0),
+ ],
+ q(GIB) => [
+ q(0085),
+ q(0),
+ ],
+ q(GIN) => [
+ q(0093),
+ q(0),
+ ],
+ q(GLP) => [
+ q(0089),
+ q(0),
+ ],
+ q(GMB) => [
+ q(0081),
+ q(0),
+ ],
+ q(GNB) => [
+ q(0094),
+ q(0),
+ ],
+ q(GNQ) => [
+ q(0068),
+ q(0),
+ ],
+ q(GRC) => [
+ q(0086),
+ q(0),
+ ],
+ q(GRD) => [
+ q(0088),
+ q(0),
+ ],
+ q(GRL) => [
+ q(0087),
+ q(0),
+ ],
+ q(GTM) => [
+ q(0091),
+ q(0),
+ ],
+ q(GUF) => [
+ q(0077),
+ q(0),
+ ],
+ q(GUM) => [
+ q(0090),
+ q(0),
+ ],
+ q(GUY) => [
+ q(0095),
+ q(0),
+ ],
+ q(HKG) => [
+ q(0100),
+ q(0),
+ ],
+ q(HMD) => [
+ q(0097),
+ q(0),
+ ],
+ q(HND) => [
+ q(0099),
+ q(0),
+ ],
+ q(HRV) => [
+ q(0056),
+ q(0),
+ ],
+ q(HTI) => [
+ q(0096),
+ q(0),
+ ],
+ q(HUN) => [
+ q(0101),
+ q(0),
+ ],
+ q(IDN) => [
+ q(0104),
+ q(0),
+ ],
+ q(IMN) => [
+ q(0108),
+ q(0),
+ ],
+ q(IND) => [
+ q(0103),
+ q(0),
+ ],
+ q(IOT) => [
+ q(0033),
+ q(0),
+ ],
+ q(IRL) => [
+ q(0107),
+ q(0),
+ ],
+ q(IRN) => [
+ q(0105),
+ q(0),
+ ],
+ q(IRQ) => [
+ q(0106),
+ q(0),
+ ],
+ q(ISL) => [
+ q(0102),
+ q(0),
+ ],
+ q(ISR) => [
+ q(0109),
+ q(0),
+ ],
+ q(ITA) => [
+ q(0110),
+ q(0),
+ ],
+ q(JAM) => [
+ q(0111),
+ q(0),
+ ],
+ q(JEY) => [
+ q(0113),
+ q(0),
+ ],
+ q(JOR) => [
+ q(0114),
+ q(0),
+ ],
+ q(JPN) => [
+ q(0112),
+ q(0),
+ ],
+ q(KAZ) => [
+ q(0115),
+ q(0),
+ ],
+ q(KEN) => [
+ q(0116),
+ q(0),
+ ],
+ q(KGZ) => [
+ q(0121),
+ q(0),
+ ],
+ q(KHM) => [
+ q(0039),
+ q(0),
+ ],
+ q(KIR) => [
+ q(0117),
+ q(0),
+ ],
+ q(KNA) => [
+ q(0187),
+ q(0),
+ ],
+ q(KOR) => [
+ q(0119),
+ q(7),
+ ],
+ q(KWT) => [
+ q(0120),
+ q(0),
+ ],
+ q(LAO) => [
+ q(0122),
+ q(4),
+ ],
+ q(LBN) => [
+ q(0124),
+ q(0),
+ ],
+ q(LBR) => [
+ q(0126),
+ q(0),
+ ],
+ q(LBY) => [
+ q(0127),
+ q(0),
+ ],
+ q(LCA) => [
+ q(0188),
+ q(0),
+ ],
+ q(LIE) => [
+ q(0128),
+ q(0),
+ ],
+ q(LKA) => [
+ q(0210),
+ q(0),
+ ],
+ q(LSO) => [
+ q(0125),
+ q(0),
+ ],
+ q(LTU) => [
+ q(0129),
+ q(0),
+ ],
+ q(LUX) => [
+ q(0130),
+ q(0),
+ ],
+ q(LVA) => [
+ q(0123),
+ q(0),
+ ],
+ q(MAC) => [
+ q(0131),
+ q(0),
+ ],
+ q(MAF) => [
+ q(0189),
+ q(0),
+ ],
+ q(MAR) => [
+ q(0151),
+ q(0),
+ ],
+ q(MCO) => [
+ q(0147),
+ q(0),
+ ],
+ q(MDA) => [
+ q(0146),
+ q(6),
+ ],
+ q(MDG) => [
+ q(0133),
+ q(0),
+ ],
+ q(MDV) => [
+ q(0136),
+ q(0),
+ ],
+ q(MEX) => [
+ q(0144),
+ q(0),
+ ],
+ q(MHL) => [
+ q(0139),
+ q(0),
+ ],
+ q(MKD) => [
+ q(0132),
+ q(0),
+ ],
+ q(MLI) => [
+ q(0137),
+ q(0),
+ ],
+ q(MLT) => [
+ q(0138),
+ q(0),
+ ],
+ q(MMR) => [
+ q(0153),
+ q(0),
+ ],
+ q(MNE) => [
+ q(0149),
+ q(0),
+ ],
+ q(MNG) => [
+ q(0148),
+ q(0),
+ ],
+ q(MNP) => [
+ q(0165),
+ q(0),
+ ],
+ q(MOZ) => [
+ q(0152),
+ q(0),
+ ],
+ q(MRT) => [
+ q(0141),
+ q(0),
+ ],
+ q(MSR) => [
+ q(0150),
+ q(0),
+ ],
+ q(MTQ) => [
+ q(0140),
+ q(0),
+ ],
+ q(MUS) => [
+ q(0142),
+ q(0),
+ ],
+ q(MWI) => [
+ q(0134),
+ q(0),
+ ],
+ q(MYS) => [
+ q(0135),
+ q(0),
+ ],
+ q(MYT) => [
+ q(0143),
+ q(0),
+ ],
+ q(NAM) => [
+ q(0154),
+ q(0),
+ ],
+ q(NCL) => [
+ q(0158),
+ q(0),
+ ],
+ q(NER) => [
+ q(0161),
+ q(0),
+ ],
+ q(NFK) => [
+ q(0164),
+ q(0),
+ ],
+ q(NGA) => [
+ q(0162),
+ q(0),
+ ],
+ q(NIC) => [
+ q(0160),
+ q(0),
+ ],
+ q(NIU) => [
+ q(0163),
+ q(0),
+ ],
+ q(NLD) => [
+ q(0157),
+ q(0),
+ ],
+ q(NOR) => [
+ q(0166),
+ q(0),
+ ],
+ q(NPL) => [
+ q(0156),
+ q(0),
+ ],
+ q(NRU) => [
+ q(0155),
+ q(0),
+ ],
+ q(NZL) => [
+ q(0159),
+ q(0),
+ ],
+ q(OMN) => [
+ q(0167),
+ q(0),
+ ],
+ q(PAK) => [
+ q(0168),
+ q(0),
+ ],
+ q(PAN) => [
+ q(0171),
+ q(0),
+ ],
+ q(PCN) => [
+ q(0176),
+ q(0),
+ ],
+ q(PER) => [
+ q(0174),
+ q(0),
+ ],
+ q(PHL) => [
+ q(0175),
+ q(0),
+ ],
+ q(PLW) => [
+ q(0169),
+ q(0),
+ ],
+ q(PNG) => [
+ q(0172),
+ q(0),
+ ],
+ q(POL) => [
+ q(0177),
+ q(0),
+ ],
+ q(PRI) => [
+ q(0179),
+ q(0),
+ ],
+ q(PRK) => [
+ q(0118),
+ q(7),
+ ],
+ q(PRT) => [
+ q(0178),
+ q(0),
+ ],
+ q(PRY) => [
+ q(0173),
+ q(0),
+ ],
+ q(PYF) => [
+ q(0078),
+ q(0),
+ ],
+ q(QAT) => [
+ q(0180),
+ q(0),
+ ],
+ q(REU) => [
+ q(0181),
+ q(0),
+ ],
+ q(ROU) => [
+ q(0182),
+ q(0),
+ ],
+ q(RUS) => [
+ q(0183),
+ q(4),
+ ],
+ q(RWA) => [
+ q(0184),
+ q(0),
+ ],
+ q(SAU) => [
+ q(0195),
+ q(0),
+ ],
+ q(SDN) => [
+ q(0211),
+ q(0),
+ ],
+ q(SEN) => [
+ q(0196),
+ q(0),
+ ],
+ q(SGP) => [
+ q(0200),
+ q(0),
+ ],
+ q(SGS) => [
+ q(0207),
+ q(2),
+ ],
+ q(SHN) => [
+ q(0186),
+ q(2),
+ ],
+ q(SLB) => [
+ q(0204),
+ q(0),
+ ],
+ q(SLE) => [
+ q(0199),
+ q(0),
+ ],
+ q(SLV) => [
+ q(0067),
+ q(0),
+ ],
+ q(SMR) => [
+ q(0193),
+ q(0),
+ ],
+ q(SOM) => [
+ q(0205),
+ q(0),
+ ],
+ q(SPM) => [
+ q(0190),
+ q(0),
+ ],
+ q(SRB) => [
+ q(0197),
+ q(0),
+ ],
+ q(SSD) => [
+ q(0208),
+ q(0),
+ ],
+ q(STP) => [
+ q(0194),
+ q(0),
+ ],
+ q(SUR) => [
+ q(0212),
+ q(0),
+ ],
+ q(SVK) => [
+ q(0202),
+ q(0),
+ ],
+ q(SVN) => [
+ q(0203),
+ q(0),
+ ],
+ q(SWE) => [
+ q(0215),
+ q(0),
+ ],
+ q(SWZ) => [
+ q(0214),
+ q(0),
+ ],
+ q(SXM) => [
+ q(0201),
+ q(1),
+ ],
+ q(SYC) => [
+ q(0198),
+ q(0),
+ ],
+ q(SYR) => [
+ q(0217),
+ q(0),
+ ],
+ q(TCA) => [
+ q(0230),
+ q(0),
+ ],
+ q(TCD) => [
+ q(0044),
+ q(0),
+ ],
+ q(TGO) => [
+ q(0223),
+ q(0),
+ ],
+ q(THA) => [
+ q(0221),
+ q(0),
+ ],
+ q(TJK) => [
+ q(0219),
+ q(0),
+ ],
+ q(TKL) => [
+ q(0224),
+ q(0),
+ ],
+ q(TKM) => [
+ q(0229),
+ q(0),
+ ],
+ q(TLS) => [
+ q(0222),
+ q(0),
+ ],
+ q(TON) => [
+ q(0225),
+ q(0),
+ ],
+ q(TTO) => [
+ q(0226),
+ q(0),
+ ],
+ q(TUN) => [
+ q(0227),
+ q(0),
+ ],
+ q(TUR) => [
+ q(0228),
+ q(0),
+ ],
+ q(TUV) => [
+ q(0231),
+ q(0),
+ ],
+ q(TWN) => [
+ q(0218),
+ q(0),
+ ],
+ q(TZA) => [
+ q(0220),
+ q(3),
+ ],
+ q(UGA) => [
+ q(0232),
+ q(0),
+ ],
+ q(UKR) => [
+ q(0233),
+ q(0),
+ ],
+ q(URY) => [
+ q(0238),
+ q(0),
+ ],
+ q(USA) => [
+ q(0237),
+ q(0),
+ ],
+ q(UZB) => [
+ q(0239),
+ q(0),
+ ],
+ q(VAT) => [
+ q(0098),
+ q(0),
+ ],
+ q(VCT) => [
+ q(0191),
+ q(0),
+ ],
+ q(VEN) => [
+ q(0241),
+ q(0),
+ ],
+ q(VGB) => [
+ q(0243),
+ q(0),
+ ],
+ q(VIR) => [
+ q(0244),
+ q(0),
+ ],
+ q(VNM) => [
+ q(0242),
+ q(0),
+ ],
+ q(VUT) => [
+ q(0240),
+ q(0),
+ ],
+ q(WLF) => [
+ q(0245),
+ q(0),
+ ],
+ q(WSM) => [
+ q(0192),
+ q(0),
+ ],
+ q(XAC) => [
+ q(0253),
+ q(0),
+ ],
+ q(XAZ) => [
+ q(0260),
+ q(0),
+ ],
+ q(XBI) => [
+ q(0255),
+ q(0),
+ ],
+ q(XBK) => [
+ q(0254),
+ q(0),
+ ],
+ q(XCR) => [
+ q(0260),
+ q(1),
+ ],
+ q(XCS) => [
+ q(0257),
+ q(0),
+ ],
+ q(XCY) => [
+ q(0260),
+ q(2),
+ ],
+ q(XEU) => [
+ q(0262),
+ q(0),
+ ],
+ q(XGL) => [
+ q(0264),
+ q(0),
+ ],
+ q(XGZ) => [
+ q(0263),
+ q(0),
+ ],
+ q(XHO) => [
+ q(0266),
+ q(0),
+ ],
+ q(XJA) => [
+ q(0269),
+ q(0),
+ ],
+ q(XJM) => [
+ q(0267),
+ q(0),
+ ],
+ q(XJN) => [
+ q(0270),
+ q(0),
+ ],
+ q(XJV) => [
+ q(0268),
+ q(0),
+ ],
+ q(XKM) => [
+ q(0260),
+ q(3),
+ ],
+ q(XKN) => [
+ q(0260),
+ q(4),
+ ],
+ q(XKR) => [
+ q(0271),
+ q(0),
+ ],
+ q(XKS) => [
+ q(0272),
+ q(0),
+ ],
+ q(XMW) => [
+ q(0273),
+ q(0),
+ ],
+ q(XNV) => [
+ q(0274),
+ q(0),
+ ],
+ q(XPL) => [
+ q(0275),
+ q(0),
+ ],
+ q(XPR) => [
+ q(0276),
+ q(0),
+ ],
+ q(XQZ) => [
+ q(0252),
+ q(0),
+ ],
+ q(XSP) => [
+ q(0277),
+ q(0),
+ ],
+ q(XSV) => [
+ q(0278),
+ q(0),
+ ],
+ q(XTR) => [
+ q(0279),
+ q(0),
+ ],
+ q(XWB) => [
+ q(0282),
+ q(0),
+ ],
+ q(XWK) => [
+ q(0281),
+ q(0),
+ ],
+ q(XXD) => [
+ q(0258),
+ q(0),
+ ],
+ q(YEM) => [
+ q(0247),
+ q(0),
+ ],
+ q(ZAF) => [
+ q(0206),
+ q(0),
+ ],
+ q(ZMB) => [
+ q(0248),
+ q(0),
+ ],
+ q(ZWE) => [
+ q(0249),
+ q(0),
+ ],
+ },
+ q(genc-numeric) => {
+ q(004) => [
+ q(0001),
+ q(0),
+ ],
+ q(008) => [
+ q(0003),
+ q(0),
+ ],
+ q(010) => [
+ q(0009),
+ q(0),
+ ],
+ q(012) => [
+ q(0004),
+ q(0),
+ ],
+ q(016) => [
+ q(0005),
+ q(0),
+ ],
+ q(020) => [
+ q(0006),
+ q(0),
+ ],
+ q(024) => [
+ q(0007),
+ q(0),
+ ],
+ q(028) => [
+ q(0010),
+ q(0),
+ ],
+ q(031) => [
+ q(0016),
+ q(0),
+ ],
+ q(032) => [
+ q(0011),
+ q(0),
+ ],
+ q(036) => [
+ q(0014),
+ q(0),
+ ],
+ q(040) => [
+ q(0015),
+ q(0),
+ ],
+ q(044) => [
+ q(0017),
+ q(0),
+ ],
+ q(048) => [
+ q(0018),
+ q(0),
+ ],
+ q(050) => [
+ q(0019),
+ q(0),
+ ],
+ q(051) => [
+ q(0012),
+ q(0),
+ ],
+ q(052) => [
+ q(0020),
+ q(0),
+ ],
+ q(056) => [
+ q(0022),
+ q(0),
+ ],
+ q(060) => [
+ q(0025),
+ q(0),
+ ],
+ q(064) => [
+ q(0026),
+ q(0),
+ ],
+ q(068) => [
+ q(0027),
+ q(0),
+ ],
+ q(070) => [
+ q(0029),
+ q(0),
+ ],
+ q(072) => [
+ q(0030),
+ q(0),
+ ],
+ q(074) => [
+ q(0031),
+ q(0),
+ ],
+ q(076) => [
+ q(0032),
+ q(0),
+ ],
+ q(084) => [
+ q(0023),
+ q(0),
+ ],
+ q(086) => [
+ q(0033),
+ q(0),
+ ],
+ q(090) => [
+ q(0204),
+ q(0),
+ ],
+ q(092) => [
+ q(0243),
+ q(0),
+ ],
+ q(096) => [
+ q(0034),
+ q(0),
+ ],
+ q(100) => [
+ q(0035),
+ q(0),
+ ],
+ q(104) => [
+ q(0153),
+ q(0),
+ ],
+ q(108) => [
+ q(0037),
+ q(0),
+ ],
+ q(112) => [
+ q(0021),
+ q(0),
+ ],
+ q(116) => [
+ q(0039),
+ q(0),
+ ],
+ q(120) => [
+ q(0040),
+ q(0),
+ ],
+ q(124) => [
+ q(0041),
+ q(0),
+ ],
+ q(132) => [
+ q(0038),
+ q(0),
+ ],
+ q(136) => [
+ q(0042),
+ q(0),
+ ],
+ q(140) => [
+ q(0043),
+ q(0),
+ ],
+ q(144) => [
+ q(0210),
+ q(0),
+ ],
+ q(148) => [
+ q(0044),
+ q(0),
+ ],
+ q(152) => [
+ q(0045),
+ q(0),
+ ],
+ q(156) => [
+ q(0046),
+ q(0),
+ ],
+ q(158) => [
+ q(0218),
+ q(0),
+ ],
+ q(162) => [
+ q(0047),
+ q(0),
+ ],
+ q(166) => [
+ q(0048),
+ q(0),
+ ],
+ q(170) => [
+ q(0049),
+ q(0),
+ ],
+ q(174) => [
+ q(0050),
+ q(0),
+ ],
+ q(175) => [
+ q(0143),
+ q(0),
+ ],
+ q(178) => [
+ q(0052),
+ q(0),
+ ],
+ q(180) => [
+ q(0051),
+ q(0),
+ ],
+ q(184) => [
+ q(0053),
+ q(0),
+ ],
+ q(188) => [
+ q(0054),
+ q(0),
+ ],
+ q(191) => [
+ q(0056),
+ q(0),
+ ],
+ q(192) => [
+ q(0057),
+ q(0),
+ ],
+ q(196) => [
+ q(0059),
+ q(0),
+ ],
+ q(203) => [
+ q(0060),
+ q(0),
+ ],
+ q(204) => [
+ q(0024),
+ q(0),
+ ],
+ q(208) => [
+ q(0061),
+ q(0),
+ ],
+ q(212) => [
+ q(0063),
+ q(0),
+ ],
+ q(214) => [
+ q(0064),
+ q(0),
+ ],
+ q(218) => [
+ q(0065),
+ q(0),
+ ],
+ q(222) => [
+ q(0067),
+ q(0),
+ ],
+ q(226) => [
+ q(0068),
+ q(0),
+ ],
+ q(231) => [
+ q(0071),
+ q(0),
+ ],
+ q(232) => [
+ q(0069),
+ q(0),
+ ],
+ q(233) => [
+ q(0070),
+ q(0),
+ ],
+ q(234) => [
+ q(0073),
+ q(0),
+ ],
+ q(238) => [
+ q(0072),
+ q(0),
+ ],
+ q(239) => [
+ q(0207),
+ q(2),
+ ],
+ q(242) => [
+ q(0074),
+ q(0),
+ ],
+ q(246) => [
+ q(0075),
+ q(0),
+ ],
+ q(250) => [
+ q(0076),
+ q(0),
+ ],
+ q(254) => [
+ q(0077),
+ q(0),
+ ],
+ q(258) => [
+ q(0078),
+ q(0),
+ ],
+ q(260) => [
+ q(0079),
+ q(0),
+ ],
+ q(262) => [
+ q(0062),
+ q(0),
+ ],
+ q(266) => [
+ q(0080),
+ q(0),
+ ],
+ q(268) => [
+ q(0082),
+ q(0),
+ ],
+ q(270) => [
+ q(0081),
+ q(0),
+ ],
+ q(276) => [
+ q(0083),
+ q(0),
+ ],
+ q(288) => [
+ q(0084),
+ q(0),
+ ],
+ q(292) => [
+ q(0085),
+ q(0),
+ ],
+ q(296) => [
+ q(0117),
+ q(0),
+ ],
+ q(300) => [
+ q(0086),
+ q(0),
+ ],
+ q(304) => [
+ q(0087),
+ q(0),
+ ],
+ q(308) => [
+ q(0088),
+ q(0),
+ ],
+ q(312) => [
+ q(0089),
+ q(0),
+ ],
+ q(316) => [
+ q(0090),
+ q(0),
+ ],
+ q(320) => [
+ q(0091),
+ q(0),
+ ],
+ q(324) => [
+ q(0093),
+ q(0),
+ ],
+ q(328) => [
+ q(0095),
+ q(0),
+ ],
+ q(332) => [
+ q(0096),
+ q(0),
+ ],
+ q(334) => [
+ q(0097),
+ q(0),
+ ],
+ q(336) => [
+ q(0098),
+ q(0),
+ ],
+ q(340) => [
+ q(0099),
+ q(0),
+ ],
+ q(344) => [
+ q(0100),
+ q(0),
+ ],
+ q(348) => [
+ q(0101),
+ q(0),
+ ],
+ q(352) => [
+ q(0102),
+ q(0),
+ ],
+ q(356) => [
+ q(0103),
+ q(0),
+ ],
+ q(360) => [
+ q(0104),
+ q(0),
+ ],
+ q(364) => [
+ q(0105),
+ q(0),
+ ],
+ q(368) => [
+ q(0106),
+ q(0),
+ ],
+ q(372) => [
+ q(0107),
+ q(0),
+ ],
+ q(376) => [
+ q(0109),
+ q(0),
+ ],
+ q(380) => [
+ q(0110),
+ q(0),
+ ],
+ q(384) => [
+ q(0055),
+ q(0),
+ ],
+ q(388) => [
+ q(0111),
+ q(0),
+ ],
+ q(392) => [
+ q(0112),
+ q(0),
+ ],
+ q(398) => [
+ q(0115),
+ q(0),
+ ],
+ q(400) => [
+ q(0114),
+ q(0),
+ ],
+ q(404) => [
+ q(0116),
+ q(0),
+ ],
+ q(408) => [
+ q(0118),
+ q(7),
+ ],
+ q(410) => [
+ q(0119),
+ q(7),
+ ],
+ q(414) => [
+ q(0120),
+ q(0),
+ ],
+ q(417) => [
+ q(0121),
+ q(0),
+ ],
+ q(418) => [
+ q(0122),
+ q(4),
+ ],
+ q(422) => [
+ q(0124),
+ q(0),
+ ],
+ q(426) => [
+ q(0125),
+ q(0),
+ ],
+ q(428) => [
+ q(0123),
+ q(0),
+ ],
+ q(430) => [
+ q(0126),
+ q(0),
+ ],
+ q(434) => [
+ q(0127),
+ q(0),
+ ],
+ q(438) => [
+ q(0128),
+ q(0),
+ ],
+ q(440) => [
+ q(0129),
+ q(0),
+ ],
+ q(442) => [
+ q(0130),
+ q(0),
+ ],
+ q(446) => [
+ q(0131),
+ q(0),
+ ],
+ q(450) => [
+ q(0133),
+ q(0),
+ ],
+ q(454) => [
+ q(0134),
+ q(0),
+ ],
+ q(458) => [
+ q(0135),
+ q(0),
+ ],
+ q(462) => [
+ q(0136),
+ q(0),
+ ],
+ q(466) => [
+ q(0137),
+ q(0),
+ ],
+ q(470) => [
+ q(0138),
+ q(0),
+ ],
+ q(474) => [
+ q(0140),
+ q(0),
+ ],
+ q(478) => [
+ q(0141),
+ q(0),
+ ],
+ q(480) => [
+ q(0142),
+ q(0),
+ ],
+ q(484) => [
+ q(0144),
+ q(0),
+ ],
+ q(492) => [
+ q(0147),
+ q(0),
+ ],
+ q(496) => [
+ q(0148),
+ q(0),
+ ],
+ q(498) => [
+ q(0146),
+ q(6),
+ ],
+ q(499) => [
+ q(0149),
+ q(0),
+ ],
+ q(500) => [
+ q(0150),
+ q(0),
+ ],
+ q(504) => [
+ q(0151),
+ q(0),
+ ],
+ q(508) => [
+ q(0152),
+ q(0),
+ ],
+ q(512) => [
+ q(0167),
+ q(0),
+ ],
+ q(516) => [
+ q(0154),
+ q(0),
+ ],
+ q(520) => [
+ q(0155),
+ q(0),
+ ],
+ q(524) => [
+ q(0156),
+ q(0),
+ ],
+ q(528) => [
+ q(0157),
+ q(0),
+ ],
+ q(531) => [
+ q(0058),
+ q(0),
+ ],
+ q(533) => [
+ q(0013),
+ q(0),
+ ],
+ q(534) => [
+ q(0201),
+ q(1),
+ ],
+ q(535) => [
+ q(0028),
+ q(1),
+ ],
+ q(540) => [
+ q(0158),
+ q(0),
+ ],
+ q(548) => [
+ q(0240),
+ q(0),
+ ],
+ q(554) => [
+ q(0159),
+ q(0),
+ ],
+ q(558) => [
+ q(0160),
+ q(0),
+ ],
+ q(562) => [
+ q(0161),
+ q(0),
+ ],
+ q(566) => [
+ q(0162),
+ q(0),
+ ],
+ q(570) => [
+ q(0163),
+ q(0),
+ ],
+ q(574) => [
+ q(0164),
+ q(0),
+ ],
+ q(578) => [
+ q(0166),
+ q(0),
+ ],
+ q(580) => [
+ q(0165),
+ q(0),
+ ],
+ q(583) => [
+ q(0145),
+ q(0),
+ ],
+ q(584) => [
+ q(0139),
+ q(0),
+ ],
+ q(585) => [
+ q(0169),
+ q(0),
+ ],
+ q(586) => [
+ q(0168),
+ q(0),
+ ],
+ q(591) => [
+ q(0171),
+ q(0),
+ ],
+ q(598) => [
+ q(0172),
+ q(0),
+ ],
+ q(600) => [
+ q(0173),
+ q(0),
+ ],
+ q(604) => [
+ q(0174),
+ q(0),
+ ],
+ q(608) => [
+ q(0175),
+ q(0),
+ ],
+ q(612) => [
+ q(0176),
+ q(0),
+ ],
+ q(616) => [
+ q(0177),
+ q(0),
+ ],
+ q(620) => [
+ q(0178),
+ q(0),
+ ],
+ q(624) => [
+ q(0094),
+ q(0),
+ ],
+ q(626) => [
+ q(0222),
+ q(0),
+ ],
+ q(630) => [
+ q(0179),
+ q(0),
+ ],
+ q(634) => [
+ q(0180),
+ q(0),
+ ],
+ q(638) => [
+ q(0181),
+ q(0),
+ ],
+ q(642) => [
+ q(0182),
+ q(0),
+ ],
+ q(643) => [
+ q(0183),
+ q(4),
+ ],
+ q(646) => [
+ q(0184),
+ q(0),
+ ],
+ q(652) => [
+ q(0185),
+ q(0),
+ ],
+ q(654) => [
+ q(0186),
+ q(2),
+ ],
+ q(659) => [
+ q(0187),
+ q(0),
+ ],
+ q(660) => [
+ q(0008),
+ q(0),
+ ],
+ q(662) => [
+ q(0188),
+ q(0),
+ ],
+ q(663) => [
+ q(0189),
+ q(0),
+ ],
+ q(666) => [
+ q(0190),
+ q(0),
+ ],
+ q(670) => [
+ q(0191),
+ q(0),
+ ],
+ q(674) => [
+ q(0193),
+ q(0),
+ ],
+ q(678) => [
+ q(0194),
+ q(0),
+ ],
+ q(682) => [
+ q(0195),
+ q(0),
+ ],
+ q(686) => [
+ q(0196),
+ q(0),
+ ],
+ q(688) => [
+ q(0197),
+ q(0),
+ ],
+ q(690) => [
+ q(0198),
+ q(0),
+ ],
+ q(694) => [
+ q(0199),
+ q(0),
+ ],
+ q(702) => [
+ q(0200),
+ q(0),
+ ],
+ q(703) => [
+ q(0202),
+ q(0),
+ ],
+ q(704) => [
+ q(0242),
+ q(0),
+ ],
+ q(705) => [
+ q(0203),
+ q(0),
+ ],
+ q(706) => [
+ q(0205),
+ q(0),
+ ],
+ q(710) => [
+ q(0206),
+ q(0),
+ ],
+ q(716) => [
+ q(0249),
+ q(0),
+ ],
+ q(724) => [
+ q(0209),
+ q(0),
+ ],
+ q(728) => [
+ q(0208),
+ q(0),
+ ],
+ q(729) => [
+ q(0211),
+ q(0),
+ ],
+ q(732) => [
+ q(0246),
+ q(0),
+ ],
+ q(740) => [
+ q(0212),
+ q(0),
+ ],
+ q(748) => [
+ q(0214),
+ q(0),
+ ],
+ q(752) => [
+ q(0215),
+ q(0),
+ ],
+ q(756) => [
+ q(0216),
+ q(0),
+ ],
+ q(760) => [
+ q(0217),
+ q(0),
+ ],
+ q(762) => [
+ q(0219),
+ q(0),
+ ],
+ q(764) => [
+ q(0221),
+ q(0),
+ ],
+ q(768) => [
+ q(0223),
+ q(0),
+ ],
+ q(772) => [
+ q(0224),
+ q(0),
+ ],
+ q(776) => [
+ q(0225),
+ q(0),
+ ],
+ q(780) => [
+ q(0226),
+ q(0),
+ ],
+ q(784) => [
+ q(0234),
+ q(0),
+ ],
+ q(788) => [
+ q(0227),
+ q(0),
+ ],
+ q(792) => [
+ q(0228),
+ q(0),
+ ],
+ q(795) => [
+ q(0229),
+ q(0),
+ ],
+ q(796) => [
+ q(0230),
+ q(0),
+ ],
+ q(798) => [
+ q(0231),
+ q(0),
+ ],
+ q(800) => [
+ q(0232),
+ q(0),
+ ],
+ q(804) => [
+ q(0233),
+ q(0),
+ ],
+ q(807) => [
+ q(0132),
+ q(0),
+ ],
+ q(818) => [
+ q(0066),
+ q(0),
+ ],
+ q(826) => [
+ q(0235),
+ q(0),
+ ],
+ q(831) => [
+ q(0092),
+ q(0),
+ ],
+ q(832) => [
+ q(0113),
+ q(0),
+ ],
+ q(833) => [
+ q(0108),
+ q(0),
+ ],
+ q(834) => [
+ q(0220),
+ q(3),
+ ],
+ q(840) => [
+ q(0237),
+ q(0),
+ ],
+ q(850) => [
+ q(0244),
+ q(0),
+ ],
+ q(854) => [
+ q(0036),
+ q(0),
+ ],
+ q(858) => [
+ q(0238),
+ q(0),
+ ],
+ q(860) => [
+ q(0239),
+ q(0),
+ ],
+ q(862) => [
+ q(0241),
+ q(0),
+ ],
+ q(876) => [
+ q(0245),
+ q(0),
+ ],
+ q(882) => [
+ q(0192),
+ q(0),
+ ],
+ q(887) => [
+ q(0247),
+ q(0),
+ ],
+ q(894) => [
+ q(0248),
+ q(0),
+ ],
+ q(900) => [
+ q(0252),
+ q(0),
+ ],
+ q(901) => [
+ q(0272),
+ q(0),
+ ],
+ q(902) => [
+ q(0253),
+ q(0),
+ ],
+ q(903) => [
+ q(0254),
+ q(0),
+ ],
+ q(904) => [
+ q(0255),
+ q(0),
+ ],
+ q(905) => [
+ q(0256),
+ q(0),
+ ],
+ q(906) => [
+ q(0257),
+ q(0),
+ ],
+ q(907) => [
+ q(0258),
+ q(0),
+ ],
+ q(908) => [
+ q(0259),
+ q(0),
+ ],
+ q(909) => [
+ q(0260),
+ q(0),
+ ],
+ q(910) => [
+ q(0260),
+ q(1),
+ ],
+ q(911) => [
+ q(0260),
+ q(2),
+ ],
+ q(912) => [
+ q(0260),
+ q(3),
+ ],
+ q(913) => [
+ q(0260),
+ q(4),
+ ],
+ q(914) => [
+ q(0261),
+ q(0),
+ ],
+ q(915) => [
+ q(0262),
+ q(0),
+ ],
+ q(916) => [
+ q(0263),
+ q(0),
+ ],
+ q(917) => [
+ q(0264),
+ q(0),
+ ],
+ q(918) => [
+ q(0265),
+ q(0),
+ ],
+ q(919) => [
+ q(0266),
+ q(0),
+ ],
+ q(920) => [
+ q(0267),
+ q(0),
+ ],
+ q(921) => [
+ q(0268),
+ q(0),
+ ],
+ q(922) => [
+ q(0269),
+ q(0),
+ ],
+ q(923) => [
+ q(0270),
+ q(0),
+ ],
+ q(924) => [
+ q(0271),
+ q(0),
+ ],
+ q(925) => [
+ q(0273),
+ q(0),
+ ],
+ q(926) => [
+ q(0274),
+ q(0),
+ ],
+ q(927) => [
+ q(0275),
+ q(0),
+ ],
+ q(928) => [
+ q(0276),
+ q(0),
+ ],
+ q(929) => [
+ q(0277),
+ q(0),
+ ],
+ q(930) => [
+ q(0278),
+ q(0),
+ ],
+ q(931) => [
+ q(0279),
+ q(0),
+ ],
+ q(932) => [
+ q(0280),
+ q(0),
+ ],
+ q(933) => [
+ q(0281),
+ q(0),
+ ],
+ q(934) => [
+ q(0282),
+ q(0),
+ ],
+ },
+ q(numeric) => {
+ q(004) => [
+ q(0001),
+ q(0),
+ ],
+ q(008) => [
+ q(0003),
+ q(0),
+ ],
+ q(010) => [
+ q(0009),
+ q(0),
+ ],
+ q(012) => [
+ q(0004),
+ q(0),
+ ],
+ q(016) => [
+ q(0005),
+ q(0),
+ ],
+ q(020) => [
+ q(0006),
+ q(0),
+ ],
+ q(024) => [
+ q(0007),
+ q(0),
+ ],
+ q(028) => [
+ q(0010),
+ q(0),
+ ],
+ q(031) => [
+ q(0016),
+ q(0),
+ ],
+ q(032) => [
+ q(0011),
+ q(0),
+ ],
+ q(036) => [
+ q(0014),
+ q(0),
+ ],
+ q(040) => [
+ q(0015),
+ q(0),
+ ],
+ q(044) => [
+ q(0017),
+ q(0),
+ ],
+ q(048) => [
+ q(0018),
+ q(0),
+ ],
+ q(050) => [
+ q(0019),
+ q(0),
+ ],
+ q(051) => [
+ q(0012),
+ q(0),
+ ],
+ q(052) => [
+ q(0020),
+ q(0),
+ ],
+ q(056) => [
+ q(0022),
+ q(0),
+ ],
+ q(060) => [
+ q(0025),
+ q(0),
+ ],
+ q(064) => [
+ q(0026),
+ q(0),
+ ],
+ q(068) => [
+ q(0027),
+ q(0),
+ ],
+ q(070) => [
+ q(0029),
+ q(0),
+ ],
+ q(072) => [
+ q(0030),
+ q(0),
+ ],
+ q(074) => [
+ q(0031),
+ q(0),
+ ],
+ q(076) => [
+ q(0032),
+ q(0),
+ ],
+ q(084) => [
+ q(0023),
+ q(0),
+ ],
+ q(086) => [
+ q(0033),
+ q(0),
+ ],
+ q(090) => [
+ q(0204),
+ q(0),
+ ],
+ q(092) => [
+ q(0243),
+ q(0),
+ ],
+ q(096) => [
+ q(0034),
+ q(0),
+ ],
+ q(100) => [
+ q(0035),
+ q(0),
+ ],
+ q(104) => [
+ q(0153),
+ q(0),
+ ],
+ q(108) => [
+ q(0037),
+ q(0),
+ ],
+ q(112) => [
+ q(0021),
+ q(0),
+ ],
+ q(116) => [
+ q(0039),
+ q(0),
+ ],
+ q(120) => [
+ q(0040),
+ q(0),
+ ],
+ q(124) => [
+ q(0041),
+ q(0),
+ ],
+ q(132) => [
+ q(0038),
+ q(0),
+ ],
+ q(136) => [
+ q(0042),
+ q(0),
+ ],
+ q(140) => [
+ q(0043),
+ q(0),
+ ],
+ q(144) => [
+ q(0210),
+ q(0),
+ ],
+ q(148) => [
+ q(0044),
+ q(0),
+ ],
+ q(152) => [
+ q(0045),
+ q(0),
+ ],
+ q(156) => [
+ q(0046),
+ q(0),
+ ],
+ q(158) => [
+ q(0218),
+ q(0),
+ ],
+ q(162) => [
+ q(0047),
+ q(0),
+ ],
+ q(166) => [
+ q(0048),
+ q(0),
+ ],
+ q(170) => [
+ q(0049),
+ q(0),
+ ],
+ q(174) => [
+ q(0050),
+ q(0),
+ ],
+ q(175) => [
+ q(0143),
+ q(0),
+ ],
+ q(178) => [
+ q(0052),
+ q(0),
+ ],
+ q(180) => [
+ q(0051),
+ q(0),
+ ],
+ q(184) => [
+ q(0053),
+ q(0),
+ ],
+ q(188) => [
+ q(0054),
+ q(0),
+ ],
+ q(191) => [
+ q(0056),
+ q(0),
+ ],
+ q(192) => [
+ q(0057),
+ q(0),
+ ],
+ q(196) => [
+ q(0059),
+ q(0),
+ ],
+ q(203) => [
+ q(0060),
+ q(0),
+ ],
+ q(204) => [
+ q(0024),
+ q(0),
+ ],
+ q(208) => [
+ q(0061),
+ q(0),
+ ],
+ q(212) => [
+ q(0063),
+ q(0),
+ ],
+ q(214) => [
+ q(0064),
+ q(0),
+ ],
+ q(218) => [
+ q(0065),
+ q(0),
+ ],
+ q(222) => [
+ q(0067),
+ q(0),
+ ],
+ q(226) => [
+ q(0068),
+ q(0),
+ ],
+ q(231) => [
+ q(0071),
+ q(0),
+ ],
+ q(232) => [
+ q(0069),
+ q(0),
+ ],
+ q(233) => [
+ q(0070),
+ q(0),
+ ],
+ q(234) => [
+ q(0073),
+ q(0),
+ ],
+ q(238) => [
+ q(0072),
+ q(0),
+ ],
+ q(239) => [
+ q(0207),
+ q(0),
+ ],
+ q(242) => [
+ q(0074),
+ q(0),
+ ],
+ q(246) => [
+ q(0075),
+ q(0),
+ ],
+ q(248) => [
+ q(0002),
+ q(0),
+ ],
+ q(250) => [
+ q(0076),
+ q(0),
+ ],
+ q(254) => [
+ q(0077),
+ q(0),
+ ],
+ q(258) => [
+ q(0078),
+ q(0),
+ ],
+ q(260) => [
+ q(0079),
+ q(0),
+ ],
+ q(262) => [
+ q(0062),
+ q(0),
+ ],
+ q(266) => [
+ q(0080),
+ q(0),
+ ],
+ q(268) => [
+ q(0082),
+ q(0),
+ ],
+ q(270) => [
+ q(0081),
+ q(0),
+ ],
+ q(275) => [
+ q(0170),
+ q(0),
+ ],
+ q(276) => [
+ q(0083),
+ q(0),
+ ],
+ q(288) => [
+ q(0084),
+ q(0),
+ ],
+ q(292) => [
+ q(0085),
+ q(0),
+ ],
+ q(296) => [
+ q(0117),
+ q(0),
+ ],
+ q(300) => [
+ q(0086),
+ q(0),
+ ],
+ q(304) => [
+ q(0087),
+ q(0),
+ ],
+ q(308) => [
+ q(0088),
+ q(0),
+ ],
+ q(312) => [
+ q(0089),
+ q(0),
+ ],
+ q(316) => [
+ q(0090),
+ q(0),
+ ],
+ q(320) => [
+ q(0091),
+ q(0),
+ ],
+ q(324) => [
+ q(0093),
+ q(0),
+ ],
+ q(328) => [
+ q(0095),
+ q(0),
+ ],
+ q(332) => [
+ q(0096),
+ q(0),
+ ],
+ q(334) => [
+ q(0097),
+ q(0),
+ ],
+ q(336) => [
+ q(0098),
+ q(0),
+ ],
+ q(340) => [
+ q(0099),
+ q(0),
+ ],
+ q(344) => [
+ q(0100),
+ q(0),
+ ],
+ q(348) => [
+ q(0101),
+ q(0),
+ ],
+ q(352) => [
+ q(0102),
+ q(0),
+ ],
+ q(356) => [
+ q(0103),
+ q(0),
+ ],
+ q(360) => [
+ q(0104),
+ q(0),
+ ],
+ q(364) => [
+ q(0105),
+ q(0),
+ ],
+ q(368) => [
+ q(0106),
+ q(0),
+ ],
+ q(372) => [
+ q(0107),
+ q(0),
+ ],
+ q(376) => [
+ q(0109),
+ q(0),
+ ],
+ q(380) => [
+ q(0110),
+ q(0),
+ ],
+ q(384) => [
+ q(0055),
+ q(0),
+ ],
+ q(388) => [
+ q(0111),
+ q(0),
+ ],
+ q(392) => [
+ q(0112),
+ q(0),
+ ],
+ q(398) => [
+ q(0115),
+ q(0),
+ ],
+ q(400) => [
+ q(0114),
+ q(0),
+ ],
+ q(404) => [
+ q(0116),
+ q(0),
+ ],
+ q(408) => [
+ q(0118),
+ q(0),
+ ],
+ q(410) => [
+ q(0119),
+ q(0),
+ ],
+ q(414) => [
+ q(0120),
+ q(0),
+ ],
+ q(417) => [
+ q(0121),
+ q(0),
+ ],
+ q(418) => [
+ q(0122),
+ q(0),
+ ],
+ q(422) => [
+ q(0124),
+ q(0),
+ ],
+ q(426) => [
+ q(0125),
+ q(0),
+ ],
+ q(428) => [
+ q(0123),
+ q(0),
+ ],
+ q(430) => [
+ q(0126),
+ q(0),
+ ],
+ q(434) => [
+ q(0127),
+ q(0),
+ ],
+ q(438) => [
+ q(0128),
+ q(0),
+ ],
+ q(440) => [
+ q(0129),
+ q(0),
+ ],
+ q(442) => [
+ q(0130),
+ q(0),
+ ],
+ q(446) => [
+ q(0131),
+ q(0),
+ ],
+ q(450) => [
+ q(0133),
+ q(0),
+ ],
+ q(454) => [
+ q(0134),
+ q(0),
+ ],
+ q(458) => [
+ q(0135),
+ q(0),
+ ],
+ q(462) => [
+ q(0136),
+ q(0),
+ ],
+ q(466) => [
+ q(0137),
+ q(0),
+ ],
+ q(470) => [
+ q(0138),
+ q(0),
+ ],
+ q(474) => [
+ q(0140),
+ q(0),
+ ],
+ q(478) => [
+ q(0141),
+ q(0),
+ ],
+ q(480) => [
+ q(0142),
+ q(0),
+ ],
+ q(484) => [
+ q(0144),
+ q(0),
+ ],
+ q(492) => [
+ q(0147),
+ q(0),
+ ],
+ q(496) => [
+ q(0148),
+ q(0),
+ ],
+ q(498) => [
+ q(0146),
+ q(0),
+ ],
+ q(499) => [
+ q(0149),
+ q(0),
+ ],
+ q(500) => [
+ q(0150),
+ q(0),
+ ],
+ q(504) => [
+ q(0151),
+ q(0),
+ ],
+ q(508) => [
+ q(0152),
+ q(0),
+ ],
+ q(512) => [
+ q(0167),
+ q(0),
+ ],
+ q(516) => [
+ q(0154),
+ q(0),
+ ],
+ q(520) => [
+ q(0155),
+ q(0),
+ ],
+ q(524) => [
+ q(0156),
+ q(0),
+ ],
+ q(528) => [
+ q(0157),
+ q(0),
+ ],
+ q(531) => [
+ q(0058),
+ q(0),
+ ],
+ q(533) => [
+ q(0013),
+ q(0),
+ ],
+ q(534) => [
+ q(0201),
+ q(0),
+ ],
+ q(535) => [
+ q(0028),
+ q(0),
+ ],
+ q(540) => [
+ q(0158),
+ q(0),
+ ],
+ q(548) => [
+ q(0240),
+ q(0),
+ ],
+ q(554) => [
+ q(0159),
+ q(0),
+ ],
+ q(558) => [
+ q(0160),
+ q(0),
+ ],
+ q(562) => [
+ q(0161),
+ q(0),
+ ],
+ q(566) => [
+ q(0162),
+ q(0),
+ ],
+ q(570) => [
+ q(0163),
+ q(0),
+ ],
+ q(574) => [
+ q(0164),
+ q(0),
+ ],
+ q(578) => [
+ q(0166),
+ q(0),
+ ],
+ q(580) => [
+ q(0165),
+ q(0),
+ ],
+ q(581) => [
+ q(0236),
+ q(0),
+ ],
+ q(583) => [
+ q(0145),
+ q(0),
+ ],
+ q(584) => [
+ q(0139),
+ q(0),
+ ],
+ q(585) => [
+ q(0169),
+ q(0),
+ ],
+ q(586) => [
+ q(0168),
+ q(0),
+ ],
+ q(591) => [
+ q(0171),
+ q(0),
+ ],
+ q(598) => [
+ q(0172),
+ q(0),
+ ],
+ q(600) => [
+ q(0173),
+ q(0),
+ ],
+ q(604) => [
+ q(0174),
+ q(0),
+ ],
+ q(608) => [
+ q(0175),
+ q(0),
+ ],
+ q(612) => [
+ q(0176),
+ q(0),
+ ],
+ q(616) => [
+ q(0177),
+ q(0),
+ ],
+ q(620) => [
+ q(0178),
+ q(0),
+ ],
+ q(624) => [
+ q(0094),
+ q(0),
+ ],
+ q(626) => [
+ q(0222),
+ q(0),
+ ],
+ q(630) => [
+ q(0179),
+ q(0),
+ ],
+ q(634) => [
+ q(0180),
+ q(0),
+ ],
+ q(638) => [
+ q(0181),
+ q(0),
+ ],
+ q(642) => [
+ q(0182),
+ q(0),
+ ],
+ q(643) => [
+ q(0183),
+ q(0),
+ ],
+ q(646) => [
+ q(0184),
+ q(0),
+ ],
+ q(652) => [
+ q(0185),
+ q(0),
+ ],
+ q(654) => [
+ q(0186),
+ q(0),
+ ],
+ q(659) => [
+ q(0187),
+ q(0),
+ ],
+ q(660) => [
+ q(0008),
+ q(0),
+ ],
+ q(662) => [
+ q(0188),
+ q(0),
+ ],
+ q(663) => [
+ q(0189),
+ q(0),
+ ],
+ q(666) => [
+ q(0190),
+ q(0),
+ ],
+ q(670) => [
+ q(0191),
+ q(0),
+ ],
+ q(674) => [
+ q(0193),
+ q(0),
+ ],
+ q(678) => [
+ q(0194),
+ q(0),
+ ],
+ q(682) => [
+ q(0195),
+ q(0),
+ ],
+ q(686) => [
+ q(0196),
+ q(0),
+ ],
+ q(688) => [
+ q(0197),
+ q(0),
+ ],
+ q(690) => [
+ q(0198),
+ q(0),
+ ],
+ q(694) => [
+ q(0199),
+ q(0),
+ ],
+ q(702) => [
+ q(0200),
+ q(0),
+ ],
+ q(703) => [
+ q(0202),
+ q(0),
+ ],
+ q(704) => [
+ q(0242),
+ q(0),
+ ],
+ q(705) => [
+ q(0203),
+ q(0),
+ ],
+ q(706) => [
+ q(0205),
+ q(0),
+ ],
+ q(710) => [
+ q(0206),
+ q(0),
+ ],
+ q(716) => [
+ q(0249),
+ q(0),
+ ],
+ q(724) => [
+ q(0209),
+ q(0),
+ ],
+ q(728) => [
+ q(0208),
+ q(0),
+ ],
+ q(729) => [
+ q(0211),
+ q(0),
+ ],
+ q(732) => [
+ q(0246),
+ q(0),
+ ],
+ q(740) => [
+ q(0212),
+ q(0),
+ ],
+ q(744) => [
+ q(0213),
+ q(0),
+ ],
+ q(748) => [
+ q(0214),
+ q(0),
+ ],
+ q(752) => [
+ q(0215),
+ q(0),
+ ],
+ q(756) => [
+ q(0216),
+ q(0),
+ ],
+ q(760) => [
+ q(0217),
+ q(0),
+ ],
+ q(762) => [
+ q(0219),
+ q(0),
+ ],
+ q(764) => [
+ q(0221),
+ q(0),
+ ],
+ q(768) => [
+ q(0223),
+ q(0),
+ ],
+ q(772) => [
+ q(0224),
+ q(0),
+ ],
+ q(776) => [
+ q(0225),
+ q(0),
+ ],
+ q(780) => [
+ q(0226),
+ q(0),
+ ],
+ q(784) => [
+ q(0234),
+ q(0),
+ ],
+ q(788) => [
+ q(0227),
+ q(0),
+ ],
+ q(792) => [
+ q(0228),
+ q(0),
+ ],
+ q(795) => [
+ q(0229),
+ q(0),
+ ],
+ q(796) => [
+ q(0230),
+ q(0),
+ ],
+ q(798) => [
+ q(0231),
+ q(0),
+ ],
+ q(800) => [
+ q(0232),
+ q(0),
+ ],
+ q(804) => [
+ q(0233),
+ q(0),
+ ],
+ q(807) => [
+ q(0132),
+ q(0),
+ ],
+ q(818) => [
+ q(0066),
+ q(0),
+ ],
+ q(826) => [
+ q(0235),
+ q(0),
+ ],
+ q(831) => [
+ q(0092),
+ q(0),
+ ],
+ q(832) => [
+ q(0113),
+ q(0),
+ ],
+ q(833) => [
+ q(0108),
+ q(0),
+ ],
+ q(834) => [
+ q(0220),
+ q(0),
+ ],
+ q(840) => [
+ q(0237),
+ q(0),
+ ],
+ q(850) => [
+ q(0244),
+ q(0),
+ ],
+ q(854) => [
+ q(0036),
+ q(0),
+ ],
+ q(858) => [
+ q(0238),
+ q(0),
+ ],
+ q(860) => [
+ q(0239),
+ q(0),
+ ],
+ q(862) => [
+ q(0241),
+ q(0),
+ ],
+ q(876) => [
+ q(0245),
+ q(0),
+ ],
+ q(882) => [
+ q(0192),
+ q(0),
+ ],
+ q(887) => [
+ q(0247),
+ q(0),
+ ],
+ q(894) => [
+ q(0248),
+ q(0),
+ ],
+ },
+ q(un-alpha-3) => {
+ q(ABW) => [
+ q(0013),
+ q(0),
+ ],
+ q(AFG) => [
+ q(0001),
+ q(0),
+ ],
+ q(AGO) => [
+ q(0007),
+ q(0),
+ ],
+ q(AIA) => [
+ q(0008),
+ q(0),
+ ],
+ q(ALA) => [
+ q(0002),
+ q(0),
+ ],
+ q(ALB) => [
+ q(0003),
+ q(0),
+ ],
+ q(AND) => [
+ q(0006),
+ q(0),
+ ],
+ q(ARG) => [
+ q(0011),
+ q(0),
+ ],
+ q(ARM) => [
+ q(0012),
+ q(0),
+ ],
+ q(ASM) => [
+ q(0005),
+ q(0),
+ ],
+ q(ATG) => [
+ q(0010),
+ q(0),
+ ],
+ q(AUS) => [
+ q(0014),
+ q(0),
+ ],
+ q(AUT) => [
+ q(0015),
+ q(0),
+ ],
+ q(AZE) => [
+ q(0016),
+ q(0),
+ ],
+ q(BDI) => [
+ q(0037),
+ q(0),
+ ],
+ q(BEL) => [
+ q(0022),
+ q(0),
+ ],
+ q(BEN) => [
+ q(0024),
+ q(0),
+ ],
+ q(BES) => [
+ q(0028),
+ q(0),
+ ],
+ q(BFA) => [
+ q(0036),
+ q(0),
+ ],
+ q(BGD) => [
+ q(0019),
+ q(0),
+ ],
+ q(BGR) => [
+ q(0035),
+ q(0),
+ ],
+ q(BHR) => [
+ q(0018),
+ q(0),
+ ],
+ q(BHS) => [
+ q(0017),
+ q(0),
+ ],
+ q(BIH) => [
+ q(0029),
+ q(0),
+ ],
+ q(BLM) => [
+ q(0185),
+ q(0),
+ ],
+ q(BLR) => [
+ q(0021),
+ q(0),
+ ],
+ q(BLZ) => [
+ q(0023),
+ q(0),
+ ],
+ q(BMU) => [
+ q(0025),
+ q(0),
+ ],
+ q(BOL) => [
+ q(0027),
+ q(0),
+ ],
+ q(BRA) => [
+ q(0032),
+ q(0),
+ ],
+ q(BRB) => [
+ q(0020),
+ q(0),
+ ],
+ q(BRN) => [
+ q(0034),
+ q(0),
+ ],
+ q(BTN) => [
+ q(0026),
+ q(0),
+ ],
+ q(BWA) => [
+ q(0030),
+ q(0),
+ ],
+ q(CAF) => [
+ q(0043),
+ q(0),
+ ],
+ q(CAN) => [
+ q(0041),
+ q(0),
+ ],
+ q(CHL) => [
+ q(0045),
+ q(0),
+ ],
+ q(CHN) => [
+ q(0046),
+ q(0),
+ ],
+ q(CIV) => [
+ q(0055),
+ q(0),
+ ],
+ q(CMR) => [
+ q(0040),
+ q(0),
+ ],
+ q(COD) => [
+ q(0051),
+ q(0),
+ ],
+ q(COG) => [
+ q(0052),
+ q(0),
+ ],
+ q(COK) => [
+ q(0053),
+ q(0),
+ ],
+ q(COL) => [
+ q(0049),
+ q(0),
+ ],
+ q(COM) => [
+ q(0050),
+ q(0),
+ ],
+ q(CPV) => [
+ q(0038),
+ q(0),
+ ],
+ q(CRI) => [
+ q(0054),
+ q(0),
+ ],
+ q(CUB) => [
+ q(0057),
+ q(0),
+ ],
+ q(CUW) => [
+ q(0058),
+ q(0),
+ ],
+ q(CYM) => [
+ q(0042),
+ q(0),
+ ],
+ q(CYP) => [
+ q(0059),
+ q(0),
+ ],
+ q(CZE) => [
+ q(0060),
+ q(0),
+ ],
+ q(DEU) => [
+ q(0083),
+ q(0),
+ ],
+ q(DJI) => [
+ q(0062),
+ q(0),
+ ],
+ q(DMA) => [
+ q(0063),
+ q(0),
+ ],
+ q(DNK) => [
+ q(0061),
+ q(0),
+ ],
+ q(DOM) => [
+ q(0064),
+ q(0),
+ ],
+ q(DZA) => [
+ q(0004),
+ q(0),
+ ],
+ q(ECU) => [
+ q(0065),
+ q(0),
+ ],
+ q(EGY) => [
+ q(0066),
+ q(0),
+ ],
+ q(ERI) => [
+ q(0069),
+ q(0),
+ ],
+ q(ESP) => [
+ q(0209),
+ q(0),
+ ],
+ q(EST) => [
+ q(0070),
+ q(0),
+ ],
+ q(ETH) => [
+ q(0071),
+ q(0),
+ ],
+ q(FIN) => [
+ q(0075),
+ q(0),
+ ],
+ q(FJI) => [
+ q(0074),
+ q(0),
+ ],
+ q(FLK) => [
+ q(0072),
+ q(0),
+ ],
+ q(FRA) => [
+ q(0076),
+ q(0),
+ ],
+ q(FRO) => [
+ q(0073),
+ q(0),
+ ],
+ q(FSM) => [
+ q(0145),
+ q(0),
+ ],
+ q(GAB) => [
+ q(0080),
+ q(0),
+ ],
+ q(GEO) => [
+ q(0082),
+ q(0),
+ ],
+ q(GGY) => [
+ q(0092),
+ q(0),
+ ],
+ q(GHA) => [
+ q(0084),
+ q(0),
+ ],
+ q(GIB) => [
+ q(0085),
+ q(0),
+ ],
+ q(GIN) => [
+ q(0093),
+ q(0),
+ ],
+ q(GLP) => [
+ q(0089),
+ q(0),
+ ],
+ q(GMB) => [
+ q(0081),
+ q(0),
+ ],
+ q(GNB) => [
+ q(0094),
+ q(0),
+ ],
+ q(GNQ) => [
+ q(0068),
+ q(0),
+ ],
+ q(GRC) => [
+ q(0086),
+ q(0),
+ ],
+ q(GRD) => [
+ q(0088),
+ q(0),
+ ],
+ q(GRL) => [
+ q(0087),
+ q(0),
+ ],
+ q(GTM) => [
+ q(0091),
+ q(0),
+ ],
+ q(GUF) => [
+ q(0077),
+ q(0),
+ ],
+ q(GUM) => [
+ q(0090),
+ q(0),
+ ],
+ q(GUY) => [
+ q(0095),
+ q(0),
+ ],
+ q(HKG) => [
+ q(0100),
+ q(0),
+ ],
+ q(HND) => [
+ q(0099),
+ q(0),
+ ],
+ q(HRV) => [
+ q(0056),
+ q(0),
+ ],
+ q(HTI) => [
+ q(0096),
+ q(0),
+ ],
+ q(HUN) => [
+ q(0101),
+ q(0),
+ ],
+ q(IDN) => [
+ q(0104),
+ q(0),
+ ],
+ q(IMN) => [
+ q(0108),
+ q(0),
+ ],
+ q(IND) => [
+ q(0103),
+ q(0),
+ ],
+ q(IRL) => [
+ q(0107),
+ q(0),
+ ],
+ q(IRN) => [
+ q(0105),
+ q(0),
+ ],
+ q(IRQ) => [
+ q(0106),
+ q(0),
+ ],
+ q(ISL) => [
+ q(0102),
+ q(0),
+ ],
+ q(ISR) => [
+ q(0109),
+ q(0),
+ ],
+ q(ITA) => [
+ q(0110),
+ q(0),
+ ],
+ q(JAM) => [
+ q(0111),
+ q(0),
+ ],
+ q(JEY) => [
+ q(0113),
+ q(0),
+ ],
+ q(JOR) => [
+ q(0114),
+ q(0),
+ ],
+ q(JPN) => [
+ q(0112),
+ q(0),
+ ],
+ q(KAZ) => [
+ q(0115),
+ q(0),
+ ],
+ q(KEN) => [
+ q(0116),
+ q(0),
+ ],
+ q(KGZ) => [
+ q(0121),
+ q(0),
+ ],
+ q(KHM) => [
+ q(0039),
+ q(0),
+ ],
+ q(KIR) => [
+ q(0117),
+ q(0),
+ ],
+ q(KNA) => [
+ q(0187),
+ q(0),
+ ],
+ q(KOR) => [
+ q(0119),
+ q(0),
+ ],
+ q(KWT) => [
+ q(0120),
+ q(0),
+ ],
+ q(LAO) => [
+ q(0122),
+ q(0),
+ ],
+ q(LBN) => [
+ q(0124),
+ q(0),
+ ],
+ q(LBR) => [
+ q(0126),
+ q(0),
+ ],
+ q(LBY) => [
+ q(0127),
+ q(0),
+ ],
+ q(LCA) => [
+ q(0188),
+ q(0),
+ ],
+ q(LIE) => [
+ q(0128),
+ q(0),
+ ],
+ q(LKA) => [
+ q(0210),
+ q(0),
+ ],
+ q(LSO) => [
+ q(0125),
+ q(0),
+ ],
+ q(LTU) => [
+ q(0129),
+ q(0),
+ ],
+ q(LUX) => [
+ q(0130),
+ q(0),
+ ],
+ q(LVA) => [
+ q(0123),
+ q(0),
+ ],
+ q(MAC) => [
+ q(0131),
+ q(0),
+ ],
+ q(MAF) => [
+ q(0189),
+ q(0),
+ ],
+ q(MAR) => [
+ q(0151),
+ q(0),
+ ],
+ q(MCO) => [
+ q(0147),
+ q(0),
+ ],
+ q(MDA) => [
+ q(0146),
+ q(0),
+ ],
+ q(MDG) => [
+ q(0133),
+ q(0),
+ ],
+ q(MDV) => [
+ q(0136),
+ q(0),
+ ],
+ q(MEX) => [
+ q(0144),
+ q(0),
+ ],
+ q(MHL) => [
+ q(0139),
+ q(0),
+ ],
+ q(MLI) => [
+ q(0137),
+ q(0),
+ ],
+ q(MLT) => [
+ q(0138),
+ q(0),
+ ],
+ q(MMR) => [
+ q(0153),
+ q(0),
+ ],
+ q(MNE) => [
+ q(0149),
+ q(0),
+ ],
+ q(MNG) => [
+ q(0148),
+ q(0),
+ ],
+ q(MNP) => [
+ q(0165),
+ q(0),
+ ],
+ q(MOZ) => [
+ q(0152),
+ q(0),
+ ],
+ q(MRT) => [
+ q(0141),
+ q(0),
+ ],
+ q(MSR) => [
+ q(0150),
+ q(0),
+ ],
+ q(MTQ) => [
+ q(0140),
+ q(0),
+ ],
+ q(MUS) => [
+ q(0142),
+ q(0),
+ ],
+ q(MWI) => [
+ q(0134),
+ q(0),
+ ],
+ q(MYS) => [
+ q(0135),
+ q(0),
+ ],
+ q(MYT) => [
+ q(0143),
+ q(0),
+ ],
+ q(NAM) => [
+ q(0154),
+ q(0),
+ ],
+ q(NCL) => [
+ q(0158),
+ q(0),
+ ],
+ q(NER) => [
+ q(0161),
+ q(0),
+ ],
+ q(NFK) => [
+ q(0164),
+ q(0),
+ ],
+ q(NGA) => [
+ q(0162),
+ q(0),
+ ],
+ q(NIC) => [
+ q(0160),
+ q(0),
+ ],
+ q(NIU) => [
+ q(0163),
+ q(0),
+ ],
+ q(NLD) => [
+ q(0157),
+ q(0),
+ ],
+ q(NOR) => [
+ q(0166),
+ q(0),
+ ],
+ q(NPL) => [
+ q(0156),
+ q(0),
+ ],
+ q(NRU) => [
+ q(0155),
+ q(0),
+ ],
+ q(NZL) => [
+ q(0159),
+ q(0),
+ ],
+ q(OMN) => [
+ q(0167),
+ q(0),
+ ],
+ q(PAK) => [
+ q(0168),
+ q(0),
+ ],
+ q(PAN) => [
+ q(0171),
+ q(0),
+ ],
+ q(PCN) => [
+ q(0176),
+ q(0),
+ ],
+ q(PER) => [
+ q(0174),
+ q(0),
+ ],
+ q(PHL) => [
+ q(0175),
+ q(0),
+ ],
+ q(PLW) => [
+ q(0169),
+ q(0),
+ ],
+ q(PNG) => [
+ q(0172),
+ q(0),
+ ],
+ q(POL) => [
+ q(0177),
+ q(0),
+ ],
+ q(PRI) => [
+ q(0179),
+ q(0),
+ ],
+ q(PRK) => [
+ q(0118),
+ q(0),
+ ],
+ q(PRT) => [
+ q(0178),
+ q(0),
+ ],
+ q(PRY) => [
+ q(0173),
+ q(0),
+ ],
+ q(PSE) => [
+ q(0170),
+ q(0),
+ ],
+ q(PYF) => [
+ q(0078),
+ q(0),
+ ],
+ q(QAT) => [
+ q(0180),
+ q(0),
+ ],
+ q(REU) => [
+ q(0181),
+ q(0),
+ ],
+ q(ROU) => [
+ q(0182),
+ q(0),
+ ],
+ q(RUS) => [
+ q(0183),
+ q(0),
+ ],
+ q(RWA) => [
+ q(0184),
+ q(0),
+ ],
+ q(SAU) => [
+ q(0195),
+ q(0),
+ ],
+ q(SEN) => [
+ q(0196),
+ q(0),
+ ],
+ q(SGP) => [
+ q(0200),
+ q(0),
+ ],
+ q(SHN) => [
+ q(0186),
+ q(0),
+ ],
+ q(SLB) => [
+ q(0204),
+ q(0),
+ ],
+ q(SLE) => [
+ q(0199),
+ q(0),
+ ],
+ q(SLV) => [
+ q(0067),
+ q(0),
+ ],
+ q(SMR) => [
+ q(0193),
+ q(0),
+ ],
+ q(SOM) => [
+ q(0205),
+ q(0),
+ ],
+ q(SPM) => [
+ q(0190),
+ q(0),
+ ],
+ q(SRB) => [
+ q(0197),
+ q(0),
+ ],
+ q(SSD) => [
+ q(0208),
+ q(0),
+ ],
+ q(STP) => [
+ q(0194),
+ q(0),
+ ],
+ q(SVK) => [
+ q(0202),
+ q(0),
+ ],
+ q(SVN) => [
+ q(0203),
+ q(0),
+ ],
+ q(SXM) => [
+ q(0201),
+ q(0),
+ ],
+ q(SYC) => [
+ q(0198),
+ q(0),
+ ],
+ q(TCD) => [
+ q(0044),
+ q(0),
+ ],
+ q(VAT) => [
+ q(0098),
+ q(0),
+ ],
+ q(VCT) => [
+ q(0191),
+ q(0),
+ ],
+ q(VGB) => [
+ q(0243),
+ q(0),
+ ],
+ q(WSM) => [
+ q(0192),
+ q(0),
+ ],
+ q(ZAF) => [
+ q(0206),
+ q(0),
+ ],
+ },
+ q(un-numeric) => {
+ q(004) => [
+ q(0001),
+ q(0),
+ ],
+ q(008) => [
+ q(0003),
+ q(0),
+ ],
+ q(012) => [
+ q(0004),
+ q(0),
+ ],
+ q(016) => [
+ q(0005),
+ q(0),
+ ],
+ q(020) => [
+ q(0006),
+ q(0),
+ ],
+ q(024) => [
+ q(0007),
+ q(0),
+ ],
+ q(028) => [
+ q(0010),
+ q(0),
+ ],
+ q(031) => [
+ q(0016),
+ q(0),
+ ],
+ q(032) => [
+ q(0011),
+ q(0),
+ ],
+ q(036) => [
+ q(0014),
+ q(0),
+ ],
+ q(040) => [
+ q(0015),
+ q(0),
+ ],
+ q(044) => [
+ q(0017),
+ q(0),
+ ],
+ q(048) => [
+ q(0018),
+ q(0),
+ ],
+ q(050) => [
+ q(0019),
+ q(0),
+ ],
+ q(051) => [
+ q(0012),
+ q(0),
+ ],
+ q(052) => [
+ q(0020),
+ q(0),
+ ],
+ q(056) => [
+ q(0022),
+ q(0),
+ ],
+ q(060) => [
+ q(0025),
+ q(0),
+ ],
+ q(064) => [
+ q(0026),
+ q(0),
+ ],
+ q(068) => [
+ q(0027),
+ q(0),
+ ],
+ q(070) => [
+ q(0029),
+ q(0),
+ ],
+ q(072) => [
+ q(0030),
+ q(0),
+ ],
+ q(076) => [
+ q(0032),
+ q(0),
+ ],
+ q(084) => [
+ q(0023),
+ q(0),
+ ],
+ q(090) => [
+ q(0204),
+ q(0),
+ ],
+ q(092) => [
+ q(0243),
+ q(0),
+ ],
+ q(096) => [
+ q(0034),
+ q(0),
+ ],
+ q(100) => [
+ q(0035),
+ q(0),
+ ],
+ q(104) => [
+ q(0153),
+ q(0),
+ ],
+ q(108) => [
+ q(0037),
+ q(0),
+ ],
+ q(112) => [
+ q(0021),
+ q(0),
+ ],
+ q(116) => [
+ q(0039),
+ q(0),
+ ],
+ q(120) => [
+ q(0040),
+ q(0),
+ ],
+ q(124) => [
+ q(0041),
+ q(0),
+ ],
+ q(132) => [
+ q(0038),
+ q(0),
+ ],
+ q(136) => [
+ q(0042),
+ q(0),
+ ],
+ q(140) => [
+ q(0043),
+ q(0),
+ ],
+ q(144) => [
q(0210),
q(0),
],
q(0046),
q(0),
],
- q(158) => [
- q(0218),
- q(0),
- ],
- q(162) => [
- q(0047),
- q(0),
- ],
- q(166) => [
- q(0048),
- q(0),
- ],
q(170) => [
q(0049),
q(0),
q(0072),
q(0),
],
- q(239) => [
- q(0207),
- q(0),
- ],
q(242) => [
q(0074),
q(0),
q(0078),
q(0),
],
- q(260) => [
- q(0079),
- q(0),
- ],
q(262) => [
q(0062),
q(0),
q(0096),
q(0),
],
- q(334) => [
- q(0097),
- q(0),
- ],
q(336) => [
q(0098),
q(0),
q(0158),
q(0),
],
- q(548) => [
- q(0240),
- q(0),
- ],
q(554) => [
q(0159),
q(0),
q(0165),
q(0),
],
- q(581) => [
- q(0236),
- q(0),
- ],
q(583) => [
q(0145),
q(0),
q(0094),
q(0),
],
- q(626) => [
- q(0222),
- q(0),
- ],
q(630) => [
q(0179),
q(0),
q(0194),
q(0),
],
+ q(680) => [
+ q(0251),
+ q(0),
+ ],
q(682) => [
q(0195),
q(0),
q(0200),
q(0),
],
- q(703) => [
- q(0202),
- q(0),
- ],
- q(704) => [
- q(0242),
- q(0),
- ],
- q(705) => [
- q(0203),
- q(0),
- ],
- q(706) => [
- q(0205),
- q(0),
- ],
- q(710) => [
- q(0206),
- q(0),
- ],
- q(716) => [
- q(0249),
- q(0),
- ],
- q(724) => [
- q(0209),
- q(0),
- ],
- q(728) => [
- q(0208),
- q(0),
- ],
- q(729) => [
- q(0211),
- q(0),
- ],
- q(732) => [
- q(0246),
- q(0),
- ],
- q(740) => [
- q(0212),
- q(0),
- ],
- q(744) => [
- q(0213),
- q(0),
- ],
- q(748) => [
- q(0214),
- q(0),
- ],
- q(752) => [
- q(0215),
- q(0),
- ],
- q(756) => [
- q(0216),
- q(0),
- ],
- q(760) => [
- q(0217),
- q(0),
- ],
- q(762) => [
- q(0219),
- q(0),
- ],
- q(764) => [
- q(0221),
- q(0),
- ],
- q(768) => [
- q(0223),
- q(0),
- ],
- q(772) => [
- q(0224),
- q(0),
- ],
- q(776) => [
- q(0225),
- q(0),
- ],
- q(780) => [
- q(0226),
- q(0),
- ],
- q(784) => [
- q(0234),
- q(0),
- ],
- q(788) => [
- q(0227),
- q(0),
- ],
- q(792) => [
- q(0228),
- q(0),
- ],
- q(795) => [
- q(0229),
+ q(703) => [
+ q(0202),
q(0),
],
- q(796) => [
- q(0230),
+ q(705) => [
+ q(0203),
q(0),
],
- q(798) => [
- q(0231),
+ q(706) => [
+ q(0205),
q(0),
],
- q(800) => [
- q(0232),
+ q(710) => [
+ q(0206),
q(0),
],
- q(804) => [
- q(0233),
+ q(724) => [
+ q(0209),
q(0),
],
- q(807) => [
- q(0132),
+ q(728) => [
+ q(0208),
q(0),
],
q(818) => [
q(0066),
q(0),
],
- q(826) => [
- q(0235),
+ q(830) => [
+ q(0250),
q(0),
],
q(831) => [
q(0108),
q(0),
],
- q(834) => [
- q(0220),
- q(0),
- ],
- q(840) => [
- q(0237),
- q(0),
- ],
- q(850) => [
- q(0244),
- q(0),
- ],
q(854) => [
q(0036),
q(0),
],
- q(858) => [
- q(0238),
- q(0),
- ],
- q(860) => [
- q(0239),
- q(0),
- ],
- q(862) => [
- q(0241),
- q(0),
- ],
- q(876) => [
- q(0245),
- q(0),
- ],
q(882) => [
q(0192),
q(0),
],
- q(887) => [
- q(0247),
- q(0),
- ],
- q(894) => [
- q(0248),
- q(0),
- ],
},
};
q(0248) => q(zm),
q(0249) => q(zw),
},
+ q(genc-alpha-2) => {
+ q(0001) => q(AF),
+ q(0003) => q(AL),
+ q(0004) => q(DZ),
+ q(0005) => q(AS),
+ q(0006) => q(AD),
+ q(0007) => q(AO),
+ q(0008) => q(AI),
+ q(0009) => q(AQ),
+ q(0010) => q(AG),
+ q(0011) => q(AR),
+ q(0012) => q(AM),
+ q(0013) => q(AW),
+ q(0014) => q(AU),
+ q(0015) => q(AT),
+ q(0016) => q(AZ),
+ q(0017) => q(BS),
+ q(0018) => q(BH),
+ q(0019) => q(BD),
+ q(0020) => q(BB),
+ q(0021) => q(BY),
+ q(0022) => q(BE),
+ q(0023) => q(BZ),
+ q(0024) => q(BJ),
+ q(0025) => q(BM),
+ q(0026) => q(BT),
+ q(0027) => q(BO),
+ q(0028) => q(BQ),
+ q(0029) => q(BA),
+ q(0030) => q(BW),
+ q(0031) => q(BV),
+ q(0032) => q(BR),
+ q(0033) => q(IO),
+ q(0034) => q(BN),
+ q(0035) => q(BG),
+ q(0036) => q(BF),
+ q(0037) => q(BI),
+ q(0038) => q(CV),
+ q(0039) => q(KH),
+ q(0040) => q(CM),
+ q(0041) => q(CA),
+ q(0042) => q(KY),
+ q(0043) => q(CF),
+ q(0044) => q(TD),
+ q(0045) => q(CL),
+ q(0046) => q(CN),
+ q(0047) => q(CX),
+ q(0048) => q(CC),
+ q(0049) => q(CO),
+ q(0050) => q(KM),
+ q(0051) => q(CD),
+ q(0052) => q(CG),
+ q(0053) => q(CK),
+ q(0054) => q(CR),
+ q(0055) => q(CI),
+ q(0056) => q(HR),
+ q(0057) => q(CU),
+ q(0058) => q(CW),
+ q(0059) => q(CY),
+ q(0060) => q(CZ),
+ q(0061) => q(DK),
+ q(0062) => q(DJ),
+ q(0063) => q(DM),
+ q(0064) => q(DO),
+ q(0065) => q(EC),
+ q(0066) => q(EG),
+ q(0067) => q(SV),
+ q(0068) => q(GQ),
+ q(0069) => q(ER),
+ q(0070) => q(EE),
+ q(0071) => q(ET),
+ q(0072) => q(FK),
+ q(0073) => q(FO),
+ q(0074) => q(FJ),
+ q(0075) => q(FI),
+ q(0076) => q(FR),
+ q(0077) => q(GF),
+ q(0078) => q(PF),
+ q(0079) => q(TF),
+ q(0080) => q(GA),
+ q(0081) => q(GM),
+ q(0082) => q(GE),
+ q(0083) => q(DE),
+ q(0084) => q(GH),
+ q(0085) => q(GI),
+ q(0086) => q(GR),
+ q(0087) => q(GL),
+ q(0088) => q(GD),
+ q(0089) => q(GP),
+ q(0090) => q(GU),
+ q(0091) => q(GT),
+ q(0092) => q(GG),
+ q(0093) => q(GN),
+ q(0094) => q(GW),
+ q(0095) => q(GY),
+ q(0096) => q(HT),
+ q(0097) => q(HM),
+ q(0098) => q(VA),
+ q(0099) => q(HN),
+ q(0100) => q(HK),
+ q(0101) => q(HU),
+ q(0102) => q(IS),
+ q(0103) => q(IN),
+ q(0104) => q(ID),
+ q(0105) => q(IR),
+ q(0106) => q(IQ),
+ q(0107) => q(IE),
+ q(0108) => q(IM),
+ q(0109) => q(IL),
+ q(0110) => q(IT),
+ q(0111) => q(JM),
+ q(0112) => q(JP),
+ q(0113) => q(JE),
+ q(0114) => q(JO),
+ q(0115) => q(KZ),
+ q(0116) => q(KE),
+ q(0117) => q(KI),
+ q(0118) => q(KP),
+ q(0119) => q(KR),
+ q(0120) => q(KW),
+ q(0121) => q(KG),
+ q(0122) => q(LA),
+ q(0123) => q(LV),
+ q(0124) => q(LB),
+ q(0125) => q(LS),
+ q(0126) => q(LR),
+ q(0127) => q(LY),
+ q(0128) => q(LI),
+ q(0129) => q(LT),
+ q(0130) => q(LU),
+ q(0131) => q(MO),
+ q(0132) => q(MK),
+ q(0133) => q(MG),
+ q(0134) => q(MW),
+ q(0135) => q(MY),
+ q(0136) => q(MV),
+ q(0137) => q(ML),
+ q(0138) => q(MT),
+ q(0139) => q(MH),
+ q(0140) => q(MQ),
+ q(0141) => q(MR),
+ q(0142) => q(MU),
+ q(0143) => q(YT),
+ q(0144) => q(MX),
+ q(0145) => q(FM),
+ q(0146) => q(MD),
+ q(0147) => q(MC),
+ q(0148) => q(MN),
+ q(0149) => q(ME),
+ q(0150) => q(MS),
+ q(0151) => q(MA),
+ q(0152) => q(MZ),
+ q(0153) => q(MM),
+ q(0154) => q(NA),
+ q(0155) => q(NR),
+ q(0156) => q(NP),
+ q(0157) => q(NL),
+ q(0158) => q(NC),
+ q(0159) => q(NZ),
+ q(0160) => q(NI),
+ q(0161) => q(NE),
+ q(0162) => q(NG),
+ q(0163) => q(NU),
+ q(0164) => q(NF),
+ q(0165) => q(MP),
+ q(0166) => q(NO),
+ q(0167) => q(OM),
+ q(0168) => q(PK),
+ q(0169) => q(PW),
+ q(0171) => q(PA),
+ q(0172) => q(PG),
+ q(0173) => q(PY),
+ q(0174) => q(PE),
+ q(0175) => q(PH),
+ q(0176) => q(PN),
+ q(0177) => q(PL),
+ q(0178) => q(PT),
+ q(0179) => q(PR),
+ q(0180) => q(QA),
+ q(0181) => q(RE),
+ q(0182) => q(RO),
+ q(0183) => q(RU),
+ q(0184) => q(RW),
+ q(0185) => q(BL),
+ q(0186) => q(SH),
+ q(0187) => q(KN),
+ q(0188) => q(LC),
+ q(0189) => q(MF),
+ q(0190) => q(PM),
+ q(0191) => q(VC),
+ q(0192) => q(WS),
+ q(0193) => q(SM),
+ q(0194) => q(ST),
+ q(0195) => q(SA),
+ q(0196) => q(SN),
+ q(0197) => q(RS),
+ q(0198) => q(SC),
+ q(0199) => q(SL),
+ q(0200) => q(SG),
+ q(0201) => q(SX),
+ q(0202) => q(SK),
+ q(0203) => q(SI),
+ q(0204) => q(SB),
+ q(0205) => q(SO),
+ q(0206) => q(ZA),
+ q(0207) => q(GS),
+ q(0208) => q(SS),
+ q(0209) => q(ES),
+ q(0210) => q(LK),
+ q(0211) => q(SD),
+ q(0212) => q(SR),
+ q(0214) => q(SZ),
+ q(0215) => q(SE),
+ q(0216) => q(CH),
+ q(0217) => q(SY),
+ q(0218) => q(TW),
+ q(0219) => q(TJ),
+ q(0220) => q(TZ),
+ q(0221) => q(TH),
+ q(0222) => q(TL),
+ q(0223) => q(TG),
+ q(0224) => q(TK),
+ q(0225) => q(TO),
+ q(0226) => q(TT),
+ q(0227) => q(TN),
+ q(0228) => q(TR),
+ q(0229) => q(TM),
+ q(0230) => q(TC),
+ q(0231) => q(TV),
+ q(0232) => q(UG),
+ q(0233) => q(UA),
+ q(0234) => q(AE),
+ q(0235) => q(GB),
+ q(0237) => q(US),
+ q(0238) => q(UY),
+ q(0239) => q(UZ),
+ q(0240) => q(VU),
+ q(0241) => q(VE),
+ q(0242) => q(VN),
+ q(0243) => q(VG),
+ q(0244) => q(VI),
+ q(0245) => q(WF),
+ q(0246) => q(EH),
+ q(0247) => q(YE),
+ q(0248) => q(ZM),
+ q(0249) => q(ZW),
+ q(0252) => q(QZ),
+ q(0253) => q(XA),
+ q(0254) => q(XB),
+ q(0255) => q(QS),
+ q(0256) => q(CP),
+ q(0257) => q(XC),
+ q(0258) => q(XD),
+ q(0259) => q(DG),
+ q(0260) => q([None Assigned]),
+ q(0261) => q(A3),
+ q(0262) => q(XE),
+ q(0263) => q(XG),
+ q(0264) => q(QX),
+ q(0265) => q(A2),
+ q(0266) => q(XH),
+ q(0267) => q(XJ),
+ q(0268) => q(XQ),
+ q(0269) => q(XU),
+ q(0270) => q(QU),
+ q(0271) => q(XM),
+ q(0272) => q(XK),
+ q(0273) => q(QM),
+ q(0274) => q(XV),
+ q(0275) => q(XL),
+ q(0276) => q(XP),
+ q(0277) => q(XS),
+ q(0278) => q(XR),
+ q(0279) => q(XT),
+ q(0280) => q(A1),
+ q(0281) => q(QW),
+ q(0282) => q(XW),
+ },
+ q(genc-alpha-3) => {
+ q(0001) => q(AFG),
+ q(0003) => q(ALB),
+ q(0004) => q(DZA),
+ q(0005) => q(ASM),
+ q(0006) => q(AND),
+ q(0007) => q(AGO),
+ q(0008) => q(AIA),
+ q(0009) => q(ATA),
+ q(0010) => q(ATG),
+ q(0011) => q(ARG),
+ q(0012) => q(ARM),
+ q(0013) => q(ABW),
+ q(0014) => q(AUS),
+ q(0015) => q(AUT),
+ q(0016) => q(AZE),
+ q(0017) => q(BHS),
+ q(0018) => q(BHR),
+ q(0019) => q(BGD),
+ q(0020) => q(BRB),
+ q(0021) => q(BLR),
+ q(0022) => q(BEL),
+ q(0023) => q(BLZ),
+ q(0024) => q(BEN),
+ q(0025) => q(BMU),
+ q(0026) => q(BTN),
+ q(0027) => q(BOL),
+ q(0028) => q(BES),
+ q(0029) => q(BIH),
+ q(0030) => q(BWA),
+ q(0031) => q(BVT),
+ q(0032) => q(BRA),
+ q(0033) => q(IOT),
+ q(0034) => q(BRN),
+ q(0035) => q(BGR),
+ q(0036) => q(BFA),
+ q(0037) => q(BDI),
+ q(0038) => q(CPV),
+ q(0039) => q(KHM),
+ q(0040) => q(CMR),
+ q(0041) => q(CAN),
+ q(0042) => q(CYM),
+ q(0043) => q(CAF),
+ q(0044) => q(TCD),
+ q(0045) => q(CHL),
+ q(0046) => q(CHN),
+ q(0047) => q(CXR),
+ q(0048) => q(CCK),
+ q(0049) => q(COL),
+ q(0050) => q(COM),
+ q(0051) => q(COD),
+ q(0052) => q(COG),
+ q(0053) => q(COK),
+ q(0054) => q(CRI),
+ q(0055) => q(CIV),
+ q(0056) => q(HRV),
+ q(0057) => q(CUB),
+ q(0058) => q(CUW),
+ q(0059) => q(CYP),
+ q(0060) => q(CZE),
+ q(0061) => q(DNK),
+ q(0062) => q(DJI),
+ q(0063) => q(DMA),
+ q(0064) => q(DOM),
+ q(0065) => q(ECU),
+ q(0066) => q(EGY),
+ q(0067) => q(SLV),
+ q(0068) => q(GNQ),
+ q(0069) => q(ERI),
+ q(0070) => q(EST),
+ q(0071) => q(ETH),
+ q(0072) => q(FLK),
+ q(0073) => q(FRO),
+ q(0074) => q(FJI),
+ q(0075) => q(FIN),
+ q(0076) => q(FRA),
+ q(0077) => q(GUF),
+ q(0078) => q(PYF),
+ q(0079) => q(ATF),
+ q(0080) => q(GAB),
+ q(0081) => q(GMB),
+ q(0082) => q(GEO),
+ q(0083) => q(DEU),
+ q(0084) => q(GHA),
+ q(0085) => q(GIB),
+ q(0086) => q(GRC),
+ q(0087) => q(GRL),
+ q(0088) => q(GRD),
+ q(0089) => q(GLP),
+ q(0090) => q(GUM),
+ q(0091) => q(GTM),
+ q(0092) => q(GGY),
+ q(0093) => q(GIN),
+ q(0094) => q(GNB),
+ q(0095) => q(GUY),
+ q(0096) => q(HTI),
+ q(0097) => q(HMD),
+ q(0098) => q(VAT),
+ q(0099) => q(HND),
+ q(0100) => q(HKG),
+ q(0101) => q(HUN),
+ q(0102) => q(ISL),
+ q(0103) => q(IND),
+ q(0104) => q(IDN),
+ q(0105) => q(IRN),
+ q(0106) => q(IRQ),
+ q(0107) => q(IRL),
+ q(0108) => q(IMN),
+ q(0109) => q(ISR),
+ q(0110) => q(ITA),
+ q(0111) => q(JAM),
+ q(0112) => q(JPN),
+ q(0113) => q(JEY),
+ q(0114) => q(JOR),
+ q(0115) => q(KAZ),
+ q(0116) => q(KEN),
+ q(0117) => q(KIR),
+ q(0118) => q(PRK),
+ q(0119) => q(KOR),
+ q(0120) => q(KWT),
+ q(0121) => q(KGZ),
+ q(0122) => q(LAO),
+ q(0123) => q(LVA),
+ q(0124) => q(LBN),
+ q(0125) => q(LSO),
+ q(0126) => q(LBR),
+ q(0127) => q(LBY),
+ q(0128) => q(LIE),
+ q(0129) => q(LTU),
+ q(0130) => q(LUX),
+ q(0131) => q(MAC),
+ q(0132) => q(MKD),
+ q(0133) => q(MDG),
+ q(0134) => q(MWI),
+ q(0135) => q(MYS),
+ q(0136) => q(MDV),
+ q(0137) => q(MLI),
+ q(0138) => q(MLT),
+ q(0139) => q(MHL),
+ q(0140) => q(MTQ),
+ q(0141) => q(MRT),
+ q(0142) => q(MUS),
+ q(0143) => q(MYT),
+ q(0144) => q(MEX),
+ q(0145) => q(FSM),
+ q(0146) => q(MDA),
+ q(0147) => q(MCO),
+ q(0148) => q(MNG),
+ q(0149) => q(MNE),
+ q(0150) => q(MSR),
+ q(0151) => q(MAR),
+ q(0152) => q(MOZ),
+ q(0153) => q(MMR),
+ q(0154) => q(NAM),
+ q(0155) => q(NRU),
+ q(0156) => q(NPL),
+ q(0157) => q(NLD),
+ q(0158) => q(NCL),
+ q(0159) => q(NZL),
+ q(0160) => q(NIC),
+ q(0161) => q(NER),
+ q(0162) => q(NGA),
+ q(0163) => q(NIU),
+ q(0164) => q(NFK),
+ q(0165) => q(MNP),
+ q(0166) => q(NOR),
+ q(0167) => q(OMN),
+ q(0168) => q(PAK),
+ q(0169) => q(PLW),
+ q(0171) => q(PAN),
+ q(0172) => q(PNG),
+ q(0173) => q(PRY),
+ q(0174) => q(PER),
+ q(0175) => q(PHL),
+ q(0176) => q(PCN),
+ q(0177) => q(POL),
+ q(0178) => q(PRT),
+ q(0179) => q(PRI),
+ q(0180) => q(QAT),
+ q(0181) => q(REU),
+ q(0182) => q(ROU),
+ q(0183) => q(RUS),
+ q(0184) => q(RWA),
+ q(0185) => q(BLM),
+ q(0186) => q(SHN),
+ q(0187) => q(KNA),
+ q(0188) => q(LCA),
+ q(0189) => q(MAF),
+ q(0190) => q(SPM),
+ q(0191) => q(VCT),
+ q(0192) => q(WSM),
+ q(0193) => q(SMR),
+ q(0194) => q(STP),
+ q(0195) => q(SAU),
+ q(0196) => q(SEN),
+ q(0197) => q(SRB),
+ q(0198) => q(SYC),
+ q(0199) => q(SLE),
+ q(0200) => q(SGP),
+ q(0201) => q(SXM),
+ q(0202) => q(SVK),
+ q(0203) => q(SVN),
+ q(0204) => q(SLB),
+ q(0205) => q(SOM),
+ q(0206) => q(ZAF),
+ q(0207) => q(SGS),
+ q(0208) => q(SSD),
+ q(0209) => q(ESP),
+ q(0210) => q(LKA),
+ q(0211) => q(SDN),
+ q(0212) => q(SUR),
+ q(0214) => q(SWZ),
+ q(0215) => q(SWE),
+ q(0216) => q(CHE),
+ q(0217) => q(SYR),
+ q(0218) => q(TWN),
+ q(0219) => q(TJK),
+ q(0220) => q(TZA),
+ q(0221) => q(THA),
+ q(0222) => q(TLS),
+ q(0223) => q(TGO),
+ q(0224) => q(TKL),
+ q(0225) => q(TON),
+ q(0226) => q(TTO),
+ q(0227) => q(TUN),
+ q(0228) => q(TUR),
+ q(0229) => q(TKM),
+ q(0230) => q(TCA),
+ q(0231) => q(TUV),
+ q(0232) => q(UGA),
+ q(0233) => q(UKR),
+ q(0234) => q(ARE),
+ q(0235) => q(GBR),
+ q(0237) => q(USA),
+ q(0238) => q(URY),
+ q(0239) => q(UZB),
+ q(0240) => q(VUT),
+ q(0241) => q(VEN),
+ q(0242) => q(VNM),
+ q(0243) => q(VGB),
+ q(0244) => q(VIR),
+ q(0245) => q(WLF),
+ q(0246) => q(ESH),
+ q(0247) => q(YEM),
+ q(0248) => q(ZMB),
+ q(0249) => q(ZWE),
+ q(0252) => q(XQZ),
+ q(0253) => q(XAC),
+ q(0254) => q(XBK),
+ q(0255) => q(XBI),
+ q(0256) => q(CPT),
+ q(0257) => q(XCS),
+ q(0258) => q(XXD),
+ q(0259) => q(DGA),
+ q(0260) => q(XKN),
+ q(0261) => q(AX3),
+ q(0262) => q(XEU),
+ q(0263) => q(XGZ),
+ q(0264) => q(XGL),
+ q(0265) => q(AX2),
+ q(0266) => q(XHO),
+ q(0267) => q(XJM),
+ q(0268) => q(XJV),
+ q(0269) => q(XJA),
+ q(0270) => q(XJN),
+ q(0271) => q(XKR),
+ q(0272) => q(XKS),
+ q(0273) => q(XMW),
+ q(0274) => q(XNV),
+ q(0275) => q(XPL),
+ q(0276) => q(XPR),
+ q(0277) => q(XSP),
+ q(0278) => q(XSV),
+ q(0279) => q(XTR),
+ q(0280) => q(AX1),
+ q(0281) => q(XWK),
+ q(0282) => q(XWB),
+ },
+ q(genc-numeric) => {
+ q(0001) => q(004),
+ q(0003) => q(008),
+ q(0004) => q(012),
+ q(0005) => q(016),
+ q(0006) => q(020),
+ q(0007) => q(024),
+ q(0008) => q(660),
+ q(0009) => q(010),
+ q(0010) => q(028),
+ q(0011) => q(032),
+ q(0012) => q(051),
+ q(0013) => q(533),
+ q(0014) => q(036),
+ q(0015) => q(040),
+ q(0016) => q(031),
+ q(0017) => q(044),
+ q(0018) => q(048),
+ q(0019) => q(050),
+ q(0020) => q(052),
+ q(0021) => q(112),
+ q(0022) => q(056),
+ q(0023) => q(084),
+ q(0024) => q(204),
+ q(0025) => q(060),
+ q(0026) => q(064),
+ q(0027) => q(068),
+ q(0028) => q(535),
+ q(0029) => q(070),
+ q(0030) => q(072),
+ q(0031) => q(074),
+ q(0032) => q(076),
+ q(0033) => q(086),
+ q(0034) => q(096),
+ q(0035) => q(100),
+ q(0036) => q(854),
+ q(0037) => q(108),
+ q(0038) => q(132),
+ q(0039) => q(116),
+ q(0040) => q(120),
+ q(0041) => q(124),
+ q(0042) => q(136),
+ q(0043) => q(140),
+ q(0044) => q(148),
+ q(0045) => q(152),
+ q(0046) => q(156),
+ q(0047) => q(162),
+ q(0048) => q(166),
+ q(0049) => q(170),
+ q(0050) => q(174),
+ q(0051) => q(180),
+ q(0052) => q(178),
+ q(0053) => q(184),
+ q(0054) => q(188),
+ q(0055) => q(384),
+ q(0056) => q(191),
+ q(0057) => q(192),
+ q(0058) => q(531),
+ q(0059) => q(196),
+ q(0060) => q(203),
+ q(0061) => q(208),
+ q(0062) => q(262),
+ q(0063) => q(212),
+ q(0064) => q(214),
+ q(0065) => q(218),
+ q(0066) => q(818),
+ q(0067) => q(222),
+ q(0068) => q(226),
+ q(0069) => q(232),
+ q(0070) => q(233),
+ q(0071) => q(231),
+ q(0072) => q(238),
+ q(0073) => q(234),
+ q(0074) => q(242),
+ q(0075) => q(246),
+ q(0076) => q(250),
+ q(0077) => q(254),
+ q(0078) => q(258),
+ q(0079) => q(260),
+ q(0080) => q(266),
+ q(0081) => q(270),
+ q(0082) => q(268),
+ q(0083) => q(276),
+ q(0084) => q(288),
+ q(0085) => q(292),
+ q(0086) => q(300),
+ q(0087) => q(304),
+ q(0088) => q(308),
+ q(0089) => q(312),
+ q(0090) => q(316),
+ q(0091) => q(320),
+ q(0092) => q(831),
+ q(0093) => q(324),
+ q(0094) => q(624),
+ q(0095) => q(328),
+ q(0096) => q(332),
+ q(0097) => q(334),
+ q(0098) => q(336),
+ q(0099) => q(340),
+ q(0100) => q(344),
+ q(0101) => q(348),
+ q(0102) => q(352),
+ q(0103) => q(356),
+ q(0104) => q(360),
+ q(0105) => q(364),
+ q(0106) => q(368),
+ q(0107) => q(372),
+ q(0108) => q(833),
+ q(0109) => q(376),
+ q(0110) => q(380),
+ q(0111) => q(388),
+ q(0112) => q(392),
+ q(0113) => q(832),
+ q(0114) => q(400),
+ q(0115) => q(398),
+ q(0116) => q(404),
+ q(0117) => q(296),
+ q(0118) => q(408),
+ q(0119) => q(410),
+ q(0120) => q(414),
+ q(0121) => q(417),
+ q(0122) => q(418),
+ q(0123) => q(428),
+ q(0124) => q(422),
+ q(0125) => q(426),
+ q(0126) => q(430),
+ q(0127) => q(434),
+ q(0128) => q(438),
+ q(0129) => q(440),
+ q(0130) => q(442),
+ q(0131) => q(446),
+ q(0132) => q(807),
+ q(0133) => q(450),
+ q(0134) => q(454),
+ q(0135) => q(458),
+ q(0136) => q(462),
+ q(0137) => q(466),
+ q(0138) => q(470),
+ q(0139) => q(584),
+ q(0140) => q(474),
+ q(0141) => q(478),
+ q(0142) => q(480),
+ q(0143) => q(175),
+ q(0144) => q(484),
+ q(0145) => q(583),
+ q(0146) => q(498),
+ q(0147) => q(492),
+ q(0148) => q(496),
+ q(0149) => q(499),
+ q(0150) => q(500),
+ q(0151) => q(504),
+ q(0152) => q(508),
+ q(0153) => q(104),
+ q(0154) => q(516),
+ q(0155) => q(520),
+ q(0156) => q(524),
+ q(0157) => q(528),
+ q(0158) => q(540),
+ q(0159) => q(554),
+ q(0160) => q(558),
+ q(0161) => q(562),
+ q(0162) => q(566),
+ q(0163) => q(570),
+ q(0164) => q(574),
+ q(0165) => q(580),
+ q(0166) => q(578),
+ q(0167) => q(512),
+ q(0168) => q(586),
+ q(0169) => q(585),
+ q(0171) => q(591),
+ q(0172) => q(598),
+ q(0173) => q(600),
+ q(0174) => q(604),
+ q(0175) => q(608),
+ q(0176) => q(612),
+ q(0177) => q(616),
+ q(0178) => q(620),
+ q(0179) => q(630),
+ q(0180) => q(634),
+ q(0181) => q(638),
+ q(0182) => q(642),
+ q(0183) => q(643),
+ q(0184) => q(646),
+ q(0185) => q(652),
+ q(0186) => q(654),
+ q(0187) => q(659),
+ q(0188) => q(662),
+ q(0189) => q(663),
+ q(0190) => q(666),
+ q(0191) => q(670),
+ q(0192) => q(882),
+ q(0193) => q(674),
+ q(0194) => q(678),
+ q(0195) => q(682),
+ q(0196) => q(686),
+ q(0197) => q(688),
+ q(0198) => q(690),
+ q(0199) => q(694),
+ q(0200) => q(702),
+ q(0201) => q(534),
+ q(0202) => q(703),
+ q(0203) => q(705),
+ q(0204) => q(090),
+ q(0205) => q(706),
+ q(0206) => q(710),
+ q(0207) => q(239),
+ q(0208) => q(728),
+ q(0209) => q(724),
+ q(0210) => q(144),
+ q(0211) => q(729),
+ q(0212) => q(740),
+ q(0214) => q(748),
+ q(0215) => q(752),
+ q(0216) => q(756),
+ q(0217) => q(760),
+ q(0218) => q(158),
+ q(0219) => q(762),
+ q(0220) => q(834),
+ q(0221) => q(764),
+ q(0222) => q(626),
+ q(0223) => q(768),
+ q(0224) => q(772),
+ q(0225) => q(776),
+ q(0226) => q(780),
+ q(0227) => q(788),
+ q(0228) => q(792),
+ q(0229) => q(795),
+ q(0230) => q(796),
+ q(0231) => q(798),
+ q(0232) => q(800),
+ q(0233) => q(804),
+ q(0234) => q(784),
+ q(0235) => q(826),
+ q(0237) => q(840),
+ q(0238) => q(858),
+ q(0239) => q(860),
+ q(0240) => q(548),
+ q(0241) => q(862),
+ q(0242) => q(704),
+ q(0243) => q(092),
+ q(0244) => q(850),
+ q(0245) => q(876),
+ q(0246) => q(732),
+ q(0247) => q(887),
+ q(0248) => q(894),
+ q(0249) => q(716),
+ q(0252) => q(900),
+ q(0253) => q(902),
+ q(0254) => q(903),
+ q(0255) => q(904),
+ q(0256) => q(905),
+ q(0257) => q(906),
+ q(0258) => q(907),
+ q(0259) => q(908),
+ q(0260) => q(913),
+ q(0261) => q(914),
+ q(0262) => q(915),
+ q(0263) => q(916),
+ q(0264) => q(917),
+ q(0265) => q(918),
+ q(0266) => q(919),
+ q(0267) => q(920),
+ q(0268) => q(921),
+ q(0269) => q(922),
+ q(0270) => q(923),
+ q(0271) => q(924),
+ q(0272) => q(901),
+ q(0273) => q(925),
+ q(0274) => q(926),
+ q(0275) => q(927),
+ q(0276) => q(928),
+ q(0277) => q(929),
+ q(0278) => q(930),
+ q(0279) => q(931),
+ q(0280) => q(932),
+ q(0281) => q(933),
+ q(0282) => q(934),
+ },
q(numeric) => {
q(0001) => q(004),
q(0002) => q(248),
q(0248) => q(894),
q(0249) => q(716),
},
+ q(un-alpha-3) => {
+ q(0001) => q(AFG),
+ q(0002) => q(ALA),
+ q(0003) => q(ALB),
+ q(0004) => q(DZA),
+ q(0005) => q(ASM),
+ q(0006) => q(AND),
+ q(0007) => q(AGO),
+ q(0008) => q(AIA),
+ q(0010) => q(ATG),
+ q(0011) => q(ARG),
+ q(0012) => q(ARM),
+ q(0013) => q(ABW),
+ q(0014) => q(AUS),
+ q(0015) => q(AUT),
+ q(0016) => q(AZE),
+ q(0017) => q(BHS),
+ q(0018) => q(BHR),
+ q(0019) => q(BGD),
+ q(0020) => q(BRB),
+ q(0021) => q(BLR),
+ q(0022) => q(BEL),
+ q(0023) => q(BLZ),
+ q(0024) => q(BEN),
+ q(0025) => q(BMU),
+ q(0026) => q(BTN),
+ q(0027) => q(BOL),
+ q(0028) => q(BES),
+ q(0029) => q(BIH),
+ q(0030) => q(BWA),
+ q(0032) => q(BRA),
+ q(0034) => q(BRN),
+ q(0035) => q(BGR),
+ q(0036) => q(BFA),
+ q(0037) => q(BDI),
+ q(0038) => q(CPV),
+ q(0039) => q(KHM),
+ q(0040) => q(CMR),
+ q(0041) => q(CAN),
+ q(0042) => q(CYM),
+ q(0043) => q(CAF),
+ q(0044) => q(TCD),
+ q(0045) => q(CHL),
+ q(0046) => q(CHN),
+ q(0049) => q(COL),
+ q(0050) => q(COM),
+ q(0051) => q(COD),
+ q(0052) => q(COG),
+ q(0053) => q(COK),
+ q(0054) => q(CRI),
+ q(0055) => q(CIV),
+ q(0056) => q(HRV),
+ q(0057) => q(CUB),
+ q(0058) => q(CUW),
+ q(0059) => q(CYP),
+ q(0060) => q(CZE),
+ q(0061) => q(DNK),
+ q(0062) => q(DJI),
+ q(0063) => q(DMA),
+ q(0064) => q(DOM),
+ q(0065) => q(ECU),
+ q(0066) => q(EGY),
+ q(0067) => q(SLV),
+ q(0068) => q(GNQ),
+ q(0069) => q(ERI),
+ q(0070) => q(EST),
+ q(0071) => q(ETH),
+ q(0072) => q(FLK),
+ q(0073) => q(FRO),
+ q(0074) => q(FJI),
+ q(0075) => q(FIN),
+ q(0076) => q(FRA),
+ q(0077) => q(GUF),
+ q(0078) => q(PYF),
+ q(0080) => q(GAB),
+ q(0081) => q(GMB),
+ q(0082) => q(GEO),
+ q(0083) => q(DEU),
+ q(0084) => q(GHA),
+ q(0085) => q(GIB),
+ q(0086) => q(GRC),
+ q(0087) => q(GRL),
+ q(0088) => q(GRD),
+ q(0089) => q(GLP),
+ q(0090) => q(GUM),
+ q(0091) => q(GTM),
+ q(0092) => q(GGY),
+ q(0093) => q(GIN),
+ q(0094) => q(GNB),
+ q(0095) => q(GUY),
+ q(0096) => q(HTI),
+ q(0098) => q(VAT),
+ q(0099) => q(HND),
+ q(0100) => q(HKG),
+ q(0101) => q(HUN),
+ q(0102) => q(ISL),
+ q(0103) => q(IND),
+ q(0104) => q(IDN),
+ q(0105) => q(IRN),
+ q(0106) => q(IRQ),
+ q(0107) => q(IRL),
+ q(0108) => q(IMN),
+ q(0109) => q(ISR),
+ q(0110) => q(ITA),
+ q(0111) => q(JAM),
+ q(0112) => q(JPN),
+ q(0113) => q(JEY),
+ q(0114) => q(JOR),
+ q(0115) => q(KAZ),
+ q(0116) => q(KEN),
+ q(0117) => q(KIR),
+ q(0118) => q(PRK),
+ q(0119) => q(KOR),
+ q(0120) => q(KWT),
+ q(0121) => q(KGZ),
+ q(0122) => q(LAO),
+ q(0123) => q(LVA),
+ q(0124) => q(LBN),
+ q(0125) => q(LSO),
+ q(0126) => q(LBR),
+ q(0127) => q(LBY),
+ q(0128) => q(LIE),
+ q(0129) => q(LTU),
+ q(0130) => q(LUX),
+ q(0131) => q(MAC),
+ q(0133) => q(MDG),
+ q(0134) => q(MWI),
+ q(0135) => q(MYS),
+ q(0136) => q(MDV),
+ q(0137) => q(MLI),
+ q(0138) => q(MLT),
+ q(0139) => q(MHL),
+ q(0140) => q(MTQ),
+ q(0141) => q(MRT),
+ q(0142) => q(MUS),
+ q(0143) => q(MYT),
+ q(0144) => q(MEX),
+ q(0145) => q(FSM),
+ q(0146) => q(MDA),
+ q(0147) => q(MCO),
+ q(0148) => q(MNG),
+ q(0149) => q(MNE),
+ q(0150) => q(MSR),
+ q(0151) => q(MAR),
+ q(0152) => q(MOZ),
+ q(0153) => q(MMR),
+ q(0154) => q(NAM),
+ q(0155) => q(NRU),
+ q(0156) => q(NPL),
+ q(0157) => q(NLD),
+ q(0158) => q(NCL),
+ q(0159) => q(NZL),
+ q(0160) => q(NIC),
+ q(0161) => q(NER),
+ q(0162) => q(NGA),
+ q(0163) => q(NIU),
+ q(0164) => q(NFK),
+ q(0165) => q(MNP),
+ q(0166) => q(NOR),
+ q(0167) => q(OMN),
+ q(0168) => q(PAK),
+ q(0169) => q(PLW),
+ q(0170) => q(PSE),
+ q(0171) => q(PAN),
+ q(0172) => q(PNG),
+ q(0173) => q(PRY),
+ q(0174) => q(PER),
+ q(0175) => q(PHL),
+ q(0176) => q(PCN),
+ q(0177) => q(POL),
+ q(0178) => q(PRT),
+ q(0179) => q(PRI),
+ q(0180) => q(QAT),
+ q(0181) => q(REU),
+ q(0182) => q(ROU),
+ q(0183) => q(RUS),
+ q(0184) => q(RWA),
+ q(0185) => q(BLM),
+ q(0186) => q(SHN),
+ q(0187) => q(KNA),
+ q(0188) => q(LCA),
+ q(0189) => q(MAF),
+ q(0190) => q(SPM),
+ q(0191) => q(VCT),
+ q(0192) => q(WSM),
+ q(0193) => q(SMR),
+ q(0194) => q(STP),
+ q(0195) => q(SAU),
+ q(0196) => q(SEN),
+ q(0197) => q(SRB),
+ q(0198) => q(SYC),
+ q(0199) => q(SLE),
+ q(0200) => q(SGP),
+ q(0201) => q(SXM),
+ q(0202) => q(SVK),
+ q(0203) => q(SVN),
+ q(0204) => q(SLB),
+ q(0205) => q(SOM),
+ q(0206) => q(ZAF),
+ q(0208) => q(SSD),
+ q(0209) => q(ESP),
+ q(0210) => q(LKA),
+ q(0243) => q(VGB),
+ },
+ q(un-numeric) => {
+ q(0001) => q(004),
+ q(0002) => q(248),
+ q(0003) => q(008),
+ q(0004) => q(012),
+ q(0005) => q(016),
+ q(0006) => q(020),
+ q(0007) => q(024),
+ q(0008) => q(660),
+ q(0010) => q(028),
+ q(0011) => q(032),
+ q(0012) => q(051),
+ q(0013) => q(533),
+ q(0014) => q(036),
+ q(0015) => q(040),
+ q(0016) => q(031),
+ q(0017) => q(044),
+ q(0018) => q(048),
+ q(0019) => q(050),
+ q(0020) => q(052),
+ q(0021) => q(112),
+ q(0022) => q(056),
+ q(0023) => q(084),
+ q(0024) => q(204),
+ q(0025) => q(060),
+ q(0026) => q(064),
+ q(0027) => q(068),
+ q(0028) => q(535),
+ q(0029) => q(070),
+ q(0030) => q(072),
+ q(0032) => q(076),
+ q(0034) => q(096),
+ q(0035) => q(100),
+ q(0036) => q(854),
+ q(0037) => q(108),
+ q(0038) => q(132),
+ q(0039) => q(116),
+ q(0040) => q(120),
+ q(0041) => q(124),
+ q(0042) => q(136),
+ q(0043) => q(140),
+ q(0044) => q(148),
+ q(0045) => q(152),
+ q(0046) => q(156),
+ q(0049) => q(170),
+ q(0050) => q(174),
+ q(0051) => q(180),
+ q(0052) => q(178),
+ q(0053) => q(184),
+ q(0054) => q(188),
+ q(0055) => q(384),
+ q(0056) => q(191),
+ q(0057) => q(192),
+ q(0058) => q(531),
+ q(0059) => q(196),
+ q(0060) => q(203),
+ q(0061) => q(208),
+ q(0062) => q(262),
+ q(0063) => q(212),
+ q(0064) => q(214),
+ q(0065) => q(218),
+ q(0066) => q(818),
+ q(0067) => q(222),
+ q(0068) => q(226),
+ q(0069) => q(232),
+ q(0070) => q(233),
+ q(0071) => q(231),
+ q(0072) => q(238),
+ q(0073) => q(234),
+ q(0074) => q(242),
+ q(0075) => q(246),
+ q(0076) => q(250),
+ q(0077) => q(254),
+ q(0078) => q(258),
+ q(0080) => q(266),
+ q(0081) => q(270),
+ q(0082) => q(268),
+ q(0083) => q(276),
+ q(0084) => q(288),
+ q(0085) => q(292),
+ q(0086) => q(300),
+ q(0087) => q(304),
+ q(0088) => q(308),
+ q(0089) => q(312),
+ q(0090) => q(316),
+ q(0091) => q(320),
+ q(0092) => q(831),
+ q(0093) => q(324),
+ q(0094) => q(624),
+ q(0095) => q(328),
+ q(0096) => q(332),
+ q(0098) => q(336),
+ q(0099) => q(340),
+ q(0100) => q(344),
+ q(0101) => q(348),
+ q(0102) => q(352),
+ q(0103) => q(356),
+ q(0104) => q(360),
+ q(0105) => q(364),
+ q(0106) => q(368),
+ q(0107) => q(372),
+ q(0108) => q(833),
+ q(0109) => q(376),
+ q(0110) => q(380),
+ q(0111) => q(388),
+ q(0112) => q(392),
+ q(0113) => q(832),
+ q(0114) => q(400),
+ q(0115) => q(398),
+ q(0116) => q(404),
+ q(0117) => q(296),
+ q(0118) => q(408),
+ q(0119) => q(410),
+ q(0120) => q(414),
+ q(0121) => q(417),
+ q(0122) => q(418),
+ q(0123) => q(428),
+ q(0124) => q(422),
+ q(0125) => q(426),
+ q(0126) => q(430),
+ q(0127) => q(434),
+ q(0128) => q(438),
+ q(0129) => q(440),
+ q(0130) => q(442),
+ q(0131) => q(446),
+ q(0133) => q(450),
+ q(0134) => q(454),
+ q(0135) => q(458),
+ q(0136) => q(462),
+ q(0137) => q(466),
+ q(0138) => q(470),
+ q(0139) => q(584),
+ q(0140) => q(474),
+ q(0141) => q(478),
+ q(0142) => q(480),
+ q(0143) => q(175),
+ q(0144) => q(484),
+ q(0145) => q(583),
+ q(0146) => q(498),
+ q(0147) => q(492),
+ q(0148) => q(496),
+ q(0149) => q(499),
+ q(0150) => q(500),
+ q(0151) => q(504),
+ q(0152) => q(508),
+ q(0153) => q(104),
+ q(0154) => q(516),
+ q(0155) => q(520),
+ q(0156) => q(524),
+ q(0157) => q(528),
+ q(0158) => q(540),
+ q(0159) => q(554),
+ q(0160) => q(558),
+ q(0161) => q(562),
+ q(0162) => q(566),
+ q(0163) => q(570),
+ q(0164) => q(574),
+ q(0165) => q(580),
+ q(0166) => q(578),
+ q(0167) => q(512),
+ q(0168) => q(586),
+ q(0169) => q(585),
+ q(0170) => q(275),
+ q(0171) => q(591),
+ q(0172) => q(598),
+ q(0173) => q(600),
+ q(0174) => q(604),
+ q(0175) => q(608),
+ q(0176) => q(612),
+ q(0177) => q(616),
+ q(0178) => q(620),
+ q(0179) => q(630),
+ q(0180) => q(634),
+ q(0181) => q(638),
+ q(0182) => q(642),
+ q(0183) => q(643),
+ q(0184) => q(646),
+ q(0185) => q(652),
+ q(0186) => q(654),
+ q(0187) => q(659),
+ q(0188) => q(662),
+ q(0189) => q(663),
+ q(0190) => q(666),
+ q(0191) => q(670),
+ q(0192) => q(882),
+ q(0193) => q(674),
+ q(0194) => q(678),
+ q(0195) => q(682),
+ q(0196) => q(686),
+ q(0197) => q(688),
+ q(0198) => q(690),
+ q(0199) => q(694),
+ q(0200) => q(702),
+ q(0201) => q(534),
+ q(0202) => q(703),
+ q(0203) => q(705),
+ q(0204) => q(090),
+ q(0205) => q(706),
+ q(0206) => q(710),
+ q(0208) => q(728),
+ q(0209) => q(724),
+ q(0210) => q(144),
+ q(0243) => q(092),
+ q(0250) => q(830),
+ q(0251) => q(680),
+ },
};
1;
# This file was automatically generated. Any changes to this file will
# be lost the next time 'deprecate_codes' is run.
-# Generated on: Wed Mar 2 09:26:23 EST 2016
+# Generated on: Tue May 31 09:21:49 EDT 2016
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.38';
+$VERSION='3.39';
$Locale::Codes::Retired{'country'}{'alpha-2'}{'code'} = {
q(an) => q(Netherlands Antilles),
q(uk) => q(United Kingdom),
};
+$Locale::Codes::Retired{'country'}{'genc-alpha-2'}{'code'} = {
+};
+
+$Locale::Codes::Retired{'country'}{'genc-alpha-3'}{'code'} = {
+};
+
+$Locale::Codes::Retired{'country'}{'genc-numeric'}{'code'} = {
+};
+
$Locale::Codes::Retired{'country'}{'numeric'}{'code'} = {
q(010) => q(Antarctica),
q(074) => q(Bouvet Island),
q(891) => q(Serbia and Montenegro),
};
+$Locale::Codes::Retired{'country'}{'un-alpha-3'}{'code'} = {
+};
+
+$Locale::Codes::Retired{'country'}{'un-numeric'}{'code'} = {
+};
+
$Locale::Codes::Retired{'country'}{'alpha-2'}{'name'} = {
q(bolivia) => [ q(bo), q(Bolivia) ],
q(bolivia, plurinational state of) => [ q(bo), q(Bolivia, Plurinational State of) ],
q(yugoslavia ) => [ q(YU), q(Yugoslavia ) ],
};
+$Locale::Codes::Retired{'country'}{'genc-alpha-2'}{'name'} = {
+};
+
+$Locale::Codes::Retired{'country'}{'genc-alpha-3'}{'name'} = {
+};
+
+$Locale::Codes::Retired{'country'}{'genc-numeric'}{'name'} = {
+};
+
$Locale::Codes::Retired{'country'}{'numeric'}{'name'} = {
q(antarctica) => [ q(010), q(Antarctica) ],
q(bolivia) => [ q(068), q(Bolivia) ],
q(zaire) => [ q(180), q(Zaire) ],
};
+$Locale::Codes::Retired{'country'}{'un-alpha-3'}{'name'} = {
+};
+
+$Locale::Codes::Retired{'country'}{'un-numeric'}{'name'} = {
+};
+
1;
our($VERSION,@ISA,@EXPORT,@EXPORT_OK);
-$VERSION='3.38';
+$VERSION='3.39';
@ISA = qw(Exporter);
@EXPORT = qw(code2currency
currency2code
# This file was automatically generated. Any changes to this file will
# be lost the next time 'harvest_data' is run.
-# Generated on: Wed Mar 2 09:20:52 EST 2016
+# Generated on: Tue May 24 14:46:57 EDT 2016
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.38';
+$VERSION='3.39';
$Locale::Codes::Data{'currency'}{'id'} = '0177';
# This file was automatically generated. Any changes to this file will
# be lost the next time 'deprecate_codes' is run.
-# Generated on: Wed Mar 2 09:26:23 EST 2016
+# Generated on: Tue May 31 09:21:49 EDT 2016
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.38';
+$VERSION='3.39';
$Locale::Codes::Retired{'currency'}{'alpha'}{'code'} = {
q(ADP) => q(Andorran Peseta),
our($VERSION,@ISA,@EXPORT,@EXPORT_OK);
-$VERSION='3.38';
+$VERSION='3.39';
@ISA = qw(Exporter);
@EXPORT = qw(code2langext
langext2code
# This file was automatically generated. Any changes to this file will
# be lost the next time 'harvest_data' is run.
-# Generated on: Wed Mar 2 09:24:09 EST 2016
+# Generated on: Tue May 24 14:47:11 EDT 2016
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.38';
+$VERSION='3.39';
$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: Wed Mar 2 09:26:23 EST 2016
+# Generated on: Tue May 31 09:21:49 EDT 2016
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.38';
+$VERSION='3.39';
$Locale::Codes::Retired{'langext'}{'alpha'}{'code'} = {
q(yds) => q(Yiddish Sign Language),
our($VERSION,@ISA,@EXPORT,@EXPORT_OK);
-$VERSION='3.38';
+$VERSION='3.39';
@ISA = qw(Exporter);
@EXPORT = qw(code2langfam
langfam2code
# This file was automatically generated. Any changes to this file will
# be lost the next time 'harvest_data' is run.
-# Generated on: Wed Mar 2 09:24:18 EST 2016
+# Generated on: Tue May 24 14:47:19 EDT 2016
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.38';
+$VERSION='3.39';
$Locale::Codes::Data{'langfam'}{'id'} = '0116';
require 5.002;
our($VERSION);
-$VERSION='3.38';
+$VERSION='3.39';
$Locale::Codes::Retired{'langfam'}{'alpha'}{'code'} = {
};
our($VERSION,@ISA,@EXPORT,@EXPORT_OK);
-$VERSION='3.38';
+$VERSION='3.39';
@ISA = qw(Exporter);
@EXPORT = qw(code2langvar
langvar2code
# This file was automatically generated. Any changes to this file will
# be lost the next time 'harvest_data' is run.
-# Generated on: Wed Mar 2 09:24:14 EST 2016
+# Generated on: Tue May 24 14:47:17 EDT 2016
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.38';
+$VERSION='3.39';
$Locale::Codes::Data{'langvar'}{'id'} = '0076';
# This file was automatically generated. Any changes to this file will
# be lost the next time 'deprecate_codes' is run.
-# Generated on: Wed Mar 2 09:26:23 EST 2016
+# Generated on: Tue May 31 09:21:49 EDT 2016
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.38';
+$VERSION='3.39';
$Locale::Codes::Retired{'langvar'}{'alpha'}{'code'} = {
};
our($VERSION,@ISA,@EXPORT,@EXPORT_OK);
-$VERSION='3.38';
+$VERSION='3.39';
@ISA = qw(Exporter);
@EXPORT = qw(code2language
language2code
# This file was automatically generated. Any changes to this file will
# be lost the next time 'harvest_data' is run.
-# Generated on: Wed Mar 2 08:58:07 EST 2016
+# Generated on: Tue May 24 14:46:48 EDT 2016
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.38';
+$VERSION='3.39';
$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: Wed Mar 2 09:26:23 EST 2016
+# Generated on: Tue May 31 09:21:49 EDT 2016
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.38';
+$VERSION='3.39';
$Locale::Codes::Retired{'language'}{'alpha-2'}{'code'} = {
q(in) => q(Indonesian),
our($VERSION,@ISA,@EXPORT,@EXPORT_OK);
-$VERSION='3.38';
+$VERSION='3.39';
@ISA = qw(Exporter);
@EXPORT = qw(code2script
script2code
# This file was automatically generated. Any changes to this file will
# be lost the next time 'harvest_data' is run.
-# Generated on: Wed Mar 2 09:24:01 EST 2016
+# Generated on: Tue May 24 14:47:06 EDT 2016
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.38';
+$VERSION='3.39';
$Locale::Codes::Data{'script'}{'id'} = '0180';
# This file was automatically generated. Any changes to this file will
# be lost the next time 'deprecate_codes' is run.
-# Generated on: Wed Mar 2 09:26:23 EST 2016
+# Generated on: Tue May 31 09:21:49 EDT 2016
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.38';
+$VERSION='3.39';
$Locale::Codes::Retired{'script'}{'alpha'}{'code'} = {
};
use Exporter;
our $VERSION;
-$VERSION='3.38';
+$VERSION='3.39';
our (@ISA,@EXPORT);
domains. The country domains are the two-letter (lowercase) codes from ISO 3166
with a few other additions.
+=item B<un-alpha-3, LOCALE_CODE_UN_ALPHA_3>
+
+=item B<un-numeric, LOCALE_CODE_UN_NUMERIC>
+
+The UN maintains a list of codes that is similar, but not identical, to the
+standard ISO 3166 lists. They maintain a 3-letter code (similar to alpha-3)
+and a numeric code (similar to numeric).
+
+=item B<genc-alpha-2, LOCALE_CODE_GENC_ALPHA_2>
+
+=item B<genc-alpha-3, LOCALE_CODE_GENC_ALPHA_3>
+
+=item B<genc-numeric, LOCALE_CODE_GENC_NUMERIC>
+
+The GENC codes are the US Government codes that replace the FIPS-11 codes.
+They are based on, but not identical to the standard ISO 3166 lists.
+
=back
NOTE: As of version 3.27, the FIPS code set is no longer supported. See the
=item L<http://unstats.un.org/unsd/methods/m49/m49alpha.htm>
-The source of the official ISO 3166-1 three-letter codes and
-three-digit codes.
+The source of the UN codes.
+
+Previously, this table was treated as a source of the ISO 3166 data,
+but I found that the table was incomplete, so I stopped using it.
+Later, it was added back in as it's own list of codes.
+
+=item L<https://nsgreg.nga.mil/genc/discovery>
-For some reason, this table is incomplete! Several countries are
-missing from it, and I cannot find them anywhere on the UN site. I
-no longer use this as a source of data.
+The source of the GENC codes.
=item L<https://www.cia.gov/library/publications/the-world-factbook/appendix/print_appendix-d.html>
use Exporter;
our $VERSION;
-$VERSION='3.38';
+$VERSION='3.39';
our (@ISA,@EXPORT);
use Exporter;
our $VERSION;
-$VERSION='3.38';
+$VERSION='3.39';
our (@ISA,@EXPORT);
use Exporter;
our $VERSION;
-$VERSION='3.38';
+$VERSION='3.39';
our (@ISA,@EXPORT);
-#############################################################################\r
-# Pod/Checker.pm -- check pod documents for syntax errors\r
-#\r
-# Copyright (C) 1994-2000 by Bradford Appleton. All rights reserved.\r
-# This file is part of "PodParser". PodParser is free software;\r
-# you can redistribute it and/or modify it under the same terms\r
-# as Perl itself.\r
-#############################################################################\r
-\r
-package Pod::Checker;\r
-use strict;\r
-\r
-use vars qw($VERSION @ISA @EXPORT %VALID_COMMANDS %VALID_SEQUENCES);\r
-$VERSION = '1.60'; ## Current version of this package\r
-require 5.005; ## requires this Perl version or later\r
-\r
-use Pod::ParseUtils; ## for hyperlinks and lists\r
-\r
-=head1 NAME\r
-\r
-Pod::Checker, podchecker() - check pod documents for syntax errors\r
-\r
-=head1 SYNOPSIS\r
-\r
- use Pod::Checker;\r
-\r
- $num_errors = podchecker($filepath, $outputpath, %options);\r
-\r
- my $checker = new Pod::Checker %options;\r
- $checker->parse_from_file($filepath, \*STDERR);\r
-\r
-=head1 OPTIONS/ARGUMENTS\r
-\r
-C<$filepath> is the input POD to read and C<$outputpath> is\r
-where to write POD syntax error messages. Either argument may be a scalar\r
-indicating a file-path, or else a reference to an open filehandle.\r
-If unspecified, the input-file it defaults to C<\*STDIN>, and\r
-the output-file defaults to C<\*STDERR>.\r
-\r
-=head2 podchecker()\r
-\r
-This function can take a hash of options:\r
-\r
-=over 4\r
-\r
-=item B<-warnings> =E<gt> I<val>\r
-\r
-Turn warnings on/off. I<val> is usually 1 for on, but higher values\r
-trigger additional warnings. See L<"Warnings">.\r
-\r
-=back\r
-\r
-=head1 DESCRIPTION\r
-\r
-B<podchecker> will perform syntax checking of Perl5 POD format documentation.\r
-\r
-Curious/ambitious users are welcome to propose additional features they wish\r
-to see in B<Pod::Checker> and B<podchecker> and verify that the checks are\r
-consistent with L<perlpod>.\r
-\r
-The following checks are currently performed:\r
-\r
-=over 4\r
-\r
-=item *\r
-\r
-Unknown '=xxxx' commands, unknown 'XE<lt>...E<gt>' interior-sequences,\r
-and unterminated interior sequences.\r
-\r
-=item *\r
-\r
-Check for proper balancing of C<=begin> and C<=end>. The contents of such\r
-a block are generally ignored, i.e. no syntax checks are performed.\r
-\r
-=item *\r
-\r
-Check for proper nesting and balancing of C<=over>, C<=item> and C<=back>.\r
-\r
-=item *\r
-\r
-Check for same nested interior-sequences (e.g.\r
-C<LE<lt>...LE<lt>...E<gt>...E<gt>>).\r
-\r
-=item *\r
-\r
-Check for malformed or non-existing entities C<EE<lt>...E<gt>>.\r
-\r
-=item *\r
-\r
-Check for correct syntax of hyperlinks C<LE<lt>...E<gt>>. See L<perlpod>\r
-for details.\r
-\r
-=item *\r
-\r
-Check for unresolved document-internal links. This check may also reveal\r
-misspelled links that seem to be internal links but should be links\r
-to something else.\r
-\r
-=back\r
-\r
-=head1 DIAGNOSTICS\r
-\r
-=head2 Errors\r
-\r
-=over 4\r
-\r
-=item * empty =headn\r
-\r
-A heading (C<=head1> or C<=head2>) without any text? That ain't no\r
-heading!\r
-\r
-=item * =over on line I<N> without closing =back\r
-\r
-The C<=over> command does not have a corresponding C<=back> before the\r
-next heading (C<=head1> or C<=head2>) or the end of the file.\r
-\r
-=item * =item without previous =over\r
-\r
-=item * =back without previous =over\r
-\r
-An C<=item> or C<=back> command has been found outside a\r
-C<=over>/C<=back> block.\r
-\r
-=item * No argument for =begin\r
-\r
-A C<=begin> command was found that is not followed by the formatter\r
-specification.\r
-\r
-=item * =end without =begin\r
-\r
-A standalone C<=end> command was found.\r
-\r
-=item * Nested =begin's\r
-\r
-There were at least two consecutive C<=begin> commands without\r
-the corresponding C<=end>. Only one C<=begin> may be active at\r
-a time.\r
-\r
-=item * =for without formatter specification\r
-\r
-There is no specification of the formatter after the C<=for> command.\r
-\r
-=item * Apparent command =foo not preceded by blank line\r
-\r
-A command which has ended up in the middle of a paragraph or other command,\r
-such as\r
-\r
- =item one\r
- =item two <-- bad\r
-\r
-=item * unresolved internal link I<NAME>\r
-\r
-The given link to I<NAME> does not have a matching node in the current\r
-POD. This also happened when a single word node name is not enclosed in\r
-C<"">.\r
-\r
-=item * Unknown command "I<CMD>"\r
-\r
-An invalid POD command has been found. Valid are C<=head1>, C<=head2>,\r
-C<=head3>, C<=head4>, C<=over>, C<=item>, C<=back>, C<=begin>, C<=end>,\r
-C<=for>, C<=pod>, C<=cut>\r
-\r
-=item * Unknown interior-sequence "I<SEQ>"\r
-\r
-An invalid markup command has been encountered. Valid are:\r
-C<BE<lt>E<gt>>, C<CE<lt>E<gt>>, C<EE<lt>E<gt>>, C<FE<lt>E<gt>>,\r
-C<IE<lt>E<gt>>, C<LE<lt>E<gt>>, C<SE<lt>E<gt>>, C<XE<lt>E<gt>>,\r
-C<ZE<lt>E<gt>>\r
-\r
-=item * nested commands I<CMD>E<lt>...I<CMD>E<lt>...E<gt>...E<gt>\r
-\r
-Two nested identical markup commands have been found. Generally this\r
-does not make sense.\r
-\r
-=item * garbled entity I<STRING>\r
-\r
-The I<STRING> found cannot be interpreted as a character entity.\r
-\r
-=item * Entity number out of range\r
-\r
-An entity specified by number (dec, hex, oct) is out of range (1-255).\r
-\r
-=item * malformed link LE<lt>E<gt>\r
-\r
-The link found cannot be parsed because it does not conform to the\r
-syntax described in L<perlpod>.\r
-\r
-=item * nonempty ZE<lt>E<gt>\r
-\r
-The C<ZE<lt>E<gt>> sequence is supposed to be empty.\r
-\r
-=item * empty XE<lt>E<gt>\r
-\r
-The index entry specified contains nothing but whitespace.\r
-\r
-=item * Spurious text after =pod / =cut\r
-\r
-The commands C<=pod> and C<=cut> do not take any arguments.\r
-\r
-=item * Spurious =cut command\r
-\r
-A C<=cut> command was found without a preceding POD paragraph.\r
-\r
-=item * Spurious =pod command\r
-\r
-A C<=pod> command was found after a preceding POD paragraph.\r
-\r
-=item * Spurious character(s) after =back\r
-\r
-The C<=back> command does not take any arguments.\r
-\r
-=back\r
-\r
-=head2 Warnings\r
-\r
-These may not necessarily cause trouble, but indicate mediocre style.\r
-\r
-=over 4\r
-\r
-=item * multiple occurrence of link target I<name>\r
-\r
-The POD file has some C<=item> and/or C<=head> commands that have\r
-the same text. Potential hyperlinks to such a text cannot be unique then.\r
-This warning is printed only with warning level greater than one.\r
-\r
-=item * line containing nothing but whitespace in paragraph\r
-\r
-There is some whitespace on a seemingly empty line. POD is very sensitive\r
-to such things, so this is flagged. B<vi> users switch on the B<list>\r
-option to avoid this problem.\r
-\r
-=begin _disabled_\r
-\r
-=item * file does not start with =head\r
-\r
-The file starts with a different POD directive than head.\r
-This is most probably something you do not want.\r
-\r
-=end _disabled_\r
-\r
-=item * previous =item has no contents\r
-\r
-There is a list C<=item> right above the flagged line that has no\r
-text contents. You probably want to delete empty items.\r
-\r
-=item * preceding non-item paragraph(s)\r
-\r
-A list introduced by C<=over> starts with a text or verbatim paragraph,\r
-but continues with C<=item>s. Move the non-item paragraph out of the\r
-C<=over>/C<=back> block.\r
-\r
-=item * =item type mismatch (I<one> vs. I<two>)\r
-\r
-A list started with e.g. a bullet-like C<=item> and continued with a\r
-numbered one. This is obviously inconsistent. For most translators the\r
-type of the I<first> C<=item> determines the type of the list.\r
-\r
-=item * I<N> unescaped C<E<lt>E<gt>> in paragraph\r
-\r
-Angle brackets not written as C<E<lt>ltE<gt>> and C<E<lt>gtE<gt>>\r
-can potentially cause errors as they could be misinterpreted as\r
-markup commands. This is only printed when the -warnings level is\r
-greater than 1.\r
-\r
-=item * Unknown entity\r
-\r
-A character entity was found that does not belong to the standard\r
-ISO set or the POD specials C<verbar> and C<sol>.\r
-\r
-=item * No items in =over\r
-\r
-The list opened with C<=over> does not contain any items.\r
-\r
-=item * No argument for =item\r
-\r
-C<=item> without any parameters is deprecated. It should either be followed\r
-by C<*> to indicate an unordered list, by a number (optionally followed\r
-by a dot) to indicate an ordered (numbered) list or simple text for a\r
-definition list.\r
-\r
-=item * empty section in previous paragraph\r
-\r
-The previous section (introduced by a C<=head> command) does not contain\r
-any text. This usually indicates that something is missing. Note: A\r
-C<=head1> followed immediately by C<=head2> does not trigger this warning.\r
-\r
-=item * Verbatim paragraph in NAME section\r
-\r
-The NAME section (C<=head1 NAME>) should consist of a single paragraph\r
-with the script/module name, followed by a dash `-' and a very short\r
-description of what the thing is good for.\r
-\r
-=item * =headI<n> without preceding higher level\r
-\r
-For example if there is a C<=head2> in the POD file prior to a\r
-C<=head1>.\r
-\r
-=back\r
-\r
-=head2 Hyperlinks\r
-\r
-There are some warnings with respect to malformed hyperlinks:\r
-\r
-=over 4\r
-\r
-=item * ignoring leading/trailing whitespace in link\r
-\r
-There is whitespace at the beginning or the end of the contents of\r
-LE<lt>...E<gt>.\r
-\r
-=item * (section) in '$page' deprecated\r
-\r
-There is a section detected in the page name of LE<lt>...E<gt>, e.g.\r
-C<LE<lt>passwd(2)E<gt>>. POD hyperlinks may point to POD documents only.\r
-Please write C<CE<lt>passwd(2)E<gt>> instead. Some formatters are able\r
-to expand this to appropriate code. For links to (builtin) functions,\r
-please say C<LE<lt>perlfunc/mkdirE<gt>>, without ().\r
-\r
-=item * alternative text/node '%s' contains non-escaped | or /\r
-\r
-The characters C<|> and C</> are special in the LE<lt>...E<gt> context.\r
-Although the hyperlink parser does its best to determine which "/" is\r
-text and which is a delimiter in case of doubt, one ought to escape\r
-these literal characters like this:\r
-\r
- / E<sol>\r
- | E<verbar>\r
-\r
-=back\r
-\r
-=head1 RETURN VALUE\r
-\r
-B<podchecker> returns the number of POD syntax errors found or -1 if\r
-there were no POD commands at all found in the file.\r
-\r
-=head1 EXAMPLES\r
-\r
-See L</SYNOPSIS>\r
-\r
-=head1 INTERFACE\r
-\r
-While checking, this module collects document properties, e.g. the nodes\r
-for hyperlinks (C<=headX>, C<=item>) and index entries (C<XE<lt>E<gt>>).\r
-POD translators can use this feature to syntax-check and get the nodes in\r
-a first pass before actually starting to convert. This is expensive in terms\r
-of execution time, but allows for very robust conversions.\r
-\r
-Since PodParser-1.24 the B<Pod::Checker> module uses only the B<poderror>\r
-method to print errors and warnings. The summary output (e.g.\r
-"Pod syntax OK") has been dropped from the module and has been included in\r
-B<podchecker> (the script). This allows users of B<Pod::Checker> to\r
-control completely the output behavior. Users of B<podchecker> (the script)\r
-get the well-known behavior.\r
-\r
-=cut\r
-\r
-#############################################################################\r
-\r
-#use diagnostics;\r
-use Carp qw(croak);\r
-use Exporter;\r
-use Pod::Parser;\r
-\r
-@ISA = qw(Pod::Parser);\r
-@EXPORT = qw(&podchecker);\r
-\r
-my %VALID_COMMANDS = (\r
- 'pod' => 1,\r
- 'cut' => 1,\r
- 'head1' => 1,\r
- 'head2' => 1,\r
- 'head3' => 1,\r
- 'head4' => 1,\r
- 'over' => 1,\r
- 'back' => 1,\r
- 'item' => 1,\r
- 'for' => 1,\r
- 'begin' => 1,\r
- 'end' => 1,\r
- 'encoding' => 1,\r
-);\r
-\r
-my %VALID_SEQUENCES = (\r
- 'I' => 1,\r
- 'B' => 1,\r
- 'S' => 1,\r
- 'C' => 1,\r
- 'L' => 1,\r
- 'F' => 1,\r
- 'X' => 1,\r
- 'Z' => 1,\r
- 'E' => 1,\r
-);\r
-\r
-# stolen from HTML::Entities\r
-my %ENTITIES = (\r
- # Some normal chars that have special meaning in SGML context\r
- amp => '&', # ampersand\r
-'gt' => '>', # greater than\r
-'lt' => '<', # less than\r
- quot => '"', # double quote\r
-\r
- # PUBLIC ISO 8879-1986//ENTITIES Added Latin 1//EN//HTML\r
- AElig => 'Æ', # capital AE diphthong (ligature)\r
- Aacute => 'Á', # capital A, acute accent\r
- Acirc => 'Â', # capital A, circumflex accent\r
- Agrave => 'À', # capital A, grave accent\r
- Aring => 'Å', # capital A, ring\r
- Atilde => 'Ã', # capital A, tilde\r
- Auml => 'Ä', # capital A, dieresis or umlaut mark\r
- Ccedil => 'Ç', # capital C, cedilla\r
- ETH => 'Ð', # capital Eth, Icelandic\r
- Eacute => 'É', # capital E, acute accent\r
- Ecirc => 'Ê', # capital E, circumflex accent\r
- Egrave => 'È', # capital E, grave accent\r
- Euml => 'Ë', # capital E, dieresis or umlaut mark\r
- Iacute => 'Í', # capital I, acute accent\r
- Icirc => 'Î', # capital I, circumflex accent\r
- Igrave => 'Ì', # capital I, grave accent\r
- Iuml => 'Ï', # capital I, dieresis or umlaut mark\r
- Ntilde => 'Ñ', # capital N, tilde\r
- Oacute => 'Ó', # capital O, acute accent\r
- Ocirc => 'Ô', # capital O, circumflex accent\r
- Ograve => 'Ò', # capital O, grave accent\r
- Oslash => 'Ø', # capital O, slash\r
- Otilde => 'Õ', # capital O, tilde\r
- Ouml => 'Ö', # capital O, dieresis or umlaut mark\r
- THORN => 'Þ', # capital THORN, Icelandic\r
- Uacute => 'Ú', # capital U, acute accent\r
- Ucirc => 'Û', # capital U, circumflex accent\r
- Ugrave => 'Ù', # capital U, grave accent\r
- Uuml => 'Ü', # capital U, dieresis or umlaut mark\r
- Yacute => 'Ý', # capital Y, acute accent\r
- aacute => 'á', # small a, acute accent\r
- acirc => 'â', # small a, circumflex accent\r
- aelig => 'æ', # small ae diphthong (ligature)\r
- agrave => 'à', # small a, grave accent\r
- aring => 'å', # small a, ring\r
- atilde => 'ã', # small a, tilde\r
- auml => 'ä', # small a, dieresis or umlaut mark\r
- ccedil => 'ç', # small c, cedilla\r
- eacute => 'é', # small e, acute accent\r
- ecirc => 'ê', # small e, circumflex accent\r
- egrave => 'è', # small e, grave accent\r
- eth => 'ð', # small eth, Icelandic\r
- euml => 'ë', # small e, dieresis or umlaut mark\r
- iacute => 'í', # small i, acute accent\r
- icirc => 'î', # small i, circumflex accent\r
- igrave => 'ì', # small i, grave accent\r
- iuml => 'ï', # small i, dieresis or umlaut mark\r
- ntilde => 'ñ', # small n, tilde\r
- oacute => 'ó', # small o, acute accent\r
- ocirc => 'ô', # small o, circumflex accent\r
- ograve => 'ò', # small o, grave accent\r
- oslash => 'ø', # small o, slash\r
- otilde => 'õ', # small o, tilde\r
- ouml => 'ö', # small o, dieresis or umlaut mark\r
- szlig => 'ß', # small sharp s, German (sz ligature)\r
- thorn => 'þ', # small thorn, Icelandic\r
- uacute => 'ú', # small u, acute accent\r
- ucirc => 'û', # small u, circumflex accent\r
- ugrave => 'ù', # small u, grave accent\r
- uuml => 'ü', # small u, dieresis or umlaut mark\r
- yacute => 'ý', # small y, acute accent\r
- yuml => 'ÿ', # small y, dieresis or umlaut mark\r
-\r
- # Some extra Latin 1 chars that are listed in the HTML3.2 draft (21-May-96)\r
- copy => '©', # copyright sign\r
- reg => '®', # registered sign\r
- nbsp => "\240", # non breaking space\r
-\r
- # Additional ISO-8859/1 entities listed in rfc1866 (section 14)\r
- iexcl => '¡',\r
- cent => '¢',\r
- pound => '£',\r
- curren => '¤',\r
- yen => '¥',\r
- brvbar => '¦',\r
- sect => '§',\r
- uml => '¨',\r
- ordf => 'ª',\r
- laquo => '«',\r
-'not' => '¬', # not is a keyword in perl\r
- shy => '',\r
- macr => '¯',\r
- deg => '°',\r
- plusmn => '±',\r
- sup1 => '¹',\r
- sup2 => '²',\r
- sup3 => '³',\r
- acute => '´',\r
- micro => 'µ',\r
- para => '¶',\r
- middot => '·',\r
- cedil => '¸',\r
- ordm => 'º',\r
- raquo => '»',\r
- frac14 => '¼',\r
- frac12 => '½',\r
- frac34 => '¾',\r
- iquest => '¿',\r
-'times' => '×', # times is a keyword in perl\r
- divide => '÷',\r
-\r
-# some POD special entities\r
- verbar => '|',\r
- sol => '/'\r
-);\r
-\r
-##---------------------------------------------------------------------------\r
-\r
-##---------------------------------\r
-## Function definitions begin here\r
-##---------------------------------\r
-\r
-sub podchecker {\r
- my ($infile, $outfile, %options) = @_;\r
- local $_;\r
-\r
- ## Set defaults\r
- $infile ||= \*STDIN;\r
- $outfile ||= \*STDERR;\r
-\r
- ## Now create a pod checker\r
- my $checker = new Pod::Checker(%options);\r
-\r
- ## Now check the pod document for errors\r
- $checker->parse_from_file($infile, $outfile);\r
-\r
- ## Return the number of errors found\r
- return $checker->num_errors();\r
-}\r
-\r
-##---------------------------------------------------------------------------\r
-\r
-##-------------------------------\r
-## Method definitions begin here\r
-##-------------------------------\r
-\r
-##################################\r
-\r
-=over 4\r
-\r
-=item C<Pod::Checker-E<gt>new( %options )>\r
-\r
-Return a reference to a new Pod::Checker object that inherits from\r
-Pod::Parser and is used for calling the required methods later. The\r
-following options are recognized:\r
-\r
-C<-warnings =E<gt> num>\r
- Print warnings if C<num> is true. The higher the value of C<num>,\r
-the more warnings are printed. Currently there are only levels 1 and 2.\r
-\r
-C<-quiet =E<gt> num>\r
- If C<num> is true, do not print any errors/warnings. This is useful\r
-when Pod::Checker is used to munge POD code into plain text from within\r
-POD formatters.\r
-\r
-=cut\r
-\r
-## sub new {\r
-## my $this = shift;\r
-## my $class = ref($this) || $this;\r
-## my %params = @_;\r
-## my $self = {%params};\r
-## bless $self, $class;\r
-## $self->initialize();\r
-## return $self;\r
-## }\r
-\r
-sub initialize {\r
- my $self = shift;\r
- ## Initialize number of errors, and setup an error function to\r
- ## increment this number and then print to the designated output.\r
- $self->{_NUM_ERRORS} = 0;\r
- $self->{_NUM_WARNINGS} = 0;\r
- $self->{-quiet} ||= 0;\r
- # set the error handling subroutine\r
- $self->errorsub($self->{-quiet} ? sub { 1; } : 'poderror');\r
- $self->{_commands} = 0; # total number of POD commands encountered\r
- $self->{_list_stack} = []; # stack for nested lists\r
- $self->{_have_begin} = ''; # stores =begin\r
- $self->{_links} = []; # stack for internal hyperlinks\r
- $self->{_nodes} = []; # stack for =head/=item nodes\r
- $self->{_index} = []; # text in X<>\r
- # print warnings?\r
- $self->{-warnings} = 1 unless(defined $self->{-warnings});\r
- $self->{_current_head1} = ''; # the current =head1 block\r
- $self->parseopts(-process_cut_cmd => 1, -warnings => $self->{-warnings});\r
-}\r
-\r
-##################################\r
-\r
-=item C<$checker-E<gt>poderror( @args )>\r
-\r
-=item C<$checker-E<gt>poderror( {%opts}, @args )>\r
-\r
-Internal method for printing errors and warnings. If no options are\r
-given, simply prints "@_". The following options are recognized and used\r
-to form the output:\r
-\r
- -msg\r
-\r
-A message to print prior to C<@args>.\r
-\r
- -line\r
-\r
-The line number the error occurred in.\r
-\r
- -file\r
-\r
-The file (name) the error occurred in.\r
-\r
- -severity\r
-\r
-The error level, should be 'WARNING' or 'ERROR'.\r
-\r
-=cut\r
-\r
-# Invoked as $self->poderror( @args ), or $self->poderror( {%opts}, @args )\r
-sub poderror {\r
- my $self = shift;\r
- my %opts = (ref $_[0]) ? %{shift()} : ();\r
-\r
- ## Retrieve options\r
- chomp( my $msg = ($opts{-msg} || '')."@_" );\r
- my $line = (exists $opts{-line}) ? " at line $opts{-line}" : '';\r
- my $file = (exists $opts{-file}) ? " in file $opts{-file}" : '';\r
- unless (exists $opts{-severity}) {\r
- ## See if can find severity in message prefix\r
- $opts{-severity} = $1 if ( $msg =~ s/^\**\s*([A-Z]{3,}):\s+// );\r
- }\r
- my $severity = (exists $opts{-severity}) ? "*** $opts{-severity}: " : '';\r
-\r
- ## Increment error count and print message "\r
- ++($self->{_NUM_ERRORS})\r
- if(!%opts || ($opts{-severity} && $opts{-severity} eq 'ERROR'));\r
- ++($self->{_NUM_WARNINGS})\r
- if(!%opts || ($opts{-severity} && $opts{-severity} eq 'WARNING'));\r
- unless($self->{-quiet}) {\r
- my $out_fh = $self->output_handle() || \*STDERR;\r
- print $out_fh ($severity, $msg, $line, $file, "\n")\r
- if($self->{-warnings} || !%opts || $opts{-severity} ne 'WARNING');\r
- }\r
-}\r
-\r
-##################################\r
-\r
-=item C<$checker-E<gt>num_errors()>\r
-\r
-Set (if argument specified) and retrieve the number of errors found.\r
-\r
-=cut\r
-\r
-sub num_errors {\r
- return (@_ > 1) ? ($_[0]->{_NUM_ERRORS} = $_[1]) : $_[0]->{_NUM_ERRORS};\r
-}\r
-\r
-##################################\r
-\r
-=item C<$checker-E<gt>num_warnings()>\r
-\r
-Set (if argument specified) and retrieve the number of warnings found.\r
-\r
-=cut\r
-\r
-sub num_warnings {\r
- return (@_ > 1) ? ($_[0]->{_NUM_WARNINGS} = $_[1]) : $_[0]->{_NUM_WARNINGS};\r
-}\r
-\r
-##################################\r
-\r
-=item C<$checker-E<gt>name()>\r
-\r
-Set (if argument specified) and retrieve the canonical name of POD as\r
-found in the C<=head1 NAME> section.\r
-\r
-=cut\r
-\r
-sub name {\r
- return (@_ > 1 && $_[1]) ?\r
- ($_[0]->{-name} = $_[1]) : $_[0]->{-name};\r
-}\r
-\r
-##################################\r
-\r
-=item C<$checker-E<gt>node()>\r
-\r
-Add (if argument specified) and retrieve the nodes (as defined by C<=headX>\r
-and C<=item>) of the current POD. The nodes are returned in the order of\r
-their occurrence. They consist of plain text, each piece of whitespace is\r
-collapsed to a single blank.\r
-\r
-=cut\r
-\r
-sub node {\r
- my ($self,$text) = @_;\r
- if(defined $text) {\r
- $text =~ s/\s+$//s; # strip trailing whitespace\r
- $text =~ s/\s+/ /gs; # collapse whitespace\r
- # add node, order important!\r
- push(@{$self->{_nodes}}, $text);\r
- # keep also a uniqueness counter\r
- $self->{_unique_nodes}->{$text}++ if($text !~ /^\s*$/s);\r
- return $text;\r
- }\r
- @{$self->{_nodes}};\r
-}\r
-\r
-##################################\r
-\r
-=item C<$checker-E<gt>idx()>\r
-\r
-Add (if argument specified) and retrieve the index entries (as defined by\r
-C<XE<lt>E<gt>>) of the current POD. They consist of plain text, each piece\r
-of whitespace is collapsed to a single blank.\r
-\r
-=cut\r
-\r
-# set/return index entries of current POD\r
-sub idx {\r
- my ($self,$text) = @_;\r
- if(defined $text) {\r
- $text =~ s/\s+$//s; # strip trailing whitespace\r
- $text =~ s/\s+/ /gs; # collapse whitespace\r
- # add node, order important!\r
- push(@{$self->{_index}}, $text);\r
- # keep also a uniqueness counter\r
- $self->{_unique_nodes}->{$text}++ if($text !~ /^\s*$/s);\r
- return $text;\r
- }\r
- @{$self->{_index}};\r
-}\r
-\r
-##################################\r
-\r
-=item C<$checker-E<gt>hyperlink()>\r
-\r
-Add (if argument specified) and retrieve the hyperlinks (as defined by\r
-C<LE<lt>E<gt>>) of the current POD. They consist of a 2-item array: line\r
-number and C<Pod::Hyperlink> object.\r
-\r
-=back\r
-\r
-=cut\r
-\r
-# set/return hyperlinks of the current POD\r
-sub hyperlink {\r
- my $self = shift;\r
- if($_[0]) {\r
- push(@{$self->{_links}}, $_[0]);\r
- return $_[0];\r
- }\r
- @{$self->{_links}};\r
-}\r
-\r
-## overrides for Pod::Parser\r
-\r
-sub end_pod {\r
- ## Do some final checks and\r
- ## print the number of errors found\r
- my $self = shift;\r
- my $infile = $self->input_file();\r
-\r
- if(@{$self->{_list_stack}}) {\r
- my $list;\r
- while(($list = $self->_close_list('EOF',$infile)) &&\r
- $list->indent() ne 'auto') {\r
- $self->poderror({ -line => 'EOF', -file => $infile,\r
- -severity => 'ERROR', -msg => '=over on line ' .\r
- $list->start() . ' without closing =back' });\r
- }\r
- }\r
-\r
- # check validity of document internal hyperlinks\r
- # first build the node names from the paragraph text\r
- my %nodes;\r
- foreach($self->node()) {\r
- $nodes{$_} = 1;\r
- if(/^(\S+)\s+\S/) {\r
- # we have more than one word. Use the first as a node, too.\r
- # This is used heavily in perlfunc.pod\r
- $nodes{$1} ||= 2; # derived node\r
- }\r
- }\r
- foreach($self->idx()) {\r
- $nodes{$_} = 3; # index node\r
- }\r
- foreach($self->hyperlink()) {\r
- my ($line,$link) = @$_;\r
- # _TODO_ what if there is a link to the page itself by the name,\r
- # e.g. in Tk::Pod : L<Tk::Pod/"DESCRIPTION">\r
- if($link->node() && !$link->page() && $link->type() ne 'hyperlink') {\r
- my $node = $self->_check_ptree($self->parse_text($link->node(),\r
- $line), $line, $infile, 'L');\r
- if($node && !$nodes{$node}) {\r
- $self->poderror({ -line => $line || '', -file => $infile,\r
- -severity => 'ERROR',\r
- -msg => "unresolved internal link '$node'"});\r
- }\r
- }\r
- }\r
-\r
- # check the internal nodes for uniqueness. This pertains to\r
- # =headX, =item and X<...>\r
- if($self->{-warnings} && $self->{-warnings}>1) {\r
- foreach(grep($self->{_unique_nodes}->{$_} > 1,\r
- keys %{$self->{_unique_nodes}})) {\r
- $self->poderror({ -line => '-', -file => $infile,\r
- -severity => 'WARNING',\r
- -msg => "multiple occurrence of link target '$_'"});\r
- }\r
- }\r
-\r
- # no POD found here\r
- $self->num_errors(-1) if($self->{_commands} == 0);\r
-}\r
-\r
-# check a POD command directive\r
-sub command {\r
- my ($self, $cmd, $paragraph, $line_num, $pod_para) = @_;\r
- my ($file, $line) = $pod_para->file_line;\r
- ## Check the command syntax\r
- my $arg; # this will hold the command argument\r
- if (! $VALID_COMMANDS{$cmd}) {\r
- $self->poderror({ -line => $line, -file => $file, -severity => 'ERROR',\r
- -msg => "Unknown command '$cmd'" });\r
- }\r
- else { # found a valid command\r
- $self->{_commands}++; # delete this line if below is enabled again\r
-\r
- $self->_commands_in_paragraphs($paragraph, $pod_para);\r
-\r
- ##### following check disabled due to strong request\r
- #if(!$self->{_commands}++ && $cmd !~ /^head/) {\r
- # $self->poderror({ -line => $line, -file => $file,\r
- # -severity => 'WARNING',\r
- # -msg => "file does not start with =head" });\r
- #}\r
-\r
- # check syntax of particular command\r
- if($cmd eq 'over') {\r
- # check for argument\r
- $arg = $self->interpolate_and_check($paragraph, $line,$file);\r
- my $indent = 4; # default\r
- if($arg && $arg =~ /^\s*(\d+)\s*$/) {\r
- $indent = $1;\r
- }\r
- # start a new list\r
- $self->_open_list($indent,$line,$file);\r
- }\r
- elsif($cmd eq 'item') {\r
- # are we in a list?\r
- unless(@{$self->{_list_stack}}) {\r
- $self->poderror({ -line => $line, -file => $file,\r
- -severity => 'ERROR',\r
- -msg => '=item without previous =over' });\r
- # auto-open in case we encounter many more\r
- $self->_open_list('auto',$line,$file);\r
- }\r
- my $list = $self->{_list_stack}->[0];\r
- # check whether the previous item had some contents\r
- if(defined $self->{_list_item_contents} &&\r
- $self->{_list_item_contents} == 0) {\r
- $self->poderror({ -line => $line, -file => $file,\r
- -severity => 'WARNING',\r
- -msg => 'previous =item has no contents' });\r
- }\r
- if($list->{_has_par}) {\r
- $self->poderror({ -line => $line, -file => $file,\r
- -severity => 'WARNING',\r
- -msg => 'preceding non-item paragraph(s)' });\r
- delete $list->{_has_par};\r
- }\r
- # check for argument\r
- $arg = $self->interpolate_and_check($paragraph, $line, $file);\r
- if($arg && $arg =~ /(\S+)/) {\r
- $arg =~ s/[\s\n]+$//;\r
- my $type;\r
- if($arg =~ /^[*]\s*(\S*.*)/) {\r
- $type = 'bullet';\r
- $self->{_list_item_contents} = $1 ? 1 : 0;\r
- $arg = $1;\r
- }\r
- elsif($arg =~ /^\d+\.?\s+(\S*)/) {\r
- $type = 'number';\r
- $self->{_list_item_contents} = $1 ? 1 : 0;\r
- $arg = $1;\r
- }\r
- else {\r
- $type = 'definition';\r
- $self->{_list_item_contents} = 1;\r
- }\r
- my $first = $list->type();\r
- if($first && $first ne $type) {\r
- $self->poderror({ -line => $line, -file => $file,\r
- -severity => 'WARNING',\r
- -msg => "=item type mismatch ('$first' vs. '$type')"});\r
- }\r
- else { # first item\r
- $list->type($type);\r
- }\r
- }\r
- else {\r
- $self->poderror({ -line => $line, -file => $file,\r
- -severity => 'WARNING',\r
- -msg => 'No argument for =item' });\r
- $arg = ' '; # empty\r
- $self->{_list_item_contents} = 0;\r
- }\r
- # add this item\r
- $list->item($arg);\r
- # remember this node\r
- $self->node($arg);\r
- }\r
- elsif($cmd eq 'back') {\r
- # check if we have an open list\r
- unless(@{$self->{_list_stack}}) {\r
- $self->poderror({ -line => $line, -file => $file,\r
- -severity => 'ERROR',\r
- -msg => '=back without previous =over' });\r
- }\r
- else {\r
- # check for spurious characters\r
- $arg = $self->interpolate_and_check($paragraph, $line,$file);\r
- if($arg && $arg =~ /\S/) {\r
- $self->poderror({ -line => $line, -file => $file,\r
- -severity => 'ERROR',\r
- -msg => 'Spurious character(s) after =back' });\r
- }\r
- # close list\r
- my $list = $self->_close_list($line,$file);\r
- # check for empty lists\r
- if(!$list->item() && $self->{-warnings}) {\r
- $self->poderror({ -line => $line, -file => $file,\r
- -severity => 'WARNING',\r
- -msg => 'No items in =over (at line ' .\r
- $list->start() . ') / =back list'});\r
- }\r
- }\r
- }\r
- elsif($cmd =~ /^head(\d+)/) {\r
- my $hnum = $1;\r
- $self->{"_have_head_$hnum"}++; # count head types\r
- if($hnum > 1 && !$self->{'_have_head_'.($hnum -1)}) {\r
- $self->poderror({ -line => $line, -file => $file,\r
- -severity => 'WARNING',\r
- -msg => "=head$hnum without preceding higher level"});\r
- }\r
- # check whether the previous =head section had some contents\r
- if(defined $self->{_commands_in_head} &&\r
- $self->{_commands_in_head} == 0 &&\r
- defined $self->{_last_head} &&\r
- $self->{_last_head} >= $hnum) {\r
- $self->poderror({ -line => $line, -file => $file,\r
- -severity => 'WARNING',\r
- -msg => 'empty section in previous paragraph'});\r
- }\r
- $self->{_commands_in_head} = -1;\r
- $self->{_last_head} = $hnum;\r
- # check if there is an open list\r
- if(@{$self->{_list_stack}}) {\r
- my $list;\r
- while(($list = $self->_close_list($line,$file)) &&\r
- $list->indent() ne 'auto') {\r
- $self->poderror({ -line => $line, -file => $file,\r
- -severity => 'ERROR',\r
- -msg => '=over on line '. $list->start() .\r
- " without closing =back (at $cmd)" });\r
- }\r
- }\r
- # remember this node\r
- $arg = $self->interpolate_and_check($paragraph, $line,$file);\r
- $arg =~ s/[\s\n]+$//s;\r
- $self->node($arg);\r
- unless(length($arg)) {\r
- $self->poderror({ -line => $line, -file => $file,\r
- -severity => 'ERROR',\r
- -msg => "empty =$cmd"});\r
- }\r
- if($cmd eq 'head1') {\r
- $self->{_current_head1} = $arg;\r
- } else {\r
- $self->{_current_head1} = '';\r
- }\r
- }\r
- elsif($cmd eq 'begin') {\r
- if($self->{_have_begin}) {\r
- # already have a begin\r
- $self->poderror({ -line => $line, -file => $file,\r
- -severity => 'ERROR',\r
- -msg => q{Nested =begin's (first at line } .\r
- $self->{_have_begin} . ')'});\r
- }\r
- else {\r
- # check for argument\r
- $arg = $self->interpolate_and_check($paragraph, $line,$file);\r
- unless($arg && $arg =~ /(\S+)/) {\r
- $self->poderror({ -line => $line, -file => $file,\r
- -severity => 'ERROR',\r
- -msg => 'No argument for =begin'});\r
- }\r
- # remember the =begin\r
- $self->{_have_begin} = "$line:$1";\r
- }\r
- }\r
- elsif($cmd eq 'end') {\r
- if($self->{_have_begin}) {\r
- # close the existing =begin\r
- $self->{_have_begin} = '';\r
- # check for spurious characters\r
- $arg = $self->interpolate_and_check($paragraph, $line,$file);\r
- # the closing argument is optional\r
- #if($arg && $arg =~ /\S/) {\r
- # $self->poderror({ -line => $line, -file => $file,\r
- # -severity => 'WARNING',\r
- # -msg => "Spurious character(s) after =end" });\r
- #}\r
- }\r
- else {\r
- # don't have a matching =begin\r
- $self->poderror({ -line => $line, -file => $file,\r
- -severity => 'ERROR',\r
- -msg => '=end without =begin' });\r
- }\r
- }\r
- elsif($cmd eq 'for') {\r
- unless($paragraph =~ /\s*(\S+)\s*/) {\r
- $self->poderror({ -line => $line, -file => $file,\r
- -severity => 'ERROR',\r
- -msg => '=for without formatter specification' });\r
- }\r
- $arg = ''; # do not expand paragraph below\r
- }\r
- elsif($cmd =~ /^(pod|cut)$/) {\r
- # check for argument\r
- $arg = $self->interpolate_and_check($paragraph, $line,$file);\r
- if($arg && $arg =~ /(\S+)/) {\r
- $self->poderror({ -line => $line, -file => $file,\r
- -severity => 'ERROR',\r
- -msg => "Spurious text after =$cmd"});\r
- }\r
- if($cmd eq 'cut' && (!$self->{_PREVIOUS} || $self->{_PREVIOUS} eq 'cut')) {\r
- $self->poderror({ -line => $line, -file => $file,\r
- -severity => 'ERROR',\r
- -msg => "Spurious =cut command"});\r
- }\r
- if($cmd eq 'pod' && $self->{_PREVIOUS} && $self->{_PREVIOUS} ne 'cut') {\r
- $self->poderror({ -line => $line, -file => $file,\r
- -severity => 'ERROR',\r
- -msg => "Spurious =pod command"});\r
- }\r
- }\r
- $self->{_commands_in_head}++;\r
- ## Check the interior sequences in the command-text\r
- $self->interpolate_and_check($paragraph, $line,$file)\r
- unless(defined $arg);\r
- }\r
-}\r
-\r
-sub _open_list\r
-{\r
- my ($self,$indent,$line,$file) = @_;\r
- my $list = Pod::List->new(\r
- -indent => $indent,\r
- -start => $line,\r
- -file => $file);\r
- unshift(@{$self->{_list_stack}}, $list);\r
- undef $self->{_list_item_contents};\r
- $list;\r
-}\r
-\r
-sub _close_list\r
-{\r
- my ($self,$line,$file) = @_;\r
- my $list = shift(@{$self->{_list_stack}});\r
- if(defined $self->{_list_item_contents} &&\r
- $self->{_list_item_contents} == 0) {\r
- $self->poderror({ -line => $line, -file => $file,\r
- -severity => 'WARNING',\r
- -msg => 'previous =item has no contents' });\r
- }\r
- undef $self->{_list_item_contents};\r
- $list;\r
-}\r
-\r
-# process a block of some text\r
-sub interpolate_and_check {\r
- my ($self, $paragraph, $line, $file) = @_;\r
- ## Check the interior sequences in the command-text\r
- # and return the text\r
- $self->_check_ptree(\r
- $self->parse_text($paragraph,$line), $line, $file, '');\r
-}\r
-\r
-sub _check_ptree {\r
- my ($self,$ptree,$line,$file,$nestlist) = @_;\r
- local($_);\r
- my $text = '';\r
- # process each node in the parse tree\r
- foreach(@$ptree) {\r
- # regular text chunk\r
- unless(ref) {\r
- # count the unescaped angle brackets\r
- # complain only when warning level is greater than 1\r
- if($self->{-warnings} && $self->{-warnings}>1) {\r
- my $count;\r
- if($count = tr/<>/<>/) {\r
- $self->poderror({ -line => $line, -file => $file,\r
- -severity => 'WARNING',\r
- -msg => "$count unescaped <> in paragraph" });\r
- }\r
- }\r
- $text .= $_;\r
- next;\r
- }\r
- # have an interior sequence\r
- my $cmd = $_->cmd_name();\r
- my $contents = $_->parse_tree();\r
- ($file,$line) = $_->file_line();\r
- # check for valid tag\r
- if (! $VALID_SEQUENCES{$cmd}) {\r
- $self->poderror({ -line => $line, -file => $file,\r
- -severity => 'ERROR',\r
- -msg => qq(Unknown interior-sequence '$cmd')});\r
- # expand it anyway\r
- $text .= $self->_check_ptree($contents, $line, $file, "$nestlist$cmd");\r
- next;\r
- }\r
- if(index($nestlist, $cmd) != -1) {\r
- $self->poderror({ -line => $line, -file => $file,\r
- -severity => 'WARNING',\r
- -msg => "nested commands $cmd<...$cmd<...>...>"});\r
- # _TODO_ should we add the contents anyway?\r
- # expand it anyway, see below\r
- }\r
- if($cmd eq 'E') {\r
- # preserve entities\r
- if(@$contents > 1 || ref $$contents[0] || $$contents[0] !~ /^\w+$/) {\r
- $self->poderror({ -line => $line, -file => $file,\r
- -severity => 'ERROR',\r
- -msg => 'garbled entity ' . $_->raw_text()});\r
- next;\r
- }\r
- my $ent = $$contents[0];\r
- my $val;\r
- if($ent =~ /^0x[0-9a-f]+$/i) {\r
- # hexadec entity\r
- $val = hex($ent);\r
- }\r
- elsif($ent =~ /^0\d+$/) {\r
- # octal\r
- $val = oct($ent);\r
- }\r
- elsif($ent =~ /^\d+$/) {\r
- # numeric entity\r
- $val = $ent;\r
- }\r
- if(defined $val) {\r
- if($val>0 && $val<256) {\r
- $text .= chr($val);\r
- }\r
- else {\r
- $self->poderror({ -line => $line, -file => $file,\r
- -severity => 'ERROR',\r
- -msg => 'Entity number out of range ' . $_->raw_text()});\r
- }\r
- }\r
- elsif($ENTITIES{$ent}) {\r
- # known ISO entity\r
- $text .= $ENTITIES{$ent};\r
- }\r
- else {\r
- $self->poderror({ -line => $line, -file => $file,\r
- -severity => 'WARNING',\r
- -msg => 'Unknown entity ' . $_->raw_text()});\r
- $text .= "E<$ent>";\r
- }\r
- }\r
- elsif($cmd eq 'L') {\r
- # try to parse the hyperlink\r
- my $link = Pod::Hyperlink->new($contents->raw_text());\r
- unless(defined $link) {\r
- $self->poderror({ -line => $line, -file => $file,\r
- -severity => 'ERROR',\r
- -msg => 'malformed link ' . $_->raw_text() ." : $@"});\r
- next;\r
- }\r
- $link->line($line); # remember line\r
- if($self->{-warnings}) {\r
- foreach my $w ($link->warning()) {\r
- $self->poderror({ -line => $line, -file => $file,\r
- -severity => 'WARNING',\r
- -msg => $w });\r
- }\r
- }\r
- # check the link text\r
- $text .= $self->_check_ptree($self->parse_text($link->text(),\r
- $line), $line, $file, "$nestlist$cmd");\r
- # remember link\r
- $self->hyperlink([$line,$link]);\r
- }\r
- elsif($cmd =~ /[BCFIS]/) {\r
- # add the guts\r
- $text .= $self->_check_ptree($contents, $line, $file, "$nestlist$cmd");\r
- }\r
- elsif($cmd eq 'Z') {\r
- if(length($contents->raw_text())) {\r
- $self->poderror({ -line => $line, -file => $file,\r
- -severity => 'ERROR',\r
- -msg => 'Nonempty Z<>'});\r
- }\r
- }\r
- elsif($cmd eq 'X') {\r
- my $idx = $self->_check_ptree($contents, $line, $file, "$nestlist$cmd");\r
- if($idx =~ /^\s*$/s) {\r
- $self->poderror({ -line => $line, -file => $file,\r
- -severity => 'ERROR',\r
- -msg => 'Empty X<>'});\r
- }\r
- else {\r
- # remember this node\r
- $self->idx($idx);\r
- }\r
- }\r
- else {\r
- # not reached\r
- croak 'internal error';\r
- }\r
- }\r
- $text;\r
-}\r
-\r
-# process a block of verbatim text\r
-sub verbatim {\r
- ## Nothing particular to check\r
- my ($self, $paragraph, $line_num, $pod_para) = @_;\r
-\r
- $self->_preproc_par($paragraph);\r
- $self->_commands_in_paragraphs($paragraph, $pod_para);\r
-\r
- if($self->{_current_head1} eq 'NAME') {\r
- my ($file, $line) = $pod_para->file_line;\r
- $self->poderror({ -line => $line, -file => $file,\r
- -severity => 'WARNING',\r
- -msg => 'Verbatim paragraph in NAME section' });\r
- }\r
-}\r
-\r
-# process a block of regular text\r
-sub textblock {\r
- my ($self, $paragraph, $line_num, $pod_para) = @_;\r
- my ($file, $line) = $pod_para->file_line;\r
-\r
- $self->_preproc_par($paragraph);\r
- $self->_commands_in_paragraphs($paragraph, $pod_para);\r
-\r
- # skip this paragraph if in a =begin block\r
- unless($self->{_have_begin}) {\r
- my $block = $self->interpolate_and_check($paragraph, $line,$file);\r
- if($self->{_current_head1} eq 'NAME') {\r
- if($block =~ /^\s*(\S+?)\s*[,-]/) {\r
- # this is the canonical name\r
- $self->{-name} = $1 unless(defined $self->{-name});\r
- }\r
- }\r
- }\r
-}\r
-\r
-sub _preproc_par\r
-{\r
- my $self = shift;\r
- $_[0] =~ s/[\s\n]+$//;\r
- if($_[0]) {\r
- $self->{_commands_in_head}++;\r
- $self->{_list_item_contents}++ if(defined $self->{_list_item_contents});\r
- if(@{$self->{_list_stack}} && !$self->{_list_stack}->[0]->item()) {\r
- $self->{_list_stack}->[0]->{_has_par} = 1;\r
- }\r
- }\r
-}\r
-\r
-# look for =foo commands at the start of a line within a paragraph, as for\r
-# instance the following which prints as "* one =item two".\r
-#\r
-# =item one\r
-# =item two\r
-#\r
-# Examples of =foo written in docs are expected to be indented in a verbatim\r
-# or marked up C<=foo> so won't be caught. A double-angle C<< =foo >> could\r
-# have the =foo at the start of a line, but that should be unlikely and is\r
-# easily enough dealt with by not putting a newline after the C<<.\r
-#\r
-sub _commands_in_paragraphs {\r
- my ($self, $str, $pod_para) = @_;\r
- while ($str =~ /[^\n]\n=([a-z][a-z0-9]+)/sg) {\r
- my $cmd = $1;\r
- my $pos = pos($str);\r
- if ($VALID_COMMANDS{$cmd}) {\r
- my ($file, $line) = $pod_para->file_line;\r
- my $part = substr($str, 0, $pos);\r
- $line += ($part =~ tr/\n//); # count of newlines\r
-\r
- $self->poderror\r
- ({ -line => $line, -file => $file,\r
- -severity => 'ERROR',\r
- -msg => "Apparent command =$cmd not preceded by blank line"});\r
- }\r
- }\r
-}\r
-\r
-1;\r
-\r
-__END__\r
-\r
-=head1 AUTHOR\r
-\r
-Please report bugs using L<http://rt.cpan.org>.\r
-\r
-Brad Appleton E<lt>bradapp@enteract.comE<gt> (initial version),\r
-Marek Rouchal E<lt>marekr@cpan.orgE<gt>\r
-\r
-Based on code for B<Pod::Text::pod2text()> written by\r
-Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>\r
-\r
-B<Pod::Checker> is part of the Pod-Checker distribution, and is based on\r
-L<Pod::Parser>.\r
-\r
-=cut\r
-\r
+#############################################################################
+# Pod/Checker.pm -- check pod documents for syntax errors
+#
+# Copyright (C) 1994-2000 by Bradford Appleton. All rights reserved.
+# This is free software; you can redistribute it and/or modify it under the
+# same terms as Perl itself.
+#############################################################################
+
+package Pod::Checker;
+use strict;
+use warnings;
+
+our $VERSION = '1.73'; ## Current version of this package
+
+=head1 NAME
+
+Pod::Checker - check pod documents for syntax errors
+
+=head1 SYNOPSIS
+
+ use Pod::Checker;
+
+ $syntax_okay = podchecker($filepath, $outputpath, %options);
+
+ my $checker = Pod::Checker->new(%options);
+ $checker->parse_from_file($filepath, \*STDERR);
+
+=head1 OPTIONS/ARGUMENTS
+
+C<$filepath> is the input POD to read and C<$outputpath> is
+where to write POD syntax error messages. Either argument may be a scalar
+indicating a file-path, or else a reference to an open filehandle.
+If unspecified, the input-file it defaults to C<\*STDIN>, and
+the output-file defaults to C<\*STDERR>.
+
+=head2 podchecker()
+
+This function can take a hash of options:
+
+=over 4
+
+=item B<-warnings> =E<gt> I<val>
+
+Turn warnings on/off. I<val> is usually 1 for on, but higher values
+trigger additional warnings. See L<"Warnings">.
+
+=item B<-quiet> =E<gt> I<val>
+
+If C<val> is true, do not print any errors/warnings.
+
+=back
+
+=head1 DESCRIPTION
+
+B<podchecker> will perform syntax checking of Perl5 POD format documentation.
+
+Curious/ambitious users are welcome to propose additional features they wish
+to see in B<Pod::Checker> and B<podchecker> and verify that the checks are
+consistent with L<perlpod>.
+
+The following checks are currently performed:
+
+=over 4
+
+=item *
+
+Unknown '=xxxx' commands, unknown 'XE<lt>...E<gt>' interior-sequences,
+and unterminated interior sequences.
+
+=item *
+
+Check for proper balancing of C<=begin> and C<=end>. The contents of such
+a block are generally ignored, i.e. no syntax checks are performed.
+
+=item *
+
+Check for proper nesting and balancing of C<=over>, C<=item> and C<=back>.
+
+=item *
+
+Check for same nested interior-sequences (e.g.
+C<LE<lt>...LE<lt>...E<gt>...E<gt>>).
+
+=item *
+
+Check for malformed or non-existing entities C<EE<lt>...E<gt>>.
+
+=item *
+
+Check for correct syntax of hyperlinks C<LE<lt>...E<gt>>. See L<perlpod>
+for details.
+
+=item *
+
+Check for unresolved document-internal links. This check may also reveal
+misspelled links that seem to be internal links but should be links
+to something else.
+
+=back
+
+=head1 DIAGNOSTICS
+
+=head2 Errors
+
+=over 4
+
+=item * empty =headn
+
+A heading (C<=head1> or C<=head2>) without any text? That ain't no
+heading!
+
+=item * =over on line I<N> without closing =back
+
+=item * You forgot a '=back' before '=headI<N>'
+
+=item * =over is the last thing in the document?!
+
+The C<=over> command does not have a corresponding C<=back> before the
+next heading (C<=head1> or C<=head2>) or the end of the file.
+
+=item * '=item' outside of any '=over'
+
+=item * =back without =over
+
+An C<=item> or C<=back> command has been found outside a
+C<=over>/C<=back> block.
+
+=item * Can't have a 0 in =over I<N>
+
+You need to indent a strictly positive number of spaces, not 0.
+
+=item * =over should be: '=over' or '=over positive_number'
+
+Either have an argumentless =over, or have its argument a strictly positive number.
+
+=item * =begin I<TARGET> without matching =end I<TARGET>
+
+A C<=begin> command was found that has no matching =end command.
+
+=item * =begin without a target?
+
+A C<=begin> command was found that is not followed by the formatter
+specification.
+
+=item * =end I<TARGET> without matching =begin.
+
+A standalone C<=end> command was found.
+
+=item * '=end' without a target?
+
+'=end' directives need to have a target, just like =begin directives.
+
+=item * '=end I<TARGET>' is invalid.
+
+I<TARGET> needs to be one word
+
+=item * =end I<CONTENT> doesn't match =begin I<TARGET>
+
+I<CONTENT> needs to match =begin's I<TARGET>.
+
+=item * =for without a target?
+
+There is no specification of the formatter after the C<=for> command.
+
+=item * unresolved internal link I<NAME>
+
+The given link to I<NAME> does not have a matching node in the current
+POD. This also happened when a single word node name is not enclosed in
+C<"">.
+
+=item * Unknown directive: I<CMD>
+
+An invalid POD command has been found. Valid are C<=head1>, C<=head2>,
+C<=head3>, C<=head4>, C<=over>, C<=item>, C<=back>, C<=begin>, C<=end>,
+C<=for>, C<=pod>, C<=cut>
+
+=item * Deleting unknown formatting code I<SEQ>
+
+An invalid markup command has been encountered. Valid are:
+C<BE<lt>E<gt>>, C<CE<lt>E<gt>>, C<EE<lt>E<gt>>, C<FE<lt>E<gt>>,
+C<IE<lt>E<gt>>, C<LE<lt>E<gt>>, C<SE<lt>E<gt>>, C<XE<lt>E<gt>>,
+C<ZE<lt>E<gt>>
+
+=item * Unterminated I<SEQ>E<lt>E<gt> sequence
+
+An unclosed formatting code
+
+=item * An EE<lt>...E<gt> surrounding strange content
+
+The I<STRING> found cannot be interpreted as a character entity.
+
+=item * An empty EE<lt>E<gt>
+
+=item * An empty C<< LE<lt>E<gt> >>
+
+=item * An empty XE<lt>E<gt>
+
+There needs to be content inside E, L, and X formatting codes.
+
+=item * A non-empty ZE<lt>E<gt>
+
+The C<ZE<lt>E<gt>> sequence is supposed to be empty.
+
+=item * Spurious text after =pod / =cut
+
+The commands C<=pod> and C<=cut> do not take any arguments.
+
+=item * =back doesn't take any parameters, but you said =back I<ARGUMENT>
+
+The C<=back> command does not take any arguments.
+
+=item * =pod directives shouldn't be over one line long! Ignoring all I<N> lines of content
+
+Self explanatory
+
+=item * =cut found outside a pod block.
+
+A '=cut' directive found in the middle of non-POD
+
+=item * Invalid =encoding syntax: I<CONTENT>
+
+Syntax error in =encoding directive
+
+=back
+
+=head2 Warnings
+
+These may not necessarily cause trouble, but indicate mediocre style.
+
+=over 4
+
+=item * nested commands I<CMD>E<lt>...I<CMD>E<lt>...E<gt>...E<gt>
+
+Two nested identical markup commands have been found. Generally this
+does not make sense.
+
+=item * multiple occurrences (I<N>) of link target I<name>
+
+The POD file has some C<=item> and/or C<=head> commands that have
+the same text. Potential hyperlinks to such a text cannot be unique then.
+This warning is printed only with warning level greater than one.
+
+=item * line containing nothing but whitespace in paragraph
+
+There is some whitespace on a seemingly empty line. POD is very sensitive
+to such things, so this is flagged. B<vi> users switch on the B<list>
+option to avoid this problem.
+
+=item * =item has no contents
+
+There is a list C<=item> that has no text contents. You probably want to delete
+empty items.
+
+=item * You can't have =items (as at line I<N>) unless the first thing after the =over is an =item
+
+A list introduced by C<=over> starts with a text or verbatim paragraph,
+but continues with C<=item>s. Move the non-item paragraph out of the
+C<=over>/C<=back> block.
+
+=item * Expected '=item I<EXPECTED VALUE>'
+
+=item * Expected '=item *'
+
+=item * Possible =item type mismatch: 'I<x>' found leading a supposed definition =item
+
+A list started with e.g. a bullet-like C<=item> and continued with a
+numbered one. This is obviously inconsistent. For most translators the
+type of the I<first> C<=item> determines the type of the list.
+
+=item * You have '=item x' instead of the expected '=item I<N>'
+
+Erroneous numbering of =item numbers; they need to ascend consecutively.
+
+=item * Unknown E content in EE<lt>I<CONTENT>E<gt>
+
+A character entity was found that does not belong to the standard
+ISO set or the POD specials C<verbar> and C<sol>. I<Currently, this warning
+only appears if a character entity was found that does not have a Unicode
+character. This should be fixed to adhere to the original warning.>
+
+=item * empty =over/=back block
+
+The list opened with C<=over> does not contain anything.
+
+=item * empty section in previous paragraph
+
+The previous section (introduced by a C<=head> command) does not contain
+any valid content. This usually indicates that something is missing. Note: A
+C<=head1> followed immediately by C<=head2> does not trigger this warning.
+
+=item * Verbatim paragraph in NAME section
+
+The NAME section (C<=head1 NAME>) should consist of a single paragraph
+with the script/module name, followed by a dash `-' and a very short
+description of what the thing is good for.
+
+=item * =headI<n> without preceding higher level
+
+For example if there is a C<=head2> in the POD file prior to a
+C<=head1>.
+
+=back
+
+=head2 Hyperlinks
+
+There are some warnings with respect to malformed hyperlinks:
+
+=over 4
+
+=item * ignoring leading/trailing whitespace in link
+
+There is whitespace at the beginning or the end of the contents of
+LE<lt>...E<gt>.
+
+=item * alternative text/node '%s' contains non-escaped | or /
+
+The characters C<|> and C</> are special in the LE<lt>...E<gt> context.
+Although the hyperlink parser does its best to determine which "/" is
+text and which is a delimiter in case of doubt, one ought to escape
+these literal characters like this:
+
+ / E<sol>
+ | E<verbar>
+
+=back
+
+Note that the line number of the error/warning may refer to the line number of
+the start of the paragraph in which the error/warning exists, not the line
+number that the error/warning is on. This bug is present in errors/warnings
+related to formatting codes. I<This should be fixed.>
+
+=head1 RETURN VALUE
+
+B<podchecker> returns the number of POD syntax errors found or -1 if
+there were no POD commands at all found in the file.
+
+=head1 EXAMPLES
+
+See L</SYNOPSIS>
+
+=head1 SCRIPTS
+
+The B<podchecker> script that comes with this distribution is a lean wrapper
+around this module. See the online manual with
+
+ podchecker -help
+ podchecker -man
+
+=head1 INTERFACE
+
+While checking, this module collects document properties, e.g. the nodes
+for hyperlinks (C<=headX>, C<=item>) and index entries (C<XE<lt>E<gt>>).
+POD translators can use this feature to syntax-check and get the nodes in
+a first pass before actually starting to convert. This is expensive in terms
+of execution time, but allows for very robust conversions.
+
+Since v1.24 the B<Pod::Checker> module uses only the B<poderror>
+method to print errors and warnings. The summary output (e.g.
+"Pod syntax OK") has been dropped from the module and has been included in
+B<podchecker> (the script). This allows users of B<Pod::Checker> to
+control completely the output behavior. Users of B<podchecker> (the script)
+get the well-known behavior.
+
+v1.45 inherits from Pod::Simple as opposed to all previous versions
+inheriting from Pod::Parser. Do B<not> use Pod::Simple's interface when
+using Pod::Checker unless it is documented somewhere on this page. I
+repeat, DO B<NOT> USE POD::SIMPLE'S INTERFACE.
+
+=cut
+
+#############################################################################
+
+#use diagnostics;
+use Carp qw(croak);
+use Exporter 'import';
+use base qw/Pod::Simple::Methody/;
+
+our @EXPORT = qw(&podchecker);
+
+##---------------------------------
+## Function definitions begin here
+##---------------------------------
+
+sub podchecker {
+ my ($infile, $outfile, %options) = @_;
+ local $_;
+
+ ## Set defaults
+ $infile ||= \*STDIN;
+ $outfile ||= \*STDERR;
+
+ ## Now create a pod checker
+ my $checker = Pod::Checker->new(%options);
+
+ ## Now check the pod document for errors
+ $checker->parse_from_file($infile, $outfile);
+
+ ## Return the number of errors found
+ return $checker->num_errors();
+}
+
+
+##---------------------------------------------------------------------------
+
+##-------------------------------
+## Method definitions begin here
+##-------------------------------
+
+##################################
+
+=over 4
+
+=item C<Pod::Checker-E<gt>new( %options )>
+
+Return a reference to a new Pod::Checker object that inherits from
+Pod::Simple and is used for calling the required methods later. The
+following options are recognized:
+
+C<-warnings =E<gt> num>
+ Print warnings if C<num> is true. The higher the value of C<num>,
+the more warnings are printed. Currently there are only levels 1 and 2.
+
+C<-quiet =E<gt> num>
+ If C<num> is true, do not print any errors/warnings. This is useful
+when Pod::Checker is used to munge POD code into plain text from within
+POD formatters.
+
+=cut
+
+sub new {
+ my $new = shift->SUPER::new(@_);
+ $new->{'output_fh'} ||= *STDERR{IO};
+
+ # Set options
+ my %opts = @_;
+ $new->{'-warnings'} = defined $opts{'-warnings'} ?
+ $opts{'-warnings'} : 1; # default on
+ $new->{'-quiet'} = $opts{'-quiet'} || 0; # default off
+
+ # Initialize number of errors/warnings
+ $new->{'_NUM_ERRORS'} = 0;
+ $new->{'_NUM_WARNINGS'} = 0;
+
+ # 'current' also means 'most recent' in the follow comments
+ $new->{'_thispara'} = ''; # current POD paragraph
+ $new->{'_line'} = 0; # current line number
+ $new->{'_head_num'} = 0; # current =head level (set to 0 to make
+ # logic easier down the road)
+ $new->{'_cmds_since_head'} = 0; # num of POD directives since prev. =headN
+ $new->{'_nodes'} = []; # stack for =head/=item nodes
+ $new->{'_fcode_stack'} = []; # stack for nested formatting codes
+ $new->{'_fcode_pos'} = []; # stack for position in paragraph of fcodes
+ $new->{'_begin_stack'} = []; # stack for =begins: [line #, target]
+ $new->{'_links'} = []; # stack for hyperlinks to external entities
+ $new->{'_internal_links'} = []; # set of linked-to internal sections
+ $new->{'_index'} = []; # stack for text in X<>s
+
+ $new->accept_targets('*'); # check all =begin/=for blocks
+ $new->cut_handler( \&handle_pod_and_cut ); # warn if text after =cut
+ $new->pod_handler( \&handle_pod_and_cut ); # warn if text after =pod
+ $new->whiteline_handler( \&handle_whiteline ); # warn if whiteline
+ $new->parse_empty_lists(1); # warn if they are empty
+
+ return $new;
+}
+
+##################################
+
+=item C<$checker-E<gt>poderror( @args )>
+
+=item C<$checker-E<gt>poderror( {%opts}, @args )>
+
+Internal method for printing errors and warnings. If no options are given,
+simply prints "@_". The following options are recognized and used to form
+the output:
+
+ -msg
+
+A message to print prior to C<@args>.
+
+ -line
+
+The line number the error occurred in.
+
+ -file
+
+The file (name) the error occurred in. Defaults to the name of the current
+file being processed.
+
+ -severity
+
+The error level, should be 'WARNING' or 'ERROR'.
+
+=cut
+
+# Invoked as $self->poderror( @args ), or $self->poderror( {%opts}, @args )
+sub poderror {
+ my $self = shift;
+ my %opts = (ref $_[0]) ? %{shift()} : ();
+
+ ## Retrieve options
+ chomp( my $msg = ($opts{'-msg'} || '')."@_" );
+ my $line = (exists $opts{'-line'}) ? " at line $opts{'-line'}" : '';
+ my $file = ' in file ' . ((exists $opts{'-file'})
+ ? $opts{'-file'}
+ : ((defined $self->source_filename)
+ ? $self->source_filename
+ : "???"));
+ unless (exists $opts{'-severity'}) {
+ ## See if can find severity in message prefix
+ $opts{'-severity'} = $1 if ( $msg =~ s/^\**\s*([A-Z]{3,}):\s+// );
+ }
+ my $severity = (exists $opts{'-severity'}) ? "*** $opts{-severity}: " : '';
+
+ ## Increment error count and print message "
+ ++($self->{'_NUM_ERRORS'})
+ if(!%opts || ($opts{-severity} && $opts{'-severity'} eq 'ERROR'));
+ ++($self->{'_NUM_WARNINGS'})
+ if(!%opts || ($opts{-severity} && $opts{'-severity'} eq 'WARNING'));
+ unless($self->{'-quiet'}) {
+ my $out_fh = $self->{'output_fh'} || \*STDERR;
+ print $out_fh ($severity, $msg, $line, $file, "\n")
+ if($self->{'-warnings'} || !%opts || $opts{'-severity'} ne 'WARNING');
+ }
+}
+
+##################################
+
+=item C<$checker-E<gt>num_errors()>
+
+Set (if argument specified) and retrieve the number of errors found.
+
+=cut
+
+sub num_errors {
+ return (@_ > 1) ? ($_[0]->{'_NUM_ERRORS'} = $_[1]) : $_[0]->{'_NUM_ERRORS'};
+}
+
+##################################
+
+=item C<$checker-E<gt>num_warnings()>
+
+Set (if argument specified) and retrieve the number of warnings found.
+
+=cut
+
+sub num_warnings {
+ return (@_ > 1) ? ($_[0]->{'_NUM_WARNINGS'} = $_[1]) :
+ $_[0]->{'_NUM_WARNINGS'};
+}
+
+##################################
+
+=item C<$checker-E<gt>name()>
+
+Set (if argument specified) and retrieve the canonical name of POD as
+found in the C<=head1 NAME> section.
+
+=cut
+
+sub name {
+ return (@_ > 1 && $_[1]) ?
+ ($_[0]->{'_pod_name'} = $_[1]) : $_[0]->{'_pod_name'};
+}
+
+##################################
+
+=item C<$checker-E<gt>node()>
+
+Add (if argument specified) and retrieve the nodes (as defined by C<=headX>
+and C<=item>) of the current POD. The nodes are returned in the order of
+their occurrence. They consist of plain text, each piece of whitespace is
+collapsed to a single blank.
+
+=cut
+
+sub node {
+ my ($self,$text) = @_;
+ if(defined $text) {
+ $text =~ s/\s+$//s; # strip trailing whitespace
+ $text =~ s/\s+/ /gs; # collapse whitespace
+ # add node, order important!
+ push(@{$self->{'_nodes'}}, $text);
+ # keep also a uniqueness counter
+ $self->{'_unique_nodes'}->{$text}++ if($text !~ /^\s*$/s);
+ return $text;
+ }
+ @{$self->{'_nodes'}};
+}
+
+##################################
+
+=item C<$checker-E<gt>idx()>
+
+Add (if argument specified) and retrieve the index entries (as defined by
+C<XE<lt>E<gt>>) of the current POD. They consist of plain text, each piece
+of whitespace is collapsed to a single blank.
+
+=cut
+
+# set/return index entries of current POD
+sub idx {
+ my ($self,$text) = @_;
+ if(defined $text) {
+ $text =~ s/\s+$//s; # strip trailing whitespace
+ $text =~ s/\s+/ /gs; # collapse whitespace
+ # add node, order important!
+ push(@{$self->{'_index'}}, $text);
+ # keep also a uniqueness counter
+ $self->{'_unique_nodes'}->{$text}++ if($text !~ /^\s*$/s);
+ return $text;
+ }
+ @{$self->{'_index'}};
+}
+
+##################################
+
+# add a hyperlink to the list of those of the current POD; returns current
+# list after the addition has been done
+sub hyperlink {
+ my $self = shift;
+ push(@{$self->{'_links'}}, $_[0]);
+ return $_[0];
+}
+
+=item C<$checker-E<gt>hyperlinks()>
+
+Retrieve an array containing the hyperlinks to things outside
+the current POD (as defined by C<LE<lt>E<gt>>).
+
+Each is an instance of a class with the following methods:
+
+=cut
+
+sub hyperlinks {
+ @{shift->{'_links'}};
+}
+
+##################################
+
+# override Pod::Simple's whine() and scream() to use poderror()
+
+# Note:
+# Ignore $self->{'no_whining'} b/c $self->{'quiet'} takes care of it in poderror
+# Don't bother incrementing $self->{'errors_seen'} -- it's not used
+# Don't bother pushing to $self->{'errata'} b/c poderror() outputs immediately
+# We don't need to set $self->no_errata_section(1) b/c of these overrides
+
+
+sub whine {
+ my ($self, $line, $complaint) = @_;
+
+ my $severity = 'ERROR';
+
+ if (0) {
+ # XXX: Let's standardize what's a warning and what's an error. Let's not
+ # move stuff up and down the severity tree. -- rjbs, 2013-04-12
+ # Convert errors in Pod::Simple that are warnings in Pod::Checker
+ # XXX Do differently so the $complaint can be reworded without this breaking
+ $severity = 'WARNING' if
+ $complaint =~ /^Expected '=item .+?'$/ ||
+ $complaint =~ /^You can't have =items \(as at line .+?\) unless the first thing after the =over is an =item$/ ||
+ $complaint =~ /^You have '=item .+?' instead of the expected '=item .+?'$/;
+ }
+
+ $self->poderror({ -line => $line,
+ -severity => $severity,
+ -msg => $complaint });
+
+ return 1; # assume everything is peachy keen
+}
+
+sub scream {
+ my ($self, $line, $complaint) = @_;
+
+ $self->poderror({ -line => $line,
+ -severity => 'ERROR', # consider making severity 'FATAL'
+ -msg => $complaint });
+
+ return 1;
+}
+
+
+##################################
+
+# Some helper subroutines
+
+sub _init_event { # assignments done at the start of most events
+ $_[0]{'_thispara'} = '';
+ $_[0]{'_line'} = $_[1]{'start_line'};
+ $_[0]{'_cmds_since_head'}++;
+}
+
+sub _check_fcode {
+ my ($self, $inner, $outers) = @_;
+ # Check for an fcode inside another of the same fcode
+ # XXX line number is the line of the start of the paragraph that the warning
+ # is in, not the line that the warning is on. Fix this
+
+ # Later versions of Pod::Simple forbid nested L<>'s
+ return if $inner eq 'L' && $Pod::Simple::VERSION ge '3.33';
+
+ if (grep { $_ eq $inner } @$outers) {
+ $self->poderror({ -line => $self->{'_line'},
+ -severity => 'WARNING',
+ -msg => "nested commands $inner<...$inner<...>...>"});
+ }
+}
+
+##################################
+
+sub handle_text { $_[0]{'_thispara'} .= $_[1] }
+
+# whiteline is a seemingly blank line that matches /[^\S\r\n]/
+sub handle_whiteline {
+ my ($line, $line_n, $self) = @_;
+ $self->poderror({
+ -line => $line_n,
+ -severity => 'WARNING',
+ -msg => 'line containing nothing but whitespace in paragraph'});
+}
+
+######## Directives
+sub handle_pod_and_cut {
+ my ($line, $line_n, $self) = @_;
+ $self->{'_cmds_since_head'}++;
+ if ($line =~ /=(pod|cut)\s+\S/) {
+ $self->poderror({ -line => $line_n,
+ -severity => 'ERROR',
+ -msg => "Spurious text after =$1"});
+ }
+}
+
+sub start_Para { shift->_init_event(@_); }
+sub end_Para {
+ my $self = shift;
+ # Get the NAME of the pod document
+ if ($self->{'_head_num'} == 1 && $self->{'_head_text'} eq 'NAME') {
+ if ($self->{'_thispara'} =~ /^\s*(\S+?)\s*[,-]/) {
+ $self->{'_pod_name'} = $1 unless defined $self->{'_pod_name'};
+ }
+ }
+}
+
+sub start_Verbatim {
+ my $self = shift;
+ $self->_init_event(@_);
+
+ if ($self->{'_head_num'} == 1 && $self->{'_head_text'} eq 'NAME') {
+ $self->poderror({ -line => $self->{'_line'},
+ -severity => 'WARNING',
+ -msg => 'Verbatim paragraph in NAME section' });
+ }
+}
+# Don't need an end_Verbatim
+
+# Do I need to do anything else with this?
+sub start_Data { shift->_init_event() }
+
+sub start_head1 { shift->start_head(1, @_) }
+sub start_head2 { shift->start_head(2, @_) }
+sub start_head3 { shift->start_head(3, @_) }
+sub start_head4 { shift->start_head(4, @_) }
+sub start_head {
+ my $self = shift;
+ my $h = shift;
+ $self->_init_event(@_);
+ my $prev_h = $self->{'_head_num'};
+ $self->{'_head_num'} = $h;
+ $self->{"_count_head$h"}++;
+
+ if ($h > 1 && !$self->{'_count_head'.($h-1)}) {
+ $self->poderror({ -line => $self->{'_line'},
+ -severity => 'WARNING',
+ -msg => "=head$h without preceding higher level"});
+ }
+
+ # If this is the first =head of the doc, $prev_h is 0, thus less than $h
+ if ($self->{'_cmds_since_head'} == 1 && $prev_h >= $h) {
+ $self->poderror({ -line => $self->{'_line'},
+ -severity => 'WARNING',
+ -msg => 'empty section in previous paragraph'});
+ }
+}
+
+sub end_head1 { shift->end_head(@_) }
+sub end_head2 { shift->end_head(@_) }
+sub end_head3 { shift->end_head(@_) }
+sub end_head4 { shift->end_head(@_) }
+sub end_head {
+ my $self = shift;
+ my $arg = $self->{'_thispara'};
+ $arg =~ s/\s+$//;
+ $self->{'_head_text'} = $arg;
+ $self->{'_cmds_since_head'} = 0;
+ my $h = $self->{'_head_num'};
+ $self->node($arg); # remember this node
+ if ($arg eq '') {
+ $self->poderror({ -line => $self->{'_line'},
+ -severity => 'ERROR',
+ -msg => "empty =head$h" });
+ }
+}
+
+sub start_over_bullet { shift->start_over(@_, 'bullet') }
+sub start_over_number { shift->start_over(@_, 'number') }
+sub start_over_text { shift->start_over(@_, 'definition') }
+sub start_over_block { shift->start_over(@_, 'block') }
+sub start_over_empty {
+ my $self = shift;
+ $self->start_over(@_, 'empty');
+ $self->poderror({ -line => $self->{'_line'},
+ -severity => 'WARNING',
+ -msg => 'empty =over/=back block' });
+}
+sub start_over {
+ my $self = shift;
+ my $type = pop;
+ $self->_init_event(@_);
+}
+
+sub start_item_bullet { shift->_init_event(@_) }
+sub start_item_number { shift->_init_event(@_) }
+sub start_item_text { shift->_init_event(@_) }
+sub end_item_bullet { shift->end_item('bullet') }
+sub end_item_number { shift->end_item('number') }
+sub end_item_text { shift->end_item('definition') }
+sub end_item {
+ my $self = shift;
+ my $type = shift;
+ # If there is verbatim text in this item, it will show up as part of
+ # 'paras', and not part of '_thispara'. If the first para after this is a
+ # verbatim one, it actually will be (part of) the contents for this item.
+ if ( $self->{'_thispara'} eq ''
+ && ( ! @{$self->{'paras'}}
+ || $self->{'paras'}[0][0] !~ /Verbatim/i))
+ {
+ $self->poderror({ -line => $self->{'_line'},
+ -severity => 'WARNING',
+ -msg => '=item has no contents' });
+ }
+
+ $self->node($self->{'_thispara'}); # remember this node
+}
+
+sub start_for { # =for and =begin directives
+ my ($self, $flags) = @_;
+ $self->_init_event($flags);
+ push @{$self->{'_begin_stack'}}, [$self->{'_line'}, $flags->{'target'}];
+}
+
+sub end_for {
+ my ($self, $flags) = @_;
+ my ($line, $target) = @{pop @{$self->{'_begin_stack'}}};
+ if ($flags->{'fake-closer'}) { # meaning Pod::Simple generated this =end
+ $self->poderror({ -line => $line,
+ -severity => 'ERROR',
+ -msg => "=begin $target without matching =end $target"
+ });
+ }
+}
+
+sub end_Document {
+ # Some final error checks
+ my $self = shift;
+
+ # no POD found here
+ $self->num_errors(-1) && return unless $self->content_seen;
+
+ my %nodes;
+ for ($self->node()) {
+ $nodes{$_} = 1;
+ if(/^(\S+)\s+\S/) {
+ # we have more than one word. Use the first as a node, too.
+ # This is used heavily in perlfunc.pod
+ $nodes{$1} ||= 2; # derived node
+ }
+ }
+ for ($self->idx()) {
+ $nodes{$_} = 3; # index node
+ }
+
+ # XXX update unresolved internal link POD -- single word not enclosed in ""?
+ # I don't know what I was thinking when I made the above TODO, and I don't
+ # know what it means...
+
+ for my $link (@{ $self->{'_internal_links'} }) {
+ my ($name, $line) = @$link;
+ unless ( $nodes{$name} ) {
+ $self->poderror({ -line => $line,
+ -severity => 'ERROR',
+ -msg => "unresolved internal link '$name'"});
+ }
+ }
+
+ # check the internal nodes for uniqueness. This pertains to
+ # =headX, =item and X<...>
+ if ($self->{'-warnings'} > 1 ) {
+ for my $node (sort keys %{ $self->{'_unique_nodes'} }) {
+ my $count = $self->{'_unique_nodes'}{$node};
+ if ($count > 1) { # not unique
+ $self->poderror({
+ -line => '-',
+ -severity => 'WARNING',
+ -msg => "multiple occurrences ($count) of link target ".
+ "'$node'"});
+ }
+ }
+ }
+}
+
+######## Formatting codes
+
+sub start_B { shift->start_fcode('B') }
+sub start_C { shift->start_fcode('C') }
+sub start_F { shift->start_fcode('F') }
+sub start_I { shift->start_fcode('I') }
+sub start_S { shift->start_fcode('S') }
+sub start_fcode {
+ my ($self, $fcode) = @_;
+ unshift @{$self->{'_fcode_stack'}}, $fcode;
+}
+
+sub end_B { shift->end_fcode() }
+sub end_C { shift->end_fcode() }
+sub end_F { shift->end_fcode() }
+sub end_I { shift->end_fcode() }
+sub end_S { shift->end_fcode() }
+sub end_fcode {
+ my $self = shift;
+ $self->_check_fcode(shift @{$self->{'_fcode_stack'}}, # current fcode removed
+ $self->{'_fcode_stack'}); # previous fcodes
+}
+
+sub start_L {
+ my ($self, $flags) = @_;
+ $self->start_fcode('L');
+
+ my $link = Pod::Checker::Hyperlink->new($flags, $self);
+ if ($link) {
+ if ( $link->type eq 'pod'
+ && $link->node
+ # It's an internal-to-this-page link if no page is given, or
+ # if the given one is to our NAME.
+ && (! $link->page || ( $self->{'_pod_name'}
+ && $link->page eq $self->{'_pod_name'})))
+ {
+ push @{ $self->{'_internal_links'} }, [ $link->{'-raw_node'}, $link->line ];
+ }
+ else {
+ $self->hyperlink($link);
+ }
+ }
+}
+
+sub end_L {
+ my $self = shift;
+ $self->end_fcode();
+}
+
+sub start_X {
+ my $self = shift;
+ $self->start_fcode('X');
+ # keep track of where X<> starts in the paragraph
+ # (this is a stack so nested X<>s are handled correctly)
+ push @{$self->{'_fcode_pos'}}, length $self->{'_thispara'};
+}
+sub end_X {
+ my $self = shift;
+ # extract contents of X<> and replace with ''
+ my $start = pop @{$self->{'_fcode_pos'}}; # start at the beginning of X<>
+ my $end = length($self->{'_thispara'}) - $start; # end at end of X<>
+ my $x = substr($self->{'_thispara'}, $start, $end, '');
+ if ($x eq "") {
+ $self->poderror({ -line => $self->{'_line'},
+ -severity => 'ERROR',
+ -msg => "An empty X<>" });
+ }
+ $self->idx($x); # remember this node
+ $self->end_fcode();
+}
+
+package Pod::Checker::Hyperlink;
+
+# This class is used to represent L<> link structures, so that the individual
+# elements are easily accessible. It is based on code in Pod::Hyperlink
+
+sub new {
+ my ($class,
+ $simple_link, # The link structure returned by Pod::Simple
+ $caller # The caller class
+ ) = @_;
+
+ my $self = +{};
+ bless $self, $class;
+
+ $self->{'-line'} ||= $caller->{'_line'};
+ $self->{'-type'} ||= $simple_link->{'type'};
+
+ # Force stringification of page and node. (This expands any E<>.)
+ $self->{'-page'} = exists $simple_link->{'to'} ? "$simple_link->{'to'}" : "";
+ $self->{'-node'} = exists $simple_link->{'section'} ? "$simple_link->{'section'}" : "";
+
+ # Save the unmodified node text, as the .t files are expecting the message
+ # for internal link failures to include it (hence this preserves backward
+ # compatibility).
+ $self->{'-raw_node'} = $self->{'-node'};
+
+ # Remove leading/trailing white space. Pod::Simple already warns about
+ # these, so if the only error is this, and the link is otherwise correct,
+ # only the Pod::Simple warning will be output, avoiding unnecessary
+ # confusion.
+ $self->{'-page'} =~ s/ ^ \s+ //x;
+ $self->{'-page'} =~ s/ \s+ $ //x;
+
+ $self->{'-node'} =~ s/ ^ \s+ //x;
+ $self->{'-node'} =~ s/ \s+ $ //x;
+
+ # Pod::Simple warns about L<> and L< >, but not L</>
+ if ($self->{'-page'} eq "" && $self->{'-node'} eq "") {
+ $caller->poderror({ -line => $caller->{'_line'},
+ -severity => 'WARNING',
+ -msg => 'empty link'});
+ return;
+ }
+
+ return $self;
+}
+
+=item line()
+
+Returns the approximate line number in which the link was encountered
+
+=cut
+
+sub line {
+ return $_[0]->{-line};
+}
+
+=item type()
+
+Returns the type of the link; one of:
+C<"url"> for things like
+C<http://www.foo>, C<"man"> for man pages, or C<"pod">.
+
+=cut
+
+sub type {
+ return $_[0]->{-type};
+}
+
+=item page()
+
+Returns the linked-to page or url.
+
+=cut
+
+sub page {
+ return $_[0]->{-page};
+}
+
+=item node()
+
+Returns the anchor or node within the linked-to page, or an empty string
+(C<"">) if none appears in the link.
+
+=back
+
+=cut
+
+sub node {
+ return $_[0]->{-node};
+}
+
+=head1 AUTHOR
+
+Please report bugs using L<http://rt.cpan.org>.
+
+Brad Appleton E<lt>bradapp@enteract.comE<gt> (initial version),
+Marek Rouchal E<lt>marekr@cpan.orgE<gt>,
+Marc Green E<lt>marcgreen@cpan.orgE<gt> (port to Pod::Simple)
+Ricardo Signes E<lt>rjbs@cpan.orgE<gt> (more porting to Pod::Simple)
+Karl Williamson E<lt>khw@cpan.orgE<gt> (more porting to Pod::Simple)
+
+Based on code for B<Pod::Text::pod2text()> written by
+Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
+
+=cut
+
+1
-#!/usr/local/bin/perl\r
-\r
-use Config;\r
-use File::Basename qw(&basename &dirname);\r
-use Cwd;\r
-\r
-# List explicitly here the variables you want Configure to\r
-# generate. Metaconfig only looks for shell variables, so you\r
-# have to mention them as if they were shell variables, not\r
-# %Config entries. Thus you write\r
-# $startperl\r
-# to ensure Configure will look for $Config{startperl}.\r
-\r
-# This forces PL files to create target in same directory as PL file.\r
-# This is so that make depend always knows where to find PL derivatives.\r
-$origdir = cwd;\r
-chdir(dirname($0));\r
-($file = basename($0)) =~ s/\.PL$//;\r
-$file =~ s/\.pl$//\r
- if ($^O eq 'VMS' or $^O eq 'os2' or $^O eq 'dos'); # "case-forgiving"\r
-$file .= '.com' if $^O eq 'VMS';\r
-\r
-open OUT,">$file" or die "Can't create $file: $!";\r
-\r
-print "Extracting $file (with variable substitutions)\n";\r
-\r
-# In this section, perl variables will be expanded during extraction.\r
-# You can use $Config{...} to use Configure variables.\r
-\r
-print OUT <<"!GROK!THIS!";\r
-$Config{'startperl'}\r
- eval 'exec perl -S \$0 "\$@"'\r
- if 0;\r
-!GROK!THIS!\r
-\r
-# In the following, perl variables are not expanded during extraction.\r
-\r
-print OUT <<'!NO!SUBS!';\r
-#############################################################################\r
-# podchecker -- command to invoke the podchecker function in Pod::Checker\r
-#\r
-# Copyright (c) 1998-2000 by Bradford Appleton. All rights reserved.\r
-# This file is part of "PodParser". PodParser is free software;\r
-# you can redistribute it and/or modify it under the same terms\r
-# as Perl itself.\r
-#############################################################################\r
-\r
-use strict;\r
-#use diagnostics;\r
-\r
-=head1 NAME\r
-\r
-podchecker - check the syntax of POD format documentation files\r
-\r
-=head1 SYNOPSIS\r
-\r
-B<podchecker> [B<-help>] [B<-man>] [B<-(no)warnings>] [I<file>S< >...]\r
-\r
-=head1 OPTIONS AND ARGUMENTS\r
-\r
-=over 8\r
-\r
-=item B<-help>\r
-\r
-Print a brief help message and exit.\r
-\r
-=item B<-man>\r
-\r
-Print the manual page and exit.\r
-\r
-=item B<-warnings> B<-nowarnings>\r
-\r
-Turn on/off printing of warnings. Repeating B<-warnings> increases the\r
-warning level, i.e. more warnings are printed. Currently increasing to\r
-level two causes flagging of unescaped "E<lt>,E<gt>" characters.\r
-\r
-=item I<file>\r
-\r
-The pathname of a POD file to syntax-check (defaults to standard input).\r
-\r
-=back\r
-\r
-=head1 DESCRIPTION\r
-\r
-B<podchecker> will read the given input files looking for POD\r
-syntax errors in the POD documentation and will print any errors\r
-it find to STDERR. At the end, it will print a status message\r
-indicating the number of errors found.\r
-\r
-Directories are ignored, an appropriate warning message is printed.\r
-\r
-B<podchecker> invokes the B<podchecker()> function exported by B<Pod::Checker>\r
-Please see L<Pod::Checker/podchecker()> for more details.\r
-\r
-=head1 RETURN VALUE\r
-\r
-B<podchecker> returns a 0 (zero) exit status if all specified\r
-POD files are ok.\r
-\r
-=head1 ERRORS\r
-\r
-B<podchecker> returns the exit status 1 if at least one of\r
-the given POD files has syntax errors.\r
-\r
-The status 2 indicates that at least one of the specified \r
-files does not contain I<any> POD commands.\r
-\r
-Status 1 overrides status 2. If you want unambiguous\r
-results, call B<podchecker> with one single argument only.\r
-\r
-=head1 SEE ALSO\r
-\r
-L<Pod::Parser> and L<Pod::Checker>\r
-\r
-=head1 AUTHORS\r
-\r
-Please report bugs using L<http://rt.cpan.org>.\r
-\r
-Brad Appleton E<lt>bradapp@enteract.comE<gt>,\r
-Marek Rouchal E<lt>marekr@cpan.orgE<gt>\r
-\r
-Based on code for B<Pod::Text::pod2text(1)> written by\r
-Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>\r
-\r
-=cut\r
-\r
-\r
-use Pod::Checker;\r
-use Pod::Usage;\r
-use Getopt::Long;\r
-\r
-## Define options\r
-my %options;\r
-\r
-## Parse options\r
-GetOptions(\%options, qw(help man warnings+ nowarnings)) || pod2usage(2);\r
-pod2usage(1) if ($options{help});\r
-pod2usage(-verbose => 2) if ($options{man});\r
-\r
-if($options{nowarnings}) {\r
- $options{warnings} = 0;\r
-}\r
-elsif(!defined $options{warnings}) {\r
- $options{warnings} = 1; # default is warnings on\r
-}\r
-\r
-## Dont default to STDIN if connected to a terminal\r
-pod2usage(2) if ((@ARGV == 0) && (-t STDIN));\r
-\r
-## Invoke podchecker()\r
-my $status = 0;\r
-@ARGV = qw(-) unless(@ARGV);\r
-for my $podfile (@ARGV) {\r
- if($podfile eq '-') {\r
- $podfile = '<&STDIN';\r
- }\r
- elsif(-d $podfile) {\r
- warn "podchecker: Warning: Ignoring directory '$podfile'\n";\r
- next;\r
- }\r
- my $errors =\r
- podchecker($podfile, undef, '-warnings' => $options{warnings});\r
- if($errors > 0) {\r
- # errors occurred\r
- $status = 1;\r
- printf STDERR ("%s has %d pod syntax %s.\n",\r
- $podfile, $errors,\r
- ($errors == 1) ? 'error' : 'errors');\r
- }\r
- elsif($errors < 0) {\r
- # no pod found\r
- $status = 2 unless($status);\r
- print STDERR "$podfile does not contain any pod commands.\n";\r
- }\r
- else {\r
- print STDERR "$podfile pod syntax OK.\n";\r
- }\r
-}\r
-exit $status;\r
-\r
-!NO!SUBS!\r
-\r
-close OUT or die "Can't close $file: $!";\r
-chmod 0755, $file or die "Can't reset permissions for $file: $!\n";\r
-exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';\r
-chdir $origdir;\r
+#!/usr/local/bin/perl
+
+use Config;
+use File::Basename qw(&basename &dirname);
+use Cwd;
+
+# List explicitly here the variables you want Configure to
+# generate. Metaconfig only looks for shell variables, so you
+# have to mention them as if they were shell variables, not
+# %Config entries. Thus you write
+# $startperl
+# to ensure Configure will look for $Config{startperl}.
+
+# This forces PL files to create target in same directory as PL file.
+# This is so that make depend always knows where to find PL derivatives.
+$origdir = cwd;
+chdir(dirname($0));
+($file = basename($0)) =~ s/\.PL$//;
+$file =~ s/\.pl$//
+ if ($^O eq 'VMS' or $^O eq 'os2' or $^O eq 'dos'); # "case-forgiving"
+$file .= '.com' if $^O eq 'VMS';
+
+open OUT,">$file" or die "Can't create $file: $!";
+
+print "Extracting $file (with variable substitutions)\n";
+
+# In this section, perl variables will be expanded during extraction.
+# You can use $Config{...} to use Configure variables.
+
+print OUT <<"!GROK!THIS!";
+$Config{'startperl'}
+ eval 'exec perl -S \$0 "\$@"'
+ if 0;
+!GROK!THIS!
+
+# In the following, perl variables are not expanded during extraction.
+
+print OUT <<'!NO!SUBS!';
+#############################################################################
+# podchecker -- command to invoke the podchecker function in Pod::Checker
+#
+# Copyright (c) 1998-2000 by Bradford Appleton. All rights reserved.
+# This is free software; you can redistribute it and/or modify it under the
+# same terms as Perl itself.
+#############################################################################
+
+use strict;
+#use diagnostics;
+
+=head1 NAME
+
+podchecker - check the syntax of POD format documentation files
+
+=head1 SYNOPSIS
+
+B<podchecker> [B<-help>] [B<-man>] [B<-(no)warnings>] [I<file>S< >...]
+
+=head1 OPTIONS AND ARGUMENTS
+
+=over 8
+
+=item B<-help>
+
+Print a brief help message and exit.
+
+=item B<-man>
+
+Print the manual page and exit.
+
+=item B<-warnings> B<-nowarnings>
+
+Turn on/off printing of warnings. Repeating B<-warnings> increases the
+warning level, i.e. more warnings are printed. Currently increasing to
+level two causes flagging of unescaped "E<lt>,E<gt>" characters.
+
+=item I<file>
+
+The pathname of a POD file to syntax-check (defaults to standard input).
+
+=back
+
+=head1 DESCRIPTION
+
+B<podchecker> will read the given input files looking for POD
+syntax errors in the POD documentation and will print any errors
+it find to STDERR. At the end, it will print a status message
+indicating the number of errors found.
+
+Directories are ignored, an appropriate warning message is printed.
+
+B<podchecker> invokes the B<podchecker()> function exported by B<Pod::Checker>
+Please see L<Pod::Checker/podchecker()> for more details.
+
+=head1 RETURN VALUE
+
+B<podchecker> returns a 0 (zero) exit status if all specified
+POD files are ok.
+
+=head1 ERRORS
+
+B<podchecker> returns the exit status 1 if at least one of
+the given POD files has syntax errors.
+
+The status 2 indicates that at least one of the specified
+files does not contain I<any> POD commands.
+
+Status 1 overrides status 2. If you want unambiguous
+results, call B<podchecker> with one single argument only.
+
+=head1 SEE ALSO
+
+L<Pod::Simple> and L<Pod::Checker>
+
+=head1 AUTHORS
+
+Please report bugs using L<http://rt.cpan.org>.
+
+Brad Appleton E<lt>bradapp@enteract.comE<gt>,
+Marek Rouchal E<lt>marekr@cpan.orgE<gt>
+
+Based on code for B<Pod::Text::pod2text(1)> written by
+Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
+
+=cut
+
+
+use Pod::Checker;
+use Pod::Usage;
+use Getopt::Long;
+
+## Define options
+my %options;
+
+## Parse options
+GetOptions(\%options, qw(help man warnings+ nowarnings)) || pod2usage(2);
+pod2usage(1) if ($options{help});
+pod2usage(-verbose => 2) if ($options{man});
+
+if($options{nowarnings}) {
+ $options{warnings} = 0;
+}
+elsif(!defined $options{warnings}) {
+ $options{warnings} = 1; # default is warnings on
+}
+
+## Dont default to STDIN if connected to a terminal
+pod2usage(2) if ((@ARGV == 0) && (-t STDIN));
+
+## Invoke podchecker()
+my $status = 0;
+@ARGV = qw(-) unless(@ARGV);
+for my $podfile (@ARGV) {
+ if($podfile eq '-') {
+ $podfile = '<&STDIN';
+ }
+ elsif(-d $podfile) {
+ warn "podchecker: Warning: Ignoring directory '$podfile'\n";
+ next;
+ }
+ my $errors =
+ podchecker($podfile, undef, '-warnings' => $options{warnings});
+ if($errors > 0) {
+ # errors occurred
+ $status = 1;
+ printf STDERR ("%s has %d pod syntax %s.\n",
+ $podfile, $errors,
+ ($errors == 1) ? 'error' : 'errors');
+ }
+ elsif($errors < 0) {
+ # no pod found
+ $status = 2 unless($status);
+ print STDERR "$podfile does not contain any pod commands.\n";
+ }
+ else {
+ print STDERR "$podfile pod syntax OK.\n";
+ }
+}
+exit $status;
+
+!NO!SUBS!
+
+close OUT or die "Can't close $file: $!";
+chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
+exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
+chdir $origdir;
-=head foo\r
-\r
-bar baz.\r
-\r
-=cut\r
+=head foo
+
+bar baz.
+
+=cut
-#!/usr/bin/perl\r
-BEGIN {\r
- use File::Basename;\r
- my $THISDIR = dirname $0;\r
- unshift @INC, $THISDIR;\r
- require "testpchk.pl";\r
- import TestPodChecker;\r
-}\r
-\r
-# this tests Pod::Checker accepts =encoding directive\r
-\r
-my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash\r
-my $passed = testpodchecker \%options, $0;\r
-exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE};\r
-\r
-__END__\r
-\r
-=encoding utf8\r
-\r
-=encode utf8\r
-\r
-dummy error\r
-\r
-=head1 An example.\r
-\r
-'Twas brillig, and the slithy toves did gyre and gimble in the wabe.\r
-\r
-=cut\r
-\r
+#!/usr/bin/perl
+BEGIN {
+ use File::Basename;
+ my $THISDIR = dirname $0;
+ unshift @INC, $THISDIR;
+ require "testpchk.pl";
+ import TestPodChecker;
+}
+
+# this tests Pod::Checker accepts =encoding directive
+
+my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash
+my $passed = testpodchecker \%options, $0;
+exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE};
+
+__END__
+
+=encoding utf8
+
+=encode utf8
+
+dummy error
+
+=head1 An example.
+
+'Twas brillig, and the slithy toves did gyre and gimble in the wabe.
+
+=cut
+
-*** ERROR: Unknown command 'encode' at line 20 in file t/pod/podchkenc.t\r
+*** ERROR: Unknown directive: =encode at line 20 in file t/pod/podchkenc.t
--- /dev/null
+#!/usr/bin/perl
+
+# This tests Pod::Checker::Hyperlink
+
+use Test::More;
+use Pod::Checker;
+
+my @answers = (
+ {
+ 'line' => 12,
+ 'node' => 'section',
+ 'page' => 'manpage',
+ 'type' => 'pod'
+ },
+ {
+ 'line' => 14,
+ 'node' => 'section',
+ 'page' => '"manpage"',
+ 'type' => 'pod',
+ },
+ {
+ 'line' => 16,
+ 'node' => 'section',
+ 'page' => 'manpage',
+ 'type' => 'pod',
+ },
+ {
+ 'line' => 20,
+ 'node' => 'section',
+ 'page' => 'manpage',
+ 'type' => 'pod',
+ },
+ {
+ 'line' => 22,
+ 'node' => 'section',
+ 'page' => 'manpage',
+ 'type' => 'pod',
+ },
+ {
+ 'line' => 24,
+ 'node' => 'section',
+ 'page' => 'manpage',
+ 'type' => 'pod',
+ },
+ {
+ 'line' => 26,
+ 'node' => 'section',
+ 'page' => 'manpage',
+ 'type' => 'pod',
+ },
+ {
+ 'line' => 28,
+ 'node' => 'section',
+ 'page' => 'manpage',
+ 'type' => 'pod',
+ },
+ {
+ 'line' => 30,
+ 'node' => 'section',
+ 'page' => 'manpage',
+ 'type' => 'pod',
+ },
+ {
+ 'line' => 36,
+ 'node' => '',
+ 'page' => 'foo',
+ 'type' => 'pod',
+ },
+ {
+ 'line' => 38,
+ 'node' => '',
+ 'page' => 'bar',
+ 'type' => 'pod'
+ },
+ {
+ 'line' => 40,
+ 'node' => 'bar',
+ 'page' => 'foo',
+ 'type' => 'pod'
+ },
+ {
+ 'line' => 42,
+ 'node' => 'baz boo',
+ 'page' => 'foo',
+ 'type' => 'pod'
+ },
+ {
+ 'line' => 50,
+ 'node' => 'baz boo',
+ 'page' => 'foo bar',
+ 'type' => 'pod',
+ },
+ {
+ 'line' => 59,
+ 'node' => '',
+ 'page' => 'foobar',
+ 'type' => 'pod',
+ },
+ {
+ 'line' => 61,
+ 'node' => 'bar',
+ 'page' => 'foo',
+ 'type' => 'pod'
+ },
+ {
+ 'line' => 63,
+ 'node' => 'Italic text',
+ 'page' => 'foo',
+ 'type' => 'pod'
+ },
+ {
+ 'line' => 65,
+ 'node' => 'Section with other markup',
+ 'page' => 'foo|bar',
+ 'type' => 'pod',
+ },
+ {
+ 'line' => 67,
+ 'node' => '',
+ 'page' => 'chmod',
+ 'type' => 'pod',
+ },
+ {
+ 'line' => 69,
+ 'node' => '',
+ 'page' => 'chmod(2)',
+ 'type' => 'man',
+ },
+ {
+ 'line' => 71,
+ 'node' => '',
+ 'page' => 'chmod(2)',
+ 'type' => 'man',
+ },
+ {
+ 'line' => 73,
+ 'node' => '',
+ 'page' => 'chmod()',
+ 'type' => 'pod',
+ },
+ {
+ 'line' => 75,
+ 'node' => '',
+ 'page' => 'mailto:foo@cpan.org',
+ 'type' => 'url',
+ },
+ {
+ 'line' => 77,
+ 'node' => '',
+ 'page' => 'mailto:foo@cpan.org',
+ 'type' => 'url',
+ },
+ {
+ 'line' => 79,
+ 'node' => '',
+ 'page' => 'http://www.perl.org',
+ 'type' => 'url',
+ },
+ {
+ 'line' => 81,
+ 'node' => '',
+ 'page' => 'http://www.perl.org',
+ 'type' => 'url',
+ },
+ );
+
+plan 'tests' => @answers * 4 + 2;
+
+my $checker = Pod::Checker->new( '-quiet' => 1);
+$checker->parse_from_file(\*DATA);
+
+is($checker->num_warnings, 0, "There were no warnings found");
+is($checker->num_errors, 0, "There were no errors found");
+
+my @links = $checker->hyperlinks;
+
+for my $i (0 .. @links - 1) {
+ is($links[$i]->line(), $answers[$i]->{'line'}, "line() returns '$answers[$i]->{'line'}' correctly");
+ is($links[$i]->node(), $answers[$i]->{'node'}, "node() returns '$answers[$i]->{'node'}' correctly");
+ is($links[$i]->page(), $answers[$i]->{'page'}, "page() returns '$answers[$i]->{'page'}' correctly");
+ is($links[$i]->type(), $answers[$i]->{'type'}, "type() returns '$answers[$i]->{'type'}' correctly");
+}
+
+__END__
+
+=head1 NAME
+
+basic.pod - Extracted and expanded from podlators; test various link types
+
+=head1 LINKS
+
+These are all taken from the Pod::Parser tests.
+
+Try out I<LOTS> of different ways of specifying references:
+
+Reference the L<manpage/section>
+
+Reference the L<"manpage"/section>
+
+Reference the L<manpage/"section">
+
+Now try it using the new "|" stuff ...
+
+Reference the L<thistext|manpage/section>|
+
+Reference the L<thistext | manpage / section>|
+
+Reference the L<thistext| manpage/ section>|
+
+Reference the L<thistext |manpage /section>|
+
+Reference the L<thistext|manpage/"section">|
+
+Reference the L<thistext|
+manpage/
+section>|
+
+And then throw in a few new ones of my own.
+
+L<foo>
+
+L<foo|bar>
+
+L<foo/bar>
+
+L<foo/"baz boo">
+
+L</bar> won't show up because is a link to this page
+
+L</"baz boo"> won't show up because is a link to this page
+
+L</baz boo> won't show up because is a link to this page
+
+L<foo bar/baz boo>
+
+L<"boo var baz"> won't show up because the quotes make it a link to this page
+
+L<bar baz> won't show up because of blanks (deprecated) make it a link to this
+page
+
+L</boo>, L</bar>, and L</baz> won't show up because are links to this page
+
+L<fooZ<>bar>
+
+L<Testing I<italics>|foo/bar>
+
+L<foo/I<Italic> text>
+
+L<fooE<verbar>barZ<>/Section C<with> I<B<other> markup>>
+
+L<chmod>
+
+L<chmod(2)>
+
+L<man page with text|chmod(2)>
+
+L<chmod()>
+
+L<mailto:foo@cpan.org>
+
+L<Don't email us|mailto:foo@cpan.org>
+
+L<http://www.perl.org>
+
+L<hyperlink|http://www.perl.org>
+
+=head1 bar
+
+=head2 baz boo
+
+=head3 boo var baz
+
+=head4 bar baz
+
+=cut
-BEGIN {\r
- use File::Basename;\r
- my $THISDIR = dirname $0;\r
- unshift @INC, $THISDIR;\r
- require "testpchk.pl";\r
- import TestPodChecker;\r
-}\r
-\r
-my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash\r
-my $passed = testpodchecker \%options, $0;\r
-exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE};\r
-\r
-### Deliberately throw in some blank but non-empty lines\r
- \r
-### The above line should contain spaces\r
-\r
-\r
-__END__\r
-\r
-=head2 This should cause a warning\r
-\r
-=head1 NAME\r
-\r
-poderrors.t - test Pod::Checker on some pod syntax errors\r
-\r
-=unknown1 this is an unknown command with two N<unknownA>\r
-and D<unknownB> interior sequences.\r
-\r
-This is some paragraph text with some unknown interior sequences,\r
-such as Q<unknown2>,\r
-A<unknown3>,\r
-and Y<unknown4 V<unknown5>>.\r
-\r
-Now try some unterminated sequences like\r
-I<hello mudda!\r
-B<hello fadda!\r
-\r
-Here I am at C<camp granada!\r
-\r
-Camps is very,\r
-entertaining.\r
-And they say we'll have some fun if it stops raining!\r
-\r
-Okay, now use a non-empty blank line to terminate a paragraph and make\r
-sure we get a warning.\r
- \r
-The above blank line contains tabs and spaces only\r
-\r
-=head1 Additional tests\r
-\r
-=head2 item without over\r
-\r
-=item oops\r
-\r
-=head2 back without over\r
-\r
-=back\r
-\r
-=head2 over without back\r
-\r
-=over 4\r
-\r
-=item aaps\r
-\r
-=head2 end without begin\r
-\r
-=end\r
-\r
-=head2 begin and begin\r
-\r
-=begin html\r
-\r
-=begin text\r
-\r
-=end\r
-\r
-=end\r
-\r
-second one results in end w/o begin\r
-\r
-=head2 begin w/o formatter\r
-\r
-=begin\r
-\r
-=end\r
-\r
-=head2 for w/o formatter\r
-\r
-=for\r
-\r
-something...\r
-\r
-=head2 Nested sequences of the same type\r
-\r
-C<code I<italic C<code again!>>>\r
-\r
-=head2 Garbled entities\r
-\r
-E<alea iacta est>\r
-E<C<auml>>\r
-E<abcI<bla>>\r
-E<0x100>\r
-E<07777>\r
-E<300>\r
-\r
-=head2 Unresolved internal links\r
-\r
-L</"begin or begin">\r
-L<"end with begin">\r
-L</OoPs>\r
-\r
-=head2 Some links with problems\r
-\r
-L<abc\r
-def>\r
-L<>\r
-L< aha>\r
-L<oho >\r
-L<"Warnings"> this one is ok\r
-L</unescaped> ok too, this POD has an X of the same name\r
-L<http://www.perl.org> this is OK\r
-L<The Perl Home Page|http://www.perl.org> this is also OK\r
-\r
-=head2 Warnings\r
-\r
-L<passwd(5)>\r
-L<some text with / in it|perlvar/$|> should give warnings as hell\r
-\r
-=over 4\r
-\r
-=item bla\r
-\r
-=back 200\r
-\r
-the 200 is evil\r
-\r
-=begin html\r
-\r
-What?\r
-\r
-=end xml\r
-\r
-X<unescaped>see these unescaped < and > in the text?\r
-\r
-=head2 Misc\r
-\r
-Z<ddd> should be empty\r
-\r
-X<> should not be empty\r
-\r
-=over four\r
-\r
-This paragrapgh is misplaced - it ought to be an item.\r
-\r
-=item four should be numeric!\r
-\r
-=item\r
-\r
-=item blah\r
-\r
-=item previous is all empty!!!\r
-\r
-=back\r
-\r
-All empty over/back:\r
-\r
-=over 4\r
-\r
-=back\r
-\r
-item w/o name\r
-\r
-=cut\r
-\r
-=pod bla\r
-\r
-bla is evil\r
-\r
-=cut blub\r
-\r
-blub is evil\r
-\r
-=head2 reoccurence\r
-\r
-=over 4\r
-\r
-=item Misc\r
-\r
-we already have a head Misc\r
-\r
-=back\r
-\r
-=head2 some heading\r
-\r
-=head2 another one\r
-\r
-=head2 the next line should be empty\r
-=head2 ... but there is a command instead\r
-\r
-And here is some text\r
-=head2 again followed by a command\r
-\r
- verbatim\r
-=item line missing\r
-\r
-previous section is empty!\r
-\r
-=head1 LINK TESTS\r
-\r
-Due to bug reported by Rafael Garcia-Suarez "rgarciasuarez@free.fr":\r
-\r
-The following hyperlinks :\r
-L<"I/O Operators">\r
-L<perlop/"I/O Operators">\r
-trigger a podchecker warning (using bleadperl) :\r
- node 'I/O Operators' contains non-escaped | or /\r
-\r
-=cut\r
-\r
-=pod\r
-\r
-=head1 ON-OFF tests\r
-\r
-The above =pod is OK. The following =cut is ok, the one after not.\r
-\r
-=cut\r
-\r
-# some comment or code here, not POD\r
-\r
-=cut\r
-\r
-# more code\r
-\r
-=head2 This opens POD\r
-\r
-=pod\r
-\r
-And the =pod above is too much.\r
-\r
-=cut\r
-\r
+BEGIN {
+ use File::Basename;
+ my $THISDIR = dirname $0;
+ unshift @INC, $THISDIR;
+ require "testpchk.pl";
+ import TestPodChecker;
+}
+
+my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash
+my $passed = testpodchecker \%options, $0;
+exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE};
+
+### Deliberately throw in some blank but non-empty lines
+
+### The above line should contain spaces
+
+#line 18
+__END__
+
+=head2 This should cause a warning
+
+=head1 NAME
+
+poderrors.t - test Pod::Checker on some pod syntax errors
+
+ GASP! A verbatim paragraph in NAME
+
+=unknown1 this is an unknown command with two N<unknownA>
+and D<unknownB> interior sequences.
+
+This is some paragraph text with some unknown interior sequences,
+such as Q<unknown2>,
+A<unknown3>,
+and Y<unknown4 V<unknown5>>.
+
+Now try some unterminated sequences like
+I<hello mudda!
+B<hello fadda!
+
+Here I am at C<camp granada!
+
+Camps is very,
+entertaining.
+And they say we'll have some fun if it stops raining!
+
+Okay, now use a non-empty blank line to terminate a paragraph and make
+sure we get a warning.
+
+The above blank line contains tabs and spaces only
+
+F<Many B<fcodes B<inside C<other I<fcodes F<inside I<many S<many C<more X<fcodes. S<This is X<ridiculous.>>>>>>>>>>>>
+
+A L<link|perlvar/$/> to L<perlvar/$E<sol>>
+
+=head1 Additional tests
+
+=head2 item without over
+
+=item oops
+
+=head2 back without over
+
+=back
+
+=head2 over without back
+
+=over 4
+
+=item aaps
+
+=head2 end without begin
+
+=end
+
+=end something
+
+=head2 begin and begin
+
+=begin html
+
+=begin text
+
+=end text
+
+=end html
+
+=head2 begin w/o formatter
+
+=begin
+
+=end
+
+=head2 for w/o formatter
+
+=for
+
+something...
+
+=head2 Nested sequences of the same type
+
+C<code I<italic C<code again!>>>
+
+=head2 Garbled entities
+
+E<alea iacta est>
+E<C<auml>>
+E<abcI<bla>>
+E<0x100>
+E<07777>
+E<300>
+E<unknown_entity>
+
+=head2 Unresolved internal links
+
+L</"begin or begin">
+L<"end with begin">
+L</OoPs>
+
+=head2 Some links with problems
+
+L<abc
+def>
+L<>
+L< aha>
+L<oho >
+L< weehee >
+L<"Warnings"> this one is ok
+L</unescaped> ok too, this POD has an X of the same name
+
+L<< lead >>
+L<< trail >>
+L<< neither >>
+L<<< both >>>
+
+L<<<<>>>>
+
+L<<<< >>>>
+
+L<<<< >>>>
+
+=head2 Warnings
+
+L<passwd(5)>
+L<some text with / in it|perlvar/$|> should give warnings as hell
+
+=over 4
+
+=item bla
+
+=back 200
+
+the 200 is evil
+
+X<unescaped>see these unescaped < and > in the text?
+
+=head2 Misc
+
+Z<ddd> should be empty
+
+X<> should not be empty
+
+X<0> should not generate a warning about being empty
+
+E<> should not be empty
+
+=over four
+
+This paragrapgh is misplaced - it ought to be an item.
+
+=item four should be numeric!
+
+=back
+
+=over 4
+
+=item
+
+=item blah
+
+=item previous is all empty!!!
+
+=back
+
+=over
+
+ This verbatim paragraph should not be here. Spaces are on the line below this
+
+=item *
+
+bullet
+
+=item 1
+
+number, uh oh
+
+=back
+
+=over
+
+=item *
+
+first bullet
+
+=item 1
+
+then number
+
+=item finally definition
+
+=back
+
+=over
+
+=item 1
+
+first number
+
+=item 3
+
+bad numbering
+
+=item then definition
+
+=item *
+
+finally bullet
+
+=back
+
+=over
+
+=item first defintion
+
+=item *
+
+then bullet
+
+=item 1
+
+finally number
+
+=item second definition
+
+ This should not generate an empty =item warning,
+ because it has verbatim text.
+
+=back
+
+Empty over/back:
+
+=over 4
+
+=over 2
+
+=back
+
+=back
+
+item w/o name
+
+=cut
+
+=pod bla
+
+bla is evil
+
+=cut blub
+
+blub is evil
+
+=head2 reoccurence
+
+=over 4
+
+=item Misc
+
+we already have a head Misc
+
+=back
+
+=head2 some heading
+
+=head2 another one
+
+previous section is empty!
+
+=head1 LINK TESTS
+
+
+
+
+
+
+
+
+
+
+L<perlop/"I/O Operators">
+don't trigger a warning because node is quoted
+
+L<"I/O Operators">
+incorrectly interpreted as 'O Operators in I', but this is deprecated syntax, as per perlpodspec.
+no warning due to quotes
+
+=head1
+
+Empty head above and unclosed over/begins below
+
+=head3 test X<stuff> I<test>
+
+=over
+
+=begin html
+
+What?
+
+=begin :xml
+
+L<This pod's NAME in a link means it is internal|poderrors.t/link_to_nowhere>,
+so should generate a warning
+
+=cut
+
+
-*** WARNING: =head2 without preceding higher level at line 20 in file t/pod/poderrs.t\r
-*** WARNING: empty section in previous paragraph at line 22 in file t/pod/poderrs.t\r
-*** ERROR: Unknown command 'unknown1' at line 26 in file t/pod/poderrs.t\r
-*** ERROR: Unknown interior-sequence 'Q' at line 30 in file t/pod/poderrs.t\r
-*** ERROR: Unknown interior-sequence 'A' at line 31 in file t/pod/poderrs.t\r
-*** ERROR: Unknown interior-sequence 'Y' at line 32 in file t/pod/poderrs.t\r
-*** ERROR: Unknown interior-sequence 'V' at line 32 in file t/pod/poderrs.t\r
-*** ERROR: unterminated B<...> at line 36 in file t/pod/poderrs.t\r
-*** ERROR: unterminated I<...> at line 35 in file t/pod/poderrs.t\r
-*** ERROR: unterminated C<...> at line 38 in file t/pod/poderrs.t\r
-*** WARNING: line containing nothing but whitespace in paragraph at line 46 in file t/pod/poderrs.t\r
-*** ERROR: =item without previous =over at line 53 in file t/pod/poderrs.t\r
-*** ERROR: =back without previous =over at line 57 in file t/pod/poderrs.t\r
-*** ERROR: =over on line 61 without closing =back (at head2) at line 65 in file t/pod/poderrs.t\r
-*** ERROR: =end without =begin at line 67 in file t/pod/poderrs.t\r
-*** ERROR: Nested =begin's (first at line 71:html) at line 73 in file t/pod/poderrs.t\r
-*** ERROR: =end without =begin at line 77 in file t/pod/poderrs.t\r
-*** ERROR: No argument for =begin at line 83 in file t/pod/poderrs.t\r
-*** ERROR: =for without formatter specification at line 89 in file t/pod/poderrs.t\r
-*** WARNING: nested commands C<...C<...>...> at line 95 in file t/pod/poderrs.t\r
-*** ERROR: garbled entity E<alea iacta est> at line 99 in file t/pod/poderrs.t\r
-*** ERROR: garbled entity E<C<auml>> at line 100 in file t/pod/poderrs.t\r
-*** ERROR: garbled entity E<abcI<bla>> at line 101 in file t/pod/poderrs.t\r
-*** ERROR: Entity number out of range E<0x100> at line 102 in file t/pod/poderrs.t\r
-*** ERROR: Entity number out of range E<07777> at line 103 in file t/pod/poderrs.t\r
-*** ERROR: Entity number out of range E<300> at line 104 in file t/pod/poderrs.t\r
-*** ERROR: malformed link L<> : empty link at line 116 in file t/pod/poderrs.t\r
-*** WARNING: ignoring leading whitespace in link at line 117 in file t/pod/poderrs.t\r
-*** WARNING: ignoring trailing whitespace in link at line 118 in file t/pod/poderrs.t\r
-*** WARNING: (section) in 'passwd(5)' deprecated at line 126 in file t/pod/poderrs.t\r
-*** WARNING: node '$|' contains non-escaped | or / at line 127 in file t/pod/poderrs.t\r
-*** WARNING: alternative text '$|' contains non-escaped | or / at line 127 in file t/pod/poderrs.t\r
-*** ERROR: Spurious character(s) after =back at line 133 in file t/pod/poderrs.t\r
-*** ERROR: Nonempty Z<> at line 147 in file t/pod/poderrs.t\r
-*** ERROR: Empty X<> at line 149 in file t/pod/poderrs.t\r
-*** WARNING: preceding non-item paragraph(s) at line 155 in file t/pod/poderrs.t\r
-*** WARNING: No argument for =item at line 157 in file t/pod/poderrs.t\r
-*** WARNING: previous =item has no contents at line 159 in file t/pod/poderrs.t\r
-*** WARNING: No items in =over (at line 167) / =back list at line 169 in file t/pod/poderrs.t\r
-*** ERROR: Spurious text after =pod at line 175 in file t/pod/poderrs.t\r
-*** ERROR: Spurious text after =cut at line 179 in file t/pod/poderrs.t\r
-*** WARNING: empty section in previous paragraph at line 195 in file t/pod/poderrs.t\r
-*** ERROR: Apparent command =head2 not preceded by blank line at line 198 in file t/pod/poderrs.t\r
-*** WARNING: empty section in previous paragraph at line 197 in file t/pod/poderrs.t\r
-*** ERROR: Apparent command =head2 not preceded by blank line at line 201 in file t/pod/poderrs.t\r
-*** ERROR: Apparent command =item not preceded by blank line at line 204 in file t/pod/poderrs.t\r
-*** ERROR: Spurious =cut command at line 230 in file t/pod/poderrs.t\r
-*** ERROR: Spurious =pod command at line 236 in file t/pod/poderrs.t\r
-*** ERROR: unresolved internal link 'begin or begin' at line 108 in file t/pod/poderrs.t\r
-*** ERROR: unresolved internal link 'end with begin' at line 109 in file t/pod/poderrs.t\r
-*** ERROR: unresolved internal link 'OoPs' at line 110 in file t/pod/poderrs.t\r
-*** ERROR: unresolved internal link 'abc def' at line 114 in file t/pod/poderrs.t\r
-*** ERROR: unresolved internal link 'I/O Operators' at line 213 in file t/pod/poderrs.t\r
+*** WARNING: =head2 without preceding higher level at line 20 in file t/pod/poderrs.t
+*** WARNING: empty section in previous paragraph at line 22 in file t/pod/poderrs.t
+*** WARNING: Verbatim paragraph in NAME section at line 26 in file t/pod/poderrs.t
+*** ERROR: Unknown directive: =unknown1 at line 28 in file t/pod/poderrs.t
+*** ERROR: Deleting unknown formatting code Q<> at line 31 in file t/pod/poderrs.t
+*** ERROR: Deleting unknown formatting code A<> at line 31 in file t/pod/poderrs.t
+*** ERROR: Deleting unknown formatting code Y<> at line 31 in file t/pod/poderrs.t
+*** ERROR: Deleting unknown formatting code V<> at line 31 in file t/pod/poderrs.t
+*** ERROR: Unterminated I<B<...>> sequence at line 36 in file t/pod/poderrs.t
+*** ERROR: Unterminated C<...> sequence at line 40 in file t/pod/poderrs.t
+*** WARNING: line containing nothing but whitespace in paragraph at line 48 in file t/pod/poderrs.t
+*** WARNING: nested commands X<...X<...>...> at line 51 in file t/pod/poderrs.t
+*** WARNING: nested commands S<...S<...>...> at line 51 in file t/pod/poderrs.t
+*** WARNING: nested commands C<...C<...>...> at line 51 in file t/pod/poderrs.t
+*** WARNING: nested commands I<...I<...>...> at line 51 in file t/pod/poderrs.t
+*** WARNING: nested commands F<...F<...>...> at line 51 in file t/pod/poderrs.t
+*** WARNING: nested commands B<...B<...>...> at line 51 in file t/pod/poderrs.t
+*** ERROR: '=item' outside of any '=over' at line 59 in file t/pod/poderrs.t
+*** ERROR: You forgot a '=back' before '=head2' at line 61 in file t/pod/poderrs.t
+*** ERROR: =back without =over at line 63 in file t/pod/poderrs.t
+*** WARNING: empty section in previous paragraph at line 65 in file t/pod/poderrs.t
+*** ERROR: You forgot a '=back' before '=head2' at line 71 in file t/pod/poderrs.t
+*** ERROR: '=end' without a target? at line 73 in file t/pod/poderrs.t
+*** ERROR: =end something without matching =begin. (Stack: [empty]) at line 75 in file t/pod/poderrs.t
+*** WARNING: empty section in previous paragraph at line 77 in file t/pod/poderrs.t
+*** ERROR: =begin without a target? at line 89 in file t/pod/poderrs.t
+*** ERROR: '=end' without a target? at line 91 in file t/pod/poderrs.t
+*** WARNING: empty section in previous paragraph at line 93 in file t/pod/poderrs.t
+*** ERROR: =for without a target? at line 95 in file t/pod/poderrs.t
+*** WARNING: nested commands C<...C<...>...> at line 101 in file t/pod/poderrs.t
+*** ERROR: Unknown E content in E<alea iacta est> at line 105 in file t/pod/poderrs.t
+*** ERROR: An E<...> surrounding strange content at line 105 in file t/pod/poderrs.t
+*** ERROR: An E<...> surrounding strange content at line 105 in file t/pod/poderrs.t
+*** ERROR: Unknown E content in E<unknown_entity> at line 105 in file t/pod/poderrs.t
+*** ERROR: An empty L<> at line 121 in file t/pod/poderrs.t
+*** ERROR: L<> starts or ends with whitespace at line 121 in file t/pod/poderrs.t
+*** ERROR: L<> starts or ends with whitespace at line 121 in file t/pod/poderrs.t
+*** ERROR: L<> starts or ends with whitespace at line 121 in file t/pod/poderrs.t
+*** ERROR: Unterminated L<<< ... >>> sequence at line 137 in file t/pod/poderrs.t
+*** ERROR: Unterminated L<<< ... >>> sequence at line 139 in file t/pod/poderrs.t
+*** ERROR: alternative text 'some text with / in it' contains non-escaped | or / at line 143 in file t/pod/poderrs.t
+*** ERROR: =back doesn't take any parameters, but you said =back 200 at line 150 in file t/pod/poderrs.t
+*** ERROR: A non-empty Z<> at line 158 in file t/pod/poderrs.t
+*** ERROR: An empty X<> at line 160 in file t/pod/poderrs.t
+*** ERROR: An empty E<> at line 164 in file t/pod/poderrs.t
+*** ERROR: =over should be: '=over' or '=over positive_number' at line 166 in file t/pod/poderrs.t
+*** ERROR: You can't have =items (as at line 170) unless the first thing after the =over is an =item at line 166 in file t/pod/poderrs.t
+*** WARNING: =item has no contents at line 176 in file t/pod/poderrs.t
+*** ERROR: Expected '=item *' at line 178 in file t/pod/poderrs.t
+*** ERROR: Expected '=item *' at line 180 in file t/pod/poderrs.t
+*** WARNING: line containing nothing but whitespace in paragraph at line 187 in file t/pod/poderrs.t
+*** ERROR: You can't have =items (as at line 188) unless the first thing after the =over is an =item at line 184 in file t/pod/poderrs.t
+*** ERROR: Expected '=item *' at line 204 in file t/pod/poderrs.t
+*** ERROR: Expected '=item *' at line 208 in file t/pod/poderrs.t
+*** ERROR: You have '=item 3' instead of the expected '=item 2' at line 218 in file t/pod/poderrs.t
+*** ERROR: Expected '=item 3' at line 222 in file t/pod/poderrs.t
+*** ERROR: Expected '=item 4' at line 224 in file t/pod/poderrs.t
+*** ERROR: Expected text after =item, not a bullet at line 234 in file t/pod/poderrs.t
+*** ERROR: Expected text after =item, not a number at line 238 in file t/pod/poderrs.t
+*** WARNING: empty =over/=back block at line 253 in file t/pod/poderrs.t
+*** ERROR: Spurious text after =pod at line 263 in file t/pod/poderrs.t
+*** ERROR: Spurious text after =cut at line 267 in file t/pod/poderrs.t
+*** WARNING: empty section in previous paragraph at line 283 in file t/pod/poderrs.t
+*** ERROR: empty =head1 at line 305 in file t/pod/poderrs.t
+*** ERROR: =over without closing =back at line 311 in file t/pod/poderrs.t
+*** ERROR: =begin :xml without matching =end :xml at line 317 in file t/pod/poderrs.t
+*** ERROR: =begin html without matching =end html at line 313 in file t/pod/poderrs.t
+*** ERROR: unresolved internal link 'begin or begin' at line 115 in file t/pod/poderrs.t
+*** ERROR: unresolved internal link 'end with begin' at line 115 in file t/pod/poderrs.t
+*** ERROR: unresolved internal link 'OoPs' at line 115 in file t/pod/poderrs.t
+*** ERROR: unresolved internal link 'abc def' at line 121 in file t/pod/poderrs.t
+*** ERROR: unresolved internal link ' aha' at line 121 in file t/pod/poderrs.t
+*** ERROR: unresolved internal link 'oho ' at line 121 in file t/pod/poderrs.t
+*** ERROR: unresolved internal link ' weehee ' at line 121 in file t/pod/poderrs.t
+*** ERROR: unresolved internal link 'link_to_nowhere' at line 319 in file t/pod/poderrs.t
+*** WARNING: multiple occurrences (2) of link target '*' at line - in file t/pod/poderrs.t
+*** WARNING: multiple occurrences (2) of link target '1' at line - in file t/pod/poderrs.t
+*** WARNING: multiple occurrences (2) of link target 'Misc' at line - in file t/pod/poderrs.t
-#!/usr/bin/perl\r
-use File::Basename;\r
-use File::Spec;\r
-use strict;\r
-my $THISDIR;\r
-BEGIN {\r
- $THISDIR = dirname $0;\r
- unshift @INC, $THISDIR;\r
- require "testpchk.pl";\r
- import TestPodChecker qw(testpodcheck);\r
-}\r
-\r
-# test that our POD is correct!\r
-my $path = File::Spec->catfile($THISDIR,(File::Spec->updir()) x 2, 'lib', 'Pod', '*.pm');\r
-print "THISDIR=$THISDIR PATH=$path\n";\r
-my @pods = glob($path);\r
-print "PODS=@pods\n";\r
-\r
-print "1..",scalar(@pods),"\n";\r
-\r
-my $errs = 0;\r
-my $testnum = 1;\r
-foreach my $pod (@pods) {\r
- my $out = File::Spec->catfile($THISDIR, basename($pod));\r
- $out =~ s{\.pm}{.OUT};\r
- my %options = ( -Out => $out );\r
- my $failmsg = testpodcheck(-In => $pod, -Out => $out, -Cmp => "$THISDIR/empty.xr");\r
- if($failmsg) {\r
- if(open(IN, "<$out")) {\r
- while(<IN>) {\r
- warn "podchecker: $_";\r
- }\r
- close(IN);\r
- } else {\r
- warn "Error: Cannot read output file $out: $!\n";\r
- }\r
- print "not ok $testnum\n";\r
- $errs++;\r
- } else {\r
- print "ok $testnum\n";\r
- }\r
- $testnum++;\r
-}\r
-exit( ($errs == 0) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE};\r
-\r
+#!/usr/bin/perl
+use File::Basename;
+use File::Spec;
+use strict;
+my $THISDIR;
+BEGIN {
+ $THISDIR = dirname $0;
+ unshift @INC, $THISDIR;
+ require "testpchk.pl";
+ import TestPodChecker qw(testpodcheck);
+}
+
+# test that our POD is correct!
+my $path = File::Spec->catfile($THISDIR,(File::Spec->updir()) x 2, 'lib', 'Pod', '*.pm');
+print "THISDIR=$THISDIR PATH=$path\n";
+my @pods = glob($path);
+print "PODS=@pods\n";
+
+print "1..",scalar(@pods),"\n";
+
+my $errs = 0;
+my $testnum = 1;
+foreach my $pod (@pods) {
+ my $out = File::Spec->catfile($THISDIR, basename($pod));
+ $out =~ s{\.pm}{.OUT};
+ my %options = ( -Out => $out );
+ my $failmsg = testpodcheck(-In => $pod, -Out => $out, -Cmp => "$THISDIR/empty.xr");
+ if($failmsg) {
+ if(open(IN, "<$out")) {
+ while(<IN>) {
+ warn "podchecker: $_";
+ }
+ close(IN);
+ } else {
+ warn "Error: Cannot read output file $out: $!\n";
+ }
+ print "not ok $testnum\n";
+ $errs++;
+ } else {
+ print "ok $testnum\n";
+ }
+ $testnum++;
+}
+exit( ($errs == 0) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE};
+
-package TestCompare;\r
-\r
-use vars qw(@ISA @EXPORT $MYPKG);\r
-#use strict;\r
-#use diagnostics;\r
-use Carp;\r
-use Exporter;\r
-use File::Basename;\r
-use File::Spec;\r
-use FileHandle;\r
-\r
-@ISA = qw(Exporter);\r
-@EXPORT = qw(&testcmp);\r
-$MYPKG = eval { (caller)[0] };\r
-\r
-##--------------------------------------------------------------------------\r
-\r
-=head1 NAME\r
-\r
-testcmp -- compare two files line-by-line\r
-\r
-=head1 SYNOPSIS\r
-\r
- $is_diff = testcmp($file1, $file2);\r
-\r
-or\r
-\r
- $is_diff = testcmp({-cmplines => \&mycmp}, $file1, $file2);\r
-\r
-=head2 DESCRIPTION\r
-\r
-Compare two text files line-by-line and return 0 if they are the\r
-same, 1 if they differ. Each of $file1 and $file2 may be a filenames,\r
-or a filehandles (in which case it must already be open for reading).\r
-\r
-If the first argument is a hashref, then the B<-cmplines> key in the\r
-hash may have a subroutine reference as its corresponding value.\r
-The referenced user-defined subroutine should be a line-comparator\r
-function that takes two pre-chomped text-lines as its arguments\r
-(the first is from $file1 and the second is from $file2). It should\r
-return 0 if it considers the two lines equivalent, and non-zero\r
-otherwise.\r
-\r
-=cut\r
-\r
-##--------------------------------------------------------------------------\r
-\r
-sub testcmp( $ $ ; $) {\r
- my %opts = ref($_[0]) eq 'HASH' ? %{shift()} : ();\r
- my ($file1, $file2) = @_;\r
- my ($fh1, $fh2) = ($file1, $file2);\r
- unless (ref $fh1) {\r
- $fh1 = FileHandle->new($file1, "r") or die "Can't open $file1: $!";\r
- }\r
- unless (ref $fh2) {\r
- $fh2 = FileHandle->new($file2, "r") or die "Can't open $file2: $!";\r
- }\r
- \r
- my $cmplines = $opts{'-cmplines'} || undef;\r
- my ($f1text, $f2text) = ("", "");\r
- my ($line, $diffs) = (0, 0);\r
- \r
- while ( defined($f1text) and defined($f2text) ) {\r
- defined($f1text = <$fh1>) and chomp($f1text);\r
- defined($f2text = <$fh2>) and chomp($f2text);\r
- ++$line;\r
- last unless ( defined($f1text) and defined($f2text) );\r
- # kill any extra line endings\r
- $f1text =~ s/[\r\n]+$//s;\r
- $f2text =~ s/[\r\n]+$//s;\r
- $diffs = (ref $cmplines) ? &$cmplines($f1text, $f2text)\r
- : ($f1text ne $f2text);\r
- last if $diffs;\r
- }\r
- close($fh1) unless (ref $file1);\r
- close($fh2) unless (ref $file2);\r
- \r
- $diffs = 1 if (defined($f1text) or defined($f2text));\r
- if ( defined($f1text) and defined($f2text) ) {\r
- ## these two lines must be different\r
- warn "$file1 and $file2 differ at line $line\n";\r
- }\r
- elsif (defined($f1text) and (! defined($f1text))) {\r
- ## file1 must be shorter\r
- warn "$file1 is shorter than $file2\n";\r
- }\r
- elsif (defined $f2text) {\r
- ## file2 must be longer\r
- warn "$file1 is shorter than $file2\n";\r
- }\r
- return $diffs;\r
-}\r
-\r
-1;\r
+package TestCompare;
+
+use vars qw(@ISA @EXPORT $MYPKG);
+#use strict;
+#use diagnostics;
+use Carp;
+use Exporter;
+use File::Basename;
+use File::Spec;
+use FileHandle;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(&testcmp);
+$MYPKG = eval { (caller)[0] };
+
+##--------------------------------------------------------------------------
+
+=head1 NAME
+
+testcmp -- compare two files line-by-line
+
+=head1 SYNOPSIS
+
+ $is_diff = testcmp($file1, $file2);
+
+or
+
+ $is_diff = testcmp({-cmplines => \&mycmp}, $file1, $file2);
+
+=head2 DESCRIPTION
+
+Compare two text files line-by-line and return 0 if they are the
+same, 1 if they differ. Each of $file1 and $file2 may be a filenames,
+or a filehandles (in which case it must already be open for reading).
+
+If the first argument is a hashref, then the B<-cmplines> key in the
+hash may have a subroutine reference as its corresponding value.
+The referenced user-defined subroutine should be a line-comparator
+function that takes two pre-chomped text-lines as its arguments
+(the first is from $file1 and the second is from $file2). It should
+return 0 if it considers the two lines equivalent, and non-zero
+otherwise.
+
+=cut
+
+##--------------------------------------------------------------------------
+
+sub testcmp( $ $ ; $) {
+ my %opts = ref($_[0]) eq 'HASH' ? %{shift()} : ();
+ my ($file1, $file2) = @_;
+ my ($fh1, $fh2) = ($file1, $file2);
+ unless (ref $fh1) {
+ $fh1 = FileHandle->new($file1, "r") or die "Can't open $file1: $!";
+ }
+ unless (ref $fh2) {
+ $fh2 = FileHandle->new($file2, "r") or die "Can't open $file2: $!";
+ }
+
+ my $cmplines = $opts{'-cmplines'} || undef;
+ my ($f1text, $f2text) = ("", "");
+ my ($line, $diffs) = (0, 0);
+
+ while ( defined($f1text) and defined($f2text) ) {
+ defined($f1text = <$fh1>) and chomp($f1text);
+ defined($f2text = <$fh2>) and chomp($f2text);
+ ++$line;
+ last unless ( defined($f1text) and defined($f2text) );
+ # kill any extra line endings
+ $f1text =~ s/[\r\n]+$//s;
+ $f2text =~ s/[\r\n]+$//s;
+ $diffs = (ref $cmplines) ? &$cmplines($f1text, $f2text)
+ : ($f1text ne $f2text);
+ last if $diffs;
+ }
+ close($fh1) unless (ref $file1);
+ close($fh2) unless (ref $file2);
+
+ $diffs = 1 if (defined($f1text) or defined($f2text));
+ if ( defined($f1text) and defined($f2text) ) {
+ ## these two lines must be different
+ warn "$file1 and $file2 differ at line $line\n";
+ }
+ elsif (defined($f1text) and (! defined($f1text))) {
+ ## file1 must be shorter
+ warn "$file1 is shorter than $file2\n";
+ }
+ elsif (defined $f2text) {
+ ## file2 must be longer
+ warn "$file1 is shorter than $file2\n";
+ }
+ return $diffs;
+}
+
+1;
-package TestPodChecker;\r
-\r
-BEGIN {\r
- use File::Basename;\r
- use File::Spec;\r
- push @INC, '..';\r
- my $THISDIR = dirname $0;\r
- unshift @INC, $THISDIR;\r
- require "testcmp.pl";\r
- import TestCompare;\r
- my $PARENTDIR = dirname $THISDIR;\r
- push @INC, map { File::Spec->catfile($_, 'lib') } ($PARENTDIR, $THISDIR);\r
- require VMS::Filespec if $^O eq 'VMS';\r
-}\r
-\r
-use Pod::Checker;\r
-use vars qw(@ISA @EXPORT $MYPKG);\r
-#use strict;\r
-#use diagnostics;\r
-use Carp;\r
-use Exporter;\r
-#use File::Compare;\r
-\r
-@ISA = qw(Exporter);\r
-@EXPORT = qw(&testpodchecker);\r
-@EXPORT_OK = qw(&testpodcheck);\r
-$MYPKG = eval { (caller)[0] };\r
-\r
-sub stripname( $ ) {\r
- local $_ = shift;\r
- return /(\w[.\w]*)\s*$/ ? $1 : $_;\r
-}\r
-\r
-sub msgcmp( $ $ ) {\r
- ## filter out platform-dependent aspects of error messages\r
- my ($line1, $line2) = @_;\r
- for ($line1, $line2) {\r
- ## remove filenames from error messages to avoid any\r
- ## filepath naming differences between OS platforms\r
- s/(at line \S+ in file) .*\W(\w+\.[tT])\s*$/$1 \L$2\E/;\r
- s/.*\W(\w+\.[tT]) (has \d+ pod syntax error)/\L$1\E $2/;\r
- }\r
- return ($line1 ne $line2);\r
-}\r
-\r
-sub testpodcheck( @ ) {\r
- my %args = @_;\r
- my $infile = $args{'-In'} || croak "No input file given!";\r
- my $outfile = $args{'-Out'} || croak "No output file given!";\r
- my $cmpfile = $args{'-Cmp'} || croak "No compare-result file given!";\r
-\r
- my $different = '';\r
- my $testname = basename $infile, '.t', '.xr';\r
-\r
- unless (-e $cmpfile) {\r
- my $msg = "*** Can't find comparison file $cmpfile for testing $infile";\r
- warn "$msg\n";\r
- return $msg;\r
- }\r
-\r
- print "# Running podchecker for '$testname'...\n";\r
- ## Compare the output against the expected result\r
- if ($^O eq 'VMS') {\r
- for ($infile, $outfile, $cmpfile) {\r
- $_ = VMS::Filespec::unixify($_) unless ref;\r
- }\r
- }\r
- podchecker($infile, $outfile);\r
- if ( testcmp({'-cmplines' => \&msgcmp}, $outfile, $cmpfile) ) {\r
- $different = "$outfile is different from $cmpfile";\r
- }\r
- else {\r
- unlink($outfile);\r
- }\r
- return $different;\r
-}\r
-\r
-sub testpodchecker( @ ) {\r
- my %opts = (ref $_[0] eq 'HASH') ? %{shift()} : ();\r
- my @testpods = @_;\r
- my ($testname, $testdir) = ("", "");\r
- my ($podfile, $cmpfile) = ("", "");\r
- my ($outfile, $errfile) = ("", "");\r
- my $passes = 0;\r
- my $failed = 0;\r
- local $_;\r
-\r
- print "1..", scalar @testpods, "\n" unless ($opts{'-xrgen'});\r
-\r
- for $podfile (@testpods) {\r
- ($testname, $_) = fileparse($podfile);\r
- $testdir ||= $_;\r
- $testname =~ s/\.t$//;\r
- $cmpfile = $testdir . $testname . '.xr';\r
- $outfile = $testdir . $testname . '.OUT';\r
-\r
- if ($opts{'-xrgen'}) {\r
- if ($opts{'-force'} or ! -e $cmpfile) {\r
- ## Create the comparison file\r
- print "# Creating expected result for \"$testname\"" .\r
- " podchecker test ...\n";\r
- podchecker($podfile, $cmpfile);\r
- }\r
- else {\r
- print "# File $cmpfile already exists" .\r
- " (use '-force' to regenerate it).\n";\r
- }\r
- next;\r
- }\r
-\r
- my $failmsg = testpodcheck\r
- -In => $podfile,\r
- -Out => $outfile,\r
- -Cmp => $cmpfile;\r
- if ($failmsg) {\r
- ++$failed;\r
- print "#\tFAILED. ($failmsg)\n";\r
- print "not ok ", $failed+$passes, "\n";\r
- }\r
- else {\r
- ++$passes;\r
- unlink($outfile);\r
- print "#\tPASSED.\n";\r
- print "ok ", $failed+$passes, "\n";\r
- }\r
- }\r
- return $passes;\r
-}\r
-\r
-1;\r
+package TestPodChecker;
+
+BEGIN {
+ use File::Basename;
+ use File::Spec;
+ push @INC, '..';
+ my $THISDIR = dirname $0;
+ unshift @INC, $THISDIR;
+ require "testcmp.pl";
+ import TestCompare;
+ my $PARENTDIR = dirname $THISDIR;
+ push @INC, map { File::Spec->catfile($_, 'lib') } ($PARENTDIR, $THISDIR);
+ require VMS::Filespec if $^O eq 'VMS';
+}
+
+use Pod::Checker;
+use vars qw(@ISA @EXPORT $MYPKG);
+#use strict;
+#use diagnostics;
+use Carp;
+use Exporter;
+#use File::Compare;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(&testpodchecker);
+@EXPORT_OK = qw(&testpodcheck);
+$MYPKG = eval { (caller)[0] };
+
+sub stripname( $ ) {
+ local $_ = shift;
+ return /(\w[.\w]*)\s*$/ ? $1 : $_;
+}
+
+sub msgcmp( $ $ ) {
+ ## filter out platform-dependent aspects of error messages
+ my ($line1, $line2) = @_;
+ for ($line1, $line2) {
+ ## remove filenames from error messages to avoid any
+ ## filepath naming differences between OS platforms
+ s/(at line \S+ in file) .*\W(\w+\.[tT])\s*$/$1 \L$2\E/;
+ s/.*\W(\w+\.[tT]) (has \d+ pod syntax error)/\L$1\E $2/;
+ }
+ return ($line1 ne $line2);
+}
+
+sub testpodcheck( @ ) {
+ my %args = @_;
+ my $infile = $args{'-In'} || croak "No input file given!";
+ my $outfile = $args{'-Out'} || croak "No output file given!";
+ my $cmpfile = $args{'-Cmp'} || croak "No compare-result file given!";
+
+ my $different = '';
+ my $testname = basename $infile, '.t', '.xr';
+
+ unless (-e $cmpfile) {
+ my $msg = "*** Can't find comparison file $cmpfile for testing $infile";
+ warn "$msg\n";
+ return $msg;
+ }
+
+ print "# Running podchecker for '$testname'...\n";
+ ## Compare the output against the expected result
+ if ($^O eq 'VMS') {
+ for ($infile, $outfile, $cmpfile) {
+ $_ = VMS::Filespec::unixify($_) unless ref;
+ }
+ }
+ podchecker($infile, $outfile, -warnings => 200);
+ if ( testcmp({'-cmplines' => \&msgcmp}, $outfile, $cmpfile) ) {
+ $different = "$outfile is different from $cmpfile";
+ system("diff -u $cmpfile $outfile") if $ENV{TEST_POD_CHECK_DIFF};
+ }
+ else {
+ unlink($outfile);
+ }
+ return $different;
+}
+
+sub testpodchecker( @ ) {
+ my %opts = (ref $_[0] eq 'HASH') ? %{shift()} : ();
+ my @testpods = @_;
+ my ($testname, $testdir) = ("", "");
+ my ($podfile, $cmpfile) = ("", "");
+ my ($outfile, $errfile) = ("", "");
+ my $passes = 0;
+ my $failed = 0;
+ local $_;
+
+ print "1..", scalar @testpods, "\n" unless ($opts{'-xrgen'});
+
+ for $podfile (@testpods) {
+ ($testname, $_) = fileparse($podfile);
+ $testdir ||= $_;
+ $testname =~ s/\.t$//;
+ $cmpfile = $testdir . $testname . '.xr';
+ $outfile = $testdir . $testname . '.OUT';
+
+ if ($opts{'-xrgen'}) {
+ if ($opts{'-force'} or ! -e $cmpfile) {
+ ## Create the comparison file
+ print "# Creating expected result for \"$testname\"" .
+ " podchecker test ...\n";
+ podchecker($podfile, $cmpfile);
+ }
+ else {
+ print "# File $cmpfile already exists" .
+ " (use '-force' to regenerate it).\n";
+ }
+ next;
+ }
+
+ my $failmsg = testpodcheck
+ -In => $podfile,
+ -Out => $outfile,
+ -Cmp => $cmpfile;
+ if ($failmsg) {
+ ++$failed;
+ print "#\tFAILED. ($failmsg)\n";
+ print "not ok ", $failed+$passes, "\n";
+ }
+ else {
+ ++$passes;
+ unlink($outfile);
+ print "#\tPASSED.\n";
+ print "ok ", $failed+$passes, "\n";
+ }
+ }
+ return $passes;
+}
+
+1;
use strict;
use vars qw($VERSION @ISA @EXPORT);
-$VERSION = '1.68'; ## Current version of this package
+$VERSION = '1.69'; ## Current version of this package
require 5.006; ## requires this Perl version or later
#use diagnostics;
--- /dev/null
+#############################################################################\r
+# Pod/InputObjects.pm -- package which defines objects for input streams\r
+# and paragraphs and commands when parsing POD docs.\r
+#\r
+# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved.\r
+# This file is part of "PodParser". PodParser is free software;\r
+# you can redistribute it and/or modify it under the same terms\r
+# as Perl itself.\r
+#############################################################################\r
+\r
+package Pod::InputObjects;\r
+use strict;\r
+\r
+use vars qw($VERSION);\r
+$VERSION = '1.60'; ## Current version of this package\r
+require 5.005; ## requires this Perl version or later\r
+\r
+#############################################################################\r
+\r
+=head1 NAME\r
+\r
+Pod::InputObjects - objects representing POD input paragraphs, commands, etc.\r
+\r
+=head1 SYNOPSIS\r
+\r
+ use Pod::InputObjects;\r
+\r
+=head1 REQUIRES\r
+\r
+perl5.004, Carp\r
+\r
+=head1 EXPORTS\r
+\r
+Nothing.\r
+\r
+=head1 DESCRIPTION\r
+\r
+This module defines some basic input objects used by B<Pod::Parser> when\r
+reading and parsing POD text from an input source. The following objects\r
+are defined:\r
+\r
+=begin __PRIVATE__\r
+\r
+=over 4\r
+\r
+=item package B<Pod::InputSource>\r
+\r
+An object corresponding to a source of POD input text. It is mostly a\r
+wrapper around a filehandle or C<IO::Handle>-type object (or anything\r
+that implements the C<getline()> method) which keeps track of some\r
+additional information relevant to the parsing of PODs.\r
+\r
+=back\r
+\r
+=end __PRIVATE__\r
+\r
+=over 4\r
+\r
+=item package B<Pod::Paragraph>\r
+\r
+An object corresponding to a paragraph of POD input text. It may be a\r
+plain paragraph, a verbatim paragraph, or a command paragraph (see\r
+L<perlpod>).\r
+\r
+=item package B<Pod::InteriorSequence>\r
+\r
+An object corresponding to an interior sequence command from the POD\r
+input text (see L<perlpod>).\r
+\r
+=item package B<Pod::ParseTree>\r
+\r
+An object corresponding to a tree of parsed POD text. Each "node" in\r
+a parse-tree (or I<ptree>) is either a text-string or a reference to\r
+a B<Pod::InteriorSequence> object. The nodes appear in the parse-tree\r
+in the order in which they were parsed from left-to-right.\r
+\r
+=back\r
+\r
+Each of these input objects are described in further detail in the\r
+sections which follow.\r
+\r
+=cut\r
+\r
+#############################################################################\r
+\r
+package Pod::InputSource;\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=begin __PRIVATE__\r
+\r
+=head1 B<Pod::InputSource>\r
+\r
+This object corresponds to an input source or stream of POD\r
+documentation. When parsing PODs, it is necessary to associate and store\r
+certain context information with each input source. All of this\r
+information is kept together with the stream itself in one of these\r
+C<Pod::InputSource> objects. Each such object is merely a wrapper around\r
+an C<IO::Handle> object of some kind (or at least something that\r
+implements the C<getline()> method). They have the following\r
+methods/attributes:\r
+\r
+=end __PRIVATE__\r
+\r
+=cut\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=begin __PRIVATE__\r
+\r
+=head2 B<new()>\r
+\r
+ my $pod_input1 = Pod::InputSource->new(-handle => $filehandle);\r
+ my $pod_input2 = new Pod::InputSource(-handle => $filehandle,\r
+ -name => $name);\r
+ my $pod_input3 = new Pod::InputSource(-handle => \*STDIN);\r
+ my $pod_input4 = Pod::InputSource->new(-handle => \*STDIN,\r
+ -name => "(STDIN)");\r
+\r
+This is a class method that constructs a C<Pod::InputSource> object and\r
+returns a reference to the new input source object. It takes one or more\r
+keyword arguments in the form of a hash. The keyword C<-handle> is\r
+required and designates the corresponding input handle. The keyword\r
+C<-name> is optional and specifies the name associated with the input\r
+handle (typically a file name).\r
+\r
+=end __PRIVATE__\r
+\r
+=cut\r
+\r
+sub new {\r
+ ## Determine if we were called via an object-ref or a classname\r
+ my $this = shift;\r
+ my $class = ref($this) || $this;\r
+\r
+ ## Any remaining arguments are treated as initial values for the\r
+ ## hash that is used to represent this object. Note that we default\r
+ ## certain values by specifying them *before* the arguments passed.\r
+ ## If they are in the argument list, they will override the defaults.\r
+ my $self = { -name => '(unknown)',\r
+ -handle => undef,\r
+ -was_cutting => 0,\r
+ @_ };\r
+\r
+ ## Bless ourselves into the desired class and perform any initialization\r
+ bless $self, $class;\r
+ return $self;\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=begin __PRIVATE__\r
+\r
+=head2 B<name()>\r
+\r
+ my $filename = $pod_input->name();\r
+ $pod_input->name($new_filename_to_use);\r
+\r
+This method gets/sets the name of the input source (usually a filename).\r
+If no argument is given, it returns a string containing the name of\r
+the input source; otherwise it sets the name of the input source to the\r
+contents of the given argument.\r
+\r
+=end __PRIVATE__\r
+\r
+=cut\r
+\r
+sub name {\r
+ (@_ > 1) and $_[0]->{'-name'} = $_[1];\r
+ return $_[0]->{'-name'};\r
+}\r
+\r
+## allow 'filename' as an alias for 'name'\r
+*filename = \&name;\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=begin __PRIVATE__\r
+\r
+=head2 B<handle()>\r
+\r
+ my $handle = $pod_input->handle();\r
+\r
+Returns a reference to the handle object from which input is read (the\r
+one used to contructed this input source object).\r
+\r
+=end __PRIVATE__\r
+\r
+=cut\r
+\r
+sub handle {\r
+ return $_[0]->{'-handle'};\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=begin __PRIVATE__\r
+\r
+=head2 B<was_cutting()>\r
+\r
+ print "Yes.\n" if ($pod_input->was_cutting());\r
+\r
+The value of the C<cutting> state (that the B<cutting()> method would\r
+have returned) immediately before any input was read from this input\r
+stream. After all input from this stream has been read, the C<cutting>\r
+state is restored to this value.\r
+\r
+=end __PRIVATE__\r
+\r
+=cut\r
+\r
+sub was_cutting {\r
+ (@_ > 1) and $_[0]->{-was_cutting} = $_[1];\r
+ return $_[0]->{-was_cutting};\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+#############################################################################\r
+\r
+package Pod::Paragraph;\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head1 B<Pod::Paragraph>\r
+\r
+An object representing a paragraph of POD input text.\r
+It has the following methods/attributes:\r
+\r
+=cut\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head2 Pod::Paragraph-E<gt>B<new()>\r
+\r
+ my $pod_para1 = Pod::Paragraph->new(-text => $text);\r
+ my $pod_para2 = Pod::Paragraph->new(-name => $cmd,\r
+ -text => $text);\r
+ my $pod_para3 = new Pod::Paragraph(-text => $text);\r
+ my $pod_para4 = new Pod::Paragraph(-name => $cmd,\r
+ -text => $text);\r
+ my $pod_para5 = Pod::Paragraph->new(-name => $cmd,\r
+ -text => $text,\r
+ -file => $filename,\r
+ -line => $line_number);\r
+\r
+This is a class method that constructs a C<Pod::Paragraph> object and\r
+returns a reference to the new paragraph object. It may be given one or\r
+two keyword arguments. The C<-text> keyword indicates the corresponding\r
+text of the POD paragraph. The C<-name> keyword indicates the name of\r
+the corresponding POD command, such as C<head1> or C<item> (it should\r
+I<not> contain the C<=> prefix); this is needed only if the POD\r
+paragraph corresponds to a command paragraph. The C<-file> and C<-line>\r
+keywords indicate the filename and line number corresponding to the\r
+beginning of the paragraph \r
+\r
+=cut\r
+\r
+sub new {\r
+ ## Determine if we were called via an object-ref or a classname\r
+ my $this = shift;\r
+ my $class = ref($this) || $this;\r
+\r
+ ## Any remaining arguments are treated as initial values for the\r
+ ## hash that is used to represent this object. Note that we default\r
+ ## certain values by specifying them *before* the arguments passed.\r
+ ## If they are in the argument list, they will override the defaults.\r
+ my $self = {\r
+ -name => undef,\r
+ -text => (@_ == 1) ? shift : undef,\r
+ -file => '<unknown-file>',\r
+ -line => 0,\r
+ -prefix => '=',\r
+ -separator => ' ',\r
+ -ptree => [],\r
+ @_\r
+ };\r
+\r
+ ## Bless ourselves into the desired class and perform any initialization\r
+ bless $self, $class;\r
+ return $self;\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head2 $pod_para-E<gt>B<cmd_name()>\r
+\r
+ my $para_cmd = $pod_para->cmd_name();\r
+\r
+If this paragraph is a command paragraph, then this method will return \r
+the name of the command (I<without> any leading C<=> prefix).\r
+\r
+=cut\r
+\r
+sub cmd_name {\r
+ (@_ > 1) and $_[0]->{'-name'} = $_[1];\r
+ return $_[0]->{'-name'};\r
+}\r
+\r
+## let name() be an alias for cmd_name()\r
+*name = \&cmd_name;\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head2 $pod_para-E<gt>B<text()>\r
+\r
+ my $para_text = $pod_para->text();\r
+\r
+This method will return the corresponding text of the paragraph.\r
+\r
+=cut\r
+\r
+sub text {\r
+ (@_ > 1) and $_[0]->{'-text'} = $_[1];\r
+ return $_[0]->{'-text'};\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head2 $pod_para-E<gt>B<raw_text()>\r
+\r
+ my $raw_pod_para = $pod_para->raw_text();\r
+\r
+This method will return the I<raw> text of the POD paragraph, exactly\r
+as it appeared in the input.\r
+\r
+=cut\r
+\r
+sub raw_text {\r
+ return $_[0]->{'-text'} unless (defined $_[0]->{'-name'});\r
+ return $_[0]->{'-prefix'} . $_[0]->{'-name'} .\r
+ $_[0]->{'-separator'} . $_[0]->{'-text'};\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head2 $pod_para-E<gt>B<cmd_prefix()>\r
+\r
+ my $prefix = $pod_para->cmd_prefix();\r
+\r
+If this paragraph is a command paragraph, then this method will return \r
+the prefix used to denote the command (which should be the string "="\r
+or "==").\r
+\r
+=cut\r
+\r
+sub cmd_prefix {\r
+ return $_[0]->{'-prefix'};\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head2 $pod_para-E<gt>B<cmd_separator()>\r
+\r
+ my $separator = $pod_para->cmd_separator();\r
+\r
+If this paragraph is a command paragraph, then this method will return\r
+the text used to separate the command name from the rest of the\r
+paragraph (if any).\r
+\r
+=cut\r
+\r
+sub cmd_separator {\r
+ return $_[0]->{'-separator'};\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head2 $pod_para-E<gt>B<parse_tree()>\r
+\r
+ my $ptree = $pod_parser->parse_text( $pod_para->text() );\r
+ $pod_para->parse_tree( $ptree );\r
+ $ptree = $pod_para->parse_tree();\r
+\r
+This method will get/set the corresponding parse-tree of the paragraph's text.\r
+\r
+=cut\r
+\r
+sub parse_tree {\r
+ (@_ > 1) and $_[0]->{'-ptree'} = $_[1];\r
+ return $_[0]->{'-ptree'};\r
+}\r
+\r
+## let ptree() be an alias for parse_tree()\r
+*ptree = \&parse_tree;\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head2 $pod_para-E<gt>B<file_line()>\r
+\r
+ my ($filename, $line_number) = $pod_para->file_line();\r
+ my $position = $pod_para->file_line();\r
+\r
+Returns the current filename and line number for the paragraph\r
+object. If called in a list context, it returns a list of two\r
+elements: first the filename, then the line number. If called in\r
+a scalar context, it returns a string containing the filename, followed\r
+by a colon (':'), followed by the line number.\r
+\r
+=cut\r
+\r
+sub file_line {\r
+ my @loc = ($_[0]->{'-file'} || '<unknown-file>',\r
+ $_[0]->{'-line'} || 0);\r
+ return (wantarray) ? @loc : join(':', @loc);\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+#############################################################################\r
+\r
+package Pod::InteriorSequence;\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head1 B<Pod::InteriorSequence>\r
+\r
+An object representing a POD interior sequence command.\r
+It has the following methods/attributes:\r
+\r
+=cut\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head2 Pod::InteriorSequence-E<gt>B<new()>\r
+\r
+ my $pod_seq1 = Pod::InteriorSequence->new(-name => $cmd\r
+ -ldelim => $delimiter);\r
+ my $pod_seq2 = new Pod::InteriorSequence(-name => $cmd,\r
+ -ldelim => $delimiter);\r
+ my $pod_seq3 = new Pod::InteriorSequence(-name => $cmd,\r
+ -ldelim => $delimiter,\r
+ -file => $filename,\r
+ -line => $line_number);\r
+\r
+ my $pod_seq4 = new Pod::InteriorSequence(-name => $cmd, $ptree);\r
+ my $pod_seq5 = new Pod::InteriorSequence($cmd, $ptree);\r
+\r
+This is a class method that constructs a C<Pod::InteriorSequence> object\r
+and returns a reference to the new interior sequence object. It should\r
+be given two keyword arguments. The C<-ldelim> keyword indicates the\r
+corresponding left-delimiter of the interior sequence (e.g. 'E<lt>').\r
+The C<-name> keyword indicates the name of the corresponding interior\r
+sequence command, such as C<I> or C<B> or C<C>. The C<-file> and\r
+C<-line> keywords indicate the filename and line number corresponding\r
+to the beginning of the interior sequence. If the C<$ptree> argument is\r
+given, it must be the last argument, and it must be either string, or\r
+else an array-ref suitable for passing to B<Pod::ParseTree::new> (or\r
+it may be a reference to a Pod::ParseTree object).\r
+\r
+=cut\r
+\r
+sub new {\r
+ ## Determine if we were called via an object-ref or a classname\r
+ my $this = shift;\r
+ my $class = ref($this) || $this;\r
+\r
+ ## See if first argument has no keyword\r
+ if (((@_ <= 2) or (@_ % 2)) and $_[0] !~ /^-\w/) {\r
+ ## Yup - need an implicit '-name' before first parameter\r
+ unshift @_, '-name';\r
+ }\r
+\r
+ ## See if odd number of args\r
+ if ((@_ % 2) != 0) {\r
+ ## Yup - need an implicit '-ptree' before the last parameter\r
+ splice @_, $#_, 0, '-ptree';\r
+ }\r
+\r
+ ## Any remaining arguments are treated as initial values for the\r
+ ## hash that is used to represent this object. Note that we default\r
+ ## certain values by specifying them *before* the arguments passed.\r
+ ## If they are in the argument list, they will override the defaults.\r
+ my $self = {\r
+ -name => (@_ == 1) ? $_[0] : undef,\r
+ -file => '<unknown-file>',\r
+ -line => 0,\r
+ -ldelim => '<',\r
+ -rdelim => '>',\r
+ @_\r
+ };\r
+\r
+ ## Initialize contents if they havent been already\r
+ my $ptree = $self->{'-ptree'} || new Pod::ParseTree();\r
+ if ( ref $ptree =~ /^(ARRAY)?$/ ) {\r
+ ## We have an array-ref, or a normal scalar. Pass it as an\r
+ ## an argument to the ptree-constructor\r
+ $ptree = new Pod::ParseTree($1 ? [$ptree] : $ptree);\r
+ }\r
+ $self->{'-ptree'} = $ptree;\r
+\r
+ ## Bless ourselves into the desired class and perform any initialization\r
+ bless $self, $class;\r
+ return $self;\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head2 $pod_seq-E<gt>B<cmd_name()>\r
+\r
+ my $seq_cmd = $pod_seq->cmd_name();\r
+\r
+The name of the interior sequence command.\r
+\r
+=cut\r
+\r
+sub cmd_name {\r
+ (@_ > 1) and $_[0]->{'-name'} = $_[1];\r
+ return $_[0]->{'-name'};\r
+}\r
+\r
+## let name() be an alias for cmd_name()\r
+*name = \&cmd_name;\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+## Private subroutine to set the parent pointer of all the given\r
+## children that are interior-sequences to be $self\r
+\r
+sub _set_child2parent_links {\r
+ my ($self, @children) = @_;\r
+ ## Make sure any sequences know who their parent is\r
+ for (@children) {\r
+ next unless (length and ref and ref ne 'SCALAR');\r
+ if (UNIVERSAL::isa($_, 'Pod::InteriorSequence') or\r
+ UNIVERSAL::can($_, 'nested'))\r
+ {\r
+ $_->nested($self);\r
+ }\r
+ }\r
+}\r
+\r
+## Private subroutine to unset child->parent links\r
+\r
+sub _unset_child2parent_links {\r
+ my $self = shift;\r
+ $self->{'-parent_sequence'} = undef;\r
+ my $ptree = $self->{'-ptree'};\r
+ for (@$ptree) {\r
+ next unless (length and ref and ref ne 'SCALAR');\r
+ $_->_unset_child2parent_links()\r
+ if UNIVERSAL::isa($_, 'Pod::InteriorSequence');\r
+ }\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head2 $pod_seq-E<gt>B<prepend()>\r
+\r
+ $pod_seq->prepend($text);\r
+ $pod_seq1->prepend($pod_seq2);\r
+\r
+Prepends the given string or parse-tree or sequence object to the parse-tree\r
+of this interior sequence.\r
+\r
+=cut\r
+\r
+sub prepend {\r
+ my $self = shift;\r
+ $self->{'-ptree'}->prepend(@_);\r
+ _set_child2parent_links($self, @_);\r
+ return $self;\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head2 $pod_seq-E<gt>B<append()>\r
+\r
+ $pod_seq->append($text);\r
+ $pod_seq1->append($pod_seq2);\r
+\r
+Appends the given string or parse-tree or sequence object to the parse-tree\r
+of this interior sequence.\r
+\r
+=cut\r
+\r
+sub append {\r
+ my $self = shift;\r
+ $self->{'-ptree'}->append(@_);\r
+ _set_child2parent_links($self, @_);\r
+ return $self;\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head2 $pod_seq-E<gt>B<nested()>\r
+\r
+ $outer_seq = $pod_seq->nested || print "not nested";\r
+\r
+If this interior sequence is nested inside of another interior\r
+sequence, then the outer/parent sequence that contains it is\r
+returned. Otherwise C<undef> is returned.\r
+\r
+=cut\r
+\r
+sub nested {\r
+ my $self = shift;\r
+ (@_ == 1) and $self->{'-parent_sequence'} = shift;\r
+ return $self->{'-parent_sequence'} || undef;\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head2 $pod_seq-E<gt>B<raw_text()>\r
+\r
+ my $seq_raw_text = $pod_seq->raw_text();\r
+\r
+This method will return the I<raw> text of the POD interior sequence,\r
+exactly as it appeared in the input.\r
+\r
+=cut\r
+\r
+sub raw_text {\r
+ my $self = shift;\r
+ my $text = $self->{'-name'} . $self->{'-ldelim'};\r
+ for ( $self->{'-ptree'}->children ) {\r
+ $text .= (ref $_) ? $_->raw_text : $_;\r
+ }\r
+ $text .= $self->{'-rdelim'};\r
+ return $text;\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head2 $pod_seq-E<gt>B<left_delimiter()>\r
+\r
+ my $ldelim = $pod_seq->left_delimiter();\r
+\r
+The leftmost delimiter beginning the argument text to the interior\r
+sequence (should be "<").\r
+\r
+=cut\r
+\r
+sub left_delimiter {\r
+ (@_ > 1) and $_[0]->{'-ldelim'} = $_[1];\r
+ return $_[0]->{'-ldelim'};\r
+}\r
+\r
+## let ldelim() be an alias for left_delimiter()\r
+*ldelim = \&left_delimiter;\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head2 $pod_seq-E<gt>B<right_delimiter()>\r
+\r
+The rightmost delimiter beginning the argument text to the interior\r
+sequence (should be ">").\r
+\r
+=cut\r
+\r
+sub right_delimiter {\r
+ (@_ > 1) and $_[0]->{'-rdelim'} = $_[1];\r
+ return $_[0]->{'-rdelim'};\r
+}\r
+\r
+## let rdelim() be an alias for right_delimiter()\r
+*rdelim = \&right_delimiter;\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head2 $pod_seq-E<gt>B<parse_tree()>\r
+\r
+ my $ptree = $pod_parser->parse_text($paragraph_text);\r
+ $pod_seq->parse_tree( $ptree );\r
+ $ptree = $pod_seq->parse_tree();\r
+\r
+This method will get/set the corresponding parse-tree of the interior\r
+sequence's text.\r
+\r
+=cut\r
+\r
+sub parse_tree {\r
+ (@_ > 1) and $_[0]->{'-ptree'} = $_[1];\r
+ return $_[0]->{'-ptree'};\r
+}\r
+\r
+## let ptree() be an alias for parse_tree()\r
+*ptree = \&parse_tree;\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head2 $pod_seq-E<gt>B<file_line()>\r
+\r
+ my ($filename, $line_number) = $pod_seq->file_line();\r
+ my $position = $pod_seq->file_line();\r
+\r
+Returns the current filename and line number for the interior sequence\r
+object. If called in a list context, it returns a list of two\r
+elements: first the filename, then the line number. If called in\r
+a scalar context, it returns a string containing the filename, followed\r
+by a colon (':'), followed by the line number.\r
+\r
+=cut\r
+\r
+sub file_line {\r
+ my @loc = ($_[0]->{'-file'} || '<unknown-file>',\r
+ $_[0]->{'-line'} || 0);\r
+ return (wantarray) ? @loc : join(':', @loc);\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head2 Pod::InteriorSequence::B<DESTROY()>\r
+\r
+This method performs any necessary cleanup for the interior-sequence.\r
+If you override this method then it is B<imperative> that you invoke\r
+the parent method from within your own method, otherwise\r
+I<interior-sequence storage will not be reclaimed upon destruction!>\r
+\r
+=cut\r
+\r
+sub DESTROY {\r
+ ## We need to get rid of all child->parent pointers throughout the\r
+ ## tree so their reference counts will go to zero and they can be\r
+ ## garbage-collected\r
+ _unset_child2parent_links(@_);\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+#############################################################################\r
+\r
+package Pod::ParseTree;\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head1 B<Pod::ParseTree>\r
+\r
+This object corresponds to a tree of parsed POD text. As POD text is\r
+scanned from left to right, it is parsed into an ordered list of\r
+text-strings and B<Pod::InteriorSequence> objects (in order of\r
+appearance). A B<Pod::ParseTree> object corresponds to this list of\r
+strings and sequences. Each interior sequence in the parse-tree may\r
+itself contain a parse-tree (since interior sequences may be nested).\r
+\r
+=cut\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head2 Pod::ParseTree-E<gt>B<new()>\r
+\r
+ my $ptree1 = Pod::ParseTree->new;\r
+ my $ptree2 = new Pod::ParseTree;\r
+ my $ptree4 = Pod::ParseTree->new($array_ref);\r
+ my $ptree3 = new Pod::ParseTree($array_ref);\r
+\r
+This is a class method that constructs a C<Pod::Parse_tree> object and\r
+returns a reference to the new parse-tree. If a single-argument is given,\r
+it must be a reference to an array, and is used to initialize the root\r
+(top) of the parse tree.\r
+\r
+=cut\r
+\r
+sub new {\r
+ ## Determine if we were called via an object-ref or a classname\r
+ my $this = shift;\r
+ my $class = ref($this) || $this;\r
+\r
+ my $self = (@_ == 1 and ref $_[0]) ? $_[0] : [];\r
+\r
+ ## Bless ourselves into the desired class and perform any initialization\r
+ bless $self, $class;\r
+ return $self;\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head2 $ptree-E<gt>B<top()>\r
+\r
+ my $top_node = $ptree->top();\r
+ $ptree->top( $top_node );\r
+ $ptree->top( @children );\r
+\r
+This method gets/sets the top node of the parse-tree. If no arguments are\r
+given, it returns the topmost node in the tree (the root), which is also\r
+a B<Pod::ParseTree>. If it is given a single argument that is a reference,\r
+then the reference is assumed to a parse-tree and becomes the new top node.\r
+Otherwise, if arguments are given, they are treated as the new list of\r
+children for the top node.\r
+\r
+=cut\r
+\r
+sub top {\r
+ my $self = shift;\r
+ if (@_ > 0) {\r
+ @{ $self } = (@_ == 1 and ref $_[0]) ? ${ @_ } : @_;\r
+ }\r
+ return $self;\r
+}\r
+\r
+## let parse_tree() & ptree() be aliases for the 'top' method\r
+*parse_tree = *ptree = \⊤\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head2 $ptree-E<gt>B<children()>\r
+\r
+This method gets/sets the children of the top node in the parse-tree.\r
+If no arguments are given, it returns the list (array) of children\r
+(each of which should be either a string or a B<Pod::InteriorSequence>.\r
+Otherwise, if arguments are given, they are treated as the new list of\r
+children for the top node.\r
+\r
+=cut\r
+\r
+sub children {\r
+ my $self = shift;\r
+ if (@_ > 0) {\r
+ @{ $self } = (@_ == 1 and ref $_[0]) ? ${ @_ } : @_;\r
+ }\r
+ return @{ $self };\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head2 $ptree-E<gt>B<prepend()>\r
+\r
+This method prepends the given text or parse-tree to the current parse-tree.\r
+If the first item on the parse-tree is text and the argument is also text,\r
+then the text is prepended to the first item (not added as a separate string).\r
+Otherwise the argument is added as a new string or parse-tree I<before>\r
+the current one.\r
+\r
+=cut\r
+\r
+use vars qw(@ptree); ## an alias used for performance reasons\r
+\r
+sub prepend {\r
+ my $self = shift;\r
+ local *ptree = $self;\r
+ for (@_) {\r
+ next unless length;\r
+ if (@ptree && !(ref $ptree[0]) && !(ref $_)) {\r
+ $ptree[0] = $_ . $ptree[0];\r
+ }\r
+ else {\r
+ unshift @ptree, $_;\r
+ }\r
+ }\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head2 $ptree-E<gt>B<append()>\r
+\r
+This method appends the given text or parse-tree to the current parse-tree.\r
+If the last item on the parse-tree is text and the argument is also text,\r
+then the text is appended to the last item (not added as a separate string).\r
+Otherwise the argument is added as a new string or parse-tree I<after>\r
+the current one.\r
+\r
+=cut\r
+\r
+sub append {\r
+ my $self = shift;\r
+ local *ptree = $self;\r
+ my $can_append = @ptree && !(ref $ptree[-1]);\r
+ for (@_) {\r
+ if (ref) {\r
+ push @ptree, $_;\r
+ }\r
+ elsif(!length) {\r
+ next;\r
+ }\r
+ elsif ($can_append) {\r
+ $ptree[-1] .= $_;\r
+ }\r
+ else {\r
+ push @ptree, $_;\r
+ }\r
+ }\r
+}\r
+\r
+=head2 $ptree-E<gt>B<raw_text()>\r
+\r
+ my $ptree_raw_text = $ptree->raw_text();\r
+\r
+This method will return the I<raw> text of the POD parse-tree\r
+exactly as it appeared in the input.\r
+\r
+=cut\r
+\r
+sub raw_text {\r
+ my $self = shift;\r
+ my $text = '';\r
+ for ( @$self ) {\r
+ $text .= (ref $_) ? $_->raw_text : $_;\r
+ }\r
+ return $text;\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+## Private routines to set/unset child->parent links\r
+\r
+sub _unset_child2parent_links {\r
+ my $self = shift;\r
+ local *ptree = $self;\r
+ for (@ptree) {\r
+ next unless (defined and length and ref and ref ne 'SCALAR');\r
+ $_->_unset_child2parent_links()\r
+ if UNIVERSAL::isa($_, 'Pod::InteriorSequence');\r
+ }\r
+}\r
+\r
+sub _set_child2parent_links {\r
+ ## nothing to do, Pod::ParseTrees cant have parent pointers\r
+}\r
+\r
+=head2 Pod::ParseTree::B<DESTROY()>\r
+\r
+This method performs any necessary cleanup for the parse-tree.\r
+If you override this method then it is B<imperative>\r
+that you invoke the parent method from within your own method,\r
+otherwise I<parse-tree storage will not be reclaimed upon destruction!>\r
+\r
+=cut\r
+\r
+sub DESTROY {\r
+ ## We need to get rid of all child->parent pointers throughout the\r
+ ## tree so their reference counts will go to zero and they can be\r
+ ## garbage-collected\r
+ _unset_child2parent_links(@_);\r
+}\r
+\r
+#############################################################################\r
+\r
+=head1 SEE ALSO\r
+\r
+B<Pod::InputObjects> is part of the L<Pod::Parser> distribution.\r
+\r
+See L<Pod::Parser>, L<Pod::Select>\r
+\r
+=head1 AUTHOR\r
+\r
+Please report bugs using L<http://rt.cpan.org>.\r
+\r
+Brad Appleton E<lt>bradapp@enteract.comE<gt>\r
+\r
+=cut\r
+\r
+1;\r
--- /dev/null
+#############################################################################\r
+# Pod/Parser.pm -- package which defines a base class for parsing POD docs.\r
+#\r
+# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved.\r
+# This file is part of "PodParser". PodParser is free software;\r
+# you can redistribute it and/or modify it under the same terms\r
+# as Perl itself.\r
+#############################################################################\r
+\r
+package Pod::Parser;\r
+use strict;\r
+\r
+## These "variables" are used as local "glob aliases" for performance\r
+use vars qw($VERSION @ISA %myData %myOpts @input_stack);\r
+$VERSION = '1.60'; ## Current version of this package\r
+require 5.005; ## requires this Perl version or later\r
+\r
+#############################################################################\r
+\r
+=head1 NAME\r
+\r
+Pod::Parser - base class for creating POD filters and translators\r
+\r
+=head1 SYNOPSIS\r
+\r
+ use Pod::Parser;\r
+\r
+ package MyParser;\r
+ @ISA = qw(Pod::Parser);\r
+\r
+ sub command { \r
+ my ($parser, $command, $paragraph, $line_num) = @_;\r
+ ## Interpret the command and its text; sample actions might be:\r
+ if ($command eq 'head1') { ... }\r
+ elsif ($command eq 'head2') { ... }\r
+ ## ... other commands and their actions\r
+ my $out_fh = $parser->output_handle();\r
+ my $expansion = $parser->interpolate($paragraph, $line_num);\r
+ print $out_fh $expansion;\r
+ }\r
+\r
+ sub verbatim { \r
+ my ($parser, $paragraph, $line_num) = @_;\r
+ ## Format verbatim paragraph; sample actions might be:\r
+ my $out_fh = $parser->output_handle();\r
+ print $out_fh $paragraph;\r
+ }\r
+\r
+ sub textblock { \r
+ my ($parser, $paragraph, $line_num) = @_;\r
+ ## Translate/Format this block of text; sample actions might be:\r
+ my $out_fh = $parser->output_handle();\r
+ my $expansion = $parser->interpolate($paragraph, $line_num);\r
+ print $out_fh $expansion;\r
+ }\r
+\r
+ sub interior_sequence { \r
+ my ($parser, $seq_command, $seq_argument) = @_;\r
+ ## Expand an interior sequence; sample actions might be:\r
+ return "*$seq_argument*" if ($seq_command eq 'B');\r
+ return "`$seq_argument'" if ($seq_command eq 'C');\r
+ return "_${seq_argument}_'" if ($seq_command eq 'I');\r
+ ## ... other sequence commands and their resulting text\r
+ }\r
+\r
+ package main;\r
+\r
+ ## Create a parser object and have it parse file whose name was\r
+ ## given on the command-line (use STDIN if no files were given).\r
+ $parser = new MyParser();\r
+ $parser->parse_from_filehandle(\*STDIN) if (@ARGV == 0);\r
+ for (@ARGV) { $parser->parse_from_file($_); }\r
+\r
+=head1 REQUIRES\r
+\r
+perl5.005, Pod::InputObjects, Exporter, Symbol, Carp\r
+\r
+=head1 EXPORTS\r
+\r
+Nothing.\r
+\r
+=head1 DESCRIPTION\r
+\r
+B<Pod::Parser> is a base class for creating POD filters and translators.\r
+It handles most of the effort involved with parsing the POD sections\r
+from an input stream, leaving subclasses free to be concerned only with\r
+performing the actual translation of text.\r
+\r
+B<Pod::Parser> parses PODs, and makes method calls to handle the various\r
+components of the POD. Subclasses of B<Pod::Parser> override these methods\r
+to translate the POD into whatever output format they desire.\r
+\r
+Note: This module is considered as legacy; modern Perl releases (5.18 and\r
+higher) are going to remove Pod::Parser from core and use L<Pod::Simple>\r
+for all things POD.\r
+\r
+=head1 QUICK OVERVIEW\r
+\r
+To create a POD filter for translating POD documentation into some other\r
+format, you create a subclass of B<Pod::Parser> which typically overrides\r
+just the base class implementation for the following methods:\r
+\r
+=over 2\r
+\r
+=item *\r
+\r
+B<command()>\r
+\r
+=item *\r
+\r
+B<verbatim()>\r
+\r
+=item *\r
+\r
+B<textblock()>\r
+\r
+=item *\r
+\r
+B<interior_sequence()>\r
+\r
+=back\r
+\r
+You may also want to override the B<begin_input()> and B<end_input()>\r
+methods for your subclass (to perform any needed per-file and/or\r
+per-document initialization or cleanup).\r
+\r
+If you need to perform any preprocessing of input before it is parsed\r
+you may want to override one or more of B<preprocess_line()> and/or\r
+B<preprocess_paragraph()>.\r
+\r
+Sometimes it may be necessary to make more than one pass over the input\r
+files. If this is the case you have several options. You can make the\r
+first pass using B<Pod::Parser> and override your methods to store the\r
+intermediate results in memory somewhere for the B<end_pod()> method to\r
+process. You could use B<Pod::Parser> for several passes with an\r
+appropriate state variable to control the operation for each pass. If\r
+your input source can't be reset to start at the beginning, you can\r
+store it in some other structure as a string or an array and have that\r
+structure implement a B<getline()> method (which is all that\r
+B<parse_from_filehandle()> uses to read input).\r
+\r
+Feel free to add any member data fields you need to keep track of things\r
+like current font, indentation, horizontal or vertical position, or\r
+whatever else you like. Be sure to read L<"PRIVATE METHODS AND DATA">\r
+to avoid name collisions.\r
+\r
+For the most part, the B<Pod::Parser> base class should be able to\r
+do most of the input parsing for you and leave you free to worry about\r
+how to interpret the commands and translate the result.\r
+\r
+Note that all we have described here in this quick overview is the\r
+simplest most straightforward use of B<Pod::Parser> to do stream-based\r
+parsing. It is also possible to use the B<Pod::Parser::parse_text> function\r
+to do more sophisticated tree-based parsing. See L<"TREE-BASED PARSING">.\r
+\r
+=head1 PARSING OPTIONS\r
+\r
+A I<parse-option> is simply a named option of B<Pod::Parser> with a\r
+value that corresponds to a certain specified behavior. These various\r
+behaviors of B<Pod::Parser> may be enabled/disabled by setting\r
+or unsetting one or more I<parse-options> using the B<parseopts()> method.\r
+The set of currently accepted parse-options is as follows:\r
+\r
+=over 3\r
+\r
+=item B<-want_nonPODs> (default: unset)\r
+\r
+Normally (by default) B<Pod::Parser> will only provide access to\r
+the POD sections of the input. Input paragraphs that are not part\r
+of the POD-format documentation are not made available to the caller\r
+(not even using B<preprocess_paragraph()>). Setting this option to a\r
+non-empty, non-zero value will allow B<preprocess_paragraph()> to see\r
+non-POD sections of the input as well as POD sections. The B<cutting()>\r
+method can be used to determine if the corresponding paragraph is a POD\r
+paragraph, or some other input paragraph.\r
+\r
+=item B<-process_cut_cmd> (default: unset)\r
+\r
+Normally (by default) B<Pod::Parser> handles the C<=cut> POD directive\r
+by itself and does not pass it on to the caller for processing. Setting\r
+this option to a non-empty, non-zero value will cause B<Pod::Parser> to\r
+pass the C<=cut> directive to the caller just like any other POD command\r
+(and hence it may be processed by the B<command()> method).\r
+\r
+B<Pod::Parser> will still interpret the C<=cut> directive to mean that\r
+"cutting mode" has been (re)entered, but the caller will get a chance\r
+to capture the actual C<=cut> paragraph itself for whatever purpose\r
+it desires.\r
+\r
+=item B<-warnings> (default: unset)\r
+\r
+Normally (by default) B<Pod::Parser> recognizes a bare minimum of\r
+pod syntax errors and warnings and issues diagnostic messages\r
+for errors, but not for warnings. (Use B<Pod::Checker> to do more\r
+thorough checking of POD syntax.) Setting this option to a non-empty,\r
+non-zero value will cause B<Pod::Parser> to issue diagnostics for\r
+the few warnings it recognizes as well as the errors.\r
+\r
+=back\r
+\r
+Please see L<"parseopts()"> for a complete description of the interface\r
+for the setting and unsetting of parse-options.\r
+\r
+=cut\r
+\r
+#############################################################################\r
+\r
+#use diagnostics;\r
+use Pod::InputObjects;\r
+use Carp;\r
+use Exporter;\r
+BEGIN {\r
+ if ($] < 5.006) {\r
+ require Symbol;\r
+ import Symbol;\r
+ }\r
+}\r
+@ISA = qw(Exporter);\r
+\r
+#############################################################################\r
+\r
+=head1 RECOMMENDED SUBROUTINE/METHOD OVERRIDES\r
+\r
+B<Pod::Parser> provides several methods which most subclasses will probably\r
+want to override. These methods are as follows:\r
+\r
+=cut\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head1 B<command()>\r
+\r
+ $parser->command($cmd,$text,$line_num,$pod_para);\r
+\r
+This method should be overridden by subclasses to take the appropriate\r
+action when a POD command paragraph (denoted by a line beginning with\r
+"=") is encountered. When such a POD directive is seen in the input,\r
+this method is called and is passed:\r
+\r
+=over 3\r
+\r
+=item C<$cmd>\r
+\r
+the name of the command for this POD paragraph\r
+\r
+=item C<$text>\r
+\r
+the paragraph text for the given POD paragraph command.\r
+\r
+=item C<$line_num>\r
+\r
+the line-number of the beginning of the paragraph\r
+\r
+=item C<$pod_para>\r
+\r
+a reference to a C<Pod::Paragraph> object which contains further\r
+information about the paragraph command (see L<Pod::InputObjects>\r
+for details).\r
+\r
+=back\r
+\r
+B<Note> that this method I<is> called for C<=pod> paragraphs.\r
+\r
+The base class implementation of this method simply treats the raw POD\r
+command as normal block of paragraph text (invoking the B<textblock()>\r
+method with the command paragraph).\r
+\r
+=cut\r
+\r
+sub command {\r
+ my ($self, $cmd, $text, $line_num, $pod_para) = @_;\r
+ ## Just treat this like a textblock\r
+ $self->textblock($pod_para->raw_text(), $line_num, $pod_para);\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head1 B<verbatim()>\r
+\r
+ $parser->verbatim($text,$line_num,$pod_para);\r
+\r
+This method may be overridden by subclasses to take the appropriate\r
+action when a block of verbatim text is encountered. It is passed the\r
+following parameters:\r
+\r
+=over 3\r
+\r
+=item C<$text>\r
+\r
+the block of text for the verbatim paragraph\r
+\r
+=item C<$line_num>\r
+\r
+the line-number of the beginning of the paragraph\r
+\r
+=item C<$pod_para>\r
+\r
+a reference to a C<Pod::Paragraph> object which contains further\r
+information about the paragraph (see L<Pod::InputObjects>\r
+for details).\r
+\r
+=back\r
+\r
+The base class implementation of this method simply prints the textblock\r
+(unmodified) to the output filehandle.\r
+\r
+=cut\r
+\r
+sub verbatim {\r
+ my ($self, $text, $line_num, $pod_para) = @_;\r
+ my $out_fh = $self->{_OUTPUT};\r
+ print $out_fh $text;\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head1 B<textblock()>\r
+\r
+ $parser->textblock($text,$line_num,$pod_para);\r
+\r
+This method may be overridden by subclasses to take the appropriate\r
+action when a normal block of POD text is encountered (although the base\r
+class method will usually do what you want). It is passed the following\r
+parameters:\r
+\r
+=over 3\r
+\r
+=item C<$text>\r
+\r
+the block of text for the a POD paragraph\r
+\r
+=item C<$line_num>\r
+\r
+the line-number of the beginning of the paragraph\r
+\r
+=item C<$pod_para>\r
+\r
+a reference to a C<Pod::Paragraph> object which contains further\r
+information about the paragraph (see L<Pod::InputObjects>\r
+for details).\r
+\r
+=back\r
+\r
+In order to process interior sequences, subclasses implementations of\r
+this method will probably want to invoke either B<interpolate()> or\r
+B<parse_text()>, passing it the text block C<$text>, and the corresponding\r
+line number in C<$line_num>, and then perform any desired processing upon\r
+the returned result.\r
+\r
+The base class implementation of this method simply prints the text block\r
+as it occurred in the input stream).\r
+\r
+=cut\r
+\r
+sub textblock {\r
+ my ($self, $text, $line_num, $pod_para) = @_;\r
+ my $out_fh = $self->{_OUTPUT};\r
+ print $out_fh $self->interpolate($text, $line_num);\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head1 B<interior_sequence()>\r
+\r
+ $parser->interior_sequence($seq_cmd,$seq_arg,$pod_seq);\r
+\r
+This method should be overridden by subclasses to take the appropriate\r
+action when an interior sequence is encountered. An interior sequence is\r
+an embedded command within a block of text which appears as a command\r
+name (usually a single uppercase character) followed immediately by a\r
+string of text which is enclosed in angle brackets. This method is\r
+passed the sequence command C<$seq_cmd> and the corresponding text\r
+C<$seq_arg>. It is invoked by the B<interpolate()> method for each interior\r
+sequence that occurs in the string that it is passed. It should return\r
+the desired text string to be used in place of the interior sequence.\r
+The C<$pod_seq> argument is a reference to a C<Pod::InteriorSequence>\r
+object which contains further information about the interior sequence.\r
+Please see L<Pod::InputObjects> for details if you need to access this\r
+additional information.\r
+\r
+Subclass implementations of this method may wish to invoke the \r
+B<nested()> method of C<$pod_seq> to see if it is nested inside\r
+some other interior-sequence (and if so, which kind).\r
+\r
+The base class implementation of the B<interior_sequence()> method\r
+simply returns the raw text of the interior sequence (as it occurred\r
+in the input) to the caller.\r
+\r
+=cut\r
+\r
+sub interior_sequence {\r
+ my ($self, $seq_cmd, $seq_arg, $pod_seq) = @_;\r
+ ## Just return the raw text of the interior sequence\r
+ return $pod_seq->raw_text();\r
+}\r
+\r
+#############################################################################\r
+\r
+=head1 OPTIONAL SUBROUTINE/METHOD OVERRIDES\r
+\r
+B<Pod::Parser> provides several methods which subclasses may want to override\r
+to perform any special pre/post-processing. These methods do I<not> have to\r
+be overridden, but it may be useful for subclasses to take advantage of them.\r
+\r
+=cut\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head1 B<new()>\r
+\r
+ my $parser = Pod::Parser->new();\r
+\r
+This is the constructor for B<Pod::Parser> and its subclasses. You\r
+I<do not> need to override this method! It is capable of constructing\r
+subclass objects as well as base class objects, provided you use\r
+any of the following constructor invocation styles:\r
+\r
+ my $parser1 = MyParser->new();\r
+ my $parser2 = new MyParser();\r
+ my $parser3 = $parser2->new();\r
+\r
+where C<MyParser> is some subclass of B<Pod::Parser>.\r
+\r
+Using the syntax C<MyParser::new()> to invoke the constructor is I<not>\r
+recommended, but if you insist on being able to do this, then the\r
+subclass I<will> need to override the B<new()> constructor method. If\r
+you do override the constructor, you I<must> be sure to invoke the\r
+B<initialize()> method of the newly blessed object.\r
+\r
+Using any of the above invocations, the first argument to the\r
+constructor is always the corresponding package name (or object\r
+reference). No other arguments are required, but if desired, an\r
+associative array (or hash-table) my be passed to the B<new()>\r
+constructor, as in:\r
+\r
+ my $parser1 = MyParser->new( MYDATA => $value1, MOREDATA => $value2 );\r
+ my $parser2 = new MyParser( -myflag => 1 );\r
+\r
+All arguments passed to the B<new()> constructor will be treated as\r
+key/value pairs in a hash-table. The newly constructed object will be\r
+initialized by copying the contents of the given hash-table (which may\r
+have been empty). The B<new()> constructor for this class and all of its\r
+subclasses returns a blessed reference to the initialized object (hash-table).\r
+\r
+=cut\r
+\r
+sub new {\r
+ ## Determine if we were called via an object-ref or a classname\r
+ my ($this,%params) = @_;\r
+ my $class = ref($this) || $this;\r
+ ## Any remaining arguments are treated as initial values for the\r
+ ## hash that is used to represent this object.\r
+ my $self = { %params };\r
+ ## Bless ourselves into the desired class and perform any initialization\r
+ bless $self, $class;\r
+ $self->initialize();\r
+ return $self;\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head1 B<initialize()>\r
+\r
+ $parser->initialize();\r
+\r
+This method performs any necessary object initialization. It takes no\r
+arguments (other than the object instance of course, which is typically\r
+copied to a local variable named C<$self>). If subclasses override this\r
+method then they I<must> be sure to invoke C<$self-E<gt>SUPER::initialize()>.\r
+\r
+=cut\r
+\r
+sub initialize {\r
+ #my $self = shift;\r
+ #return;\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head1 B<begin_pod()>\r
+\r
+ $parser->begin_pod();\r
+\r
+This method is invoked at the beginning of processing for each POD\r
+document that is encountered in the input. Subclasses should override\r
+this method to perform any per-document initialization.\r
+\r
+=cut\r
+\r
+sub begin_pod {\r
+ #my $self = shift;\r
+ #return;\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head1 B<begin_input()>\r
+\r
+ $parser->begin_input();\r
+\r
+This method is invoked by B<parse_from_filehandle()> immediately I<before>\r
+processing input from a filehandle. The base class implementation does\r
+nothing, however, subclasses may override it to perform any per-file\r
+initializations.\r
+\r
+Note that if multiple files are parsed for a single POD document\r
+(perhaps the result of some future C<=include> directive) this method\r
+is invoked for every file that is parsed. If you wish to perform certain\r
+initializations once per document, then you should use B<begin_pod()>.\r
+\r
+=cut\r
+\r
+sub begin_input {\r
+ #my $self = shift;\r
+ #return;\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head1 B<end_input()>\r
+\r
+ $parser->end_input();\r
+\r
+This method is invoked by B<parse_from_filehandle()> immediately I<after>\r
+processing input from a filehandle. The base class implementation does\r
+nothing, however, subclasses may override it to perform any per-file\r
+cleanup actions.\r
+\r
+Please note that if multiple files are parsed for a single POD document\r
+(perhaps the result of some kind of C<=include> directive) this method\r
+is invoked for every file that is parsed. If you wish to perform certain\r
+cleanup actions once per document, then you should use B<end_pod()>.\r
+\r
+=cut\r
+\r
+sub end_input {\r
+ #my $self = shift;\r
+ #return;\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head1 B<end_pod()>\r
+\r
+ $parser->end_pod();\r
+\r
+This method is invoked at the end of processing for each POD document\r
+that is encountered in the input. Subclasses should override this method\r
+to perform any per-document finalization.\r
+\r
+=cut\r
+\r
+sub end_pod {\r
+ #my $self = shift;\r
+ #return;\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head1 B<preprocess_line()>\r
+\r
+ $textline = $parser->preprocess_line($text, $line_num);\r
+\r
+This method should be overridden by subclasses that wish to perform\r
+any kind of preprocessing for each I<line> of input (I<before> it has\r
+been determined whether or not it is part of a POD paragraph). The\r
+parameter C<$text> is the input line; and the parameter C<$line_num> is\r
+the line number of the corresponding text line.\r
+\r
+The value returned should correspond to the new text to use in its\r
+place. If the empty string or an undefined value is returned then no\r
+further processing will be performed for this line.\r
+\r
+Please note that the B<preprocess_line()> method is invoked I<before>\r
+the B<preprocess_paragraph()> method. After all (possibly preprocessed)\r
+lines in a paragraph have been assembled together and it has been\r
+determined that the paragraph is part of the POD documentation from one\r
+of the selected sections, then B<preprocess_paragraph()> is invoked.\r
+\r
+The base class implementation of this method returns the given text.\r
+\r
+=cut\r
+\r
+sub preprocess_line {\r
+ my ($self, $text, $line_num) = @_;\r
+ return $text;\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head1 B<preprocess_paragraph()>\r
+\r
+ $textblock = $parser->preprocess_paragraph($text, $line_num);\r
+\r
+This method should be overridden by subclasses that wish to perform any\r
+kind of preprocessing for each block (paragraph) of POD documentation\r
+that appears in the input stream. The parameter C<$text> is the POD\r
+paragraph from the input file; and the parameter C<$line_num> is the\r
+line number for the beginning of the corresponding paragraph.\r
+\r
+The value returned should correspond to the new text to use in its\r
+place If the empty string is returned or an undefined value is\r
+returned, then the given C<$text> is ignored (not processed).\r
+\r
+This method is invoked after gathering up all the lines in a paragraph\r
+and after determining the cutting state of the paragraph,\r
+but before trying to further parse or interpret them. After\r
+B<preprocess_paragraph()> returns, the current cutting state (which\r
+is returned by C<$self-E<gt>cutting()>) is examined. If it evaluates\r
+to true then input text (including the given C<$text>) is cut (not\r
+processed) until the next POD directive is encountered.\r
+\r
+Please note that the B<preprocess_line()> method is invoked I<before>\r
+the B<preprocess_paragraph()> method. After all (possibly preprocessed)\r
+lines in a paragraph have been assembled together and either it has been\r
+determined that the paragraph is part of the POD documentation from one\r
+of the selected sections or the C<-want_nonPODs> option is true,\r
+then B<preprocess_paragraph()> is invoked.\r
+\r
+The base class implementation of this method returns the given text.\r
+\r
+=cut\r
+\r
+sub preprocess_paragraph {\r
+ my ($self, $text, $line_num) = @_;\r
+ return $text;\r
+}\r
+\r
+#############################################################################\r
+\r
+=head1 METHODS FOR PARSING AND PROCESSING\r
+\r
+B<Pod::Parser> provides several methods to process input text. These\r
+methods typically won't need to be overridden (and in some cases they\r
+can't be overridden), but subclasses may want to invoke them to exploit\r
+their functionality.\r
+\r
+=cut\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head1 B<parse_text()>\r
+\r
+ $ptree1 = $parser->parse_text($text, $line_num);\r
+ $ptree2 = $parser->parse_text({%opts}, $text, $line_num);\r
+ $ptree3 = $parser->parse_text(\%opts, $text, $line_num);\r
+\r
+This method is useful if you need to perform your own interpolation \r
+of interior sequences and can't rely upon B<interpolate> to expand\r
+them in simple bottom-up order.\r
+\r
+The parameter C<$text> is a string or block of text to be parsed\r
+for interior sequences; and the parameter C<$line_num> is the\r
+line number corresponding to the beginning of C<$text>.\r
+\r
+B<parse_text()> will parse the given text into a parse-tree of "nodes."\r
+and interior-sequences. Each "node" in the parse tree is either a\r
+text-string, or a B<Pod::InteriorSequence>. The result returned is a\r
+parse-tree of type B<Pod::ParseTree>. Please see L<Pod::InputObjects>\r
+for more information about B<Pod::InteriorSequence> and B<Pod::ParseTree>.\r
+\r
+If desired, an optional hash-ref may be specified as the first argument\r
+to customize certain aspects of the parse-tree that is created and\r
+returned. The set of recognized option keywords are:\r
+\r
+=over 3\r
+\r
+=item B<-expand_seq> =E<gt> I<code-ref>|I<method-name>\r
+\r
+Normally, the parse-tree returned by B<parse_text()> will contain an\r
+unexpanded C<Pod::InteriorSequence> object for each interior-sequence\r
+encountered. Specifying B<-expand_seq> tells B<parse_text()> to "expand"\r
+every interior-sequence it sees by invoking the referenced function\r
+(or named method of the parser object) and using the return value as the\r
+expanded result.\r
+\r
+If a subroutine reference was given, it is invoked as:\r
+\r
+ &$code_ref( $parser, $sequence )\r
+\r
+and if a method-name was given, it is invoked as:\r
+\r
+ $parser->method_name( $sequence )\r
+\r
+where C<$parser> is a reference to the parser object, and C<$sequence>\r
+is a reference to the interior-sequence object.\r
+[I<NOTE>: If the B<interior_sequence()> method is specified, then it is\r
+invoked according to the interface specified in L<"interior_sequence()">].\r
+\r
+=item B<-expand_text> =E<gt> I<code-ref>|I<method-name>\r
+\r
+Normally, the parse-tree returned by B<parse_text()> will contain a\r
+text-string for each contiguous sequence of characters outside of an\r
+interior-sequence. Specifying B<-expand_text> tells B<parse_text()> to\r
+"preprocess" every such text-string it sees by invoking the referenced\r
+function (or named method of the parser object) and using the return value\r
+as the preprocessed (or "expanded") result. [Note that if the result is\r
+an interior-sequence, then it will I<not> be expanded as specified by the\r
+B<-expand_seq> option; Any such recursive expansion needs to be handled by\r
+the specified callback routine.]\r
+\r
+If a subroutine reference was given, it is invoked as:\r
+\r
+ &$code_ref( $parser, $text, $ptree_node )\r
+\r
+and if a method-name was given, it is invoked as:\r
+\r
+ $parser->method_name( $text, $ptree_node )\r
+\r
+where C<$parser> is a reference to the parser object, C<$text> is the\r
+text-string encountered, and C<$ptree_node> is a reference to the current\r
+node in the parse-tree (usually an interior-sequence object or else the\r
+top-level node of the parse-tree).\r
+\r
+=item B<-expand_ptree> =E<gt> I<code-ref>|I<method-name>\r
+\r
+Rather than returning a C<Pod::ParseTree>, pass the parse-tree as an\r
+argument to the referenced subroutine (or named method of the parser\r
+object) and return the result instead of the parse-tree object.\r
+\r
+If a subroutine reference was given, it is invoked as:\r
+\r
+ &$code_ref( $parser, $ptree )\r
+\r
+and if a method-name was given, it is invoked as:\r
+\r
+ $parser->method_name( $ptree )\r
+\r
+where C<$parser> is a reference to the parser object, and C<$ptree>\r
+is a reference to the parse-tree object.\r
+\r
+=back\r
+\r
+=cut\r
+\r
+sub parse_text {\r
+ my $self = shift;\r
+ local $_ = '';\r
+\r
+ ## Get options and set any defaults\r
+ my %opts = (ref $_[0]) ? %{ shift() } : ();\r
+ my $expand_seq = $opts{'-expand_seq'} || undef;\r
+ my $expand_text = $opts{'-expand_text'} || undef;\r
+ my $expand_ptree = $opts{'-expand_ptree'} || undef;\r
+\r
+ my $text = shift;\r
+ my $line = shift;\r
+ my $file = $self->input_file();\r
+ my $cmd = "";\r
+\r
+ ## Convert method calls into closures, for our convenience\r
+ my $xseq_sub = $expand_seq;\r
+ my $xtext_sub = $expand_text;\r
+ my $xptree_sub = $expand_ptree;\r
+ if (defined $expand_seq and $expand_seq eq 'interior_sequence') {\r
+ ## If 'interior_sequence' is the method to use, we have to pass\r
+ ## more than just the sequence object, we also need to pass the\r
+ ## sequence name and text.\r
+ $xseq_sub = sub {\r
+ my ($sself, $iseq) = @_;\r
+ my $args = join('', $iseq->parse_tree->children);\r
+ return $sself->interior_sequence($iseq->name, $args, $iseq);\r
+ };\r
+ }\r
+ ref $xseq_sub or $xseq_sub = sub { shift()->$expand_seq(@_) };\r
+ ref $xtext_sub or $xtext_sub = sub { shift()->$expand_text(@_) };\r
+ ref $xptree_sub or $xptree_sub = sub { shift()->$expand_ptree(@_) };\r
+\r
+ ## Keep track of the "current" interior sequence, and maintain a stack\r
+ ## of "in progress" sequences.\r
+ ##\r
+ ## NOTE that we push our own "accumulator" at the very beginning of the\r
+ ## stack. It's really a parse-tree, not a sequence; but it implements\r
+ ## the methods we need so we can use it to gather-up all the sequences\r
+ ## and strings we parse. Thus, by the end of our parsing, it should be\r
+ ## the only thing left on our stack and all we have to do is return it!\r
+ ##\r
+ my $seq = Pod::ParseTree->new();\r
+ my @seq_stack = ($seq);\r
+ my ($ldelim, $rdelim) = ('', '');\r
+\r
+ ## Iterate over all sequence starts text (NOTE: split with\r
+ ## capturing parens keeps the delimiters)\r
+ $_ = $text;\r
+ my @tokens = split /([A-Z]<(?:<+(?:\r?\n|[ \t]))?)/;\r
+ while ( @tokens ) {\r
+ $_ = shift @tokens;\r
+ ## Look for the beginning of a sequence\r
+ if ( /^([A-Z])(<(?:<+(?:\r?\n|[ \t]))?)$/ ) {\r
+ ## Push a new sequence onto the stack of those "in-progress"\r
+ my $ldelim_orig;\r
+ ($cmd, $ldelim_orig) = ($1, $2);\r
+ ($ldelim = $ldelim_orig) =~ s/\s+$//;\r
+ ($rdelim = $ldelim) =~ tr/</>/;\r
+ $seq = Pod::InteriorSequence->new(\r
+ -name => $cmd,\r
+ -ldelim => $ldelim_orig, -rdelim => $rdelim,\r
+ -file => $file, -line => $line\r
+ );\r
+ (@seq_stack > 1) and $seq->nested($seq_stack[-1]);\r
+ push @seq_stack, $seq;\r
+ }\r
+ ## Look for sequence ending\r
+ elsif ( @seq_stack > 1 ) {\r
+ ## Make sure we match the right kind of closing delimiter\r
+ my ($seq_end, $post_seq) = ('', '');\r
+ if ( ($ldelim eq '<' and /\A(.*?)(>)/s)\r
+ or /\A(.*?)(\s+$rdelim)/s )\r
+ {\r
+ ## Found end-of-sequence, capture the interior and the\r
+ ## closing the delimiter, and put the rest back on the\r
+ ## token-list\r
+ $post_seq = substr($_, length($1) + length($2));\r
+ ($_, $seq_end) = ($1, $2);\r
+ (length $post_seq) and unshift @tokens, $post_seq;\r
+ }\r
+ if (length) {\r
+ ## In the middle of a sequence, append this text to it, and\r
+ ## dont forget to "expand" it if that's what the caller wanted\r
+ $seq->append($expand_text ? &$xtext_sub($self,$_,$seq) : $_);\r
+ $_ .= $seq_end;\r
+ }\r
+ if (length $seq_end) {\r
+ ## End of current sequence, record terminating delimiter\r
+ $seq->rdelim($seq_end);\r
+ ## Pop it off the stack of "in progress" sequences\r
+ pop @seq_stack;\r
+ ## Append result to its parent in current parse tree\r
+ $seq_stack[-1]->append($expand_seq ? &$xseq_sub($self,$seq)\r
+ : $seq);\r
+ ## Remember the current cmd-name and left-delimiter\r
+ if(@seq_stack > 1) {\r
+ $cmd = $seq_stack[-1]->name;\r
+ $ldelim = $seq_stack[-1]->ldelim;\r
+ $rdelim = $seq_stack[-1]->rdelim;\r
+ } else {\r
+ $cmd = $ldelim = $rdelim = '';\r
+ }\r
+ }\r
+ }\r
+ elsif (length) {\r
+ ## In the middle of a sequence, append this text to it, and\r
+ ## dont forget to "expand" it if that's what the caller wanted\r
+ $seq->append($expand_text ? &$xtext_sub($self,$_,$seq) : $_);\r
+ }\r
+ ## Keep track of line count\r
+ $line += /\n/;\r
+ ## Remember the "current" sequence\r
+ $seq = $seq_stack[-1];\r
+ }\r
+\r
+ ## Handle unterminated sequences\r
+ my $errorsub = (@seq_stack > 1) ? $self->errorsub() : undef;\r
+ while (@seq_stack > 1) {\r
+ ($cmd, $file, $line) = ($seq->name, $seq->file_line);\r
+ $ldelim = $seq->ldelim;\r
+ ($rdelim = $ldelim) =~ tr/</>/;\r
+ $rdelim =~ s/^(\S+)(\s*)$/$2$1/;\r
+ pop @seq_stack;\r
+ my $errmsg = "*** ERROR: unterminated ${cmd}${ldelim}...${rdelim}".\r
+ " at line $line in file $file\n";\r
+ (ref $errorsub) and &{$errorsub}($errmsg)\r
+ or (defined $errorsub) and $self->$errorsub($errmsg)\r
+ or carp($errmsg);\r
+ $seq_stack[-1]->append($expand_seq ? &$xseq_sub($self,$seq) : $seq);\r
+ $seq = $seq_stack[-1];\r
+ }\r
+\r
+ ## Return the resulting parse-tree\r
+ my $ptree = (pop @seq_stack)->parse_tree;\r
+ return $expand_ptree ? &$xptree_sub($self, $ptree) : $ptree;\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head1 B<interpolate()>\r
+\r
+ $textblock = $parser->interpolate($text, $line_num);\r
+\r
+This method translates all text (including any embedded interior sequences)\r
+in the given text string C<$text> and returns the interpolated result. The\r
+parameter C<$line_num> is the line number corresponding to the beginning\r
+of C<$text>.\r
+\r
+B<interpolate()> merely invokes a private method to recursively expand\r
+nested interior sequences in bottom-up order (innermost sequences are\r
+expanded first). If there is a need to expand nested sequences in\r
+some alternate order, use B<parse_text> instead.\r
+\r
+=cut\r
+\r
+sub interpolate {\r
+ my($self, $text, $line_num) = @_;\r
+ my %parse_opts = ( -expand_seq => 'interior_sequence' );\r
+ my $ptree = $self->parse_text( \%parse_opts, $text, $line_num );\r
+ return join '', $ptree->children();\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=begin __PRIVATE__\r
+\r
+=head1 B<parse_paragraph()>\r
+\r
+ $parser->parse_paragraph($text, $line_num);\r
+\r
+This method takes the text of a POD paragraph to be processed, along\r
+with its corresponding line number, and invokes the appropriate method\r
+(one of B<command()>, B<verbatim()>, or B<textblock()>).\r
+\r
+For performance reasons, this method is invoked directly without any\r
+dynamic lookup; Hence subclasses may I<not> override it!\r
+\r
+=end __PRIVATE__\r
+\r
+=cut\r
+\r
+sub parse_paragraph {\r
+ my ($self, $text, $line_num) = @_;\r
+ local *myData = $self; ## alias to avoid deref-ing overhead\r
+ local *myOpts = ($myData{_PARSEOPTS} ||= {}); ## get parse-options\r
+ local $_;\r
+\r
+ ## See if we want to preprocess nonPOD paragraphs as well as POD ones.\r
+ my $wantNonPods = $myOpts{'-want_nonPODs'};\r
+\r
+ ## Update cutting status\r
+ $myData{_CUTTING} = 0 if $text =~ /^={1,2}\S/;\r
+\r
+ ## Perform any desired preprocessing if we wanted it this early\r
+ $wantNonPods and $text = $self->preprocess_paragraph($text, $line_num);\r
+\r
+ ## Ignore up until next POD directive if we are cutting\r
+ return if $myData{_CUTTING};\r
+\r
+ ## Now we know this is block of text in a POD section!\r
+\r
+ ##-----------------------------------------------------------------\r
+ ## This is a hook (hack ;-) for Pod::Select to do its thing without\r
+ ## having to override methods, but also without Pod::Parser assuming\r
+ ## $self is an instance of Pod::Select (if the _SELECTED_SECTIONS\r
+ ## field exists then we assume there is an is_selected() method for\r
+ ## us to invoke (calling $self->can('is_selected') could verify this\r
+ ## but that is more overhead than I want to incur)\r
+ ##-----------------------------------------------------------------\r
+\r
+ ## Ignore this block if it isnt in one of the selected sections\r
+ if (exists $myData{_SELECTED_SECTIONS}) {\r
+ $self->is_selected($text) or return ($myData{_CUTTING} = 1);\r
+ }\r
+\r
+ ## If we havent already, perform any desired preprocessing and\r
+ ## then re-check the "cutting" state\r
+ unless ($wantNonPods) {\r
+ $text = $self->preprocess_paragraph($text, $line_num);\r
+ return 1 unless ((defined $text) and (length $text));\r
+ return 1 if ($myData{_CUTTING});\r
+ }\r
+\r
+ ## Look for one of the three types of paragraphs\r
+ my ($pfx, $cmd, $arg, $sep) = ('', '', '', '');\r
+ my $pod_para = undef;\r
+ if ($text =~ /^(={1,2})(?=\S)/) {\r
+ ## Looks like a command paragraph. Capture the command prefix used\r
+ ## ("=" or "=="), as well as the command-name, its paragraph text,\r
+ ## and whatever sequence of characters was used to separate them\r
+ $pfx = $1;\r
+ $_ = substr($text, length $pfx);\r
+ ($cmd, $sep, $text) = split /(\s+)/, $_, 2;\r
+ $sep = '' unless defined $sep;\r
+ $text = '' unless defined $text;\r
+ ## If this is a "cut" directive then we dont need to do anything\r
+ ## except return to "cutting" mode.\r
+ if ($cmd eq 'cut') {\r
+ $myData{_CUTTING} = 1;\r
+ return unless $myOpts{'-process_cut_cmd'};\r
+ }\r
+ }\r
+ ## Save the attributes indicating how the command was specified.\r
+ $pod_para = new Pod::Paragraph(\r
+ -name => $cmd,\r
+ -text => $text,\r
+ -prefix => $pfx,\r
+ -separator => $sep,\r
+ -file => $myData{_INFILE},\r
+ -line => $line_num\r
+ );\r
+ # ## Invoke appropriate callbacks\r
+ # if (exists $myData{_CALLBACKS}) {\r
+ # ## Look through the callback list, invoke callbacks,\r
+ # ## then see if we need to do the default actions\r
+ # ## (invoke_callbacks will return true if we do).\r
+ # return 1 unless $self->invoke_callbacks($cmd, $text, $line_num, $pod_para);\r
+ # }\r
+\r
+ # If the last paragraph ended in whitespace, and we're not between verbatim blocks, carp\r
+ if ($myData{_WHITESPACE} and $myOpts{'-warnings'}\r
+ and not ($text =~ /^\s+/ and ($myData{_PREVIOUS}||"") eq "verbatim")) {\r
+ my $errorsub = $self->errorsub();\r
+ my $line = $line_num - 1;\r
+ my $errmsg = "*** WARNING: line containing nothing but whitespace".\r
+ " in paragraph at line $line in file $myData{_INFILE}\n";\r
+ (ref $errorsub) and &{$errorsub}($errmsg)\r
+ or (defined $errorsub) and $self->$errorsub($errmsg)\r
+ or carp($errmsg);\r
+ }\r
+\r
+ if (length $cmd) {\r
+ ## A command paragraph\r
+ $self->command($cmd, $text, $line_num, $pod_para);\r
+ $myData{_PREVIOUS} = $cmd;\r
+ }\r
+ elsif ($text =~ /^\s+/) {\r
+ ## Indented text - must be a verbatim paragraph\r
+ $self->verbatim($text, $line_num, $pod_para);\r
+ $myData{_PREVIOUS} = "verbatim";\r
+ }\r
+ else {\r
+ ## Looks like an ordinary block of text\r
+ $self->textblock($text, $line_num, $pod_para);\r
+ $myData{_PREVIOUS} = "textblock";\r
+ }\r
+\r
+ # Update the whitespace for the next time around\r
+ #$myData{_WHITESPACE} = $text =~ /^[^\S\r\n]+\Z/m ? 1 : 0;\r
+ $myData{_WHITESPACE} = $text =~ /^[^\S\r\n]+\r*\Z/m ? 1 : 0;\r
+\r
+ return 1;\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head1 B<parse_from_filehandle()>\r
+\r
+ $parser->parse_from_filehandle($in_fh,$out_fh);\r
+\r
+This method takes an input filehandle (which is assumed to already be\r
+opened for reading) and reads the entire input stream looking for blocks\r
+(paragraphs) of POD documentation to be processed. If no first argument\r
+is given the default input filehandle C<STDIN> is used.\r
+\r
+The C<$in_fh> parameter may be any object that provides a B<getline()>\r
+method to retrieve a single line of input text (hence, an appropriate\r
+wrapper object could be used to parse PODs from a single string or an\r
+array of strings).\r
+\r
+Using C<$in_fh-E<gt>getline()>, input is read line-by-line and assembled\r
+into paragraphs or "blocks" (which are separated by lines containing\r
+nothing but whitespace). For each block of POD documentation\r
+encountered it will invoke a method to parse the given paragraph.\r
+\r
+If a second argument is given then it should correspond to a filehandle where\r
+output should be sent (otherwise the default output filehandle is\r
+C<STDOUT> if no output filehandle is currently in use).\r
+\r
+B<NOTE:> For performance reasons, this method caches the input stream at\r
+the top of the stack in a local variable. Any attempts by clients to\r
+change the stack contents during processing when in the midst executing\r
+of this method I<will not affect> the input stream used by the current\r
+invocation of this method.\r
+\r
+This method does I<not> usually need to be overridden by subclasses.\r
+\r
+=cut\r
+\r
+sub parse_from_filehandle {\r
+ my $self = shift;\r
+ my %opts = (ref $_[0] eq 'HASH') ? %{ shift() } : ();\r
+ my ($in_fh, $out_fh) = @_;\r
+ $in_fh = \*STDIN unless ($in_fh);\r
+ local *myData = $self; ## alias to avoid deref-ing overhead\r
+ local *myOpts = ($myData{_PARSEOPTS} ||= {}); ## get parse-options\r
+ local $_;\r
+\r
+ ## Put this stream at the top of the stack and do beginning-of-input\r
+ ## processing. NOTE that $in_fh might be reset during this process.\r
+ my $topstream = $self->_push_input_stream($in_fh, $out_fh);\r
+ (exists $opts{-cutting}) and $self->cutting( $opts{-cutting} );\r
+\r
+ ## Initialize line/paragraph\r
+ my ($textline, $paragraph) = ('', '');\r
+ my ($nlines, $plines) = (0, 0);\r
+\r
+ ## Use <$fh> instead of $fh->getline where possible (for speed)\r
+ $_ = ref $in_fh;\r
+ my $tied_fh = (/^(?:GLOB|FileHandle|IO::\w+)$/ or tied $in_fh);\r
+\r
+ ## Read paragraphs line-by-line\r
+ while (defined ($textline = $tied_fh ? <$in_fh> : $in_fh->getline)) {\r
+ $textline = $self->preprocess_line($textline, ++$nlines);\r
+ next unless ((defined $textline) && (length $textline));\r
+\r
+ if ((! length $paragraph) && ($textline =~ /^==/)) {\r
+ ## '==' denotes a one-line command paragraph\r
+ $paragraph = $textline;\r
+ $plines = 1;\r
+ $textline = '';\r
+ } else {\r
+ ## Append this line to the current paragraph\r
+ $paragraph .= $textline;\r
+ ++$plines;\r
+ }\r
+\r
+ ## See if this line is blank and ends the current paragraph.\r
+ ## If it isnt, then keep iterating until it is.\r
+ next unless (($textline =~ /^[^\S\r\n]*[\r\n]*$/)\r
+ && (length $paragraph));\r
+\r
+ ## Now process the paragraph\r
+ parse_paragraph($self, $paragraph, ($nlines - $plines) + 1);\r
+ $paragraph = '';\r
+ $plines = 0;\r
+ }\r
+ ## Dont forget about the last paragraph in the file\r
+ if (length $paragraph) {\r
+ parse_paragraph($self, $paragraph, ($nlines - $plines) + 1)\r
+ }\r
+\r
+ ## Now pop the input stream off the top of the input stack.\r
+ $self->_pop_input_stream();\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head1 B<parse_from_file()>\r
+\r
+ $parser->parse_from_file($filename,$outfile);\r
+\r
+This method takes a filename and does the following:\r
+\r
+=over 2\r
+\r
+=item *\r
+\r
+opens the input and output files for reading\r
+(creating the appropriate filehandles)\r
+\r
+=item *\r
+\r
+invokes the B<parse_from_filehandle()> method passing it the\r
+corresponding input and output filehandles.\r
+\r
+=item *\r
+\r
+closes the input and output files.\r
+\r
+=back\r
+\r
+If the special input filename "-" or "<&STDIN" is given then the STDIN\r
+filehandle is used for input (and no open or close is performed). If no\r
+input filename is specified then "-" is implied. Filehandle references,\r
+or objects that support the regular IO operations (like C<E<lt>$fhE<gt>>\r
+or C<$fh-<Egt>getline>) are also accepted; the handles must already be \r
+opened.\r
+\r
+If a second argument is given then it should be the name of the desired\r
+output file. If the special output filename "-" or ">&STDOUT" is given\r
+then the STDOUT filehandle is used for output (and no open or close is\r
+performed). If the special output filename ">&STDERR" is given then the\r
+STDERR filehandle is used for output (and no open or close is\r
+performed). If no output filehandle is currently in use and no output\r
+filename is specified, then "-" is implied.\r
+Alternatively, filehandle references or objects that support the regular\r
+IO operations (like C<print>, e.g. L<IO::String>) are also accepted;\r
+the object must already be opened.\r
+\r
+This method does I<not> usually need to be overridden by subclasses.\r
+\r
+=cut\r
+\r
+sub parse_from_file {\r
+ my $self = shift;\r
+ my %opts = (ref $_[0] eq 'HASH') ? %{ shift() } : ();\r
+ my ($infile, $outfile) = @_;\r
+ my ($in_fh, $out_fh);\r
+ if ($] < 5.006) {\r
+ ($in_fh, $out_fh) = (gensym(), gensym());\r
+ }\r
+ my ($close_input, $close_output) = (0, 0);\r
+ local *myData = $self;\r
+ local *_;\r
+\r
+ ## Is $infile a filename or a (possibly implied) filehandle\r
+ if (defined $infile && ref $infile) {\r
+ if (ref($infile) =~ /^(SCALAR|ARRAY|HASH|CODE|REF)$/) {\r
+ croak "Input from $1 reference not supported!\n";\r
+ }\r
+ ## Must be a filehandle-ref (or else assume its a ref to an object\r
+ ## that supports the common IO read operations).\r
+ $myData{_INFILE} = ${$infile};\r
+ $in_fh = $infile;\r
+ }\r
+ elsif (!defined($infile) || !length($infile) || ($infile eq '-')\r
+ || ($infile =~ /^<&(?:STDIN|0)$/i))\r
+ {\r
+ ## Not a filename, just a string implying STDIN\r
+ $infile ||= '-';\r
+ $myData{_INFILE} = '<standard input>';\r
+ $in_fh = \*STDIN;\r
+ }\r
+ else {\r
+ ## We have a filename, open it for reading\r
+ $myData{_INFILE} = $infile;\r
+ open($in_fh, "< $infile") or\r
+ croak "Can't open $infile for reading: $!\n";\r
+ $close_input = 1;\r
+ }\r
+\r
+ ## NOTE: we need to be *very* careful when "defaulting" the output\r
+ ## file. We only want to use a default if this is the beginning of\r
+ ## the entire document (but *not* if this is an included file). We\r
+ ## determine this by seeing if the input stream stack has been set-up\r
+ ## already\r
+\r
+ ## Is $outfile a filename, a (possibly implied) filehandle, maybe a ref?\r
+ if (ref $outfile) {\r
+ ## we need to check for ref() first, as other checks involve reading\r
+ if (ref($outfile) =~ /^(ARRAY|HASH|CODE)$/) {\r
+ croak "Output to $1 reference not supported!\n";\r
+ }\r
+ elsif (ref($outfile) eq 'SCALAR') {\r
+# # NOTE: IO::String isn't a part of the perl distribution,\r
+# # so probably we shouldn't support this case...\r
+# require IO::String;\r
+# $myData{_OUTFILE} = "$outfile";\r
+# $out_fh = IO::String->new($outfile);\r
+ croak "Output to SCALAR reference not supported!\n";\r
+ }\r
+ else {\r
+ ## Must be a filehandle-ref (or else assume its a ref to an\r
+ ## object that supports the common IO write operations).\r
+ $myData{_OUTFILE} = ${$outfile};\r
+ $out_fh = $outfile;\r
+ }\r
+ }\r
+ elsif (!defined($outfile) || !length($outfile) || ($outfile eq '-')\r
+ || ($outfile =~ /^>&?(?:STDOUT|1)$/i))\r
+ {\r
+ if (defined $myData{_TOP_STREAM}) {\r
+ $out_fh = $myData{_OUTPUT};\r
+ }\r
+ else {\r
+ ## Not a filename, just a string implying STDOUT\r
+ $outfile ||= '-';\r
+ $myData{_OUTFILE} = '<standard output>';\r
+ $out_fh = \*STDOUT;\r
+ }\r
+ }\r
+ elsif ($outfile =~ /^>&(STDERR|2)$/i) {\r
+ ## Not a filename, just a string implying STDERR\r
+ $myData{_OUTFILE} = '<standard error>';\r
+ $out_fh = \*STDERR;\r
+ }\r
+ else {\r
+ ## We have a filename, open it for writing\r
+ $myData{_OUTFILE} = $outfile;\r
+ (-d $outfile) and croak "$outfile is a directory, not POD input!\n";\r
+ open($out_fh, "> $outfile") or\r
+ croak "Can't open $outfile for writing: $!\n";\r
+ $close_output = 1;\r
+ }\r
+\r
+ ## Whew! That was a lot of work to set up reasonably/robust behavior\r
+ ## in the case of a non-filename for reading and writing. Now we just\r
+ ## have to parse the input and close the handles when we're finished.\r
+ $self->parse_from_filehandle(\%opts, $in_fh, $out_fh);\r
+\r
+ $close_input and\r
+ close($in_fh) || croak "Can't close $infile after reading: $!\n";\r
+ $close_output and\r
+ close($out_fh) || croak "Can't close $outfile after writing: $!\n";\r
+}\r
+\r
+#############################################################################\r
+\r
+=head1 ACCESSOR METHODS\r
+\r
+Clients of B<Pod::Parser> should use the following methods to access\r
+instance data fields:\r
+\r
+=cut\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head1 B<errorsub()>\r
+\r
+ $parser->errorsub("method_name");\r
+ $parser->errorsub(\&warn_user);\r
+ $parser->errorsub(sub { print STDERR, @_ });\r
+\r
+Specifies the method or subroutine to use when printing error messages\r
+about POD syntax. The supplied method/subroutine I<must> return TRUE upon\r
+successful printing of the message. If C<undef> is given, then the B<carp>\r
+builtin is used to issue error messages (this is the default behavior).\r
+\r
+ my $errorsub = $parser->errorsub()\r
+ my $errmsg = "This is an error message!\n"\r
+ (ref $errorsub) and &{$errorsub}($errmsg)\r
+ or (defined $errorsub) and $parser->$errorsub($errmsg)\r
+ or carp($errmsg);\r
+\r
+Returns a method name, or else a reference to the user-supplied subroutine\r
+used to print error messages. Returns C<undef> if the B<carp> builtin\r
+is used to issue error messages (this is the default behavior).\r
+\r
+=cut\r
+\r
+sub errorsub {\r
+ return (@_ > 1) ? ($_[0]->{_ERRORSUB} = $_[1]) : $_[0]->{_ERRORSUB};\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head1 B<cutting()>\r
+\r
+ $boolean = $parser->cutting();\r
+\r
+Returns the current C<cutting> state: a boolean-valued scalar which\r
+evaluates to true if text from the input file is currently being "cut"\r
+(meaning it is I<not> considered part of the POD document).\r
+\r
+ $parser->cutting($boolean);\r
+\r
+Sets the current C<cutting> state to the given value and returns the\r
+result.\r
+\r
+=cut\r
+\r
+sub cutting {\r
+ return (@_ > 1) ? ($_[0]->{_CUTTING} = $_[1]) : $_[0]->{_CUTTING};\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head1 B<parseopts()>\r
+\r
+When invoked with no additional arguments, B<parseopts> returns a hashtable\r
+of all the current parsing options.\r
+\r
+ ## See if we are parsing non-POD sections as well as POD ones\r
+ my %opts = $parser->parseopts();\r
+ $opts{'-want_nonPODs}' and print "-want_nonPODs\n";\r
+\r
+When invoked using a single string, B<parseopts> treats the string as the\r
+name of a parse-option and returns its corresponding value if it exists\r
+(returns C<undef> if it doesn't).\r
+\r
+ ## Did we ask to see '=cut' paragraphs?\r
+ my $want_cut = $parser->parseopts('-process_cut_cmd');\r
+ $want_cut and print "-process_cut_cmd\n";\r
+\r
+When invoked with multiple arguments, B<parseopts> treats them as\r
+key/value pairs and the specified parse-option names are set to the\r
+given values. Any unspecified parse-options are unaffected.\r
+\r
+ ## Set them back to the default\r
+ $parser->parseopts(-warnings => 0);\r
+\r
+When passed a single hash-ref, B<parseopts> uses that hash to completely\r
+reset the existing parse-options, all previous parse-option values\r
+are lost.\r
+\r
+ ## Reset all options to default \r
+ $parser->parseopts( { } );\r
+\r
+See L<"PARSING OPTIONS"> for more information on the name and meaning of each\r
+parse-option currently recognized.\r
+\r
+=cut\r
+\r
+sub parseopts {\r
+ local *myData = shift;\r
+ local *myOpts = ($myData{_PARSEOPTS} ||= {});\r
+ return %myOpts if (@_ == 0);\r
+ if (@_ == 1) {\r
+ local $_ = shift;\r
+ return ref($_) ? $myData{_PARSEOPTS} = $_ : $myOpts{$_};\r
+ }\r
+ my @newOpts = (%myOpts, @_);\r
+ $myData{_PARSEOPTS} = { @newOpts };\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head1 B<output_file()>\r
+\r
+ $fname = $parser->output_file();\r
+\r
+Returns the name of the output file being written.\r
+\r
+=cut\r
+\r
+sub output_file {\r
+ return $_[0]->{_OUTFILE};\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head1 B<output_handle()>\r
+\r
+ $fhandle = $parser->output_handle();\r
+\r
+Returns the output filehandle object.\r
+\r
+=cut\r
+\r
+sub output_handle {\r
+ return $_[0]->{_OUTPUT};\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head1 B<input_file()>\r
+\r
+ $fname = $parser->input_file();\r
+\r
+Returns the name of the input file being read.\r
+\r
+=cut\r
+\r
+sub input_file {\r
+ return $_[0]->{_INFILE};\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head1 B<input_handle()>\r
+\r
+ $fhandle = $parser->input_handle();\r
+\r
+Returns the current input filehandle object.\r
+\r
+=cut\r
+\r
+sub input_handle {\r
+ return $_[0]->{_INPUT};\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=begin __PRIVATE__\r
+\r
+=head1 B<input_streams()>\r
+\r
+ $listref = $parser->input_streams();\r
+\r
+Returns a reference to an array which corresponds to the stack of all\r
+the input streams that are currently in the middle of being parsed.\r
+\r
+While parsing an input stream, it is possible to invoke\r
+B<parse_from_file()> or B<parse_from_filehandle()> to parse a new input\r
+stream and then return to parsing the previous input stream. Each input\r
+stream to be parsed is pushed onto the end of this input stack\r
+before any of its input is read. The input stream that is currently\r
+being parsed is always at the end (or top) of the input stack. When an\r
+input stream has been exhausted, it is popped off the end of the\r
+input stack.\r
+\r
+Each element on this input stack is a reference to C<Pod::InputSource>\r
+object. Please see L<Pod::InputObjects> for more details.\r
+\r
+This method might be invoked when printing diagnostic messages, for example,\r
+to obtain the name and line number of the all input files that are currently\r
+being processed.\r
+\r
+=end __PRIVATE__\r
+\r
+=cut\r
+\r
+sub input_streams {\r
+ return $_[0]->{_INPUT_STREAMS};\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=begin __PRIVATE__\r
+\r
+=head1 B<top_stream()>\r
+\r
+ $hashref = $parser->top_stream();\r
+\r
+Returns a reference to the hash-table that represents the element\r
+that is currently at the top (end) of the input stream stack\r
+(see L<"input_streams()">). The return value will be the C<undef>\r
+if the input stack is empty.\r
+\r
+This method might be used when printing diagnostic messages, for example,\r
+to obtain the name and line number of the current input file.\r
+\r
+=end __PRIVATE__\r
+\r
+=cut\r
+\r
+sub top_stream {\r
+ return $_[0]->{_TOP_STREAM} || undef;\r
+}\r
+\r
+#############################################################################\r
+\r
+=head1 PRIVATE METHODS AND DATA\r
+\r
+B<Pod::Parser> makes use of several internal methods and data fields\r
+which clients should not need to see or use. For the sake of avoiding\r
+name collisions for client data and methods, these methods and fields\r
+are briefly discussed here. Determined hackers may obtain further\r
+information about them by reading the B<Pod::Parser> source code.\r
+\r
+Private data fields are stored in the hash-object whose reference is\r
+returned by the B<new()> constructor for this class. The names of all\r
+private methods and data-fields used by B<Pod::Parser> begin with a\r
+prefix of "_" and match the regular expression C</^_\w+$/>.\r
+\r
+=cut\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=begin _PRIVATE_\r
+\r
+=head1 B<_push_input_stream()>\r
+\r
+ $hashref = $parser->_push_input_stream($in_fh,$out_fh);\r
+\r
+This method will push the given input stream on the input stack and\r
+perform any necessary beginning-of-document or beginning-of-file\r
+processing. The argument C<$in_fh> is the input stream filehandle to\r
+push, and C<$out_fh> is the corresponding output filehandle to use (if\r
+it is not given or is undefined, then the current output stream is used,\r
+which defaults to standard output if it doesnt exist yet).\r
+\r
+The value returned will be reference to the hash-table that represents\r
+the new top of the input stream stack. I<Please Note> that it is\r
+possible for this method to use default values for the input and output\r
+file handles. If this happens, you will need to look at the C<INPUT>\r
+and C<OUTPUT> instance data members to determine their new values.\r
+\r
+=end _PRIVATE_\r
+\r
+=cut\r
+\r
+sub _push_input_stream {\r
+ my ($self, $in_fh, $out_fh) = @_;\r
+ local *myData = $self;\r
+\r
+ ## Initialize stuff for the entire document if this is *not*\r
+ ## an included file.\r
+ ##\r
+ ## NOTE: we need to be *very* careful when "defaulting" the output\r
+ ## filehandle. We only want to use a default value if this is the\r
+ ## beginning of the entire document (but *not* if this is an included\r
+ ## file).\r
+ unless (defined $myData{_TOP_STREAM}) {\r
+ $out_fh = \*STDOUT unless (defined $out_fh);\r
+ $myData{_CUTTING} = 1; ## current "cutting" state\r
+ $myData{_INPUT_STREAMS} = []; ## stack of all input streams\r
+ }\r
+\r
+ ## Initialize input indicators\r
+ $myData{_OUTFILE} = '(unknown)' unless (defined $myData{_OUTFILE});\r
+ $myData{_OUTPUT} = $out_fh if (defined $out_fh);\r
+ $in_fh = \*STDIN unless (defined $in_fh);\r
+ $myData{_INFILE} = '(unknown)' unless (defined $myData{_INFILE});\r
+ $myData{_INPUT} = $in_fh;\r
+ my $input_top = $myData{_TOP_STREAM}\r
+ = new Pod::InputSource(\r
+ -name => $myData{_INFILE},\r
+ -handle => $in_fh,\r
+ -was_cutting => $myData{_CUTTING}\r
+ );\r
+ local *input_stack = $myData{_INPUT_STREAMS};\r
+ push(@input_stack, $input_top);\r
+\r
+ ## Perform beginning-of-document and/or beginning-of-input processing\r
+ $self->begin_pod() if (@input_stack == 1);\r
+ $self->begin_input();\r
+\r
+ return $input_top;\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=begin _PRIVATE_\r
+\r
+=head1 B<_pop_input_stream()>\r
+\r
+ $hashref = $parser->_pop_input_stream();\r
+\r
+This takes no arguments. It will perform any necessary end-of-file or\r
+end-of-document processing and then pop the current input stream from\r
+the top of the input stack.\r
+\r
+The value returned will be reference to the hash-table that represents\r
+the new top of the input stream stack.\r
+\r
+=end _PRIVATE_\r
+\r
+=cut\r
+\r
+sub _pop_input_stream {\r
+ my ($self) = @_;\r
+ local *myData = $self;\r
+ local *input_stack = $myData{_INPUT_STREAMS};\r
+\r
+ ## Perform end-of-input and/or end-of-document processing\r
+ $self->end_input() if (@input_stack > 0);\r
+ $self->end_pod() if (@input_stack == 1);\r
+\r
+ ## Restore cutting state to whatever it was before we started\r
+ ## parsing this file.\r
+ my $old_top = pop(@input_stack);\r
+ $myData{_CUTTING} = $old_top->was_cutting();\r
+\r
+ ## Dont forget to reset the input indicators\r
+ my $input_top = undef;\r
+ if (@input_stack > 0) {\r
+ $input_top = $myData{_TOP_STREAM} = $input_stack[-1];\r
+ $myData{_INFILE} = $input_top->name();\r
+ $myData{_INPUT} = $input_top->handle();\r
+ } else {\r
+ delete $myData{_TOP_STREAM};\r
+ delete $myData{_INPUT_STREAMS};\r
+ }\r
+\r
+ return $input_top;\r
+}\r
+\r
+#############################################################################\r
+\r
+=head1 TREE-BASED PARSING\r
+\r
+If straightforward stream-based parsing wont meet your needs (as is\r
+likely the case for tasks such as translating PODs into structured\r
+markup languages like HTML and XML) then you may need to take the\r
+tree-based approach. Rather than doing everything in one pass and\r
+calling the B<interpolate()> method to expand sequences into text, it\r
+may be desirable to instead create a parse-tree using the B<parse_text()>\r
+method to return a tree-like structure which may contain an ordered\r
+list of children (each of which may be a text-string, or a similar\r
+tree-like structure).\r
+\r
+Pay special attention to L<"METHODS FOR PARSING AND PROCESSING"> and\r
+to the objects described in L<Pod::InputObjects>. The former describes\r
+the gory details and parameters for how to customize and extend the\r
+parsing behavior of B<Pod::Parser>. B<Pod::InputObjects> provides\r
+several objects that may all be used interchangeably as parse-trees. The\r
+most obvious one is the B<Pod::ParseTree> object. It defines the basic\r
+interface and functionality that all things trying to be a POD parse-tree\r
+should do. A B<Pod::ParseTree> is defined such that each "node" may be a\r
+text-string, or a reference to another parse-tree. Each B<Pod::Paragraph>\r
+object and each B<Pod::InteriorSequence> object also supports the basic\r
+parse-tree interface.\r
+\r
+The B<parse_text()> method takes a given paragraph of text, and\r
+returns a parse-tree that contains one or more children, each of which\r
+may be a text-string, or an InteriorSequence object. There are also\r
+callback-options that may be passed to B<parse_text()> to customize\r
+the way it expands or transforms interior-sequences, as well as the\r
+returned result. These callbacks can be used to create a parse-tree\r
+with custom-made objects (which may or may not support the parse-tree\r
+interface, depending on how you choose to do it).\r
+\r
+If you wish to turn an entire POD document into a parse-tree, that process\r
+is fairly straightforward. The B<parse_text()> method is the key to doing\r
+this successfully. Every paragraph-callback (i.e. the polymorphic methods\r
+for B<command()>, B<verbatim()>, and B<textblock()> paragraphs) takes\r
+a B<Pod::Paragraph> object as an argument. Each paragraph object has a\r
+B<parse_tree()> method that can be used to get or set a corresponding\r
+parse-tree. So for each of those paragraph-callback methods, simply call\r
+B<parse_text()> with the options you desire, and then use the returned\r
+parse-tree to assign to the given paragraph object.\r
+\r
+That gives you a parse-tree for each paragraph - so now all you need is\r
+an ordered list of paragraphs. You can maintain that yourself as a data\r
+element in the object/hash. The most straightforward way would be simply\r
+to use an array-ref, with the desired set of custom "options" for each\r
+invocation of B<parse_text>. Let's assume the desired option-set is\r
+given by the hash C<%options>. Then we might do something like the\r
+following:\r
+\r
+ package MyPodParserTree;\r
+\r
+ @ISA = qw( Pod::Parser );\r
+\r
+ ...\r
+\r
+ sub begin_pod {\r
+ my $self = shift;\r
+ $self->{'-paragraphs'} = []; ## initialize paragraph list\r
+ }\r
+\r
+ sub command { \r
+ my ($parser, $command, $paragraph, $line_num, $pod_para) = @_;\r
+ my $ptree = $parser->parse_text({%options}, $paragraph, ...);\r
+ $pod_para->parse_tree( $ptree );\r
+ push @{ $self->{'-paragraphs'} }, $pod_para;\r
+ }\r
+\r
+ sub verbatim { \r
+ my ($parser, $paragraph, $line_num, $pod_para) = @_;\r
+ push @{ $self->{'-paragraphs'} }, $pod_para;\r
+ }\r
+\r
+ sub textblock { \r
+ my ($parser, $paragraph, $line_num, $pod_para) = @_;\r
+ my $ptree = $parser->parse_text({%options}, $paragraph, ...);\r
+ $pod_para->parse_tree( $ptree );\r
+ push @{ $self->{'-paragraphs'} }, $pod_para;\r
+ }\r
+\r
+ ...\r
+\r
+ package main;\r
+ ...\r
+ my $parser = new MyPodParserTree(...);\r
+ $parser->parse_from_file(...);\r
+ my $paragraphs_ref = $parser->{'-paragraphs'};\r
+\r
+Of course, in this module-author's humble opinion, I'd be more inclined to\r
+use the existing B<Pod::ParseTree> object than a simple array. That way\r
+everything in it, paragraphs and sequences, all respond to the same core\r
+interface for all parse-tree nodes. The result would look something like:\r
+\r
+ package MyPodParserTree2;\r
+\r
+ ...\r
+\r
+ sub begin_pod {\r
+ my $self = shift;\r
+ $self->{'-ptree'} = new Pod::ParseTree; ## initialize parse-tree\r
+ }\r
+\r
+ sub parse_tree {\r
+ ## convenience method to get/set the parse-tree for the entire POD\r
+ (@_ > 1) and $_[0]->{'-ptree'} = $_[1];\r
+ return $_[0]->{'-ptree'};\r
+ }\r
+\r
+ sub command { \r
+ my ($parser, $command, $paragraph, $line_num, $pod_para) = @_;\r
+ my $ptree = $parser->parse_text({<<options>>}, $paragraph, ...);\r
+ $pod_para->parse_tree( $ptree );\r
+ $parser->parse_tree()->append( $pod_para );\r
+ }\r
+\r
+ sub verbatim { \r
+ my ($parser, $paragraph, $line_num, $pod_para) = @_;\r
+ $parser->parse_tree()->append( $pod_para );\r
+ }\r
+\r
+ sub textblock { \r
+ my ($parser, $paragraph, $line_num, $pod_para) = @_;\r
+ my $ptree = $parser->parse_text({<<options>>}, $paragraph, ...);\r
+ $pod_para->parse_tree( $ptree );\r
+ $parser->parse_tree()->append( $pod_para );\r
+ }\r
+\r
+ ...\r
+\r
+ package main;\r
+ ...\r
+ my $parser = new MyPodParserTree2(...);\r
+ $parser->parse_from_file(...);\r
+ my $ptree = $parser->parse_tree;\r
+ ...\r
+\r
+Now you have the entire POD document as one great big parse-tree. You\r
+can even use the B<-expand_seq> option to B<parse_text> to insert\r
+whole different kinds of objects. Just don't expect B<Pod::Parser>\r
+to know what to do with them after that. That will need to be in your\r
+code. Or, alternatively, you can insert any object you like so long as\r
+it conforms to the B<Pod::ParseTree> interface.\r
+\r
+One could use this to create subclasses of B<Pod::Paragraphs> and\r
+B<Pod::InteriorSequences> for specific commands (or to create your own\r
+custom node-types in the parse-tree) and add some kind of B<emit()>\r
+method to each custom node/subclass object in the tree. Then all you'd\r
+need to do is recursively walk the tree in the desired order, processing\r
+the children (most likely from left to right) by formatting them if\r
+they are text-strings, or by calling their B<emit()> method if they\r
+are objects/references.\r
+\r
+=head1 CAVEATS\r
+\r
+Please note that POD has the notion of "paragraphs": this is something\r
+starting I<after> a blank (read: empty) line, with the single exception\r
+of the file start, which is also starting a paragraph. That means that\r
+especially a command (e.g. C<=head1>) I<must> be preceded with a blank\r
+line; C<__END__> is I<not> a blank line.\r
+\r
+=head1 SEE ALSO\r
+\r
+L<Pod::InputObjects>, L<Pod::Select>\r
+\r
+B<Pod::InputObjects> defines POD input objects corresponding to\r
+command paragraphs, parse-trees, and interior-sequences.\r
+\r
+B<Pod::Select> is a subclass of B<Pod::Parser> which provides the ability\r
+to selectively include and/or exclude sections of a POD document from being\r
+translated based upon the current heading, subheading, subsubheading, etc.\r
+\r
+=for __PRIVATE__\r
+B<Pod::Callbacks> is a subclass of B<Pod::Parser> which gives its users\r
+the ability the employ I<callback functions> instead of, or in addition\r
+to, overriding methods of the base class.\r
+\r
+=for __PRIVATE__\r
+B<Pod::Select> and B<Pod::Callbacks> do not override any\r
+methods nor do they define any new methods with the same name. Because\r
+of this, they may I<both> be used (in combination) as a base class of\r
+the same subclass in order to combine their functionality without\r
+causing any namespace clashes due to multiple inheritance.\r
+\r
+=head1 AUTHOR\r
+\r
+Please report bugs using L<http://rt.cpan.org>.\r
+\r
+Brad Appleton E<lt>bradapp@enteract.comE<gt>\r
+\r
+Based on code for B<Pod::Text> written by\r
+Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>\r
+\r
+=head1 LICENSE\r
+\r
+Pod-Parser is free software; you can redistribute it and/or modify it\r
+under the terms of the Artistic License distributed with Perl version\r
+5.000 or (at your option) any later version. Please refer to the\r
+Artistic License that came with your Perl distribution for more\r
+details. If your version of Perl was not distributed under the\r
+terms of the Artistic License, than you may distribute PodParser\r
+under the same terms as Perl itself.\r
+\r
+=cut\r
+\r
+1;\r
+# vim: ts=4 sw=4 et\r
--- /dev/null
+# Pod::PlainText -- Convert POD data to formatted ASCII text.\r
+# $Id: Text.pm,v 2.1 1999/09/20 11:53:33 eagle Exp $\r
+#\r
+# Copyright 1999-2000 by Russ Allbery <rra@stanford.edu>\r
+#\r
+# This program is free software; you can redistribute it and/or modify it\r
+# under the same terms as Perl itself.\r
+#\r
+# This module is intended to be a replacement for Pod::Text, and attempts to\r
+# match its output except for some specific circumstances where other\r
+# decisions seemed to produce better output. It uses Pod::Parser and is\r
+# designed to be very easy to subclass.\r
+\r
+############################################################################\r
+# Modules and declarations\r
+############################################################################\r
+\r
+package Pod::PlainText;\r
+use strict;\r
+\r
+require 5.005;\r
+\r
+use Carp qw(carp croak);\r
+use Pod::Select ();\r
+\r
+use vars qw(@ISA %ESCAPES $VERSION);\r
+\r
+# We inherit from Pod::Select instead of Pod::Parser so that we can be used\r
+# by Pod::Usage.\r
+@ISA = qw(Pod::Select);\r
+\r
+$VERSION = '2.06';\r
+\r
+BEGIN {\r
+ if ($] < 5.006) {\r
+ require Symbol;\r
+ import Symbol;\r
+ }\r
+}\r
+\r
+############################################################################\r
+# Table of supported E<> escapes\r
+############################################################################\r
+\r
+# This table is taken near verbatim from Pod::PlainText in Pod::Parser,\r
+# which got it near verbatim from the original Pod::Text. It is therefore\r
+# credited to Tom Christiansen, and I'm glad I didn't have to write it. :)\r
+%ESCAPES = (\r
+ 'amp' => '&', # ampersand\r
+ 'lt' => '<', # left chevron, less-than\r
+ 'gt' => '>', # right chevron, greater-than\r
+ 'quot' => '"', # double quote\r
+\r
+ "Aacute" => "\xC1", # capital A, acute accent\r
+ "aacute" => "\xE1", # small a, acute accent\r
+ "Acirc" => "\xC2", # capital A, circumflex accent\r
+ "acirc" => "\xE2", # small a, circumflex accent\r
+ "AElig" => "\xC6", # capital AE diphthong (ligature)\r
+ "aelig" => "\xE6", # small ae diphthong (ligature)\r
+ "Agrave" => "\xC0", # capital A, grave accent\r
+ "agrave" => "\xE0", # small a, grave accent\r
+ "Aring" => "\xC5", # capital A, ring\r
+ "aring" => "\xE5", # small a, ring\r
+ "Atilde" => "\xC3", # capital A, tilde\r
+ "atilde" => "\xE3", # small a, tilde\r
+ "Auml" => "\xC4", # capital A, dieresis or umlaut mark\r
+ "auml" => "\xE4", # small a, dieresis or umlaut mark\r
+ "Ccedil" => "\xC7", # capital C, cedilla\r
+ "ccedil" => "\xE7", # small c, cedilla\r
+ "Eacute" => "\xC9", # capital E, acute accent\r
+ "eacute" => "\xE9", # small e, acute accent\r
+ "Ecirc" => "\xCA", # capital E, circumflex accent\r
+ "ecirc" => "\xEA", # small e, circumflex accent\r
+ "Egrave" => "\xC8", # capital E, grave accent\r
+ "egrave" => "\xE8", # small e, grave accent\r
+ "ETH" => "\xD0", # capital Eth, Icelandic\r
+ "eth" => "\xF0", # small eth, Icelandic\r
+ "Euml" => "\xCB", # capital E, dieresis or umlaut mark\r
+ "euml" => "\xEB", # small e, dieresis or umlaut mark\r
+ "Iacute" => "\xCD", # capital I, acute accent\r
+ "iacute" => "\xED", # small i, acute accent\r
+ "Icirc" => "\xCE", # capital I, circumflex accent\r
+ "icirc" => "\xEE", # small i, circumflex accent\r
+ "Igrave" => "\xCD", # capital I, grave accent\r
+ "igrave" => "\xED", # small i, grave accent\r
+ "Iuml" => "\xCF", # capital I, dieresis or umlaut mark\r
+ "iuml" => "\xEF", # small i, dieresis or umlaut mark\r
+ "Ntilde" => "\xD1", # capital N, tilde\r
+ "ntilde" => "\xF1", # small n, tilde\r
+ "Oacute" => "\xD3", # capital O, acute accent\r
+ "oacute" => "\xF3", # small o, acute accent\r
+ "Ocirc" => "\xD4", # capital O, circumflex accent\r
+ "ocirc" => "\xF4", # small o, circumflex accent\r
+ "Ograve" => "\xD2", # capital O, grave accent\r
+ "ograve" => "\xF2", # small o, grave accent\r
+ "Oslash" => "\xD8", # capital O, slash\r
+ "oslash" => "\xF8", # small o, slash\r
+ "Otilde" => "\xD5", # capital O, tilde\r
+ "otilde" => "\xF5", # small o, tilde\r
+ "Ouml" => "\xD6", # capital O, dieresis or umlaut mark\r
+ "ouml" => "\xF6", # small o, dieresis or umlaut mark\r
+ "szlig" => "\xDF", # small sharp s, German (sz ligature)\r
+ "THORN" => "\xDE", # capital THORN, Icelandic\r
+ "thorn" => "\xFE", # small thorn, Icelandic\r
+ "Uacute" => "\xDA", # capital U, acute accent\r
+ "uacute" => "\xFA", # small u, acute accent\r
+ "Ucirc" => "\xDB", # capital U, circumflex accent\r
+ "ucirc" => "\xFB", # small u, circumflex accent\r
+ "Ugrave" => "\xD9", # capital U, grave accent\r
+ "ugrave" => "\xF9", # small u, grave accent\r
+ "Uuml" => "\xDC", # capital U, dieresis or umlaut mark\r
+ "uuml" => "\xFC", # small u, dieresis or umlaut mark\r
+ "Yacute" => "\xDD", # capital Y, acute accent\r
+ "yacute" => "\xFD", # small y, acute accent\r
+ "yuml" => "\xFF", # small y, dieresis or umlaut mark\r
+\r
+ "lchevron" => "\xAB", # left chevron (double less than)\r
+ "rchevron" => "\xBB", # right chevron (double greater than)\r
+);\r
+\r
+\r
+############################################################################\r
+# Initialization\r
+############################################################################\r
+\r
+# Initialize the object. Must be sure to call our parent initializer.\r
+sub initialize {\r
+ my $self = shift;\r
+\r
+ $$self{alt} = 0 unless defined $$self{alt};\r
+ $$self{indent} = 4 unless defined $$self{indent};\r
+ $$self{loose} = 0 unless defined $$self{loose};\r
+ $$self{sentence} = 0 unless defined $$self{sentence};\r
+ $$self{width} = 76 unless defined $$self{width};\r
+\r
+ $$self{INDENTS} = []; # Stack of indentations.\r
+ $$self{MARGIN} = $$self{indent}; # Current left margin in spaces.\r
+\r
+ return $self->SUPER::initialize;\r
+}\r
+\r
+\r
+############################################################################\r
+# Core overrides\r
+############################################################################\r
+\r
+# Called for each command paragraph. Gets the command, the associated\r
+# paragraph, the line number, and a Pod::Paragraph object. Just dispatches\r
+# the command to a method named the same as the command. =cut is handled\r
+# internally by Pod::Parser.\r
+sub command {\r
+ my $self = shift;\r
+ my $command = shift;\r
+ return if $command eq 'pod';\r
+ return if ($$self{EXCLUDE} && $command ne 'end');\r
+ if (defined $$self{ITEM}) {\r
+ $self->item ("\n");\r
+ local $_ = "\n";\r
+ $self->output($_) if($command eq 'back');\r
+ }\r
+ $command = 'cmd_' . $command;\r
+ return $self->$command (@_);\r
+}\r
+\r
+# Called for a verbatim paragraph. Gets the paragraph, the line number, and\r
+# a Pod::Paragraph object. Just output it verbatim, but with tabs converted\r
+# to spaces.\r
+sub verbatim {\r
+ my $self = shift;\r
+ return if $$self{EXCLUDE};\r
+ $self->item if defined $$self{ITEM};\r
+ local $_ = shift;\r
+ return if /^\s*$/;\r
+ s/^(\s*\S+)/(' ' x $$self{MARGIN}) . $1/gme;\r
+ return $self->output($_);\r
+}\r
+\r
+# Called for a regular text block. Gets the paragraph, the line number, and\r
+# a Pod::Paragraph object. Perform interpolation and output the results.\r
+sub textblock {\r
+ my $self = shift;\r
+ return if $$self{EXCLUDE};\r
+ if($$self{VERBATIM}) {\r
+ $self->output($_[0]);\r
+ return;\r
+ }\r
+ local $_ = shift;\r
+ my $line = shift;\r
+\r
+ # Perform a little magic to collapse multiple L<> references. This is\r
+ # here mostly for backwards-compatibility. We'll just rewrite the whole\r
+ # thing into actual text at this part, bypassing the whole internal\r
+ # sequence parsing thing.\r
+ s{\r
+ (\r
+ L< # A link of the form L</something>.\r
+ /\r
+ (\r
+ [:\w]+ # The item has to be a simple word...\r
+ (\(\))? # ...or simple function.\r
+ )\r
+ >\r
+ (\r
+ ,?\s+(and\s+)? # Allow lots of them, conjuncted.\r
+ L< \r
+ /\r
+ (\r
+ [:\w]+\r
+ (\(\))?\r
+ )\r
+ >\r
+ )+\r
+ )\r
+ } {\r
+ local $_ = $1;\r
+ s%L</([^>]+)>%$1%g;\r
+ my @items = split /(?:,?\s+(?:and\s+)?)/;\r
+ my $string = "the ";\r
+ my $i;\r
+ for ($i = 0; $i < @items; $i++) {\r
+ $string .= $items[$i];\r
+ $string .= ", " if @items > 2 && $i != $#items;\r
+ $string .= " and " if ($i == $#items - 1);\r
+ }\r
+ $string .= " entries elsewhere in this document";\r
+ $string;\r
+ }gex;\r
+\r
+ # Now actually interpolate and output the paragraph.\r
+ $_ = $self->interpolate ($_, $line);\r
+ s/\s*$/\n/s;\r
+ if (defined $$self{ITEM}) {\r
+ $self->item ($_ . "\n");\r
+ } else {\r
+ $self->output ($self->reformat ($_ . "\n"));\r
+ }\r
+}\r
+\r
+# Called for an interior sequence. Gets the command, argument, and a\r
+# Pod::InteriorSequence object and is expected to return the resulting text.\r
+# Calls code, bold, italic, file, and link to handle those types of\r
+# sequences, and handles S<>, E<>, X<>, and Z<> directly.\r
+sub interior_sequence {\r
+ my $self = shift;\r
+ my $command = shift;\r
+ local $_ = shift;\r
+ return '' if ($command eq 'X' || $command eq 'Z');\r
+\r
+ # Expand escapes into the actual character now, carping if invalid.\r
+ if ($command eq 'E') {\r
+ return $ESCAPES{$_} if defined $ESCAPES{$_};\r
+ carp "Unknown escape: E<$_>";\r
+ return "E<$_>";\r
+ }\r
+\r
+ # For all the other sequences, empty content produces no output.\r
+ return if $_ eq '';\r
+\r
+ # For S<>, compress all internal whitespace and then map spaces to \01.\r
+ # When we output the text, we'll map this back.\r
+ if ($command eq 'S') {\r
+ s/\s{2,}/ /g;\r
+ tr/ /\01/;\r
+ return $_;\r
+ }\r
+\r
+ # Anything else needs to get dispatched to another method.\r
+ if ($command eq 'B') { return $self->seq_b ($_) }\r
+ elsif ($command eq 'C') { return $self->seq_c ($_) }\r
+ elsif ($command eq 'F') { return $self->seq_f ($_) }\r
+ elsif ($command eq 'I') { return $self->seq_i ($_) }\r
+ elsif ($command eq 'L') { return $self->seq_l ($_) }\r
+ else { carp "Unknown sequence $command<$_>" }\r
+}\r
+\r
+# Called for each paragraph that's actually part of the POD. We take\r
+# advantage of this opportunity to untabify the input.\r
+sub preprocess_paragraph {\r
+ my $self = shift;\r
+ local $_ = shift;\r
+ 1 while s/^(.*?)(\t+)/$1 . ' ' x (length ($2) * 8 - length ($1) % 8)/me;\r
+ return $_;\r
+}\r
+\r
+\r
+############################################################################\r
+# Command paragraphs\r
+############################################################################\r
+\r
+# All command paragraphs take the paragraph and the line number.\r
+\r
+# First level heading.\r
+sub cmd_head1 {\r
+ my $self = shift;\r
+ local $_ = shift;\r
+ s/\s+$//s;\r
+ $_ = $self->interpolate ($_, shift);\r
+ if ($$self{alt}) {\r
+ $self->output ("\n==== $_ ====\n\n");\r
+ } else {\r
+ $_ .= "\n" if $$self{loose};\r
+ $self->output ($_ . "\n");\r
+ }\r
+}\r
+\r
+# Second level heading.\r
+sub cmd_head2 {\r
+ my $self = shift;\r
+ local $_ = shift;\r
+ s/\s+$//s;\r
+ $_ = $self->interpolate ($_, shift);\r
+ if ($$self{alt}) {\r
+ $self->output ("\n== $_ ==\n\n");\r
+ } else {\r
+ $_ .= "\n" if $$self{loose};\r
+ $self->output (' ' x ($$self{indent} / 2) . $_ . "\n");\r
+ }\r
+}\r
+\r
+# third level heading - not strictly perlpodspec compliant\r
+sub cmd_head3 {\r
+ my $self = shift;\r
+ local $_ = shift;\r
+ s/\s+$//s;\r
+ $_ = $self->interpolate ($_, shift);\r
+ if ($$self{alt}) {\r
+ $self->output ("\n= $_ =\n");\r
+ } else {\r
+ $_ .= "\n" if $$self{loose};\r
+ $self->output (' ' x ($$self{indent}) . $_ . "\n");\r
+ }\r
+}\r
+\r
+# fourth level heading - not strictly perlpodspec compliant\r
+# just like head3\r
+*cmd_head4 = \&cmd_head3;\r
+\r
+# Start a list.\r
+sub cmd_over {\r
+ my $self = shift;\r
+ local $_ = shift;\r
+ unless (/^[-+]?\d+\s+$/) { $_ = $$self{indent} }\r
+ push (@{ $$self{INDENTS} }, $$self{MARGIN});\r
+ $$self{MARGIN} += ($_ + 0);\r
+}\r
+\r
+# End a list.\r
+sub cmd_back {\r
+ my $self = shift;\r
+ $$self{MARGIN} = pop @{ $$self{INDENTS} };\r
+ unless (defined $$self{MARGIN}) {\r
+ carp 'Unmatched =back';\r
+ $$self{MARGIN} = $$self{indent};\r
+ }\r
+}\r
+\r
+# An individual list item.\r
+sub cmd_item {\r
+ my $self = shift;\r
+ if (defined $$self{ITEM}) { $self->item }\r
+ local $_ = shift;\r
+ s/\s+$//s;\r
+ $$self{ITEM} = $self->interpolate ($_);\r
+}\r
+\r
+# Begin a block for a particular translator. Setting VERBATIM triggers\r
+# special handling in textblock().\r
+sub cmd_begin {\r
+ my $self = shift;\r
+ local $_ = shift;\r
+ my ($kind) = /^(\S+)/ or return;\r
+ if ($kind eq 'text') {\r
+ $$self{VERBATIM} = 1;\r
+ } else {\r
+ $$self{EXCLUDE} = 1;\r
+ }\r
+}\r
+\r
+# End a block for a particular translator. We assume that all =begin/=end\r
+# pairs are properly closed.\r
+sub cmd_end {\r
+ my $self = shift;\r
+ $$self{EXCLUDE} = 0;\r
+ $$self{VERBATIM} = 0;\r
+}\r
+\r
+# One paragraph for a particular translator. Ignore it unless it's intended\r
+# for text, in which case we treat it as a verbatim text block.\r
+sub cmd_for {\r
+ my $self = shift;\r
+ local $_ = shift;\r
+ my $line = shift;\r
+ return unless s/^text\b[ \t]*\r?\n?//;\r
+ $self->verbatim ($_, $line);\r
+}\r
+\r
+# just a dummy method for the time being\r
+sub cmd_encoding {\r
+ return;\r
+}\r
+\r
+############################################################################\r
+# Interior sequences\r
+############################################################################\r
+\r
+# The simple formatting ones. These are here mostly so that subclasses can\r
+# override them and do more complicated things.\r
+sub seq_b { return $_[0]{alt} ? "``$_[1]''" : $_[1] }\r
+sub seq_c { return $_[0]{alt} ? "``$_[1]''" : "`$_[1]'" }\r
+sub seq_f { return $_[0]{alt} ? "\"$_[1]\"" : $_[1] }\r
+sub seq_i { return '*' . $_[1] . '*' }\r
+\r
+# The complicated one. Handle links. Since this is plain text, we can't\r
+# actually make any real links, so this is all to figure out what text we\r
+# print out.\r
+sub seq_l {\r
+ my $self = shift;\r
+ local $_ = shift;\r
+\r
+ # Smash whitespace in case we were split across multiple lines.\r
+ s/\s+/ /g;\r
+\r
+ # If we were given any explicit text, just output it.\r
+ if (/^([^|]+)\|/) { return $1 }\r
+\r
+ # Okay, leading and trailing whitespace isn't important; get rid of it.\r
+ s/^\s+//;\r
+ s/\s+$//;\r
+\r
+ # Default to using the whole content of the link entry as a section\r
+ # name. Note that L<manpage/> forces a manpage interpretation, as does\r
+ # something looking like L<manpage(section)>. The latter is an\r
+ # enhancement over the original Pod::Text.\r
+ my ($manpage, $section) = ('', $_);\r
+ if (/^(?:https?|ftp|news):/) {\r
+ # a URL\r
+ return $_;\r
+ } elsif (/^"\s*(.*?)\s*"$/) {\r
+ $section = '"' . $1 . '"';\r
+ } elsif (m/^[-:.\w]+(?:\(\S+\))?$/) {\r
+ ($manpage, $section) = ($_, '');\r
+ } elsif (m{/}) {\r
+ ($manpage, $section) = split (/\s*\/\s*/, $_, 2);\r
+ }\r
+\r
+ my $text = '';\r
+ # Now build the actual output text.\r
+ if (!length $section) {\r
+ $text = "the $manpage manpage" if length $manpage;\r
+ } elsif ($section =~ /^[:\w]+(?:\(\))?/) {\r
+ $text .= 'the ' . $section . ' entry';\r
+ $text .= (length $manpage) ? " in the $manpage manpage"\r
+ : ' elsewhere in this document';\r
+ } else {\r
+ $section =~ s/^\"\s*//;\r
+ $section =~ s/\s*\"$//;\r
+ $text .= 'the section on "' . $section . '"';\r
+ $text .= " in the $manpage manpage" if length $manpage;\r
+ }\r
+ return $text;\r
+}\r
+\r
+\r
+############################################################################\r
+# List handling\r
+############################################################################\r
+\r
+# This method is called whenever an =item command is complete (in other\r
+# words, we've seen its associated paragraph or know for certain that it\r
+# doesn't have one). It gets the paragraph associated with the item as an\r
+# argument. If that argument is empty, just output the item tag; if it\r
+# contains a newline, output the item tag followed by the newline.\r
+# Otherwise, see if there's enough room for us to output the item tag in the\r
+# margin of the text or if we have to put it on a separate line.\r
+sub item {\r
+ my $self = shift;\r
+ local $_ = shift;\r
+ my $tag = $$self{ITEM};\r
+ unless (defined $tag) {\r
+ carp 'item called without tag';\r
+ return;\r
+ }\r
+ undef $$self{ITEM};\r
+ my $indent = $$self{INDENTS}[-1];\r
+ unless (defined $indent) { $indent = $$self{indent} }\r
+ my $space = ' ' x $indent;\r
+ $space =~ s/^ /:/ if $$self{alt};\r
+ if (!$_ || /^\s+$/ || ($$self{MARGIN} - $indent < length ($tag) + 1)) {\r
+ my $margin = $$self{MARGIN};\r
+ $$self{MARGIN} = $indent;\r
+ my $output = $self->reformat ($tag);\r
+ $output =~ s/[\r\n]*$/\n/;\r
+ $self->output ($output);\r
+ $$self{MARGIN} = $margin;\r
+ $self->output ($self->reformat ($_)) if /\S/;\r
+ } else {\r
+ $_ = $self->reformat ($_);\r
+ s/^ /:/ if ($$self{alt} && $indent > 0);\r
+ my $tagspace = ' ' x length $tag;\r
+ s/^($space)$tagspace/$1$tag/ or carp 'Bizarre space in item';\r
+ $self->output ($_);\r
+ }\r
+}\r
+\r
+\r
+############################################################################\r
+# Output formatting\r
+############################################################################\r
+\r
+# Wrap a line, indenting by the current left margin. We can't use\r
+# Text::Wrap because it plays games with tabs. We can't use formline, even\r
+# though we'd really like to, because it screws up non-printing characters.\r
+# So we have to do the wrapping ourselves.\r
+sub wrap {\r
+ my $self = shift;\r
+ local $_ = shift;\r
+ my $output = '';\r
+ my $spaces = ' ' x $$self{MARGIN};\r
+ my $width = $$self{width} - $$self{MARGIN};\r
+ while (length > $width) {\r
+ if (s/^([^\r\n]{0,$width})\s+// || s/^([^\r\n]{$width})//) {\r
+ $output .= $spaces . $1 . "\n";\r
+ } else {\r
+ last;\r
+ }\r
+ }\r
+ $output .= $spaces . $_;\r
+ $output =~ s/\s+$/\n\n/;\r
+ return $output;\r
+}\r
+\r
+# Reformat a paragraph of text for the current margin. Takes the text to\r
+# reformat and returns the formatted text.\r
+sub reformat {\r
+ my $self = shift;\r
+ local $_ = shift;\r
+\r
+ # If we're trying to preserve two spaces after sentences, do some\r
+ # munging to support that. Otherwise, smash all repeated whitespace.\r
+ if ($$self{sentence}) {\r
+ s/ +$//mg;\r
+ s/\.\r?\n/. \n/g;\r
+ s/[\r\n]+/ /g;\r
+ s/ +/ /g;\r
+ } else {\r
+ s/\s+/ /g;\r
+ }\r
+ return $self->wrap($_);\r
+}\r
+\r
+# Output text to the output device.\r
+sub output { $_[1] =~ tr/\01/ /; print { $_[0]->output_handle } $_[1] }\r
+\r
+\r
+############################################################################\r
+# Backwards compatibility\r
+############################################################################\r
+\r
+# The old Pod::Text module did everything in a pod2text() function. This\r
+# tries to provide the same interface for legacy applications.\r
+sub pod2text {\r
+ my @args;\r
+\r
+ # This is really ugly; I hate doing option parsing in the middle of a\r
+ # module. But the old Pod::Text module supported passing flags to its\r
+ # entry function, so handle -a and -<number>.\r
+ while ($_[0] =~ /^-/) {\r
+ my $flag = shift;\r
+ if ($flag eq '-a') { push (@args, alt => 1) }\r
+ elsif ($flag =~ /^-(\d+)$/) { push (@args, width => $1) }\r
+ else {\r
+ unshift (@_, $flag);\r
+ last;\r
+ }\r
+ }\r
+\r
+ # Now that we know what arguments we're using, create the parser.\r
+ my $parser = Pod::PlainText->new (@args);\r
+\r
+ # If two arguments were given, the second argument is going to be a file\r
+ # handle. That means we want to call parse_from_filehandle(), which\r
+ # means we need to turn the first argument into a file handle. Magic\r
+ # open will handle the <&STDIN case automagically.\r
+ if (defined $_[1]) {\r
+ my $infh;\r
+ if ($] < 5.006) {\r
+ $infh = gensym();\r
+ }\r
+ unless (open ($infh, $_[0])) {\r
+ croak ("Can't open $_[0] for reading: $!\n");\r
+ }\r
+ $_[0] = $infh;\r
+ return $parser->parse_from_filehandle (@_);\r
+ } else {\r
+ return $parser->parse_from_file (@_);\r
+ }\r
+}\r
+\r
+\r
+############################################################################\r
+# Module return value and documentation\r
+############################################################################\r
+\r
+1;\r
+__END__\r
+\r
+=head1 NAME\r
+\r
+Pod::PlainText - Convert POD data to formatted ASCII text\r
+\r
+=head1 SYNOPSIS\r
+\r
+ use Pod::PlainText;\r
+ my $parser = Pod::PlainText->new (sentence => 0, width => 78);\r
+\r
+ # Read POD from STDIN and write to STDOUT.\r
+ $parser->parse_from_filehandle;\r
+\r
+ # Read POD from file.pod and write to file.txt.\r
+ $parser->parse_from_file ('file.pod', 'file.txt');\r
+\r
+=head1 DESCRIPTION\r
+\r
+Pod::PlainText is a module that can convert documentation in the POD format (the\r
+preferred language for documenting Perl) into formatted ASCII. It uses no\r
+special formatting controls or codes whatsoever, and its output is therefore\r
+suitable for nearly any device.\r
+\r
+As a derived class from Pod::Parser, Pod::PlainText supports the same methods and\r
+interfaces. See L<Pod::Parser> for all the details; briefly, one creates a\r
+new parser with C<Pod::PlainText-E<gt>new()> and then calls either\r
+parse_from_filehandle() or parse_from_file().\r
+\r
+new() can take options, in the form of key/value pairs, that control the\r
+behavior of the parser. The currently recognized options are:\r
+\r
+=over 4\r
+\r
+=item alt\r
+\r
+If set to a true value, selects an alternate output format that, among other\r
+things, uses a different heading style and marks C<=item> entries with a\r
+colon in the left margin. Defaults to false.\r
+\r
+=item indent\r
+\r
+The number of spaces to indent regular text, and the default indentation for\r
+C<=over> blocks. Defaults to 4.\r
+\r
+=item loose\r
+\r
+If set to a true value, a blank line is printed after a C<=headN> headings.\r
+If set to false (the default), no blank line is printed after C<=headN>.\r
+This is the default because it's the expected formatting for manual pages;\r
+if you're formatting arbitrary text documents, setting this to true may\r
+result in more pleasing output.\r
+\r
+=item sentence\r
+\r
+If set to a true value, Pod::PlainText will assume that each sentence ends in two\r
+spaces, and will try to preserve that spacing. If set to false, all\r
+consecutive whitespace in non-verbatim paragraphs is compressed into a\r
+single space. Defaults to true.\r
+\r
+=item width\r
+\r
+The column at which to wrap text on the right-hand side. Defaults to 76.\r
+\r
+=back\r
+\r
+The standard Pod::Parser method parse_from_filehandle() takes up to two\r
+arguments, the first being the file handle to read POD from and the second\r
+being the file handle to write the formatted output to. The first defaults\r
+to STDIN if not given, and the second defaults to STDOUT. The method\r
+parse_from_file() is almost identical, except that its two arguments are the\r
+input and output disk files instead. See L<Pod::Parser> for the specific\r
+details.\r
+\r
+=head1 DIAGNOSTICS\r
+\r
+=over 4\r
+\r
+=item Bizarre space in item\r
+\r
+(W) Something has gone wrong in internal C<=item> processing. This message\r
+indicates a bug in Pod::PlainText; you should never see it.\r
+\r
+=item Can't open %s for reading: %s\r
+\r
+(F) Pod::PlainText was invoked via the compatibility mode pod2text() interface\r
+and the input file it was given could not be opened.\r
+\r
+=item Unknown escape: %s\r
+\r
+(W) The POD source contained an C<EE<lt>E<gt>> escape that Pod::PlainText didn't\r
+know about.\r
+\r
+=item Unknown sequence: %s\r
+\r
+(W) The POD source contained a non-standard internal sequence (something of\r
+the form C<XE<lt>E<gt>>) that Pod::PlainText didn't know about.\r
+\r
+=item Unmatched =back\r
+\r
+(W) Pod::PlainText encountered a C<=back> command that didn't correspond to an\r
+C<=over> command.\r
+\r
+=back\r
+\r
+=head1 RESTRICTIONS\r
+\r
+Embedded Ctrl-As (octal 001) in the input will be mapped to spaces on\r
+output, due to an internal implementation detail.\r
+\r
+=head1 NOTES\r
+\r
+This is a replacement for an earlier Pod::Text module written by Tom\r
+Christiansen. It has a revamped interface, since it now uses Pod::Parser,\r
+but an interface roughly compatible with the old Pod::Text::pod2text()\r
+function is still available. Please change to the new calling convention,\r
+though.\r
+\r
+The original Pod::Text contained code to do formatting via termcap\r
+sequences, although it wasn't turned on by default and it was problematic to\r
+get it to work at all. This rewrite doesn't even try to do that, but a\r
+subclass of it does. Look for L<Pod::Text::Termcap|Pod::Text::Termcap>.\r
+\r
+=head1 SEE ALSO\r
+\r
+B<Pod::PlainText> is part of the L<Pod::Parser> distribution.\r
+\r
+L<Pod::Parser|Pod::Parser>, L<Pod::Text::Termcap|Pod::Text::Termcap>,\r
+pod2text(1)\r
+\r
+=head1 AUTHOR\r
+\r
+Please report bugs using L<http://rt.cpan.org>.\r
+\r
+Russ Allbery E<lt>rra@stanford.eduE<gt>, based I<very> heavily on the\r
+original Pod::Text by Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> and\r
+its conversion to Pod::Parser by Brad Appleton\r
+E<lt>bradapp@enteract.comE<gt>.\r
+\r
+=cut\r
--- /dev/null
+#############################################################################\r
+# Pod/Select.pm -- function to select portions of POD docs\r
+#\r
+# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved.\r
+# This file is part of "PodParser". PodParser is free software;\r
+# you can redistribute it and/or modify it under the same terms\r
+# as Perl itself.\r
+#############################################################################\r
+\r
+package Pod::Select;\r
+use strict;\r
+\r
+use vars qw($VERSION @ISA @EXPORT $MAX_HEADING_LEVEL %myData @section_headings @selected_sections);\r
+$VERSION = '1.60'; ## Current version of this package\r
+require 5.005; ## requires this Perl version or later\r
+\r
+#############################################################################\r
+\r
+=head1 NAME\r
+\r
+Pod::Select, podselect() - extract selected sections of POD from input\r
+\r
+=head1 SYNOPSIS\r
+\r
+ use Pod::Select;\r
+\r
+ ## Select all the POD sections for each file in @filelist\r
+ ## and print the result on standard output.\r
+ podselect(@filelist);\r
+\r
+ ## Same as above, but write to tmp.out\r
+ podselect({-output => "tmp.out"}, @filelist):\r
+\r
+ ## Select from the given filelist, only those POD sections that are\r
+ ## within a 1st level section named any of: NAME, SYNOPSIS, OPTIONS.\r
+ podselect({-sections => ["NAME|SYNOPSIS", "OPTIONS"]}, @filelist):\r
+\r
+ ## Select the "DESCRIPTION" section of the PODs from STDIN and write\r
+ ## the result to STDERR.\r
+ podselect({-output => ">&STDERR", -sections => ["DESCRIPTION"]}, \*STDIN);\r
+\r
+or\r
+\r
+ use Pod::Select;\r
+\r
+ ## Create a parser object for selecting POD sections from the input\r
+ $parser = new Pod::Select();\r
+\r
+ ## Select all the POD sections for each file in @filelist\r
+ ## and print the result to tmp.out.\r
+ $parser->parse_from_file("<&STDIN", "tmp.out");\r
+\r
+ ## Select from the given filelist, only those POD sections that are\r
+ ## within a 1st level section named any of: NAME, SYNOPSIS, OPTIONS.\r
+ $parser->select("NAME|SYNOPSIS", "OPTIONS");\r
+ for (@filelist) { $parser->parse_from_file($_); }\r
+\r
+ ## Select the "DESCRIPTION" and "SEE ALSO" sections of the PODs from\r
+ ## STDIN and write the result to STDERR.\r
+ $parser->select("DESCRIPTION");\r
+ $parser->add_selection("SEE ALSO");\r
+ $parser->parse_from_filehandle(\*STDIN, \*STDERR);\r
+\r
+=head1 REQUIRES\r
+\r
+perl5.005, Pod::Parser, Exporter, Carp\r
+\r
+=head1 EXPORTS\r
+\r
+podselect()\r
+\r
+=head1 DESCRIPTION\r
+\r
+B<podselect()> is a function which will extract specified sections of\r
+pod documentation from an input stream. This ability is provided by the\r
+B<Pod::Select> module which is a subclass of B<Pod::Parser>.\r
+B<Pod::Select> provides a method named B<select()> to specify the set of\r
+POD sections to select for processing/printing. B<podselect()> merely\r
+creates a B<Pod::Select> object and then invokes the B<podselect()>\r
+followed by B<parse_from_file()>.\r
+\r
+=head1 SECTION SPECIFICATIONS\r
+\r
+B<podselect()> and B<Pod::Select::select()> may be given one or more\r
+"section specifications" to restrict the text processed to only the\r
+desired set of sections and their corresponding subsections. A section\r
+specification is a string containing one or more Perl-style regular\r
+expressions separated by forward slashes ("/"). If you need to use a\r
+forward slash literally within a section title you can escape it with a\r
+backslash ("\/").\r
+\r
+The formal syntax of a section specification is:\r
+\r
+=over 4\r
+\r
+=item *\r
+\r
+I<head1-title-regex>/I<head2-title-regex>/...\r
+\r
+=back\r
+\r
+Any omitted or empty regular expressions will default to ".*".\r
+Please note that each regular expression given is implicitly\r
+anchored by adding "^" and "$" to the beginning and end. Also, if a\r
+given regular expression starts with a "!" character, then the\r
+expression is I<negated> (so C<!foo> would match anything I<except>\r
+C<foo>).\r
+\r
+Some example section specifications follow.\r
+\r
+=over 4\r
+\r
+=item *\r
+\r
+Match the C<NAME> and C<SYNOPSIS> sections and all of their subsections:\r
+\r
+C<NAME|SYNOPSIS>\r
+\r
+=item *\r
+\r
+Match only the C<Question> and C<Answer> subsections of the C<DESCRIPTION>\r
+section:\r
+\r
+C<DESCRIPTION/Question|Answer>\r
+\r
+=item *\r
+\r
+Match the C<Comments> subsection of I<all> sections:\r
+\r
+C</Comments>\r
+\r
+=item *\r
+\r
+Match all subsections of C<DESCRIPTION> I<except> for C<Comments>:\r
+\r
+C<DESCRIPTION/!Comments>\r
+\r
+=item *\r
+\r
+Match the C<DESCRIPTION> section but do I<not> match any of its subsections:\r
+\r
+C<DESCRIPTION/!.+>\r
+\r
+=item *\r
+\r
+Match all top level sections but none of their subsections:\r
+\r
+C</!.+>\r
+\r
+=back \r
+\r
+=begin _NOT_IMPLEMENTED_\r
+\r
+=head1 RANGE SPECIFICATIONS\r
+\r
+B<podselect()> and B<Pod::Select::select()> may be given one or more\r
+"range specifications" to restrict the text processed to only the\r
+desired ranges of paragraphs in the desired set of sections. A range\r
+specification is a string containing a single Perl-style regular\r
+expression (a regex), or else two Perl-style regular expressions\r
+(regexs) separated by a ".." (Perl's "range" operator is "..").\r
+The regexs in a range specification are delimited by forward slashes\r
+("/"). If you need to use a forward slash literally within a regex you\r
+can escape it with a backslash ("\/").\r
+\r
+The formal syntax of a range specification is:\r
+\r
+=over 4\r
+\r
+=item *\r
+\r
+/I<start-range-regex>/[../I<end-range-regex>/]\r
+\r
+=back\r
+\r
+Where each the item inside square brackets (the ".." followed by the\r
+end-range-regex) is optional. Each "range-regex" is of the form:\r
+\r
+ =cmd-expr text-expr\r
+\r
+Where I<cmd-expr> is intended to match the name of one or more POD\r
+commands, and I<text-expr> is intended to match the paragraph text for\r
+the command. If a range-regex is supposed to match a POD command, then\r
+the first character of the regex (the one after the initial '/')\r
+absolutely I<must> be a single '=' character; it may not be anything\r
+else (not even a regex meta-character) if it is supposed to match\r
+against the name of a POD command.\r
+\r
+If no I<=cmd-expr> is given then the text-expr will be matched against\r
+plain textblocks unless it is preceded by a space, in which case it is\r
+matched against verbatim text-blocks. If no I<text-expr> is given then\r
+only the command-portion of the paragraph is matched against.\r
+\r
+Note that these two expressions are each implicitly anchored. This\r
+means that when matching against the command-name, there will be an\r
+implicit '^' and '$' around the given I<=cmd-expr>; and when matching\r
+against the paragraph text there will be an implicit '\A' and '\Z'\r
+around the given I<text-expr>.\r
+\r
+Unlike with section-specs, the '!' character does I<not> have any special\r
+meaning (negation or otherwise) at the beginning of a range-spec!\r
+\r
+Some example range specifications follow.\r
+\r
+=over 4\r
+\r
+=item\r
+Match all C<=for html> paragraphs:\r
+\r
+C</=for html/>\r
+\r
+=item\r
+Match all paragraphs between C<=begin html> and C<=end html>\r
+(note that this will I<not> work correctly if such sections\r
+are nested):\r
+\r
+C</=begin html/../=end html/>\r
+\r
+=item\r
+Match all paragraphs between the given C<=item> name until the end of the\r
+current section:\r
+\r
+C</=item mine/../=head\d/>\r
+\r
+=item\r
+Match all paragraphs between the given C<=item> until the next item, or\r
+until the end of the itemized list (note that this will I<not> work as\r
+desired if the item contains an itemized list nested within it):\r
+\r
+C</=item mine/../=(item|back)/>\r
+\r
+=back \r
+\r
+=end _NOT_IMPLEMENTED_\r
+\r
+=cut\r
+\r
+#############################################################################\r
+\r
+#use diagnostics;\r
+use Carp;\r
+use Pod::Parser 1.04;\r
+\r
+@ISA = qw(Pod::Parser);\r
+@EXPORT = qw(&podselect);\r
+\r
+## Maximum number of heading levels supported for '=headN' directives\r
+*MAX_HEADING_LEVEL = \3;\r
+\r
+#############################################################################\r
+\r
+=head1 OBJECT METHODS\r
+\r
+The following methods are provided in this module. Each one takes a\r
+reference to the object itself as an implicit first parameter.\r
+\r
+=cut\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+## =begin _PRIVATE_\r
+## \r
+## =head1 B<_init_headings()>\r
+## \r
+## Initialize the current set of active section headings.\r
+## \r
+## =cut\r
+## \r
+## =end _PRIVATE_\r
+\r
+sub _init_headings {\r
+ my $self = shift;\r
+ local *myData = $self;\r
+\r
+ ## Initialize current section heading titles if necessary\r
+ unless (defined $myData{_SECTION_HEADINGS}) {\r
+ local *section_headings = $myData{_SECTION_HEADINGS} = [];\r
+ for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) {\r
+ $section_headings[$i] = '';\r
+ }\r
+ }\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head1 B<curr_headings()>\r
+\r
+ ($head1, $head2, $head3, ...) = $parser->curr_headings();\r
+ $head1 = $parser->curr_headings(1);\r
+\r
+This method returns a list of the currently active section headings and\r
+subheadings in the document being parsed. The list of headings returned\r
+corresponds to the most recently parsed paragraph of the input.\r
+\r
+If an argument is given, it must correspond to the desired section\r
+heading number, in which case only the specified section heading is\r
+returned. If there is no current section heading at the specified\r
+level, then C<undef> is returned.\r
+\r
+=cut\r
+\r
+sub curr_headings {\r
+ my $self = shift;\r
+ $self->_init_headings() unless (defined $self->{_SECTION_HEADINGS});\r
+ my @headings = @{ $self->{_SECTION_HEADINGS} };\r
+ return (@_ > 0 and $_[0] =~ /^\d+$/) ? $headings[$_[0] - 1] : @headings;\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head1 B<select()>\r
+\r
+ $parser->select($section_spec1,$section_spec2,...);\r
+\r
+This method is used to select the particular sections and subsections of\r
+POD documentation that are to be printed and/or processed. The existing\r
+set of selected sections is I<replaced> with the given set of sections.\r
+See B<add_selection()> for adding to the current set of selected\r
+sections.\r
+\r
+Each of the C<$section_spec> arguments should be a section specification\r
+as described in L<"SECTION SPECIFICATIONS">. The section specifications\r
+are parsed by this method and the resulting regular expressions are\r
+stored in the invoking object.\r
+\r
+If no C<$section_spec> arguments are given, then the existing set of\r
+selected sections is cleared out (which means C<all> sections will be\r
+processed).\r
+\r
+This method should I<not> normally be overridden by subclasses.\r
+\r
+=cut\r
+\r
+sub select {\r
+ my ($self, @sections) = @_;\r
+ local *myData = $self;\r
+ local $_;\r
+\r
+### NEED TO DISCERN A SECTION-SPEC FROM A RANGE-SPEC (look for m{^/.+/$}?)\r
+\r
+ ##---------------------------------------------------------------------\r
+ ## The following is a blatant hack for backward compatibility, and for\r
+ ## implementing add_selection(). If the *first* *argument* is the\r
+ ## string "+", then the remaining section specifications are *added*\r
+ ## to the current set of selections; otherwise the given section\r
+ ## specifications will *replace* the current set of selections.\r
+ ##\r
+ ## This should probably be fixed someday, but for the present time,\r
+ ## it seems incredibly unlikely that "+" would ever correspond to\r
+ ## a legitimate section heading\r
+ ##---------------------------------------------------------------------\r
+ my $add = ($sections[0] eq '+') ? shift(@sections) : '';\r
+\r
+ ## Reset the set of sections to use\r
+ unless (@sections) {\r
+ delete $myData{_SELECTED_SECTIONS} unless ($add);\r
+ return;\r
+ }\r
+ $myData{_SELECTED_SECTIONS} = []\r
+ unless ($add && exists $myData{_SELECTED_SECTIONS});\r
+ local *selected_sections = $myData{_SELECTED_SECTIONS};\r
+\r
+ ## Compile each spec\r
+ for my $spec (@sections) {\r
+ if ( defined($_ = _compile_section_spec($spec)) ) {\r
+ ## Store them in our sections array\r
+ push(@selected_sections, $_);\r
+ }\r
+ else {\r
+ carp qq{Ignoring section spec "$spec"!\n};\r
+ }\r
+ }\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head1 B<add_selection()>\r
+\r
+ $parser->add_selection($section_spec1,$section_spec2,...);\r
+\r
+This method is used to add to the currently selected sections and\r
+subsections of POD documentation that are to be printed and/or\r
+processed. See <select()> for replacing the currently selected sections.\r
+\r
+Each of the C<$section_spec> arguments should be a section specification\r
+as described in L<"SECTION SPECIFICATIONS">. The section specifications\r
+are parsed by this method and the resulting regular expressions are\r
+stored in the invoking object.\r
+\r
+This method should I<not> normally be overridden by subclasses.\r
+\r
+=cut\r
+\r
+sub add_selection {\r
+ my $self = shift;\r
+ return $self->select('+', @_);\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head1 B<clear_selections()>\r
+\r
+ $parser->clear_selections();\r
+\r
+This method takes no arguments, it has the exact same effect as invoking\r
+<select()> with no arguments.\r
+\r
+=cut\r
+\r
+sub clear_selections {\r
+ my $self = shift;\r
+ return $self->select();\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head1 B<match_section()>\r
+\r
+ $boolean = $parser->match_section($heading1,$heading2,...);\r
+\r
+Returns a value of true if the given section and subsection heading\r
+titles match any of the currently selected section specifications in\r
+effect from prior calls to B<select()> and B<add_selection()> (or if\r
+there are no explicitly selected/deselected sections).\r
+\r
+The arguments C<$heading1>, C<$heading2>, etc. are the heading titles of\r
+the corresponding sections, subsections, etc. to try and match. If\r
+C<$headingN> is omitted then it defaults to the current corresponding\r
+section heading title in the input.\r
+\r
+This method should I<not> normally be overridden by subclasses.\r
+\r
+=cut\r
+\r
+sub match_section {\r
+ my $self = shift;\r
+ my (@headings) = @_;\r
+ local *myData = $self;\r
+\r
+ ## Return true if no restrictions were explicitly specified\r
+ my $selections = (exists $myData{_SELECTED_SECTIONS})\r
+ ? $myData{_SELECTED_SECTIONS} : undef;\r
+ return 1 unless ((defined $selections) && @{$selections});\r
+\r
+ ## Default any unspecified sections to the current one\r
+ my @current_headings = $self->curr_headings();\r
+ for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) {\r
+ (defined $headings[$i]) or $headings[$i] = $current_headings[$i];\r
+ }\r
+\r
+ ## Look for a match against the specified section expressions\r
+ for my $section_spec ( @{$selections} ) {\r
+ ##------------------------------------------------------\r
+ ## Each portion of this spec must match in order for\r
+ ## the spec to be matched. So we will start with a \r
+ ## match-value of 'true' and logically 'and' it with\r
+ ## the results of matching a given element of the spec.\r
+ ##------------------------------------------------------\r
+ my $match = 1;\r
+ for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) {\r
+ my $regex = $section_spec->[$i];\r
+ my $negated = ($regex =~ s/^\!//);\r
+ $match &= ($negated ? ($headings[$i] !~ /${regex}/)\r
+ : ($headings[$i] =~ /${regex}/));\r
+ last unless ($match);\r
+ }\r
+ return 1 if ($match);\r
+ }\r
+ return 0; ## no match\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head1 B<is_selected()>\r
+\r
+ $boolean = $parser->is_selected($paragraph);\r
+\r
+This method is used to determine if the block of text given in\r
+C<$paragraph> falls within the currently selected set of POD sections\r
+and subsections to be printed or processed. This method is also\r
+responsible for keeping track of the current input section and\r
+subsections. It is assumed that C<$paragraph> is the most recently read\r
+(but not yet processed) input paragraph.\r
+\r
+The value returned will be true if the C<$paragraph> and the rest of the\r
+text in the same section as C<$paragraph> should be selected (included)\r
+for processing; otherwise a false value is returned.\r
+\r
+=cut\r
+\r
+sub is_selected {\r
+ my ($self, $paragraph) = @_;\r
+ local $_;\r
+ local *myData = $self;\r
+\r
+ $self->_init_headings() unless (defined $myData{_SECTION_HEADINGS});\r
+\r
+ ## Keep track of current sections levels and headings\r
+ $_ = $paragraph;\r
+ if (/^=((?:sub)*)(?:head(?:ing)?|sec(?:tion)?)(\d*)\s+(.*?)\s*$/)\r
+ {\r
+ ## This is a section heading command\r
+ my ($level, $heading) = ($2, $3);\r
+ $level = 1 + (length($1) / 3) if ((! length $level) || (length $1));\r
+ ## Reset the current section heading at this level\r
+ $myData{_SECTION_HEADINGS}->[$level - 1] = $heading;\r
+ ## Reset subsection headings of this one to empty\r
+ for (my $i = $level; $i < $MAX_HEADING_LEVEL; ++$i) {\r
+ $myData{_SECTION_HEADINGS}->[$i] = '';\r
+ }\r
+ }\r
+\r
+ return $self->match_section();\r
+}\r
+\r
+#############################################################################\r
+\r
+=head1 EXPORTED FUNCTIONS\r
+\r
+The following functions are exported by this module. Please note that\r
+these are functions (not methods) and therefore C<do not> take an\r
+implicit first argument.\r
+\r
+=cut\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=head1 B<podselect()>\r
+\r
+ podselect(\%options,@filelist);\r
+\r
+B<podselect> will print the raw (untranslated) POD paragraphs of all\r
+POD sections in the given input files specified by C<@filelist>\r
+according to the given options.\r
+\r
+If any argument to B<podselect> is a reference to a hash\r
+(associative array) then the values with the following keys are\r
+processed as follows:\r
+\r
+=over 4\r
+\r
+=item B<-output>\r
+\r
+A string corresponding to the desired output file (or ">&STDOUT"\r
+or ">&STDERR"). The default is to use standard output.\r
+\r
+=item B<-sections>\r
+\r
+A reference to an array of sections specifications (as described in\r
+L<"SECTION SPECIFICATIONS">) which indicate the desired set of POD\r
+sections and subsections to be selected from input. If no section\r
+specifications are given, then all sections of the PODs are used.\r
+\r
+=begin _NOT_IMPLEMENTED_\r
+\r
+=item B<-ranges>\r
+\r
+A reference to an array of range specifications (as described in\r
+L<"RANGE SPECIFICATIONS">) which indicate the desired range of POD\r
+paragraphs to be selected from the desired input sections. If no range\r
+specifications are given, then all paragraphs of the desired sections\r
+are used.\r
+\r
+=end _NOT_IMPLEMENTED_\r
+\r
+=back\r
+\r
+All other arguments should correspond to the names of input files\r
+containing POD sections. A file name of "-" or "<&STDIN" will\r
+be interpreted to mean standard input (which is the default if no\r
+filenames are given).\r
+\r
+=cut \r
+\r
+sub podselect {\r
+ my(@argv) = @_;\r
+ my %defaults = ();\r
+ my $pod_parser = new Pod::Select(%defaults);\r
+ my $num_inputs = 0;\r
+ my $output = '>&STDOUT';\r
+ my %opts;\r
+ local $_;\r
+ for (@argv) {\r
+ if (ref($_)) {\r
+ next unless (ref($_) eq 'HASH');\r
+ %opts = (%defaults, %{$_});\r
+\r
+ ##-------------------------------------------------------------\r
+ ## Need this for backward compatibility since we formerly used\r
+ ## options that were all uppercase words rather than ones that\r
+ ## looked like Unix command-line options.\r
+ ## to be uppercase keywords)\r
+ ##-------------------------------------------------------------\r
+ %opts = map {\r
+ my ($key, $val) = (lc $_, $opts{$_});\r
+ $key =~ s/^(?=\w)/-/;\r
+ $key =~ /^-se[cl]/ and $key = '-sections';\r
+ #! $key eq '-range' and $key .= 's';\r
+ ($key => $val);\r
+ } (keys %opts);\r
+\r
+ ## Process the options\r
+ (exists $opts{'-output'}) and $output = $opts{'-output'};\r
+\r
+ ## Select the desired sections\r
+ $pod_parser->select(@{ $opts{'-sections'} })\r
+ if ( (defined $opts{'-sections'})\r
+ && ((ref $opts{'-sections'}) eq 'ARRAY') );\r
+\r
+ #! ## Select the desired paragraph ranges\r
+ #! $pod_parser->select(@{ $opts{'-ranges'} })\r
+ #! if ( (defined $opts{'-ranges'})\r
+ #! && ((ref $opts{'-ranges'}) eq 'ARRAY') );\r
+ }\r
+ else {\r
+ $pod_parser->parse_from_file($_, $output);\r
+ ++$num_inputs;\r
+ }\r
+ }\r
+ $pod_parser->parse_from_file('-') unless ($num_inputs > 0);\r
+}\r
+\r
+#############################################################################\r
+\r
+=head1 PRIVATE METHODS AND DATA\r
+\r
+B<Pod::Select> makes uses a number of internal methods and data fields\r
+which clients should not need to see or use. For the sake of avoiding\r
+name collisions with client data and methods, these methods and fields\r
+are briefly discussed here. Determined hackers may obtain further\r
+information about them by reading the B<Pod::Select> source code.\r
+\r
+Private data fields are stored in the hash-object whose reference is\r
+returned by the B<new()> constructor for this class. The names of all\r
+private methods and data-fields used by B<Pod::Select> begin with a\r
+prefix of "_" and match the regular expression C</^_\w+$/>.\r
+\r
+=cut\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=begin _PRIVATE_\r
+\r
+=head1 B<_compile_section_spec()>\r
+\r
+ $listref = $parser->_compile_section_spec($section_spec);\r
+\r
+This function (note it is a function and I<not> a method) takes a\r
+section specification (as described in L<"SECTION SPECIFICATIONS">)\r
+given in C<$section_sepc>, and compiles it into a list of regular\r
+expressions. If C<$section_spec> has no syntax errors, then a reference\r
+to the list (array) of corresponding regular expressions is returned;\r
+otherwise C<undef> is returned and an error message is printed (using\r
+B<carp>) for each invalid regex.\r
+\r
+=end _PRIVATE_\r
+\r
+=cut\r
+\r
+sub _compile_section_spec {\r
+ my ($section_spec) = @_;\r
+ my (@regexs, $negated);\r
+\r
+ ## Compile the spec into a list of regexs\r
+ local $_ = $section_spec;\r
+ s{\\\\}{\001}g; ## handle escaped backward slashes\r
+ s{\\/}{\002}g; ## handle escaped forward slashes\r
+\r
+ ## Parse the regexs for the heading titles\r
+ @regexs = split(/\//, $_, $MAX_HEADING_LEVEL);\r
+\r
+ ## Set default regex for ommitted levels\r
+ for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) {\r
+ $regexs[$i] = '.*' unless ((defined $regexs[$i])\r
+ && (length $regexs[$i]));\r
+ }\r
+ ## Modify the regexs as needed and validate their syntax\r
+ my $bad_regexs = 0;\r
+ for (@regexs) {\r
+ $_ .= '.+' if ($_ eq '!');\r
+ s{\001}{\\\\}g; ## restore escaped backward slashes\r
+ s{\002}{\\/}g; ## restore escaped forward slashes\r
+ $negated = s/^\!//; ## check for negation\r
+ eval "m{$_}"; ## check regex syntax\r
+ if ($@) {\r
+ ++$bad_regexs;\r
+ carp qq{Bad regular expression /$_/ in "$section_spec": $@\n};\r
+ }\r
+ else {\r
+ ## Add the forward and rear anchors (and put the negator back)\r
+ $_ = '^' . $_ unless (/^\^/);\r
+ $_ = $_ . '$' unless (/\$$/);\r
+ $_ = '!' . $_ if ($negated);\r
+ }\r
+ }\r
+ return (! $bad_regexs) ? [ @regexs ] : undef;\r
+}\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=begin _PRIVATE_\r
+\r
+=head2 $self->{_SECTION_HEADINGS}\r
+\r
+A reference to an array of the current section heading titles for each\r
+heading level (note that the first heading level title is at index 0).\r
+\r
+=end _PRIVATE_\r
+\r
+=cut\r
+\r
+##---------------------------------------------------------------------------\r
+\r
+=begin _PRIVATE_\r
+\r
+=head2 $self->{_SELECTED_SECTIONS}\r
+\r
+A reference to an array of references to arrays. Each subarray is a list\r
+of anchored regular expressions (preceded by a "!" if the expression is to\r
+be negated). The index of the expression in the subarray should correspond\r
+to the index of the heading title in C<$self-E<gt>{_SECTION_HEADINGS}>\r
+that it is to be matched against.\r
+\r
+=end _PRIVATE_\r
+\r
+=cut\r
+\r
+#############################################################################\r
+\r
+=head1 SEE ALSO\r
+\r
+L<Pod::Parser>\r
+\r
+=head1 AUTHOR\r
+\r
+Please report bugs using L<http://rt.cpan.org>.\r
+\r
+Brad Appleton E<lt>bradapp@enteract.comE<gt>\r
+\r
+Based on code for B<pod2text> written by\r
+Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>\r
+\r
+B<Pod::Select> is part of the L<Pod::Parser> distribution.\r
+\r
+=cut\r
+\r
+1;\r
+# vim: ts=4 sw=4 et\r
plan skip_all => "Not portable on Win32 or VMS\n";
}
else {
- plan tests => 34;
+ plan tests => 33;
}
use_ok ("Pod::Usage");
}
#
EOT
-# test with pod_where
-use_ok('Pod::Find', qw(pod_where));
+# test with self
-($exit, $text) = getoutput( sub { pod2usage( -input => pod_where({-inc => 1}, 'Pod::Usage'),
+my $src = File::Spec->catfile(qw(lib Pod Usage.pm));
+($exit, $text) = getoutput( sub { pod2usage( -input => $src,
-exitval => 0, -verbose => 0) } );
$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
-is ($exit, 0, "Exit status pod2usage with Pod::Find");
-ok (compare ($text, <<'EOT'), "Output test pod2usage with Pod::Find") or diag "Got:\n$text\n";
+is ($exit, 0, "Exit status pod2usage with self");
+ok (compare ($text, <<'EOT'), "Output test pod2usage with self") or diag "Got:\n$text\n";
#Usage:
# use Pod::Usage
#
package TestPodIncPlainText;
+my $PARENTDIR;
+
BEGIN {
use File::Basename;
use File::Spec;
unshift @INC, $THISDIR;
require "testcmp.pl";
import TestCompare;
- my $PARENTDIR = dirname $THISDIR;
+ $PARENTDIR = dirname $THISDIR;
push @INC, map { File::Spec->catfile($_, 'lib') } ($PARENTDIR, $THISDIR);
}
$MYPKG = eval { (caller)[0] };
@EXPORT = qw(&testpodplaintext);
BEGIN {
+ # we want this for testing only
+ unshift(@INC, File::Spec->catfile($PARENTDIR, 'inc'));
+print "INC=@INC\n";
+
require Pod::PlainText;
@ISA = qw( Pod::PlainText );
require VMS::Filespec if $^O eq 'VMS';
use strict;
use warnings;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
BEGIN {
if( $] < 5.008 ) {
}
}
-use overload();
-
use Scalar::Util qw/blessed reftype weaken/;
use Test2::Util qw/USE_THREADS try get_tid/;
use Test::Builder::TodoDiag;
our $Level = 1;
-our $Test = Test::Builder->new;
-
-# 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});
-
-Test2::API::test2_add_callback_exit(sub { $Test->_ending(@_) });
-
-Test2::API::test2_ipc()->set_no_fatal(1) if USE_THREADS;
+our $Test = $ENV{TB_NO_EARLY_INIT} ? undef : Test::Builder->new;
sub _add_ts_hooks {
my $self = shift;
my $ctx = context();
$Test = $class->create(singleton => 1);
$ctx->release;
+
+ # 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 });
+
+ Test2::API::test2_add_callback_exit(sub { $Test->_ending(@_) });
+
+ Test2::API::test2_ipc()->set_no_fatal(1) if USE_THREADS;
}
return $Test;
}
($err, $child_error) = ($@, $?);
# They might have done 'BEGIN { skip_all => "whatever" }'
- if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/) {
+ if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/ || (blessed($err) && blessed($err) eq 'Test::Builder::Exception')) {
$ok = undef;
$err = undef;
}
my $ctx = $self->ctx;
+ if (defined $ctx->hub->plan) {
+ warn "Plan already set, no_plan() is a no-op, this will change to a hard failure in the future.";
+ $ctx->release;
+ return;
+ }
+
$ctx->alert("no_plan takes no arguments") if $arg;
$ctx->hub->plan('NO PLAN');
return unless ref $$thing;
return unless blessed($$thing) || scalar $self->_try(sub{ $$thing->isa('UNIVERSAL') });
+ {
+ local ($!, $@);
+ require overload;
+ }
my $string_meth = overload::Method( $$thing, $type ) || return;
$$thing = $$thing->$string_meth();
}
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.
+B<NOTE>: the implementation is not complete. C<level>, for example, is still
+shared by B<all> Test::Builder objects, even ones created using this method.
+Also, the method name may change in the future.
=item B<subtest>
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;
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.
+regular expression, or C<undef> if its argument is not recognized.
For example, a version of C<like()>, sans the useful diagnostic messages,
could be written as:
=head1 THREADS
-In perl 5.8.1 and later, Test::Builder is thread-safe. The test
-number is shared amongst all threads. This means if one thread sets
-the test number using C<current_test()> they will all be effected.
+In perl 5.8.1 and later, Test::Builder is thread-safe. The test number is
+shared by all threads. This means if one thread sets the test number using
+C<current_test()> they will all be effected.
While versions earlier than 5.8.1 had threads they contain too many
bugs to support.
use strict;
use warnings;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
-use base 'Test2::Formatter::TAP';
+BEGIN { require Test2::Formatter::TAP; our @ISA = qw(Test2::Formatter::TAP) }
use Test2::Util::HashBase qw/no_header no_diag/;
use strict;
-use Test::Builder 1.00;
+use Test::Builder;
require Exporter;
our @ISA = qw(Exporter);
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
=head1 NAME
$test->plan(@_);
- $class->export_to_level( 1, $class, @imports );
+ local $Exporter::ExportLevel = $Exporter::ExportLevel + 1;
+ $class->Exporter::import(@imports);
}
sub _strip_imports {
package Test::Builder::Tester;
use strict;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
-use Test::Builder 0.99;
+use Test::Builder;
use Symbol;
use Carp;
package Test::Builder::Tester::Color;
use strict;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
require Test::Builder::Tester;
use strict;
use warnings;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
-use base 'Test2::Event::Diag';
+BEGIN { require Test2::Event::Diag; our @ISA = qw(Test2::Event::Diag) }
sub diagnostics { 0 }
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
+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>.
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
+There seems to be a Dummy Mode with respect to testing. An otherwise competent
person goes to write a test and they suddenly forget all basic
programming practice.
return warn @_, " at $file line $line\n";
}
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
-use Test::Builder::Module 0.99;
+use Test::Builder::Module;
our @ISA = qw(Test::Builder::Module);
our @EXPORT = qw(ok use_ok require_ok
is isnt like unlike is_deeply
my @other = ();
my $idx = 0;
+ my $import;
while( $idx <= $#{$list} ) {
my $item = $list->[$idx];
if( defined $item and $item eq 'no_diag' ) {
$class->builder->no_diag(1);
}
+ elsif( defined $item and $item eq 'import' ) {
+ if ($import) {
+ push @$import, @{$list->[ ++$idx ]};
+ }
+ else {
+ $import = $list->[ ++$idx ];
+ push @other, $item, $import;
+ }
+ }
else {
push @other, $item;
}
@$list = @other;
+ if ($class eq __PACKAGE__ && (!$import || grep $_ eq '$TODO', @$import)) {
+ my $to = $class->builder->exported_to;
+ no strict 'refs';
+ *{"$to\::TODO"} = \our $TODO;
+ if ($import) {
+ @$import = grep $_ ne '$TODO', @$import;
+ }
+ else {
+ push @$list, import => [grep $_ ne '$TODO', @EXPORT];
+ }
+ }
+
return;
}
use strict;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
-use Test::Builder::Module 0.99;
+use Test::Builder::Module;
our @ISA = qw(Test::Builder::Module);
our @EXPORT = qw(ok);
use vars qw( @ISA @EXPORT );
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
@EXPORT = qw( run_tests check_tests check_test cmp_results show_space );
@ISA = qw( Exporter );
my $colour = '';
my $reset = '';
-if (my $want_colour = $ENV{TESTTESTERCOLOUR} || $ENV{TESTTESTERCOLOUR})
+if (my $want_colour = $ENV{TESTTESTERCOLOUR} || $ENV{TESTTESTERCOLOR})
{
if (eval "require Term::ANSIColor")
{
Note that Test::Builder ensures that any diagnostics end in a \n and
it in earlier versions of Test::Tester it was essential that you have
-the final \n in your expected diagnostics. From version 0.10 onwards,
+the final \n in your expected diagnostics. From version 0.10 onward,
Test::Tester will add the \n if you forgot it. It will not add a \n if
you are expecting no diagnostics. See below for help tracking down
hard to find space and tab related problems.
your diagnostics are wrong when they look perfectly right then the answer is
probably whitespace. From version 0.10 on, Test::Tester surrounds the
expected and got diag values with single quotes to make it easier to spot
-trailing whitesapce. So in this example
+trailing whitespace. So in this example
# Got diag (5 bytes):
# 'abcd '
\{xx}. Tricky characters are those with ASCII code less than 33 or higher
than 126. This makes the output more difficult to read but much easier to
find subtle differences between strings. To turn on this mode either call
-show_space() in your test script or set the TESTTESTERSPACE environment
+C<show_space()> in your test script or set the C<TESTTESTERSPACE> environment
variable to be a true value. The example above would then look like
# Got diag (5 bytes):
=head1 COLOUR
If you prefer to use colour as a means of finding tricky whitespace
-characters then you can set the TESTTESTCOLOUR environment variable to a
+characters then you can set the C<TESTTESTCOLOUR> environment variable to a
comma separated pair of colours, the first for the foreground, the second
for the background. For example "white,red" will print white text on a red
background. This requires the Term::ANSIColor module. You can specify any
colour that would be acceptable to the Term::ANSIColor::color function.
-If you spell colour differently, that's no problem. The TESTTESTERCOLOR
+If you spell colour differently, that's no problem. The C<TESTTESTERCOLOR>
variable also works (if both are set then the British spelling wins out).
=head1 EXPORTED FUNCTIONS
package Test::Tester::Capture;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
use Test::Builder;
package Test::Tester::CaptureRunner;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
use Test::Tester::Capture;
package Test::Tester::Delegate;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
use vars '$AUTOLOAD';
package Test::use::ok;
use 5.005;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
__END__
use strict;
use warnings;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
1;
=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
+L<Test2::Suite>. L<Test::Suite> is a separate cpan distribution that contains
many tools implemented on Test2.
If you are interested in writing new tools you should take a look at
=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
+formatter currently. It is acceptable 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
+Events live under this namespace. It is considered acceptable for third party
distributions to add new event types in this namespace.
=head2 Test2::Hub::
=head2 Test2::
-The Test2:: namespace is intended for extentions and frameworks. Tools,
-Plugins, etc should not go directly into this namespace. However extentions
+The Test2:: namespace is intended for extensions and frameworks. Tools,
+Plugins, etc should not go directly into this namespace. However extensions
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
use strict;
use warnings;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
my $INST;
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;
-}
+BEGIN { require Exporter; our @ISA = qw(Exporter) }
my $STACK = $INST->stack;
my $CONTEXTS = $INST->contexts;
delete $CONTEXTS->{$hid};
}
- # Directly bless the object here, calling new is a noticable performance
+ # Directly bless the object here, calling new is a noticeable performance
# hit with how often this needs to be called.
my $trace = bless(
{
'Test2::Util::Trace'
);
- # Directly bless the object here, calling new is a noticable performance
+ # Directly bless the object here, calling new is a noticeable performance
# hit with how often this needs to be called.
my $aborted = 0;
$current = bless(
$err = $@;
# They might have done 'BEGIN { skip_all => "whatever" }'
- if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/) {
+ if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/ || (blessed($err) && blessed($err) eq 'Test::Builder::Exception')) {
$ok = undef;
$err = undef;
}
return $pass;
}
+# 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 noticeable performance impact with how often context() is
+# called.
+require Test2::API::Context;
+
1;
__END__
=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
+methods provided will not change in backwards-incompatible ways (once there is
a stable release), but the underlying implementation details might.
B<Do not break encapsulation here!>
quickly. You are also provided with tools that help you to test the tools you
write.
-=head1 SYNOPSYS
+=head1 SYNOPSIS
=head2 WRITING A TOOL
return $bool;
}
-See L<Test2::API::Context> for a list of methods avabilable on the context object.
+See L<Test2::API::Context> for a list of methods available on the context object.
=head2 TESTING YOUR TOOLS
=item level => $int
-If you must obtain a context in a sub deper than your entry point you can use
+If you must obtain a context in a sub deeper 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.
=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
+'buffered' setting. If this is a hash reference then it will be used as a
parameters hash. The param hash will be used for hub construction (with the
'buffered' key removed).
=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
+immediately 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.
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.
+sent independently of the final subtest event.
=back
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
+comes with great responsibility". 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:
=item $bool = test2_init_done()
-This will return true if the stack and ipc instances have already been
+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
+possible, it happens as soon as a tool requests the IPC instance, the
formatter, or the stack.
=item $bool = test2_load_done()
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.
+If Test2 has already finished loading then the callback will be run immediately.
=item test2_add_callback_context_acquire(sub { ... })
=item test2_ipc_enable_shm()
-Turn on IPC shm. Only some IPC drivers use this, and most will turn it on
+Turn on IPC SHM. Only some IPC drivers use this, and most will turn it on
themselves.
=item test2_ipc_set_pending($uniq_val)
use strict;
use warnings;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
use Test2::Util qw/pkg_to_file/;
upgrade_required
known_broken
};
-use base 'Exporter';
+BEGIN { require Exporter; our @ISA = qw(Exporter) }
sub upgrade_suggested {
return (
specified one then the module will not work. A newer version may work, but is
not tested or verified.
+=back
+
=head1 SOURCE
The source code repository for Test2 can be found at
use strict;
use warnings;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
use Carp qw/confess croak longmess/;
=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.
+This will return the L<Test2::Hub> instance the context recognizes as the
+current one to which all events should be sent.
=item $dbg = $ctx->trace()
});
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
+the original. This allows the thread id, process id, and error variables to be correct without
modifying the original context.
=item $ctx->restore_error_vars()
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.
+tools, plugins, and other extensions.
=head1 SOURCE
use strict;
use warnings;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
our @CARP_NOT = qw/Test2::API Test2::API::Instance Test2::IPC::Driver Test2::Formatter/;
use Test2::API::Stack();
use Test2::Util::HashBase qw{
- pid tid
+ _pid _tid
no_wait
finalized loaded
ipc stack formatter
context_release_callbacks
};
+sub pid { $_[0]->{+_PID} ||= $$ }
+sub tid { $_[0]->{+_TID} ||= get_tid() }
+
# Wrap around the getters that should call _finalize.
BEGIN {
for my $finalizer (IPC, FORMATTER) {
sub reset {
my $self = shift;
- $self->{+PID} = $$;
- $self->{+TID} = get_tid();
+ delete $self->{+_PID};
+ delete $self->{+_TID};
+
$self->{+CONTEXTS} = {};
$self->{+IPC_DRIVERS} = [];
$self->{+FINALIZED} = $caller;
+ $self->{+_PID} = $$ unless defined $self->{+_PID};
+ $self->{+_TID} = get_tid() unless defined $self->{+_TID};
+
unless ($self->{+FORMATTER}) {
my ($formatter, $source);
if ($ENV{T2_FORMATTER}) {
$self->{+FORMATTER} = $formatter;
}
- # Turn on IPC if threads are on, drivers are reigstered, or the Test2::IPC
+ # Turn on IPC if threads are on, drivers are registered, or the Test2::IPC
# module is loaded.
return unless USE_THREADS || $INC{'Test2/IPC.pm'} || @{$self->{+IPC_DRIVERS}};
sub load {
my $self = shift;
unless ($self->{+LOADED}) {
+ $self->{+_PID} = $$ unless defined $self->{+_PID};
+ $self->{+_TID} = get_tid() unless defined $self->{+_TID};
+
# 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
sub enable_ipc_polling {
my $self = shift;
+ $self->{+_PID} = $$ unless defined $self->{+_PID};
+ $self->{+_TID} = get_tid() unless defined $self->{+_TID};
+
$self->add_context_init_callback(
# This is called every time a context is created, it needs to be fast.
# $_[0] is a context object
return 1 if defined $self->{+IPC_SHM_ID};
+ $self->{+_PID} = $$ unless defined $self->{+_PID};
+ $self->{+_TID} = get_tid() unless defined $self->{+_TID};
+
my ($ok, $err) = try {
require IPC::SysV;
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 (CAN_FORK) {
+ while (1) {
+ 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) {
sub DESTROY {
my $self = shift;
- return unless $self->{+PID} == $$;
- return unless $self->{+TID} == get_tid();
+ return unless defined($self->{+_PID}) && $self->{+_PID} == $$;
+ return unless defined($self->{+_TID}) && $self->{+_TID} == get_tid();
shmctl($self->{+IPC_SHM_ID}, IPC::SysV::IPC_RMID(), 0)
if defined $self->{+IPC_SHM_ID};
# Only worry about contexts in this PID
my $trace = $ctx->trace || next;
- next unless $trace->pid == $$;
+ next unless $trace->pid && $trace->pid == $$;
# Do not worry about contexts that have no hub
my $hub = $ctx->hub || next;
$new_exit = 255;
}
- if ($self->{+PID} != $$ or $self->{+TID} != get_tid()) {
+ if (!defined($self->{+_PID}) or !defined($self->{+_TID}) or $self->{+_PID} != $$ or $self->{+_TID} != get_tid()) {
$? = $exit;
return;
}
$new_exit = 255 if $new_exit > 255;
- if ($new_exit) {
- require Test2::API::Breakage;
+ if ($new_exit && eval { require Test2::API::Breakage; 1 }) {
my @warn = Test2::API::Breakage->report();
if (@warn) {
=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
+be immediately 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()
use strict;
use warnings;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
use Test2::Hub();
=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
+methods provided will not change in backwards incompatible ways, but the
underlying implementation details might. B<Do not break encapsulation here!>
=head1 DESCRIPTION
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.
+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,
+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.
use strict;
use warnings;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
use Test2::Util::HashBase qw/trace nested in_subtest subtest_id/;
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.
+test to exit immediately.
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
=item $id = $e->subtest_id
-If the event is a final subtes event, this should contain the subtest ID.
+If the event is a final subtest event, this should contain the subtest ID.
=back
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.
+tools, plugins, and other extensions.
=head1 SOURCE
use strict;
use warnings;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
-use base 'Test2::Event';
+BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use Test2::Util::HashBase qw{reason};
sub callback {
use strict;
use warnings;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
-use base 'Test2::Event';
+BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use Test2::Util::HashBase qw/message/;
sub init {
use strict;
use warnings;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
-use base 'Test2::Event';
+BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use Test2::Util::HashBase qw{error};
sub causes_fail { 1 }
--- /dev/null
+package Test2::Event::Generic;
+use strict;
+use warnings;
+
+use Carp qw/croak/;
+use Scalar::Util qw/reftype/;
+
+our $VERSION = '1.302026';
+
+BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
+use Test2::Util::HashBase;
+
+my @FIELDS = qw{
+ causes_fail increments_count diagnostics no_display callback terminate
+ global sets_plan summary
+};
+my %DEFAULTS = (
+ causes_fail => 0,
+ increments_count => 0,
+ diagnostics => 0,
+ no_display => 0,
+);
+
+sub init {
+ my $self = shift;
+
+ for my $field (@FIELDS) {
+ my $val = defined $self->{$field} ? delete $self->{$field} : $DEFAULTS{$field};
+ next unless defined $val;
+
+ my $set = "set_$field";
+ $self->$set($val);
+ }
+}
+
+for my $field (@FIELDS) {
+ no strict 'refs';
+ my $stash = \%{__PACKAGE__ . "::"};
+
+ *$field = sub { exists $_[0]->{$field} ? $_[0]->{$field} : () }
+ unless defined $stash->{$field}
+ && defined *{$stash->{$field}}{CODE};
+
+ *{"set_$field"} = sub { $_[0]->{$field} = $_[1] }
+ unless defined $stash->{"set_$field"}
+ && defined *{$stash->{"set_$field"}}{CODE};
+}
+
+sub summary {
+ my $self = shift;
+ return $self->{summary} if defined $self->{summary};
+ $self->SUPER::summary();
+}
+
+sub sets_plan {
+ my $self = shift;
+ return unless $self->{sets_plan};
+ return @{$self->{sets_plan}};
+}
+
+sub callback {
+ my $self = shift;
+ my $cb = $self->{callback} || return;
+ $self->$cb(@_);
+}
+
+sub set_global {
+ my $self = shift;
+ my ($bool) = @_;
+
+ if(!defined $bool) {
+ delete $self->{global};
+ return undef;
+ }
+
+ $self->{global} = $bool;
+}
+
+sub set_callback {
+ my $self = shift;
+ my ($cb) = @_;
+
+ if(!defined $cb) {
+ delete $self->{callback};
+ return undef;
+ }
+
+ croak "callback must be a code reference"
+ unless ref($cb) && reftype($cb) eq 'CODE';
+
+ $self->{callback} = $cb;
+}
+
+sub set_terminate {
+ my $self = shift;
+ my ($exit) = @_;
+
+ if(!defined $exit) {
+ delete $self->{terminate};
+ return undef;
+ }
+
+ croak "terminate must be a positive integer"
+ unless $exit =~ m/^\d+$/;
+
+ $self->{terminate} = $exit;
+}
+
+sub set_sets_plan {
+ my $self = shift;
+ my ($plan) = @_;
+
+ if(!defined $plan) {
+ delete $self->{sets_plan};
+ return undef;
+ }
+
+ croak "'sets_plan' must be an array reference"
+ unless ref($plan) && reftype($plan) eq 'ARRAY';
+
+ $self->{sets_plan} = $plan;
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2::Event::Generic - Generic event type.
+
+=head1 DESCRIPTION
+
+This is a generic event that lets you customize all fields in the event API.
+This is useful if you have need for a custom event that does not make sense as
+a published reusable event subclass.
+
+=head1 SYNOPSIS
+
+ use Test2::API qw/context/;
+
+ sub send_custom_fail {
+ my $ctx = shift;
+
+ $ctx->send_event('Generic', causes_fail => 1, summary => 'The sky is falling');
+
+ $ctx->release;
+ }
+
+ send_custom_fail();
+
+=head1 METHODS
+
+=over 4
+
+=item $e->callback($hub)
+
+Call the custom callback if one is set, otherwise this does nothing.
+
+=item $e->set_callback(sub { ... })
+
+Set the custom callback. The custom callback must be a coderef. The first
+argument to your callback will be the event itself, the second will be the
+L<Test2::Event::Hub> that is using the callback.
+
+=item $bool = $e->causes_fail
+
+=item $e->set_causes_fail($bool)
+
+Get/Set the C<causes_fail> attribute. This defaults to C<0>.
+
+=item $bool = $e->diagnostics
+
+=item $e->set_diagnostics($bool)
+
+Get/Set the C<diagnostics> attribute. This defaults to C<0>.
+
+=item $bool_or_undef = $e->global
+
+=item @bool_or_empty = $e->global
+
+=item $e->set_global($bool_or_undef)
+
+Get/Set the C<diagnostics> attribute. This defaults to an empty list which is
+undef in scalar context.
+
+=item $bool = $e->increments_count
+
+=item $e->set_increments_count($bool)
+
+Get/Set the C<increments_count> attribute. This defaults to C<0>.
+
+=item $bool = $e->no_display
+
+=item $e->set_no_display($bool)
+
+Get/Set the C<no_display> attribute. This defaults to C<0>.
+
+=item @plan = $e->sets_plan
+
+Get the plan if this event sets one. The plan is a list of up to 3 items:
+C<($count, $directive, $reason)>. C<$count> must be defined, the others may be
+undef, or may not exist at all.
+
+=item $e->set_sets_plan(\@plan)
+
+Set the plan. You must pass in an arrayref with up to 3 elements.
+
+=item $summary = $e->summary
+
+=item $e->set_summary($summary_or_undef)
+
+Get/Set the summary. This will default to the event package
+C<'Test2::Event::Generic'>. You can set it to any value. Setting this to
+C<undef> will reset it to the default.
+
+=item $int_or_undef = $e->terminate
+
+=item @int_or_empty = $e->terminate
+
+=item $e->set_terminate($int_or_undef)
+
+This will get/set the C<terminate> attribute. This defaults to undef in scalar
+context, or an empty list in list context. Setting this to undef will clear it
+completely. This must be set to a positive integer (0 or larger).
+
+=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
use strict;
use warnings;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
-use base 'Test2::Event';
+BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use Test2::Util::HashBase qw/message/;
sub init {
use strict;
use warnings;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
-use base 'Test2::Event';
+BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use Test2::Util::HashBase qw{
pass effective_pass name todo
};
use strict;
use warnings;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
-use base 'Test2::Event';
+BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use Test2::Util::HashBase qw{max directive reason};
use Carp qw/confess/;
use strict;
use warnings;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
-use base 'Test2::Event::Ok';
+BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) }
use Test2::Util::HashBase qw{reason};
sub init {
use strict;
use warnings;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
-use base 'Test2::Event::Ok';
+BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) }
use Test2::Util::HashBase qw{subevents buffered subtest_id};
sub init {
use strict;
use warnings;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
-use base 'Test2::Event';
+BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
sub global { 1 };
use strict;
use warnings;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
my %ADDED;
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.
+this even is not itself an assertion. The assertion number may be any integer 0
+or greater, 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.
use strict;
use warnings;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
use Test2::Util::HashBase qw{
use Carp qw/croak/;
-use base 'Test2::Formatter';
+BEGIN { require Test2::Formatter; our @ISA = qw(Test2::Formatter) }
my %CONVERTERS = (
'Test2::Event::Ok' => 'event_ok',
# 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.
+ # non-verbose harness we do not 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;
=item @out = $TAP->event_other($e, $num)
-Fallback for unregistered event types. It uses the L<Test2::Event> api to
+Fallback for unregistered event types. It uses the L<Test2::Event> API to
convert the event to TAP.
=back
use strict;
use warnings;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
use Carp qw/carp croak confess/;
=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
+formatter. The hub also tracks test state, and provides several hooks into the
event pipeline.
=head1 COMMON TASKS
=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
+context. It gets a single argument, a reference of the hash of parameters
being used the construct the context. This is your chance to change the
parameters by directly altering the hash.
=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.
+have not ended this will return undef, otherwise it will be a true/false.
=back
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.
+tools, plugins, and other extensions.
=head1 SOURCE
use strict;
use warnings;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
use Test2::Hub::Interceptor::Terminator();
-use base 'Test2::Hub';
+BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) }
use Test2::Util::HashBase;
sub inherit {
use strict;
use warnings;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
1;
use strict;
use warnings;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
-use base 'Test2::Hub';
+BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) }
use Test2::Util::HashBase qw/nested bailed_out exit_code manual_skip_all id/;
use Test2::Util qw/get_tid/;
use strict;
use warnings;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
use Test2::API::Instance;
use Carp qw/confess/;
our @EXPORT_OK = qw/cull/;
-use base 'Exporter';
+BEGIN { require Exporter; our @ISA = qw(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();
+ confess "Cannot add IPC in a child process (" . test2_pid() . " vs $$)" if test2_pid() != $$;
+ confess "Cannot add IPC in a child thread (" . test2_tid() . " vs " . get_tid() . ")" if test2_tid() != get_tid();
Test2::API::_set_ipc(_make_ipc());
apply_ipc(test2_stack());
use strict;
use warnings;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
use Carp qw/confess longmess/;
}
# 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
+# catastrophic 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.
=item $bites = $ipc->shm_size()
-Use this to customize the size of the shm space. There are no guarantees about
+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
use strict;
use warnings;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
-use base 'Test2::IPC::Driver';
+BEGIN { require Test2::IPC::Driver; our @ISA = qw(Test2::IPC::Driver) }
use Test2::Util::HashBase qw{tempdir event_id tid pid globals};
use File::Temp();
use Storable();
use File::Spec();
+use POSIX();
-use Test2::Util qw/try get_tid pkg_to_file/;
+use Test2::Util qw/try get_tid pkg_to_file IS_WIN32/;
use Test2::API qw/test2_ipc_set_pending/;
sub use_shm { 1 }
my $self = shift;
my ($hid) = @_;
my $tdir = $self->{+TEMPDIR};
- return File::Spec->canonpath("$tdir/HUB-$hid");
+ return File::Spec->catfile($tdir, "HUB-$hid");
}
sub event_file {
my @type = split '::', $type;
my $name = join('-', $hid, $$, get_tid(), $self->{+EVENT_ID}++, @type);
- return File::Spec->canonpath("$tempdir/$name");
+ return File::Spec->catfile($tempdir, $name);
}
sub add_hub {
$self->{+GLOBALS}->{$hid}->{$name}++;
}
+ my ($old, $blocked);
+ unless(IS_WIN32) {
+ my $to_block = POSIX::SigSet->new(
+ POSIX::SIGINT(),
+ POSIX::SIGALRM(),
+ POSIX::SIGHUP(),
+ POSIX::SIGTERM(),
+ POSIX::SIGUSR1(),
+ POSIX::SIGUSR2(),
+ );
+ $old = POSIX::SigSet->new;
+ $blocked = POSIX::sigprocmask(POSIX::SIG_BLOCK(), $to_block, $old);
+ # Silently go on if we failed to log signals, not much we can do.
+ }
+
+ # Write and rename the file.
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 our block was successful we want to restore the old mask.
+ POSIX::sigprocmask(POSIX::SIG_SETMASK(), $old, POSIX::SigSet->new()) if defined $blocked;
+
if (!$ok) {
my $src_file = __FILE__;
$err =~ s{ at \Q$src_file\E.*$}{};
next if $global && $self->{+GLOBALS}->{$hid}->{$file}++;
# Untaint the path.
- my $full = File::Spec->canonpath("$tempdir/$file");
+ my $full = File::Spec->catfile($tempdir, $file);
($full) = ($full =~ m/^(.*)$/gs);
my $obj = $self->read_event_file($full);
while(my $file = readdir($dh)) {
next if $file =~ m/^\.+$/;
next if $file =~ m/\.complete$/;
- my $full = File::Spec->canonpath("$tempdir/$file");
+ my $full = File::Spec->catfile($tempdir, $file);
if ($file =~ m/^(GLOBAL|HUB-)/) {
$full =~ m/^(.*)$/;
=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.
+documented. The upgrade causes Test::Builder to defer to Test2 under the hood.
This transition is mostly transparent, but there are a few cases that can trip
you up.
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
+The Test::Builder2/1.5 projects both died out. Now the conditional code people
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.
+legacy Test::Builder API, or use Test2 directly.
=head2 Replacing the Test::Builder singleton
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:
+to outdent the subtest note instead of having it inline with the subtest:
# subtest foo
ok 1 - blah
=item Test::Kit
This actually works fine, but will not install because L<Test::Aggregate> is in
-the dep chain.
+the dependency chain.
See the L<Test::Aggregate> info below for additional information.
use strict;
use warnings;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
use Config qw/%Config/;
CAN_THREAD
CAN_REALLY_FORK
CAN_FORK
+
+ IS_WIN32
};
-use base 'Exporter';
+BEGIN { require Exporter; our @ISA = qw(Exporter) }
+
+BEGIN {
+ *IS_WIN32 = ($^O eq 'MSWin32') ? sub() { 1 } : sub() { 0 };
+}
sub _can_thread {
return 0 unless $] >= 5.008001;
# 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;
+ return 0 if $parts[0] > 4 || ($parts[0] == 4 && $parts[1] >= 8);
}
# Change to a version check if this ever changes
sub _can_fork {
return 1 if $Config{d_fork};
- return 0 unless $^O eq 'MSWin32' || $^O eq 'NetWare';
+ return 0 unless IS_WIN32 || $^O eq 'NetWare';
return 0 unless $Config{useithreads};
return 0 unless $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/;
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 };
+}
+my $can_fork;
+sub CAN_FORK () {
+ return $can_fork
+ if defined $can_fork;
+ $can_fork = !!_can_fork();
+ no warnings 'redefine';
+ *CAN_FORK = $can_fork ? sub() { 1 } : sub() { 0 };
+ $can_fork;
+}
+my $can_really_fork;
+sub CAN_REALLY_FORK () {
+ return $can_really_fork
+ if defined $can_really_fork;
+ $can_really_fork = !!$Config{d_fork};
+ no warnings 'redefine';
+ *CAN_REALLY_FORK = $can_really_fork ? sub() { 1 } : sub() { 0 };
+ $can_really_fork;
}
sub _manual_try(&;@) {
# 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) {
+ if (IS_WIN32 && $] < 5.020002) {
*try = \&_manual_try;
}
else {
}
BEGIN {
- if(CAN_THREAD) {
+ 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() };
+ *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 };
+ *USE_THREADS = sub() { $INC{'threads.pm'} ? 1 : 0 };
+ *get_tid = sub() { $INC{'threads.pm'} ? threads->tid() : 0 };
}
}
else {
=item CAN_FORK
-True if this system is capable of true or psuedo-fork.
+True if this system is capable of true or pseudo-fork.
=item CAN_REALLY_FORK
use strict;
use warnings;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
use Carp qw/croak/;
sub META_KEY() { '_meta' }
our @EXPORT = qw/meta set_meta get_meta delete_meta/;
-use base 'Exporter';
+BEGIN { require Exporter; our @ISA = qw(Exporter) }
sub set_meta {
my $self = shift;
package, and imports its methods, then third party meta-data has a safe place
to live.
-=head1 SYNOPSYS
+=head1 SYNOPSIS
package My::Object;
use strict;
=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<undef> when there is no value for the C<$key>, however you can specify a
C<$default> value to set when no value is already set.
=item $val = $obj->get_meta($key)
=back
-=head1 META-KEY RESTICTIONS
+=head1 META-KEY RESTRICTIONS
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
use strict;
use warnings;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
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;
+my %ATTR_SUBS;
+
+BEGIN {
+ # these are not strictly equivalent, but for out use we don't care
+ # about order
+ *_isa = ($] >= 5.010 && require mro) ? \&mro::get_linear_isa : sub {
+ no strict 'refs';
+ my @packages = ($_[0]);
+ my %seen;
+ for my $package (@packages) {
+ push @packages, grep !$seen{$_}++, @{"$package\::ISA"};
+ }
+ return \@packages;
}
-
- 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 $isa = _isa($into);
+ my $attr_subs = $ATTR_SUBS{$into} ||= {};
my %subs = (
- %attrs,
- @{_get_inherited_attrs($into)},
- $into->can('new') ? () : (new => \&_new)
+ ($into->can('new') ? () : (new => \&_new)),
+ (map %{ $ATTR_SUBS{$_}||{} }, @{$isa}[1 .. $#$isa]),
+ (map {
+ my ($sub, $attr) = (uc $_, $_);
+ $sub => ($attr_subs->{$sub} = sub() { $attr }),
+ $attr => sub { $_[0]->{$attr} },
+ "set_$attr" => sub { $_[0]->{$attr} = $_[1] },
+ } @_),
);
no strict 'refs';
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
+return the key into the hash for that accessor. Single inheritance is also
supported.
=head1 METHODS
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.
+packages inheritance 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>.
use strict;
use warnings;
-our $VERSION = '1.302015';
+our $VERSION = '1.302026';
use Test2::Util qw/get_tid/;
=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.
+then its value will be returned instead.
=item $trace->alert($MESSAGE)
package ok;
-$ok::VERSION = '1.302015';
+$ok::VERSION = '1.302026';
use strict;
use Test::More ();
+++ /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);
- }
-}
use strict;
use warnings;
+use Test2::Util qw/CAN_THREAD/;
BEGIN {
- my $skip = !eval { require threads; 1 };
- if ($skip) {
- require Test::More;
- Test::More::plan(skip_all => 'no threads');
+ unless(CAN_THREAD) {
+ print "1..0 # Skip threads are not supported.\n";
+ exit 0;
}
}
+BEGIN {
+ unless ( $ENV{AUTHOR_TESTING} ) {
+ print "1..0 # Skip many perls have broken threads. Enable with AUTHOR_TESTING.\n";
+ exit 0;
+ }
+}
+
+use Test2::IPC;
use threads;
use Test::More;
# argh! now we need to test the thing we're testing. Basically we need
# to pretty much reimplement the whole code again. This is very
-# annoying but can't be avoided. And onwards with the cut and paste
+# annoying but can't be avoided. And onward with the cut and paste
# My brain is melting. My brain is melting. ETOOMANYLAYERSOFTESTING
# argh! now we need to test the thing we're testing. Basically we need
# to pretty much reimplement the whole code again. This is very
-# annoying but can't be avoided. And onwards with the cut and paste
+# annoying but can't be avoided. And onward with the cut and paste
# My brain is melting. My brain is melting. ETOOMANYLAYERSOFTESTING
test2_stack->top->unfilter($filter);
ok(1, "Third");
-diag "should be a diag";
done_testing;
is_deeply(
$one,
{
- pid => $$,
- tid => get_tid(),
contexts => {},
finalized => undef,
is_deeply(
$one,
{
- pid => $$,
- tid => get_tid(),
contexts => {},
ipc_polling => undef,
{
$one->reset();
- $one->set_tid(1);
+ $one->set__tid(1);
local $? = 0;
$one->set_exit;
is($?, 0, "no errors on exit");
{
$one->reset();
+ $one->load();
$one->stack->top->set_failed(2);
local $? = 0;
$one->set_exit;
{
$one->reset();
+ $one->load();
local $? = 500;
$one->set_exit;
is($?, 255, "set exit code to a sane number");
local %INC = %INC;
delete $INC{'Test2/IPC.pm'};
$one->reset();
+ $one->load();
my @events;
$one->stack->top->filter(sub { push @events => $_[1]; undef});
$one->stack->new_hub;
local *Test2::API::Breakage::report = sub { $ran++; return "foo" };
use warnings qw/redefine once/;
$one->reset();
+ $one->load();
my $stderr = "";
{
{
$one->reset();
+ $one->load();
my @events;
$one->stack->top->filter(sub { push @events => $_[1]; undef});
$one->stack->new_hub;
{
$one->reset;
+
ok(!@{$one->context_init_callbacks}, "no callbacks");
is($one->ipc_polling, undef, "no polling, undef");
use warnings;
$one->enable_ipc_polling;
+ ok(defined($one->{_pid}), "pid is defined");
+ ok(defined($one->{_tid}), "tid is defined");
is(@{$one->context_init_callbacks}, 1, "added the callback");
is($one->ipc_polling, 1, "polling on");
$one->set_ipc_shm_last('abc1');
--- /dev/null
+use strict;
+use warnings;
+
+BEGIN { require "t/tools.pl" };
+use Test2::Util::Trace;
+
+use Test2::API qw/context intercept/;
+
+sub tool {
+ my $ctx = context();
+ my $e = $ctx->send_event('Generic', @_);
+ $ctx->release;
+ return $e;
+}
+
+my $e;
+intercept { $e = tool() };
+
+ok($e, "got event");
+ok($e->isa('Test2::Event'), "It is an event");
+ok($e->isa('Test2::Event::Generic'), "It is an event");
+delete $e->{trace};
+is_deeply(
+ $e,
+ {
+ causes_fail => 0,
+ increments_count => 0,
+ diagnostics => 0,
+ no_display => 0,
+ },
+ "Defaults"
+);
+
+for my $f (qw/causes_fail increments_count diagnostics no_display/) {
+ is($e->$f, 0, "'$f' is 0");
+ is_deeply([$e->$f], [0], "'$f' is 0 is list context as well");
+
+ my $set = "set_$f";
+ $e->$set(1);
+ is($e->$f, 1, "'$f' was set to 1");
+}
+
+for my $f (qw/callback terminate global sets_plan/) {
+ is($e->$f, undef, "no $f");
+ is_deeply([$e->$f], [], "$f is empty in list context");
+}
+
+like($e->summary, qr/Test2::Event::Generic/, "Got base class summary");
+
+like(
+ exception { $e->set_sets_plan('bad') },
+ qr/'sets_plan' must be an array reference/,
+ "Must provide an arrayref"
+);
+
+$e->set_sets_plan([0, skip => 'cause']);
+is_deeply([$e->sets_plan], [0, skip => 'cause'], "sets_plan returns a list, not a ref");
+$e->set_sets_plan(undef);
+ok(!exists $e->{sets_plan}, "Removed sets_plan key");
+ok(!$e->sets_plan, "sets_plan is cleared");
+
+$e->set_global(0);
+is($e->global, 0, "global is off");
+$e->set_global(1);
+is($e->global, 1, "global is on");
+$e->set_global(0);
+is($e->global, 0, "global is again");
+$e->set_global(undef);
+ok(!exists $e->{global}, "removed global key");
+is($e->global, undef, "global is not defined");
+
+like(
+ exception { $e->set_callback('dogfood') },
+ qr/callback must be a code reference/,
+ "Callback must be code"
+);
+
+my $ran = 0;
+$e->set_callback(sub {
+ $ran++;
+ my $self = shift;
+ is($self, $e, "got self");
+ is_deeply( \@_, ['a', 'b', 'c'], "Got args" );
+ return 'foo';
+});
+is($e->callback('a', 'b', 'c'), 'foo', "got callback's return");
+ok($ran, "ran callback");
+
+$e->set_callback(undef);
+ok(!$e->callback, "no callback");
+ok(!exists $e->{callback}, "no callback key");
+
+like(
+ exception { $e->set_terminate('1.1') },
+ qr/terminate must be a positive integer/,
+ "terminate only takes integers"
+);
+
+like(
+ exception { $e->set_terminate('foo') },
+ qr/terminate must be a positive integer/,
+ "terminate only takes numbers"
+);
+
+like(
+ exception { $e->set_terminate('-1') },
+ qr/terminate must be a positive integer/,
+ "terminate only takes positive integers"
+);
+
+$e->set_terminate(0),
+is($e->terminate, 0, "set to 0, 0 is valid");
+$e->set_terminate(1),
+is($e->terminate, 1, "set to 1");
+$e->set_terminate(123),
+is($e->terminate, 123, "set to 123");
+$e->set_terminate(0),
+is($e->terminate, 0, "set to 0, 0 is valid");
+
+$e->set_terminate(undef);
+is($e->terminate, undef, "terminate is not defined");
+ok(!exists $e->{terminate}, "no terminate key");
+
+# Test constructor args
+intercept { $e = tool(causes_fail => 1, increments_count => 'a') };
+is($e->causes_fail, 1, "attr from constructor");
+is($e->increments_count, 'a', "attr from constructor");
+
+done_testing;
BEGIN { require "t/tools.pl" };
use Test2::Util qw/get_tid USE_THREADS try/;
use File::Temp qw/tempfile/;
+use File::Spec qw/catfile/;
use strict;
use warnings;
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 $hubfile = File::Spec->catfile($ipc->tempdir, "HUB-$hid");
+ok(-f $hubfile, "wrote hub file");
+if(ok(open(my $fh, '<', $hubfile), "opened hub file")) {
my @lines = <$fh>;
close($fh);
is_deeply(
$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);
+my @files = grep { $_ !~ m/^\.+$/ && $_ !~ m/^HUB-$hid/ } readdir($dh);
closedir($dh);
is(@files, 2, "2 files added to the IPC directory");
);
opendir($dh, $ipc->tempdir) || die "Could not open tempdir: !?";
-@files = grep { $_ !~ m/^\.+$/ && $_ ne "HUB-$hid" } readdir($dh);
+@files = grep { $_ !~ m/^\.+$/ && $_ !~ m/^HUB-$hid/ } readdir($dh);
closedir($dh);
is(@files, 0, "All files collected");
1;
};
+ my $cleanup = sub {
+ if (opendir(my $d, $tmpdir)) {
+ for my $f (readdir($d)) {
+ next if $f =~ m/^\.+$/;
+ next unless -f "$tmpdir/$f";
+ unlink("$tmpdir/$f");
+ }
+ }
+ rmdir($tmpdir) or warn "Could not remove temp dir '$tmpdir': $!";
+ };
+ $cleanup->();
+
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");
$out = capture {
my $ipc = Test2::IPC::Driver::Files->new();
+ $tmpdir = $ipc->tempdir;
$ipc->add_hub($hid);
$ipc->send($hid, bless({ foo => 1 }, 'Foo'));
local $@;
eval { $ipc->drop_hub($hid) };
print STDERR $@ unless $@ =~ m/^255/;
};
+ $cleanup->();
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");
CAN_FORK
CAN_THREAD
CAN_REALLY_FORK
+
+ IS_WIN32
/;
{
CAN_THREAD();
CAN_FORK();
CAN_REALLY_FORK();
+IS_WIN32();
+
+is(IS_WIN32(), ($^O eq 'MSWin32') ? 1 : 0, "IS_WIN32 is correct ($^O)");
done_testing;
--- /dev/null
+use Test::Builder::Tester;
+use Test::More tests => 1;
+use strict;
+use warnings;
+
+BEGIN {
+ package Example::Tester;
+
+ use base 'Test::Builder::Module';
+ $INC{'Example/Tester.pm'} = 1;
+
+ sub import {
+ my $package = shift;
+ my %args = @_;
+ my $callerpack = caller;
+ my $tb = __PACKAGE__->builder;
+ $tb->exported_to($callerpack);
+ local $SIG{__WARN__} = sub { };
+ $tb->no_plan;
+ }
+}
+
+test_out('ok 1 - use Example::Tester;');
+use_ok('Example::Tester');
+test_test("use Example::Tester;");
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";
our $VERSION;
BEGIN {
- $VERSION = '3.31';
+ $VERSION = '3.32';
}
use ExtUtils::ParseXS::Constants $VERSION;
use ExtUtils::ParseXS::CountLines $VERSION;
optimize => 1,
prototypes => 1,
);
-
+
# Legacy non-OO interface using a singleton:
use ExtUtils::ParseXS qw(process_file);
process_file( filename => 'foo.xs' );
use warnings;
use Symbol;
-our $VERSION = '3.31';
+our $VERSION = '3.32';
=head1 NAME
package ExtUtils::ParseXS::CountLines;
use strict;
-our $VERSION = '3.31';
+our $VERSION = '3.32';
our $SECTION_END_MARKER;
use strict;
use warnings;
-our $VERSION = '3.31';
+our $VERSION = '3.32';
=head1 NAME
use File::Spec;
use ExtUtils::ParseXS::Constants ();
-our $VERSION = '3.31';
+our $VERSION = '3.32';
our (@ISA, @EXPORT_OK);
@ISA = qw(Exporter);
use 5.006001;
use strict;
use warnings;
-our $VERSION = '3.31';
+our $VERSION = '3.32';
require ExtUtils::ParseXS;
require ExtUtils::ParseXS::Constants;
# $typemap = ExtUtils::Typemaps->new();
# alternatively create an in-memory typemap by parsing a string
# $typemap = ExtUtils::Typemaps->new(string => $sometypemap);
-
+
# add a mapping
$typemap->add_typemap(ctype => 'NV', xstype => 'T_NV');
$typemap->add_inputmap(
);
$typemap->add_string(string => $typemapstring);
# will be parsed and merged
-
+
# remove a mapping (same for remove_typemap and remove_outputmap...)
$typemap->remove_inputmap(xstype => 'SomeType');
-
+
# save a typemap to a file
$typemap->write(file => 'anotherfile.map');
-
+
# merge the other typemap into this one
$typemap->merge(typemap => $another_typemap);
Write the typemap to a file. Optionally takes a C<file> argument. If given, the
typemap will be written to the specified file. If not, the typemap is written
-to the currently stored file name (see C<-E<gt>file> above, this defaults to the file
+to the currently stored file name (see L</file> above, this defaults to the file
it was read from if any).
=cut
use 5.006001;
use strict;
use warnings;
-our $VERSION = '3.31';
+our $VERSION = '3.32';
use ExtUtils::Typemaps;
use 5.006001;
use strict;
use warnings;
-our $VERSION = '3.31';
+our $VERSION = '3.32';
=head1 NAME
use 5.006001;
use strict;
use warnings;
-our $VERSION = '3.31';
+our $VERSION = '3.32';
=head1 NAME
use warnings;
require ExtUtils::Typemaps;
-our $VERSION = '3.31';
+our $VERSION = '3.32';
=head1 NAME
+5.20160620
+ - Updated for v5.25.2
+
5.20160520
- fixed edge-case checking in is_core() (checking for a specific
version of a module returned false for the first perl release
%bug_tracker %deprecated %delta/;
use Module::CoreList::TieHashDelta;
use version;
-$VERSION = '5.20160520';
+$VERSION = '5.20160620';
sub _released_order { # Sort helper, to make '?' sort after everything else
(substr($released{$a}, 0, 1) eq "?")
5.024000 => '2016-05-09',
5.025000 => '2016-05-09',
5.025001 => '2016-05-20',
+ 5.025002 => '2016-06-20',
);
for my $version ( sort { $a <=> $b } keys %released ) {
removed => {
}
},
+ 5.025002 => {
+ delta_from => 5.025001,
+ changed => {
+ 'App::Cpan' => '1.64',
+ 'B::Op_private' => '5.025002',
+ 'CPAN' => '2.14',
+ 'CPAN::Distribution' => '2.12',
+ 'CPAN::FTP' => '5.5007',
+ 'CPAN::FirstTime' => '5.5309',
+ 'CPAN::HandleConfig' => '5.5007',
+ 'CPAN::Index' => '2.12',
+ 'CPAN::Mirrors' => '2.12',
+ 'CPAN::Plugin' => '0.96',
+ 'CPAN::Shell' => '5.5006',
+ 'Config' => '5.025002',
+ 'Cwd' => '3.64',
+ 'Devel::Peek' => '1.24',
+ 'DynaLoader' => '1.39',
+ 'ExtUtils::Command' => '7.18',
+ 'ExtUtils::Command::MM' => '7.18',
+ 'ExtUtils::Liblist' => '7.18',
+ 'ExtUtils::Liblist::Kid'=> '7.18',
+ 'ExtUtils::MM' => '7.18',
+ 'ExtUtils::MM_AIX' => '7.18',
+ 'ExtUtils::MM_Any' => '7.18',
+ 'ExtUtils::MM_BeOS' => '7.18',
+ 'ExtUtils::MM_Cygwin' => '7.18',
+ 'ExtUtils::MM_DOS' => '7.18',
+ 'ExtUtils::MM_Darwin' => '7.18',
+ 'ExtUtils::MM_MacOS' => '7.18',
+ 'ExtUtils::MM_NW5' => '7.18',
+ 'ExtUtils::MM_OS2' => '7.18',
+ 'ExtUtils::MM_QNX' => '7.18',
+ 'ExtUtils::MM_UWIN' => '7.18',
+ 'ExtUtils::MM_Unix' => '7.18',
+ 'ExtUtils::MM_VMS' => '7.18',
+ 'ExtUtils::MM_VOS' => '7.18',
+ 'ExtUtils::MM_Win32' => '7.18',
+ 'ExtUtils::MM_Win95' => '7.18',
+ 'ExtUtils::MY' => '7.18',
+ 'ExtUtils::MakeMaker' => '7.18',
+ 'ExtUtils::MakeMaker::Config'=> '7.18',
+ 'ExtUtils::MakeMaker::Locale'=> '7.18',
+ 'ExtUtils::MakeMaker::version'=> '7.18',
+ 'ExtUtils::MakeMaker::version::regex'=> '7.18',
+ 'ExtUtils::Miniperl' => '1.06',
+ 'ExtUtils::Mkbootstrap' => '7.18',
+ 'ExtUtils::Mksymlists' => '7.18',
+ 'ExtUtils::ParseXS' => '3.32',
+ 'ExtUtils::ParseXS::Constants'=> '3.32',
+ 'ExtUtils::ParseXS::CountLines'=> '3.32',
+ 'ExtUtils::ParseXS::Eval'=> '3.32',
+ 'ExtUtils::ParseXS::Utilities'=> '3.32',
+ 'ExtUtils::Typemaps' => '3.32',
+ 'ExtUtils::Typemaps::Cmd'=> '3.32',
+ 'ExtUtils::Typemaps::InputMap'=> '3.32',
+ 'ExtUtils::Typemaps::OutputMap'=> '3.32',
+ 'ExtUtils::Typemaps::Type'=> '3.32',
+ 'ExtUtils::testlib' => '7.18',
+ 'File::Copy' => '2.32',
+ 'File::Glob' => '1.27',
+ 'File::Spec' => '3.64',
+ 'File::Spec::Cygwin' => '3.64',
+ 'File::Spec::Epoc' => '3.64',
+ 'File::Spec::Functions' => '3.64',
+ 'File::Spec::Mac' => '3.64',
+ 'File::Spec::OS2' => '3.64',
+ 'File::Spec::Unix' => '3.64',
+ 'File::Spec::VMS' => '3.64',
+ 'File::Spec::Win32' => '3.64',
+ 'FileHandle' => '2.03',
+ 'Getopt::Long' => '2.49',
+ 'HTTP::Tiny' => '0.058',
+ 'JSON::PP' => '2.27400',
+ 'Locale::Codes' => '3.39',
+ 'Locale::Codes::Constants'=> '3.39',
+ 'Locale::Codes::Country'=> '3.39',
+ 'Locale::Codes::Country_Codes'=> '3.39',
+ 'Locale::Codes::Country_Retired'=> '3.39',
+ 'Locale::Codes::Currency'=> '3.39',
+ 'Locale::Codes::Currency_Codes'=> '3.39',
+ 'Locale::Codes::Currency_Retired'=> '3.39',
+ 'Locale::Codes::LangExt'=> '3.39',
+ 'Locale::Codes::LangExt_Codes'=> '3.39',
+ 'Locale::Codes::LangExt_Retired'=> '3.39',
+ 'Locale::Codes::LangFam'=> '3.39',
+ 'Locale::Codes::LangFam_Codes'=> '3.39',
+ 'Locale::Codes::LangFam_Retired'=> '3.39',
+ 'Locale::Codes::LangVar'=> '3.39',
+ 'Locale::Codes::LangVar_Codes'=> '3.39',
+ 'Locale::Codes::LangVar_Retired'=> '3.39',
+ 'Locale::Codes::Language'=> '3.39',
+ 'Locale::Codes::Language_Codes'=> '3.39',
+ 'Locale::Codes::Language_Retired'=> '3.39',
+ 'Locale::Codes::Script' => '3.39',
+ 'Locale::Codes::Script_Codes'=> '3.39',
+ 'Locale::Codes::Script_Retired'=> '3.39',
+ 'Locale::Country' => '3.39',
+ 'Locale::Currency' => '3.39',
+ 'Locale::Language' => '3.39',
+ 'Locale::Script' => '3.39',
+ 'Module::CoreList' => '5.20160620',
+ 'Module::CoreList::TieHashDelta'=> '5.20160620',
+ 'Module::CoreList::Utils'=> '5.20160620',
+ 'Opcode' => '1.35',
+ 'POSIX' => '1.70',
+ 'Pod::Checker' => '1.73',
+ 'Pod::Functions' => '1.11',
+ 'Pod::Functions::Functions'=> '1.11',
+ 'Pod::Usage' => '1.69',
+ 'Test2' => '1.302026',
+ 'Test2::API' => '1.302026',
+ 'Test2::API::Breakage' => '1.302026',
+ 'Test2::API::Context' => '1.302026',
+ 'Test2::API::Instance' => '1.302026',
+ 'Test2::API::Stack' => '1.302026',
+ 'Test2::Event' => '1.302026',
+ 'Test2::Event::Bail' => '1.302026',
+ 'Test2::Event::Diag' => '1.302026',
+ 'Test2::Event::Exception'=> '1.302026',
+ 'Test2::Event::Generic' => '1.302026',
+ 'Test2::Event::Note' => '1.302026',
+ 'Test2::Event::Ok' => '1.302026',
+ 'Test2::Event::Plan' => '1.302026',
+ 'Test2::Event::Skip' => '1.302026',
+ 'Test2::Event::Subtest' => '1.302026',
+ 'Test2::Event::Waiting' => '1.302026',
+ 'Test2::Formatter' => '1.302026',
+ 'Test2::Formatter::TAP' => '1.302026',
+ 'Test2::Hub' => '1.302026',
+ 'Test2::Hub::Interceptor'=> '1.302026',
+ 'Test2::Hub::Interceptor::Terminator'=> '1.302026',
+ 'Test2::Hub::Subtest' => '1.302026',
+ 'Test2::IPC' => '1.302026',
+ 'Test2::IPC::Driver' => '1.302026',
+ 'Test2::IPC::Driver::Files'=> '1.302026',
+ 'Test2::Util' => '1.302026',
+ 'Test2::Util::ExternalMeta'=> '1.302026',
+ 'Test2::Util::HashBase' => '1.302026',
+ 'Test2::Util::Trace' => '1.302026',
+ 'Test::Builder' => '1.302026',
+ 'Test::Builder::Formatter'=> '1.302026',
+ 'Test::Builder::Module' => '1.302026',
+ 'Test::Builder::Tester' => '1.302026',
+ 'Test::Builder::Tester::Color'=> '1.302026',
+ 'Test::Builder::TodoDiag'=> '1.302026',
+ 'Test::More' => '1.302026',
+ 'Test::Simple' => '1.302026',
+ 'Test::Tester' => '1.302026',
+ 'Test::Tester::Capture' => '1.302026',
+ 'Test::Tester::CaptureRunner'=> '1.302026',
+ 'Test::Tester::Delegate'=> '1.302026',
+ 'Test::use::ok' => '1.302026',
+ 'Thread::Queue' => '3.11',
+ 'Time::HiRes' => '1.9734',
+ 'Unicode::UCD' => '0.65',
+ 'VMS::DCLsym' => '1.07',
+ 'XS::APItest' => '0.82',
+ 'diagnostics' => '1.35',
+ 'feature' => '1.44',
+ 'ok' => '1.302026',
+ 'threads' => '2.09',
+ },
+ removed => {
+ }
+ },
);
sub is_core
removed => {
}
},
+ 5.025002 => {
+ delta_from => 5.025001,
+ changed => {
+ },
+ removed => {
+ }
+ },
);
for my $version (sort { $a <=> $b } keys %deprecated) {
'Test2::Event::Bail' => 'cpan',
'Test2::Event::Diag' => 'cpan',
'Test2::Event::Exception'=> 'cpan',
+ 'Test2::Event::Generic' => 'cpan',
'Test2::Event::Note' => 'cpan',
'Test2::Event::Ok' => 'cpan',
'Test2::Event::Plan' => 'cpan',
'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::Generic' => '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',
use strict;
use vars qw($VERSION);
-$VERSION = '5.20160520';
+$VERSION = '5.20160620';
sub TIEHASH {
my ($class, $changed, $removed, $parent) = @_;
use Module::CoreList;
use Module::CoreList::TieHashDelta;
-$VERSION = '5.20160520';
+$VERSION = '5.20160620';
sub utilities {
my $perl = shift;
removed => {
}
},
+ 5.025002 => {
+ delta_from => 5.025001,
+ changed => {
+ },
+ removed => {
+ }
+ },
);
for my $version (sort { $a <=> $b } keys %delta) {
Revision history for Perl distribution PathTools.
+3.64 - Tue May 24 10:00:19 MST 2016
+- just minor pod changes to silence Pod::Checker
+
3.62 - Mon Jan 11 08:39:19 EST 2016
- ensure File::Spec::canonpath() preserves taint (CVE-2015-8607)
use Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
-$VERSION = '3.63';
+$VERSION = '3.64';
my $xs_version = $VERSION;
$VERSION =~ tr/_//d;
use strict;
use vars qw(@ISA $VERSION);
-$VERSION = '3.63';
+$VERSION = '3.64';
$VERSION =~ tr/_//d;
my %module = (MacOS => 'Mac',
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.63';
+$VERSION = '3.64';
$VERSION =~ tr/_//d;
@ISA = qw(File::Spec::Unix);
use strict;
use vars qw($VERSION @ISA);
-$VERSION = '3.63';
+$VERSION = '3.64';
$VERSION =~ tr/_//d;
require File::Spec::Unix;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
-$VERSION = '3.63';
+$VERSION = '3.64';
$VERSION =~ tr/_//d;
require Exporter;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.63';
+$VERSION = '3.64';
$VERSION =~ tr/_//d;
@ISA = qw(File::Spec::Unix);
is passed as the first argument, it has a special meaning, see
(6)). This way, a colon ":" is handled like a "." (curdir) on Unix,
while an empty string "" is generally ignored (see
-C<Unix-E<gt>canonpath()> ). Likewise, a "::" is handled like a ".."
+L<File::Spec::Unix/canonpath()> ). Likewise, a "::" is handled like a ".."
(updir), and a ":::" is handled like a "../.." etc. E.g.
catdir("a",":",":","b") = ":a:b:"
# (e.g. "HD:a:")
However, this approach is limited to the first arguments following
-"root" (again, see C<Unix-E<gt>canonpath()> ). If there are more
+"root" (again, see L<File::Spec::Unix/canonpath()>. If there are more
arguments that move up the directory tree, an invalid path going
beyond root can be created.
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.63';
+$VERSION = '3.64';
$VERSION =~ tr/_//d;
@ISA = qw(File::Spec::Unix);
use strict;
use vars qw($VERSION);
-$VERSION = '3.63';
+$VERSION = '3.64';
my $xs_version = $VERSION;
$VERSION =~ tr/_//d;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.63';
+$VERSION = '3.64';
$VERSION =~ tr/_//d;
@ISA = qw(File::Spec::Unix);
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.63';
+$VERSION = '3.64';
$VERSION =~ tr/_//d;
@ISA = qw(File::Spec::Unix);
use strict;
use warnings;
-our $VERSION = '3.09';
+our $VERSION = '3.11';
$VERSION = eval $VERSION;
use threads::shared 1.21;
=head1 VERSION
-This document describes Thread::Queue version 3.09
+This document describes Thread::Queue version 3.11
=head1 SYNOPSIS
=head1 SEE ALSO
-Thread::Queue Discussion Forum on CPAN:
-L<http://www.cpanforum.com/dist/Thread-Queue>
+Thread::Queue on MetaCPAN:
+L<https://metacpan.org/release/Thread-Queue>
+
+Code repository for CPAN distribution:
+L<https://github.com/Dual-Life/Thread-Queue>
L<threads>, L<threads::shared>
my $sm = Thread::Semaphore->new(0);
my $st = Thread::Semaphore->new(0);
-threads->create(sub {
+my $thr = threads->create(sub {
{
lock($q);
$sm->up();
my @x = $q->extract(5,2);
is_deeply(\@x, [6,7], 'Thread dequeues under lock');
}
-})->detach();
+});
$sm->down();
$st->up();
my @x = $q->dequeue_nb(100);
is_deeply(\@x, [1..5,8..10], 'Main dequeues');
-threads::yield();
+
+$thr->join();
exit(0);
stat lstat
);
-our $VERSION = '1.9733';
+our $VERSION = '1.9734';
our $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
}
# endif
#endif
-#if defined(PERL_DARWIN)
+#if defined(PERL_DARWIN) && !defined(CLOCK_REALTIME)
# ifdef USE_ITHREADS
MUTEX_INIT(&darwin_time_mutex);
# endif
cmp_ok(abs(PI - 3.1416), '<', 0.0001);
is Other::PI, 3.141;
-use constant E2BIG => $! = 7;
-cmp_ok E2BIG, '==', 7;
-# This is something like "Arg list too long", but the actual message
-# text may vary, so we can't test much better than this.
-cmp_ok length(E2BIG), '>', 6;
+# Test that constant.pm can create a dualvar out of $!
+use constant A_DUALVAR_CONSTANT => $! = 7;
+cmp_ok A_DUALVAR_CONSTANT, '==', 7;
+# Make sure we have an error message string. It does not
+# matter that 7 means different things on different platforms.
+# If this test fails, then either constant.pm or $! is broken:
+cmp_ok length(A_DUALVAR_CONSTANT), '>', 6;
is @warnings, 0 or diag join "\n- ", "unexpected warning:", @warnings;
@warnings = (); # just in case
use strict;
use warnings;
-our $VERSION = '2.08';
+our $VERSION = '2.09';
my $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
=head1 VERSION
-This document describes threads version 2.08
+This document describes threads version 2.09
=head1 WARNING
crash the interpreter.
L<[perl #75154]|http://rt.perl.org/rt3/Public/Bug/Display.html?id=75154>
+=item Detached threads and global destruction
+
+If the main thread exits while there are detached threads which are still
+running, then Perl's global destruction phase is not executed because
+otherwise certain global structures that control the operation of threads and
+that are allocated in the main thread's memory may get destroyed before the
+detached thread is destroyed.
+
+If you are using any code that requires the execution of the global
+destruction phase for clean up (e.g., removing temp files), then do not use
+detached threads, but rather join all threads before exiting the program.
+
=item Perl Bugs and the CPAN Version of L<threads>
Support for threads extends beyond the code in this module (i.e.,
ok(! defined($rc), 'Exited: threads->exit()');
-run_perl(prog => 'use threads 2.08;' .
+run_perl(prog => 'use threads 2.09;' .
'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.08 qw(exit thread_only);' .
+run_perl(prog => 'use threads 2.09 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.08;' .
+my $out = run_perl(prog => 'use threads 2.09;' .
'threads->create(sub {' .
' exit(99);' .
'});' .
like($out, qr/1 finished and unjoined/, "exit(status) in thread");
-$out = run_perl(prog => 'use threads 2.08 qw(exit thread_only);' .
+$out = run_perl(prog => 'use threads 2.09 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.08;' .
+run_perl(prog => 'use threads 2.09;' .
'threads->create(sub {' .
' $SIG{__WARN__} = sub { exit(99); };' .
' die();' .
# bugid #24165
-run_perl(prog => 'use threads 2.08;' .
+run_perl(prog => 'use threads 2.09;' .
'sub a{threads->create(shift)} $t = a sub{};' .
'$t->tid; $t->join; $t->tid',
nolib => ($ENV{PERL_CORE}) ? 0 : 1,
const U8 gimme = GIMME_V;
const I32 dokv = (PL_op->op_type == OP_RV2HV || PL_op->op_type == OP_PADHV);
/* op_type is OP_RKEYS/OP_RVALUES if pp_rkeys delegated to here */
- const I32 dokeys = dokv || (PL_op->op_type == OP_KEYS);
- const I32 dovalues = dokv || (PL_op->op_type == OP_VALUES);
+ const I32 dokeys = dokv || (PL_op->op_type == OP_KEYS)
+ || ( PL_op->op_type == OP_AVHVSWITCH
+ && (PL_op->op_private & 3) + OP_EACH == OP_KEYS );
+ const I32 dovalues = dokv || (PL_op->op_type == OP_VALUES)
+ || ( PL_op->op_type == OP_AVHVSWITCH
+ && (PL_op->op_private & 3) + OP_EACH == OP_VALUES );
(void)hv_iterinit(keys); /* always reset iterator regardless */
RETURN;
}
+ if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
+ const I32 flags = is_lvalue_sub();
+ if (flags && !(flags & OPpENTERSUB_INARGS))
+ /* diag_listed_as: Can't modify %s in %s */
+ Perl_croak(aTHX_ "Can't modify keys in list assignment");
+ }
+
/* 2*HvUSEDKEYS() should never be big enough to truncate or wrap */
assert(HvUSEDKEYS(keys) <= (SSize_t_MAX >> 1));
extend_size = (SSize_t)HvUSEDKEYS(keys) * (dokeys + dovalues);
Ap |I32 * |markstack_grow
#if defined(USE_LOCALE_COLLATE)
p |int |magic_setcollxfrm|NN SV* sv|NN MAGIC* mg
+pb |char* |mem_collxfrm |NN const char* input_string|STRLEN len|NN STRLEN* xlen
: Defined in locale.c, used only in sv.c
-p |char* |mem_collxfrm |NN const char* s|STRLEN len|NN STRLEN* xlen
+# if defined(PERL_IN_LOCALE_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_MATHOMS_C)
+pM |char* |_mem_collxfrm |NN const char* input_string \
+ |STRLEN len \
+ |NN STRLEN* xlen \
+ |bool utf8
+# endif
#endif
Afpd |SV* |mess |NN const char* pat|...
Apd |SV* |mess_sv |NN SV* basemsg|bool consume
#define share_hek_flags(a,b,c,d) S_share_hek_flags(aTHX_ a,b,c,d)
#define unshare_hek_or_pvn(a,b,c,d) S_unshare_hek_or_pvn(aTHX_ a,b,c,d)
# endif
+# if defined(PERL_IN_LOCALE_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_MATHOMS_C)
+# if defined(USE_LOCALE_COLLATE)
+#define _mem_collxfrm(a,b,c,d) Perl__mem_collxfrm(aTHX_ a,b,c,d)
+# endif
+# endif
# if defined(PERL_IN_MALLOC_C)
#define adjust_size_and_find_bucket S_adjust_size_and_find_bucket
# endif
# endif
# if defined(USE_LOCALE_COLLATE)
#define magic_setcollxfrm(a,b) Perl_magic_setcollxfrm(aTHX_ a,b)
+#ifndef NO_MATHOMS
#define mem_collxfrm(a,b,c) Perl_mem_collxfrm(aTHX_ a,b,c)
+#endif
# endif
# if defined(USE_PERLIO)
#define PerlIO_restore_errno(a) Perl_PerlIO_restore_errno(aTHX_ a)
#define PL_in_clean_objs (vTHX->Iin_clean_objs)
#define PL_in_eval (vTHX->Iin_eval)
#define PL_in_load_module (vTHX->Iin_load_module)
+#define PL_in_utf8_COLLATE_locale (vTHX->Iin_utf8_COLLATE_locale)
#define PL_in_utf8_CTYPE_locale (vTHX->Iin_utf8_CTYPE_locale)
#define PL_incgv (vTHX->Iincgv)
#define PL_initav (vTHX->Iinitav)
#define PL_stderrgv (vTHX->Istderrgv)
#define PL_stdingv (vTHX->Istdingv)
#define PL_strtab (vTHX->Istrtab)
+#define PL_strxfrm_is_behaved (vTHX->Istrxfrm_is_behaved)
+#define PL_strxfrm_max_cp (vTHX->Istrxfrm_max_cp)
+#define PL_strxfrm_min_char (vTHX->Istrxfrm_min_char)
#define PL_sub_generation (vTHX->Isub_generation)
#define PL_subline (vTHX->Isubline)
#define PL_subname (vTHX->Isubname)
package Devel::Peek;
-$VERSION = '1.23';
+$VERSION = '1.24';
$XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
If C<use Devel::Peek> directive has a C<:opd=FLAGS> argument,
this switches on debugging of opcode dispatch. C<FLAGS> should be a
-combination of C<s>, C<t>, and C<P> (see B<-D> flags in L<perlrun>).
+combination of C<s>, C<t>, and C<P> (see
+L<< B<-D> flags in perlrun|perlrun/B<-D>I<letters> >>).
+
C<:opd> is a shortcut for C<:opd=st>.
=head2 Runtime debugging
=item *
-it is not currently executed (see C<DEPTH>);
+it is not currently executed (because C<DEPTH> is 0);
=item *
# Tim.Bunce@ig.co.uk, August 1994
BEGIN {
- $VERSION = '1.38';
+ $VERSION = '1.39';
}
EOT
Dean Roerich's Perl 5 API document. Also, have a look in the typemap
file (in the ext directory) for a fairly comprehensive list of types
that are already supported. If you are completely stuck, I suggest you
- post a message to perl5-porters, comp.lang.perl.misc or if you are really
- desperate to me.
+ post a message to perl5-porters.
Remember when you are making any changes that the return value from
dl_load_file is used as a parameter in the dl_find_symbol
@ISA = qw(Exporter);
@EXPORT = qw(writemain);
-$VERSION = '1.05';
+$VERSION = '1.06';
# blead will run this with miniperl, hence we can't use autodie or File::Temp
my $temp;
my(@exts) = @_;
printf $fh <<'EOF!HEAD', xsi_header();
-/* miniperlmain.c
+/* miniperlmain.c or perlmain.c - a generated file
*
* Copyright (C) 1994, 1995, 1996, 1997, 1999, 2000, 2001, 2002, 2003,
- * 2004, 2005, 2006, 2007, by Larry Wall and others
+ * 2004, 2005, 2006, 2007, 2016 by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
/* This file contains the main() function for the perl interpreter.
* Note that miniperlmain.c contains main() for the 'miniperl' binary,
- * while perlmain.c contains main() for the 'perl' binary.
+ * while perlmain.c contains main() for the 'perl' binary. The typical
+ * difference being that the latter includes Dynaloader.
*
* Miniperl is like perl except that it does not support dynamic loading,
* and in fact is used to build the dynamic modules needed for the 'real'
* perl executable.
+ *
+ * The content of the body of this generated file is mostly contained
+ * in Miniperl.pm - edit that file if you want to change anything.
+ * miniperlmain.c is generated by running regen/miniperlmain.pl.pl, while
+ * perlmain.c is built automatically by Makefile (so the former is
+ * included in the tarball while the latter isn't).
*/
#ifdef OEMVS
=head1 NAME
-ExtUtils::Miniperl - write the C code for perlmain.c
+ExtUtils::Miniperl - write the C code for miniperlmain.c and perlmain.c
=head1 SYNOPSIS
=head1 DESCRIPTION
-C<writemain()> takes an argument list of directories containing archive
+C<writemain()> takes an argument list of zero or more directories
+containing archive
libraries that relate to perl modules and should be linked into a new
-perl binary. It writes a corresponding F<perlmain.c> file that
+perl binary. It writes a corresponding F<miniperlmain.c> or F<perlmain.c>
+file that
is a plain C file containing all the bootstrap code to make the
modules associated with the libraries available from within perl.
If the first argument to C<writemain()> is a reference to a scalar it is
used as the filename to open for output. Any other reference is used as
the filehandle to write to. Otherwise output defaults to C<STDOUT>.
-The typical usage is from within a Makefile generated by
-L<ExtUtils::MakeMaker>. So under normal circumstances you won't have to
-deal with this module directly.
+The typical usage is from within perl's own Makefile (to build
+F<perlmain.c>) or from F<regen/miniperlmain.pl> (to build miniperlmain.c).
+So under normal circumstances you won't have to deal with this module
+directly.
=head1 SEE ALSO
@EXPORT_OK = (@{$EXPORT_TAGS{'glob'}}, 'csh_glob');
-$VERSION = '1.26';
+$VERSION = '1.27';
sub import {
require Exporter;
=head3 C<bsd_glob>
This function, which is included in the two export tags listed above,
-takes one or two arguments. The first is the glob pattern. The second is
-a set of flags ORed together. The available flags are listed below under
-L</POSIX FLAGS>. If the second argument is omitted, C<GLOB_CSH> (or
-C<GLOB_CSH|GLOB_NOCASE> on VMS and DOSish systems) is used by default.
+takes one or two arguments. The first is the glob pattern. The
+second, if given, is a set of flags ORed together. The available
+flags and the default set of flags are listed below under L</POSIX FLAGS>.
+
+Remember that to use the named constants for flags you must import
+them, for example with C<:bsd_glob> described above. If not imported,
+and C<use strict> is not in effect, then the constants will be
+treated as bareword strings, which won't do what you what.
+
=head3 C<:nocase> and C<:case>
=head2 POSIX FLAGS
-The POSIX defined flags for bsd_glob() are:
+If no flags argument is give then C<GLOB_CSH> is set, and on VMS and
+Windows systems, C<GLOB_NOCASE> too. Otherwise the flags to use are
+determined solely by the flags argument. The POSIX defined flags are:
=over 4
our($VERSION, @ISA, @EXPORT_OK);
-$VERSION = "1.34";
+$VERSION = "1.35";
use Carp;
use Exporter ();
warn die lineseq nextstate scope enter leave
- rv2cv anoncode prototype coreargs anonconst
+ rv2cv anoncode prototype coreargs avhvswitch anonconst
entersub leavesub leavesublv return method method_named
method_super method_redir method_redir_super
SV *const t = newSVrv(rv, packname);
void *const p = sv_grow(t, size + 1);
+ /* Ensure at least one use of not_here() to avoid "defined but not
+ * used" warning. This is not at all related to allocate_struct(); I
+ * just needed somewhere to dump it - DAPM */
+ if (0) { not_here(""); }
+
SvCUR_set(t, size);
SvPOK_on(t);
return p;
our ($AUTOLOAD, %SIGRT);
-our $VERSION = '1.69';
+our $VERSION = '1.70';
require XSLoader;
$skip{pid}{$^O} = $skip{uid}{$^O} = "not set for kill()"
if (($^O.$Config{osvers}) =~ /^darwin[0-8]\./
||
- ($^O.$Config{osvers}) =~ /^openbsd[0-5]\./);
+ ($^O.$Config{osvers}) =~ /^openbsd[0-5]\./
+ ||
+ ($^O eq 'gnu'));
my $tests = keys %{{ %siginfo, %opt_val }};
eval 'use POSIX qw(SA_SIGINFO); SA_SIGINFO';
skip("no SA_SIGINFO", $tests) if $@;
=head1 SYNOPSIS
use Pod::Functions;
-
+
my @misc_ops = @{ $Kinds{ 'Misc' } };
my $misc_dsc = $Type_Description{ 'Misc' };
=cut
-our $VERSION = '1.10';
+our $VERSION = '1.11';
require Exporter;
# Package globals
@ISA = ( 'DynaLoader' );
-$VERSION = '1.06';
+$VERSION = '1.07';
my(%Locsyms) = ( ':ID' => 'LOCAL' );
my(%Gblsyms) = ( ':ID' => 'GLOBAL');
my $DoCache = 1;
deleting an element deletes the corresponding symbol. Setting an element to
C<undef>, or C<undef>ing it directly, sets the corresponding symbol to the null
string. You may also read the special keys ':GLOBAL' and ':LOCAL' to find out
-whether a default symbol table has been specified for this hash (see C<table>
-below), or set either or these keys to specify a default symbol table.
+whether a default symbol table has been specified for this hash (see the next
+paragraph), or set either or these keys to specify a default symbol table.
When you call the C<tie> function to bind an associative array to this package,
you may specify as an optional argument the symbol table in which you wish to
use warnings;
use Carp;
-our $VERSION = '0.81';
+our $VERSION = '0.82';
require XSLoader;
padadd_STATE, 0, 0);
SvREFCNT_dec(PL_curpad[off]);
PL_curpad[off] = SvREFCNT_inc(cv);
+ intro_my();
LEAVE;
}
} 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);
+ Perl_croak(aTHX_ "load_module can't yet support %"IVdf" items", (IV)items);
MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest
-use Test::More tests => 4;
+use Test::More tests => 5;
use XS::APItest;
our sub fribbler;
is fribbler(15), 30, 'our sub overrides XS-registered lexical sub';
}
+
+# With ‘use’ rather than explicit BEGIN:
+package Lexical::Exporter {
+ sub import { shift; ::lexical_import @_; return }
+}
+BEGIN { ++$INC{"Lexical/Exporter.pm"} }
+
+{
+ use Lexical::Exporter fribbler => sub { shift() . "foo" };
+ is fribbler("bar"), "barfoo";
+}
FEATURE_IS_ENABLED("evalbytes")) \
)
-#define FEATURE_POSTDEREF_IS_ENABLED \
- ( \
- CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \
- FEATURE_IS_ENABLED("postderef") \
- )
-
#define FEATURE_ARYBASE_IS_ENABLED \
( \
CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_511 \
FEATURE_IS_ENABLED("refaliasing") \
)
-#define FEATURE_LEXSUBS_IS_ENABLED \
- ( \
- CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \
- FEATURE_IS_ENABLED("lexsubs") \
- )
-
#define FEATURE_POSTDEREF_QQ_IS_ENABLED \
( \
CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_523 \
return NULL;
case KEY_chdir:
case KEY_chomp: case KEY_chop: case KEY_defined: case KEY_delete:
- case KEY_each : case KEY_eof : case KEY_exec : case KEY_exists:
- case KEY_keys:
+ case KEY_eof : case KEY_exec: case KEY_exists :
case KEY_lstat:
- case KEY_pop:
- case KEY_push:
- case KEY_shift:
- case KEY_splice: case KEY_split:
+ case KEY_split:
case KEY_stat:
case KEY_system:
case KEY_truncate: case KEY_unlink:
- case KEY_unshift:
- case KEY_values:
ampable = FALSE;
}
if (!gv) {
)) != NULL) {
assert(GvCV(gv) == orig_cv);
if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS
- && opnum != OP_UNDEF)
+ && opnum != OP_UNDEF && opnum != OP_KEYS)
CvLVALUE_off(cv); /* Now *that* was a neat trick. */
}
LEAVE;
=for apidoc Am|void|Newx|void* ptr|int nitems|type
The XSUB-writer's interface to the C C<malloc> function.
-Memory obtained by this should B<ONLY> be freed with L<"Safefree">.
+Memory obtained by this should B<ONLY> be freed with L</"Safefree">.
In 5.9.3, Newx() and friends replace the older New() API, and drops
the first parameter, I<x>, a debug aid which allowed callers to identify
The XSUB-writer's interface to the C C<malloc> function, with
cast. See also C<L</Newx>>.
-Memory obtained by this should B<ONLY> be freed with L<"Safefree">.
+Memory obtained by this should B<ONLY> be freed with L</"Safefree">.
=for apidoc Am|void|Newxz|void* ptr|int nitems|type
The XSUB-writer's interface to the C C<malloc> function. The allocated
memory is zeroed with C<memzero>. See also C<L</Newx>>.
-Memory obtained by this should B<ONLY> be freed with L<"Safefree">.
+Memory obtained by this should B<ONLY> be freed with L</"Safefree">.
=for apidoc Am|void|Renew|void* ptr|int nitems|type
The XSUB-writer's interface to the C C<realloc> function.
-Memory obtained by this should B<ONLY> be freed with L<"Safefree">.
+Memory obtained by this should B<ONLY> be freed with L</"Safefree">.
=for apidoc Am|void|Renewc|void* ptr|int nitems|type|cast
The XSUB-writer's interface to the C C<realloc> function, with
cast.
-Memory obtained by this should B<ONLY> be freed with L<"Safefree">.
+Memory obtained by this should B<ONLY> be freed with L</"Safefree">.
=for apidoc Am|void|Safefree|void* ptr
The XSUB-writer's interface to the C C<free> function.
-This should B<ONLY> be used on memory obtained using L<"Newx"> and friends.
+This should B<ONLY> be used on memory obtained using L</"Newx"> and friends.
=for apidoc Am|void|Move|void* src|void* dest|int nitems|type
The XSUB-writer's interface to the C C<memmove> function. The C<src> is the
# 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.1
+# mkdir -p /opt/perl-catamount/lib/perl5/5.25.2
# 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.1
+# cp -pr lib/* /opt/perl-catamount/lib/perl5/5.25.2
# 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
# hints/gnu.sh
-# Last modified: Thu Dec 10 20:47:28 CET 1998
-# Mark Kettenis <kettenis@phys.uva.nl>
+# Originally contributed by: Mark Kettenis <kettenis@phys.uva.nl> Dec 10 1998
# libnsl is unusable on the Hurd.
# XXX remove this once SUNRPC is implemented.
# Flags needed by programs that use dynamic linking.
ccdlflags='-Wl,-E'
-# Debian bug #258618
-ccflags="-D_GNU_SOURCE $ccflags"
+# This script UU/usethreads.cbu will get 'called-back' by Configure
+# after it has prompted the user for whether to use threads.
+cat > UU/usethreads.cbu <<'EOCBU'
+case "$usethreads" in
+$define|true|[yY]*)
+ ccflags="-D_REENTRANT -D_GNU_SOURCE $ccflags"
+ if echo $libswanted | grep -v pthread >/dev/null
+ then
+ set `echo X "$libswanted "| sed -e 's/ c / pthread c /'`
+ shift
+ libswanted="$*"
+ fi
+
+ # Somehow at least in Debian 2.2 these manage to escape
+ # the #define forest of <features.h> and <time.h> so that
+ # the hasproto macro of Configure doesn't see these protos,
+ # even with the -D_GNU_SOURCE.
+
+ d_asctime_r_proto="$define"
+ d_crypt_r_proto="$define"
+ d_ctime_r_proto="$define"
+ d_gmtime_r_proto="$define"
+ d_localtime_r_proto="$define"
+ d_random_r_proto="$define"
+
+ ;;
+esac
+EOCBU
cat > UU/uselargefiles.cbu <<'EOCBU'
# This script UU/uselargefiles.cbu will get 'called-back' by Configure
PERLVAR(I, utf8locale, bool) /* utf8 locale detected */
PERLVAR(I, in_utf8_CTYPE_locale, bool)
+PERLVAR(I, in_utf8_COLLATE_locale, bool)
#ifdef USE_LOCALE_CTYPE
PERLVAR(I, warn_locale, SV *)
#endif
PERLVAR(I, collxfrm_base, Size_t) /* Basic overhead in *xfrm() */
PERLVARI(I, collxfrm_mult,Size_t, 2) /* Expansion factor in *xfrm() */
PERLVARI(I, collation_ix, U32, 0) /* Collation generation index */
+PERLVARA(I, strxfrm_min_char, 3, char)
+PERLVARI(I, strxfrm_is_behaved, bool, TRUE)
+ /* Assume until proven otherwise that it works */
+PERLVARI(I, strxfrm_max_cp, U8, 0) /* Highest collating cp in locale */
PERLVARI(I, collation_standard, bool, TRUE)
/* Assume simple collation */
#endif /* USE_LOCALE_COLLATE */
####
# SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"
# lexical subroutine
-use feature 'lexical_subs';
+# CONTEXT use feature 'lexical_subs';
no warnings "experimental::lexical_subs";
my sub f {}
print f();
>>>>
-use feature 'lexical_subs';
BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55\x15"}
my sub f {
BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x15"}
####
# SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"
# lexical "state" subroutine
-use feature 'state', 'lexical_subs';
+# CONTEXT use feature 'state', 'lexical_subs';
no warnings 'experimental::lexical_subs';
state sub f {}
print f();
>>>>
-use feature 'lexical_subs';
BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55\x15"}
-CORE::state sub f {
+state sub f {
BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x15"}
- use feature 'state';
}
BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x15"}
-use feature 'state';
print f();
####
# SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"
our %bits;
-our $VERSION = "5.025001";
+our $VERSION = "5.025002";
$bits{$_}{3} = 'OPpENTERSUB_AMPER' for qw(entersub rv2cv);
$bits{$_}{6} = 'OPpENTERSUB_DB' for qw(entersub rv2cv);
$bits{$_}{7} = 'OPpLVAL_INTRO' for qw(aelem aslice cond_expr delete enteriter entersub gvsv helem hslice list lvavref lvref lvrefslice multideref padav padhv padrange padsv pushmark refassign rv2av rv2gv rv2hv rv2sv);
$bits{$_}{2} = 'OPpLVREF_ELEM' for qw(lvref refassign);
$bits{$_}{3} = 'OPpLVREF_ITER' for qw(lvref refassign);
-$bits{$_}{3} = 'OPpMAYBE_LVSUB' for qw(aassign aelem aslice av2arylen helem hslice keys kvaslice kvhslice multideref padav padhv pos rv2av rv2gv rv2hv substr vec);
+$bits{$_}{3} = 'OPpMAYBE_LVSUB' for qw(aassign aelem akeys aslice av2arylen avhvswitch helem hslice keys kvaslice kvhslice multideref padav padhv pos rv2av rv2gv rv2hv substr vec);
$bits{$_}{4} = 'OPpMAYBE_TRUEBOOL' for qw(padhv rv2hv);
$bits{$_}{7} = 'OPpOFFBYONE' for qw(caller runcv wantarray);
$bits{$_}{5} = 'OPpOPEN_IN_CRLF' for qw(backtick open);
bitmask => 3,
},
{
+ bitmin => 0,
+ bitmax => 1,
+ bitmask => 3,
+ },
+ {
label => '-',
mask_def => 'OPpARG3_MASK',
bitmin => 0,
@{$bits{aassign}}{6,5,4,1,0} = ('OPpASSIGN_COMMON_SCALAR', 'OPpASSIGN_COMMON_RC1', 'OPpASSIGN_COMMON_AGG', $bf[1], $bf[1]);
$bits{abs}{0} = $bf[0];
-@{$bits{accept}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{accept}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{add}}{1,0} = ($bf[1], $bf[1]);
$bits{aeach}{0} = $bf[0];
-@{$bits{aelem}}{5,4,1,0} = ($bf[6], $bf[6], $bf[1], $bf[1]);
-@{$bits{aelemfast}}{7,6,5,4,3,2,1,0} = ($bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5]);
-@{$bits{aelemfast_lex}}{7,6,5,4,3,2,1,0} = ($bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5]);
+@{$bits{aelem}}{5,4,1,0} = ($bf[7], $bf[7], $bf[1], $bf[1]);
+@{$bits{aelemfast}}{7,6,5,4,3,2,1,0} = ($bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6]);
+@{$bits{aelemfast_lex}}{7,6,5,4,3,2,1,0} = ($bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6]);
$bits{akeys}{0} = $bf[0];
$bits{alarm}{0} = $bf[0];
$bits{and}{0} = $bf[0];
$bits{andassign}{0} = $bf[0];
$bits{anonconst}{0} = $bf[0];
-@{$bits{anonhash}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{anonlist}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{atan2}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{anonhash}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{anonlist}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{atan2}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{av2arylen}{0} = $bf[0];
$bits{avalues}{0} = $bf[0];
+@{$bits{avhvswitch}}{1,0} = ($bf[2], $bf[2]);
$bits{backtick}{0} = $bf[0];
-@{$bits{bind}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{binmode}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{bind}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{binmode}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{bit_and}}{1,0} = ($bf[1], $bf[1]);
@{$bits{bit_or}}{1,0} = ($bf[1], $bf[1]);
@{$bits{bit_xor}}{1,0} = ($bf[1], $bf[1]);
-@{$bits{bless}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{caller}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{chdir}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{chmod}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{bless}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{caller}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{chdir}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{chmod}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{chomp}{0} = $bf[0];
$bits{chop}{0} = $bf[0];
-@{$bits{chown}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{chown}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{chr}{0} = $bf[0];
$bits{chroot}{0} = $bf[0];
-@{$bits{close}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{close}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{closedir}{0} = $bf[0];
$bits{complement}{0} = $bf[0];
@{$bits{concat}}{1,0} = ($bf[1], $bf[1]);
$bits{cond_expr}{0} = $bf[0];
-@{$bits{connect}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{connect}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{const}}{6,4,3,2,1} = ('OPpCONST_BARE', 'OPpCONST_ENTERED', 'OPpCONST_STRICT', 'OPpCONST_SHORTCIRCUIT', 'OPpCONST_NOVER');
@{$bits{coreargs}}{7,6,1,0} = ('OPpCOREARGS_PUSHMARK', 'OPpCOREARGS_SCALARMOD', 'OPpCOREARGS_DEREF2', 'OPpCOREARGS_DEREF1');
$bits{cos}{0} = $bf[0];
-@{$bits{crypt}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{crypt}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{dbmclose}{0} = $bf[0];
-@{$bits{dbmopen}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{dbmopen}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{defined}{0} = $bf[0];
@{$bits{delete}}{6,0} = ('OPpSLICE', $bf[0]);
-@{$bits{die}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{die}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{divide}}{1,0} = ($bf[1], $bf[1]);
$bits{dofile}{0} = $bf[0];
$bits{dor}{0} = $bf[0];
@{$bits{entereval}}{5,4,3,2,1,0} = ('OPpEVAL_RE_REPARSING', 'OPpEVAL_COPHH', 'OPpEVAL_BYTES', 'OPpEVAL_UNICODE', 'OPpEVAL_HAS_HH', $bf[0]);
$bits{entergiven}{0} = $bf[0];
$bits{enteriter}{3} = 'OPpITER_DEF';
-@{$bits{entersub}}{5,4,0} = ($bf[6], $bf[6], 'OPpENTERSUB_INARGS');
+@{$bits{entersub}}{5,4,0} = ($bf[7], $bf[7], 'OPpENTERSUB_INARGS');
$bits{entertry}{0} = $bf[0];
$bits{enterwhen}{0} = $bf[0];
-@{$bits{enterwrite}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{eof}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{enterwrite}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{eof}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{eq}}{1,0} = ($bf[1], $bf[1]);
-@{$bits{exec}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{exec}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{exists}}{6,0} = ('OPpEXISTS_SUB', $bf[0]);
-@{$bits{exit}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{exit}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{exp}{0} = $bf[0];
$bits{fc}{0} = $bf[0];
-@{$bits{fcntl}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{fileno}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{fcntl}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{fileno}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{flip}{0} = $bf[0];
-@{$bits{flock}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{flock}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{flop}{0} = $bf[0];
-@{$bits{formline}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{formline}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{ftatime}{0} = $bf[0];
$bits{ftbinary}{0} = $bf[0];
$bits{ftblk}{0} = $bf[0];
$bits{ftzero}{0} = $bf[0];
@{$bits{ge}}{1,0} = ($bf[1], $bf[1]);
@{$bits{gelem}}{1,0} = ($bf[1], $bf[1]);
-@{$bits{getc}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{getc}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{getpeername}{0} = $bf[0];
-@{$bits{getpgrp}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{getpriority}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{getpgrp}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{getpriority}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{getsockname}{0} = $bf[0];
$bits{ggrgid}{0} = $bf[0];
$bits{ggrnam}{0} = $bf[0];
-@{$bits{ghbyaddr}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{ghbyaddr}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{ghbyname}{0} = $bf[0];
-@{$bits{glob}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{gmtime}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{gnbyaddr}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{glob}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{gmtime}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{gnbyaddr}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{gnbyname}{0} = $bf[0];
$bits{goto}{0} = $bf[0];
$bits{gpbyname}{0} = $bf[0];
-@{$bits{gpbynumber}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{gpbynumber}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{gpwnam}{0} = $bf[0];
$bits{gpwuid}{0} = $bf[0];
$bits{grepstart}{0} = $bf[0];
$bits{grepwhile}{0} = $bf[0];
-@{$bits{gsbyname}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{gsbyport}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{gsockopt}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{gsbyname}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{gsbyport}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{gsockopt}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{gt}}{1,0} = ($bf[1], $bf[1]);
$bits{gv}{5} = 'OPpEARLY_CV';
-@{$bits{helem}}{5,4,1,0} = ($bf[6], $bf[6], $bf[1], $bf[1]);
+@{$bits{helem}}{5,4,1,0} = ($bf[7], $bf[7], $bf[1], $bf[1]);
$bits{hex}{0} = $bf[0];
@{$bits{i_add}}{1,0} = ($bf[1], $bf[1]);
@{$bits{i_divide}}{1,0} = ($bf[1], $bf[1]);
$bits{i_predec}{0} = $bf[0];
$bits{i_preinc}{0} = $bf[0];
@{$bits{i_subtract}}{1,0} = ($bf[1], $bf[1]);
-@{$bits{index}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{index}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{int}{0} = $bf[0];
-@{$bits{ioctl}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{join}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{ioctl}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{join}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{keys}{0} = $bf[0];
-@{$bits{kill}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{kill}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{last}{0} = $bf[0];
$bits{lc}{0} = $bf[0];
$bits{lcfirst}{0} = $bf[0];
$bits{leavewrite}{0} = $bf[0];
@{$bits{left_shift}}{1,0} = ($bf[1], $bf[1]);
$bits{length}{0} = $bf[0];
-@{$bits{link}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{link}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{list}{6} = 'OPpLIST_GUESSED';
-@{$bits{listen}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{listen}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{localtime}{0} = $bf[0];
$bits{lock}{0} = $bf[0];
$bits{log}{0} = $bf[0];
$bits{lstat}{0} = $bf[0];
@{$bits{lt}}{1,0} = ($bf[1], $bf[1]);
$bits{lvavref}{0} = $bf[0];
-@{$bits{lvref}}{5,4,0} = ($bf[7], $bf[7], $bf[0]);
+@{$bits{lvref}}{5,4,0} = ($bf[8], $bf[8], $bf[0]);
$bits{mapstart}{0} = $bf[0];
$bits{mapwhile}{0} = $bf[0];
$bits{method}{0} = $bf[0];
$bits{method_redir}{0} = $bf[0];
$bits{method_redir_super}{0} = $bf[0];
$bits{method_super}{0} = $bf[0];
-@{$bits{mkdir}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{mkdir}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{modulo}}{1,0} = ($bf[1], $bf[1]);
-@{$bits{msgctl}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{msgget}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{msgrcv}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{msgsnd}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{msgctl}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{msgget}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{msgrcv}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{msgsnd}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{multideref}}{5,4,0} = ('OPpMULTIDEREF_DELETE', 'OPpMULTIDEREF_EXISTS', $bf[0]);
@{$bits{multiply}}{1,0} = ($bf[1], $bf[1]);
@{$bits{nbit_and}}{1,0} = ($bf[1], $bf[1]);
$bits{not}{0} = $bf[0];
$bits{oct}{0} = $bf[0];
$bits{once}{0} = $bf[0];
-@{$bits{open}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{open_dir}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{open}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{open_dir}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{or}{0} = $bf[0];
$bits{orassign}{0} = $bf[0];
$bits{ord}{0} = $bf[0];
-@{$bits{pack}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{padrange}}{6,5,4,3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4], $bf[4], $bf[4], $bf[4]);
-@{$bits{padsv}}{5,4} = ($bf[6], $bf[6]);
-@{$bits{pipe_op}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{pack}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{padrange}}{6,5,4,3,2,1,0} = ($bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5]);
+@{$bits{padsv}}{5,4} = ($bf[7], $bf[7]);
+@{$bits{pipe_op}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{pop}{0} = $bf[0];
$bits{pos}{0} = $bf[0];
$bits{postdec}{0} = $bf[0];
$bits{predec}{0} = $bf[0];
$bits{preinc}{0} = $bf[0];
$bits{prototype}{0} = $bf[0];
-@{$bits{push}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{push}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{quotemeta}{0} = $bf[0];
-@{$bits{rand}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{rand}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{range}{0} = $bf[0];
-@{$bits{read}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{read}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{readdir}{0} = $bf[0];
$bits{readline}{0} = $bf[0];
$bits{readlink}{0} = $bf[0];
-@{$bits{recv}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{recv}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{redo}{0} = $bf[0];
$bits{ref}{0} = $bf[0];
-@{$bits{refassign}}{5,4,1,0} = ($bf[7], $bf[7], $bf[1], $bf[1]);
+@{$bits{refassign}}{5,4,1,0} = ($bf[8], $bf[8], $bf[1], $bf[1]);
$bits{refgen}{0} = $bf[0];
$bits{regcmaybe}{0} = $bf[0];
$bits{regcomp}{0} = $bf[0];
$bits{regcreset}{0} = $bf[0];
-@{$bits{rename}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{rename}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{repeat}}{6,1,0} = ('OPpREPEAT_DOLIST', $bf[1], $bf[1]);
$bits{require}{0} = $bf[0];
-@{$bits{reset}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{reset}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{reverse}}{3,0} = ('OPpREVERSE_INPLACE', $bf[0]);
$bits{rewinddir}{0} = $bf[0];
@{$bits{right_shift}}{1,0} = ($bf[1], $bf[1]);
-@{$bits{rindex}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{rindex}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{rmdir}{0} = $bf[0];
$bits{rv2av}{0} = $bf[0];
@{$bits{rv2cv}}{7,5,0} = ('OPpENTERSUB_NOPAREN', 'OPpMAY_RETURN_CONSTANT', $bf[0]);
-@{$bits{rv2gv}}{6,5,4,2,0} = ('OPpALLOW_FAKE', $bf[6], $bf[6], 'OPpDONT_INIT_GV', $bf[0]);
+@{$bits{rv2gv}}{6,5,4,2,0} = ('OPpALLOW_FAKE', $bf[7], $bf[7], 'OPpDONT_INIT_GV', $bf[0]);
$bits{rv2hv}{0} = $bf[0];
-@{$bits{rv2sv}}{5,4,0} = ($bf[6], $bf[6], $bf[0]);
+@{$bits{rv2sv}}{5,4,0} = ($bf[7], $bf[7], $bf[0]);
@{$bits{sassign}}{7,6,1,0} = ('OPpASSIGN_CV_TO_GV', 'OPpASSIGN_BACKWARDS', $bf[1], $bf[1]);
@{$bits{sbit_and}}{1,0} = ($bf[1], $bf[1]);
@{$bits{sbit_or}}{1,0} = ($bf[1], $bf[1]);
$bits{schop}{0} = $bf[0];
@{$bits{scmp}}{1,0} = ($bf[1], $bf[1]);
$bits{scomplement}{0} = $bf[0];
-@{$bits{seek}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{seekdir}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{select}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{semctl}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{semget}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{semop}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{send}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{seek}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{seekdir}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{select}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{semctl}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{semget}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{semop}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{send}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{seq}}{1,0} = ($bf[1], $bf[1]);
-@{$bits{setpgrp}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{setpriority}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{setpgrp}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{setpriority}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{sge}}{1,0} = ($bf[1], $bf[1]);
@{$bits{sgt}}{1,0} = ($bf[1], $bf[1]);
$bits{shift}{0} = $bf[0];
-@{$bits{shmctl}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{shmget}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{shmread}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{shmwrite}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{shmctl}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{shmget}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{shmread}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{shmwrite}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{shostent}{0} = $bf[0];
-@{$bits{shutdown}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{shutdown}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{sin}{0} = $bf[0];
@{$bits{sle}}{1,0} = ($bf[1], $bf[1]);
-@{$bits{sleep}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{sleep}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{slt}}{1,0} = ($bf[1], $bf[1]);
@{$bits{smartmatch}}{1,0} = ($bf[1], $bf[1]);
@{$bits{sne}}{1,0} = ($bf[1], $bf[1]);
$bits{snetent}{0} = $bf[0];
-@{$bits{socket}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{sockpair}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{socket}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{sockpair}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{sort}}{6,5,4,3,2,1,0} = ('OPpSORT_STABLE', 'OPpSORT_QSORT', 'OPpSORT_DESCEND', 'OPpSORT_INPLACE', 'OPpSORT_REVERSE', 'OPpSORT_INTEGER', 'OPpSORT_NUMERIC');
-@{$bits{splice}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{splice}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{split}{7} = 'OPpSPLIT_IMPLIM';
-@{$bits{sprintf}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{sprintf}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{sprotoent}{0} = $bf[0];
$bits{sqrt}{0} = $bf[0];
-@{$bits{srand}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{srand}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{srefgen}{0} = $bf[0];
-@{$bits{sselect}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{sselect}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{sservent}{0} = $bf[0];
-@{$bits{ssockopt}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{ssockopt}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{stat}{0} = $bf[0];
-@{$bits{stringify}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{stringify}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{study}{0} = $bf[0];
$bits{substcont}{0} = $bf[0];
-@{$bits{substr}}{4,2,1,0} = ('OPpSUBSTR_REPL_FIRST', $bf[2], $bf[2], $bf[2]);
+@{$bits{substr}}{4,2,1,0} = ('OPpSUBSTR_REPL_FIRST', $bf[3], $bf[3], $bf[3]);
@{$bits{subtract}}{1,0} = ($bf[1], $bf[1]);
-@{$bits{symlink}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{syscall}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{sysopen}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{sysread}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{sysseek}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{system}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{syswrite}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{tell}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{symlink}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{syscall}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{sysopen}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{sysread}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{sysseek}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{system}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{syswrite}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{tell}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{telldir}{0} = $bf[0];
-@{$bits{tie}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{tie}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{tied}{0} = $bf[0];
-@{$bits{truncate}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{truncate}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{uc}{0} = $bf[0];
$bits{ucfirst}{0} = $bf[0];
-@{$bits{umask}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{umask}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{undef}{0} = $bf[0];
-@{$bits{unlink}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{unpack}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{unshift}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{unlink}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{unpack}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{unshift}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{untie}{0} = $bf[0];
-@{$bits{utime}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{utime}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{values}{0} = $bf[0];
@{$bits{vec}}{1,0} = ($bf[1], $bf[1]);
-@{$bits{waitpid}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
-@{$bits{warn}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{waitpid}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{warn}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{xor}}{1,0} = ($bf[1], $bf[1]);
OPpLVAL_DEFER => [qw(aelem helem multideref)],
OPpLVAL_INTRO => [qw(aelem aslice cond_expr delete enteriter entersub gvsv helem hslice list lvavref lvref lvrefslice multideref padav padhv padrange padsv pushmark refassign rv2av rv2gv rv2hv rv2sv)],
OPpLVREF_ELEM => [qw(lvref refassign)],
- OPpMAYBE_LVSUB => [qw(aassign aelem aslice av2arylen helem hslice keys kvaslice kvhslice multideref padav padhv pos rv2av rv2gv rv2hv substr vec)],
+ OPpMAYBE_LVSUB => [qw(aassign aelem akeys aslice av2arylen avhvswitch helem hslice keys kvaslice kvhslice multideref padav padhv pos rv2av rv2gv rv2hv substr vec)],
OPpMAYBE_TRUEBOOL => [qw(padhv rv2hv)],
OPpMULTIDEREF_DELETE => [qw(multideref)],
OPpOFFBYONE => [qw(caller runcv wantarray)],
functions, as they have special syntax that cannot always be translated
into a simple list (e.g., C<eof> vs C<eof()>):
-C<chdir>, C<chomp>, C<chop>, C<defined>, C<delete>, C<each>,
-C<eof>, C<exec>, C<exists>, C<keys>, C<lstat>, C<pop>, C<push>,
-C<shift>, C<splice>, C<split>, C<stat>, C<system>, C<truncate>,
-C<unlink>, C<unshift>, C<values>
+C<chdir>, C<chomp>, C<chop>, C<defined>, C<delete>, C<eof>, C<exec>,
+C<exists>, C<lstat>, C<split>, C<stat>, C<system>, C<truncate>, C<unlink>
=head1 OVERRIDING CORE FUNCTIONS
sub cp;
sub mv;
-$VERSION = '2.31';
+$VERSION = '2.32';
require Exporter;
@ISA = qw(Exporter);
revision date are propagated. If this parameter is not supplied,
it defaults to 0.
+C<rmscopy> is VMS specific and cannot be exported; it must be
+referenced by its full name, e.g.:
+
+ File::Copy::rmscopy($from, $to) or die $!;
+
Like C<copy>, C<rmscopy> returns 1 on success. If an error occurs,
it sets C<$!>, deletes the output file, and returns 0.
use strict;
our($VERSION, @ISA, @EXPORT, @EXPORT_OK);
-$VERSION = "2.02";
+$VERSION = "2.03";
require IO::File;
@ISA = qw(IO::File);
#
# Everything we're willing to export, we must first import.
#
-import IO::Handle grep { !defined(&$_) } @EXPORT, @EXPORT_OK;
+IO::Handle->import( grep { !defined(&$_) } @EXPORT, @EXPORT_OK );
#
# Some people call "FileHandle::function", so all the functions
#
sub pipe {
- my $r = new IO::Handle;
- my $w = new IO::Handle;
+ my $r = IO::Handle->new;
+ my $w = IO::Handle->new;
CORE::pipe($r, $w) or return undef;
($r, $w);
}
no warnings 'surrogate'; # surrogates can be inputs to this
use charnames ();
-our $VERSION = '0.64';
+our $VERSION = '0.65';
require Exporter;
223 # Decimal 223 in native character set
0223 # Hexadecimal 223, native (= 547 decimal)
- 0xDF # Hexadecimal DF, native (= 223 decimal
+ 0xDF # Hexadecimal DF, native (= 223 decimal)
+ '0xDF' # String form of hexadecimal (= 223 decimal)
'U+DF' # Hexadecimal DF, in Unicode's character set
(= LATIN SMALL LETTER SHARP S)
# For use below to output better messages
my ($prop, $official, $constructed, $tested_function_name) = @_;
- is($constructed, $official, "$tested_function_name('$prop')");
- diag("Comment out lines " . (__LINE__ - 1) . " through " . (__LINE__ + 1) . " in '$0' on Un*x-like systems to see just the differences. Uses the 'diff' first in your \$PATH");
- return;
+ if (! $ENV{PERL_DIFF_TOOL}) {
+
+ is($constructed, $official, "$tested_function_name('$prop')");
+
+ diag("Set environment variable PERL_DIFF_TOOL=diff_tool to see just "
+ . "the differences.");
+ return;
+ }
fail("$tested_function_name('$prop')");
close $gend || die "Can't close gend";
my $diff = File::Temp->new();
- system("diff $off $gend > $diff");
+ system("$ENV{PERL_DIFF_TOOL} $off $gend > $diff");
open my $fh, "<", $diff || die "Can't open $diff";
my @diffs = <$fh>;
use Carp;
$Carp::Internal{__PACKAGE__.""}++;
-our $VERSION = '1.34';
+our $VERSION = '1.35';
our $DEBUG;
our $VERBOSE;
our $PRETTY;
EOFUNC
my %msg;
+my $over_level = 0; # We look only at =item lines at the first =over level
{
print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
local $/ = '';
push @headers, $header if defined $header;
}
- unless ( s/=item (.*?)\s*\z//s) {
+ if ( ! s/=item (.*?)\s*\z//s || $over_level != 1) {
if ( s/=head1\sDESCRIPTION//) {
$msg{$header = 'DESCRIPTION'} = '';
elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) {
$for_item = $1;
}
- elsif( /^=back/ ) { # Stop processing body here
- undef $header;
- undef $for_item;
- $seen_body = 0;
- next;
+ elsif( /^=over\b/ ) {
+ $over_level++;
+ }
+ elsif( /^=back\b/ ) { # Stop processing body here
+ $over_level--;
+ if ($over_level == 0) {
+ undef $header;
+ undef $for_item;
+ $seen_body = 0;
+ next;
+ }
}
next;
}
chdir '..' if -d '../pod' && -d '../t';
@INC = 'lib';
require './t/test.pl';
- plan(29);
+ plan(31);
}
BEGIN {
{
# Find last warning in perldiag.pod, and last items if any
my $lw;
+ my $over_level = 0;
my $inlast;
my $item;
+ my $items_not_in_overs = 0;
open(my $f, '<', "pod/perldiag.pod")
or die "failed to open pod/perldiag.pod for reading: $!";
while (<$f>) {
- if ( /^=item\s+(.*)/) {
- $lw = $1;
- } elsif (/^=back/) {
- $inlast = 1;
+
+ # We only look for entries (=item lines) in the first level of =overs
+
+ if ( /^=over\b/) {
+ $over_level++;
+ } elsif ( /^=item\s+(.*)/) {
+ if ($over_level < 1) {
+ $items_not_in_overs++;
+ }
+ elsif ($over_level == 1) {
+ $lw = $1;
+ }
+ } elsif (/^=back\b/) {
+ $inlast = 1 if $over_level == 1;
+ $over_level--;
} elsif ($inlast) {
# Skip headings
next if /^=/;
}
close($f);
+ is($over_level, 0, "(sanity...) =over balanced with =back (off by $over_level)");
+ is($items_not_in_overs, 0, "(sanity...) all =item lines are within =over..=back blocks");
ok($item, "(sanity...) found an item to check with ($item)");
seek STDERR, 0,0;
$warning = '';
package feature;
-our $VERSION = '1.43';
+our $VERSION = '1.44';
our %feature = (
fc => 'feature_fc',
switch => 'feature_switch',
bitwise => 'feature_bitwise',
evalbytes => 'feature_evalbytes',
- postderef => 'feature_postderef',
array_base => 'feature_arybase',
signatures => 'feature_signatures',
current_sub => 'feature___SUB__',
refaliasing => 'feature_refaliasing',
- lexical_subs => 'feature_lexsubs',
postderef_qq => 'feature_postderef_qq',
unicode_eval => 'feature_unieval',
unicode_strings => 'feature_unicode',
"5.11" => [qw(array_base say state switch unicode_strings)],
"5.15" => [qw(current_sub evalbytes fc say state switch unicode_eval unicode_strings)],
"5.23" => [qw(current_sub evalbytes fc postderef_qq say state switch unicode_eval unicode_strings)],
- "all" => [qw(array_base bitwise current_sub evalbytes fc lexical_subs postderef postderef_qq refaliasing say signatures state switch unicode_eval unicode_strings)],
+ "all" => [qw(array_base bitwise current_sub evalbytes fc postderef_qq refaliasing say signatures state switch unicode_eval unicode_strings)],
"default" => [qw(array_base)],
);
$feature_bundle{"5.25"} = $feature_bundle{"5.23"};
$feature_bundle{"5.26"} = $feature_bundle{"5.23"};
$feature_bundle{"5.9.5"} = $feature_bundle{"5.10"};
+my %noops = (
+ postderef => 1,
+ lexical_subs => 1,
+);
our $hint_shift = 26;
our $hint_mask = 0x1c000000;
=head2 The 'lexical_subs' feature
-B<WARNING>: This feature is still experimental and the implementation may
-change in future versions of Perl. For this reason, Perl will
-warn when you use the feature, unless you have explicitly disabled the
-warning:
+In Perl versions prior to 5.26, this feature enabled
+declaration of subroutines via C<my sub foo>, C<state sub foo>
+and C<our sub foo> syntax. See L<perlsub/Lexical Subroutines> for details.
- no warnings "experimental::lexical_subs";
+This feature is available from Perl 5.18 onwards. From Perl 5.18 to 5.24,
+it was classed as experimental, and Perl emitted a warning for its
+usage, except when explicitly disabled:
-This enables declaration of subroutines via C<my sub foo>, C<state sub foo>
-and C<our sub foo> syntax. See L<perlsub/Lexical Subroutines> for details.
+ no warnings "experimental::lexical_subs";
-This feature is available from Perl 5.18 onwards.
+As of Perl 5.26, use of this feature no longer triggers a warning, though
+the C<experimental::lexical_subs> warning category still exists (for
+compatibility with code that disables it). In addition, this syntax is
+not only no longer experimental, but it is enabled for all Perl code,
+regardless of what feature declarations are in scope.
=head2 The 'postderef' and 'postderef_qq' features
next;
}
if (!exists $feature{$name}) {
+ if (exists $noops{$name}) {
+ next;
+ }
unknown_feature($name);
}
if ($import) {
sub report_result {
my ($Locale, $i, $pass_fail, $message) = @_;
- $message //= "";
- $message = " ($message)" if $message;
if ($pass_fail) {
push @{$Okay{$i}}, $Locale;
}
else {
+ $message //= "";
+ $message = " ($message)" if $message;
$Known_bad_locale{$i}{$Locale} = 1 if exists $known_bad_locales{$^O}
&& $Locale =~ $known_bad_locales{$^O};
$Problem{$i}{$Locale} = 1;
last;
}
}
+
+ use locale;
+
+ ++$locales_test_number;
+ $test_names{$locales_test_number}
+ = 'Skip in locales where \001 has primary sorting weight; '
+ . 'otherwise verify that \0 doesn\'t have primary sorting weight';
+ if ("a\001c" lt "ab") {
+ report_result($Locale, $locales_test_number, 1);
+ }
+ else {
+ my $ok = "ab" lt "a\0c";
+ report_result($Locale, $locales_test_number, $ok);
+ }
+
+ ++$locales_test_number;
+ $test_names{$locales_test_number}
+ = 'Verify that strings with embedded NUL collate';
+ my $ok = "a\0a\0a" lt "a\001a\001a";
+ report_result($Locale, $locales_test_number, $ok);
+
+ ++$locales_test_number;
+ $test_names{$locales_test_number}
+ = 'Verify that strings with embedded NUL and '
+ . 'extra trailing NUL collate';
+ $ok = "a\0a\0" lt "a\001a\001";
+ report_result($Locale, $locales_test_number, $ok);
+
+ ++$locales_test_number;
+ $test_names{$locales_test_number}
+ = "Skip in non-UTF-8 locales; otherwise verify that UTF8ness "
+ . "doesn't matter with collation";
+ if (! $is_utf8_locale) {
+ report_result($Locale, $locales_test_number, 1);
+ }
+ else {
+
+ # khw can't think of anything better. Start with a string that is
+ # higher than its UTF-8 representation in both EBCDIC and ASCII
+ my $string = chr utf8::unicode_to_native(0xff);
+ my $utf8_string = $string;
+ utf8::upgrade($utf8_string);
+
+ # 8 should be lt 9 in all locales (except ones that aren't
+ # ASCII-based, which might fail this)
+ $ok = ("a${string}8") lt ("a${utf8_string}9");
+ report_result($Locale, $locales_test_number, $ok);
+ }
+
+ ++$locales_test_number;
+ $test_names{$locales_test_number}
+ = "Skip in UTF-8 locales; otherwise verify that single byte "
+ . "collates before 0x100 and above";
+ if ($is_utf8_locale) {
+ report_result($Locale, $locales_test_number, 1);
+ }
+ else {
+ my $max_collating = chr 0; # Find byte that collates highest
+ for my $i (0 .. 255) {
+ my $char = chr $i;
+ $max_collating = $char if $char gt $max_collating;
+ }
+ $ok = $max_collating lt chr 0x100;
+ report_result($Locale, $locales_test_number, $ok);
+ }
+
+ ++$locales_test_number;
+ $test_names{$locales_test_number}
+ = "Skip in UTF-8 locales; otherwise verify that 0x100 and "
+ . "above collate in code point order";
+ if ($is_utf8_locale) {
+ report_result($Locale, $locales_test_number, 1);
+ }
+ else {
+ $ok = chr 0x100 lt chr 0x101;
+ report_result($Locale, $locales_test_number, $ok);
+ }
}
my $ok1;
#include "reentr.h"
+/* If the environment says to, we can output debugging information during
+ * initialization. This is done before option parsing, and before any thread
+ * creation, so can be a file-level static */
+#ifdef DEBUGGING
+# ifdef PERL_GLOBAL_STRUCT
+ /* no global syms allowed */
+# define debug_initialization 0
+# define DEBUG_INITIALIZATION_set(v)
+# else
+static bool debug_initialization = FALSE;
+# define DEBUG_INITIALIZATION_set(v) (debug_initialization = v)
+# endif
+#endif
+
#ifdef USE_LOCALE
/*
else
PL_numeric_radix_sv = NULL;
- DEBUG_L(PerlIO_printf(Perl_debug_log, "Locale radix is '%s', ?UTF-8=%d\n",
+#ifdef DEBUGGING
+ if (DEBUG_L_TEST || debug_initialization) {
+ PerlIO_printf(Perl_debug_log, "Locale radix is '%s', ?UTF-8=%d\n",
(PL_numeric_radix_sv)
? SvPVX(PL_numeric_radix_sv)
: "NULL",
(PL_numeric_radix_sv)
? cBOOL(SvUTF8(PL_numeric_radix_sv))
- : 0));
+ : 0);
+ }
+#endif
# endif /* HAS_LOCALECONV */
#endif /* USE_LOCALE_NUMERIC */
PL_numeric_standard = TRUE;
PL_numeric_local = isNAME_C_OR_POSIX(PL_numeric_name);
set_numeric_radix();
- DEBUG_L(PerlIO_printf(Perl_debug_log,
- "Underlying LC_NUMERIC locale now is C\n"));
+#ifdef DEBUGGING
+ if (DEBUG_L_TEST || debug_initialization) {
+ PerlIO_printf(Perl_debug_log,
+ "Underlying LC_NUMERIC locale now is C\n");
+ }
+#endif
#endif /* USE_LOCALE_NUMERIC */
}
PL_numeric_standard = isNAME_C_OR_POSIX(PL_numeric_name);
PL_numeric_local = TRUE;
set_numeric_radix();
- DEBUG_L(PerlIO_printf(Perl_debug_log,
+#ifdef DEBUGGING
+ if (DEBUG_L_TEST || debug_initialization) {
+ PerlIO_printf(Perl_debug_log,
"Underlying LC_NUMERIC locale now is %s\n",
- PL_numeric_name));
+ PL_numeric_name);
+ }
+#endif
#endif /* USE_LOCALE_NUMERIC */
}
PL_collation_name = NULL;
}
PL_collation_standard = TRUE;
+ is_standard_collation:
PL_collxfrm_base = 0;
PL_collxfrm_mult = 2;
+ PL_in_utf8_COLLATE_locale = FALSE;
+ *PL_strxfrm_min_char = '\0';
+ PL_strxfrm_max_cp = 0;
return;
}
Safefree(PL_collation_name);
PL_collation_name = stdize_locale(savepv(newcoll));
PL_collation_standard = isNAME_C_OR_POSIX(newcoll);
+ if (PL_collation_standard) {
+ goto is_standard_collation;
+ }
+
+ PL_in_utf8_COLLATE_locale = _is_cur_LC_category_utf8(LC_COLLATE);
+ *PL_strxfrm_min_char = '\0';
+ PL_strxfrm_max_cp = 0;
+
+ /* 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 transformed 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 effect that strcmp() will look at the secondary
+ * or tertiary weights only if the strings compare equal at all higher
+ * priority weights. The spaces shown here, like in
+ * "A¹B¹C¹ * A²B²C² "
+ * are not just for readability. In the general case, these must
+ * actually be bytes, which we will call here 'separator weights'; and
+ * they must be smaller than any other weight value, but since these
+ * are C strings, only the terminating one can be a NUL (some
+ * implementations may include a non-NUL separator weight just before
+ * the NUL). Implementations tend to reserve 01 for the separator
+ * weights. They are needed so that a shorter string's secondary
+ * weights won't be misconstrued as primary weights of a longer string,
+ * etc. By making them smaller than any other weight, the shorter
+ * string will sort first. (Actually, if all secondary weights are
+ * smaller than all primary ones, there is no need for a separator
+ * weight between those two levels, etc.)
+ *
+ * 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. When we call strxfrm() we have to
+ * allocate some memory to hold the transformed string. The
+ * calculations below try to find coefficients 'm' and 'b' for this
+ * locale 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. */
{
- /* 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)
- char xbuf[XFRMBUFSIZE];
- const Size_t fa = strxfrm(xbuf, "a", XFRMBUFSIZE);
- const Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE);
- const SSize_t mult = fb - fa;
- if (mult < 1 && !(fa == 0 && fb == 0))
- Perl_croak(aTHX_ "panic: strxfrm() gets absurd - a => %"UVuf", ab => %"UVuf,
- (UV) fa, (UV) fb);
- PL_collxfrm_base = (fa > (Size_t)mult) ? (fa - mult) : 0;
- PL_collxfrm_mult = mult;
+ /* We use the string below to find how long the tranformation of it
+ * is. Almost all locales are supersets of ASCII, or at least the
+ * ASCII letters. We use all of them, half upper half lower,
+ * because if we used fewer, we might hit just the ones that are
+ * outliers in a particular locale. Most of the strings being
+ * collated will contain a preponderance of letters, and even if
+ * they are above-ASCII, they are likely to have the same number of
+ * weight levels as the ASCII ones. It turns out that digits tend
+ * to have fewer levels, and some punctuation has more, but those
+ * are relatively sparse in text, and khw believes this gives a
+ * reasonable result, but it could be changed if experience so
+ * dictates. */
+ const char longer[] = "ABCDEFGHIJKLMnopqrstuvwxyz";
+ char * x_longer; /* Transformed 'longer' */
+ Size_t x_len_longer; /* Length of 'x_longer' */
+
+ char * x_shorter; /* We also transform a substring of 'longer' */
+ Size_t x_len_shorter;
+
+ /* _mem_collxfrm() is used get the transformation (though here we
+ * are interested only in its length). It is used because it has
+ * the intelligence to handle all cases, but to work, it needs some
+ * values of 'm' and 'b' to get it started. For the purposes of
+ * this calculation we use a very conservative estimate of 'm' and
+ * 'b'. This assumes a weight can be multiple bytes, enough to
+ * hold any UV on the platform, and there are 5 levels, 4 weight
+ * bytes, and a trailing NUL. */
+ PL_collxfrm_base = 5;
+ PL_collxfrm_mult = 5 * sizeof(UV);
+
+ /* Find out how long the transformation really is */
+ x_longer = _mem_collxfrm(longer,
+ sizeof(longer) - 1,
+ &x_len_longer,
+
+ /* We avoid converting to UTF-8 in the
+ * called function by telling it the
+ * string is in UTF-8 if the locale is a
+ * UTF-8 one. Since the string passed
+ * here is invariant under UTF-8, we can
+ * claim it's UTF-8 even though it isn't.
+ * */
+ PL_in_utf8_COLLATE_locale);
+ Safefree(x_longer);
+
+ /* Find out how long the transformation of a substring of 'longer'
+ * is. Together the lengths of these transformations are
+ * sufficient to calculate 'm' and 'b'. The substring is all of
+ * 'longer' except the first character. This minimizes the chances
+ * of being swayed by outliers */
+ x_shorter = _mem_collxfrm(longer + 1,
+ sizeof(longer) - 2,
+ &x_len_shorter,
+ PL_in_utf8_COLLATE_locale);
+ Safefree(x_shorter);
+
+ /* If the results are nonsensical for this simple test, the whole
+ * locale definition is suspect. Mark it so that locale collation
+ * is not active at all for it. XXX Should we warn? */
+ if ( x_len_shorter == 0
+ || x_len_longer == 0
+ || x_len_shorter >= x_len_longer)
+ {
+ PL_collxfrm_mult = 0;
+ PL_collxfrm_base = 0;
+ }
+ else {
+ SSize_t base; /* Temporary */
+
+ /* We have both: m * strlen(longer) + b = x_len_longer
+ * m * strlen(shorter) + b = x_len_shorter;
+ * subtracting yields:
+ * m * (strlen(longer) - strlen(shorter))
+ * = x_len_longer - x_len_shorter
+ * But we have set things up so that 'shorter' is 1 byte smaller
+ * than 'longer'. Hence:
+ * m = x_len_longer - x_len_shorter
+ *
+ * But if something went wrong, make sure the multiplier is at
+ * least 1.
+ */
+ if (x_len_longer > x_len_shorter) {
+ PL_collxfrm_mult = (STRLEN) x_len_longer - x_len_shorter;
+ }
+ else {
+ PL_collxfrm_mult = 1;
+ }
+
+ /* mx + b = len
+ * so: b = len - mx
+ * but in case something has gone wrong, make sure it is
+ * non-negative */
+ base = x_len_longer - PL_collxfrm_mult * (sizeof(longer) - 1);
+ if (base < 0) {
+ base = 0;
+ }
+
+ /* Add 1 for the trailing NUL */
+ PL_collxfrm_base = base + 1;
+ }
+
+#ifdef DEBUGGING
+ if (DEBUG_L_TEST || debug_initialization) {
+ PerlIO_printf(Perl_debug_log,
+ "%s:%d: ?UTF-8 locale=%d; x_len_shorter=%"UVuf", "
+ "x_len_longer=%"UVuf","
+ " collate multipler=%"UVuf", collate base=%"UVuf"\n",
+ __FILE__, __LINE__,
+ PL_in_utf8_COLLATE_locale,
+ x_len_shorter, x_len_longer,
+ PL_collxfrm_mult, PL_collxfrm_base);
+ }
+#endif
}
}
const char * const setlocale_init = (PerlEnv_getenv("PERL_SKIP_LOCALE_INIT"))
? NULL
: "";
-#ifdef DEBUGGING
- const bool debug = (PerlEnv_getenv("PERL_DEBUG_LOCALE_INIT"))
- ? TRUE
- : FALSE;
-# define DEBUG_LOCALE_INIT(category, locale, result) \
- STMT_START { \
- if (debug) { \
- PerlIO_printf(Perl_debug_log, \
- "%s:%d: %s\n", \
- __FILE__, __LINE__, \
- _setlocale_debug_string(category, \
- locale, \
- result)); \
- } \
- } STMT_END
-#else
-# define DEBUG_LOCALE_INIT(a,b,c)
-#endif
const char* trial_locales[5]; /* 5 = 1 each for "", LC_ALL, LANG, "", C */
unsigned int trial_locales_count;
const char * const lc_all = savepv(PerlEnv_getenv("LC_ALL"));
const char *system_default_locale = NULL;
#endif
+#ifdef DEBUGGING
+ DEBUG_INITIALIZATION_set((PerlEnv_getenv("PERL_DEBUG_LOCALE_INIT"))
+ ? TRUE
+ : FALSE);
+# define DEBUG_LOCALE_INIT(category, locale, result) \
+ STMT_START { \
+ if (debug_initialization) { \
+ PerlIO_printf(Perl_debug_log, \
+ "%s:%d: %s\n", \
+ __FILE__, __LINE__, \
+ _setlocale_debug_string(category, \
+ locale, \
+ result)); \
+ } \
+ } STMT_END
+#else
+# define DEBUG_LOCALE_INIT(a,b,c)
+#endif
+
#ifndef LOCALE_ENVIRON_REQUIRED
PERL_UNUSED_VAR(done);
PERL_UNUSED_VAR(locale_param);
PERL_UNUSED_ARG(printwarn);
#endif /* USE_LOCALE */
+#ifdef DEBUGGING
+ /* So won't continue to output stuff */
+ DEBUG_INITIALIZATION_set(FALSE);
+#endif
+
return ok;
}
-
#ifdef USE_LOCALE_COLLATE
-/*
- * mem_collxfrm() is a bit like strxfrm() but with two important
- * 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.
- */
-
char *
-Perl_mem_collxfrm(pTHX_ const char *s, STRLEN len, STRLEN *xlen)
+Perl__mem_collxfrm(pTHX_ const char *input_string,
+ STRLEN len, /* Length of 'input_string' */
+ STRLEN *xlen, /* Set to length of returned string
+ (not including the collation index
+ prefix) */
+ bool utf8 /* Is the input in UTF-8? */
+ )
{
- char *xbuf;
- STRLEN xAlloc, xin, xout; /* xalloc is a reserved word in VC */
- PERL_ARGS_ASSERT_MEM_COLLXFRM;
+ /* _mem_collxfrm() is a bit like strxfrm() but with two important
+ * 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 COLLXFRM_HDR_LEN. *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. */
+
+#define COLLXFRM_HDR_LEN sizeof(PL_collation_ix)
+
+ char * s = (char *) input_string;
+ STRLEN s_strlen = strlen(input_string);
+ char *xbuf = NULL;
+ STRLEN xAlloc; /* xalloc is a reserved word in VC */
+ STRLEN length_in_chars;
+ bool first_time = TRUE; /* Cleared after first loop iteration */
+
+ PERL_ARGS_ASSERT__MEM_COLLXFRM;
+
+ /* Must be NUL-terminated */
+ assert(*(input_string + len) == '\0');
+
+ /* If this locale has defective collation, skip */
+ if (PL_collxfrm_base == 0 && PL_collxfrm_mult == 0) {
+ goto bad;
+ }
+
+ /* Replace any embedded NULs with the control that sorts before any others.
+ * This will give as good as possible results on strings that don't
+ * otherwise contain that character, but otherwise there may be
+ * less-than-perfect results with that character and NUL. This is
+ * unavoidable unless we replace strxfrm with our own implementation.
+ *
+ * XXX This code may be overkill. khw wrote it before realizing that if
+ * you change a NUL into some other character, that that may change the
+ * strxfrm results if that character is part of a sequence with other
+ * characters for weight calculations. To minimize the chances of this,
+ * now the replacement is restricted to another control (likely to be
+ * \001). But the full generality has been retained.
+ *
+ * This is one of the few places in the perl core, where we can use
+ * standard functions like strlen() and strcat(). It's because we're
+ * looking for NULs. */
+ if (s_strlen < len) {
+ char * e = s + len;
+ char * sans_nuls;
+ STRLEN cur_min_char_len;
+
+ /* If we don't know what control character sorts lowest for this
+ * locale, find it */
+ if (*PL_strxfrm_min_char == '\0') {
+ int j;
+#ifdef DEBUGGING
+ U8 cur_min_cp = 1; /* The code point that sorts lowest, so far */
+#endif
+ char * cur_min_x = NULL; /* And its xfrm, (except it also
+ includes the collation index
+ prefixed. */
+
+ /* Look through all legal code points (NUL isn't) */
+ for (j = 1; j < 256; j++) {
+ char * x; /* j's xfrm plus collation index */
+ STRLEN x_len; /* length of 'x' */
+ STRLEN trial_len = 1;
+
+ /* Create a 1 byte string of the current code point, but with
+ * room to be 2 bytes */
+ char cur_source[] = { (char) j, '\0' , '\0' };
+
+ if (PL_in_utf8_COLLATE_locale) {
+ if (! isCNTRL_L1(j)) {
+ continue;
+ }
+
+ /* If needs to be 2 bytes, find them */
+ if (! UVCHR_IS_INVARIANT(j)) {
+ char * d = cur_source;
+ append_utf8_from_native_byte((U8) j, (U8 **) &d);
+ trial_len = 2;
+ }
+ }
+ else if (! isCNTRL_LC(j)) {
+ continue;
+ }
+
+ /* Then transform it */
+ x = _mem_collxfrm(cur_source, trial_len, &x_len,
+ PL_in_utf8_COLLATE_locale);
+
+ /* If something went wrong (which it shouldn't), just
+ * ignore this code point */
+ if ( x_len == 0
+ || strlen(x + COLLXFRM_HDR_LEN) < x_len)
+ {
+ continue;
+ }
+
+ /* If this character's transformation is lower than
+ * the current lowest, this one becomes the lowest */
+ if ( cur_min_x == NULL
+ || strLT(x + COLLXFRM_HDR_LEN,
+ cur_min_x + COLLXFRM_HDR_LEN))
+ {
+ PL_strxfrm_min_char[0] = cur_source[0];
+ PL_strxfrm_min_char[1] = cur_source[1];
+ PL_strxfrm_min_char[2] = cur_source[2];
+ cur_min_x = x;
+#ifdef DEBUGGING
+ cur_min_cp = j;
+#endif
+ }
+ else {
+ Safefree(x);
+ }
+ } /* end of loop through all bytes */
+
+ /* Unlikely, but possible, if there aren't any controls in the
+ * locale, arbitrarily use \001 */
+ if (cur_min_x == NULL) {
+ STRLEN x_len; /* temporary */
+ cur_min_x = _mem_collxfrm("\001", 1, &x_len,
+ PL_in_utf8_COLLATE_locale);
+ /* cur_min_cp was already initialized to 1 */
+ }
+
+ DEBUG_L(PerlIO_printf(Perl_debug_log,
+ "_mem_collxfrm: lowest collating control in the 0-255 "
+ "range in locale %s is 0x%02X\n",
+ PL_collation_name,
+ cur_min_cp));
+ if (DEBUG_Lv_TEST) {
+ unsigned i;
+ PerlIO_printf(Perl_debug_log, "Its xfrm is");
+ for (i = 0; i < strlen(cur_min_x + COLLXFRM_HDR_LEN); i ++) {
+ PerlIO_printf(Perl_debug_log, " %02x",
+ (U8) *(cur_min_x + COLLXFRM_HDR_LEN + i));
+ }
+ PerlIO_printf(Perl_debug_log, "\n");
+ }
+
+ Safefree(cur_min_x);
+ }
+
+ /* The worst case length for the replaced string would be if every
+ * character in it is NUL. Multiply that by the length of each
+ * replacement, and allow for a trailing NUL */
+ cur_min_char_len = strlen(PL_strxfrm_min_char);
+ Newx(sans_nuls, (len * cur_min_char_len) + 1, char);
+ *sans_nuls = '\0';
+
+
+ /* Replace each NUL with the lowest collating control. Loop until have
+ * exhausted all the NULs */
+ while (s + s_strlen < e) {
+ strcat(sans_nuls, s);
+
+ /* Do the actual replacement */
+ strcat(sans_nuls, PL_strxfrm_min_char);
+
+ /* Move past the input NUL */
+ s += s_strlen + 1;
+ s_strlen = strlen(s);
+ }
+
+ /* And add anything that trails the final NUL */
+ strcat(sans_nuls, s);
+
+ /* Switch so below we transform this modified string */
+ s = sans_nuls;
+ len = strlen(s);
+ }
- /* the first sizeof(collationix) bytes are used by sv_collxfrm(). */
- /* the +1 is for the terminating NUL. */
+ /* Make sure the UTF8ness of the string and locale match */
+ if (utf8 != PL_in_utf8_COLLATE_locale) {
+ const char * const t = s; /* Temporary so we can later find where the
+ input was */
- xAlloc = sizeof(PL_collation_ix) + PL_collxfrm_base + (PL_collxfrm_mult * len) + 1;
+ /* Here they don't match. Change the string's to be what the locale is
+ * expecting */
+
+ if (! utf8) { /* locale is UTF-8, but input isn't; upgrade the input */
+ s = (char *) bytes_to_utf8((const U8 *) s, &len);
+ utf8 = TRUE;
+ }
+ else { /* locale is not UTF-8; but input is; downgrade the input */
+
+ s = (char *) bytes_from_utf8((const U8 *) s, &len, &utf8);
+
+ /* If the downgrade was successful we are done, but if the input
+ * contains things that require UTF-8 to represent, have to do
+ * damage control ... */
+ if (UNLIKELY(utf8)) {
+
+ /* What we do is construct a non-UTF-8 string with
+ * 1) the characters representable by a single byte converted
+ * to be so (if necessary);
+ * 2) and the rest converted to collate the same as the
+ * highest collating representable character. That makes
+ * them collate at the end. This is similar to how we
+ * handle embedded NULs, but we use the highest collating
+ * code point instead of the smallest. Like the NUL case,
+ * this isn't perfect, but is the best we can reasonably
+ * do. Every above-255 code point will sort the same as
+ * the highest-sorting 0-255 code point. If that code
+ * point can combine in a sequence with some other code
+ * points for weight calculations, us changing something to
+ * be it can adversely affect the results. But in most
+ * cases, it should work reasonably. And note that this is
+ * really an illegal situation: using code points above 255
+ * on a locale where only 0-255 are valid. If two strings
+ * sort entirely equal, then the sort order for the
+ * above-255 code points will be in code point order. */
+
+ utf8 = FALSE;
+
+ /* If we haven't calculated the code point with the maximum
+ * collating order for this locale, do so now */
+ if (! PL_strxfrm_max_cp) {
+ int j;
+
+ /* The current transformed string that collates the
+ * highest (except it also includes the prefixed collation
+ * index. */
+ char * cur_max_x = NULL;
+
+ /* Look through all legal code points (NUL isn't) */
+ for (j = 1; j < 256; j++) {
+ char * x;
+ STRLEN x_len;
+
+ /* Create a 1-char string of the current code point. */
+ char cur_source[] = { (char) j, '\0' };
+
+ /* Then transform it */
+ x = _mem_collxfrm(cur_source, 1, &x_len, FALSE);
+
+ /* If something went wrong (which it shouldn't), just
+ * ignore this code point */
+ if (x_len == 0) {
+ Safefree(x);
+ continue;
+ }
+
+ /* If this character's transformation is higher than
+ * the current highest, this one becomes the highest */
+ if ( cur_max_x == NULL
+ || strGT(x + COLLXFRM_HDR_LEN,
+ cur_max_x + COLLXFRM_HDR_LEN))
+ {
+ PL_strxfrm_max_cp = j;
+ cur_max_x = x;
+ }
+ else {
+ Safefree(x);
+ }
+ }
+
+ DEBUG_L(PerlIO_printf(Perl_debug_log,
+ "_mem_collxfrm: highest 1-byte collating character"
+ " in locale %s is 0x%02X\n",
+ PL_collation_name,
+ PL_strxfrm_max_cp));
+ if (DEBUG_Lv_TEST) {
+ unsigned i;
+ PerlIO_printf(Perl_debug_log, "Its xfrm is ");
+ for (i = 0;
+ i < strlen(cur_max_x + COLLXFRM_HDR_LEN);
+ i++)
+ {
+ PerlIO_printf(Perl_debug_log, " %02x",
+ (U8) cur_max_x[i + COLLXFRM_HDR_LEN]);
+ }
+ PerlIO_printf(Perl_debug_log, "\n");
+ }
+
+ Safefree(cur_max_x);
+ }
+
+ /* Here we know which legal code point collates the highest.
+ * We are ready to construct the non-UTF-8 string. The length
+ * will be at least 1 byte smaller than the input string
+ * (because we changed at least one 2-byte character into a
+ * single byte), but that is eaten up by the trailing NUL */
+ Newx(s, len, char);
+
+ {
+ STRLEN i;
+ STRLEN d= 0;
+
+ for (i = 0; i < len; i+= UTF8SKIP(t + i)) {
+ U8 cur_char = t[i];
+ if (UTF8_IS_INVARIANT(cur_char)) {
+ s[d++] = cur_char;
+ }
+ else if (UTF8_IS_DOWNGRADEABLE_START(cur_char)) {
+ s[d++] = EIGHT_BIT_UTF8_TO_NATIVE(cur_char, t[i+1]);
+ }
+ else { /* Replace illegal cp with highest collating
+ one */
+ s[d++] = PL_strxfrm_max_cp;
+ }
+ }
+ s[d++] = '\0';
+ Renew(s, d, char); /* Free up unused space */
+ }
+ }
+ }
+
+ /* Here, we have constructed a modified version of the input. It could
+ * be that we already had a modified copy before we did this version.
+ * If so, that copy is no longer needed */
+ if (t != input_string) {
+ Safefree(t);
+ }
+ }
+
+ length_in_chars = (utf8)
+ ? utf8_length((U8 *) s, (U8 *) s + len)
+ : len;
+
+ /* The first element in the output is the collation id, used by
+ * sv_collxfrm(); then comes the space for the transformed string. The
+ * equation should give us a good estimate as to how much is needed */
+ xAlloc = COLLXFRM_HDR_LEN
+ + PL_collxfrm_base
+ + (PL_collxfrm_mult * length_in_chars);
Newx(xbuf, xAlloc, char);
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 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 (UNLIKELY(! xbuf))
- goto bad;
- }
+ for (;;) {
+ *xlen = strxfrm(xbuf + COLLXFRM_HDR_LEN, s, xAlloc - COLLXFRM_HDR_LEN);
+
+ /* If the transformed string occupies less space than we told strxfrm()
+ * was available, it means it successfully transformed the whole
+ * string. */
+ if (*xlen < xAlloc - COLLXFRM_HDR_LEN) {
+
+ /* If the first try didn't get it, it means our prediction was low.
+ * Modify the coefficients so that we predict a larger value in any
+ * future transformations */
+ if (! first_time) {
+ STRLEN needed = *xlen + 1; /* +1 For trailing NUL */
+ STRLEN computed_guess = PL_collxfrm_base
+ + (PL_collxfrm_mult * length_in_chars);
+ const STRLEN new_m = needed / length_in_chars;
+
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log,
+ "%s: %d: initial size of %"UVuf" bytes for a length "
+ "%"UVuf" string was insufficient, %"UVuf" needed\n",
+ __FILE__, __LINE__,
+ (UV) computed_guess, (UV) length_in_chars, (UV) needed));
+
+ /* If slope increased, use it, but discard this result for
+ * length 1 strings, as we can't be sure that it's a real slope
+ * change */
+ if (length_in_chars > 1 && new_m > PL_collxfrm_mult) {
+#ifdef DEBUGGING
+ STRLEN old_m = PL_collxfrm_mult;
+ STRLEN old_b = PL_collxfrm_base;
+#endif
+ PL_collxfrm_mult = new_m;
+ PL_collxfrm_base = 1; /* +1 For trailing NUL */
+ computed_guess = PL_collxfrm_base
+ + (PL_collxfrm_mult * length_in_chars);
+ if (computed_guess < needed) {
+ PL_collxfrm_base += needed - computed_guess;
+ }
+
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log,
+ "%s: %d: slope is now %"UVuf"; was %"UVuf", base "
+ "is now %"UVuf"; was %"UVuf"\n",
+ __FILE__, __LINE__,
+ (UV) PL_collxfrm_mult, (UV) old_m,
+ (UV) PL_collxfrm_base, (UV) old_b));
+ }
+ else { /* Slope didn't change, but 'b' did */
+ const STRLEN new_b = needed
+ - computed_guess
+ + PL_collxfrm_base;
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log,
+ "%s: %d: base is now %"UVuf"; was %"UVuf"\n",
+ __FILE__, __LINE__,
+ (UV) new_b, (UV) PL_collxfrm_base));
+ PL_collxfrm_base = new_b;
+ }
+ }
+
+ break;
+ }
- xin += strlen(s + xin) + 1;
- xout += xused;
+ if (UNLIKELY(*xlen >= PERL_INT_MAX))
+ goto bad;
- /* Embedded NULs are understood but silently skipped
- * because they make no sense in locale collation. */
+ /* A well-behaved strxfrm() returns exactly how much space it needs
+ * (not including the trailing NUL) when it fails due to not enough
+ * space being provided. Assume that this is the case unless it's been
+ * proven otherwise */
+ if (LIKELY(PL_strxfrm_is_behaved) && first_time) {
+ xAlloc = *xlen + COLLXFRM_HDR_LEN + 1;
+ }
+ else { /* Here, either:
+ * 1) The strxfrm() has previously shown bad behavior; or
+ * 2) It isn't the first time through the loop, which means
+ * that the strxfrm() is now showing bad behavior, because
+ * we gave it what it said was needed in the previous
+ * iteration, and it came back saying it needed still more.
+ * (Many versions of cygwin fit this. When the buffer size
+ * isn't sufficient, they return the input size instead of
+ * how much is needed.)
+ * Increase the buffer size by a fixed percentage and try again. */
+ xAlloc += (xAlloc / 4) + 1;
+ PL_strxfrm_is_behaved = FALSE;
+
+#ifdef DEBUGGING
+ if (DEBUG_Lv_TEST || debug_initialization) {
+ PerlIO_printf(Perl_debug_log,
+ "_mem_collxfrm required more space than previously calculated"
+ " for locale %s, trying again with new guess=%d+%"UVuf"\n",
+ PL_collation_name, (int) COLLXFRM_HDR_LEN,
+ (UV) xAlloc - COLLXFRM_HDR_LEN);
+ }
+#endif
+ }
+
+ Renew(xbuf, xAlloc, char);
+ if (UNLIKELY(! xbuf))
+ goto bad;
+
+ first_time = FALSE;
+ }
+
+
+#ifdef DEBUGGING
+ if (DEBUG_Lv_TEST || debug_initialization) {
+ unsigned i;
+ PerlIO_printf(Perl_debug_log,
+ "_mem_collxfrm[%d]: returning %"UVuf" for locale %s '%s'\n",
+ PL_collation_ix, *xlen, PL_collation_name, input_string);
+ PerlIO_printf(Perl_debug_log, "Its xfrm is");
+ for (i = COLLXFRM_HDR_LEN; i < *xlen + COLLXFRM_HDR_LEN; i++) {
+ PerlIO_printf(Perl_debug_log, " %02x", (U8) xbuf[i]);
+ }
+ PerlIO_printf(Perl_debug_log, "\n");
+ }
+#endif
+
+ /* Free up unneeded space; retain ehough for trailing NUL */
+ Renew(xbuf, COLLXFRM_HDR_LEN + *xlen + 1, char);
+
+ if (s != input_string) {
+ Safefree(s);
}
- xbuf[xout] = '\0';
- *xlen = xout - sizeof(PL_collation_ix);
return xbuf;
bad:
Safefree(xbuf);
+ if (s != input_string) {
+ Safefree(s);
+ }
*xlen = 0;
+#ifdef DEBUGGING
+ if (DEBUG_Lv_TEST || debug_initialization) {
+ PerlIO_printf(Perl_debug_log, "_mem_collxfrm[%d] returning NULL\n",
+ PL_collation_ix);
+ }
+#endif
return NULL;
}
}
# This is running under miniperl, so no autodie
if ($target eq 'all') {
- local $ENV{PERL_INSTALL_QUIET} = 1;
- require ExtUtils::Install;
- ExtUtils::Install::pm_to_blib(\%pm, '../../lib/auto');
- open my $fh, '>', $pm_to_blib
- or die "Can't open '$pm_to_blib': $!";
- print $fh "$0 has handled pm_to_blib directly\n";
- close $fh
- or die "Can't close '$pm_to_blib': $!";
- if (IS_UNIX) {
- # Fake the fallback cleanup
- my $fallback
- = join '', map {s!^\.\./\.\./!!; "rm -f $_\n"} sort values %pm;
- foreach my $clean_target ('realclean', 'veryclean') {
- fallback_cleanup($return_dir, $clean_target, $fallback);
+ my $need_update = 1;
+ if (-f $pm_to_blib) {
+ # avoid touching pm_to_blib unless there's something that
+ # needs updating, see #126710
+ $need_update = 0;
+ my $test_at = -M _;
+ while (my $from = each(%pm)) {
+ if (-M $from < $test_at) {
+ ++$need_update;
+ last;
+ }
+ }
+ keys %pm; # reset iterator
+ }
+
+ if ($need_update) {
+ local $ENV{PERL_INSTALL_QUIET} = 1;
+ require ExtUtils::Install;
+ ExtUtils::Install::pm_to_blib(\%pm, '../../lib/auto');
+ open my $fh, '>', $pm_to_blib
+ or die "Can't open '$pm_to_blib': $!";
+ print $fh "$0 has handled pm_to_blib directly\n";
+ close $fh
+ or die "Can't close '$pm_to_blib': $!";
+ if (IS_UNIX) {
+ # Fake the fallback cleanup
+ my $fallback
+ = join '', map {s!^\.\./\.\./!!; "rm -f $_\n"} sort values %pm;
+ foreach my $clean_target ('realclean', 'veryclean') {
+ fallback_cleanup($return_dir, $clean_target, $fallback);
+ }
}
}
} else {
/*
* 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.
+ * versions of Perl which we cannot completely remove from the core
+ * code. There are two reasons functions should be here:
*
- * REMEMBER to update makedef.pl when adding a function to mathoms.c whose
- * name doesn't begin with "Perl_".
+ * 1) A function has been been replaced by a macro within a minor release,
+ * so XS modules compiled against an older release will expect to
+ * still be able to link against the function
+ * 2) A function Perl_foo(...) with #define foo Perl_foo(aTHX_ ...)
+ * has been replaced by a macro, e.g. #define foo(...) foo_flags(...,0)
+ * but XS code may still explicitly use the long form, i.e.
+ * Perl_foo(aTHX_ ...)
*
- * SMP - Oct. 24, 2005
+ * 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.
*
* The compilation of this file can be suppressed; see INSTALL
*
+ * Some blurb for perlapi.pod:
+
=head1 Obsolete backwards compatibility functions
+
Some of these are also deprecated. You can exclude these from
your compiled Perl by adding this option to Configure:
C<-Accflags='-DNO_MATHOMS'>
*/
#else
-/* 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.
*/
{
return sv_collxfrm_flags(sv, nxp, SV_GMAGIC);
}
+
+char *
+Perl_mem_collxfrm(pTHX_ const char *input_string, STRLEN len, STRLEN *xlen)
+{
+ /* This function is retained for compatibility in case someone outside core
+ * is using this (but it is undocumented) */
+
+ PERL_ARGS_ASSERT_MEM_COLLXFRM;
+
+ return _mem_collxfrm(input_string, len, xlen, FALSE);
+}
+
#endif
bool
* HAS_NEWLOCALE
* HAS_PRCTL
* HAS_PSEUDOFORK
+ * HAS_QUERYLOCALE
+ * HAS_STRERROR_L
* HAS_TIMEGM
* HAS_USELOCALE
* I16SIZE
Any changes made here will be lost!
*/
-/* miniperlmain.c
+/* miniperlmain.c or perlmain.c - a generated file
*
* Copyright (C) 1994, 1995, 1996, 1997, 1999, 2000, 2001, 2002, 2003,
- * 2004, 2005, 2006, 2007, by Larry Wall and others
+ * 2004, 2005, 2006, 2007, 2016 by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
/* This file contains the main() function for the perl interpreter.
* Note that miniperlmain.c contains main() for the 'miniperl' binary,
- * while perlmain.c contains main() for the 'perl' binary.
+ * while perlmain.c contains main() for the 'perl' binary. The typical
+ * difference being that the latter includes Dynaloader.
*
* Miniperl is like perl except that it does not support dynamic loading,
* and in fact is used to build the dynamic modules needed for the 'real'
* perl executable.
+ *
+ * The content of the body of this generated file is mostly contained
+ * in Miniperl.pm - edit that file if you want to change anything.
+ * miniperlmain.c is generated by running regen/miniperlmain.pl.pl, while
+ * perlmain.c is built automatically by Makefile (so the former is
+ * included in the tarball while the latter isn't).
*/
#ifdef OEMVS
# This script is designed to provide a handy summary of the configuration
# information being used to build perl. This is especially useful if you
-# are requesting help from comp.lang.perl.misc on usenet or via mail.
+# are requesting help online or via email.
# Note that the text lines /^Summary of/ .. /^\s*$/ are copied into Config.pm.
cat <<'!NO!SUBS!'
Summary of my $package (revision $revision $version_patchlevel_string) configuration:
$git_commit_id_title $git_commit_id$git_ancestor_line
Platform:
- osname=$osname, osvers=$osvers, archname=$archname
+ osname=$osname
+ osvers=$osvers
+ archname=$archname
uname='$myuname'
config_args='$config_args'
- hint=$hint, useposix=$useposix, d_sigaction=$d_sigaction
- useithreads=$useithreads, usemultiplicity=$usemultiplicity
- use64bitint=$use64bitint, use64bitall=$use64bitall, uselongdouble=$uselongdouble
- usemymalloc=$usemymalloc, bincompat5005=undef
+ hint=$hint
+ useposix=$useposix
+ d_sigaction=$d_sigaction
+ useithreads=$useithreads
+ usemultiplicity=$usemultiplicity
+ use64bitint=$use64bitint
+ use64bitall=$use64bitall
+ uselongdouble=$uselongdouble
+ usemymalloc=$usemymalloc
+ bincompat5005=undef
Compiler:
- cc='$cc', ccflags ='$ccflags',
- optimize='$optimize',
+ cc='$cc'
+ ccflags ='$ccflags'
+ optimize='$optimize'
cppflags='$cppflags'
- ccversion='$ccversion', gccversion='$gccversion', gccosandvers='$gccosandvers'
- intsize=$intsize, longsize=$longsize, ptrsize=$ptrsize, doublesize=$doublesize, byteorder=$byteorder, doublekind=$doublekind
- d_longlong=$d_longlong, longlongsize=$longlongsize, d_longdbl=$d_longdbl, longdblsize=$longdblsize, longdblkind=$longdblkind
- ivtype='$ivtype', ivsize=$ivsize, nvtype='$nvtype', nvsize=$nvsize, Off_t='$lseektype', lseeksize=$lseeksize
- alignbytes=$alignbytes, prototype=$prototype
+ ccversion='$ccversion'
+ gccversion='$gccversion'
+ gccosandvers='$gccosandvers'
+ intsize=$intsize
+ longsize=$longsize
+ ptrsize=$ptrsize
+ doublesize=$doublesize
+ byteorder=$byteorder
+ doublekind=$doublekind
+ d_longlong=$d_longlong
+ longlongsize=$longlongsize
+ d_longdbl=$d_longdbl
+ longdblsize=$longdblsize
+ longdblkind=$longdblkind
+ ivtype='$ivtype'
+ ivsize=$ivsize
+ nvtype='$nvtype'
+ nvsize=$nvsize
+ Off_t='$lseektype'
+ lseeksize=$lseeksize
+ alignbytes=$alignbytes
+ prototype=$prototype
Linker and Libraries:
- ld='$ld', ldflags ='$ldflags'
+ ld='$ld'
+ ldflags ='$ldflags'
libpth=$libpth
libs=$libs
perllibs=$perllibs
- libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl
+ libc=$libc
+ so=$so
+ useshrplib=$useshrplib
+ libperl=$libperl
gnulibc_version='$gnulibc_version'
Dynamic Linking:
- dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags'
- cccdlflags='$cccdlflags', lddlflags='$lddlflags'
+ dlsrc=$dlsrc
+ dlext=$dlext
+ d_dlsymun=$d_dlsymun
+ ccdlflags='$ccdlflags'
+ cccdlflags='$cccdlflags'
+ lddlflags='$lddlflags'
!NO!SUBS!
!GROK!THIS!
{
PERL_ARGS_ASSERT_SCALARBOOLEAN;
- if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
- && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
+ if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
+ !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
+ (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
+ cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
+ !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
if (ckWARN(WARN_SYNTAX)) {
const line_t oldline = CopLINE(PL_curcop);
o->op_private |= OPpLVREF_ITER;
}
+PERL_STATIC_INLINE bool
+S_potential_mod_type(I32 type)
+{
+ /* Types that only potentially result in modification. */
+ return type == OP_GREPSTART || type == OP_ENTERSUB
+ || type == OP_REFGEN || type == OP_LEAVESUBLV;
+}
+
OP *
Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
{
else { /* lvalue subroutine call */
o->op_private |= OPpLVAL_INTRO;
PL_modcount = RETURN_UNLIMITED_NUMBER;
- if (type == OP_GREPSTART || type == OP_ENTERSUB
- || type == OP_REFGEN || type == OP_LEAVESUBLV) {
- /* Potential lvalue context: */
+ if (S_potential_mod_type(type)) {
o->op_private |= OPpENTERSUB_INARGS;
break;
}
nomod:
if (flags & OP_LVALUE_NO_CROAK) return NULL;
/* grep, foreach, subcalls, refgen */
- if (type == OP_GREPSTART || type == OP_ENTERSUB
- || type == OP_REFGEN || type == OP_LEAVESUBLV)
+ if (S_potential_mod_type(type))
break;
yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
break;
case OP_KVHSLICE:
case OP_KVASLICE:
+ case OP_AKEYS:
if (type == OP_LEAVESUBLV)
o->op_private |= OPpMAYBE_LVSUB;
goto nomod;
+ case OP_AVHVSWITCH:
+ if (type == OP_LEAVESUBLV
+ && (o->op_private & 3) + OP_EACH == OP_KEYS)
+ o->op_private |= OPpMAYBE_LVSUB;
+ goto nomod;
case OP_AV2ARYLEN:
PL_hints |= HINT_BLOCK_SCOPE;
if (type == OP_LEAVESUBLV)
break;
case OP_KEYS:
- if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
+ if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
goto nomod;
goto lvalue_func;
case OP_SUBSTR:
lvalue_func:
if (type == OP_LEAVESUBLV)
o->op_private |= OPpMAYBE_LVSUB;
- if (o->op_flags & OPf_KIDS)
- op_lvalue(OpSIBLING(cBINOPo->op_first), type);
+ if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
+ /* substr and vec */
+ /* If this op is in merely potential (non-fatal) modifiable
+ context, then apply OP_ENTERSUB context to
+ the kid op (to avoid croaking). Other-
+ wise pass this op’s own type so the correct op is mentioned
+ in error messages. */
+ op_lvalue(OpSIBLING(cBINOPo->op_first),
+ S_potential_mod_type(type)
+ ? OP_ENTERSUB
+ : o->op_type);
+ }
break;
case OP_AELEM:
case OP_BIT_AND:
case OP_BIT_XOR:
case OP_BIT_OR:
+ case OP_NBIT_AND:
+ case OP_NBIT_XOR:
+ case OP_NBIT_OR:
+ case OP_SBIT_AND:
+ case OP_SBIT_XOR:
+ case OP_SBIT_OR:
case OP_CONCAT:
case OP_SUBST:
case OP_TRANS:
case OP_ANDASSIGN:
case OP_ORASSIGN:
case OP_DORASSIGN:
+ case OP_VEC:
+ case OP_SUBSTR:
return TRUE;
default:
return FALSE;
return o;
} else if (type == OP_RV2SV || /* "our" declaration */
type == OP_RV2AV ||
- type == OP_RV2HV) { /* XXX does this let anything illegal in? */
+ type == OP_RV2HV) {
if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
S_cant_declare(aTHX_ o);
} else if (attrs) {
)
goto bad;
default:
- yyerror_pv(Perl_form(aTHX_
+ qerror(Perl_mess(aTHX_
"Experimental %s on scalar is now forbidden",
- PL_op_desc[orig_type]), 0);
+ PL_op_desc[orig_type]));
bad:
bad_type_pv(1, "hash or array", o, kid);
return o;
newOP(OP_CALLER,0)
)
);
+ case OP_EACH:
+ case OP_KEYS:
+ case OP_VALUES:
+ o = newUNOP(OP_AVHVSWITCH,0,argop);
+ o->op_private = opnum-OP_EACH;
+ return o;
case OP_SELECT: /* which represents OP_SSELECT as well */
if (code)
return newCONDOP(
"aslice",
"kvaslice",
"aeach",
- "akeys",
"avalues",
+ "akeys",
"each",
"values",
"keys",
"once",
"custom",
"coreargs",
+ "avhvswitch",
"runcv",
"fc",
"padcv",
"bitwise and (&)",
"bitwise xor (^)",
"bitwise or (|)",
- "numeric bitiwse and (&)",
+ "numeric bitwise and (&)",
"numeric bitwise xor (^)",
"numeric bitwise or (|)",
- "string bitiwse and (&)",
- "string bitwise xor (^)",
- "string bitwise or (|)",
+ "string bitwise and (&.)",
+ "string bitwise xor (^.)",
+ "string bitwise or (|.)",
"negation (-)",
"integer negation (-)",
"not",
"array slice",
"index/value array slice",
"each on array",
- "keys on array",
"values on array",
+ "keys on array",
"each",
"values",
"keys",
"once",
"unknown custom operator",
"CORE:: subroutine",
+ "Array/hash switch",
"__SUB__",
"fc",
"private subroutine",
Perl_pp_aslice,
Perl_pp_kvaslice,
Perl_pp_aeach,
- Perl_pp_akeys,
Perl_pp_avalues, /* implemented by Perl_pp_akeys */
+ Perl_pp_akeys,
Perl_pp_each,
Perl_pp_values, /* implemented by Perl_do_kv */
Perl_pp_keys, /* implemented by Perl_do_kv */
Perl_pp_once,
Perl_pp_custom, /* implemented by Perl_unimplemented_op */
Perl_pp_coreargs,
+ Perl_pp_avhvswitch,
Perl_pp_runcv,
Perl_pp_fc,
Perl_pp_padcv,
Perl_ck_null, /* aslice */
Perl_ck_null, /* kvaslice */
Perl_ck_each, /* aeach */
- Perl_ck_each, /* akeys */
Perl_ck_each, /* avalues */
+ Perl_ck_each, /* akeys */
Perl_ck_each, /* each */
Perl_ck_each, /* values */
Perl_ck_each, /* keys */
Perl_ck_null, /* once */
Perl_ck_null, /* custom */
Perl_ck_null, /* coreargs */
+ Perl_ck_null, /* avhvswitch */
Perl_ck_null, /* runcv */
Perl_ck_fun, /* fc */
Perl_ck_null, /* padcv */
0x00023401, /* aslice */
0x00023401, /* kvaslice */
0x00003b40, /* aeach */
- 0x00003b08, /* akeys */
0x00003b48, /* avalues */
+ 0x00003b08, /* akeys */
0x00004b40, /* each */
0x00004b48, /* values */
0x00004b08, /* keys */
0x00000300, /* once */
0x00000000, /* custom */
0x00000600, /* coreargs */
+ 0x00000108, /* avhvswitch */
0x00000004, /* runcv */
0x00009b8e, /* fc */
0x00000040, /* padcv */
EXTCONST I16 PL_op_private_bitfields[] = {
0, 8, -1,
0, 8, -1,
+ 0, -1, -1,
0, 8, -1,
0, 8, -1,
0, 8, -1,
96, /* aslice */
99, /* kvaslice */
0, /* aeach */
- 0, /* akeys */
0, /* avalues */
+ 39, /* akeys */
0, /* each */
0, /* values */
39, /* keys */
0, /* once */
-1, /* custom */
181, /* coreargs */
+ 185, /* avhvswitch */
3, /* runcv */
0, /* fc */
-1, /* padcv */
-1, /* introcv */
-1, /* clonecv */
- 185, /* padrange */
- 187, /* refassign */
- 193, /* lvref */
- 199, /* lvrefslice */
- 200, /* lvavref */
+ 187, /* padrange */
+ 189, /* refassign */
+ 195, /* lvref */
+ 201, /* lvrefslice */
+ 202, /* lvavref */
0, /* anonconst */
};
*/
EXTCONST U16 PL_op_private_bitdefs[] = {
- 0x0003, /* scalar, prototype, refgen, srefgen, ref, readline, regcmaybe, regcreset, regcomp, chop, schop, defined, undef, study, preinc, i_preinc, predec, i_predec, postinc, i_postinc, postdec, i_postdec, negate, i_negate, not, complement, ucfirst, lcfirst, uc, lc, quotemeta, aeach, akeys, avalues, each, values, pop, shift, grepstart, grepwhile, mapstart, mapwhile, range, and, or, dor, andassign, orassign, dorassign, method, method_named, method_super, method_redir, method_redir_super, entergiven, leavegiven, enterwhen, leavewhen, untie, tied, dbmclose, getsockname, getpeername, lstat, stat, readlink, readdir, telldir, rewinddir, closedir, localtime, alarm, require, dofile, entertry, ghbyname, gnbyname, gpbyname, shostent, snetent, sprotoent, sservent, gpwnam, gpwuid, ggrnam, ggrgid, lock, once, fc, anonconst */
+ 0x0003, /* scalar, prototype, refgen, srefgen, ref, readline, regcmaybe, regcreset, regcomp, chop, schop, defined, undef, study, preinc, i_preinc, predec, i_predec, postinc, i_postinc, postdec, i_postdec, negate, i_negate, not, complement, ucfirst, lcfirst, uc, lc, quotemeta, aeach, avalues, each, values, pop, shift, grepstart, grepwhile, mapstart, mapwhile, range, and, or, dor, andassign, orassign, dorassign, method, method_named, method_super, method_redir, method_redir_super, entergiven, leavegiven, enterwhen, leavewhen, untie, tied, dbmclose, getsockname, getpeername, lstat, stat, readlink, readdir, telldir, rewinddir, closedir, localtime, alarm, require, dofile, entertry, ghbyname, gnbyname, gpbyname, shostent, snetent, sprotoent, sservent, gpwnam, gpwuid, ggrnam, ggrgid, lock, once, fc, anonconst */
0x2b5c, 0x3d59, /* pushmark */
0x00bd, /* wantarray, runcv */
0x03b8, 0x17f0, 0x3e0c, 0x38c8, 0x2f25, /* const */
0x2b5c, 0x3079, /* gvsv */
0x1655, /* gv */
0x0067, /* gelem, lt, i_lt, gt, i_gt, le, i_le, ge, i_ge, eq, i_eq, ne, i_ne, ncmp, i_ncmp, slt, sgt, sle, sge, seq, sne, scmp, bit_and, bit_xor, bit_or, sbit_and, sbit_xor, sbit_or, smartmatch, lslice, xor */
- 0x2b5c, 0x3d58, 0x0257, /* padsv */
+ 0x2b5c, 0x3d58, 0x02b7, /* padsv */
0x2b5c, 0x3d58, 0x2c4c, 0x3a49, /* padav */
0x2b5c, 0x3d58, 0x0534, 0x05d0, 0x2c4c, 0x3a49, /* padhv */
0x3819, /* pushre, match, qr, subst */
- 0x2b5c, 0x19d8, 0x0256, 0x2c4c, 0x2e48, 0x3e04, 0x0003, /* rv2gv */
- 0x2b5c, 0x3078, 0x0256, 0x3e04, 0x0003, /* rv2sv */
- 0x2c4c, 0x0003, /* av2arylen, pos, keys */
+ 0x2b5c, 0x19d8, 0x02b6, 0x2c4c, 0x2e48, 0x3e04, 0x0003, /* rv2gv */
+ 0x2b5c, 0x3078, 0x02b6, 0x3e04, 0x0003, /* rv2sv */
+ 0x2c4c, 0x0003, /* av2arylen, pos, akeys, keys */
0x2dbc, 0x0e18, 0x0b74, 0x028c, 0x3fc8, 0x3e04, 0x0003, /* rv2cv */
- 0x012f, /* bless, glob, sprintf, formline, unpack, pack, join, anonlist, anonhash, splice, warn, die, reset, exit, close, pipe_op, fileno, umask, binmode, tie, dbmopen, sselect, select, getc, read, enterwrite, sysopen, sysseek, sysread, syswrite, eof, tell, seek, truncate, fcntl, ioctl, send, recv, socket, sockpair, bind, connect, listen, accept, shutdown, gsockopt, ssockopt, open_dir, seekdir, gmtime, shmget, shmctl, shmread, shmwrite, msgget, msgctl, msgsnd, msgrcv, semop, semget, semctl, ghbyaddr, gnbyaddr, gpbynumber, gsbyname, gsbyport, syscall */
+ 0x018f, /* bless, glob, sprintf, formline, unpack, pack, join, anonlist, anonhash, splice, warn, die, reset, exit, close, pipe_op, fileno, umask, binmode, tie, dbmopen, sselect, select, getc, read, enterwrite, sysopen, sysseek, sysread, syswrite, eof, tell, seek, truncate, fcntl, ioctl, send, recv, socket, sockpair, bind, connect, listen, accept, shutdown, gsockopt, ssockopt, open_dir, seekdir, gmtime, shmget, shmctl, shmread, shmwrite, msgget, msgctl, msgsnd, msgrcv, semop, semget, semctl, ghbyaddr, gnbyaddr, gpbynumber, gsbyname, gsbyport, syscall */
0x325c, 0x3178, 0x2634, 0x2570, 0x0003, /* backtick */
0x3818, 0x0003, /* substcont */
0x0f1c, 0x1f58, 0x0754, 0x3b8c, 0x22e8, 0x01e4, 0x0141, /* trans, transr */
0x4070, 0x0003, /* chomp, schomp, ncomplement, scomplement, sin, cos, exp, log, sqrt, int, hex, oct, abs, length, ord, chr, chroot, rmdir */
0x4070, 0x0067, /* pow, multiply, i_multiply, divide, i_divide, modulo, i_modulo, add, i_add, subtract, i_subtract, concat, left_shift, right_shift, nbit_and, nbit_xor, nbit_or */
0x12d8, 0x0067, /* repeat */
- 0x4070, 0x012f, /* stringify, atan2, rand, srand, index, rindex, crypt, push, unshift, flock, chdir, chown, unlink, chmod, utime, rename, link, symlink, mkdir, waitpid, system, exec, kill, getpgrp, setpgrp, getpriority, setpriority, sleep */
- 0x3570, 0x2c4c, 0x00cb, /* substr */
+ 0x4070, 0x018f, /* stringify, atan2, rand, srand, index, rindex, crypt, push, unshift, flock, chdir, chown, unlink, chmod, utime, rename, link, symlink, mkdir, waitpid, system, exec, kill, getpgrp, setpgrp, getpriority, setpriority, sleep */
+ 0x3570, 0x2c4c, 0x012b, /* substr */
0x2c4c, 0x0067, /* vec */
0x2b5c, 0x3078, 0x2c4c, 0x3a48, 0x3e04, 0x0003, /* rv2av */
- 0x01ff, /* aelemfast, aelemfast_lex */
- 0x2b5c, 0x2a58, 0x0256, 0x2c4c, 0x0067, /* aelem, helem */
+ 0x025f, /* aelemfast, aelemfast_lex */
+ 0x2b5c, 0x2a58, 0x02b6, 0x2c4c, 0x0067, /* aelem, helem */
0x2b5c, 0x2c4c, 0x3a49, /* aslice, hslice */
0x2c4d, /* kvaslice, kvhslice */
0x2b5c, 0x3998, 0x0003, /* delete */
0x26cc, 0x0003, /* reverse */
0x28f8, 0x0003, /* flip, flop */
0x2b5c, 0x0003, /* cond_expr */
- 0x2b5c, 0x0e18, 0x0256, 0x028c, 0x3fc8, 0x3e04, 0x2481, /* entersub */
+ 0x2b5c, 0x0e18, 0x02b6, 0x028c, 0x3fc8, 0x3e04, 0x2481, /* entersub */
0x33d8, 0x0003, /* leavesub, leavesublv, leavewrite, leaveeval */
- 0x00bc, 0x012f, /* caller */
+ 0x00bc, 0x018f, /* caller */
0x21f5, /* nextstate, dbstate */
0x29fc, 0x33d9, /* leave */
0x2b5c, 0x3078, 0x0e8c, 0x36e5, /* enteriter */
0x36e5, /* iter */
0x29fc, 0x0067, /* leaveloop */
0x41dc, 0x0003, /* last, next, redo, dump, goto */
- 0x325c, 0x3178, 0x2634, 0x2570, 0x012f, /* open */
+ 0x325c, 0x3178, 0x2634, 0x2570, 0x018f, /* open */
0x1b90, 0x1dec, 0x1ca8, 0x1a64, 0x0003, /* ftrread, ftrwrite, ftrexec, fteread, ftewrite, fteexec */
0x1b90, 0x1dec, 0x1ca8, 0x0003, /* ftis, ftsize, ftmtime, ftatime, ftctime, ftrowned, fteowned, ftzero, ftsock, ftchr, ftblk, ftfile, ftdir, ftpipe, ftsuid, ftsgid, ftsvtx, ftlink, fttty, fttext, ftbinary */
0x4071, /* wait, getppid, time */
0x3474, 0x0c30, 0x068c, 0x4148, 0x2104, 0x0003, /* entereval */
0x2d1c, 0x0018, 0x1144, 0x1061, /* coreargs */
- 0x2b5c, 0x019b, /* padrange */
- 0x2b5c, 0x3d58, 0x0376, 0x284c, 0x1748, 0x0067, /* refassign */
- 0x2b5c, 0x3d58, 0x0376, 0x284c, 0x1748, 0x0003, /* lvref */
+ 0x2c4c, 0x00c7, /* avhvswitch */
+ 0x2b5c, 0x01fb, /* padrange */
+ 0x2b5c, 0x3d58, 0x03d6, 0x284c, 0x1748, 0x0067, /* refassign */
+ 0x2b5c, 0x3d58, 0x03d6, 0x284c, 0x1748, 0x0003, /* lvref */
0x2b5d, /* lvrefslice */
0x2b5c, 0x3d58, 0x0003, /* lvavref */
/* ASLICE */ (OPpSLICEWARNING|OPpMAYBE_LVSUB|OPpLVAL_INTRO),
/* KVASLICE */ (OPpMAYBE_LVSUB),
/* AEACH */ (OPpARG1_MASK),
- /* AKEYS */ (OPpARG1_MASK),
/* AVALUES */ (OPpARG1_MASK),
+ /* AKEYS */ (OPpARG1_MASK|OPpMAYBE_LVSUB),
/* EACH */ (OPpARG1_MASK),
/* VALUES */ (OPpARG1_MASK),
/* KEYS */ (OPpARG1_MASK|OPpMAYBE_LVSUB),
/* ONCE */ (OPpARG1_MASK),
/* CUSTOM */ (0xff),
/* COREARGS */ (OPpCOREARGS_DEREF1|OPpCOREARGS_DEREF2|OPpCOREARGS_SCALARMOD|OPpCOREARGS_PUSHMARK),
+ /* AVHVSWITCH */ (3|OPpMAYBE_LVSUB),
/* RUNCV */ (OPpOFFBYONE),
/* FC */ (OPpARG1_MASK),
/* PADCV */ (0),
OP_ASLICE = 139,
OP_KVASLICE = 140,
OP_AEACH = 141,
- OP_AKEYS = 142,
- OP_AVALUES = 143,
+ OP_AVALUES = 142,
+ OP_AKEYS = 143,
OP_EACH = 144,
OP_VALUES = 145,
OP_KEYS = 146,
OP_ONCE = 379,
OP_CUSTOM = 380,
OP_COREARGS = 381,
- OP_RUNCV = 382,
- OP_FC = 383,
- OP_PADCV = 384,
- OP_INTROCV = 385,
- OP_CLONECV = 386,
- OP_PADRANGE = 387,
- OP_REFASSIGN = 388,
- OP_LVREF = 389,
- OP_LVREFSLICE = 390,
- OP_LVAVREF = 391,
- OP_ANONCONST = 392,
+ OP_AVHVSWITCH = 382,
+ OP_RUNCV = 383,
+ OP_FC = 384,
+ OP_PADCV = 385,
+ OP_INTROCV = 386,
+ OP_CLONECV = 387,
+ OP_PADRANGE = 388,
+ OP_REFASSIGN = 389,
+ OP_LVREF = 390,
+ OP_LVREFSLICE = 391,
+ OP_LVAVREF = 392,
+ OP_ANONCONST = 393,
OP_max
} opcode;
-#define MAXO 393
+#define MAXO 394
#define OP_FREED MAXO
/* the OP_IS_* macros are optimized to a simple range check because
#define PERL_REVISION 5 /* age */
#define PERL_VERSION 25 /* epoch */
-#define PERL_SUBVERSION 1 /* generation */
+#define PERL_SUBVERSION 2 /* 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 1
+#define PERL_API_SUBVERSION 2
/*
XXX Note: The selection of non-default Configure options, such
as -Duselonglong may invalidate these settings. Currently, Configure
* and destroy a perl interpreter, plus the functions used by XS code to
* call back into perl. Note that it does not contain the actual main()
* function of the interpreter; that can be found in perlmain.c
+ *
+ * Note that at build time this file is also linked to as perlmini.c,
+ * and perlmini.o is then built with PERL_IS_MINIPERL defined, which is
+ * then used to create the miniperl executable, rather than perl.o.
*/
#if defined(PERL_IS_MINIPERL) && !defined(USE_SITECUSTOMIZE)
" M trace smart match resolution\n"
" B dump suBroutine definitions, including special Blocks like BEGIN\n",
" L trace some locale setting information--for Perl core development\n",
+ " i trace PerlIO layer processing\n",
NULL
};
UV uv = 0;
if (isALPHA(**s)) {
/* if adding extra options, remember to update DEBUG_MASK */
- static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBL";
+ static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBLi";
for (; isWORDCHAR(**s); (*s)++) {
const char * const d = strchr(debopts,**s);
#define DEBUG_M_FLAG 0x01000000 /*16777216*/
#define DEBUG_B_FLAG 0x02000000 /*33554432*/
#define DEBUG_L_FLAG 0x04000000 /*67108864*/
-#define DEBUG_MASK 0x07FFEFFF /* mask of all the standard flags */
+#define DEBUG_i_FLAG 0x08000000 /*134217728*/
+#define DEBUG_MASK 0x0FFFEFFF /* mask of all the standard flags */
#define DEBUG_DB_RECURSE_FLAG 0x40000000
#define DEBUG_TOP_FLAG 0x80000000 /* -D was given --> PL_debug |= FLAG */
# define DEBUG_M_TEST_ (PL_debug & DEBUG_M_FLAG)
# define DEBUG_B_TEST_ (PL_debug & DEBUG_B_FLAG)
# define DEBUG_L_TEST_ (PL_debug & DEBUG_L_FLAG)
+# define DEBUG_i_TEST_ (PL_debug & DEBUG_i_FLAG)
# define DEBUG_Xv_TEST_ (DEBUG_X_TEST_ && DEBUG_v_TEST_)
# define DEBUG_Uv_TEST_ (DEBUG_U_TEST_ && DEBUG_v_TEST_)
# define DEBUG_Pv_TEST_ (DEBUG_P_TEST_ && DEBUG_v_TEST_)
# define DEBUG_M_TEST DEBUG_M_TEST_
# define DEBUG_B_TEST DEBUG_B_TEST_
# define DEBUG_L_TEST DEBUG_L_TEST_
+# define DEBUG_i_TEST DEBUG_i_TEST_
# define DEBUG_Xv_TEST DEBUG_Xv_TEST_
# define DEBUG_Uv_TEST DEBUG_Uv_TEST_
# define DEBUG_Pv_TEST DEBUG_Pv_TEST_
# define DEBUG_M(a) DEBUG__(DEBUG_M_TEST, a)
# define DEBUG_B(a) DEBUG__(DEBUG_B_TEST, a)
# define DEBUG_L(a) DEBUG__(DEBUG_L_TEST, a)
+# define DEBUG_i(a) DEBUG__(DEBUG_i_TEST, a)
#else /* DEBUGGING */
# define DEBUG_M_TEST (0)
# define DEBUG_B_TEST (0)
# define DEBUG_L_TEST (0)
+# define DEBUG_i_TEST (0)
# define DEBUG_Xv_TEST (0)
# define DEBUG_Uv_TEST (0)
# define DEBUG_Pv_TEST (0)
# define DEBUG_M(a)
# define DEBUG_B(a)
# define DEBUG_L(a)
+# define DEBUG_i(a)
# define DEBUG_Xv(a)
# define DEBUG_Uv(a)
# define DEBUG_Pv(a)
/* These are all the compile time options that affect binary compatibility.
Other compile time options that are binary compatible are in perl.c
- Both are combined for the output of perl -V
+ (in S_Internals_V()). Both are combined for the output of perl -V
However, this string will be embedded in any shared perl library, which will
allow us add a comparison check in perlmain.c in the near future. */
#ifdef DOINIT
va_list ap;
dSYS;
va_start(ap, fmt);
+
+ if (!DEBUG_i_TEST)
+ return;
+
if (!PL_perlio_debug_fd) {
if (!TAINTING_get &&
PerlProc_getuid() == PerlProc_geteuid() &&
PL_perlio_debug_fd
= PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
else
- PL_perlio_debug_fd = -1;
+ PL_perlio_debug_fd = PerlLIO_dup(2); /* stderr */
} else {
- /* tainting or set*id, so ignore the environment, and ensure we
- skip these tests next time through. */
- PL_perlio_debug_fd = -1;
+ /* tainting or set*id, so ignore the environment and send the
+ debug output to stderr, like other -D switches. */
+ PL_perlio_debug_fd = PerlLIO_dup(2); /* stderr */
}
}
if (PL_perlio_debug_fd > 0) {
{
if (PerlIOValid(f)) {
const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
- PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param);
+ DEBUG_i( PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param) );
if (tab && tab->Dup)
return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
else {
PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
PerlIO_init_table(aTHX);
- PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto);
+ DEBUG_i( PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto) );
while ((f = *table)) {
int i;
table = (PerlIOl **) (f++);
PerlIOl **table = &PL_perlio;
PerlIOl *f;
#ifdef USE_ITHREADS
- PerlIO_debug("Destruct %p\n",(void*)aTHX);
+ DEBUG_i( PerlIO_debug("Destruct %p\n",(void*)aTHX) );
#endif
while ((f = *table)) {
int i;
const PerlIOl *l;
while ((l = *x)) {
if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) {
- PerlIO_debug("Destruct popping %s\n", l->tab->name);
+ DEBUG_i( PerlIO_debug("Destruct popping %s\n", l->tab->name) );
PerlIO_flush(x);
PerlIO_pop(aTHX_ x);
}
const PerlIOl *l = *f;
VERIFY_HEAD(f);
if (l) {
- PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f,
- l->tab ? l->tab->name : "(Null)");
+ DEBUG_i( PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f,
+ l->tab ? l->tab->name : "(Null)") );
if (l->tab && l->tab->Popped) {
/*
* If popped returns non-zero do not free its layer structure
PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
const STRLEN this_len = strlen(f->name);
if (this_len == len && memEQ(f->name, name, len)) {
- PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f);
+ DEBUG_i( PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f) );
return f;
}
}
return PerlIO_find_layer(aTHX_ name, len, 0);
}
}
- PerlIO_debug("Cannot find %.*s\n", (int) len, name);
+ DEBUG_i( PerlIO_debug("Cannot find %.*s\n", (int) len, name) );
return NULL;
}
*/
dXSARGS;
PERL_UNUSED_ARG(cv);
- if (items)
- PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0)));
+ PERL_UNUSED_VAR(items);
+ DEBUG_i(
+ if (items)
+ PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0))) );
XSRETURN(0);
}
if (!PL_known_layers)
PL_known_layers = PerlIO_list_alloc(aTHX);
PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
- PerlIO_debug("define %s %p\n", tab->name, (void*)tab);
+ DEBUG_i( PerlIO_debug("define %s %p\n", tab->name, (void*)tab) );
}
int
if (PerlIO_stdio.Set_ptrcnt)
tab = &PerlIO_stdio;
#endif
- PerlIO_debug("Pushing %s\n", tab->name);
+ DEBUG_i( PerlIO_debug("Pushing %s\n", tab->name) );
PerlIO_list_push(aTHX_ av, (PerlIO_funcs *)tab, &PL_sv_undef);
}
PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
{
if (n >= 0 && n < av->cur) {
- PerlIO_debug("Layer %" IVdf " is %s\n", n,
- av->array[n].funcs->name);
+ DEBUG_i( PerlIO_debug("Layer %" IVdf " is %s\n", n,
+ av->array[n].funcs->name) );
return av->array[n].funcs;
}
if (!def)
l->tab = (PerlIO_funcs*) tab;
l->head = ((PerlIOl*)f)->head;
*f = l;
- PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
- (void*)f, tab->name,
- (mode) ? mode : "(Null)", (void*)arg);
+ DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
+ (void*)f, tab->name,
+ (mode) ? mode : "(Null)", (void*)arg) );
if (*l->tab->Pushed &&
(*l->tab->Pushed)
(aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
}
else if (f) {
/* Pseudo-layer where push does its own stack adjust */
- PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
- (mode) ? mode : "(Null)", (void*)arg);
+ DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
+ (mode) ? mode : "(Null)", (void*)arg) );
if (tab->Pushed &&
(*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
return NULL;
}
}
if (PerlIOValid(f)) {
- PerlIO_debug(":raw f=%p :%s\n", (void*)f,
- PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)");
+ DEBUG_i( PerlIO_debug(":raw f=%p :%s\n", (void*)f,
+ PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)") );
return 0;
}
}
int
PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
{
- PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
- (PerlIOBase(f) && PerlIOBase(f)->tab) ?
- PerlIOBase(f)->tab->name : "(Null)",
- iotype, mode, (names) ? names : "(Null)");
+ PERL_UNUSED_ARG(iotype);
+ PERL_UNUSED_ARG(mode);
+
+ DEBUG_i(
+ PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
+ (PerlIOBase(f) && PerlIOBase(f)->tab) ?
+ PerlIOBase(f)->tab->name : "(Null)",
+ iotype, mode, (names) ? names : "(Null)") );
if (names) {
/* Do not flush etc. if (e.g.) switching encodings.
if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
}
- PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
- tab->name, layers ? layers : "(Null)", mode, fd,
- imode, perm, (void*)f, narg, (void*)args);
+ DEBUG_i( PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
+ tab->name, layers ? layers : "(Null)", mode, fd,
+ imode, perm, (void*)f, narg, (void*)args) );
if (tab->Open)
f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
f, narg, args);
return 0; /* If no Flush defined, silently succeed. */
}
else {
- PerlIO_debug("Cannot flush f=%p\n", (void*)f);
+ DEBUG_i( PerlIO_debug("Cannot flush f=%p\n", (void*)f) );
SETERRNO(EBADF, SS_IVCHAN);
return -1;
}
}
}
#if 0
+ DEBUG_i(
PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
(void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
l->flags, PerlIO_modestr(f, temp));
+ );
#endif
return 0;
}
SV *arg = NULL;
char buf[8];
assert(self);
- PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
- self->name,
- (void*)f, (void*)o, (void*)param);
+ DEBUG_i(PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
+ self->name,
+ (void*)f, (void*)o, (void*)param) );
if (self->Getarg)
arg = (*self->Getarg)(aTHX_ o, param, flags);
f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
PERL_UNUSED_CONTEXT;
#endif
- PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
- old_max, new_fd, new_max);
+ DEBUG_i( PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
+ old_max, new_fd, new_max) );
if (new_fd < old_max) {
return;
PL_perlio_fd_refcnt_size = new_max;
PL_perlio_fd_refcnt = new_array;
- PerlIO_debug("Zeroing %p, %d\n",
- (void*)(new_array + old_max),
- new_max - old_max);
+ DEBUG_i( PerlIO_debug("Zeroing %p, %d\n",
+ (void*)(new_array + old_max),
+ new_max - old_max) );
Zero(new_array + old_max, new_max - old_max, int);
}
Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
fd, PL_perlio_fd_refcnt[fd]);
}
- PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
- fd, PL_perlio_fd_refcnt[fd]);
+ DEBUG_i( PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
+ fd, PL_perlio_fd_refcnt[fd]) );
#ifdef USE_ITHREADS
MUTEX_UNLOCK(&PL_perlio_mutex);
{
int cnt = 0;
if (fd >= 0) {
+#ifdef DEBUGGING
+ dTHX;
+#else
dVAR;
+#endif
#ifdef USE_ITHREADS
MUTEX_LOCK(&PL_perlio_mutex);
#endif
fd, PL_perlio_fd_refcnt[fd]);
}
cnt = --PL_perlio_fd_refcnt[fd];
- PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
+ DEBUG_i( PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt) );
#ifdef USE_ITHREADS
MUTEX_UNLOCK(&PL_perlio_mutex);
#endif
{
int i;
#ifdef USE_ITHREADS
- PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
+ DEBUG_i( PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX) );
#else
- PerlIO_debug("Cleanup layers\n");
+ DEBUG_i( PerlIO_debug("Cleanup layers\n") );
#endif
/* Raise STDIN..STDERR refcount so we don't close them */
Stat_t st;
if (PerlLIO_fstat(fd, &st) == 0) {
if (!S_ISREG(st.st_mode)) {
- PerlIO_debug("%d is not regular file\n",fd);
+ DEBUG_i( PerlIO_debug("%d is not regular file\n",fd) );
PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
}
else {
- PerlIO_debug("%d _is_ a regular file\n",fd);
+ DEBUG_i( PerlIO_debug("%d _is_ a regular file\n",fd) );
}
}
#endif
PerlIOBase(f)->flags |= PERLIO_F_CRLF;
code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
#if 0
+ DEBUG_i(
PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
(void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
PerlIOBase(f)->flags);
+ );
#endif
{
/* If the old top layer is a CRLF layer, reactivate it (if
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),0); ;}
break;
case 171:
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),1); ;}
break;
case 219:
/* Generated from:
- * 703ebd267cf8ca45f9dee9bc0f4b21511117a0c1dca1c8bc9438ce91950217ae perly.y
+ * 70adb6e1be5382fb5c8cd783cd886cb4725c98a3e69c54eb16da5d7829d929aa perly.y
* 3e1dff60f26df8933d7aed0c0e87177a0f022c14800c0707eb62a7db4196ac98 regen_perly.pl
* ex: set ro: */
/* Generated from:
- * 703ebd267cf8ca45f9dee9bc0f4b21511117a0c1dca1c8bc9438ce91950217ae perly.y
+ * 70adb6e1be5382fb5c8cd783cd886cb4725c98a3e69c54eb16da5d7829d929aa perly.y
* 3e1dff60f26df8933d7aed0c0e87177a0f022c14800c0707eb62a7db4196ac98 regen_perly.pl
* ex: set ro: */
};
/* Generated from:
- * 703ebd267cf8ca45f9dee9bc0f4b21511117a0c1dca1c8bc9438ce91950217ae perly.y
+ * 70adb6e1be5382fb5c8cd783cd886cb4725c98a3e69c54eb16da5d7829d929aa perly.y
* 3e1dff60f26df8933d7aed0c0e87177a0f022c14800c0707eb62a7db4196ac98 regen_perly.pl
* ex: set ro: */
| myattrterm %prec UNIOP
{ $$ = $1; }
| LOCAL term %prec UNIOP
- { $$ = localize($2,$1); }
+ { $$ = localize($2,0); }
| '(' expr ')'
{ $$ = sawparens($2); }
| QWLIST
myattrterm: MY myterm myattrlist
{ $$ = my_attrs($2,$3); }
| MY myterm
- { $$ = localize($2,$1); }
+ { $$ = localize($2,1); }
;
/* Things that can be "my"'d */
* 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.1" /**/
-#define PRIVLIB_EXP "/sys/lib/perl/5.25.1" /**/
+#define PRIVLIB "/sys/lib/perl/5.25.2" /**/
+#define PRIVLIB_EXP "/sys/lib/perl/5.25.2" /**/
/* 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.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" /**/
+#define SITELIB "/sys/lib/perl/5.25.2/site_perl" /**/
+#define SITELIB_EXP "/sys/lib/perl/5.25.2/site_perl" /**/
+#define SITELIB_STEM "/sys/lib/perl/5.25.2/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='1'
+api_subversion='2'
api_version='25'
-api_versionstring='5.25.1'
+api_versionstring='5.25.2'
ar='ar'
-archlib='/sys/lib/perl5/5.25.1/386'
-archlibexp='/sys/lib/perl5/5.25.1/386'
+archlib='/sys/lib/perl5/5.25.2/386'
+archlibexp='/sys/lib/perl5/5.25.2/386'
archname64=''
archname='386'
archobjs=''
d_pwquota='undef'
d_qgcvt='undef'
d_quad='define'
+d_querylocale='undef'
d_random_r='undef'
d_readdir64_r='undef'
d_readdir='define'
d_strctcpy='define'
d_strerrm='strerror(e)'
d_strerror='define'
+d_strerror_l='undef'
d_strerror_r='undef'
d_strftime='define'
d_strlcat='undef'
inc_version_list_init='0'
incpath=''
inews=''
-installarchlib='/sys/lib/perl/5.25.1/386'
+installarchlib='/sys/lib/perl/5.25.2/386'
installbin='/usr/bin'
installman1dir='/sys/man/1pub'
installman3dir='/sys/man/2pub'
installprefix='/usr'
installprefixexp='/usr'
-installprivlib='/sys/lib/perl/5.25.1'
+installprivlib='/sys/lib/perl/5.25.2'
installscript='/usr/bin'
-installsitearch='/sys/lib/perl/5.25.1/site_perl/386'
+installsitearch='/sys/lib/perl/5.25.2/site_perl/386'
installsitebin='/usr/bin'
-installsitelib='/sys/lib/perl/5.25.1/site_perl'
+installsitelib='/sys/lib/perl/5.25.2/site_perl'
installstyle='lib/perl5'
installusrbinperl='undef'
installvendorarch=''
pr=''
prefix='/usr'
prefixexp='/usr'
-privlib='/sys/lib/perl/5.25.1'
-privlibexp='/sys/lib/perl/5.25.1'
+privlib='/sys/lib/perl/5.25.2'
+privlibexp='/sys/lib/perl/5.25.2'
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.1/site_perl/386'
+sitearch='/sys/lib/perl/5.25.2/site_perl/386'
sitearchexp='/sys/lib/perl/site_perl/386'
sitebin='/usr/bin'
sitebinexp='/usr/bin'
-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'
+sitelib='/sys/lib/perl/5.25.2/site_perl'
+sitelib_stem='/sys/lib/perl/5.25.2/site_perl'
+sitelibexp='/sys/lib/perl/5.25.2/site_perl'
siteprefix='/usr'
siteprefixexp='/usr'
sizesize='4'
strerror_r_proto='0'
strings='/sys/include/ape/string.h'
submit=''
-subversion='1'
+subversion='2'
sysman='/sys/man/1pub'
tail=''
tar=''
vendorlibexp=''
vendorprefix=''
vendorprefixexp=''
-version='5.25.1'
-version_patchlevel_string='version 25 subversion 1'
+version='5.25.2'
+version_patchlevel_string='version 25 subversion 2'
versiononly='undef'
vi=''
xlibpth=''
config_argc=0
PERL_REVISION=5
PERL_VERSION=25
-PERL_SUBVERSION=1
+PERL_SUBVERSION=2
PERL_API_REVISION=5
PERL_API_VERSION=25
-PERL_API_SUBVERSION=1
+PERL_API_SUBVERSION=2
PERL_PATCHLEVEL=
PERL_CONFIG_SH=true
/roffitall
# generated
-/perl5251delta.pod
+/perl5252delta.pod
/perlapi.pod
/perlintern.pod
*.html
perlhist Perl history records
perldelta Perl changes since previous version
+ perl5251delta Perl changes in version 5.25.1
perl5250delta Perl changes in version 5.25.0
perl5240delta Perl changes in version 5.24.0
perl5222delta Perl changes in version 5.22.2
If this macro is defined, running out of memory need not be a fatal
error: a memory pool can allocated by assigning to the special
-variable C<$^M>. See L<"$^M">.
+variable C<$^M>. See L</"$^M">.
=item -DPACK_MALLOC
backward compatible with existing perls and provides source compatibility
with threading is enabled.
-See L<"C Source Compatibility"> for more information.
+See L</"C Source Compatibility"> for more information.
=back
Many new warnings that were introduced in 5.004 have been made
optional. Some of these warnings are still present, but perl's new
-features make them less often a problem. See L<New Diagnostics>.
+features make them less often a problem. See L</New Diagnostics>.
=head2 Licensing
=item *
The semantics of C<use feature :5.10*> have changed slightly.
-See L<"Modules and Pragmata"> for more information.
+See L</"Modules and Pragmata"> for more information.
=item *
However, C<package NAME VERSION> requires a new, 'strict' version
-number format. See L<"Version number formats"> for details.
+number format. See L</"Version number formats"> for details.
=head2 The C<...> operator
=item *
The semantics of C<use feature :5.10*> have changed slightly.
-See L<"Modules and Pragmata"> for more information.
+See L</"Modules and Pragmata"> for more information.
=item *
--- /dev/null
+=encoding utf8
+
+=head1 NAME
+
+perl5251delta - what is new for perl v5.25.1
+
+=head1 DESCRIPTION
+
+This document describes differences between the 5.25.0 release and the 5.25.1
+release.
+
+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.
+
+=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]
+The C<POSIX::tmpnam()> interface has been removed,
+see L</"POSIX::tmpnam() has been removed">.
+Trying to import POSIX subs that have no real implementations
+(like C<POSIX::atend()>) now fails at import time, instead of
+waiting until runtime.
+
+=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.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 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.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.
+
+Many of the changes included in this version originated in the CPAN modules
+included in Perl's core. We're grateful to the entire CPAN community for
+helping Perl to flourish.
+
+For a more complete list of all of Perl's historical contributors, please see
+the F<AUTHORS> file in the Perl source distribution.
+
+=head1 Reporting Bugs
+
+If you find what you think is a bug, you might check the 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
Send us a report via perlbug if you are affected by this.)
The v1.2.3 syntax is also now legal in Perl.
-See L<Support for strings represented as a vector of ordinals> for more on that.
+See L</Support for strings represented as a vector of ordinals> for more on that.
To cope with the new versioning system's use of at least three significant
digits for each version component, the method used for incrementing the
necessary APIs and datatypes, you should be able just to go ahead and
use them, for threads by Configure -Dusethreads, and for 64 bits
either explicitly by Configure -Duse64bitint or implicitly if your
-system has 64-bit wide datatypes. See also L<"64-bit support">.
+system has 64-bit wide datatypes. See also L</"64-bit support">.
=head2 Long Doubles
=head2 -Dusemorebits
You can enable both -Duse64bitint and -Duselongdouble with -Dusemorebits.
-See also L<"64-bit support">.
+See also L</"64-bit support">.
=head2 -Duselargefiles
(typically, files larger than two gigabytes). Perl will try to use these
APIs if you ask for -Duselargefiles.
-See L<"Large file support"> for more information.
+See L</"Large file support"> for more information.
=head2 installusrbinperl
Send us a report via perlbug if you are affected by this.)
The v1.2.3 syntax is also now legal in Perl.
-See L<Support for strings represented as a vector of ordinals> for more on that.
+See L</Support for strings represented as a vector of ordinals> for more on that.
To cope with the new versioning system's use of at least three significant
digits for each version component, the method used for incrementing the
necessary APIs and datatypes, you should be able just to go ahead and
use them, for threads by Configure -Dusethreads, and for 64 bits
either explicitly by Configure -Duse64bitint or implicitly if your
-system has 64-bit wide datatypes. See also L<"64-bit support">.
+system has 64-bit wide datatypes. See also L</"64-bit support">.
=head2 Long Doubles
=head2 -Dusemorebits
You can enable both -Duse64bitint and -Duselongdouble with -Dusemorebits.
-See also L<"64-bit support">.
+See also L</"64-bit support">.
=head2 -Duselargefiles
(typically, files larger than two gigabytes). Perl will try to use these
APIs if you ask for -Duselargefiles.
-See L<"Large file support"> for more information.
+See L</"Large file support"> for more information.
=head2 installusrbinperl
enabled in 5.6.x releases may be supported in a transparent,
data-dependent fashion in a future release.
-For the new life of this switch, see L<"UTF-8 no longer default under
+For the new life of this switch, see L</"UTF-8 no longer default under
UTF-8 locales">, and L<perlrun/-C>.
=head2 (Win32) The /d Switch Of cmd.exe
The existing behaviour when localising tied arrays and hashes is wrong,
and will be changed in a future release, so do not rely on the existing
-behaviour. See L<"Localising Tied Arrays and Hashes Is Broken">.
+behaviour. See L</"Localising Tied Arrays and Hashes Is Broken">.
=back
real printf, warn() etc. would recursively call PerlIO and be a
problem.
-PerlIO_debug writes to the file named by $ENV{'PERLIO_DEBUG'} typical
+PerlIO_debug writes to the file named by $ENV{'PERLIO_DEBUG'} or defaults
+to stderr if the environment variable is not defined. Typical
use might be
Bourne shells (sh, ksh, bash, zsh, ash, ...):
- PERLIO_DEBUG=/dev/tty ./perl somescript some args
+ PERLIO_DEBUG=/tmp/perliodebug.log ./perl -Di somescript some args
Csh/Tcsh:
- setenv PERLIO_DEBUG /dev/tty
- ./perl somescript some args
+ setenv PERLIO_DEBUG /tmp/perliodebug.log
+ ./perl -Di somescript some args
If you have the "env" utility:
- env PERLIO_DEBUG=/dev/tty ./perl somescript some args
+ env PERLIO_DEBUG=/tmp/perliodebug.log ./perl -Di somescript args
Win32:
- set PERLIO_DEBUG=CON
- perl somescript some args
+ set PERLIO_DEBUG=perliodebug.log
+ perl -Di somescript some args
-If $ENV{'PERLIO_DEBUG'} is not set PerlIO_debug() is a no-op.
+On a Perl built without C<-DDEBUGGING>, or when the C<-Di> command-line switch
+is not specified, or under taint, PerlIO_debug() is a no-op.
=back
L<http://lists.perl.org>, check the particular website for that project.
Most mailing lists are archived at L<http://nntp.perl.org/>.
-There are also plenty of Perl related newsgroups located under
-C<comp.lang.perl.*>.
-
=head2 IRC
The Perl community has a rather large IRC presence. For starters, it has its
archaic C<'>); all but the last are interpreted as names of packages,
to locate the namespace in which to look up the final identifier
(see L<perlmod/Packages> for details). For a more in-depth discussion
-on identifiers, see L<Identifier parsing>. It's possible to
+on identifiers, see L</Identifier parsing>. It's possible to
substitute for a simple identifier, an expression that produces a reference
to the value at runtime. This is described in more detail below
and in L<perlref>.
See L<Dumpvalue> if you'd like to do this yourself.
The output format is governed by multiple options described under
-L<"Configurable Options">.
+L</"Configurable Options">.
If the C<maxdepth> is included, it must be a numeral I<N>; the value is
dumped only I<N> levels deep, as if the C<dumpDepth> option had been
1 only where it is safe to do so--that is, mostly for Boolean
options. It is always better to assign a specific value using C<=>.
The C<option> can be abbreviated, but for clarity probably should
-not be. Several options can be set together. See L<"Configurable Options">
+not be. Several options can be set together. See L</"Configurable Options">
for a list of these.
=item < ?
=head1 NAME
-perldelta - what is new for perl v5.25.1
+perldelta - what is new for perl v5.25.2
=head1 DESCRIPTION
-This document describes differences between the 5.25.0 release and the 5.25.1
+This document describes differences between the 5.25.1 release and the 5.25.2
release.
-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.
+If you are upgrading from an earlier release such as 5.25.0, first read
+L<perl5251delta>, which describes differences between 5.25.0 and 5.25.1.
=head1 Core Enhancements
-=head2 POSIX::tmpnam() has been removed
+=head2 Perl can now do default collation in UTF-8 locales on platforms
+that support it
-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.
+Some platforms natively do a reasonable job of collating and sorting in
+UTF-8 locales. Perl now works with those. For portability and full
+control, L<Unicode::Collate> is still recommended, but now you may
+not need to do anything special to get good-enough results, depending on
+your application. See
+L<perllocale/Category C<LC_COLLATE>: Collation: Text Comparisons and Sorting>.
-=head2 require ::Foo::Bar is now illegal.
+=head2 Better locale collation of strings containing embedded C<NUL>
+characters
-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.
+In locales that have multi-level character weights, these are now
+ignored at the higher priority ones. There are still some gotchas in
+some strings, though. See
+L<perllocale/Collation of strings containing embedded C<NUL> characters>.
-=head2 Unescaped literal C<"{"> characters in regular expression
-patterns are no longer permissible
+=head2 Lexical subroutines are no longer experimental
-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.
+Using the C<lexical_subs> feature no longer emits a warning. Existing code that disables the C<experimental::lexical_subs> warning category that the
+feature previously used will continue to work. The C<lexical_subs> feature
+has no effect; all Perl code can use lexical subroutines, regardless of
+what feature declarations are in scope.
-These have been deprecated since v5.16, with a deprecation message
-displayed starting in v5.22.
+=head2 C<CORE> subroutines for hash and array functions callable via
+reference
-=head2 Literal control character variable names are no longer permissible
+The hash and array functions in the C<CORE> namespace--C<keys>, C<each>,
+C<values>, C<push>, C<pop>, C<shift>, C<unshift> and C<splice>--, can now
+be called with ampersand syntax (C<&CORE::keys(\%hash>) and via reference
+(C<< my $k = \&CORE::keys; $k->(\%hash) >>). Previously they could only be
+used when inlined.
-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.
+=head1 Security
-=head2 C<qr//xx> is no longer permissible
+=head2 C<-Di> switch is now required for PerlIO debugging output
-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.
+Previously PerlIO debugging output would be sent to the file specified
+by the C<PERLIO_DEBUG> environment variable if perl wasn't running
+setuid and the C<-T> or C<-t> switches hadn't been parsed yet.
-=head2 C<NBSP> is no longer permissible in C<\N{...}>
+If perl performed output at a point where it hadn't yet parsed its
+switches this could result in perl creating or overwriting the file
+named by C<PERLIO_DEBUG> even when the C<-T> switch had been supplied.
-The name of a character may no longer contain non-breaking spaces. It
-has been deprecated to do so since Perl v5.22.
+Perl now requires the C<-Di> switch to produce PerlIO debugging
+output. By default this is written to C<stderr>, but can optionally
+be redirected to a file by setting the C<PERLIO_DEBUG> environment
+variable.
-=head1 Performance Enhancements
+If perl is running setuid or the C<-T> switch has supplied
+C<PERLIO_DEBUG> is ignored and the debugging output is sent to
+C<stderr> as for any other C<-D> switch.
-=over 4
+=head1 Incompatible Changes
-=item *
+=head2 C<keys> returned from an lvalue subroutine
-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.
+C<keys> returned from an lvalue subroutine can no longer be assigned
+to in list context.
-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.
+ sub foo : lvalue { keys(%INC) }
+ (foo) = 3; # death
+ sub bar : lvalue { keys(@_) }
+ (bar) = 3; # also an error
-=back
+This makes the lvalue sub case consistent with C<(keys %hash) = ...> and
+C<(keys @_) = ...>, which are also errors. [perl #128187]
=head1 Modules and Pragmata
=item *
-L<Archive::Tar> has been upgraded from version 2.04 to 2.08.
+L<CPAN> has been upgraded from version 2.11 to 2.14.
+
+=item *
+
+L<Devel::Peek> has been upgraded from version 1.23 to 1.24.
+
+=item *
+
+L<diagnostics> has been upgraded from version 1.34 to 1.35.
+
+=item *
+
+L<DynaLoader> has been upgraded from version 1.38 to 1.39.
+
+=item *
+
+L<ExtUtils::MakeMaker> has been upgraded from version 7.10_01 to 7.18.
+
+=item *
+
+L<ExtUtils::Miniperl> has been upgraded from version 1.05 to 1.06.
+
+=item *
+
+L<ExtUtils::ParseXS> has been upgraded from version 3.31 to 3.32.
=item *
-L<Carp> has been upgraded from version 1.40 to 1.41.
+L<ExtUtils::Typemaps> has been upgraded from version 3.31 to 3.32.
=item *
-L<charnames> has been upgraded from version 1.43 to 1.44.
+L<feature> 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.
+L<File::Copy> has been upgraded from version 2.31 to 2.32.
=item *
-L<DB_File> has been upgraded from version 1.835 to 1.838.
+L<File::Glob> has been upgraded from version 1.26 to 1.27.
=item *
-L<Digest::MD5> has been upgraded from version 2.54 to 2.55.
+L<File::Spec> has been upgraded from version 3.63 to 3.64.
=item *
-L<IPC::Cmd> has been upgraded from version 0.92 to 0.94.
+L<FileHandle> has been upgraded from version 2.02 to 2.03.
=item *
-L<IPC::SysV> has been upgraded from version 2.06_01 to 2.07.
+L<Getopt::Long> has been upgraded from version 2.48 to 2.49.
=item *
-L<List::Util> has been upgraded from version 1.42_02 to 1.45_01.
+L<HTTP::Tiny> has been upgraded from version 0.056 to 0.058.
=item *
-L<Locale::Codes> has been upgraded from version 3.37 to 3.38.
+L<JSON::PP> has been upgraded from version 2.27300 to 2.27400.
=item *
-L<Locale::Maketext> has been upgraded from version 1.26 to 1.27.
+L<Locale::Codes> has been upgraded from version 3.38 to 3.39.
=item *
-L<Module::CoreList> has been upgraded from version 5.20160507 to 5.20160520.
+L<Module::CoreList> has been upgraded from 5.20160520 to 5.20160620.
=item *
-L<Module::Metadata> has been upgraded from version 1.000031 to 1.000032.
+L<Opcode> has been upgraded from version 1.34 to 1.35.
=item *
-L<perlfaq> has been upgraded from version 5.021010 to 5.021011.
+L<Pod::Checker> has been upgraded from version 1.60 to 1.73.
=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">.
+L<Pod::Functions> has been upgraded from version 1.10 to 1.11.
=item *
-L<re> has been upgraded from version 0.32 to 0.33.
+L<Pod::Usage> has been upgraded from version 1.68 to 1.69.
=item *
-L<Scalar::Util> has been upgraded from version 1.42_02 to 1.45_01.
+L<POSIX> has been upgraded from version 1.69 to 1.70.
=item *
-L<Sys::Syslog> has been upgraded from version 0.33 to 0.34.
+L<Test::Simple> has been upgraded from version 1.302015 to 1.302026.
=item *
-L<Term::ANSIColor> has been upgraded from version 4.04 to 4.05.
+L<Thread::Queue> has been upgraded from version 3.09 to 3.11.
=item *
-L<Test::Simple> has been upgraded from version 1.001014 to 1.302015.
+L<threads> has been upgraded from version 2.08 to 2.09.
=item *
-L<threads> has been upgraded from version 2.07 to 2.08. Compatibility
-with 5.8 has been restored.
+L<Time::HiRes> has been upgraded from version 1.9733 to 1.9734.
=item *
-L<threads::shared> has been upgraded from version 1.51 to 1.52.
-Compatibility with 5.8 has been restored.
+L<Unicode::UCD> has been upgraded from version 0.64 to 0.65.
+
+=item *
+
+L<VMS::DCLsym> has been upgraded from version 1.06 to 1.07.
=back
=head2 Changes to Existing Documentation
+=head3 L<perlcommunity>
+
=over 4
=item *
-Fixed link to Crosby paper on hash complexity attack in L<perlsec>.
+All references to Usenet have been removed.
=back
-=head1 Diagnostics
+=head3 L<perldelta>
-=head2 New Diagnostics
+=over 4
-=head3 New Errors
+=item *
+
+All references to Usenet have been removed.
+
+=back
+
+=head3 L<perllocale>
=over 4
=item *
-L<Bareword in require contains "%s"|perldiag/"Bareword in require contains "%s"">
+Document NUL collation handling.
+
+=back
+
+=head3 L<perlmodinstall>
+
+=over 4
=item *
-L<Bareword in require maps to empty filename|perldiag/"Bareword in require maps to empty filename">
+All references to Usenet have been removed.
+
+=back
+
+=head3 L<perlmodlib>
+
+=over 4
=item *
-L<Bareword in require maps to disallowed filename "%s"|perldiag/"Bareword in require maps to disallowed filename "%s"">
+Updated the mirror list.
=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"">
+All references to Usenet have been removed.
=back
-=head2 Changes to Existing Diagnostics
+=head3 L<perlnewmod>
=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]
+All references to Usenet have been removed.
-=item *
+=back
+
+=head1 Diagnostics
+
+The following additions or changes have been made to diagnostic output,
+including warnings and fatal error messages. For the complete list of
+diagnostic messages, see L<perldiag>.
-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]
+=head2 New Diagnostics
+
+=head3 New Errors
+
+=over 4
=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.
+L<Version control conflict marker|perldiag/"Version control conflict marker">
+
+(F) The parser found a line starting with C<E<lt><<<<<<>,
+C<E<gt>E<gt>E<gt>E<gt>E<gt>E<gt>E<gt>>, or C<=======>. These may be left by a
+version control system to mark conflicts after a failed merge operation.
=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>.
+L<%s: command not found|perldiag/"%s: command not found">
+
+(A) You've accidentally run your script through B<bash> or another shell
+instead of Perl. Check the #! line, or manually feed your script into
+Perl yourself. The #! line at the top of your file could look like:
+
+ #!/usr/bin/perl
=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]
+L<%s: command not found: %s|perldiag/"%s: command not found: %s">
+
+(A) You've accidentally run your script through B<zsh> or another shell
+instead of Perl. Check the #! line, or manually feed your script into
+Perl yourself. The #! line at the top of your file could look like:
+
+ #!/usr/bin/perl
=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]
+L<Unescaped left brace in regex is deprecated here, passed through in regex; marked by S<<-- HERE> in mE<sol>%sE<sol>|perldiag/"Unescaped left brace in regex is deprecated here, passed through in regex; marked by S<<-- HERE> in m/%s/">
-=back
+Unescaped left braces are already illegal in some contexts in regular
+expression patterns, but, due to an oversight, no deprecation warning
+was raised in other contexts where they are intended to become illegal.
+This warning is now raised in these contexts.
-=head1 Utility Changes
+=back
-=head2 L<perlbug>
+=head2 Changes to Existing Diagnostics
=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]
+L<Unescaped left brace in regex is illegal here in regex; marked by S<<-- HERE> in mE<sol>%sE<sol>|perldiag/"Unescaped left brace in regex is illegal here in regex; marked by S<<-- HERE> in m/%s/">
+
+The word "here" has been added to the message that was raised in
+v5.25.1. This is to indicate that there are contexts in which unescaped
+left braces are not (yet) illegal.
=back
=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]
+F<make_ext.pl> no longer updates a module's F<pm_to_blib> file when no
+files require updates. This could cause dependencies, F<perlmain.c>
+in particular, to be rebuilt unnecessarily. [perl #126710]
=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 *
+The output of C<perl -V> has been reformatted so that each configuration
+and compile-time option is now listed one per line, to improve
+readability.
-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]
+=back
-=item *
+=head1 Testing
-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]
+=over 4
=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).
+F<t/harness> now tries really hard not to run tests outside of the Perl
+source tree. [perl #124050]
=back
=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.
+Perl no longer panics when switching into some locales on machines with
+buggy C<strxfrm()> implementations in their libc. [perl #121734]
=back
=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]
+C< until ($x = 1) { ... } > and C< ... until $x = 1 > now properly
+warn when syntax warnings are enabled. [perl #127333]
+
+=item *
+
+socket() now leaves the error code returned by the system in C<$!> on
+failure. [perl #128316]
+
+=item *
+
+Assignment variants of any bitwise ops under the C<bitwise> feature would
+crash if the left-hand side was an array or hash. [perl #128204]
+
+=item *
+
+C<require> followed by a single colon (as in C<foo() ? require : ...> is
+now parsed correctly as C<require> with implicit $_, rather than
+C<require "">. [perl #128307]
=item *
-C<reset> with an argument no longer crashes when encountering stash entries
-other than globs. [perl #128106]
+Scalar C<keys %hash> can now be assigned to consistently in all scalar
+lvalue contexts. Previously it worked for some contexts but not others.
=item *
-Assignment of hashes to, and deletion of, typeglobs named C<*::::::> no
-longer causes crashes. [perl #128086]
+List assignment to C<vec> or C<substr> with an array or hash for its first
+argument used to result in crashes or "Can't coerce" error messages at run
+time, unlike scalar assignment, which would give an error at compile time.
+List assignment now gives a compile-time error, too. [perl #128260]
=back
=head1 Acknowledgements
-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
+Perl 5.25.2 represents approximately 4 weeks of development since Perl 5.25.1
+and contains approximately 32,000 lines of changes across 430 files from 28
authors.
Excluding auto-generated files, documentation and release tools, there were
-approximately 40,000 lines of changes to 510 .pm, .t, .c and .h files.
+approximately 27,000 lines of changes to 300 .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.1:
+improvements that became Perl 5.25.2:
-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.
+Aaron Crane, Andreas König, Andy Lester, Chad Granum, Chase Whitener, Chris
+'BinGOs' Williams, Craig A. Berry, Dagfinn Ilmari Mannsåker, Dan Collins,
+David Mitchell, Dominic Hargreaves, Ed Avis, Father Chrysostomos, H.Merijn
+Brand, Ivan Pozdeev, James E Keenan, Jarkko Hietaniemi, Jerry D. Hedden, Jim
+Cromie, Karl Williamson, Lukas Mai, Matthew Horsfall, Misty De Meo, Samuel
+Thibault, Sawyer X, Sullivan Beck, 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
=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
+If you find what you think is a bug, you might check the perl bug database
+at L<https://rt.perl.org/> . There may also be information at
L<http://www.perl.org/> , the Perl Home Page.
If you believe you have an unreported bug, please run the L<perlbug> program
=item Bareword in require contains "%s"
-=item Bareword in require maps to empty filename
-
=item Bareword in require maps to disallowed filename "%s"
+=item Bareword in require maps to empty filename
(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
instead of Perl. Check the #! line, or manually feed your script into
Perl yourself. The #! line at the top of your file could look like
- #!/usr/bin/perl -w
+ #!/usr/bin/perl
+
+=item %s: command not found
+
+(A) You've accidentally run your script through B<bash> or another shell
+instead of Perl. Check the #! line, or manually feed your script into
+Perl yourself. The #! line at the top of your file could look like
+
+ #!/usr/bin/perl
+
+=item %s: command not found: %s
+
+(A) You've accidentally run your script through B<zsh> or another shell
+instead of Perl. Check the #! line, or manually feed your script into
+Perl yourself. The #! line at the top of your file could look like
+
+ #!/usr/bin/perl
=item Compilation failed in require
use feature "signatures";
sub foo ($left, $right) { ... }
-=item Experimental "%s" subs not enabled
-
-(F) To use lexical subs, you must first enable them:
-
- no warnings 'experimental::lexical_subs';
- use feature 'lexical_subs';
- my sub foo { ... }
-
=item Explicit blessing to '' (assuming package main)
(W misc) You are blessing a reference to a zero length string. This has
for I/O (in anticipation of future reads and to imitate the behavior
with real files).
+=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. This has been made illegal, in order to allow future
+extensions to the Perl language.
+
=item %s() on unopened %s
(W unopened) An I/O operation was attempted on a filehandle that was
(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.
(P) The compiler is screwed up and attempted to use an op that isn't
permitted at run time.
+=item panic: unknown OA_*: %x
+
+(P) The internal routine that handles arguments to C<&CORE::foo()>
+subroutine calls was unable to determine what type of arguments
+were expected.
+
=item panic: utf16_to_utf8: odd bytelen
(P) Something tried to call utf16_to_utf8 with an odd (as opposed
(F) The function indicated isn't implemented on this architecture,
according to the probings of Configure.
-=item The lexical_subs feature is experimental
-
-(S experimental::lexical_subs) This warning is emitted if you
-declare a sub with C<my> or C<state>. Simply suppress the warning
-if you want to use the feature, but know that in doing so you
-are taking the risk of using an experimental feature which may
-change or be removed in a future Perl version:
-
- no warnings "experimental::lexical_subs";
- use feature "lexical_subs";
- my sub foo { ... }
-
=item The regex_sets feature is experimental
(S experimental::regex_sets) This warning is emitted if you
(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 illegal in regex;
+=item Unescaped left brace in regex is deprecated here, passed through in
+regex; marked by S<<-- HERE> in m/%s/
+
+(D deprecated, regexp) The simple rule to remember, if you want to
+match a literal C<"{"> character (U+007B C<LEFT CURLY BRACKET>) in a
+regular expression pattern, is to escape each literal instance of it in
+some way. Generally easiest is to precede it with a backslash, like
+C<"\{"> or enclose it in square brackets (C<"[{]">). 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}
+
+Forcing literal C<"{"> characters to be escaped will enable the Perl
+language to be extended in various ways in future releases. To avoid
+needlessly breaking existing code, the restriction is is not enforced in
+contexts where there are unlikely to ever be extensions that could
+conflict with the use there of C<"{"> as a literal.
+
+In this release of Perl, some literal uses of C<"{"> are fatal, and some
+still just deprecated. This is because of an oversight: some uses of a
+literal C<"{"> that should have raised a deprecation warning starting in
+v5.20 did not warn until v5.26. By making the already-warned uses fatal
+now, some of the planned extensions can be made to the language sooner.
+
+The contexts where no warnings or errors are raised are:
+
+=over 4
+
+=item *
+
+as the first character in a pattern, or following C<"^"> indicating to
+anchor the match to the beginning of a line.
+
+=item *
+
+as the first character following a C<"|"> indicating alternation.
+
+=item *
+
+as the first character in a parenthesized grouping like
+
+ /foo({bar)/
+ /foo(?:{bar)/
+
+=item *
+
+as the first character following a quantifier
+
+ /\s*{/
+
+=back
+
+=for comment
+The text of the message above is duplicated below to allow splain (and
+'use diagnostics') to work. Since one is fatal, and one not, they can't
+be combined as one message. And since the non-fatal one is temporary,
+there's no real need to enhance perldiag to handle this transient case.
+
+=item Unescaped left brace in regex is illegal here in regex;
marked by S<<-- HERE> in m/%s/
-(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,
+(F) The simple rule to remember, if you want to
+match a literal C<"{"> character (U+007B C<LEFT CURLY BRACKET>) in a
+regular expression pattern, is to escape each literal instance of it in
+some way. Generally easiest is to precede it with a backslash, like
+C<"\{"> or enclose it in square brackets (C<"[{]">). 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}
+
+Forcing literal C<"{"> characters to be escaped will enable the Perl
+language to be extended in various ways in future releases. To avoid
+needlessly breaking existing code, the restriction is is not enforced in
+contexts where there are unlikely to ever be extensions that could
+conflict with the use there of C<"{"> as a literal.
+
+In this release of Perl, some literal uses of C<"{"> are fatal, and some
+still just deprecated. This is because of an oversight: some uses of a
+literal C<"{"> that should have raised a deprecation warning starting in
+v5.20 did not warn until v5.26. By making the already-warned uses fatal
+now, some of the planned extensions can be made to the language sooner.
+
+The contexts where no warnings or errors are raised are:
+
+=over 4
+
+=item *
+
+as the first character in a pattern, or following C<"^"> indicating to
+anchor the match to the beginning of a line.
+
+=item *
- qr{abc\{def\}ghi}
+as the first character following a C<"|"> indicating alternation.
-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 *
+
+as the first character in a parenthesized grouping like
+
+ /foo({bar)/
+ /foo(?:{bar)/
+
+=item *
+
+as the first character following a quantifier
+
+ /\s*{/
+
+=back
=item unexec of %s into %s failed!
came from. If you really really know what you are doing you can turn
off this warning by C<no warnings 'surrogate';>.
-=item Unknown charname '' is deprecated
-
-(D deprecated) You had a C<\N{}> with nothing between the braces. This
-usage is deprecated, and will be made a syntax error in a future Perl
-version.
-
=item Unknown charname '%s'
(F) The name you used inside C<\N{}> is unknown to Perl. Check the
also happen if the C<\N{}> is not in the scope of the corresponding
C<S<use charnames>>.
+=item Unknown charname '' is deprecated
+
+(D deprecated) You had a C<\N{}> with nothing between the braces. This
+usage is deprecated, and will be made a syntax error in a future Perl
+version.
+
=item Unknown error
(P) Perl was about to print an error message in C<$@>, but the C<$@> variable
(F) You used a verb pattern that is not allowed an argument. Remove the
argument or check that you are using the right verb.
+=item Version control conflict marker
+
+(F) The parser found a line starting with C<E<lt><<<<<<>,
+C<E<gt>E<gt>E<gt>E<gt>E<gt>E<gt>E<gt>>, or C<=======>. These may be left by a
+version control system to mark conflicts after a failed merge operation.
+
=item Version number must be a constant number
(P) The attempt to translate a C<use Module n.n LIST> statement into
Internationalization (I18N) and localization (L10N) are supported at least
in principle even on EBCDIC platforms. The details are system-dependent
-and discussed under the L<OS ISSUES> section below.
+and discussed under the L</OS ISSUES> section below.
=head1 MULTI-OCTET CHARACTER SETS
perl -MConfig -e 'print $Config{archlib}'
Here's how you'd compile the example in the next section,
-L<Adding a Perl interpreter to your C program>, on my Linux box:
+L</Adding a Perl interpreter to your C program>, on my Linux box:
% gcc -O2 -Dbool=char -DHAS_BOOL -I/usr/local/include
-I/usr/local/lib/perl5/i586-linux/5.003/CORE
strings to the C<NULL>-terminated C<args> list passed to
I<call_argv>. For other data types, or to examine return values,
you'll need to manipulate the Perl stack. That's demonstrated in
-L<Fiddling with the Perl stack from your C program>.
+L</Fiddling with the Perl stack from your C program>.
=head2 Evaluating a Perl statement from your C program
Introduced in Perl 5.11.2
-=item Lexical subroutines
-
-Introduced in Perl 5.18
-
-See also: L<perlsub/Lexical Subroutines>
-
-Using this feature triggers warnings in the category
-C<experimental::lexical_subs>.
-
-The ticket for this feature is
-L<[perl #120085]|https://rt.perl.org/rt3/Ticket/Display.html?id=120085>.
-
=item Regular Expression Set Operations
Introduced in Perl 5.18
Accepted in Perl 5.24.0
+=item Lexical subroutines
+
+Introduced in Perl 5.18.0
+
+Accepted in Perl 5.26.0
+
=back
=head2 Removed features
point is determined by the current LC_NUMERIC locale if C<use locale> is in
effect. This means that, if, for example, the run-time environment happens
to specify a German locale, "," will be used instead of the default ".". See
-L<perllocale> and L<"WARNINGS"> for more information.
+L<perllocale> and L</"WARNINGS"> for more information.
=head2 Using Fill Mode
the format.
The C<sv_set*()> functions are not generic enough to operate on values
-that have "magic". See L<Magic Virtual Tables> later in this document.
+that have "magic". See L</Magic Virtual Tables> later in this document.
All SVs that contain strings should be terminated with a C<NUL> character.
If it is not C<NUL>-terminated there is a risk of
to be interpreted as a string.
The C<sv_cat*()> functions are not generic enough to operate on values that
-have "magic". See L<Magic Virtual Tables> later in this document.
+have "magic". See L</Magic Virtual Tables> later in this document.
If you know the name of a scalar variable, you can get a pointer to its SV
by using the following:
So to repeat always use SvOK() to check whether an sv is defined.
Also you have to be careful when using C<&PL_sv_undef> as a value in
-AVs or HVs (see L<AVs, HVs and undefined values>).
+AVs or HVs (see L</AVs, HVs and undefined values>).
There are also the two values C<PL_sv_yes> and C<PL_sv_no>, which contain
boolean TRUE and FALSE values, respectively. Like C<PL_sv_undef>, their
first line and all will be well.
To free an SV that you've created, call C<SvREFCNT_dec(SV*)>. Normally this
-call is not necessary (see L<Reference Counts and Mortality>).
+call is not necessary (see L</Reference Counts and Mortality>).
=head2 Offsets
This returns NULL if the variable does not exist.
-See L<Understanding the Magic of Tied Hashes and Arrays> for more
+See L</Understanding the Magic of Tied Hashes and Arrays> for more
information on how to use the array access functions on tied arrays.
=head2 Working with HVs
of perl, and the return value may change per invocation, so the value
is only valid for the duration of a single perl process.
-See L<Understanding the Magic of Tied Hashes and Arrays> for more
+See L</Understanding the Magic of Tied Hashes and Arrays> for more
information on how to use the hash access functions on tied hashes.
=head2 Hash API Extensions
The C<sv> argument must be a reference value. The C<stash> argument
specifies which class the reference will belong to. See
-L<Stashes and Globs> for information on converting class names into stashes.
+L</Stashes and Globs> for information on converting class names into stashes.
/* Still under construction */
The sv_magic function uses C<how> to determine which, if any, predefined
"Magic Virtual Table" should be assigned to the C<mg_virtual> field.
-See the L<Magic Virtual Tables> section below. The C<how> argument is also
+See the L</Magic Virtual Tables> section below. The C<how> argument is also
stored in the C<mg_type> field. The value of
C<how> should be chosen from the set of macros
C<PERL_MAGIC_foo> found in F<perl.h>. Note that before
the tie methods. Lastly it ties the two hashes together, and returns a
reference to the new tied hash. Note that the code below does NOT call the
TIEHASH method in the MyTie class -
-see L<Calling Perl Routines from within C Programs> for details on how
+see L</Calling Perl Routines from within C Programs> for details on how
to do this.
SV*
not constantly freed/created.
Each of the targets is created only once (but see
-L<Scratchpads and recursion> below), and when an opcode needs to put
+L</Scratchpads and recursion> below), and when an opcode needs to put
an integer, a double, or a string on stack, it just sets the
corresponding parts of its I<target> and puts the I<target> on stack.
-pedantic> flags which enforce stricter ANSI rules.
If using the C<gcc -Wall> note that not all the possible warnings (like
-C<-Wunitialized>) are given unless you also compile with C<-O>.
+C<-Wuninitialized>) are given unless you also compile with C<-O>.
Note that if using gcc, starting from Perl 5.9.5 the Perl core source
code files (the ones at the top level of the source code distribution,
Ricardo 5.25.0 2016-May-09 The 5.25 development track
Sawyer X 5.25.1 2016-May-20
+ Matthew 5.25.2 2016-Jun-20
=head2 SELECTED RELEASE SIZES
locales", based on Unicode. These are locales whose character set is
Unicode, encoded in UTF-8. Starting in v5.20, Perl fully supports
UTF-8 locales, except for sorting and string comparisons like C<lt> and
-C<ge>. (Use L<Unicode::Collate> for these.) Perl continues to support
-the old non UTF-8 locales as well. There are currently no UTF-8 locales
-for EBCDIC platforms.
+C<ge>. Starting in v5.26, Perl can handle these reasonably as well,
+depending on the platform's implementation. However, for earlier
+releases or for better control, use L<Unicode::Collate> . Perl continues to
+support the old non UTF-8 locales as well. There are currently no UTF-8
+locales for EBCDIC platforms.
(Unicode is also creating C<CLDR>, the "Common Locale Data Repository",
L<http://cldr.unicode.org/> which includes more types of information than
If you want a Perl application to process and present your data
according to a particular locale, the application code should include
-the S<C<use locale>> pragma (see L<The "use locale" pragma>) where
+the S<C<use locale>> pragma (see L</The "use locale" pragma>) where
appropriate, and B<at least one> of the following must be true:
=over 4
=item 2
B<The application must set its own locale> using the method described in
-L<The setlocale function>.
+L</The setlocale function>.
=back
The string result of any operation that uses locale
information is tainted, as it is possible for a locale to be
-untrustworthy. See L<"SECURITY">.
+untrustworthy. See L</"SECURITY">.
Starting in Perl v5.16 in a very limited way, and more generally in
v5.22, you can restrict which category or categories are enabled by this
other locale variables) may affect other programs as well, not just
Perl. In particular, external programs run from within Perl will see
these changes. If you make the new settings permanent (read on), all
-programs you run see the changes. See L<"ENVIRONMENT"> for
-the full list of relevant environment variables and L<USING LOCALES>
+programs you run see the changes. See L</"ENVIRONMENT"> for
+the full list of relevant environment variables and L</"USING LOCALES">
for their effects in Perl. Effects in other programs are
easily deducible. For example, the variable C<LC_COLLATE> may well affect
your B<sort> program (or whatever the program that arranges "records"
mis(sing)configuration of the whole system's locales usually requires
the help of your friendly system administrator.
-First, see earlier in this document about L<Finding locales>. That tells
+First, see earlier in this document about L</Finding locales>. That tells
how to find which locales are really supported--and more importantly,
installed--on your system. In our example error message, environment
variables affecting the locale are listed in the order of decreasing
(prefix matches do not count and case usually counts) like "En_US"
without the quotes, then you should be okay because you are using a
locale name that should be installed and available in your system.
-In this case, see L<Permanently fixing your system's locale configuration>.
+In this case, see L</Permanently fixing your system's locale configuration>.
=head2 Permanently fixing your system's locale configuration
that you can list and which somehow matches what you tried. The
rules for matching locale names are a bit vague because
standardization is weak in this area. See again the
-L<Finding locales> about general rules.
+L</Finding locales> about general rules.
=head2 Fixing system locale configuration
Contact a system administrator (preferably your own) and report the exact
error message you get, and ask them to read this same documentation you
are now reading. They should be able to check whether there is something
-wrong with the locale configuration of the system. The L<Finding locales>
+wrong with the locale configuration of the system. The L</Finding locales>
section is unfortunately a bit vague about the exact commands and places
because these things are not that standardized.
whether called from within the scope of C<S<use locale>> or not). (If
you just want the name of
the current locale for a particular category, use C<POSIX::setlocale()>
-with a single parameter--see L<The setlocale function>.)
+with a single parameter--see L</The setlocale function>.)
use POSIX qw(locale_h);
The following subsections describe basic locale categories. Beyond these,
some combination categories allow manipulation of more than one
-basic category at a time. See L<"ENVIRONMENT"> for a discussion of these.
+basic category at a time. See L</"ENVIRONMENT"> for a discussion of these.
-=head2 Category C<LC_COLLATE>: Collation
+=head2 Category C<LC_COLLATE>: Collation: Text Comparisons and Sorting
In the scope of a S<C<use locale>> form that includes collation, Perl
looks to the C<LC_COLLATE>
sorting raw binary data, whereas the locale-dependent collation of the
first example is useful for natural text.
-As noted in L<USING LOCALES>, C<cmp> compares according to the current
+As noted in L</USING LOCALES>, C<cmp> compares according to the current
collation locale when C<use locale> is in effect, but falls back to a
char-by-char comparison for strings that the locale says are equal. You
can use C<POSIX::strcoll()> if you don't want this fall-back:
dictionary-like ordering that ignores space characters completely and
which folds case.
-Perl currently only supports single-byte locales for C<LC_COLLATE>. This means
-that a UTF-8 locale likely will just give you machine-native ordering.
-Use L<Unicode::Collate> for the full implementation of the Unicode
-Collation Algorithm.
+Perl uses the platform's C library collation functions C<strcoll()> and
+C<strxfrm()>. That means you get whatever they give. On some
+platforms, these functions work well on UTF-8 locales, giving
+a reasonable default collation for the code points that are important in
+that locale. (And if they aren't working well, the problem may only be
+that the locale definition is deficient, so can be fixed by using a
+better definition file. Unicode's definitions (see L</Freely available
+locale definitions>) provide reasonable UTF-8 locale collation
+definitions.) Starting in Perl v5.26, Perl's use of these functions has
+been made more seamless. This may be sufficient for your needs. For
+more control, and to make sure strings containing any code point (not
+just the ones important in the locale) collate properly, the
+L<Unicode::Collate> module is suggested.
+
+In non-UTF-8 locales (hence single byte), code points above 0xFF are
+technically invalid. But if present, again starting in v5.26, they will
+collate to the same position as the highest valid code point does. This
+generally gives good results, but the collation order may be skewed if
+the valid code point gets special treatment when it forms particular
+sequences with other characters as defined by the locale.
+When two strings collate identically, the code point order is used as a
+tie breaker.
+
+If Perl detects that there are problems with the locale collation order,
+it reverts to using non-locale collation rules for that locale.
+
+If Perl detects that there are problems with the locale collation order,
+it reverts to using non-locale collation rules for that locale.
If you have a single string that you want to check for "equality in
locale" against several others, you might think you could gain a little
in clearly ineligible characters being considered to be alphanumeric by
your application. For strict matching of (mundane) ASCII letters and
digits--for example, in command strings--locale-aware applications
-should use C<\w> with the C</a> regular expression modifier. See L<"SECURITY">.
+should use C<\w> with the C</a> regular expression modifier. See L</"SECURITY">.
=head2 Category C<LC_NUMERIC>: Numeric Formatting
In most implementations the only effect is to
change the character used for the decimal point--perhaps from "." to ",".
The functions aren't aware of such niceties as thousands separation and
-so on. (See L<The localeconv function> if you care about these things.)
+so on. (See L</The localeconv function> if you care about these things.)
use POSIX qw(strtod setlocale LC_NUMERIC);
use locale;
committees will recognize that the working group decided to punt on the
issue.) Consequently, Perl essentially takes no notice of it. If you
really want to use C<LC_MONETARY>, you can query its contents--see
-L<The localeconv function>--and use the information that it returns in your
+L</The localeconv function>--and use the information that it returns in your
application's own formatting of currency amounts. However, you may well
find that the information, voluminous and complex though it may be, still
does not quite meet your requirements: currency formatting is a hard nut
See also L<I18N::Langinfo> and C<CRNCYSTR>.
-=head2 C<LC_TIME>
+=head2 Category C<LC_TIME>: Respresentation of time
Output produced by C<POSIX::strftime()>, which builds a formatted
human-readable date/time string, is affected by the current C<LC_TIME>
Versions of Perl prior to 5.004 B<mostly> ignored locale information,
generally behaving as if something similar to the C<"C"> locale were
always in force, even if the program environment suggested otherwise
-(see L<The setlocale function>). By default, Perl still behaves this
+(see L</The setlocale function>). By default, Perl still behaves this
way for backward compatibility. If you want a Perl application to pay
attention to locale information, you B<must> use the S<C<use locale>>
-pragma (see L<The "use locale" pragma>) or, in the unlikely event
+pragma (see L</The "use locale" pragma>) or, in the unlikely event
that you want to do so for just pattern matching, the
C</l> regular expression modifier (see L<perlre/Character set
modifiers>) to instruct it to do so.
The support of Unicode is new starting from Perl version v5.6, and more fully
implemented in versions v5.8 and later. See L<perluniintro>.
-Starting in Perl v5.20, UTF-8 locales are supported in Perl, except for
-C<LC_COLLATE> (use L<Unicode::Collate> instead). If you have Perl v5.16
-or v5.18 and can't upgrade, you can use
+Starting in Perl v5.20, UTF-8 locales are supported in Perl, except
+C<LC_COLLATE> is only partially supported; collation support is improved
+in Perl v5.26 to a level that may be sufficient for your needs
+(see L</Category C<LC_COLLATE>: Collation: Text Comparisons and Sorting>).
+
+If you have Perl v5.16 or v5.18 and can't upgrade, you can use
use locale ':not_characters';
This form of the pragma allows essentially seamless handling of locales
with Unicode. The collation order will be by Unicode code point order.
-It is strongly
-recommended that when you need to order and sort strings that you use
-the standard module L<Unicode::Collate> which gives much better results
-in many instances than you can get with the old-style locale handling.
+L<Unicode::Collate> can be used to get Unicode rules collation.
All the modules and switches just described can be used in v5.20 with
just plain C<use locale>, and, should the input locales not be UTF-8,
character classes; in v5.14 it was extended to all regex matches; and in
v5.16 to the casing operations such as C<\L> and C<uc()>. For
collation, in all releases so far, the system's C<strxfrm()> function is
-called, and whatever it does is what you get.
+called, and whatever it does is what you get. Starting in v5.26, various
+bugs are fixed with the way perl uses this function.
=head1 BUGS
+=head2 Collation of strings containing embedded C<NUL> characters
+
+C<NUL> characters will sort the same as the lowest collating control
+character does, or to C<"\001"> in the unlikely event that there are no
+control characters at all in the locale. In cases where the strings
+don't contain this non-C<NUL> control, the results will be correct, and
+in many locales, this control, whatever it might be, will rarely be
+encountered. But there are cases where a C<NUL> should sort before this
+control, but doesn't. If two strings do collate identically, the one
+containing the C<NUL> will sort to earlier.
+
=head2 Broken systems
In certain systems, the operating system's locale support
reasons why you might have trouble using it with MacPerl. Look for
F<.xs> and F<.c> files, which normally denote that the distribution
must be compiled, and you cannot install it "out of the box."
-(See L<"PORTABILITY">.)
+(See L</"PORTABILITY">.)
D. INSTALL
don't send me mail asking for help on how to install your modules.
There are too many modules, and too few Orwants, for me to be able to
answer or even acknowledge all your questions. Contact the module
-author instead, or post to comp.lang.perl.modules, or ask someone
-familiar with Perl on your operating system.
+author instead, ask someone familiar with Perl on your operating
+system, or if all else fails, file a ticket at http://rt.cpan.org/.
=head1 AUTHOR
=item South Africa
- http://cpan.mirror.ac.za/
- ftp://cpan.mirror.ac.za/
http://mirror.is.co.za/pub/cpan/
ftp://ftp.is.co.za/pub/cpan/
+ http://cpan.mirror.ac.za/
+ ftp://cpan.mirror.ac.za/
+ http://cpan.saix.net/
ftp://ftp.saix.net/pub/CPAN/
+ http://ftp.wa.co.za/pub/CPAN/
+ ftp://ftp.wa.co.za/pub/CPAN/
+
+=item Uganda
+
+ http://mirror.ucu.ac.ug/cpan/
+
+=item Zimbabwe
+
+ http://mirror.zol.co.zw/CPAN/
+ ftp://mirror.zol.co.zw/CPAN/
=back
=over 4
-=item China
+=item Bangladesh
- http://cpan.wenzk.com/
+ http://mirror.dhakacom.com/CPAN/
+ ftp://mirror.dhakacom.com/CPAN/
-=item Hong Kong
+=item China
+ http://cpan.communilink.net/
http://ftp.cuhk.edu.hk/pub/packages/perl/CPAN/
ftp://ftp.cuhk.edu.hk/pub/packages/perl/CPAN/
- http://mirrors.geoexpat.com/cpan/
+ http://mirrors.hust.edu.cn/CPAN/
+ http://mirrors.neusoft.edu.cn/cpan/
+ http://mirror.lzu.edu.cn/CPAN/
+ http://mirrors.163.com/cpan/
+ http://mirrors.sohu.com/CPAN/
+ http://mirrors.ustc.edu.cn/CPAN/
+ ftp://mirrors.ustc.edu.cn/CPAN/
+ http://mirrors.xmu.edu.cn/CPAN/
+ ftp://mirrors.xmu.edu.cn/CPAN/
+ http://mirrors.zju.edu.cn/CPAN/
=item India
+ http://cpan.excellmedia.net/
http://perlmirror.indialinks.com/
=item Indonesia
- http://cpan.biz.net.id/
- http://komo.vlsm.org/CPAN/
- ftp://komo.vlsm.org/CPAN/
- http://cpan.cermin.lipi.go.id/
- ftp://cermin.lipi.go.id/pub/CPAN/
+ http://kambing.ui.ac.id/cpan/
http://cpan.pesat.net.id/
+ http://mirror.poliwangi.ac.id/CPAN/
+ http://kartolo.sby.datautama.net.id/CPAN/
+ http://mirror.wanxp.id/cpan/
+
+=item Iran
+
+ http://mirror.yazd.ac.ir/cpan/
+
+=item Israel
+
+ http://biocourse.weizmann.ac.il/CPAN/
=item Japan
- ftp://ftp.u-aizu.ac.jp/pub/CPAN
+ http://ftp.jaist.ac.jp/pub/CPAN/
+ ftp://ftp.jaist.ac.jp/pub/CPAN/
+ http://mirror.jre655.com/CPAN/
+ ftp://mirror.jre655.com/CPAN/
ftp://ftp.kddilabs.jp/CPAN/
http://ftp.nara.wide.ad.jp/pub/CPAN/
ftp://ftp.nara.wide.ad.jp/pub/CPAN/
- http://ftp.jaist.ac.jp/pub/CPAN/
- ftp://ftp.jaist.ac.jp/pub/CPAN/
- ftp://ftp.dti.ad.jp/pub/lang/CPAN/
- ftp://ftp.ring.gr.jp/pub/lang/perl/CPAN/
http://ftp.riken.jp/lang/CPAN/
ftp://ftp.riken.jp/lang/CPAN/
+ ftp://ftp.u-aizu.ac.jp/pub/CPAN/
http://ftp.yz.yamagata-u.ac.jp/pub/lang/cpan/
ftp://ftp.yz.yamagata-u.ac.jp/pub/lang/cpan/
+=item Kazakhstan
+
+ http://mirror.neolabs.kz/CPAN/
+ ftp://mirror.neolabs.kz/CPAN/
+
+=item Philippines
+
+ http://mirror.pregi.net/CPAN/
+ ftp://mirror.pregi.net/CPAN/
+ http://mirror.rise.ph/cpan/
+ ftp://mirror.rise.ph/cpan/
+
+=item Qatar
+
+ http://mirror.qnren.qa/CPAN/
+ ftp://mirror.qnren.qa/CPAN/
+
=item Republic of Korea
- http://ftp.kaist.ac.kr/pub/CPAN
- ftp://ftp.kaist.ac.kr/pub/CPAN
http://cpan.mirror.cdnetworks.com/
ftp://cpan.mirror.cdnetworks.com/CPAN/
- http://cpan.sarang.net/
- ftp://cpan.sarang.net/CPAN/
-
-=item Russia
-
- http://cpan.tomsk.ru/
- ftp://cpan.tomsk.ru/
+ http://ftp.kaist.ac.kr/pub/CPAN/
+ ftp://ftp.kaist.ac.kr/CPAN/
+ http://ftp.kr.freebsd.org/pub/CPAN/
+ ftp://ftp.kr.freebsd.org/pub/CPAN/
+ http://mirror.navercorp.com/CPAN/
+ http://ftp.neowiz.com/CPAN/
+ ftp://ftp.neowiz.com/CPAN/
=item Singapore
- http://mirror.averse.net/pub/CPAN
- ftp://mirror.averse.net/pub/CPAN
http://cpan.mirror.choon.net/
- http://cpan.oss.eznetsols.org
- ftp://ftp.oss.eznetsols.org/cpan
+ http://mirror.0x.sg/CPAN/
+ ftp://mirror.0x.sg/CPAN/
=item Taiwan
- http://ftp.cse.yzu.edu.tw/pub/CPAN/
- ftp://ftp.cse.yzu.edu.tw/pub/CPAN/
+ http://cpan.cdpa.nsysu.edu.tw/Unix/Lang/CPAN/
+ ftp://cpan.cdpa.nsysu.edu.tw/Unix/Lang/CPAN/
+ http://cpan.stu.edu.tw/
+ ftp://ftp.stu.edu.tw/CPAN/
+ http://ftp.yzu.edu.tw/CPAN/
+ ftp://ftp.yzu.edu.tw/CPAN/
http://cpan.nctu.edu.tw/
ftp://cpan.nctu.edu.tw/
- ftp://ftp.ncu.edu.tw/CPAN/
- http://cpan.cdpa.nsysu.edu.tw/
- ftp://cpan.cdpa.nsysu.edu.tw/Unix/Lang/CPAN/
- http://cpan.stu.edu.tw
- ftp://ftp.stu.edu.tw/CPAN
- http://ftp.stu.edu.tw/CPAN
- ftp://ftp.stu.edu.tw/pub/CPAN
- http://cpan.cs.pu.edu.tw/
- ftp://cpan.cs.pu.edu.tw/pub/CPAN
-
-=item Thailand
-
- http://mirrors.issp.co.th/cpan/
- ftp://mirrors.issp.co.th/cpan/
- http://mirror.yourconnect.com/CPAN/
- ftp://mirror.yourconnect.com/CPAN/
+ http://ftp.ubuntu-tw.org/mirror/CPAN/
+ ftp://ftp.ubuntu-tw.org/mirror/CPAN/
=item Turkey
- http://cpan.gazi.edu.tr/
+ http://cpan.ulak.net.tr/
+ ftp://ftp.ulak.net.tr/pub/perl/CPAN/
+ http://mirror.vit.com.tr/mirror/CPAN/
+ ftp://mirror.vit.com.tr/CPAN/
-=back
-
-=head2 Central America
-
-=over 4
-
-=item Costa Rica
+=item Viet Nam
- http://mirrors.ucr.ac.cr/CPAN/
- ftp://mirrors.ucr.ac.cr/CPAN/
+ http://mirrors.digipower.vn/CPAN/
+ http://mirror.downloadvn.com/cpan/
+ http://mirrors.vinahost.vn/CPAN/
=back
=item Austria
http://cpan.inode.at/
- ftp://cpan.inode.at
+ ftp://cpan.inode.at/
+ http://mirror.easyname.at/cpan/
+ ftp://mirror.easyname.at/cpan/
http://gd.tuwien.ac.at/languages/perl/CPAN/
ftp://gd.tuwien.ac.at/pub/CPAN/
+=item Belarus
+
+ http://ftp.byfly.by/pub/CPAN/
+ ftp://ftp.byfly.by/pub/CPAN/
+ http://mirror.datacenter.by/pub/CPAN/
+ ftp://mirror.datacenter.by/pub/CPAN/
+
=item Belgium
- http://ftp.belnet.be/mirror/ftp.cpan.org/
+ http://ftp.belnet.be/ftp.cpan.org/
ftp://ftp.belnet.be/mirror/ftp.cpan.org/
- http://ftp.easynet.be/pub/CPAN/
- http://cpan.weepee.org/
+ http://cpan.cu.be/
+ http://lib.ugent.be/CPAN/
+ http://cpan.weepeetelecom.be/
=item Bosnia and Herzegovina
- http://cpan.blic.net/
+ http://cpan.mirror.ba/
+ ftp://ftp.mirror.ba/CPAN/
=item Bulgaria
- http://cpan.cbox.biz/
- ftp://cpan.cbox.biz/cpan/
- http://cpan.digsys.bg/
- ftp://ftp.digsys.bg/pub/CPAN
+ http://mirrors.neterra.net/CPAN/
+ ftp://mirrors.neterra.net/CPAN/
+ http://mirrors.netix.net/CPAN/
+ ftp://mirrors.netix.net/CPAN/
=item Croatia
=item Czech Republic
+ http://mirror.dkm.cz/cpan/
+ ftp://mirror.dkm.cz/cpan/
ftp://ftp.fi.muni.cz/pub/CPAN/
- http://archive.cpan.cz/
+ http://mirrors.nic.cz/CPAN/
+ ftp://mirrors.nic.cz/pub/CPAN/
+ http://cpan.mirror.vutbr.cz/
+ ftp://mirror.vutbr.cz/cpan/
=item Denmark
- http://mirrors.dotsrc.org/cpan
- ftp://mirrors.dotsrc.org/cpan/
http://www.cpan.dk/
- http://mirror.uni-c.dk/pub/CPAN/
+ http://mirrors.dotsrc.org/cpan/
+ ftp://mirrors.dotsrc.org/cpan/
=item Finland
ftp://ftp.funet.fi/pub/languages/perl/CPAN/
- http://mirror.eunet.fi/CPAN
=item France
- http://cpan.enstimac.fr/
- ftp://ftp.inria.fr/pub/CPAN/
+ http://ftp.ciril.fr/pub/cpan/
+ ftp://ftp.ciril.fr/pub/cpan/
http://distrib-coffee.ipsl.jussieu.fr/pub/mirrors/cpan/
ftp://distrib-coffee.ipsl.jussieu.fr/pub/mirrors/cpan/
+ http://ftp.lip6.fr/pub/perl/CPAN/
ftp://ftp.lip6.fr/pub/perl/CPAN/
- http://mir2.ovh.net/ftp.cpan.org
- ftp://mir1.ovh.net/ftp.cpan.org
+ http://mirror.ibcp.fr/pub/CPAN/
ftp://ftp.oleane.net/pub/CPAN/
- http://ftp.crihan.fr/mirrors/ftp.cpan.org/
- ftp://ftp.crihan.fr/mirrors/ftp.cpan.org/
- http://ftp.u-strasbg.fr/CPAN
- ftp://ftp.u-strasbg.fr/CPAN
- http://cpan.cict.fr/
- ftp://cpan.cict.fr/pub/CPAN/
+ http://cpan.mirrors.ovh.net/ftp.cpan.org/
+ ftp://cpan.mirrors.ovh.net/ftp.cpan.org/
+ http://cpan.enstimac.fr/
=item Germany
- ftp://ftp.fu-berlin.de/unix/languages/perl/
- http://mirrors.softliste.de/cpan/
- ftp://ftp.rub.de/pub/CPAN/
- http://www.planet-elektronik.de/CPAN/
+ http://mirror.23media.de/cpan/
+ ftp://mirror.23media.de/cpan/
+ http://artfiles.org/cpan.org/
+ ftp://artfiles.org/cpan.org/
+ http://mirror.bibleonline.ru/cpan/
+ http://mirror.checkdomain.de/CPAN/
+ ftp://mirror.checkdomain.de/CPAN/
+ http://cpan.noris.de/
+ http://mirror.de.leaseweb.net/CPAN/
+ ftp://mirror.de.leaseweb.net/CPAN/
+ http://cpan.mirror.euserv.net/
+ ftp://mirror.euserv.net/cpan/
+ http://ftp-stud.hs-esslingen.de/pub/Mirrors/CPAN/
+ ftp://mirror.fraunhofer.de/CPAN/
+ ftp://ftp.freenet.de/pub/ftp.cpan.org/pub/CPAN/
http://ftp.hosteurope.de/pub/CPAN/
ftp://ftp.hosteurope.de/pub/CPAN/
- http://www.mirrorspace.org/cpan/
- http://mirror.netcologne.de/cpan/
- ftp://mirror.netcologne.de/cpan/
- ftp://ftp.freenet.de/pub/ftp.cpan.org/pub/CPAN/
- http://ftp-stud.hs-esslingen.de/pub/Mirrors/CPAN/
- ftp://ftp-stud.hs-esslingen.de/pub/Mirrors/CPAN/
- http://mirrors.zerg.biz/cpan/
+ ftp://ftp.fu-berlin.de/unix/languages/perl/
http://ftp.gwdg.de/pub/languages/perl/CPAN/
ftp://ftp.gwdg.de/pub/languages/perl/CPAN/
- http://dl.ambiweb.de/mirrors/ftp.cpan.org/
- http://cpan.mirror.clusters.kg/
+ http://ftp.hawo.stw.uni-erlangen.de/CPAN/
+ ftp://ftp.hawo.stw.uni-erlangen.de/CPAN/
http://cpan.mirror.iphh.net/
ftp://cpan.mirror.iphh.net/pub/CPAN/
- http://cpan.mirroring.de/
- http://mirror.informatik.uni-mannheim.de/pub/mirrors/CPAN/
- ftp://mirror.informatik.uni-mannheim.de/pub/mirrors/CPAN/
- http://www.chemmedia.de/mirrors/CPAN/
- http://ftp.cw.net/pub/CPAN/
- ftp://ftp.cw.net/pub/CPAN/
- http://cpan.cpantesters.org/
- ftp://cpan.cpantesters.org/CPAN/
- http://cpan.mirrored.de/
+ ftp://ftp.mpi-inf.mpg.de/pub/perl/CPAN/
+ http://cpan.netbet.org/
+ http://mirror.netcologne.de/cpan/
+ ftp://mirror.netcologne.de/cpan/
ftp://mirror.petamem.com/CPAN/
- http://cpan.noris.de/
- ftp://cpan.noris.de/pub/CPAN/
- ftp://ftp.mpi-sb.mpg.de/pub/perl/CPAN/
- ftp://ftp.gmd.de/mirrors/CPAN/
+ http://www.planet-elektronik.de/CPAN/
+ http://ftp.halifax.rwth-aachen.de/cpan/
+ ftp://ftp.halifax.rwth-aachen.de/cpan/
+ http://mirror.softaculous.com/cpan/
+ http://ftp.u-tx.net/CPAN/
+ ftp://ftp.u-tx.net/CPAN/
+ http://mirror.reismil.ch/CPAN/
=item Greece
- ftp://ftp.forthnet.gr/pub/languages/perl/CPAN
- ftp://ftp.ntua.gr/pub/lang/perl/
- http://cpan.cc.uoc.gr/
+ http://cpan.cc.uoc.gr/mirrors/CPAN/
ftp://ftp.cc.uoc.gr/mirrors/CPAN/
+ http://ftp.ntua.gr/pub/lang/perl/
+ ftp://ftp.ntua.gr/pub/lang/perl/
=item Hungary
- http://cpan.mirrors.enexis.hu/
- ftp://cpan.mirrors.enexis.hu/mirrors/cpan/
- http://cpan.hu/
-
-=item Iceland
-
- http://ftp.rhnet.is/pub/CPAN/
- ftp://ftp.rhnet.is/pub/CPAN/
+ http://mirror.met.hu/CPAN/
=item Ireland
- http://ftp.esat.net/pub/languages/perl/CPAN/
- ftp://ftp.esat.net/pub/languages/perl/CPAN/
- http://ftp.heanet.ie/mirrors/ftp.perl.org/pub/CPAN
- ftp://ftp.heanet.ie/mirrors/ftp.perl.org/pub/CPAN
+ http://ftp.heanet.ie/mirrors/ftp.perl.org/pub/CPAN/
+ ftp://ftp.heanet.ie/mirrors/ftp.perl.org/pub/CPAN/
=item Italy
http://bo.mirror.garr.it/mirrors/CPAN/
+ ftp://ftp.eutelia.it/CPAN_Mirror/
http://cpan.panu.it/
ftp://ftp.panu.it/pub/mirrors/perl/CPAN/
+ http://cpan.muzzy.it/
=item Latvia
http://ftp.litnet.lt/pub/CPAN/
ftp://ftp.litnet.lt/pub/CPAN/
-=item Malta
+=item Moldova
- http://cpan.waldonet.net.mt/
+ http://mirror.as43289.net/pub/CPAN/
+ ftp://mirror.as43289.net/pub/CPAN/
=item Netherlands
- ftp://ftp.quicknet.nl/pub/CPAN/
- http://mirror.hostfuss.com/CPAN/
- ftp://mirror.hostfuss.com/CPAN/
- http://mirrors3.kernel.org/cpan/
- ftp://mirrors3.kernel.org/pub/CPAN/
- http://cpan.mirror.versatel.nl/
- ftp://ftp.mirror.versatel.nl/cpan/
+ http://cpan.cs.uu.nl/
+ ftp://ftp.cs.uu.nl/pub/CPAN/
+ http://mirror.nl.leaseweb.net/CPAN/
+ ftp://mirror.nl.leaseweb.net/CPAN/
+ http://ftp.nluug.nl/languages/perl/CPAN/
+ ftp://ftp.nluug.nl/pub/languages/perl/CPAN/
+ http://mirror.transip.net/CPAN/
+ ftp://mirror.transip.net/CPAN/
+ http://cpan.mirror.triple-it.nl/
+ http://ftp.tudelft.nl/cpan/
+ ftp://ftp.tudelft.nl/pub/CPAN/
ftp://download.xs4all.nl/pub/mirror/CPAN/
- http://mirror.leaseweb.com/CPAN/
- ftp://mirror.leaseweb.com/CPAN/
- ftp://ftp.cpan.nl/pub/CPAN/
- http://archive.cs.uu.nl/mirror/CPAN/
- ftp://ftp.cs.uu.nl/mirror/CPAN/
- http://luxitude.net/cpan/
=item Norway
- ftp://ftp.uninett.no/pub/languages/perl/CPAN
- ftp://ftp.uit.no/pub/languages/perl/cpan/
+ http://cpan.uib.no/
+ ftp://cpan.uib.no/pub/CPAN/
+ ftp://ftp.uninett.no/pub/languages/perl/CPAN/
+ http://cpan.vianett.no/
=item Poland
- http://piotrkosoft.net/pub/mirrors/CPAN/
+ http://ftp.agh.edu.pl/CPAN/
+ ftp://ftp.agh.edu.pl/CPAN/
+ http://ftp.piotrkosoft.net/pub/mirrors/CPAN/
ftp://ftp.piotrkosoft.net/pub/mirrors/CPAN/
- http://ftp.man.poznan.pl/pub/CPAN
- ftp://ftp.man.poznan.pl/pub/CPAN
ftp://ftp.ps.pl/pub/CPAN/
+ http://sunsite.icm.edu.pl/pub/CPAN/
ftp://sunsite.icm.edu.pl/pub/CPAN/
- ftp://ftp.tpnet.pl/d4/CPAN/
=item Portugal
- http://cpan.dei.uc.pt/
- ftp://ftp.dei.uc.pt/pub/CPAN
- ftp://ftp.ist.utl.pt/pub/CPAN/
- http://cpan.perl.pt/
- http://cpan.ip.pt/
- ftp://cpan.ip.pt/pub/cpan/
- http://mirrors.nfsi.pt/CPAN/
- ftp://mirrors.nfsi.pt/pub/CPAN/
http://cpan.dcc.fc.up.pt/
+ http://mirrors.fe.up.pt/pub/CPAN/
+ http://cpan.perl-hackers.net/
+ http://cpan.perl.pt/
=item Romania
- http://ftp.astral.ro/pub/CPAN/
- ftp://ftp.astral.ro/pub/CPAN/
- ftp://ftp.lug.ro/CPAN
+ http://mirrors.hostingromania.ro/cpan.org/
+ ftp://ftp.lug.ro/CPAN/
+ http://mirrors.m247.ro/CPAN/
+ http://mirrors.evowise.com/CPAN/
+ http://mirrors.teentelecom.net/CPAN/
+ ftp://mirrors.teentelecom.net/CPAN/
http://mirrors.xservers.ro/CPAN/
- http://mirrors.hostingromania.ro/ftp.cpan.org/
- ftp://ftp.hostingromania.ro/mirrors/ftp.cpan.org/
- ftp://ftp.iasi.roedu.net/pub/mirrors/ftp.cpan.org/
-=item Russia
+=item Russian Federation
ftp://ftp.aha.ru/CPAN/
http://cpan.rinet.ru/
ftp://cpan.rinet.ru/pub/mirror/CPAN/
- ftp://ftp.SpringDaemons.com/pub/CPAN/
+ http://cpan-mirror.rbc.ru/pub/CPAN/
http://mirror.rol.ru/CPAN/
- http://ftp.silvernet.ru/CPAN/
- http://ftp.spbu.ru/CPAN/
- ftp://ftp.spbu.ru/CPAN/
+ http://cpan.uni-altai.ru/
+ http://cpan.webdesk.ru/
+ ftp://cpan.webdesk.ru/cpan/
+ http://mirror.yandex.ru/mirrors/cpan/
+ ftp://mirror.yandex.ru/mirrors/cpan/
+
+=item Serbia
+
+ http://mirror.sbb.rs/CPAN/
+ ftp://mirror.sbb.rs/CPAN/
=item Slovakia
- http://cpan.fyxm.net/
+ http://cpan.lnx.sk/
+ http://tux.rainside.sk/CPAN/
+ ftp://tux.rainside.sk/CPAN/
=item Slovenia
- http://www.klevze.si/cpan
+ http://ftp.arnes.si/software/perl/CPAN/
+ ftp://ftp.arnes.si/software/perl/CPAN/
=item Spain
+ http://mirrors.evowise.com/CPAN/
http://osl.ugr.es/CPAN/
+ http://ftp.rediris.es/mirror/CPAN/
ftp://ftp.rediris.es/mirror/CPAN/
- http://ftp.gui.uva.es/sites/cpan.org/
- ftp://ftp.gui.uva.es/sites/cpan.org/
=item Sweden
- http://mirrors4.kernel.org/cpan/
- ftp://mirrors4.kernel.org/pub/CPAN/
+ http://ftp.acc.umu.se/mirror/CPAN/
+ ftp://ftp.acc.umu.se/mirror/CPAN/
=item Switzerland
- http://cpan.mirror.solnet.ch/
- ftp://ftp.solnet.ch/mirror/CPAN/
- ftp://ftp.adwired.ch/CPAN/
+ http://www.pirbot.com/mirrors/cpan/
http://mirror.switch.ch/ftp/mirror/CPAN/
ftp://mirror.switch.ch/mirror/CPAN/
=item Ukraine
- http://cpan.makeperl.org/
- ftp://cpan.makeperl.org/pub/CPAN
- http://cpan.org.ua/
- http://cpan.gafol.net/
- ftp://ftp.gafol.net/pub/cpan/
+ http://cpan.ip-connect.vn.ua/
+ ftp://cpan.ip-connect.vn.ua/mirror/cpan/
=item United Kingdom
- http://www.mirrorservice.org/sites/ftp.funet.fi/pub/languages/perl/CPAN/
- ftp://ftp.mirrorservice.org/sites/ftp.funet.fi/pub/languages/perl/CPAN/
- http://mirror.tje.me.uk/pub/mirrors/ftp.cpan.org/
- ftp://mirror.tje.me.uk/pub/mirrors/ftp.cpan.org/
- http://www.mirror.8086.net/sites/CPAN/
- ftp://ftp.mirror.8086.net/sites/CPAN/
http://cpan.mirror.anlx.net/
ftp://ftp.mirror.anlx.net/CPAN/
http://mirror.bytemark.co.uk/CPAN/
ftp://mirror.bytemark.co.uk/CPAN/
+ http://mirrors.coreix.net/CPAN/
http://cpan.etla.org/
- ftp://cpan.etla.org/pub/CPAN
- ftp://ftp.demon.co.uk/pub/CPAN/
+ ftp://cpan.etla.org/pub/CPAN/
+ http://cpan.cpantesters.org/
+ http://mirror.sax.uk.as61049.net/CPAN/
http://mirror.sov.uk.goscomb.net/CPAN/
- ftp://mirror.sov.uk.goscomb.net/pub/CPAN/
- http://ftp.plig.net/pub/CPAN/
- ftp://ftp.plig.net/pub/CPAN/
+ http://www.mirrorservice.org/sites/cpan.perl.org/CPAN/
+ ftp://ftp.mirrorservice.org/sites/cpan.perl.org/CPAN/
+ http://mirror.ox.ac.uk/sites/www.cpan.org/
+ ftp://mirror.ox.ac.uk/sites/www.cpan.org/
http://ftp.ticklers.org/pub/CPAN/
ftp://ftp.ticklers.org/pub/CPAN/
http://cpan.mirrors.uk2.net/
ftp://mirrors.uk2.net/pub/CPAN/
- http://mirror.ox.ac.uk/sites/www.cpan.org/
- ftp://mirror.ox.ac.uk/sites/www.cpan.org/
+ http://mirror.ukhost4u.com/CPAN/
=back
=over 4
-=item Bahamas
-
- http://www.securehost.com/mirror/CPAN/
-
=item Canada
- http://cpan.arcticnetwork.ca
- ftp://mirror.arcticnetwork.ca/pub/CPAN
- http://cpan.sunsite.ualberta.ca/
- ftp://cpan.sunsite.ualberta.ca/pub/CPAN/
- http://theoryx5.uwinnipeg.ca/pub/CPAN/
- ftp://theoryx5.uwinnipeg.ca/pub/CPAN/
- http://arwen.cs.dal.ca/mirror/CPAN/
- ftp://arwen.cs.dal.ca/pub/mirror/CPAN/
http://CPAN.mirror.rafal.ca/
ftp://CPAN.mirror.rafal.ca/pub/CPAN/
- ftp://ftp.nrc.ca/pub/CPAN/
- http://mirror.csclub.uwaterloo.ca/pub/CPAN/
- ftp://mirror.csclub.uwaterloo.ca/pub/CPAN/
+ http://mirror.csclub.uwaterloo.ca/CPAN/
+ ftp://mirror.csclub.uwaterloo.ca/CPAN/
+ http://mirrors.gossamer-threads.com/CPAN/
+ http://mirror.its.dal.ca/cpan/
+ ftp://mirror.its.dal.ca/cpan/
+ ftp://ftp.ottix.net/pub/CPAN/
+
+=item Costa Rica
+
+ http://mirrors.ucr.ac.cr/CPAN/
=item Mexico
=item Alabama
- http://mirror.hiwaay.net/CPAN/
- ftp://mirror.hiwaay.net/CPAN/
+ http://mirror.teklinks.com/CPAN/
=item Arizona
- http://cpan.ezarticleinformation.com/
+ http://mirror.n5tech.com/CPAN/
+ http://mirrors.namecheap.com/CPAN/
+ ftp://mirrors.namecheap.com/CPAN/
=item California
- http://cpan.knowledgematters.net/
- http://cpan.binkerton.com/
http://cpan.develooper.com/
- http://mirrors.gossamer-threads.com/CPAN
- http://cpan.schatt.com/
- http://mirrors.kernel.org/cpan/
- ftp://mirrors.kernel.org/pub/CPAN
- http://mirrors2.kernel.org/cpan/
- ftp://mirrors2.kernel.org/pub/CPAN/
- http://cpan.mirror.facebook.net/
- http://mirrors1.kernel.org/cpan/
- ftp://mirrors1.kernel.org/pub/CPAN/
- http://cpan-sj.viaverio.com/
- ftp://cpan-sj.viaverio.com/pub/CPAN/
+ http://httpupdate127.cpanel.net/CPAN/
+ http://mirrors.sonic.net/cpan/
+ ftp://mirrors.sonic.net/cpan/
http://www.perl.com/CPAN/
-
-=item Florida
-
- ftp://ftp.cise.ufl.edu/pub/mirrors/CPAN/
- http://mirror.atlantic.net/pub/CPAN/
- ftp://mirror.atlantic.net/pub/CPAN/
+ http://cpan.yimg.com/
=item Idaho
- http://mirror.its.uidaho.edu/pub/cpan/
- ftp://mirror.its.uidaho.edu/cpan/
+ http://mirrors.syringanetworks.net/CPAN/
+ ftp://mirrors.syringanetworks.net/CPAN/
=item Illinois
http://cpan.mirrors.hoobly.com/
- http://cpan.uchicago.edu/pub/CPAN/
- ftp://cpan.uchicago.edu/pub/CPAN/
- http://mirrors.servercentral.net/CPAN/
- http://www.stathy.com/CPAN/
- ftp://www.stathy.com/CPAN/
+ http://mirror.team-cymru.org/CPAN/
+ ftp://mirror.team-cymru.org/CPAN/
=item Indiana
- ftp://ftp.uwsg.iu.edu/pub/perl/CPAN/
http://cpan.netnitco.net/
ftp://cpan.netnitco.net/pub/mirrors/CPAN/
- http://ftp.ndlug.nd.edu/pub/perl/
- ftp://ftp.ndlug.nd.edu/pub/perl/
+ ftp://ftp.uwsg.iu.edu/pub/perl/CPAN/
+
+=item Kansas
+
+ http://mirrors.concertpass.com/cpan/
=item Massachusetts
=item Michigan
- http://ftp.wayne.edu/cpan/
- ftp://ftp.wayne.edu/cpan/
+ http://cpan.cse.msu.edu/
+ ftp://cpan.cse.msu.edu/
+ http://httpupdate118.cpanel.net/CPAN/
+ http://mirrors-usa.go-parts.com/cpan/
+ http://ftp.wayne.edu/CPAN/
+ ftp://ftp.wayne.edu/CPAN/
-=item Minnesota
+=item New Hampshire
- http://cpan.msi.umn.edu/
+ http://mirror.metrocast.net/cpan/
=item New Jersey
http://mirror.datapipe.net/CPAN/
ftp://mirror.datapipe.net/pub/CPAN/
+ http://www.hoovism.com/CPAN/
+ ftp://ftp.hoovism.com/CPAN/
+ http://cpan.mirror.nac.net/
=item New York
- http://mirrors.24-7-solutions.net/pub/CPAN/
- ftp://mirrors.24-7-solutions.net/pub/CPAN/
http://mirror.cc.columbia.edu/pub/software/cpan/
ftp://mirror.cc.columbia.edu/pub/software/cpan/
http://cpan.belfry.net/
ftp://cpan.erlbaum.net/CPAN/
http://cpan.hexten.net/
ftp://cpan.hexten.net/
- ftp://mirror.nyi.net/CPAN/
- http://mirror.rit.edu/CPAN/
- ftp://mirror.rit.edu/CPAN/
+ http://mirror.nyi.net/CPAN/
+ ftp://mirror.nyi.net/pub/CPAN/
+ http://noodle.portalus.net/CPAN/
+ ftp://noodle.portalus.net/CPAN/
+ http://mirrors.rit.edu/CPAN/
+ ftp://mirrors.rit.edu/CPAN/
=item North Carolina
- http://www.ibiblio.org/pub/mirrors/CPAN
- ftp://ftp.ncsu.edu/pub/mirror/CPAN/
+ http://httpupdate140.cpanel.net/CPAN/
+ http://mirrors.ibiblio.org/CPAN/
=item Oregon
http://ftp.osuosl.org/pub/CPAN/
ftp://ftp.osuosl.org/pub/CPAN/
+ http://mirror.uoregon.edu/CPAN/
=item Pennsylvania
- http://ftp.epix.net/CPAN/
- ftp://ftp.epix.net/pub/languages/perl/
http://cpan.pair.com/
ftp://cpan.pair.com/pub/CPAN/
+ http://cpan.mirrors.ionfish.org/
=item South Carolina
http://cpan.mirror.clemson.edu/
-=item Tennessee
-
- http://mira.sunsite.utk.edu/CPAN/
-
=item Texas
- http://mirror.uta.edu/CPAN
+ http://mirror.uta.edu/CPAN/
=item Utah
+ http://cpan.cs.utah.edu/
+ ftp://cpan.cs.utah.edu/CPAN/
ftp://mirror.xmission.com/CPAN/
=item Virginia
- http://cpan-du.viaverio.com/
- ftp://cpan-du.viaverio.com/pub/CPAN/
- http://perl.secsup.org/
- ftp://perl.secsup.org/pub/perl/
+ http://mirror.cogentco.com/pub/CPAN/
ftp://mirror.cogentco.com/pub/CPAN/
+ http://mirror.jmu.edu/pub/CPAN/
+ ftp://mirror.jmu.edu/pub/CPAN/
+ http://mirror.us.leaseweb.net/CPAN/
+ ftp://mirror.us.leaseweb.net/CPAN/
=item Washington
http://cpan.llarian.net/
ftp://cpan.llarian.net/pub/CPAN/
- ftp://ftp-mirror.internap.com/pub/CPAN/
=item Wisconsin
- http://cpan.mirrors.tds.net
- ftp://cpan.mirrors.tds.net/pub/CPAN
- http://mirror.sit.wisc.edu/pub/CPAN/
- ftp://mirror.sit.wisc.edu/pub/CPAN/
+ http://cpan.mirrors.tds.net/
+ ftp://cpan.mirrors.tds.net/pub/CPAN/
=back
=item Australia
- http://mirror.internode.on.net/pub/cpan/
+ http://mirror.as24220.net/pub/cpan/
+ ftp://mirror.as24220.net/pub/cpan/
+ http://cpan.mirrors.ilisys.com.au/
+ http://cpan.mirror.digitalpacific.com.au/
ftp://mirror.internode.on.net/pub/cpan/
- http://cpan.mirror.aussiehq.net.au/
- http://mirror.as24220.net/cpan/
- ftp://mirror.as24220.net/cpan/
+ http://mirror.optusnet.com.au/CPAN/
+ http://cpan.mirror.serversaustralia.com.au/
+ http://cpan.uberglobalmirror.com/
+ http://mirror.waia.asn.au/pub/cpan/
+
+=item New Caledonia
+
+ http://cpan.lagoon.nc/pub/CPAN/
+ ftp://cpan.lagoon.nc/pub/CPAN/
+ http://cpan.nautile.nc/CPAN/
+ ftp://cpan.nautile.nc/CPAN/
=item New Zealand
ftp://ftp.auckland.ac.nz/pub/perl/CPAN/
- http://cpan.inspire.net.nz
- ftp://cpan.inspire.net.nz/cpan
http://cpan.catalyst.net.nz/CPAN/
ftp://cpan.catalyst.net.nz/pub/CPAN/
+ http://cpan.inspire.net.nz/
+ ftp://cpan.inspire.net.nz/cpan/
+ http://mirror.webtastix.net/CPAN/
+ ftp://mirror.webtastix.net/CPAN/
=back
=item Argentina
- http://cpan.patan.com.ar/
- http://cpan.localhost.net.ar
- ftp://mirrors.localhost.net.ar/pub/mirrors/CPAN
+ http://cpan.mmgdesigns.com.ar/
=item Brazil
- ftp://cpan.pop-mg.com.br/pub/CPAN/
- http://ftp.pucpr.br/CPAN
- ftp://ftp.pucpr.br/CPAN
http://cpan.kinghost.net/
+ http://linorg.usp.br/CPAN/
+ http://mirror.nbtelecom.com.br/CPAN/
=item Chile
http://cpan.dcc.uchile.cl/
ftp://cpan.dcc.uchile.cl/pub/lang/cpan/
-=item Colombia
-
- http://www.laqee.unal.edu.co/CPAN/
-
=back
=head2 RSYNC Mirrors
- mirror.as24220.net::cpan
- cpan.inode.at::CPAN
- gd.tuwien.ac.at::CPAN
- ftp.belnet.be::packages/cpan
- rsync.linorg.usp.br::CPAN
- rsync.arcticnetwork.ca::CPAN
- CPAN.mirror.rafal.ca::CPAN
- mirror.csclub.uwaterloo.ca::CPAN
- theoryx5.uwinnipeg.ca::CPAN
- www.laqee.unal.edu.co::CPAN
- mirror.uni-c.dk::CPAN
- rsync.nic.funet.fi::CPAN
- rsync://distrib-coffee.ipsl.jussieu.fr/pub/mirrors/cpan/
- mir1.ovh.net::CPAN
- miroir-francais.fr::cpan
- ftp.crihan.fr::CPAN
- rsync://mirror.cict.fr/cpan/
- rsync://mirror.netcologne.de/cpan/
- ftp-stud.hs-esslingen.de::CPAN/
- ftp.gwdg.de::FTP/languages/perl/CPAN/
- cpan.mirror.iphh.net::CPAN
- cpan.cpantesters.org::cpan
- cpan.hu::CPAN
- komo.vlsm.org::CPAN
- mirror.unej.ac.id::cpan
- ftp.esat.net::/pub/languages/perl/CPAN
- ftp.heanet.ie::mirrors/ftp.perl.org/pub/CPAN
- rsync.panu.it::CPAN
- cpan.fastbull.org::CPAN
- ftp.kddilabs.jp::cpan
- ftp.nara.wide.ad.jp::cpan/
- rsync://ftp.jaist.ac.jp/pub/CPAN/
- rsync://ftp.riken.jp/cpan/
- mirror.linuxiso.kz::CPAN
- rsync://mirrors3.kernel.org/mirrors/CPAN/
- rsync://rsync.osmirror.nl/cpan/
- mirror.leaseweb.com::CPAN
- cpan.nautile.nc::CPAN
- mirror.icis.pcz.pl::CPAN
- piotrkosoft.net::mirrors/CPAN
- rsync://cpan.perl.pt/
- ftp.kaist.ac.kr::cpan
- cpan.sarang.net::CPAN
- mirror.averse.net::cpan
- rsync.oss.eznetsols.org
- mirror.ac.za::cpan
- ftp.is.co.za::IS-Mirror/ftp.cpan.org/
- rsync://ftp.gui.uva.es/cpan/
- rsync://mirrors4.kernel.org/mirrors/CPAN/
- ftp.solnet.ch::CPAN
- ftp.ulak.net.tr::CPAN
- gafol.net::cpan
- rsync.mirrorservice.org::ftp.funet.fi/pub/
- rsync://rsync.mirror.8086.net/CPAN/
- rsync.mirror.anlx.net::CPAN
- mirror.bytemark.co.uk::CPAN
- ftp.plig.net::CPAN
- rsync://ftp.ticklers.org:CPAN/
- mirrors.ibiblio.org::CPAN
- cpan-du.viaverio.com::CPAN
- mirror.hiwaay.net::CPAN
- rsync://mira.sunsite.utk.edu/CPAN/
- cpan.mirrors.tds.net::CPAN
- mirror.its.uidaho.edu::cpan
- rsync://mirror.cc.columbia.edu::cpan/
- ftp.fxcorporate.com::CPAN
- rsync.atlantic.net::CPAN
- mirrors.kernel.org::mirrors/CPAN
- rsync://mirrors2.kernel.org/mirrors/CPAN/
- cpan.pair.com::CPAN
- rsync://mirror.rit.edu/CPAN/
- rsync://mirror.facebook.net/cpan/
- rsync://mirrors1.kernel.org/mirrors/CPAN/
- cpan-sj.viaverio.com::CPAN
+ rsync://ftp.is.co.za/IS-Mirror/ftp.cpan.org/
+ rsync://mirror.ac.za/CPAN/
+ rsync://mirror.zol.co.zw/CPAN/
+ rsync://mirror.dhakacom.com/CPAN/
+ rsync://mirrors.ustc.edu.cn/CPAN/
+ rsync://mirrors.xmu.edu.cn/CPAN/
+ rsync://kambing.ui.ac.id/CPAN/
+ rsync://ftp.jaist.ac.jp/pub/CPAN/
+ rsync://mirror.jre655.com/CPAN/
+ rsync://ftp.kddilabs.jp/cpan/
+ rsync://ftp.nara.wide.ad.jp/cpan/
+ rsync://ftp.riken.jp/cpan/
+ rsync://mirror.neolabs.kz/CPAN/
+ rsync://mirror.qnren.qa/CPAN/
+ rsync://ftp.neowiz.com/CPAN/
+ rsync://mirror.0x.sg/CPAN/
+ rsync://ftp.yzu.edu.tw/pub/CPAN/
+ rsync://ftp.ubuntu-tw.org/CPAN/
+ rsync://mirrors.digipower.vn/CPAN/
+ rsync://cpan.inode.at/CPAN/
+ rsync://ftp.byfly.by/CPAN/
+ rsync://mirror.datacenter.by/CPAN/
+ rsync://ftp.belnet.be/cpan/
+ rsync://cpan.mirror.ba/CPAN/
+ rsync://mirrors.neterra.net/CPAN/
+ rsync://mirrors.netix.net/CPAN/
+ rsync://mirror.dkm.cz/cpan/
+ rsync://mirrors.nic.cz/CPAN/
+ rsync://cpan.mirror.vutbr.cz/cpan/
+ rsync://rsync.nic.funet.fi/CPAN/
+ rsync://ftp.ciril.fr/pub/cpan/
+ rsync://distrib-coffee.ipsl.jussieu.fr/pub/mirrors/cpan/
+ rsync://cpan.mirrors.ovh.net/CPAN/
+ rsync://mirror.de.leaseweb.net/CPAN/
+ rsync://mirror.euserv.net/cpan/
+ rsync://ftp-stud.hs-esslingen.de/CPAN/
+ rsync://ftp.gwdg.de/pub/languages/perl/CPAN/
+ rsync://ftp.hawo.stw.uni-erlangen.de/CPAN/
+ rsync://cpan.mirror.iphh.net/CPAN/
+ rsync://mirror.netcologne.de/cpan/
+ rsync://ftp.halifax.rwth-aachen.de/cpan/
+ rsync://ftp.ntua.gr/CPAN/
+ rsync://mirror.met.hu/CPAN/
+ rsync://ftp.heanet.ie/mirrors/ftp.perl.org/pub/CPAN/
+ rsync://rsync.panu.it/CPAN/
+ rsync://mirror.as43289.net/CPAN/
+ rsync://rsync.cs.uu.nl/CPAN/
+ rsync://mirror.nl.leaseweb.net/CPAN/
+ rsync://ftp.nluug.nl/CPAN/
+ rsync://mirror.transip.net/CPAN/
+ rsync://cpan.uib.no/cpan/
+ rsync://cpan.vianett.no/CPAN/
+ rsync://cpan.perl-hackers.net/CPAN/
+ rsync://cpan.perl.pt/cpan/
+ rsync://mirrors.m247.ro/CPAN/
+ rsync://mirrors.teentelecom.net/CPAN/
+ rsync://cpan.webdesk.ru/CPAN/
+ rsync://mirror.yandex.ru/mirrors/cpan/
+ rsync://mirror.sbb.rs/CPAN/
+ rsync://ftp.acc.umu.se/mirror/CPAN/
+ rsync://rsync.pirbot.com/ftp/cpan/
+ rsync://cpan.ip-connect.vn.ua/CPAN/
+ rsync://rsync.mirror.anlx.net/CPAN/
+ rsync://mirror.bytemark.co.uk/CPAN/
+ rsync://mirror.sax.uk.as61049.net/CPAN/
+ rsync://rsync.mirrorservice.org/cpan.perl.org/CPAN/
+ rsync://ftp.ticklers.org/CPAN/
+ rsync://mirrors.uk2.net/CPAN/
+ rsync://CPAN.mirror.rafal.ca/CPAN/
+ rsync://mirror.csclub.uwaterloo.ca/CPAN/
+ rsync://mirrors.namecheap.com/CPAN/
+ rsync://mirrors.syringanetworks.net/CPAN/
+ rsync://mirror.team-cymru.org/CPAN/
+ rsync://debian.cse.msu.edu/cpan/
+ rsync://mirrors-usa.go-parts.com/mirrors/cpan/
+ rsync://rsync.hoovism.com/CPAN/
+ rsync://mirror.cc.columbia.edu/cpan/
+ rsync://noodle.portalus.net/CPAN/
+ rsync://mirrors.rit.edu/cpan/
+ rsync://mirrors.ibiblio.org/CPAN/
+ rsync://cpan.pair.com/CPAN/
+ rsync://cpan.cs.utah.edu/CPAN/
+ rsync://mirror.cogentco.com/CPAN/
+ rsync://mirror.jmu.edu/CPAN/
+ rsync://mirror.us.leaseweb.net/CPAN/
+ rsync://cpan.mirror.digitalpacific.com.au/cpan/
+ rsync://mirror.internode.on.net/cpan/
+ rsync://uberglobalmirror.com/cpan/
+ rsync://cpan.lagoon.nc/cpan/
+ rsync://mirrors.mmgdesigns.com.ar/CPAN/
+
For an up-to-date listing of CPAN sites,
-see http://www.cpan.org/SITES or ftp://www.cpan.org/SITES .
+see L<http://www.cpan.org/SITES> or L<ftp://www.cpan.org/SITES>.
=head1 Modules: Creation, Use, and Abuse
How to release and distribute a module.
-It's good idea to post an announcement of the availability of your
-module (or the module itself if small) to the comp.lang.perl.announce
-Usenet newsgroup. This will at least ensure very wide once-off
-distribution.
+If possible, register the module with CPAN. Follow the instructions
+and links on:
-If possible, register the module with CPAN. You should
-include details of its location in your announcement.
-
-Some notes about ftp archives: Please use a long descriptive file
-name that includes the version number. Most incoming directories
-will not be readable/listable, i.e., you won't be able to see your
-file after uploading it. Remember to send your email notification
-message as soon as possible after uploading else your file may get
-deleted automatically. Allow time for the file to be processed
-and/or check the file has been processed before announcing its
-location.
-
-FTP Archives for Perl Modules:
-
-Follow the instructions and links on:
-
- http://www.cpan.org/modules/00modlist.long.html
http://www.cpan.org/modules/04pause.html
-or upload to one of these sites:
+and upload to:
- https://pause.kbx.de/pause/
http://pause.perl.org/
-and notify <modules@perl.org>.
+and notify <modules@perl.org>. This will allow anyone to install
+your module using the C<cpan> tool distributed with Perl.
By using the WWW interface you can ask the Upload Server to mirror
your modules from your ftp or WWW site into your own directory on
CPAN!
-Please remember to send me an updated entry for the Module list!
-
=item *
Take care when changing a released module.
You might love it. You might feel that everyone else needs it. But there
might not actually be any real demand for it out there. If you're unsure
-about the demand your module will have, consider sending out feelers
-on the C<comp.lang.perl.modules> newsgroup, or as a last resort, ask the
-modules list at C<modules@perl.org>. Remember that this is a closed list
-with a very long turn-around time - be prepared to wait a good while for
-a response from them.
+about the demand your module will have, consider asking the
+C<module-authors@perl.org> mailing list (send an email to
+C<module-authors-subscribe@perl.org> to subscribe; see
+L<http://lists.perl.org/list/module-authors.html> for more information
+and a link to the archives).
=item Choose a name
Namespace" on PAUSE. Once registered, your module will appear in the
by-module and by-category listings on CPAN.
-=item Announce to clpa
-
-If you have a burning desire to tell the world about your release, post
-an announcement to the moderated C<comp.lang.perl.announce> newsgroup.
-
=item Fix bugs!
Once you start accumulating users, they'll send you bug reports. If
I<storage> of these numbers. The fact that you can store such "large" numbers
does not mean that the I<operations> over these numbers will use all
of the significant digits.
-See L<"Numeric operators and numeric conversions"> for details.)
+See L</"Numeric operators and numeric conversions"> for details.)
In fact numbers stored in the native integer format may be stored either
in the signed native form, or in the unsigned native form. Thus the limits
Note, however, that (unlike most other OO languages) Perl does not
ensure or enforce encapsulation in any way. If you want objects to
actually I<be> opaque you need to arrange for that yourself. This can
-be done in a variety of ways, including using L<"Inside-Out objects">
+be done in a variety of ways, including using L</"Inside-Out objects">
or modules from CPAN.
=head3 Objects Are Blessed; Variables Are Not
C<Moose> lets you define roles the same way you define classes:
- package HasOnOfSwitch;
+ package HasOnOffSwitch;
use Moose::Role;
has is_on => (
print(($foo & 255) + 1, "\n");
-See L<Named Unary Operators> for more discussion of this.
+See L</Named Unary Operators> for more discussion of this.
Also parsed as terms are the S<C<do {}>> and S<C<eval {}>> constructs, as
well as subroutine and method calls, and the anonymous
constructors C<[]> and C<{}>.
-See also L<Quote and Quote-like Operators> toward the end of this section,
+See also L</Quote and Quote-like Operators> toward the end of this section,
as well as L</"I/O Operators">.
=head2 The Arrow Operator
X<-> X<negation, arithmetic>
Unary C<"~"> performs bitwise negation, that is, 1's complement. For
-example, S<C<0666 & ~027>> is 0640. (See also L<Integer Arithmetic> and
-L<Bitwise String Operators>.) Note that the width of the result is
+example, S<C<0666 & ~027>> is 0640. (See also L</Integer Arithmetic> and
+L</Bitwise String Operators>.) Note that the width of the result is
platform-dependent: C<~0> is 32 bits wide on a 32-bit platform, but 64
bits wide on a 64-bit platform, so if you are expecting a certain bit
width, remember to use the C<"&"> operator to mask off the excess bits.
Binary C<<< "<<" >>> returns the value of its left argument shifted left by the
number of bits specified by the right argument. Arguments should be
-integers. (See also L<Integer Arithmetic>.)
+integers. (See also L</Integer Arithmetic>.)
Binary C<<< ">>" >>> returns the value of its left argument shifted right by
the number of bits specified by the right argument. Arguments should
-be integers. (See also L<Integer Arithmetic>.)
+be integers. (See also L</Integer Arithmetic>.)
-If S<C<use integer>> (see L<Integer Arithmetic>) is in force then
+If S<C<use integer>> (see L</Integer Arithmetic>) is in force then
signed C integers are used (I<arithmetic shift>), otherwise unsigned C
integers are used (I<logical shift>), even for negative shiftees.
In arithmetic right shift the sign bit is replicated on the left,
equivalent to S<C<-f "$file.bak">>.
X<-X> X<filetest> X<operator, filetest>
-See also L<"Terms and List Operators (Leftward)">.
+See also L</"Terms and List Operators (Leftward)">.
=head2 Relational Operators
X<relational operator> X<operator, relational>
Binary C<"&"> returns its operands ANDed together bit by bit. Although no
warning is currently raised, the result is not well defined when this operation
is performed on operands that aren't either numbers (see
-L<Integer Arithmetic>) nor bitstrings (see L<Bitwise String Operators>).
+L</Integer Arithmetic>) nor bitstrings (see L</Bitwise String Operators>).
Note that C<"&"> has lower priority than relational operators, so for example
the parentheses are essential in a test like
Although no warning is currently raised, the results are not well
defined when these operations are performed on operands that aren't either
-numbers (see L<Integer Arithmetic>) nor bitstrings (see L<Bitwise String
+numbers (see L</Integer Arithmetic>) nor bitstrings (see L</Bitwise String
Operators>).
Note that C<"|"> and C<"^"> have lower priority than relational operators, so
Used on numbers, the bitwise operators (C<&> C<|> C<^> C<~> C<< << >>
C<< >> >>) always produce integral results. (But see also
-L<Bitwise String Operators>.) However, S<C<use integer>> still has meaning for
+L</Bitwise String Operators>.) However, S<C<use integer>> still has meaning for
them. By default, their results are interpreted as unsigned integers, but
if S<C<use integer>> is in effect, their results are interpreted
as signed integers. For example, C<~0> usually evaluates to a large
and pass C<$buf> to your send routine. Some protocols demand that the
count should include the length of the count itself: then just add 4
-to the data length. (But make sure to read L<"Lengths and Widths"> before
+to the data length. (But make sure to read L</"Lengths and Widths"> before
you really code this!)
You will probably find these modifiers even more useful if you have
to deal with big- or little-endian C structures. Be sure to read
-L<"Packing and Unpacking C Structures"> for more on that.
+L</"Packing and Unpacking C Structures"> for more on that.
=head2 Floating point Numbers
deliberate in your decision.
The material below is separated into three main sections: main issues of
-portability (L<"ISSUES">), platform-specific issues (L<"PLATFORMS">), and
+portability (L</"ISSUES">), platform-specific issues (L</"PLATFORMS">), and
built-in Perl functions that behave differently on various ports
-(L<"FUNCTION IMPLEMENTATIONS">).
+(L</"FUNCTION IMPLEMENTATIONS">).
This information should not be considered complete; it includes possibly
transient information about idiosyncrasies of some of the ports, almost
consider keeping the platform-specific code in one place, making porting
to other platforms easier. Use the C<Config> module and the special
variable C<$^O> to differentiate platforms, as described in
-L<"PLATFORMS">.
+L</"PLATFORMS">.
Beware of the "else syndrome":
put wrappers around your scripts.
Newline (C<\n>) is translated as C<\015\012> by STDIO when reading from
-and writing to files (see L<"Newlines">). C<binmode(FILEHANDLE)>
+and writing to files (see L</"Newlines">). C<binmode(FILEHANDLE)>
will keep C<\n> translated as C<\012> for that filehandle. Since it is a
no-op on other systems, C<binmode> should be used for cross-platform code
that deals with binary data. That's assuming you realize in advance
C<pack>, C<print>, C<printf>, C<ord>, C<sort>, C<sprintf>, C<unpack>), as
well as bit-fiddling with ASCII constants using operators like C<^>, C<&>
and C<|>, not to mention dealing with socket interfaces to ASCII computers
-(see L<"Newlines">).
+(see L</"Newlines">).
Fortunately, most web servers for the mainframe will correctly
translate the C<\n> in the following statement to its ASCII equivalent
pattern will still see the values which were localized in earlier blocks.
These accumulated localizations are undone either at the end of a
successful match, or if the assertion is backtracked (compare
-L<"Backtracking">). For example,
+L</"Backtracking">). For example,
$_ = 'a' x 8;
m<
The assignment to C<$^R> above is properly localized, so the old
value of C<$^R> is restored if the assertion is backtracked; compare
-L<"Backtracking">.
+L</"Backtracking">.
Note that the special variable C<$^N> is particularly useful with code
blocks to capture the results of submatches in variables without having to
that a I<standalone> C<pattern> would match if anchored at the given
position, and it matches I<nothing other than this substring>. This
construct is useful for optimizations of what would otherwise be
-"eternal" matches, because it will not backtrack (see L<"Backtracking">).
+"eternal" matches, because it will not backtrack (see L</"Backtracking">).
It may also be useful in places where the "grab all you can, and do not
give anything back" semantic is desirable.
characters C<a> at the beginning of string, leaving no C<a> for
C<ab> to match. In contrast, C<a*ab> will match the same as C<a+b>,
since the match of the subgroup C<a*> is influenced by the following
-group C<ab> (see L<"Backtracking">). In particular, C<a*> inside
+group C<ab> (see L<
/"Backtracking">). In particular, C<a*> inside
C<a*ab> will match fewer characters than a standalone C<a*>, since
this makes the tail match.
NOTE: This section presents an abstract approximation of regular
expression behavior. For a more rigorous (and complicated) view of
the rules involved in selecting a match among possible alternatives,
-see L<Combining RE Pieces>.
+see L</Combining RE Pieces>.
A fundamental feature of regular expression matching involves the
notion called I<backtracking>, which is currently used (when needed)
The higher-level loops preserve an additional state between iterations:
whether the last match was zero-length. To break the loop, the following
match after a zero-length match is prohibited to have a length of zero.
-This prohibition interacts with backtracking (see L<"Backtracking">),
+This prohibition interacts with backtracking (see L</"Backtracking">),
and so the I<second best> match is chosen if the I<best> match is of
zero length.
Such combinations can include alternatives, leading to a problem of choice:
if we match a regular expression C<a|ab> against C<"abc">, will it match
substring C<"a"> or C<"ab">? One way to describe which substring is
-actually matched is the concept of backtracking (see L<"Backtracking">).
+actually matched is the concept of backtracking (see L</"Backtracking">).
However, this description is too low-level and makes you think
in terms of a particular implementation.
=back
There are various other synonyms that can be used besides the names
-listed in the table. For example, C<\p{PosixAlpha}> can be written as
+listed in the table. For example, C<\p{XPosixAlpha}> can be written as
C<\p{Alpha}>. All are listed in
L<perluniprops/Properties accessible through \p{} and \P{}>.
C<re_intuit_start()> is responsible for handling start points and no-match
optimisations as determined by the results of the analysis done by
-C<study_chunk()> (and described in L<Peep-hole Optimisation and Analysis>).
+C<study_chunk()> (and described in L</Peep-hole Optimisation and Analysis>).
The basic structure of this routine is to try to find the start- and/or
end-points of where the pattern could match, and to ensure that the string
have a match.
To take a closer look at how the engine does optimizations, see the
-section L<"Pragmas and debugging"> below.
+section L</"Pragmas and debugging"> below.
More fun with C<?{}>:
Contained in the file specified by the first filename on the command line.
(Note that systems supporting the C<#!> notation invoke interpreters this
-way. See L<Location of Perl>.)
+way. See L</Location of Perl>.)
=item 3.
As an alternative, specify a number instead of list of letters (e.g.,
B<-D14> is equivalent to B<-Dtls>):
- 1 p Tokenizing and parsing (with v, displays parse stack)
- 2 s Stack snapshots (with v, displays all stacks)
- 4 l Context (loop) stack processing
- 8 t Trace execution
- 16 o Method and overloading resolution
- 32 c String/numeric conversions
- 64 P Print profiling info, source file input state
- 128 m Memory and SV allocation
- 256 f Format processing
- 512 r Regular expression parsing and execution
- 1024 x Syntax tree dump
- 2048 u Tainting checks
- 4096 U Unofficial, User hacking (reserved for private,
- unreleased use)
- 8192 H Hash dump -- usurps values()
- 16384 X Scratchpad allocation
- 32768 D Cleaning up
- 65536 S Op slab allocation
- 131072 T Tokenizing
- 262144 R Include reference counts of dumped variables (eg when
- using -Ds)
- 524288 J show s,t,P-debug (don't Jump over) on opcodes within
- package DB
- 1048576 v Verbose: use in conjunction with other flags
- 2097152 C Copy On Write
- 4194304 A Consistency checks on internal structures
- 8388608 q quiet - currently only suppresses the "EXECUTING"
- message
- 16777216 M trace smart match resolution
- 33554432 B dump suBroutine definitions, including special Blocks
- like BEGIN
- 67108864 L trace Locale-related info; what gets output is very
- subject to change
+ 1 p Tokenizing and parsing (with v, displays parse
+ stack)
+ 2 s Stack snapshots (with v, displays all stacks)
+ 4 l Context (loop) stack processing
+ 8 t Trace execution
+ 16 o Method and overloading resolution
+ 32 c String/numeric conversions
+ 64 P Print profiling info, source file input state
+ 128 m Memory and SV allocation
+ 256 f Format processing
+ 512 r Regular expression parsing and execution
+ 1024 x Syntax tree dump
+ 2048 u Tainting checks
+ 4096 U Unofficial, User hacking (reserved for private,
+ unreleased use)
+ 8192 H Hash dump -- usurps values()
+ 16384 X Scratchpad allocation
+ 32768 D Cleaning up
+ 65536 S Op slab allocation
+ 131072 T Tokenizing
+ 262144 R Include reference counts of dumped variables
+ (eg when using -Ds)
+ 524288 J show s,t,P-debug (don't Jump over) on opcodes within
+ package DB
+ 1048576 v Verbose: use in conjunction with other flags
+ 2097152 C Copy On Write
+ 4194304 A Consistency checks on internal structures
+ 8388608 q quiet - currently only suppresses the "EXECUTING"
+ message
+ 16777216 M trace smart match resolution
+ 33554432 B dump suBroutine definitions, including special
+ Blocks like BEGIN
+ 67108864 L trace Locale-related info; what gets output is very
+ subject to change
+ 134217728 i trace PerlIO layer processing. Set PERLIO_DEBUG to
+ the filename to trace to.
All these flags require B<-DDEBUGGING> when you compile the Perl
executable (but see C<:opd> in L<Devel::Peek> or L<re/'debug' mode>
=item PERLIO_DEBUG
X<PERLIO_DEBUG>
-If set to the name of a file or device, certain operations of PerlIO
-subsystem will be logged to that file, which is opened in append mode.
-Typical uses are in Unix:
+If set to the name of a file or device when Perl is run with the
+B<-Di> command-line switch, the logging of certain operations of
+the PerlIO subsystem will be redirected to the specified file rather
+than going to stderr, which is the default. The file is opened in append
+mode. Typical uses are in Unix:
- % env PERLIO_DEBUG=/dev/tty perl script ...
+ % env PERLIO_DEBUG=/tmp/perlio.log perl -Di script ...
and under Win32, the approximately equivalent:
> set PERLIO_DEBUG=CON
- perl script ...
+ perl -Di script ...
-This functionality is disabled for setuid scripts and for scripts run
-with B<-T>.
+This functionality is disabled for setuid scripts, for scripts run
+with B<-T>, and for scripts run on a Perl built without C<-DDEBUGGING>
+support.
=item PERLLIB
X<PERLLIB>
Perl does not have named formal parameters. In practice all you
do is assign to a C<my()> list of these. Variables that aren't
declared to be private are global variables. For gory details
-on creating private variables, see L<"Private Variables via my()">
-and L<"Temporary Values via local()">. To create protected
+on creating private variables, see L</"Private Variables via my()">
+and L</"Temporary Values via local()">. To create protected
environments for a set of functions in a separate package (and
probably a separate file), see L<perlmod/"Packages">.
X<formal parameter> X<parameter, formal>
Like the flattened incoming parameter list, the return list is also
flattened on return. So all you have managed to do here is stored
everything in C<@a> and made C<@b> empty. See
-L<Pass by Reference> for alternatives.
+L</Pass by Reference> for alternatives.
A subroutine may be called using an explicit C<&> prefix. The
C<&> is optional in modern Perl, as are parentheses if the
=head2 Lexical Subroutines
X<my sub> X<state sub> X<our sub> X<subroutine, lexical>
-B<WARNING>: Lexical subroutines are still experimental. The feature may be
-modified or removed in future versions of Perl.
-
-Lexical subroutines are only available under the C<use feature
-'lexical_subs'> pragma, which produces a warning unless the
-"experimental::lexical_subs" warnings category is disabled.
-
Beginning with Perl 5.18, you can declare a private subroutine with C<my>
or C<state>. As with state variables, the C<state> keyword is only
available under C<use feature 'state'> or C<use 5.010> or higher.
+Prior to Perl 5.26, lexical subroutines were deemed experimental and were
+available only under the C<use feature 'lexical_subs'> pragma. They also
+produced a warning unless the "experimental::lexical_subs" warnings
+category was disabled.
+
These subroutines are only visible within the block in which they are
declared, and only after that declaration:
+ # Include these two lines if your code is intended to run under Perl
+ # versions earlier than 5.26.
no warnings "experimental::lexical_subs";
use feature 'lexical_subs';
So, in general, "state" subroutines are faster. But "my" subs are
necessary if you want to create closures:
- no warnings "experimental::lexical_subs";
- use feature 'lexical_subs';
-
sub whatever {
my $x = shift;
my sub inner {
The two main uses for this are to switch back to using the package sub
inside an inner scope:
- no warnings "experimental::lexical_subs";
- use feature 'lexical_subs';
-
sub foo { ... }
sub bar {
package MySneakyModule;
- no warnings "experimental::lexical_subs";
- use feature 'lexical_subs';
-
our sub do_something { ... }
sub do_something_with_caller {
Under the current implementation, the C<foreach> loop can be
anywhere within the C<when> modifier's dynamic scope, but must be
-within the C<given> block's lexical scope. This restricted may
-be relaxed in a future release. See L<"Switch Statements"> below.
+within the C<given> block's lexical scope. This restriction may
+be relaxed in a future release. See L</"Switch Statements"> below.
=head2 Compound Statements
X<statement, compound> X<block> X<bracket, curly> X<curly bracket> X<brace>
}}
This is caused by the fact that a block by itself acts as a loop that
-executes once, see L<"Basic BLOCKs">.
+executes once, see L</"Basic BLOCKs">.
The form C<while/if BLOCK BLOCK>, available in Perl 4, is no longer
available. Replace any occurrence of C<if BLOCK> by C<if (do BLOCK)>.
PUSHi(av_tindex(array) + 1);
}
else if (gimme == G_ARRAY) {
+ if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
+ const I32 flags = is_lvalue_sub();
+ if (flags && !(flags & OPpENTERSUB_INARGS))
+ /* diag_listed_as: Can't modify %s in %s */
+ Perl_croak(aTHX_
+ "Can't modify keys on array in list assignment");
+ }
+ {
IV n = Perl_av_len(aTHX_ array);
IV i;
EXTEND(SP, n + 1);
- if (PL_op->op_type == OP_AKEYS) {
+ if ( PL_op->op_type == OP_AKEYS
+ || ( PL_op->op_type == OP_AVHVSWITCH
+ && (PL_op->op_private & 3) + OP_AEACH == OP_AKEYS ))
+ {
for (i = 0; i <= n; i++) {
mPUSHi(i);
}
PUSHs(elem ? *elem : &PL_sv_undef);
}
}
+ }
}
RETURN;
}
if (flags) {
if (!(flags & OPpENTERSUB_INARGS))
/* diag_listed_as: Can't modify %s in %s */
- Perl_croak(aTHX_ "Can't modify key/value hash slice in list assignment");
+ Perl_croak(aTHX_ "Can't modify key/value hash slice in %s assignment",
+ GIMME_V == G_ARRAY ? "list" : "scalar");
lval = flags;
}
}
DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
}
+static void
+S_maybe_unwind_defav(pTHX)
+{
+ if (CX_CUR()->cx_type & CXp_HASARGS) {
+ PERL_CONTEXT *cx = CX_CUR();
+
+ assert(CxHASARGS(cx));
+ cx_popsub_args(cx);
+ cx->cx_type &= ~CXp_HASARGS;
+ }
+}
+
/* For sorting out arguments passed to a &CORE:: subroutine */
PP(pp_coreargs)
{
svp++;
}
RETURN;
+ case OA_AVREF:
+ if (!numargs) {
+ GV *gv;
+ if (CvUNIQUE(find_runcv_where(FIND_RUNCV_level_eq,1,NULL)))
+ gv = PL_argvgv;
+ else {
+ S_maybe_unwind_defav(aTHX);
+ gv = PL_defgv;
+ }
+ PUSHs((SV *)GvAVn(gv));
+ break;
+ }
+ if (!svp || !*svp || !SvROK(*svp)
+ || SvTYPE(SvRV(*svp)) != SVt_PVAV)
+ DIE(aTHX_
+ /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
+ "Type of arg %d to &CORE::%s must be array reference",
+ whicharg, PL_op_desc[opnum]
+ );
+ PUSHs(SvRV(*svp));
+ break;
case OA_HVREF:
if (!svp || !*svp || !SvROK(*svp)
- || SvTYPE(SvRV(*svp)) != SVt_PVHV)
+ || ( SvTYPE(SvRV(*svp)) != SVt_PVHV
+ && ( opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
+ || SvTYPE(SvRV(*svp)) != SVt_PVAV )))
DIE(aTHX_
/* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
- "Type of arg %d to &CORE::%s must be hash reference",
- whicharg, OP_DESC(PL_op->op_next)
+ "Type of arg %d to &CORE::%s must be hash%s reference",
+ whicharg, PL_op_desc[opnum],
+ opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
+ ? ""
+ : " or array"
);
PUSHs(SvRV(*svp));
break;
: "reference to one of [$@%*]"
);
PUSHs(SvRV(*svp));
- if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv
- && CX_CUR()->cx_type & CXp_HASARGS) {
+ if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv) {
/* Undo @_ localisation, so that sub exit does not undo
part of our undeffing. */
- PERL_CONTEXT *cx = CX_CUR();
-
- assert(CxHASARGS(cx));
- cx_popsub_args(cx);;
- cx->cx_type &= ~CXp_HASARGS;
+ S_maybe_unwind_defav(aTHX);
}
}
break;
RETURN;
}
+PP(pp_avhvswitch)
+{
+ dVAR; dSP;
+ return PL_ppaddr[
+ (SvTYPE(TOPs) == SVt_PVAV ? OP_AEACH : OP_EACH)
+ + (PL_op->op_private & 3)
+ ](aTHX);
+}
+
PP(pp_runcv)
{
dSP;
PERL_CALLCONV OP *Perl_pp_aslice(pTHX);
PERL_CALLCONV OP *Perl_pp_atan2(pTHX);
PERL_CALLCONV OP *Perl_pp_av2arylen(pTHX);
+PERL_CALLCONV OP *Perl_pp_avhvswitch(pTHX);
PERL_CALLCONV OP *Perl_pp_backtick(pTHX);
PERL_CALLCONV OP *Perl_pp_bind(pTHX);
PERL_CALLCONV OP *Perl_pp_binmode(pTHX);
TAINT_PROPER("socket");
fd = PerlSock_socket(domain, type, protocol);
if (fd < 0) {
- SETERRNO(EBADF,RMS_IFI);
RETPUSHUNDEF;
}
IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
}
PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
if (PL_laststatval < 0) {
+ dSAVE_ERRNO;
(void)PerlIO_close(fp);
- SETERRNO(EBADF,RMS_IFI);
+ RESTORE_ERRNO;
FT_RETURNUNDEF;
}
PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
#define PERL_ARGS_ASSERT_HFREE_NEXT_ENTRY \
assert(hv); assert(indexp)
#endif
+#if defined(PERL_IN_LOCALE_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_MATHOMS_C)
+# if defined(USE_LOCALE_COLLATE)
+PERL_CALLCONV char* Perl__mem_collxfrm(pTHX_ const char* input_string, STRLEN len, STRLEN* xlen, bool utf8);
+#define PERL_ARGS_ASSERT__MEM_COLLXFRM \
+ assert(input_string); assert(xlen)
+# endif
+#endif
#if defined(PERL_IN_MALLOC_C)
STATIC int S_adjust_size_and_find_bucket(size_t *nbytes_p);
#define PERL_ARGS_ASSERT_ADJUST_SIZE_AND_FIND_BUCKET \
PERL_CALLCONV int Perl_magic_setcollxfrm(pTHX_ SV* sv, MAGIC* mg);
#define PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM \
assert(sv); assert(mg)
-PERL_CALLCONV char* Perl_mem_collxfrm(pTHX_ const char* s, STRLEN len, STRLEN* xlen);
+#ifndef NO_MATHOMS
+PERL_CALLCONV char* Perl_mem_collxfrm(pTHX_ const char* input_string, STRLEN len, STRLEN* xlen);
#define PERL_ARGS_ASSERT_MEM_COLLXFRM \
- assert(s); assert(xlen)
+ assert(input_string); assert(xlen)
+#endif
/* PERL_CALLCONV char* sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp); */
PERL_CALLCONV char* Perl_sv_collxfrm_flags(pTHX_ SV *const sv, STRLEN *const nxp, I32 const flags);
#define PERL_ARGS_ASSERT_SV_COLLXFRM_FLAGS \
#endif /* H_REGCHARCLASS */
/* Generated from:
- * cb3170dd603ad12ba0299440e99e8f50a8afde60ade2ffcbf1ff4a8a53854b90 lib/Unicode/UCD.pm
+ * 66726fe32be96a422e8c9b45bc9daf61e068d988c99ff41112972ef721365521 lib/Unicode/UCD.pm
* ae98bec7e4f0564758eed81eca5015481ba32581f8a735a825b71b3bba714450 lib/unicore/ArabicShaping.txt
* 1687fe5994eb7e5c0dab8503fc2a1b3b479d91af9d3b8055941c9bd791f7d0b5 lib/unicore/BidiBrackets.txt
* 350d1302116194b0b21def287434b55c5088098fbc726e879f7420a391965643 lib/unicore/BidiMirroring.txt
scan_frame *frame_head;
scan_frame *frame_last;
U32 frame_count;
+ AV *warn_text;
#ifdef ADD_TO_REGEXEC
char *starttry; /* -Dr: where regtry was called. */
#define RExC_starttry (pRExC_state->starttry)
#define RExC_frame_count (pRExC_state->frame_count)
#define RExC_strict (pRExC_state->strict)
#define RExC_study_started (pRExC_state->study_started)
+#define RExC_warn_text (pRExC_state->warn_text)
/* 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
#endif
}
+ pRExC_state->warn_text = NULL;
pRExC_state->code_blocks = NULL;
pRExC_state->num_code_blocks = 0;
* length there. The preface says to incorporate its examples into your
* code at your own risk.
*
- * The algorithm is like a merge sort.
- *
- * XXX A potential performance improvement is to keep track as we go along
- * if only one of the inputs contributes to the result, meaning the other
- * is a subset of that one. In that case, we can skip the final copy and
- * return the larger of the input lists, but then outside code might need
- * to keep track of whether to free the input list or not */
+ * The algorithm is like a merge sort. */
const UV* array_a; /* a's array */
const UV* array_b;
/* running count, as explained in the algorithm source book; items are
* stopped accumulating and are output when the count changes to/from 0.
- * The count is incremented when we start a range that's in the set, and
- * decremented when we start a range that's not in the set. So its range
- * is 0 to 2. Only when the count is zero is something not in the set.
- */
+ * The count is incremented when we start a range that's in an input's set,
+ * and decremented when we start a range that's not in a set. So this
+ * variable can be 0, 1, or 2. When it is 0 neither input is in their set,
+ * and hence nothing goes into the union; 1, just one of the inputs is in
+ * its set (and its current range gets added to the union); and 2 when both
+ * inputs are in their sets. */
UV count = 0;
PERL_ARGS_ASSERT__INVLIST_UNION_MAYBE_COMPLEMENT_2ND;
invlist_replace_list_destroys_src(*output, u);
SvREFCNT_dec_NN(u);
- return;
+ return;
}
if (a == NULL || ((len_a = _invlist_len(a)) == 0)) {
u = _new_invlist(len_a + len_b);
/* Will contain U+0000 if either component does */
- array_u = _invlist_array_init(u, (len_a > 0 && array_a[0] == 0)
- || (len_b > 0 && array_b[0] == 0));
+ array_u = _invlist_array_init(u, ( len_a > 0 && array_a[0] == 0)
+ || (len_b > 0 && array_b[0] == 0));
- /* Go through each list item by item, stopping when exhausted one of
+ /* Go through each input list item by item, stopping when exhausted one of
* them */
while (i_a < len_a && i_b < len_b) {
UV cp; /* The element to potentially add to the union's array */
/* We need to take one or the other of the two inputs for the union.
* Since we are merging two sorted lists, we take the smaller of the
- * next items. In case of a tie, we take the one that is in its set
- * first. If we took one not in the set first, it would decrement the
- * count, possibly to 0 which would cause it to be output as ending the
- * range, and the next time through we would take the same number, and
- * output it again as beginning the next range. By doing it the
- * opposite way, there is no possibility that the count will be
- * momentarily decremented to 0, and thus the two adjoining ranges will
- * be seamlessly merged. (In a tie and both are in the set or both not
- * in the set, it doesn't matter which we take first.) */
- if (array_a[i_a] < array_b[i_b]
- || (array_a[i_a] == array_b[i_b]
+ * next items. In case of a tie, we take first the one that is in its
+ * set. If we first took the one not in its set, it would decrement
+ * the count, possibly to 0 which would cause it to be output as ending
+ * the range, and the next time through we would take the same number,
+ * and output it again as beginning the next range. By doing it the
+ * opposite way, there is no possibility that the count will be
+ * momentarily decremented to 0, and thus the two adjoining ranges will
+ * be seamlessly merged. (In a tie and both are in the set or both not
+ * in the set, it doesn't matter which we take first.) */
+ if ( array_a[i_a] < array_b[i_b]
+ || ( array_a[i_a] == array_b[i_b]
&& ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
{
cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
- cp= array_a[i_a++];
+ cp = array_a[i_a++];
}
else {
cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
}
}
- /* Here, we are finished going through at least one of the lists, which
- * means there is something remaining in at most one. We check if the list
- * that hasn't been exhausted is positioned such that we are in the middle
- * of a range in its set or not. (i_a and i_b point to the element beyond
- * the one we care about.) If in the set, we decrement 'count'; if 0, there
- * is potentially more to output.
- * There are four cases:
- * 1) Both weren't in their sets, count is 0, and remains 0. What's left
- * in the union is entirely from the non-exhausted set.
- * 2) Both were in their sets, count is 2. Nothing further should
- * be output, as everything that remains will be in the exhausted
- * list's set, hence in the union; decrementing to 1 but not 0 insures
- * that
- * 3) the exhausted was in its set, non-exhausted isn't, count is 1.
- * Nothing further should be output because the union includes
- * everything from the exhausted set. Not decrementing ensures that.
- * 4) the exhausted wasn't in its set, non-exhausted is, count is 1;
- * decrementing to 0 insures that we look at the remainder of the
- * non-exhausted set */
+
+ /* The loop above increments the index into exactly one of the input lists
+ * each iteration, and ends when either index gets to its list end. That
+ * means the other index is lower than its end, and so something is
+ * remaining in that one. We decrement 'count', as explained below, if
+ * that list is in its set. (i_a and i_b each currently index the element
+ * beyond the one we care about.) */
if ( (i_a != len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
|| (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
{
count--;
}
- /* The final length is what we've output so far, plus what else is about to
- * be output. (If 'count' is non-zero, then the input list we exhausted
- * has everything remaining up to the machine's limit in its set, and hence
- * in the union, so there will be no further output. */
- len_u = i_u;
- if (count == 0) {
- /* At most one of the subexpressions will be non-zero */
- len_u += (len_a - i_a) + (len_b - i_b);
+ /* Above we decremented 'count' if the list that had unexamined elements in
+ * it was in its set. This has made it so that 'count' being non-zero
+ * means there isn't anything left to output; and 'count' equal to 0 means
+ * that what is left to output is precisely that which is left in the
+ * non-exhausted input list.
+ *
+ * To see why, note first that the exhausted input obviously has nothing
+ * left to add to the union. If it was in its set at its end, that means
+ * the set extends from here to the platform's infinity, and hence so does
+ * the union and the non-exhausted set is irrelevant. The exhausted set
+ * also contributed 1 to 'count'. If 'count' was 2, it got decremented to
+ * 1, but if it was 1, the non-exhausted set wasn't in its set, and so
+ * 'count' remains at 1. This is consistent with the decremented 'count'
+ * != 0 meaning there's nothing left to add to the union.
+ *
+ * But if the exhausted input wasn't in its set, it contributed 0 to
+ * 'count', and the rest of the union will be whatever the other input is.
+ * If 'count' was 0, neither list was in its set, and 'count' remains 0;
+ * otherwise it gets decremented to 0. This is consistent with 'count'
+ * == 0 meaning the remainder of the union is whatever is left in the
+ * non-exhausted list. */
+ if (count != 0) {
+ len_u = i_u;
+ }
+ else {
+ IV copy_count = len_a - i_a;
+ if (copy_count > 0) { /* The non-exhausted input is 'a' */
+ Copy(array_a + i_a, array_u + i_u, copy_count, UV);
+ }
+ else { /* The non-exhausted input is b */
+ copy_count = len_b - i_b;
+ Copy(array_b + i_b, array_u + i_u, copy_count, UV);
+ }
+ len_u = i_u + copy_count;
}
/* Set the result to the final length, which can change the pointer to
array_u = invlist_array(u);
}
- /* When 'count' is 0, the list that was exhausted (if one was shorter than
- * the other) ended with everything above it not in its set. That means
- * that the remaining part of the union is precisely the same as the
- * non-exhausted list, so can just copy it unchanged. (If both lists were
- * exhausted at the same time, then the operations below will be both 0.)
- */
- if (count == 0) {
- IV copy_count; /* At most one will have a non-zero copy count */
- if ((copy_count = len_a - i_a) > 0) {
- Copy(array_a + i_a, array_u + i_u, copy_count, UV);
- }
- else if ((copy_count = len_b - i_b) > 0) {
- Copy(array_b + i_b, array_u + i_u, copy_count, UV);
- }
- }
-
/* If the output is not to overwrite either of the inputs, just return the
* calculated union */
if (a != *output && b != *output) {
* shown [perl #127392] that if the input is a mortal, we can get a
* huge build-up of these during regex compilation before they get
* freed. So for that case, replace just the input's interior with
- * the output's, and then free the output */
+ * the union's, and then free the union */
assert(! invlist_is_iterating(*output));
UV i_b = 0;
UV i_r = 0;
- /* running count, as explained in the algorithm source book; items are
- * stopped accumulating and are output when the count changes to/from 2.
- * The count is incremented when we start a range that's in the set, and
- * decremented when we start a range that's not in the set. So its range
- * is 0 to 2. Only when the count is 2 is something in the intersection.
- */
+ /* running count of how many of the two inputs are postitioned at ranges
+ * that are in their sets. As explained in the algorithm source book,
+ * items are stopped accumulating and are output when the count changes
+ * to/from 2. The count is incremented when we start a range that's in an
+ * input's set, and decremented when we start a range that's not in a set.
+ * Only when it is 2 are we in the intersection. */
UV count = 0;
PERL_ARGS_ASSERT__INVLIST_INTERSECTION_MAYBE_COMPLEMENT_2ND;
r= _new_invlist(len_a + len_b);
/* Will contain U+0000 iff both components do */
- array_r = _invlist_array_init(r, len_a > 0 && array_a[0] == 0
- && len_b > 0 && array_b[0] == 0);
+ array_r = _invlist_array_init(r, len_a > 0 && array_a[0] == 0
+ && len_b > 0 && array_b[0] == 0);
/* Go through each list item by item, stopping when exhausted one of
* them */
/* We need to take one or the other of the two inputs for the
* intersection. Since we are merging two sorted lists, we take the
- * smaller of the next items. In case of a tie, we take the one that
- * is not in its set first (a difference from the union algorithm). If
- * we took one in the set first, it would increment the count, possibly
- * to 2 which would cause it to be output as starting a range in the
- * intersection, and the next time through we would take that same
- * number, and output it again as ending the set. By doing it the
- * opposite of this, there is no possibility that the count will be
- * momentarily incremented to 2. (In a tie and both are in the set or
- * both not in the set, it doesn't matter which we take first.) */
- if (array_a[i_a] < array_b[i_b]
- || (array_a[i_a] == array_b[i_b]
+ * smaller of the next items. In case of a tie, we take first the one
+ * that is not in its set (a difference from the union algorithm). If
+ * we first took the one in its set, it would increment the count,
+ * possibly to 2 which would cause it to be output as starting a range
+ * in the intersection, and the next time through we would take that
+ * same number, and output it again as ending the set. By doing the
+ * opposite of this, there is no possibility that the count will be
+ * momentarily incremented to 2. (In a tie and both are in the set or
+ * both not in the set, it doesn't matter which we take first.) */
+ if ( array_a[i_a] < array_b[i_b]
+ || ( array_a[i_a] == array_b[i_b]
&& ! ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
{
cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
- cp= array_a[i_a++];
+ cp = array_a[i_a++];
}
else {
cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
}
count--;
}
- }
- /* Here, we are finished going through at least one of the lists, which
- * means there is something remaining in at most one. We check if the list
- * that has been exhausted is positioned such that we are in the middle
- * of a range in its set or not. (i_a and i_b point to elements 1 beyond
- * the ones we care about.) There are four cases:
- * 1) Both weren't in their sets, count is 0, and remains 0. There's
- * nothing left in the intersection.
- * 2) Both were in their sets, count is 2 and perhaps is incremented to
- * above 2. What should be output is exactly that which is in the
- * non-exhausted set, as everything it has is also in the intersection
- * set, and everything it doesn't have can't be in the intersection
- * 3) The exhausted was in its set, non-exhausted isn't, count is 1, and
- * gets incremented to 2. Like the previous case, the intersection is
- * everything that remains in the non-exhausted set.
- * 4) the exhausted wasn't in its set, non-exhausted is, count is 1, and
- * remains 1. And the intersection has nothing more. */
+ }
+ /* The loop above increments the index into exactly one of the input lists
+ * each iteration, and ends when either index gets to its list end. That
+ * means the other index is lower than its end, and so something is
+ * remaining in that one. We increment 'count', as explained below, if the
+ * exhausted list was in its set. (i_a and i_b each currently index the element
+ * beyond the one we care about.) */
if ( (i_a == len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
- || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
+ || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
{
count++;
}
- /* The final length is what we've output so far plus what else is in the
- * intersection. At most one of the subexpressions below will be non-zero
- * */
- len_r = i_r;
- if (count >= 2) {
- len_r += (len_a - i_a) + (len_b - i_b);
+ /* Above we incremented 'count' if the exhausted list was in its set. This
+ * has made it so that 'count' being below 2 means there is nothing left to
+ * output; otheriwse what's left to add to the intersection is precisely
+ * that which is left in the non-exhausted input list.
+ *
+ * To see why, note first that the exhausted input obviously has nothing
+ * left to affect the intersection. If it was in its set at its end, that
+ * means the set extends from here to the platform's infinity, and hence
+ * anything in the non-exhausted's list will be in the intersection, and
+ * anything not in it won't be. Hence, the rest of the intersection is
+ * precisely what's in the non-exhausted list The exhausted set also
+ * contributed 1 to 'count', meaning 'count' was at least 1. Incrementing
+ * it means 'count' is now at least 2. This is consistent with the
+ * incremented 'count' being >= 2 means to add the non-exhausted list to
+ * the intersection.
+ *
+ * But if the exhausted input wasn't in its set, it contributed 0 to
+ * 'count', and the intersection can't include anything further; the
+ * non-exhausted set is irrelevant. 'count' was at most 1, and doesn't get
+ * incremented. This is consistent with 'count' being < 2 meaning nothing
+ * further to add to the intersection. */
+ if (count < 2) { /* Nothing left to put in the intersection. */
+ len_r = i_r;
+ }
+ else { /* copy the non-exhausted list, unchanged. */
+ IV copy_count = len_a - i_a;
+ if (copy_count > 0) { /* a is the one with stuff left */
+ Copy(array_a + i_a, array_r + i_r, copy_count, UV);
+ }
+ else { /* b is the one with stuff left */
+ copy_count = len_b - i_b;
+ Copy(array_b + i_b, array_r + i_r, copy_count, UV);
+ }
+ len_r = i_r + copy_count;
}
/* Set the result to the final length, which can change the pointer to
FAIL2("panic: regpiece returned NULL, flags=%#"UVxf"", (UV) flags);
}
else if (ret == NULL)
- ret = latest;
+ ret = latest;
*flagp |= flags&(HASWIDTH|POSTPONED);
if (chain == NULL) /* First piece. */
*flagp |= flags&SPSTART;
/*
- regatom - the lowest level
- Try to identify anything special at the start of the pattern. If there
- is, then handle it as required. This may involve generating a single regop,
- such as for an assertion; or it may involve recursing, such as to
- handle a () structure.
+ Try to identify anything special at the start of the current parse position.
+ If there is, then handle it as required. This may involve generating a
+ single regop, such as for an assertion; or it may involve recursing, such as
+ to handle a () structure.
If the string doesn't start with something special then we gobble up
- as much literal text as we can.
+ as much literal text as we can. If we encounter a quantifier, we have to
+ back off the final literal character, as that quantifier applies to just it
+ and not to the whole string of literals.
Once we have been able to handle whatever type of thing started the
sequence, we return.
|| UTF8_IS_INVARIANT(UCHARAT(RExC_parse))
|| UTF8_IS_START(UCHARAT(RExC_parse)));
+ /* Here, we have a literal character. Find the maximal string of
+ * them in the input that we can fit into a single EXACTish node.
+ * We quit at the first non-literal or when the node gets full */
for (p = RExC_parse;
len < upper_parse && p < RExC_end;
len++)
* something like "\b" */
if (len || (p > RExC_start && isALPHA_A(*(p -1)))) {
RExC_parse = p + 1;
- vFAIL("Unescaped left brace in regex is illegal");
+ vFAIL("Unescaped left brace in regex is illegal here");
}
/*FALLTHROUGH*/
default: /* A literal character */
* the node, close the node with just them, and set up to do
* this character again next time through, when it will be the
* only thing in its new node */
+
if ((next_is_quantifier = ( LIKELY(p < RExC_end)
&& UNLIKELY(ISMULT2(p))))
&& LIKELY(len))
RExC_parse = p - 1;
Set_Node_Cur_Length(ret, parse_start);
RExC_parse = p;
- skip_to_be_ignored_text(pRExC_state, &RExC_parse,
- FALSE /* Don't force to /x */ );
{
/* len is STRLEN which is unsigned, need to copy to signed */
IV iv = len;
break;
} /* End of giant switch on input character */
+ /* Position parse to next real character */
+ skip_to_be_ignored_text(pRExC_state, &RExC_parse,
+ FALSE /* Don't force to /x */ );
+ if (PASS2 && *RExC_parse == '{' && OP(ret) != SBOL && ! regcurly(RExC_parse)) {
+ ckWARNregdep(RExC_parse + 1, "Unescaped left brace in regex is deprecated here, passed through");
+ }
+
return(ret);
}
* routine. q.v. */
#define ADD_POSIX_WARNING(p, text) STMT_START { \
if (posix_warnings) { \
- if (! warn_text) warn_text = newAV(); \
- av_push(warn_text, Perl_newSVpvf(aTHX_ \
+ if (! RExC_warn_text ) RExC_warn_text = (AV *) sv_2mortal((SV *) newAV()); \
+ av_push(RExC_warn_text, Perl_newSVpvf(aTHX_ \
WARNING_PREFIX \
text \
REPORT_LOCATION, \
bool has_opening_colon = FALSE;
int class_number = OOB_NAMEDCLASS; /* Out-of-bounds until find
valid class */
- AV* warn_text = NULL; /* any warning messages */
const char * possible_end = NULL; /* used for a 2nd parse pass */
const char* name_start; /* ptr to class name first char */
PERL_ARGS_ASSERT_HANDLE_POSSIBLE_POSIX;
+ if (posix_warnings && RExC_warn_text)
+ av_clear(RExC_warn_text);
+
if (p >= e) {
return NOT_MEANT_TO_BE_A_POSIX_CLASS;
}
ADD_POSIX_WARNING(p, "there is no terminating ']'");
}
- if (warn_text) {
- if (posix_warnings) {
- /* mortalize to avoid a leak with FATAL warnings */
- *posix_warnings = (AV *) sv_2mortal((SV *) warn_text);
- }
- else {
- SvREFCNT_dec_NN(warn_text);
- }
+ if (posix_warnings && RExC_warn_text && av_top_index(RExC_warn_text) > -1) {
+ *posix_warnings = RExC_warn_text;
}
}
else if (class_number != OOB_NAMEDCLASS) {
RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
skip_to_be_ignored_text(pRExC_state, &RExC_parse,
- FALSE /* Don't assume /x */ );
+ FALSE /* Don't force /x */ );
}
}
switch => 'switch',
bitwise => 'bitwise',
evalbytes => 'evalbytes',
- postderef => 'postderef',
array_base => 'arybase',
current_sub => '__SUB__',
refaliasing => 'refaliasing',
- lexical_subs => 'lexsubs',
postderef_qq => 'postderef_qq',
unicode_eval => 'unieval',
unicode_strings => 'unicode',
evalbytes current_sub fc postderef_qq)],
);
-# not actually used currently
-my @experimental = qw( lexical_subs );
+my @noops = qw( postderef lexical_subs );
###########################################################################
qq'\$feature_bundle{"$_"} = \$feature_bundle{"$Aliases{$_}"};\n';
};
-#print $pm "my \%experimental = (\n";
-#print $pm " $_ => 1,\n", for @experimental;
-#print $pm ");\n";
+print $pm "my \%noops = (\n";
+print $pm " $_ => 1,\n", for @noops;
+print $pm ");\n";
print $pm <<EOPM;
__END__
package feature;
-our $VERSION = '1.43';
+our $VERSION = '1.44';
FEATURES
=head2 The 'lexical_subs' feature
-B<WARNING>: This feature is still experimental and the implementation may
-change in future versions of Perl. For this reason, Perl will
-warn when you use the feature, unless you have explicitly disabled the
-warning:
+In Perl versions prior to 5.26, this feature enabled
+declaration of subroutines via C<my sub foo>, C<state sub foo>
+and C<our sub foo> syntax. See L<perlsub/Lexical Subroutines> for details.
- no warnings "experimental::lexical_subs";
+This feature is available from Perl 5.18 onwards. From Perl 5.18 to 5.24,
+it was classed as experimental, and Perl emitted a warning for its
+usage, except when explicitly disabled:
-This enables declaration of subroutines via C<my sub foo>, C<state sub foo>
-and C<our sub foo> syntax. See L<perlsub/Lexical Subroutines> for details.
+ no warnings "experimental::lexical_subs";
-This feature is available from Perl 5.18 onwards.
+As of Perl 5.26, use of this feature no longer triggers a warning, though
+the C<experimental::lexical_subs> warning category still exists (for
+compatibility with code that disables it). In addition, this syntax is
+not only no longer experimental, but it is enabled for all Perl code,
+regardless of what feature declarations are in scope.
=head2 The 'postderef' and 'postderef_qq' features
next;
}
if (!exists $feature{$name}) {
+ if (exists $noops{$name}) {
+ next;
+ }
unknown_feature($name);
}
if ($import) {
# find which ops use 0,1,2,3 or 4 bits of op_private for arg count info
- $args0{$_} = 1 for qw(entersub); # UNOPs that usurp bit 0
+ $args0{$_} = 1 for qw(entersub avhvswitch); # UNOPs that usurp bit 0
$args1{$_} = 1 for (
qw(reverse), # ck_fun(), but most bits stolen
# We might be an lvalue to return
addbits($_, 3 => qw(OPpMAYBE_LVSUB LVSUB))
for qw(aassign rv2av rv2gv rv2hv padav padhv aelem helem aslice hslice
- av2arylen keys kvaslice kvhslice substr pos vec multideref);
+ av2arylen keys akeys avhvswitch kvaslice kvhslice substr pos vec
+ multideref);
5 => qw(OPpMULTIDEREF_DELETE DELETE), # deref is actually delete
);
+
+
+addbits('avhvswitch', '0..1' => { });
+
1;
# ex: set ts=8 sts=4 sw=4 et:
bit_and bitwise and (&) ck_bitop fst2 S S|
bit_xor bitwise xor (^) ck_bitop fst2 S S|
bit_or bitwise or (|) ck_bitop fst2 S S|
-nbit_and numeric bitiwse and (&) ck_bitop fsT2 S S|
+nbit_and numeric bitwise and (&) ck_bitop fsT2 S S|
nbit_xor numeric bitwise xor (^) ck_bitop fsT2 S S|
nbit_or numeric bitwise or (|) ck_bitop fsT2 S S|
-sbit_and string bitiwse and (&) ck_bitop fst2 S S|
-sbit_xor string bitwise xor (^) ck_bitop fst2 S S|
-sbit_or string bitwise or (|) ck_bitop fst2 S S|
+sbit_and string bitwise and (&.) ck_bitop fst2 S S|
+sbit_xor string bitwise xor (^.) ck_bitop fst2 S S|
+sbit_or string bitwise or (|.) ck_bitop fst2 S S|
negate negation (-) ck_null Ifst1 S
i_negate integer negation (-) ck_null ifst1 S
kvaslice index/value array slice ck_null m@ A L
aeach each on array ck_each d% A
-akeys keys on array ck_each t% A
avalues values on array ck_each dt% A
+akeys keys on array ck_each t% A
# Hashes.
# For CORE:: subs
coreargs CORE:: subroutine ck_null $
+avhvswitch Array/hash switch ck_null t1
runcv __SUB__ ck_null s0
b1 = (locinput == reginfo->strbeg)
? 0 /* isWORDCHAR_L1('\n') */
: isWORDCHAR_utf8(reghop3((U8*)locinput, -1,
- (U8*)(reginfo->strbeg)));
+ (U8*)(reginfo->strbeg)));
b2 = (NEXTCHR_IS_EOS)
? 0 /* isWORDCHAR_L1('\n') */
: isWORDCHAR_utf8((U8*)locinput);
void
Perl_savestack_grow(pTHX)
{
+#ifdef STRESS_REALLOC
+ PL_savestack_max += SS_MAXPUSH;
+#else
PL_savestack_max = GROW(PL_savestack_max);
+#endif
/* Note that we allocate SS_MAXPUSH slots higher than ss_max
* so that SS_ADD_END(), SSGROW() etc can do a simper check */
Renew(PL_savestack, PL_savestack_max + SS_MAXPUSH, ANY);
Safefree(mg->mg_ptr);
s = SvPV_flags_const(sv, len, flags);
- if ((xf = mem_collxfrm(s, len, &xlen))) {
+ if ((xf = _mem_collxfrm(s, len, &xlen, cBOOL(SvUTF8(sv))))) {
if (! mg) {
mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
0, 0);
PL_collation_standard = proto_perl->Icollation_standard;
PL_collxfrm_base = proto_perl->Icollxfrm_base;
PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
+ PL_strxfrm_max_cp = proto_perl->Istrxfrm_max_cp;
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
/* Did the locale setup indicate UTF-8? */
PL_utf8locale = proto_perl->Iutf8locale;
PL_in_utf8_CTYPE_locale = proto_perl->Iin_utf8_CTYPE_locale;
+ PL_in_utf8_COLLATE_locale = proto_perl->Iin_utf8_COLLATE_locale;
/* Unicode features (see perlrun/-C) */
PL_unicode = proto_perl->Iunicode;
d_pwquota='undef'
d_qgcvt='undef'
d_quad='undef'
+d_querylocale='undef'
d_random_r='undef'
d_readdir64_r='undef'
d_readdir='define'
d_strctcpy='undef'
d_strerrm='strerror(e)'
d_strerror='define'
+d_strerror_l='undef'
d_strerror_r='undef'
d_strftime='undef'
d_strlcat='undef'
chdir 't' if -d 't';
}
-print "1..173\n";
+print "1..185\n";
sub failed {
my ($got, $expected, $name) = @_;
eval 'qq{@{0]}${}},{})';
is(1, 1, "RT #124207");
+# RT #127993 version control conflict markers
+" this should keep working
+<<<<<<<
+" =~ /
+>>>>>>>
+/;
+for my $marker (qw(
+<<<<<<<
+=======
+>>>>>>>
+)) {
+ eval "$marker";
+ like $@, qr/^Version control conflict marker at \(eval \d+\) line 1, near "$marker"/, "VCS marker '$marker' at beginning";
+ eval "\$_\n$marker";
+ like $@, qr/^Version control conflict marker at \(eval \d+\) line 2, near "$marker"/, "VCS marker '$marker' after value";
+ eval "\n\$_ =\n$marker";
+ like $@, qr/^Version control conflict marker at \(eval \d+\) line 3, near "$marker"/, "VCS marker '$marker' after operator";
+}
+
+# keys assignments in weird contexts (mentioned in perl #128260)
+eval 'keys(%h) .= "00"';
+is $@, "", 'keys .=';
+eval 'sub { read $fh, keys %h, 0 }';
+is $@, "", 'read into keys';
+eval 'substr keys(%h),0,=3';
+is $@, "", 'substr keys assignment';
# Add new tests HERE (above this line)
# Allow eg ./perl t/harness t/op/lc.t
for (@tests) {
- if (-f "../$_") {
+ if (! -f $_ && !/^\.\./ && -f "../$_") {
$_ = "../$_";
s{^\.\./t/}{};
}
}
}
+SKIP:
+{
+ eval { require Errno; defined &Errno::EMFILE }
+ or skip "Can't load Errno or EMFILE not defined", 1;
+ my @socks;
+ my $sock_limit = 1000; # don't consume every file in the system
+ # Default limits on various systems I have:
+ # 65536 - Linux
+ # 256 - Solaris
+ # 128 - NetBSD
+ # 256 - Cygwin
+ # 256 - darwin
+ while (@socks < $sock_limit) {
+ socket my $work, PF_INET, SOCK_STREAM, $tcp
+ or last;
+ push @socks, $work;
+ }
+ @socks == $sock_limit
+ and skip "Didn't run out of open handles", 1;
+ is(0+$!, Errno::EMFILE(), "check correct errno for too many files");
+}
+
done_testing();
my @child_tests;
EXPECT
No such class field "c" in variable $f of type main at - line 3.
########
+# NAME Num-specific &= on @array
+use feature 'bitwise';
+@a &= 1;
+EXPECT
+The bitwise feature is experimental at - line 2.
+Can't modify array dereference in numeric bitwise and (&) at - line 2, near "1;"
+Execution of - aborted due to compilation errors.
+########
+# NAME Num-specific |= on @array
+use feature 'bitwise';
+@a |= 1;
+EXPECT
+The bitwise feature is experimental at - line 2.
+Can't modify array dereference in numeric bitwise or (|) at - line 2, near "1;"
+Execution of - aborted due to compilation errors.
+########
+# NAME Num-specific ^= on @array
+use feature 'bitwise';
+@a ^= 1;
+EXPECT
+The bitwise feature is experimental at - line 2.
+Can't modify array dereference in numeric bitwise xor (^) at - line 2, near "1;"
+Execution of - aborted due to compilation errors.
+########
+# NAME &.= on @array
+use feature 'bitwise';
+@a &.= 1;
+EXPECT
+The bitwise feature is experimental at - line 2.
+Can't modify array dereference in string bitwise and (&.) at - line 2, near "1;"
+Execution of - aborted due to compilation errors.
+########
+# NAME |.= on @array
+use feature 'bitwise';
+@a |.= 1;
+EXPECT
+The bitwise feature is experimental at - line 2.
+Can't modify array dereference in string bitwise or (|.) at - line 2, near "1;"
+Execution of - aborted due to compilation errors.
+########
+# NAME ^.= on @array
+use feature 'bitwise';
+@a ^.= 1;
+EXPECT
+The bitwise feature is experimental at - line 2.
+Can't modify array dereference in string bitwise xor (^.) at - line 2, near "1;"
+Execution of - aborted due to compilation errors.
+########
+# NAME substr %h in scalar assignment
+substr(%h,0) = 3;
+EXPECT
+Can't modify hash dereference in substr at - line 1, near "3;"
+Execution of - aborted due to compilation errors.
+########
+# NAME substr %h in list assignment
+(substr %h,0) = 3;
+EXPECT
+Can't modify hash dereference in substr at - line 1, near "3;"
+Execution of - aborted due to compilation errors.
+########
+# NAME vec %h in scalar assignment
+vec(%h,1,1) = 3;
+EXPECT
+Can't modify hash dereference in vec at - line 1, near "3;"
+Execution of - aborted due to compilation errors.
+########
+# NAME vec %h in list assignment
+(vec %h,1,1) = 3;
+EXPECT
+Can't modify hash dereference in vec at - line 1, near "3;"
+Execution of - aborted due to compilation errors.
+########
# NAME Can't declare conditional
my($a?$b:$c)
EXPECT
# NAME Missing name in "my sub"
use feature 'lexical_subs'; my sub;
EXPECT
-The lexical_subs feature is experimental at - line 1.
Missing name in "my sub" at - line 1.
########
# NAME Missing name in "our sub"
use feature 'lexical_subs'; our sub;
EXPECT
-The lexical_subs feature is experimental at - line 1.
Missing name in "our sub" at - line 1.
########
# NAME Missing name in "state sub"
-use 5.01; use feature 'lexical_subs';
+use 5.01;
state sub;
EXPECT
-The lexical_subs feature is experimental at - line 2.
Missing name in "state sub" at - line 2.
########
# NAME my sub pack::foo
my sub foo::bar;
state sub foo::bear;
EXPECT
-The lexical_subs feature is experimental at - line 2.
-The lexical_subs feature is experimental at - line 3.
"my" subroutine &foo::bar can't be in a package at - line 2, near "my sub foo::bar"
"state" subroutine &foo::bear can't be in a package at - line 3, near "state sub foo::bear"
Execution of - aborted due to compilation errors.
# NAME my (our $x) errors
my (our $x);
EXPECT
-Can't redeclare "our" in "my" at - line 1, at end of line
+Can't redeclare "our" in "my" at - line 1, near "(our"
Execution of - aborted due to compilation errors.
########
# NAME our (my $x) errors
our (my $x);
EXPECT
-Can't redeclare "my" in "our" at - line 1, at end of line
+Can't redeclare "my" in "our" at - line 1, near "(my"
Execution of - aborted due to compilation errors.
########
# NAME state (my $x) errors
use feature 'state';
state (my $x);
EXPECT
-Can't redeclare "my" in "state" at - line 2, at end of line
+Can't redeclare "my" in "state" at - line 2, near "(my"
Execution of - aborted due to compilation errors.
########
# NAME our (state $x) errors
use feature 'state';
our (state $x);
EXPECT
-Can't redeclare "state" in "our" at - line 2, at end of line
+Can't redeclare "state" in "our" at - line 2, near "(state"
Execution of - aborted due to compilation errors.
########
# NAME my (my $x) errors
my (my $x, $y, $z);
EXPECT
-Can't redeclare "my" in "my" at - line 1, at end of line
+Can't redeclare "my" in "my" at - line 1, near "(my"
Execution of - aborted due to compilation errors.
########
# NAME our (our $x) errors
our ($x, our($y), $z);
EXPECT
-Can't redeclare "our" in "our" at - line 1, near ", "
+Can't redeclare "our" in "our" at - line 1, near ", our"
Execution of - aborted due to compilation errors.
########
# NAME state (state $x) errors
use feature 'state';
state ($x, $y, state $z);
EXPECT
-Can't redeclare "state" in "state" at - line 2, near ", "
+Can't redeclare "state" in "state" at - line 2, near ", state"
Execution of - aborted due to compilation errors.
########
# NAME BEGIN <> [perl #125341]
BEGIN <>
EXPECT
Illegal declaration of subroutine BEGIN at - line 1.
+########
+# NAME multiple conflict markers
+<<<<<<< yours:sample.txt
+my $some_code;
+=======
+my $some_other_code;
+>>>>>>> theirs:sample.txt
+EXPECT
+Version control conflict marker at - line 1, near "<<<<<<<"
+Version control conflict marker at - line 3, near "======="
+Version control conflict marker at - line 5, near ">>>>>>>"
+Execution of - aborted due to compilation errors.
Found = in conditional, should be == at - line 4.
########
# op.c
+# NAME while with assignment as condition
+use warnings 'syntax';
+1 while $a = 0;
+while ($a = 0) {
+ 1;
+}
+EXPECT
+Found = in conditional, should be == at - line 3.
+Found = in conditional, should be == at - line 4.
+########
+# op.c
+# NAME until with assignment as condition
+use warnings 'syntax';
+1 until $a = 1;
+until ($a = 1) {
+ 1;
+}
+EXPECT
+Found = in conditional, should be == at - line 3.
+Found = in conditional, should be == at - line 4.
+########
+# op.c
use warnings 'syntax' ;
@a[3];
@a{3};
state sub jorge { 1 }
sub jorge () { 2 } # should *not* produce redef warnings by default
EXPECT
-The lexical_subs feature is experimental at - line 3.
Prototype mismatch: sub fred () vs none at - line 4.
Constant subroutine fred redefined at - line 4.
-The lexical_subs feature is experimental at - line 5.
Prototype mismatch: sub george: none vs () at - line 6.
-The lexical_subs feature is experimental at - line 7.
Prototype mismatch: sub phred () vs none at - line 8.
Constant subroutine phred redefined at - line 8.
-The lexical_subs feature is experimental at - line 9.
Prototype mismatch: sub jorge: none vs () at - line 10.
########
# op.c
Use of :locked is deprecated at - line 6.
########
# toke.c
-use warnings "syntax"; use feature 'lexical_subs';
+use warnings "syntax";
sub proto_after_array(@$);
sub proto_after_arref(\@$);
sub proto_after_arref2(\[@$]);
Prototype after '%' for main::proto_after_hash : %$ at - line 7.
Illegal character after '_' in prototype for main::underscore_fail : $_$ at - line 12.
Prototype after '@' for main::underscore_after_at : @_ at - line 13.
-The lexical_subs feature is experimental at - line 14.
Prototype after '@' for hour : @$ at - line 14.
-The lexical_subs feature is experimental at - line 15.
Prototype after '@' for migh : @$ at - line 15.
-The lexical_subs feature is experimental at - line 17.
Prototype after '@' for estate : @$ at - line 17.
Prototype after '@' for hour : @$ at - line 19.
Prototype after '@' for migh : @$ at - line 20.
package hov {
use overload '%{}' => sub { +{} }
}
+package aov {
+ use overload '@{}' => sub { [] }
+}
package sov {
use overload '${}' => sub { \my $x }
}
"&$o with coderef arg";
}
}
+ elsif ($p =~ /^;?\\\@([\@;])?/) { # ;\@ \@@ \@;$$@
+ $tests += 7;
+
+ if ($1) {
+ eval { &{"CORE::$o"}() };
+ like $@, qr/^Not enough arguments for $o at /,
+ "&$o with too few args";
+ }
+ else {
+ eval " &CORE::$o(\\\@1,2) ";
+ like $@, qr/^Too many arguments for $o at /,
+ "&$o with too many args";
+ }
+ eval " &CORE::$o(2) ";
+ like $@, qr/^Type of arg 1 to &CORE::$o must be array reference at /,
+ "&$o with non-ref arg";
+ eval " &CORE::$o(*STDOUT{IO}) ";
+ like $@, qr/^Type of arg 1 to &CORE::$o must be array reference at /,
+ "&$o with ioref arg";
+ my $class = ref *DATA{IO};
+ eval " &CORE::$o(bless(*DATA{IO}, 'aov')) ";
+ like $@, qr/^Type of arg 1 to &CORE::$o must be array reference at /,
+ "&$o with ioref arg with array overload (which does not count)";
+ bless *DATA{IO}, $class;
+ eval " &CORE::$o(\\&scriggle) ";
+ like $@, qr/^Type of arg 1 to &CORE::$o must be array reference at /,
+ "&$o with coderef arg";
+ eval " &CORE::$o(\\\$_) ";
+ like $@, qr/^Type of arg 1 to &CORE::$o must be array reference at /,
+ "&$o with scalarref arg";
+ eval " &CORE::$o({}) ";
+ like $@, qr/^Type of arg 1 to &CORE::$o must be array reference at /,
+ "&$o with hashref arg";
+ }
+ elsif ($p eq '\[%@]') {
+ $tests += 7;
+
+ eval " &CORE::$o(\\%1,2) ";
+ like $@, qr/^Too many arguments for ${\op_desc($o)} at /,
+ "&$o with too many args";
+ eval { &{"CORE::$o"}() };
+ like $@, qr/^Not enough arguments for $o at /,
+ "&$o with too few args";
+ eval " &CORE::$o(2) ";
+ like $@, qr/^Type of arg 1 to &CORE::$o must be hash or array (?x:
+ )reference at /,
+ "&$o with non-ref arg";
+ eval " &CORE::$o(*STDOUT{IO}) ";
+ like $@, qr/^Type of arg 1 to &CORE::$o must be hash or array (?x:
+ )reference at /,
+ "&$o with ioref arg";
+ my $class = ref *DATA{IO};
+ eval " &CORE::$o(bless(*DATA{IO}, 'hov')) ";
+ like $@, qr/^Type of arg 1 to &CORE::$o must be hash or array (?x:
+ )reference at /,
+ "&$o with ioref arg with hash overload (which does not count)";
+ bless *DATA{IO}, $class;
+ eval " &CORE::$o(\\&scriggle) ";
+ like $@, qr/^Type of arg 1 to &CORE::$o must be hash or array (?x:
+ )reference at /,
+ "&$o with coderef arg";
+ eval " &CORE::$o(\\\$_) ";
+ like $@, qr/^Type of arg 1 to &CORE::$o must be hash or array (?x:
+ )reference at /,
+ "&$o with scalarref arg";
+ }
elsif ($p eq ';\[$*]') {
$tests += 4;
is $^A, ' 1 2', 'effect of &myformline';
lis [&myformline('@')], [1], '&myformline in list context';
+test_proto 'each';
+$tests += 4;
+is &myeach({ "a","b" }), "a", '&myeach(\%hash) in scalar cx';
+lis [&myeach({qw<a b>})], [qw<a b>], '&myeach(\%hash) in list cx';
+is &myeach([ "a","b" ]), 0, '&myeach(\@array) in scalar cx';
+lis [&myeach([qw<a b>])], [qw<0 a>], '&myeach(\@array) in list cx';
+
test_proto 'exp';
test_proto 'fc';
is &myjoin('a','b','c'), 'bac', '&join';
lis [&myjoin('a','b','c')], ['bac'], '&join in list context';
+test_proto 'keys';
+$tests += 6;
+is &mykeys({ 1..4 }), 2, '&mykeys(\%hash) in scalar cx';
+lis [sort &mykeys({1..4})], [1,3], '&mykeys(\%hash) in list cx';
+is &mykeys([ 1..4 ]), 4, '&mykeys(\@array) in scalar cx';
+lis [&mykeys([ 1..4 ])], [0..3], '&mykeys(\@array) in list cx';
+{
+ my %h = 1..2;
+ &mykeys(\%h) = 1024;
+ like %h, qr|/1024\z|, '&mykeys = ...';
+ eval { (&mykeys(\%h)) = 1025; };
+ like $@, qr/^Can't modify keys in list assignment at /;
+}
+
test_proto 'kill'; # set up mykill alias
if ($^O ne 'riscos') {
$tests ++;
test_proto 'pipe';
+test_proto 'pop';
+$tests += 6;
+@ARGV = qw<a b c>;
+is &mypop(), 'c', 'retval of &pop with no args (@ARGV)';
+is "@ARGV", "a b", 'effect of &pop on @ARGV';
+sub {
+ is &mypop(), 'k', 'retval of &pop with no args (@_)';
+ is "@_", "q j", 'effect of &pop on @_';
+}->(qw(q j k));
+{
+ my @a = 1..4;
+ is &mypop(\@a), 4, 'retval of &pop';
+ lis [@a], [1..3], 'effect of &pop';
+}
+
test_proto 'pos';
$tests += 4;
$_ = "hello";
$tests++;
is &myprototype(\&myprototype), prototype("CORE::prototype"), '&prototype';
+test_proto 'push';
+$tests += 2;
+{
+ my @a = qw<a b c>;
+ is &mypush(\@a, "d", "e"), 5, 'retval of &push';
+ is "@a", "a b c d e", 'effect of &push';
+}
+
test_proto 'quotemeta', '$', '\$';
test_proto 'rand';
priority protoent pwent servent sockopt
';
+test_proto 'shift';
+$tests += 6;
+@ARGV = qw<a b c>;
+is &myshift(), 'a', 'retval of &shift with no args (@ARGV)';
+is "@ARGV", "b c", 'effect of &shift on @ARGV';
+sub {
+ is &myshift(), 'q', 'retval of &shift with no args (@_)';
+ is "@_", "j k", 'effect of &shift on @_';
+}->(qw(q j k));
+{
+ my @a = 1..4;
+ is &myshift(\@a), 1, 'retval of &shift';
+ lis [@a], [2..4], 'effect of &shift';
+}
+
test_proto "shm$_" for qw "ctl get read write";
test_proto 'shutdown';
test_proto 'sin';
test_proto 'sleep';
test_proto "socket$_" for "", "pair";
+test_proto 'splice';
+$tests += 8;
+{
+ my @a = qw<a b c>;
+ is &mysplice(\@a, 1), 'c', 'retval of 2-arg &splice in scalar context';
+ lis \@a, ['a'], 'effect of 2-arg &splice in scalar context';
+ @a = qw<a b c>;
+ lis [&mysplice(\@a, 1)], ['b','c'], 'retval of 2-arg &splice in list cx';
+ lis \@a, ['a'], 'effect of 2-arg &splice in list context';
+ @a = qw<a b c d>;
+ lis [&mysplice(\@a,1,2)],['b','c'], 'retval of 3-arg &splice in list cx';
+ lis \@a, ['a','d'], 'effect of 3-arg &splice in list context';
+ @a = qw<a b c d>;
+ lis [&mysplice(\@a,1,1,'e')],['b'], 'retval of 4-arg &splice in list cx';
+ lis \@a, [qw<a e c d>], 'effect of 4-arg &splice in list context';
+}
+
test_proto 'sprintf';
$tests += 2;
is &mysprintf("%x", 65), '41', '&sprintf';
is &myunpack("H*", "bcde"), $bcde_as_a_hex_string, '&unpack with two arg';
+test_proto 'unshift';
+$tests += 2;
+{
+ my @a = qw<a b c>;
+ is &myunshift(\@a, "d", "e"), 5, 'retval of &unshift';
+ is "@a", "d e a b c", 'effect of &unshift';
+}
+
test_proto 'untie'; # behaviour already tested along with tie(d)
test_proto 'utime';
is &myutime(undef,undef), 0, '&utime';
lis [&myutime(undef,undef)], [0], '&utime in list context';
+test_proto 'values';
+$tests += 4;
+is &myvalues({ 1..4 }), 2, '&myvalues(\%hash) in scalar cx';
+lis [sort &myvalues({1..4})], [2,4], '&myvalues(\%hash) in list cx';
+is &myvalues([ 1..4 ]), 4, '&myvalues(\@array) in scalar cx';
+lis [&myvalues([ 1..4 ])], [1..4], '&myvalues(\@array) in list cx';
+
test_proto 'vec';
$tests += 3;
is &myvec("foo", 0, 4), 6, '&vec';
# use strict;
-plan tests => 39;
+plan tests => 40;
# simple use cases
{
# lvalue subs in assignment
{
local $@;
- eval 'sub bar:lvalue{ %h{qw(a b)} }; bar() = "1"';
+ eval 'sub bar:lvalue{ %h{qw(a b)} }; (bar) = "1"';
like $@, qr{^Can't modify key/value hash slice in list assignment},
'not allowed as result of lvalue sub';
+ eval 'sub bbar:lvalue{ %h{qw(a b)} }; bbar() = "1"';
+ like $@,
+ qr{^Can't modify key/value hash slice in scalar assignment},
+ 'not allowed as result of lvalue sub';
}
}
BEGIN { chdir 't' if -d 't'; require './test.pl'; }
-plan(tests => 25);
+plan(tests => 26);
{
no warnings 'deprecated';
{ stderr => 1 },
's;@{<<a; [perl #123995]'
);
+
+fresh_perl_is(
+ '$_ = q-strict.pm-; 1 ? require : die;'
+ .' print qq-ok\n- if $INC{q-strict.pm-}',
+ "ok\n",
+ 'foo ? require : bar [perl #128307]'
+);
}
}
+# time() can't be tested using the standard framework since two successive
+# calls may return differing values.
+
+{
+ my $a;
+ $a = time;
+ $b = time;
+ my $diff = $b - $a;
+ cmp_ok($diff, '>=', 0, "time is monotically increasing");
+ cmp_ok($diff, '<', 2, "time delta is small");
+}
+
done_testing();
ref $cstr # ref nonref
`$runme -e "print qq[1\\n]"` # backtick skip(MSWin32)
`$undefed` # backtick undef skip(MSWin32)
-<*> # glob
+'???' # glob (not currently OA_TARGLEX)
<OP> # readline
'faked' # rcatline
(@z = (1 .. 3)) # aassign
setpgrp # setpgrp
getpriority $$, $$ # getpriority
'???' # setpriority
-time # time
+'???' # time
localtime $^T # localtime
gmtime $^T # gmtime
'???' # sleep: can randomly fail
*bar::is = *is;
*bar::like = *like;
}
-plan 152;
-
-# -------------------- Errors with feature disabled -------------------- #
-
-eval "#line 8 foo\nmy sub foo";
-is $@, qq 'Experimental "my" subs not enabled at foo line 8.\n',
- 'my sub unexperimental error';
-eval "#line 8 foo\nCORE::state sub foo";
-is $@, qq 'Experimental "state" subs not enabled at foo line 8.\n',
- 'state sub unexperimental error';
-eval "#line 8 foo\nour sub foo";
-is $@, qq 'Experimental "our" subs not enabled at foo line 8.\n',
- 'our sub unexperimental error';
+plan 149;
# -------------------- our -------------------- #
-no warnings "experimental::lexical_subs";
-use feature 'lexical_subs';
{
our sub foo { 42 }
is foo, 42, 'calling our sub from same package';
# 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;
+ qr/Experimental $_[0] on scalar is now forbidden .* line 1\.(?x:
+ ).*Type of arg 1 to $_[0] must be hash or array \(not (?x:
+ ).*line 1,/s;
}
# Keys -- errors
'stat inside stat gets scalar context';
# [perl #126162] stat an array should not work
-my $Errno_loaded = eval { require Errno };
-my $statfile = './op/stat.t';
-my @statarg = ($statfile, $statfile);
-ok !stat(@statarg),
- 'stat on an array of valid paths should warn and should not return any data';
-my $error = 0+$!;
+# skip if -e '2'.
SKIP:
{
+ skip "There is a file named '2', which invalidates this test", 2 if -e '2';
+
+ my $Errno_loaded = eval { require Errno };
+ my @statarg = ($statfile, $statfile);
+ ok !stat(@statarg),
+ 'stat on an array of valid paths should warn and should not return any data';
+ my $error = 0+$!;
skip "Errno not available", 1
unless $Errno_loaded;
is $error, &Errno::ENOENT,
@INC = '../lib';
require './test.pl';
}
-plan tests=>209;
+plan tests=>211;
sub a : lvalue { my $a = 34; ${\(bless \$a)} } # Return a temporary
sub b : lvalue { ${\shift} }
%__ = ("a","b");
keeze = 64;
is scalar %__, '1/64', 'keys assignment through lvalue sub';
+eval { (keeze) = 64 };
+like $@, qr/^Can't modify keys in list assignment at /,
+ 'list assignment to keys through lv sub is forbidden';
+sub akeeze : lvalue { keys @_ }
+eval { (akeeze) = 64 };
+like $@, qr/^Can't modify keys on array in list assignment at /,
+ 'list assignment to keys @_ through lv sub is forbidden';
# Bug 20001223.002: split thought that the list had only one element
@ary = qw(4 5 6);
}
};
-plan(388);
+plan(390);
run_tests() unless caller;
# [perl #7678] core dump with substr reference and localisation
{$b="abcde"; local $k; *k=\substr($b, 2, 1);}
+# [perl #128260] assertion failure with \substr %h, \substr @h
+{
+ my %h = 1..100;
+ my @a = 1..100;
+ is ${\substr %h, 0}, scalar %h, '\substr %h';
+ is ${\substr @a, 0}, scalar @a, '\substr @a';
+}
+
} # sub run_tests - put tests above this line that can run in threads
use Config;
-plan tests => 131;
+plan tests => 132;
# run some code N times. If the number of SVs at the end of loop N is
# greater than (N-1)*delta at the end of loop 1, we've got a leak
::leak(5, 0, \&f, q{goto shouldn't leak @_});
}
+
+# [perl #128313] POSIX warnings shouldn't leak
+{
+ no warnings 'experimental';
+ use re 'strict';
+ my $a = 'aaa';
+ my $b = 'aa';
+ sub f { $a =~ /[^.]+$b/; }
+ ::leak(2, 0, \&f, q{use re 'strict' shouldn't leak warning strings});
+}
set_up_inc('../lib');
}
-plan( tests => 35 );
+plan( tests => 37 );
is(vec($foo,0,1), 0);
$v = vec($x, 0, 8);
is($v, 255, "downgraded utf8 try 2");
}
+
+# [perl #128260] assertion failure with \vec %h, \vec @h
+{
+ my %h = 1..100;
+ my @a = 1..100;
+ is ${\vec %h, 0, 1}, vec(scalar %h, 0, 1), '\vec %h';
+ is ${\vec @a, 0, 1}, vec(scalar @a, 0, 1), '\vec @a';
+}
-CPAN cpan/CPAN/lib/CPAN.pm ce62c43d72f101c011184dbbc59e21c2790826f0
+Encode cpan/Encode/Byte/Makefile.PL 54f446297d614331ef3f51e8310faff27cc44f90
Encode cpan/Encode/encoding.pm 51c19efc9bfe8467d6ae12a4654f6e7f980715bf
ExtUtils::Constant cpan/ExtUtils-Constant/t/Constant.t a0369c919e216fb02767a637666bb4577ad79b02
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/Command/MM.pm 8d772fbc6a57637ab24d12a02794073ee71b489c
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist.pm 9be9ac3fee6fd6df702469904e02c8b4c6f2502e
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist/Kid.pm bb2443c2314c50f09f7eab4aacc03ade8b9907dd
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker.pm 830acdc810e2974d7fd4ec408ea1bfa825c75b69
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Config.pm 5c41b40e33464c6635258061dff4ece018b46bd9
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/FAQ.pod 062e5d14a803fbbec8d61803086a3d7997e8a473
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Tutorial.pod a8a9cab7d67922ed3d6883c864e1fe29aaa6ad89
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/version.pm 0c970778ac7b437d9363b314dd0ab85b7d83c8cb
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/version/regex.pm 987b7b5567b95a085a69037a7fa99af2b9bdf4df
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/Mkbootstrap.pm 5d5cd55e8d367477337e06f56c02e94c5f7d4a39
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/Mksymlists.pm 23a4b33b974e036d59bf55aa02e025506a408048
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM.pm 288df61e9ba7be3505b58b6345091fe1f310a117
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_AIX.pm 8578f2ea4ec9e764a789f6ecf620ea449ddca8c1
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Any.pm 9f1f6c51fb0337726c99332facc52159c0619fe2
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_BeOS.pm a0ec076bedfa0c2e52fc2b735fbc75b4c2706bbf
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Cygwin.pm 976b10ec76d1fe6f7ee9000b5596e8950434880b
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Darwin.pm bc4b33fa5296ab35bcb1be1c18759b93c4de2598
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_DOS.pm db807cc6e804e34e2b061c2eb96716b79274fd60
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_MacOS.pm 83601fa89eb285ae458c6f57bc3d6789a50de684
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_NW5.pm 8185a7db6c4d7e0fdc5001aeaa8c2b612a884a5e
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS2.pm 2fe66ca8a894d6a2ae340b8bf6f8d69c5e1f7fbe
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_QNX.pm e8a4dbba69a1d551bd581ea6a3f2415bacbc0ae5
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm d666ac424618c3e11b8549755c9646d942bd2d57
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_UWIN.pm f6581a0e75e45bfc26f343f173d3366c43fb1221
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VMS.pm 1997912b5018970cdeb3dae8fd7e0c24f6e5d567
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VOS.pm 210a4eda8b081d9986477e3a9762fce6ebea8474
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Win32.pm 675c0a890c0c74178c845f40d133e603d913b835
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Win95.pm f73ef46755d59467960e98c0d1df085fb56e22ef
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MY.pm 6059d9bb7c4f0c154a61f115aa6b24ba08622b81
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/testlib.pm 6347934cbe40da977790cea6c81987816b2fe26b
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/t/cd.t 0a71fbd646a7be8358b07b6f64f838243cc0aef4
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/t/echo.t 37aec8f794c52e037540757eb5b2556f79419ff7
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/t/lib/MakeMaker/Test/NoXS.pm 371cdff1b2375017907cfbc9c8f4a31f5ad10582
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/t/prereq.t 53bda2c549fd13a6b6c13a070ca6bc79883081c0
-ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/t/vstrings.t 90035a2bdbf45f15b9c3196d072d7cba7e662871
+ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/t/basic.t b7ee8691baf37197bf4249534f429fcf28f5cedf
File::Path cpan/File-Path/lib/File/Path.pm fd8ce4420a0c113d3f47dd3223859743655c1da8
File::Path cpan/File-Path/t/Path_win32.t 94b9276557ce7f80b91f6fd9bfa7a0cd9bf9683e
Math::BigRat cpan/Math-BigRat/lib/Math/BigRat.pm 6eabc68e04f67694f6fe523e64eb013fc337ca5b
next if $f =~ $not_installed;
my $bn = basename($f);
if(grep { /\A(?i:$bn)\z/ } keys %dist_dir_exe) {
- ok( -f "$dist_dir_exe{lc $bn}$ext", $f);
+ my $exe_file = "$dist_dir_exe{lc $bn}$ext";
+ ok( -f $exe_file, "Verify -f '$exe_file'");
} else {
- ok( -f catfile('..', 'utils', "$bn$ext"), $f );
+ my $utils_file = catfile('..', 'utils', "$bn$ext");
+ ok( -f $utils_file, "Verify -f '$utils_file'" );
}
}
YAML::Tiny
dist/data-dumper/dumper.pm ? Should you be using L<...> instead of 1
ext/amiga-exec/exec.pm Verbatim line length including indents exceeds 79 by 1
-ext/devel-peek/peek.pm ? Should you be using L<...> instead of 2
ext/dynaloader/dynaloader.pm Verbatim line length including indents exceeds 79 by 1
ext/hash-util/lib/hash/util.pm Verbatim line length including indents exceeds 79 by 2
ext/pod-html/testdir/perlpodspec-copy.pod Verbatim line length including indents exceeds 79 by 2
ext/pod-html/testdir/perlvar-copy.pod ? Should you be using L<...> instead of 3
ext/pod-html/testdir/perlvar-copy.pod Verbatim line length including indents exceeds 79 by 6
-ext/vms-dclsym/dclsym.pm ? Should you be using L<...> instead of 1
ext/vms-filespec/lib/vms/filespec.pm Verbatim line length including indents exceeds 79 by 1
install ? Should you be using F<...> or maybe L<...> instead of 1
pod/perl.pod Verbatim line length including indents exceeds 79 by 8
pod/perldebguts.pod Verbatim line length including indents exceeds 79 by 27
pod/perldebtut.pod Verbatim line length including indents exceeds 79 by 3
pod/perldtrace.pod Verbatim line length including indents exceeds 79 by 7
+pod/perlgit.pod ? Should you be using F<...> or maybe L<...> instead of 1
pod/perlgit.pod Verbatim line length including indents exceeds 79 by 1
pod/perlguts.pod ? Should you be using L<...> instead of 1
pod/perlhack.pod ? Should you be using L<...> instead of 1
pod/perlinterp.pod ? Should you be using L<...> instead of 1
pod/perlirix.pod Verbatim line length including indents exceeds 79 by 1
pod/perlmacosx.pod Verbatim line length including indents exceeds 79 by 3
-pod/perlmodlib.pod Verbatim line length including indents exceeds 79 by 3
pod/perlmroapi.pod ? Should you be using L<...> instead of 1
pod/perlos2.pod ? Should you be using L<...> instead of 2
pod/perlos2.pod Verbatim line length including indents exceeds 79 by 5
pod/perlwin32.pod Verbatim line length including indents exceeds 79 by 7
porting/epigraphs.pod Verbatim line length including indents exceeds 79 by 16
porting/release_managers_guide.pod Verbatim line length including indents exceeds 79 by 1
-utils/encguess There is no NAME 1
+porting/todo.pod ? Should you be using F<...> or maybe L<...> instead of 1
+utils/ptar Verbatim paragraph in NAME section 1
lib/benchmark.pm Verbatim line length including indents exceeds 79 by 2
lib/config.pod ? Should you be using L<...> instead of -1
lib/perl5db.pl ? Should you be using L<...> instead of 1
}
undef $nm_err_tmp; # In this case there will be no nm errors.
} else {
+ print qq{# command: "$nm $nm_opt $libperl_a 2>$nm_err_tmp |"\n};
open($nm_fh, "$nm $nm_opt $libperl_a 2>$nm_err_tmp |") or
skip_all "$nm $nm_opt $libperl_a failed: $!";
}
} elsif (/^ {8}(?: {8})? \(undefined(?: \[lazy bound\])?\) external _?(.+)/) {
# darwin/ppc marks most undefined text symbols
# as "[lazy bound]".
- my ($symbol) = $1;
+ my ($symbol) = $1 =~ s/\$UNIX2003\z//r;
return if is_perlish_symbol($symbol);
$symbols->{undef}{$symbol}{$symbols->{o}}++;
return;
ok(!exists $data_symbols{PL_hash_seed}, "has no PL_hash_seed");
ok(!exists $data_symbols{PL_ppaddr}, "has no PL_ppaddr");
- ok(! exists $symbols{data}{bss}, "has no data bss symbols");
+ ok(! exists $symbols{data}{bss}, "has no data bss symbols")
+ or do {
+ my $bad = "BSS entries (there are supposed to be none):\n";
+ $bad .= " bss sym: $_\n" for sort keys %{$symbols{data}{bss}};
+ diag($bad);
+ };
+
ok(! exists $symbols{data}{data} ||
# clang with ASAN seems to add this symbol to every object file:
!grep($_ ne '__unnamed_1', keys %{$symbols{data}{data}}),
ok(!exists $data_symbols{PL_hash_seed}, "has no PL_hash_seed");
ok(!exists $data_symbols{PL_ppaddr}, "has no PL_ppaddr");
- ok(! exists $symbols{data}{bss}, "has no data bss symbols");
+ ok(! exists $symbols{data}{bss}, "has no data bss symbols")
+ or do {
+ my $bad = "BSS entries (there are supposed to be none):\n";
+ $bad .= " bss sym: $_\n" for sort keys %{$symbols{data}{bss}};
+ diag($bad);
+ };
+
# These PerlIO data symbols are left visible with
# -DPERL_GLOBAL_STRUCT (as opposed to -DPERL_GLOBAL_STRUCT_PRIVATE)
SKIP: {
skip("uses sprintf for Gconvert in sv.o");
}
+ }
+ elsif ( $symbol eq 'strcat'
+ && @o == 1 && $o[0] eq 'locale.o')
+ {
+ SKIP: {
+ skip("locale.o legitimately uses strcat");
+ }
} else {
is(@o, 0, "uses no $symbol (@o)");
}
#!/usr/bin/perl -w
+package main;
+
BEGIN {
chdir 't';
@INC = "../lib";
(specified below). It does additional checking beyond that done by
Pod::Checker, and keeps a database of known potential problems, and will
fail a pod only if the number of such problems differs from that given in the
-database. It also suppresses the C<(section) deprecated> message from
-Pod::Checker, since specifying the man page section number is quite proper to do.
+database.
The additional checks it always makes are:
A pod can't be linked to unless it has a unique name.
And a NAME should have a dash and short description after it.
-=item =encoding statement issues
-
-This indicates if an C<=encoding> statement should be present, or moved to the
-front of the pod.
-
-=back
-
If the C<PERL_POD_PEDANTIC> environment variable is set or the C<--pedantic>
command line argument is provided then a few more checks are made.
The pedantic checks are:
valid in the database
actually are. Thus any errors introduced there will remain there.
+=back
+
=head2 Specially handled pods
=over
my $broken_internal_link = "Apparent internal link is missing its forward slash";
my $multiple_targets = "There is more than one target";
my $duplicate_name = "Pod NAME already used";
-my $need_encoding = "Should have =encoding statement because have non-ASCII";
-my $encoding_first = "=encoding must be first command (if present)";
my $no_name = "There is no NAME";
my $missing_name_description = "The NAME should have a dash and short description after it";
# the pedantic warnings messages
my %excluded_files = (
canonicalize("lib/unicore/mktables") => 1,
canonicalize("Porting/make-rmg-checklist") => 1,
- # this one is a POD, but unfinished, so skip
- # it for now
- canonicalize("Porting/perl5200delta.pod") => 1,
canonicalize("Porting/perldelta_template.pod") => 1,
canonicalize("regen/feature.pl") => 1,
canonicalize("regen/warnings.pl") => 1,
| ^(?i:Makefile\.PL)$
/x;
+# Matches something that looks like a file name, but is enclosed in C<...>
+my $C_path_re = qr{ ^
+ # exclude various things that have slashes
+ # in them but aren't paths
+ (?!
+ (?: (?: s | qr | m | tr | y ) / ) # regexes
+ | \d+/\d+ \b # probable fractions
+ | (?: [LF] < )+
+ | OS/2 \b
+ | Perl/Tk \b
+ | origin/blead \b
+ | origin/maint \b
+
+ )
+ /? # Optional initial slash
+ \w+ # First component of path, doesn't begin with
+ # a minus
+ (?: / [-\w]+ )+ # Subsequent path components
+ (?: \. \w+ )? # Optional trailing dot and suffix
+ >* # Any enclosed L< F< have matching closing >
+ $
+ }x;
+
# '.PL' files should be excluded, as they aren't final pods, but often contain
# material used in generating pods, and so can look like a pod. We can't use
# the regexp above because case sensisitivity is important for these, as some
# Pod::Checker messages to suppress
my @suppressed_messages = (
- "(section) in", # Checker is wrong to flag this
- "multiple occurrence of link target", # We catch independently the ones
- # that are real problems.
- "unescaped <>",
- "Entity number out of range", # Checker outputs this for anything above
- # 255, but in fact all Unicode is valid
- "No items in =over", # ie a blockquote
+ # We catch independently the ones that are real problems.
+ qr/multiple occurrences \(\d+\) of link target/,
+
+ "unescaped <>", # Not every '<' or '>' need be escaped
+ qr/No items in =over/, # i.e., a blockquote, which we consider legal
);
sub suppressed {
# Returns bool as to if input message is one that is to be suppressed
my $message = shift;
- return grep { $message =~ /^\Q$_/i } @suppressed_messages;
+
+ return grep { $message =~ /^$_/i } @suppressed_messages;
}
{ # Closure to contain a simple subset of test.pl. This is to get rid of the
# Uses inside out hash to protect from typos
# For new fields, remember to add to destructor DESTROY()
- my %indents; # Stack of indents from =over's in effect for
- # current line
+ my %CFL_text; # The text comprising the current C<>, F<>, or L<>
+ my %C_text; # If defined, are in a C<> section, and includes
+ # the accumulated text from that
my %current_indent; # Current line's indent
my %filename; # The pod is store in this file
- my %skip; # is SKIP set for this pod
+ my %in_CFL; # count of stacked C<>, F<>, L<> directives
+ my %indents; # Stack of indents from =over's in effect for
+ # current line
+ my %in_for; # true if in a =for or =begin
my %in_NAME; # true if within NAME section
my %in_begin; # true if within =begin section
+ my %in_X; # true if in a X<>
my %linkable_item; # Bool: if the latest =item is linkable. It isn't
# for bullet and number lists
my %linkable_nodes; # Pod::Checker adds all =items to its node list,
# but not all =items are linkable to
- my %seen_encoding_cmd; # true if have =encoding earlier
+ my %running_CFL_text; # The current text that is being accumulated until
+ # an end_FOO is found, and this includes any C<>,
+ # F<>, or L<> directives.
+ my %running_simple_text; # The currentt text that is being accumulated
+ # until an end_FOO is found, and all directives
+ # have been expanded into plain text
my %command_count; # Number of commands seen
my %seen_pod_cmd; # true if have =pod earlier
- my %warned_encoding; # true if already have warned about =encoding
- # problems
+ my %skip; # is SKIP set for this pod
+ my %start_line; # the first input line number in the the thing
+ # currently being worked on
sub DESTROY {
my $addr = Scalar::Util::refaddr $_[0];
+ delete $CFL_text{$addr};
+ delete $C_text{$addr};
delete $command_count{$addr};
delete $current_indent{$addr};
delete $filename{$addr};
delete $in_begin{$addr};
+ delete $in_CFL{$addr};
delete $indents{$addr};
+ delete $in_for{$addr};
delete $in_NAME{$addr};
+ delete $in_X{$addr};
delete $linkable_item{$addr};
delete $linkable_nodes{$addr};
- delete $seen_encoding_cmd{$addr};
+ delete $running_CFL_text{$addr};
+ delete $running_simple_text{$addr};
delete $seen_pod_cmd{$addr};
delete $skip{$addr};
- delete $warned_encoding{$addr};
+ delete $start_line{$addr};
return;
}
$current_indent{$addr} = 0;
$filename{$addr} = $filename;
$in_begin{$addr} = 0;
+ $in_X{$addr} = 0;
+ $in_CFL{$addr} = 0;
$in_NAME{$addr} = 0;
$linkable_item{$addr} = 0;
- $seen_encoding_cmd{$addr} = 0;
$seen_pod_cmd{$addr} = 0;
- $warned_encoding{$addr} = 0;
return $self;
}
#push @{$problems{$self->get_filename}{$message}}, $opts;
}
- sub check_encoding { # Does it need an =encoding statement?
- my ($self, $paragraph, $line_num, $pod_para) = @_;
+ # In the next subroutines, we keep track of the text of the current
+ # innermost thing, like F<fooC<bar>baz>. The things we care about raising
+ # messages about in this program all come from a single sequence of
+ # characters uninterrupted by other pod commands. Therefore we don't have
+ # to worry about recursion, and we can just set the string we care about
+ # to empty on entrance to each command.
+
+ sub handle_text {
+ # This is called by the parent class to deal with any straight text.
+ # We mostly just append this to the running current value which will
+ # be dealt with upon the end of the current construct, like a
+ # paragraph. But certain things don't contribute to checking the pod
+ # and are ignored. We also have set flags to indicate this text is
+ # going towards constructing certain constructs, and handle those
+ # specially.
- # Do nothing if there is an =encoding in the file, or if the line
- # doesn't require an =encoding, or have already warned.
+ my $self = shift;
my $addr = Scalar::Util::refaddr $self;
- return if $seen_encoding_cmd{$addr}
- || $warned_encoding{$addr}
- || $paragraph !~ /\P{ASCII}/;
-
- $warned_encoding{$addr} = 1;
- my ($file, $line) = $pod_para->file_line;
- $self->poderror({ -line => $line, -file => $file,
- -msg => $need_encoding
- });
- return;
+
+ my $return = $self->SUPER::handle_text(@_);
+
+ if ($in_X{$addr} || $in_for{$addr}) { # ignore
+ return $return;
+ }
+
+ my $text = join "\n", @_;
+ $running_simple_text{$addr} .= $text;
+
+ # Keep separate tabs on C<>, F<>, and L<> directives, and one
+ # especially for C<> ones.
+ if ($in_CFL{$addr}) {
+ $CFL_text{$addr} .= $text;
+ $C_text{$addr} .= $text if defined $C_text{$addr};
+ }
+ else {
+ # This variable is updated instead in the corresponding C, F, or L
+ # handler.
+ $running_CFL_text{$addr} .= $text;
+ }
+
+ return $return;
}
- sub verbatim {
- my ($self, $paragraph, $line_num, $pod_para) = @_;
- $self->check_encoding($paragraph, $line_num, $pod_para);
+ # The start_FOO routines check that somehow a C<> construct hasn't escaped
+ # without being checked, and initialize things, and call the parent
+ # class's equivalent routine.
- $self->SUPER::verbatim($paragraph, $line_num, $pod_para);
+ # The end_FOO routines close things off, and check the text that has been
+ # accumulated for FOO, then call the parent's corresponding routine.
+
+ sub start_Para {
+ my $self = shift;
+ check_see_but_not_link($self);
my $addr = Scalar::Util::refaddr $self;
+ $start_line{$addr} = $_[0]->{start_line};
+ $running_CFL_text{$addr} = "";
+ $running_simple_text{$addr} = "";
+ return $self->SUPER::start_Para(@_);
+ }
- # Pick up the name, since the parent class doesn't in verbatim
- # NAMEs; so treat as non-verbatim. The parent class only allows one
- # paragraph in a NAME section, so if there is an extra blank line, it
- # will trigger a message, but such a blank line is harmless, so skip
- # in that case.
- if ($in_NAME{$addr} && $paragraph =~ /\S/) {
- $self->textblock($paragraph, $line_num, $pod_para);
- }
+ sub start_item_text {
+ my $self = shift;
+ check_see_but_not_link($self);
- my @lines = split /^/, $paragraph;
- for my $i (0 .. @lines - 1) {
- if ( my $encoding = $seen_encoding_cmd{$addr} ) {
- require Encode;
- $lines[$i] = Encode::decode($encoding, $lines[$i]);
- }
- $lines[$i] =~ s/\s+$//;
- my $indent = $self->get_current_indent;
-
- if ($pedantic) { # TODO: this check should be moved higher
- # to avoid more unnecessary work
- my $exceeds = length(Text::Tabs::expand($lines[$i]))
- + $indent - $MAX_LINE_LENGTH;
- next unless $exceeds > 0;
- my ($file, $line) = $pod_para->file_line;
- $self->poderror({ -line => $line + $i, -file => $file,
- -msg => $line_length,
- parameter => "+$exceeds (including " . ($indent - $INDENT) . " from =over's)",
- });
- }
- }
+ my $addr = Scalar::Util::refaddr $self;
+ $start_line{$addr} = $_[0]->{start_line};
+ $running_CFL_text{$addr} = "";
+ $running_simple_text{$addr} = "";
+
+ # This is the only =item that is linkable
+ $linkable_item{$addr} = 1;
+
+ return $self->SUPER::start_item_text(@_);
+ }
+
+ sub start_item_number {
+ my $self = shift;
+ check_see_but_not_link($self);
+
+ my $addr = Scalar::Util::refaddr $self;
+ $start_line{$addr} = $_[0]->{start_line};
+ $running_CFL_text{$addr} = "";
+ $running_simple_text{$addr} = "";
+
+ return $self->SUPER::start_item_number(@_);
+ }
+
+ sub start_item_bullet {
+ my $self = shift;
+ check_see_but_not_link($self);
+
+ my $addr = Scalar::Util::refaddr $self;
+ $start_line{$addr} = $_[0]->{start_line};
+ $running_CFL_text{$addr} = "";
+ $running_simple_text{$addr} = "";
+
+ return $self->SUPER::start_item_bullet(@_);
}
- sub textblock {
- my ($self, $paragraph, $line_num, $pod_para) = @_;
- $self->check_encoding($paragraph, $line_num, $pod_para);
+ sub end_item { # No difference in =item types endings
+ my $self = shift;
+ check_see_but_not_link($self);
+ return $self->SUPER::end_item(@_);
+ }
- $self->SUPER::textblock($paragraph, $line_num, $pod_para);
+ sub start_over {
+ my $self = shift;
+ check_see_but_not_link($self);
- my ($file, $line) = $pod_para->file_line;
my $addr = Scalar::Util::refaddr $self;
- if ($in_NAME{$addr}) {
- if (! $self->name) {
- my $text = $self->interpolate($paragraph, $line_num);
- if ($text =~ /^\s*(\S+?)\s*$/) {
- $self->name($1);
- $self->poderror({ -line => $line, -file => $file,
- -msg => $missing_name_description,
- parameter => $1});
- }
- }
+ $start_line{$addr} = $_[0]->{start_line};
+ $running_CFL_text{$addr} = "";
+ $running_simple_text{$addr} = "";
+
+ # Save this indent on a stack, and keep track of total indent
+ my $indent = $_[0]{'indent'};
+ push @{$indents{$addr}}, $indent;
+ $current_indent{$addr} += $indent;
+
+ return $self->SUPER::start_over(@_);
+ }
+
+ sub end_over_bullet { shift->end_over(@_) }
+ sub end_over_number { shift->end_over(@_) }
+ sub end_over_text { shift->end_over(@_) }
+ sub end_over_block { shift->end_over(@_) }
+ sub end_over_empty { shift->end_over(@_) }
+ sub end_over {
+ my $self = shift;
+ check_see_but_not_link($self);
+
+ my $addr = Scalar::Util::refaddr $self;
+
+ # Pop current indent
+ if (@{$indents{$addr}}) {
+ $current_indent{$addr} -= pop @{$indents{$addr}};
}
- $paragraph = join " ", split /^/, $paragraph;
-
- # Matches something that looks like a file name, but is enclosed in
- # C<...>
- my $C_path_re = qr{ \b ( C<
- # exclude various things that have slashes
- # in them but aren't paths
- (?!
- (?: (?: s | qr | m) / ) # regexes
- | \d+/\d+> # probable fractions
- | OS/2>
- | Perl/Tk>
- | origin/blead>
- | origin/maint
- | - # File names don't begin with "-"
- )
- [-\w]+ (?: / [-\w]+ )+ (?: \. \w+ )? > )
- }x;
-
- # If looks like a reference to other documentation by containing the
- # word 'See' and then a likely pod directive, warn.
- while ($paragraph =~ m{
+ else {
+ # =back without corresponding =over, but should have
+ # warned already
+ $current_indent{$addr} = 0;
+ }
+ }
+
+ sub check_see_but_not_link {
+
+ # Looks through accumulated text for current element that includes the
+ # C<>, F<>, and L<> directives for ones that look like they are
+ # C<link> instead of L<link>.
+
+ my $self = shift;
+ my $addr = Scalar::Util::refaddr $self;
+
+ return unless defined $running_CFL_text{$addr};
+
+ while ($running_CFL_text{$addr} =~ m{
( (?: \w+ \s+ )* ) # The phrase before, if any
\b [Ss]ee \s+
( ( [^L] )
>
)
( \s+ (?: under | in ) \s+ L< )?
- }xg) {
+ }xg)
+ {
my $prefix = $1 // "";
my $construct = $2; # The whole thing, like C<...>
my $type = $3;
# construct would be if it actually has L<> syntax. If it
# doesn't have that syntax, will set the module to the entire
# interior.
- $interior =~ m/ ^
- (?: [^|]+ \| )? # Optional arbitrary text ending
- # in "|"
- ( .+? ) # module, etc. name
- (?: \/ .+ )? # target within module
- $
- /xs;
- my $module = $1;
if (! defined $trailing # not referring to something in another
# section
&& $interior !~ /$non_pods/
- # C<> that look like files have their own message below, so
- # exclude them
- && $construct !~ /$C_path_re/g
-
# There can't be spaces (I think) in module names or man
# pages
- && $module !~ / \s /x
+ && $interior !~ / \s /x
# F<> that end in eg \.pl are almost certainly ok, as are
# those that look like a path with multiple "/" chars
)
) {
# TODO: move the checking of $pedantic higher up
- $self->poderror({ -line => $line, -file => $file,
+ $self->poderror({ -line => $start_line{$addr},
-msg => $C_not_linked,
parameter => $construct
- }) if $pedantic;
+ });
}
}
}
- while ($paragraph =~ m/$C_path_re/g) {
- my $construct = $1;
- # TODO: move the checking of $pedantic higher up
- $self->poderror({ -line => $line, -file => $file,
- -msg => $C_with_slash,
- parameter => $construct
- }) if $pedantic;
- }
- return;
+
+ undef $running_CFL_text{$addr};
}
- sub command {
- my ($self, $cmd, $paragraph, $line_num, $pod_para) = @_;
+ sub end_Para {
+ my $self = shift;
+ check_see_but_not_link($self);
+
my $addr = Scalar::Util::refaddr $self;
- if ($cmd eq "pod") {
- $seen_pod_cmd{$addr}++;
- }
- elsif ($cmd eq "encoding") {
- my ($file, $line) = $pod_para->file_line;
- $seen_encoding_cmd{$addr} = $paragraph; # for later decoding
- if ($command_count{$addr} != 1 && $seen_pod_cmd{$addr}) {
- $self->poderror({ -line => $line, -file => $file,
- -msg => $encoding_first
- });
+ if ($in_NAME{$addr}) {
+ if ($running_simple_text{$addr} =~ /^\s*(\S+?)\s*$/) {
+ $self->poderror({ -line => $start_line{$addr},
+ -msg => $missing_name_description,
+ parameter => $1});
}
+ $in_NAME{$addr} = 0;
}
- $self->check_encoding($paragraph, $line_num, $pod_para);
-
- # Pod::Check treats all =items as linkable, but the bullet and
- # numbered lists really aren't. So keep our own list. This has to be
- # processed before SUPER is called so that the list is started before
- # the rest of it gets parsed.
- if ($cmd eq 'item') { # Not linkable if item begins with * or a digit
- $linkable_item{$addr} = ($paragraph !~ / ^ \s*
- (?: [*]
- | \d+ \.? (?: \$ | \s+ )
- )/x)
- ? 1
- : 0;
+ $self->SUPER::end_Para(@_);
+ }
+ sub start_head1 {
+ my $self = shift;
+ check_see_but_not_link($self);
+
+ my $addr = Scalar::Util::refaddr $self;
+ $start_line{$addr} = $_[0]->{start_line};
+ $running_CFL_text{$addr} = "";
+ $running_simple_text{$addr} = "";
+
+ return $self->SUPER::start_head1(@_);
+ }
+
+ sub end_head1 { # This is called at the end of the =head line.
+ my $self = shift;
+ check_see_but_not_link($self);
+
+ my $addr = Scalar::Util::refaddr $self;
+
+ $in_NAME{$addr} = 1 if $running_simple_text{$addr} eq 'NAME';
+ return $self->SUPER::end_head(@_);
+ }
+
+ sub start_Verbatim {
+ my $self = shift;
+ check_see_but_not_link($self);
+
+ my $addr = Scalar::Util::refaddr $self;
+ $running_simple_text{$addr} = "";
+ $start_line{$addr} = $_[0]->{start_line};
+ return $self->SUPER::start_Verbatim(@_);
+ }
+
+ sub end_Verbatim {
+ my $self = shift;
+ my $addr = Scalar::Util::refaddr $self;
+
+ # Pick up the name if it looks like one, since the parent class
+ # doesn't handle verbatim NAMEs
+ if ($in_NAME{$addr}
+ && $running_simple_text{$addr} =~ /^\s*(\S+?)\s*[,-]/)
+ {
+ $self->name($1);
}
- $self->SUPER::command($cmd, $paragraph, $line_num, $pod_para);
-
- $command_count{$addr}++;
-
- $in_NAME{$addr} = 0; # Will change to 1 below if necessary
- $in_begin{$addr} = 0; # ibid
- if ($cmd eq 'over') {
- my $text = $self->interpolate($paragraph, $line_num);
- my $indent = 4; # default
- $indent = $1 if $text && $text =~ /^\s*(\d+)\s*$/;
- push @{$indents{$addr}}, $indent;
- $current_indent{$addr} += $indent;
+
+ my $indent = $self->get_current_indent;
+
+ # Look at each line to verify it is short enough
+ my @lines = split /^/, $running_simple_text{$addr};
+ for my $i (0 .. @lines - 1) {
+ $lines[$i] =~ s/\s+$//;
+ my $exceeds = length(Text::Tabs::expand($lines[$i]))
+ + $indent - $MAX_LINE_LENGTH;
+ next unless $exceeds > 0;
+
+ $self->poderror({ -line => $start_line{$addr} + $i,
+ -msg => $line_length,
+ parameter => "+$exceeds (including " . ($indent - $INDENT) . " from =over's)",
+ });
}
- elsif ($cmd eq 'back') {
- if (@{$indents{$addr}}) {
- $current_indent{$addr} -= pop @{$indents{$addr}};
+
+ undef $running_simple_text{$addr};
+
+ # Parent class didn't bother to define this
+ #return $self->SUPER::SUPER::end_Verbatim(@_);
+ }
+
+ sub start_C {
+ my $self = shift;
+ my $addr = Scalar::Util::refaddr $self;
+
+ $C_text{$addr} = "";
+
+ # If not in a stacked set of C<>, F<> and L<>, initialize the text for
+ # them.
+ $CFL_text{$addr} = "" if ! $in_CFL{$addr};
+ $in_CFL{$addr}++;
+
+ return $self->SUPER::start_C(@_);
+ }
+
+ sub start_F {
+ my $self = shift;
+ my $addr = Scalar::Util::refaddr $self;
+
+ $CFL_text{$addr} = "" if ! $in_CFL{$addr};
+ $in_CFL{$addr}++;
+ return $self->SUPER::start_F(@_);
+ }
+
+ sub start_L {
+ my $self = shift;
+ my $addr = Scalar::Util::refaddr $self;
+
+ $CFL_text{$addr} = "" if ! $in_CFL{$addr};
+ $in_CFL{$addr}++;
+ return $self->SUPER::start_L(@_);
+ }
+
+ sub end_C {
+ my $self = shift;
+ my $addr = Scalar::Util::refaddr $self;
+
+ # Warn if looks like a file or link enclosed instead by this C<>
+ if ($C_text{$addr} =~ qr/^ $C_path_re $/x) {
+ # Here it does look like it could be be a file path or a link.
+ # But some varieties of regex patterns could also fit with what we
+ # have so far. Weed those out as best we can. '/foo/' is almost
+ # certainly meant to be a pattern, as is '/foo/g'.
+ my $is_pattern;
+ if ($C_text{$addr} !~ qr| ^ / [^/]* / ( [msixpodualngcr]* ) $ |x) {
+ $is_pattern = 0;
}
else {
- # =back without corresponding =over, but should have
- # warned already
- $current_indent{$addr} = 0;
- }
- }
- elsif ($cmd =~ /^head/) {
- if (! $in_begin{$addr}) {
- # If a particular formatter, then this command doesn't really
- # apply
- $current_indent{$addr} = 0;
- undef @{$indents{$addr}};
+ # Here, it looks like a pattern potentially followed by some
+ # modifiers. To make doubly sure, don't count as patterns
+ # those constructs which have more occurrences (generally 1)
+ # of a modifier than is legal.
+ my %counts;
+ map { $counts{$_}++ } split "", $1;
+ foreach my $modifier (keys %counts) {
+ if ($counts{$modifier} > (($modifier eq 'a')
+ ? 2
+ : 1))
+ {
+ $is_pattern = 0;
+ last;
+ }
+ }
+ $is_pattern = 1 unless defined $is_pattern;
}
- my $text = $self->interpolate($paragraph, $line_num);
- $in_NAME{$addr} = 1 if $cmd eq 'head1'
- && $text && $text =~ /^NAME\b/;
- }
- elsif ($cmd eq 'begin') {
- $in_begin{$addr} = 1;
+ unless ($is_pattern) {
+ $self->poderror({ -line => $start_line{$addr},
+ -msg => $C_with_slash,
+ parameter => "C<$C_text{$addr}>"
+ });
+ }
}
+ undef $C_text{$addr};
+
+ # Add the current text to the running total. This was not done in
+ # handle_text(), because it just sees the plain text of the innermost
+ # stacked directive. We want to keep all the directive names
+ # enclosing the text. Otherwise the fact that C<L<foobar>> is to a
+ # link would be lost, as the L<> would be gone.
+ $CFL_text{$addr} = "C<$CFL_text{$addr}>";
+
+ # Add this text to the the whole running total only if popping this
+ # directive off the stack leaves it empty. As long as something is on
+ # the stack, it gets added to $CFL_text (just above). It is only
+ # entirely constructed when the stack is empty.
+ $in_CFL{$addr}--;
+ $running_CFL_text{$addr} .= $CFL_text{$addr} if ! $in_CFL{$addr};
+
+ return $self->SUPER::end_C(@_);
+ }
- return;
+ sub end_F {
+ my $self = shift;
+ my $addr = Scalar::Util::refaddr $self;
+
+ $CFL_text{$addr} = "F<$CFL_text{$addr}>";
+ $in_CFL{$addr}--;
+ $running_CFL_text{$addr} .= $CFL_text{$addr} if ! $in_CFL{$addr};
+ return $self->SUPER::end_F(@_);
}
- sub hyperlink {
+ sub end_L {
my $self = shift;
+ my $addr = Scalar::Util::refaddr $self;
- my $page;
- if ($_[0] && ($page = $_[0][1]{'-page'})) {
- my $node = $_[0][1]{'-node'};
-
- if ($node) {
- $_[0][1]{'-node'} = $node = do {
- my $expand_seq = sub {
- my (undef, $seq) = @_;
- my $arg = join '', $seq->parse_tree->children;
- if ($seq->name eq 'E') {
- $arg =
- $arg eq 'sol' ? '/' :
- $arg eq 'verbar' ? '|' :
- $arg eq 'lt' ? '<' :
- $arg eq 'gt' ? '>' :
- die "Not implemented: E<$arg>";
- }
- return $arg;
- };
- my $ptree = $self->parse_text({ -expand_seq => $expand_seq }, $node, $_[0][0]);
- join '', $ptree->children
- };
-
- # If the hyperlink is to an interior node of another page, save it
- # so that we can see if we need to parse normally skipped files.
- $has_referred_to_node{$page} = 1;
- }
+ $CFL_text{$addr} = "L<$CFL_text{$addr}>";
+ $in_CFL{$addr}--;
+ $running_CFL_text{$addr} .= $CFL_text{$addr} if ! $in_CFL{$addr};
+ return $self->SUPER::end_L(@_);
+ }
+
+ sub start_X {
+ my $self = shift;
+ my $addr = Scalar::Util::refaddr $self;
+
+ $in_X{$addr} = 1;
+ return $self->SUPER::start_X(@_);
+ }
+
+ sub end_X {
+ my $self = shift;
+ my $addr = Scalar::Util::refaddr $self;
+
+ $in_X{$addr} = 0;
+ return $self->SUPER::end_X(@_);
+ }
+
+ sub start_for {
+ my $self = shift;
+ my $addr = Scalar::Util::refaddr $self;
+
+ $in_for{$addr} = 1;
+ return $self->SUPER::start_for(@_);
+ }
+
+ sub end_for {
+ my $self = shift;
+ my $addr = Scalar::Util::refaddr $self;
+
+ $in_for{$addr} = 0;
+ return $self->SUPER::end_for(@_);
+ }
+
+ sub hyperlink {
+ my ($self, $link) = @_;
+
+ if ($link && $link->type eq 'pod') {
+ my $page = $link->page;
+ my $node = $link->node;
+
+ # If the hyperlink is to an interior node of another page, save it
+ # so that we can see if we need to parse normally skipped files.
+ $has_referred_to_node{$page} = 1 if $node;
# Ignore certain placeholder links in perldelta. Check if the
# link is page-level, and also check if to a node within the page
- if ($self->name && $self->name eq "perldelta"
- && ((grep { $page eq $_ } @perldelta_ignore_links)
- || ($node
+ if ( $self->name && $self->name eq "perldelta"
+ && (( grep { $page eq $_ } @perldelta_ignore_links)
+ || ( $node
&& (grep { "$page/$node" eq $_ } @perldelta_ignore_links)
))) {
return;
}
}
- return $self->SUPER::hyperlink($_[0]);
+
+ return $self->SUPER::hyperlink($link);
}
sub node {
# ignores 2nd param, which is output file. Always uses undef
if (open my $in_fh, '<:bytes', $filename) {
- $self->SUPER::parse_from_filehandle($in_fh, undef);
+ $self->SUPER::parse_from_file($in_fh, undef);
close $in_fh;
return 1;
}
sub extract_pod { # Extracts just the pod from a file; returns undef if file
# doesn't exist
my $filename = shift;
+ use Pod::Parser;
my @pod;
if (! $has_input_files) {
foreach my $filename (@files) {
next if $filename_to_checker{$filename}->get_skip;
+
my $checker = $filename_to_checker{$filename};
- foreach my $link ($checker->hyperlink) {
- my $linked_to_page = $link->[1]->page;
+ foreach my $link ($checker->hyperlinks()) {
+ my $linked_to_page = $link->page;
next unless $linked_to_page; # intra-file checks are handled by std
# Pod::Checker
+ # Currently, we assume all external links are valid
+ next if $link->type eq 'url';
# Initialize the potential message.
my %problem = ( -msg => $broken_link,
- -line => $link->[0],
+ -line => $link->line,
parameter => "to \"$linked_to_page\"",
);
# See if we have found the linked-to_file in our parse
if (exists $nodes{$linked_to_page}) {
- my $node = $link->[1]->node;
+ my $node = $link->node;
# If link is only to the page-level, already have it
next if ! $node;
}
} # Linked-to-file not in parse; maybe is in exception list
- elsif (! exists $valid_modules{$link->[1]->page}) {
+ elsif (! exists $valid_modules{$link->page}) {
# Here, is a link to a target that we can't find. Check if
# there is an internal link on the page with the target name.
chdir $original_dir || die "Can't change directories to $original_dir";
close_and_rename($copy_fh);
}
+
+1;
.{1}?? - c - Nested quantifiers
.{1}?+ - c - Nested quantifiers
(?:.||)(?|)000000000@ 000000000@ y $& 000000000@ # [perl #126405]
+aa$|a(?R)a|a aaa y $& aaa # [perl 128420] recursive matches
+(?:\1|a)([bcd])\1(?:(?R)|e)\1 abbaccaddedcb y $& abbaccaddedcb # [perl 128420] recursive match with backreferences
# Keep these lines at the end of the file
# vim: softtabstop=0 noexpandtab
'/(?[\ |!])/' => '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/',
+ '/\w{/' => 'Unescaped left brace in regex is illegal here {#} m/\w{{#}/',
+ '/\q{/' => 'Unescaped left brace in regex is illegal here {#} m/\q{{#}/',
+ '/\A{/' => 'Unescaped left brace in regex is illegal here {#} m/\A{{#}/',
+ '/:{4,a}/' => 'Unescaped left brace in regex is illegal here {#} m/:{{#}4,a}/',
+ '/xa{3\,4}y/' => 'Unescaped left brace in regex is illegal here {#} 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/',
);
my @deprecated = (
+ '/^{/' => "",
+ '/foo|{/' => "",
+ '/foo|^{/' => "",
+ '/foo({bar)/' => "",
+ '/foo(:?{bar)/' => "",
+ '/\s*{/' => "",
+ '/a{3,4}{/' => "",
+ '/.{/' => 'Unescaped left brace in regex is deprecated here, passed through {#} m/.{{#}/',
+ '/[x]{/' => 'Unescaped left brace in regex is deprecated here, passed through {#} m/[x]{{#}/',
+ '/\p{Latin}{/' => 'Unescaped left brace in regex is deprecated here, passed through {#} m/\p{Latin}{{#}/',
);
for my $strict ("", "use re 'strict';") {
--- /dev/null
+#!./perl -w
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+ skip_all_if_miniperl();
+}
+
+use Config;
+
+my $perlio_log = "perlio$$.txt";
+
+skip_all "DEBUGGING build required"
+ unless $::Config{ccflags} =~ /DEBUGGING/
+ or $^O eq 'VMS' && $::Config{usedebugging_perl} eq 'Y';
+
+plan tests => 8;
+
+END {
+ unlink $perlio_log;
+}
+{
+ unlink $perlio_log;
+ local $ENV{PERLIO_DEBUG} = $perlio_log;
+ fresh_perl_is("print qq(hello\n)", "hello\n",
+ { stderr => 1 },
+ "No perlio debug file without -Di...");
+ ok(!-e $perlio_log, "...no perlio.txt found");
+ fresh_perl_is("print qq(hello\n)", "\nEXECUTING...\n\nhello\n",
+ { stderr => 1, switches => [ "-Di" ] },
+ "Perlio debug file with both -Di and PERLIO_DEBUG...");
+ ok(-e $perlio_log, "... perlio debugging file found with -Di and PERLIO_DEBUG");
+
+ unlink $perlio_log;
+ fresh_perl_like("print qq(hello\n)", qr/define raw/,
+ { stderr => 1, switches => [ "-TDi" ] },
+ "Perlio debug output to stderr with -TDi (with PERLIO_DEBUG)...");
+ ok(!-e $perlio_log, "...no perlio debugging file found");
+}
+
+{
+ local $ENV{PERLIO_DEBUG};
+ fresh_perl_like("print qq(hello)", qr/define raw/,
+ { stderr => 1, switches => [ '-Di' ] },
+ "-Di defaults to stderr");
+ fresh_perl_like("print qq(hello)", qr/define raw/,
+ { stderr => 1, switches => [ '-TDi' ] },
+ "Perlio debug output to STDERR with -TDi (no PERLIO_DEBUG)");
+}
+
start = skipspace(start);
s = start;
if (isIDFIRST_lazy_if(s,UTF)
- || (allow_pack && *s == ':') )
+ || (allow_pack && *s == ':' && s[1] == ':') )
{
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
if (check_keyword) {
};
#endif
-#define word_takes_any_delimeter(p,l) S_word_takes_any_delimeter(p,l)
+#define word_takes_any_delimiter(p,l) S_word_takes_any_delimiter(p,l)
STATIC bool
-S_word_takes_any_delimeter(char *p, STRLEN len)
+S_word_takes_any_delimiter(char *p, STRLEN len)
{
return (len == 1 && strchr("msyq", p[0]))
|| (len == 2
pl_yylval.ival = OPpSLICEWARNING;
}
+#define lex_token_boundary() S_lex_token_boundary(aTHX)
+static void
+S_lex_token_boundary(pTHX)
+{
+ PL_oldoldbufptr = PL_oldbufptr;
+ PL_oldbufptr = PL_bufptr;
+}
+
+#define vcs_conflict_marker(s) S_vcs_conflict_marker(aTHX_ s)
+static char *
+S_vcs_conflict_marker(pTHX_ char *s)
+{
+ lex_token_boundary();
+ PL_bufptr = s;
+ yyerror("Version control conflict marker");
+ while (s < PL_bufend && *s != '\n')
+ s++;
+ return s;
+}
+
/*
yylex
The type of the next token
Structure:
+ Check if we have already built the token; if so, use it.
Switch based on the current state:
- - if we already built the token before, use it
- if we have a case modifier in a string, deal with that
- handle other cases of interpolation inside a string
- scan the next line if we are inside a format
- In the normal state switch on the next character:
+ In the normal state, switch on the next character:
- default:
if alphabetic, go to key lookup
- unrecoginized character - croak
+ unrecognized character - croak
- 0/4/26: handle end-of-line or EOF
- cases for whitespace
- \n and #: handle comments and line numbers
{
const char tmp = *s++;
if (tmp == '=') {
+ if ((s == PL_linestart+2 || s[-3] == '\n') && strnEQ(s, "=====", 5)) {
+ s = vcs_conflict_marker(s + 5);
+ goto retry;
+ }
if (!PL_lex_allbrackets
&& PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
{
if (PL_expect != XOPERATOR) {
if (s[1] != '<' && !strchr(s,'>'))
check_uni();
- if (s[1] == '<' && s[2] != '>')
+ if (s[1] == '<' && s[2] != '>') {
+ if ((s == PL_linestart || s[-1] == '\n') && strnEQ(s+2, "<<<<<", 5)) {
+ s = vcs_conflict_marker(s + 7);
+ goto retry;
+ }
s = scan_heredoc(s);
+ }
else
s = scan_inputsymbol(s);
PL_expect = XOPERATOR;
{
char tmp = *s++;
if (tmp == '<') {
+ if ((s == PL_linestart+2 || s[-3] == '\n') && strnEQ(s, "<<<<<", 5)) {
+ s = vcs_conflict_marker(s + 5);
+ goto retry;
+ }
if (*s == '=' && !PL_lex_allbrackets
&& PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
{
{
const char tmp = *s++;
if (tmp == '>') {
+ if ((s == PL_linestart+2 || s[-3] == '\n') && strnEQ(s, ">>>>>", 5)) {
+ s = vcs_conflict_marker(s + 5);
+ goto retry;
+ }
if (*s == '=' && !PL_lex_allbrackets
&& PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
{
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
/* Some keywords can be followed by any delimiter, including ':' */
- anydelim = word_takes_any_delimeter(PL_tokenbuf, len);
+ anydelim = word_takes_any_delimiter(PL_tokenbuf, len);
/* x::* is just a word, unless x is "CORE" */
if (!anydelim && *s == ':' && s[1] == ':') {
UNI(OP_LCFIRST);
case KEY_local:
- pl_yylval.ival = 0;
OPERATOR(LOCAL);
case KEY_length:
case KEY_my:
case KEY_state:
if (PL_in_my) {
+ PL_bufptr = s;
yyerror(Perl_form(aTHX_
"Can't redeclare \"%s\" in \"%s\"",
tmp == KEY_my ? "my" :
if (isIDFIRST_lazy_if(s,UTF)) {
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
- {
- if (!FEATURE_LEXSUBS_IS_ENABLED)
- Perl_croak(aTHX_
- "Experimental \"%s\" subs not enabled",
- tmp == KEY_my ? "my" :
- tmp == KEY_state ? "state" : "our");
- Perl_ck_warner_d(aTHX_
- packWARN(WARN_EXPERIMENTAL__LEXICAL_SUBS),
- "The lexical_subs feature is experimental");
goto really_sub;
- }
PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
if (!PL_in_my_stash) {
char tmpbuf[1024];
yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
}
}
- pl_yylval.ival = 1;
OPERATOR(MY);
case KEY_next:
if (!isIDFIRST_lazy_if(s, UTF))
goto no_label;
t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen);
- if (word_takes_any_delimeter(s, wlen))
+ if (word_takes_any_delimiter(s, wlen))
goto no_label;
bufptr_pos = s - SvPVX(PL_linestr);
PL_bufptr = t;
return stmtseqop;
}
-#define lex_token_boundary() S_lex_token_boundary(aTHX)
-static void
-S_lex_token_boundary(pTHX)
-{
- PL_oldoldbufptr = PL_oldbufptr;
- PL_oldbufptr = PL_bufptr;
-}
-
#define parse_opt_lexvar() S_parse_opt_lexvar(aTHX)
static OP *
S_parse_opt_lexvar(pTHX)
/*#define HAS_GETLOGIN / **/
/* HAS_GETPGID:
- * This symbol, if defined, indicates to the C program that
+ * This symbol, if defined, indicates to the C program that
* the getpgid(pid) function is available to get the
* process group id.
*/
* This symbol holds the type used for the second argument to
* getgroups() and setgroups(). Usually, this is the same as
* gidtype (gid_t) , but sometimes it isn't.
- * It can be int, ushort, gid_t, etc...
- * It may be necessary to include <sys/types.h> to get any
+ * It can be int, ushort, gid_t, etc...
+ * It may be necessary to include <sys/types.h> to get any
* typedef'ed information. This is only required if you have
* getgroups() or setgroups()..
*/
* This symbol, if defined, indicates that the uselocale routine is
* available to set the current locale for the calling thread.
*/
+/* HAS_QUERYLOCALE:
+ * This symbol, if defined, indicates that the querylocale routine is
+ * available to return the name of the locale for a category mask.
+ */
/*#define HAS_NEWLOCALE / **/
/*#define HAS_FREELOCALE / **/
/*#define HAS_USELOCALE / **/
+/*#define HAS_QUERYLOCALE / **/
/* HAS_NEXTAFTER:
* This symbol, if defined, indicates that the nextafter routine is
*/
/*#define HAS_FSTATVFS / **/
+/* HAS_STRERROR_L:
+ * This symbol, if defined, indicates that the strerror_l routine is
+ * available to return the error message for a given errno value in
+ * a particular locale (identified by a locale_t object).
+ */
+/*#define HAS_STRERROR_L / **/
+
/* HAS_STRFTIME:
* This symbol, if defined, indicates that the strftime routine is
* available to do time formatting.
#endif
/* Generated from:
- * ce61c4f18e82f6356cdae44c5336ceac1d3253033d7449651927f5633be5c3c2 config_h.SH
- * f28cf0c2509cffce1f29866cccd109cee84c941fc63685f0795d25380d47382d uconfig.sh
+ * c14530f7567d861ce42d42446fc2ee9cd3625763f65867d5f42849c337bbc361 config_h.SH
+ * 3b14c76342a834042da506e8c3b4269f7d545453079733cb740970ab9cc4294e uconfig.sh
* ex: set ro: */
d_pwquota='undef'
d_qgcvt='undef'
d_quad='undef'
+d_querylocale='undef'
d_random_r='undef'
d_readdir64_r='undef'
d_readdir='define'
d_strctcpy='undef'
d_strerrm='strerror(e)'
d_strerror='undef'
+d_strerror_l='undef'
d_strerror_r='undef'
d_strftime='undef'
d_strlcat='undef'
d_pwquota='undef'
d_qgcvt='undef'
d_quad='define'
+d_querylocale='undef'
d_random_r='undef'
d_readdir64_r='undef'
d_readdir='define'
d_strctcpy='undef'
d_strerrm='strerror(e)'
d_strerror='undef'
+d_strerror_l='undef'
d_strerror_r='undef'
d_strftime='undef'
d_strlcat='undef'
extra.pods : miniperl
@ @extra_pods.com
-PERLDELTA_CURRENT = [.pod]perl5251delta.pod
+PERLDELTA_CURRENT = [.pod]perl5252delta.pod
$(PERLDELTA_CURRENT) : [.pod]perldelta.pod
Copy/NoConfirm/Log $(MMS$SOURCE) $(PERLDELTA_CURRENT)
$! # This script is designed to provide a handy summary of the configuration
$! # information being used to build perl. This is especially useful if you
-$! # are requesting help from comp.lang.perl.misc on usenet or via mail.
+$! # are requesting help online or via email.
$! DCL-ified by Peter Prymmer <pvhp@lns62.lns.cornell.edu> 22-DEC-1995
$! DCL usage (choose one):
# versioned installation can be obtained by setting INST_TOP above to a
# path that includes an arbitrary version string.
#
-#INST_VER := \5.25.1
+#INST_VER := \5.25.2
#
# 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\perl5251delta.pod
+ copy ..\pod\perldelta.pod ..\pod\perl5252delta.pod
$(MINIPERL) -I..\lib $(PL2BAT) $(UTILS)
$(MINIPERL) -I..\lib ..\autodoc.pl ..
$(MINIPERL) -I..\lib ..\pod\perlmodlib.PL -q ..
-if exist $(LIBDIR)\Win32API rmdir /s /q $(LIBDIR)\Win32API
-if exist $(LIBDIR)\XS rmdir /s /q $(LIBDIR)\XS
-cd $(PODDIR) && del /f *.html *.bat roffitall \
- perl5251delta.pod perlaix.pod perlamiga.pod perlandroid.pod \
+ perl5252delta.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.1
+#INST_VER = \5.25.2
#
# 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\perl5251delta.pod
+ copy ..\pod\perldelta.pod ..\pod\perl5252delta.pod
cd ..\win32
$(PERLEXE) $(PL2BAT) $(UTILS)
$(MINIPERL) -I..\lib ..\autodoc.pl ..
-if exist $(LIBDIR)\Win32API rmdir /s /q $(LIBDIR)\Win32API
-if exist $(LIBDIR)\XS rmdir /s /q $(LIBDIR)\XS
-cd $(PODDIR) && del /f *.html *.bat roffitall \
- perl5251delta.pod perlaix.pod perlamiga.pod perlandroid.pod \
+ perl5252delta.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 \
d_pwquota='undef'
d_qgcvt='undef'
d_quad='undef'
+d_querylocale='undef'
d_random_r='undef'
d_readdir64_r='undef'
d_readdir='define'
d_strctcpy='define'
d_strerrm='strerror(e)'
d_strerror='define'
+d_strerror_l='undef'
d_strerror_r='undef'
d_strftime='undef'
d_strlcat='undef'
d_pwquota='undef'
d_qgcvt='undef'
d_quad='define'
+d_querylocale='undef'
d_random_r='undef'
d_readdir64_r='undef'
d_readdir='define'
d_strctcpy='define'
d_strerrm='strerror(e)'
d_strerror='define'
+d_strerror_l='undef'
d_strerror_r='undef'
d_strftime='define'
d_strlcat='undef'
d_pwquota='undef'
d_qgcvt='undef'
d_quad='define'
+d_querylocale='undef'
d_random_r='undef'
d_readdir64_r='undef'
d_readdir='define'
d_strctcpy='define'
d_strerrm='strerror(e)'
d_strerror='define'
+d_strerror_l='undef'
d_strerror_r='undef'
d_strftime='define'
d_strlcat='undef'
# versioned installation can be obtained by setting INST_TOP above to a
# path that includes an arbitrary version string.
#
-#INST_VER *= \5.25.1
+#INST_VER *= \5.25.2
#
# 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\perl5251delta.pod
+ copy ..\pod\perldelta.pod ..\pod\perl5252delta.pod
$(MINIPERL) -I..\lib $(PL2BAT) $(UTILS)
$(MINIPERL) -I..\lib ..\autodoc.pl ..
$(MINIPERL) -I..\lib ..\pod\perlmodlib.PL -q ..
-if exist $(LIBDIR)\Win32API rmdir /s /q $(LIBDIR)\Win32API
-if exist $(LIBDIR)\XS rmdir /s /q $(LIBDIR)\XS
-cd $(PODDIR) && del /f *.html *.bat roffitall \
- perl5251delta.pod perlaix.pod perlamiga.pod perlandroid.pod \
+ perl5252delta.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 \
perl5240delta.pod \
perl5250delta.pod \
perl5251delta.pod \
+ perl5252delta.pod \
perl561delta.pod \
perl56delta.pod \
perl581delta.pod \
perl5240delta.man \
perl5250delta.man \
perl5251delta.man \
+ perl5252delta.man \
perl561delta.man \
perl56delta.man \
perl581delta.man \
perl5240delta.html \
perl5250delta.html \
perl5251delta.html \
+ perl5252delta.html \
perl561delta.html \
perl56delta.html \
perl581delta.html \
perl5240delta.tex \
perl5250delta.tex \
perl5251delta.tex \
+ perl5252delta.tex \
perl561delta.tex \
perl56delta.tex \
perl581delta.tex \
void VDir::FromEnvA(char *pEnv, int index)
{ /* gets the directory for index from the environment variable. */
while (*pEnv != '\0') {
- if ((pEnv[0] == '=') && (DriveIndex(pEnv[1]) == index)) {
+ if ((pEnv[0] == '=') && (DriveIndex(pEnv[1]) == index)
+ && pEnv[2] == ':' && pEnv[3] == '=') {
SetDirA(&pEnv[4], index);
break;
}
void VDir::FromEnvW(WCHAR *pEnv, int index)
{ /* gets the directory for index from the environment variable. */
while (*pEnv != '\0') {
- if ((pEnv[0] == '=') && (DriveIndex((char)pEnv[1]) == index)) {
+ if ((pEnv[0] == '=') && (DriveIndex((char)pEnv[1]) == index)
+ && pEnv[2] == ':' && pEnv[3] == '=') {
SetDirW(&pEnv[4], index);
break;
}
projects / platform / upstream / perl.git / commitdiff